diff --git a/lib/dmustache/README.md b/lib/dmustache/README.md deleted file mode 100644 index c83670d3..00000000 --- a/lib/dmustache/README.md +++ /dev/null @@ -1,201 +0,0 @@ -`SynMustache` is a Delphi/FPC implementation of the [Mustache template language](http://mustache.github.io/). - - -Presentation -============ - - * SynMustache is the first Delphi implementation of Mustache, supporting Delphi 6 up to latest Delphi, and FPC/Lazarus; - * It has a separate parser and renderer (so you can compile your templates ahead of time); - * The parser features a shared cache of compiled templates; - * It [passes all official Mustache specification tests](https://github.com/mustache/spec) - including all weird whitespace process; - * External partials can be supplied as `TSynMustachePartials` dictionaries; - * `{{.}}`, `{{-index}}` and `{{"some text}}` pseudo-variables were added to the standard Mustache syntax; - * `{{#-first}}`, `{{#-last}}` and `{{#-odd}}` pseudo-sections were added to the standard Mustache syntax; - * `{{helperName value}}` *Expression Helpers* were added to the standard Mustache syntax; - * `{{if value<=>value}}` *Expression Helper* for conditional sections; - * Internal partials can be defined via `{{partial}}'#$A'3'); - html := mustache.RenderJSON('{}',TSynMustachePartials.CreateOwned(['partial','1'#$A'2'])); - // now html='1'#$A'23','external partials' - -Here `TSynMustachePartials.CreateOwned()` expects the partials to be supplied as name/value pairs. - -Internal partials (one of the SynMustache extensions), can be defined directly in the main template: - - mustache := TSynMustache.Parse('{{partial}}4'); - html := mustache.RenderJSON('{name:3}'); - // now html='1'#$A'234','internal partials' - -Internationalization --------------------- - -You can define `{{"some text}}` pseudo-variables in your templates, which text will be supplied to a callback, ready to be transformed on the fly: it may be convenient for i18n of web applications. - -By default, the text will be written directly to the output buffer, but you can define a callback which may be used e.g. for text translation: - - procedure TTestLowLevelTypes.MustacheTranslate(var English: string); - begin - if English='Hello' then - English := 'Bonjour' else - if English='You have just won' then - English := 'Vous venez de gagner'; - end; - -Of course, in a real application, you may assign one `TLanguageFile.Translate(var English: string)` method, as defined in the `mORMoti18n.pas` unit. - -Then, you will be able to define your template as such: - - mustache := TSynMustache.Parse( - '{{"Hello}} {{name}}'#13#10'{{"You have just won}} {{value}} {{"dollars}}!'); - html := mustache.RenderJSON('{name:?,value:?}',[],['Chris',10000],nil,MustacheTranslate); - // now html='Bonjour Chris'#$D#$A'Vous venez de gagner 10000 dollars!' - -All text has indeed been translated as expected. - - -Some Links -========== - -We wrote a series of blog articles, about Mustache in general, and `SynMustache` unit in particular: - - * [Mustache Logic-less templates for Delphi - part 1: general presentation of Mustache](https://blog.synopse.info/?post/2014/04/28/Mustache-Logic-less-templates-for-Delphi-part-1); - * [Mustache Logic-less templates for Delphi - part 2: the Mustache syntax](https://blog.synopse.info/?post/2014/04/28/Mustache-Logic-less-templates-for-Delphi-part-2); - * [Mustache Logic-less templates for Delphi - part 3: SynMustache implementation](https://blog.synopse.info/?post/2014/04/28/Mustache-Logic-less-templates-for-Delphi-part-3). - -You can use also [Synopse forums](http://synopse.info/forum/viewtopic.php?id=1720) to obtain direct support from the developpers, or send your feedback. - -The documentation is [available as a single pdf file](http://blog.synopse.info/public/Documents/SynMustache.pdf), if needed. Note that this `pdf` can be outdated, so you should better consult the "Mustache" part of the *mORMot* SAD pdf, which should be more accurate. - - -*The Synopse team* diff --git a/lib/dmustache/ReadMe.txt b/lib/dmustache/ReadMe.txt deleted file mode 100644 index f7792d1b..00000000 --- a/lib/dmustache/ReadMe.txt +++ /dev/null @@ -1,282 +0,0 @@ - - Synopse mORMot framework - -An Open Source Client-Server ORM/SOA framework - (c) 2008-2021 Synopse Informatique - https://synopse.info - http://mormot.net - -Contributors - Alan Chate - Alexander (sha) - Alexander (volax) - AlexPirate - Alfred Glaenzer (alf) - Andre Heider (dhewg) - Antoine Simard (AntoineGS) - Arnaud Bouchez - ASiwon - Aweste - Bas Schouten - BigStar - BugsDigger - Cheemeng - CoMPi - Damien (ddemars) - Darian Miller - Daniel Kuettner - David Mead (MDW) - Delphinium (louisyeow) - DigDiver - Dominikcz - EgorovAlex - Emanuele (lele9) - Eric Grange - Esmond - Esteban Martin (EMartin) - Eugene Ilyin - Eva Freimann (EVaF) - F-Vicente - Goran Despalatovic (gigo) - Jean-Baptiste Roussia (jbroussia) - Joe (jokusoft) - Johan Bontes - Jordi Tudela - Kevin Chen - Lagodny - Leon Oosthuizen - Macc2010 - Maciej Izak (hnb) - Marcos Douglas B. Santos (mdbs99) - Mario Moretti - Marius Maximus (mariuszekpl) - Martin Eckes - Martin Suer - Mapes - Matkov - Maxim Masiutin - Mazinsw - MChaos - Miab3 - Michael (EgonHugeist) - Michalis Kamburelis - MilesYou - Mingda - Mr Yang (ysair) - Nicolas Marchand (MC) - Nortg - Nzsolt - Oleg Tretyakov - Ondrej (reddwarf) - Pavel Mashlyakovskii (mpv) - Pierre le Riche - RalfS - Richard6688 - Sabbiolina - Sanyin - Sinisa (sinisav) - Sllimr7139 - SSoftPro - Stefan (itSDS) - Svetozar Belic (transmogrifix) - Transmogrifix - Uian2000 - Vaclav - Vadim Orel - Willo vd Merwe - Win2014 - Wloochacz - Wolfgang Ehrhardt - Yoanq - Ysair - Zed - -[See below if you upgrade from 1.17 revision] - - -Synopse mORMot is an Open Source Client-Server ORM SOA MVC framework -for Delphi 6 up to Delphi 10.3 Rio and FPC, targeting Windows/Linux -for servers, and any platform for clients (including mobile or AJAX). - -The main features of mORMot are therefore: - - - ORM/ODM: objects persistence on almost any database (SQL or NoSQL); - - SOA: organize your business logic into REST services; - - Clients: consume your data or services from any platform, via ORM/SOA APIs; - - Web MVC: publish your ORM/SOA process as responsive Web Applications. - -With local or remote access, via an auto-configuring Client-Server REST design. - -Due to its modular design, switch from a Client-Server architecture over -HTTP, named pipes or GDI messages into a stand-alone application is just -a matter of mORMot classes initialization. -For instance, the very same executable can even be running stand-alone, -as a server, as a service, or a client, depending on some run-time parameters! - -Emphasizing simplicity, speed and versatility, mORMot is a incredibly well -documented Open Source project easy enough to add basic ORM or Client-Server -features to simple applications for hobbyists, or let experienced users -develop scaling and strong service-based projects for their customers, with -the advantages of native code and easy-to-deploy solutions, reducing -deployment cost and increasing ROI. - -It provides an Open Source self-sufficient set of units (even Delphi starter -edition is enough) for creating any application, from a stand-alone solution -up to the most complex Domain-Driven Design (DDD): - - - Presentation layer featuring MVC UI generation with i18n and reporting - (with pdf export) for rich Delphi clients, MVC web clients (with logic-less - Mustache templates) or rich AJAX clients (via native JSON/REST access); - - - Application layer implementing Service Oriented Architecture via - interface-based services (like WCF) and Client-Server ORM (including - method-based services) - following a RESTful model using JSON over several - communication protocols (e.g. HTTP/1.1); - - - Domain Model layer handling all the needed business logic in plain Delphi - objects, including high-level managed types like dynamic arrays or records - for Value Objects, dedicated classes for Entities or Aggregates, and variant - storage with late-binding for dynamic documents; - - - Data persistence infrastructure layer with ORM operations on direct - Oracle, MS SQL, OleDB, ODBC, ZEOS/ZDBC access or any TDataSet provider (e.g. - FireDAC/AnyDAC, UniDAC, NexusDB, BDE...), with a powerful SQLite3 kernel, - and optional SQL access if needed, with amazing performance and advanced - features like Array DML, auto-generating SQL for SQLite3, Oracle, - Jet/MSAccess, MS SQL, Firebird, DB2, PostgreSQL, MySQL and NexusDB - and - alternative high-speed MongoDB NoSQL database access for ODM persistence; - - - Cross-Cutting infrastructure layers for handling data filtering and - validation, security (e.g. Windows authentication or any custom model), - caching, logging and testing (framework uses test-driven approach and - features interface stubbing and mocking). - -With mORMot, ORM/ODM is not used only for data persistence of objects (like -in other implementations), but as part of a global n-Tier, Service Oriented -Architecture (SOA), ready to implement Domain-Driven solutions. This -framework is not an ORM on which a transmission layer has been added, like -almost everything existing in Delphi, C# or Java: this is a full Client-Server -ORM/SOA from the ground up. -This really makes the difference. - -The business logic of your applications will be easily exposed as Services, -and will be accessible from light clients (written in Delphi or any other -mean, including AJAX). -The SpiderMonkey JavaScript engine has been integrated on the server side -and can be used to define business rules or any process (including MVC web -rendering) - just like node.js, but with a multi-threaded core, and the -full power of our optimized Delphi libraries at hand. - -The framework Core is non-visual: you will get everything you need in a -consistent set of classes to be used from code. In order to let you focus -on your business, using mORMot's KISS/DRY/SOC/YAGNI/TDD and Convention Over -Configuration patterns. But you have also some UI units available (including -screen auto-generation, reporting and ribbon GUI), and you can use it from -any RAD, web, or AJAX clients (via JavaScript or Smart Mobile Studio). - -No dependency is needed on the client side (no DB driver, or third-party -runtime): it is able to connect via standard HTTP, even through a corporate -proxy or a VPN. Rich Delphi clients can be deployed just by copying and running -a stand-alone small executable, with no installation process. Stream can be -encrypted via HTTS or with proven SHA/AES-256. Endpoints are configured -automatically for each published interface on both server and client sides, -and creating a load-balancing proxy is a matter of one method call. -Speed and scalability has been implemented from the ground up: a genuine -optimized multi-threaded core let a single server handle more than 50,000 -concurrent clients, faster than DataSnap, WCF or node.js, and our rich SOA -design is able to implement both vertical and horizontal scalable hosting, -using recognized enterprise-level SQL or NoSQL databases for storage. - -Even if mORMot will be more easily used in a project designed from scratch, -it fits very well the purpose of evolving any existing Delphi project, or -creating the server side part of an AJAX application. - -Licensed under a disjunctive tri-license giving you the choice of one of -the three following sets of free software/open source licensing terms: - - Mozilla Public License, version 1.1 or later; - - GNU General Public License, version 2.0 or later; - - GNU Lesser General Public License, version 2.1 or later. -This allows the use of our code in as wide a variety of software projects -as possible, while still maintaining copy-left on code we wrote. - -Main project page: -http://mORMot.net - -Documentation: -https://synopse.info/files/html/Synopse%20mORMot%20Framework%20SAD%201.18.html - -Installation: -https://synopse.info/files/html/Synopse%20mORMot%20Framework%20SAD%201.18.html#TITL_113 - -FAQ: -https://synopse.info/files/html/Synopse%20mORMot%20Framework%20SAD%201.18.html#TITL_123 - -How to get the source: -https://synopse.info/fossil/wiki?name=Get+the+source - -A forum is dedicated to support: -https://synopse.info - -A blog is available: -http://blog.synopse.info - -Issues and feature requests can be posted (take a look at the forums -and latest unstable version first!): -https://synopse.info/fossil/reportlist - -You can also monitor/fork our projects on GitHub: -https://github.com/synopse/mORMot - -You may also install it as a Delphinus package: Delphinus-Support - -Don't forget to download the documentation (available online or as pdf files, -created by our SynProject tool). -In particular, you should take a look at all general introduction chapters -of the SAD document. It will cover all key-concepts and code modelling -used by the framework. -A developer guide is included in this SAD document, in its 2nd part. You'll -get good practice guidance, presentation of the ORM/SOA approach and other -underlying concepts. - -Feel free to contribute by posting enhancements and patches to this -quickly evolving project. - -Enjoy! - - -Some units (e.g. SynPdf, SynGdiPlus, SynBigTable, SynCommons, SynCrypto, -SynDB*, SynSQLite3, SynMongoDB, SynMustache, SynSM, mORMotReport) are used -by mORMot, but do not require the whole framework to be linked. -That is, you can use e.g. only PDF generation, SynDB fast database -access, a static-linked SQLite3 engine, direct MongoDB access, Mustache -templates, SpiderMonkey JavaSCript engine, code-generated reports, or -the TDocVariant, TDynArray, TSynLog classes of SynCommons, without using -the main mORMot units and features (ORM, Client-Server, services, UI). - -Some of those units can even be compiled with Delphi 5 (e.g. SynPdf, SynDB). - - -Quick Steps when upgrading from a previous 1.17 revision: - -1) Note that some units where renamed, and some breaking changes introduced - by some enhanced features, therefore a direct update is not possible - -2) Erase or rename your whole previous #\Lib directory - -3) Download latest 1.18 revision files as stated just above - -4) Change your references to mORMot units: - - Add in your uses clause SynLog.pas and/or SynTests.pas if needed; - - Rename in your uses clause any SQLite3Commons reference into mORmot; - - Rename in your uses clause any SQLite3 reference into mORMotSQLite3; - - Rename in your uses clause any other SQlite3* reference into mORMot*; - - Add in one uses clause a link to SynSQLite3Static (for Win32). - -5) Consult the units headers about 1.18 for breaking changes, mainly: - - TSQLRecord.ID: TID primary key, TIDDynArray, and TRecordReference are now Int64; - - Renamed Iso8601 low-level structure as TTimeLogBits; - - TJSONSerializerCustomReader/Writer callbacks changed; - - TSQLRestServerCallBackParams replaced by TSQLRestServerURIContext class; - - TSQLRestServerStatic* classes renamed as TSQLRestStorage*; - - rmJSON* enums replaced by TSQLRestRoutingREST/JSON_RPC classes; - - Changed '¤' into '~' character for mORMoti18n language files. diff --git a/lib/dmustache/SynCommons.pas b/lib/dmustache/SynCommons.pas deleted file mode 100644 index 6c16dc26..00000000 --- a/lib/dmustache/SynCommons.pas +++ /dev/null @@ -1,63348 +0,0 @@ -/// common functions used by most Synopse projects -// - this unit is a part of the freeware Synopse mORMot framework, -// licensed under a MPL/GPL/LGPL tri-license; version 1.18 -unit SynCommons; - -(* - This file is part of Synopse framework. - - Synopse framework. Copyright (C) 2022 Arnaud Bouchez - Synopse Informatique - https://synopse.info - - *** BEGIN LICENSE BLOCK ***** - Version: MPL 1.1/GPL 2.0/LGPL 2.1 - - The contents of this file are subject to the Mozilla Public License Version - 1.1 (the "License"); you may not use this file except in compliance with - the License. You may obtain a copy of the License at - http://www.mozilla.org/MPL - - Software distributed under the License is distributed on an "AS IS" basis, - WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License - for the specific language governing rights and limitations under the License. - - The Original Code is Synopse framework. - - The Initial Developer of the Original Code is Arnaud Bouchez. - - Portions created by the Initial Developer are Copyright (C) 2022 - the Initial Developer. All Rights Reserved. - - Contributor(s): - - Alan Chate - - Aleksandr (sha) - - Alfred Glaenzer (alf) - - ASiwon - - Chaa - - BigStar - - Eugene Ilyin - - f-vicente - - itSDS - - Johan Bontes - - kevinday - - Kevin Chen - - Maciej Izak (hnb) - - Marius Maximus (mariuszekpl) - - mazinsw - - mingda - - PBa - - RalfS - - Sanyin - - Pavel Mashlyakovskii (mpv) - - Wloochacz - - zed - - Alternatively, the contents of this file may be used under the terms of - either the GNU General Public License Version 2 or later (the "GPL"), or - the GNU Lesser General Public License Version 2.1 or later (the "LGPL"), - in which case the provisions of the GPL or the LGPL are applicable instead - of those above. If you wish to allow use of your version of this file only - under the terms of either the GPL or the LGPL, and not to allow others to - use your version of this file under the terms of the MPL, indicate your - decision by deleting the provisions above and replace them with the notice - and other provisions required by the GPL or the LGPL. If you do not delete - the provisions above, a recipient may use your version of this file under - the terms of any one of the MPL, the GPL or the LGPL. - - ***** END LICENSE BLOCK ***** - -*) - - -{$I Synopse.inc} // define HASINLINE CPU32 CPU64 OWNNORMTOUPPER - -interface - -uses -{$ifdef MSWINDOWS} - Windows, - Messages, -{$else MSWINDOWS} - {$ifdef KYLIX3} - Types, - LibC, - SynKylix, - {$endif KYLIX3} - {$ifdef FPC} - BaseUnix, - {$endif FPC} -{$endif MSWINDOWS} - Classes, -{$ifndef LVCL} - SyncObjs, // for TEvent and TCriticalSection - Contnrs, // for TObjectList - {$ifdef HASINLINE} - Types, - {$endif HASINLINE} -{$endif LVCL} -{$ifndef NOVARIANTS} - Variants, -{$endif NOVARIANTS} - SynLZ, // needed for TSynMapFile .mab format - SysUtils; - - -const - /// the corresponding version of the freeware Synopse framework - // - includes a commit increasing number (generated by SourceCodeRep tool) - // - a similar constant shall be defined in SynCrtSock.pas - SYNOPSE_FRAMEWORK_VERSION = {$I SynopseCommit.inc}; - - /// a text including the version and the main active conditional options - // - usefull for low-level debugging purpose - SYNOPSE_FRAMEWORK_FULLVERSION = SYNOPSE_FRAMEWORK_VERSION - {$ifdef FPC} - {$ifdef FPC_X64MM}+' x64MM'{$ifdef FPCMM_BOOST}+'b'{$endif} - {$ifdef FPCMM_SERVER}+'s'{$endif}{$else} - {$ifdef FPC_FASTMM4}+' FMM4'{$else} - {$ifdef FPC_SYNTBB}+' TBB'{$else} - {$ifdef FPC_SYNJEMALLOC}+' JM'{$else} - {$ifdef FPC_SYNCMEM}+' CM'{$else} - {$ifdef FPC_CMEM}+' cM'{$endif}{$endif}{$endif}{$endif}{$endif}{$endif} - {$else} - {$ifdef LVCL}+' LVCL'{$else} - {$ifdef ENHANCEDRTL}+' ERTL'{$endif}{$endif} - {$ifdef FullDebugMode}+' FDM'{$endif} - {$endif FPC} - {$ifdef DOPATCHTRTL}+' PRTL'{$endif}; - - -{ ************ common types used for compatibility between compilers and CPU } - -const - /// internal Code Page for UTF-16 Unicode encoding - // - used e.g. for Delphi 2009+ UnicodeString=String type - CP_UTF16 = 1200; - - /// fake code page used to recognize TSQLRawBlob - // - as returned e.g. by TTypeInfo.AnsiStringCodePage from mORMot.pas - CP_SQLRAWBLOB = 65534; - - /// internal Code Page for RawByteString undefined string - CP_RAWBYTESTRING = 65535; - - /// US English Windows Code Page, i.e. WinAnsi standard character encoding - CODEPAGE_US = 1252; - - /// Latin-1 ISO/IEC 8859-1 Code Page - CODEPAGE_LATIN1 = 819; - -{$ifndef MSWINDOWS} - /// internal Code Page for UTF-8 Unicode encoding - CP_UTF8 = 65001; -var - /// contains the curent system code page (default WinAnsi) - GetACP: integer = CODEPAGE_US; -{$endif} - -{$ifdef FPC} { make cross-compiler and cross-CPU types available to Delphi } - -type - PBoolean = ^Boolean; - -{$else FPC} - -type - {$ifdef CPU64} // Delphi XE2 seems stable about those types (not Delphi 2009) - PtrInt = NativeInt; - PtrUInt = NativeUInt; - {$else} - /// a CPU-dependent signed integer type cast of a pointer / register - // - used for 64-bit compatibility, native under Free Pascal Compiler - PtrInt = integer; - /// a CPU-dependent unsigned integer type cast of a pointer / register - // - used for 64-bit compatibility, native under Free Pascal Compiler - PtrUInt = cardinal; - {$endif} - /// a CPU-dependent unsigned integer type cast of a pointer of pointer - // - used for 64-bit compatibility, native under Free Pascal Compiler - PPtrUInt = ^PtrUInt; - /// a CPU-dependent signed integer type cast of a pointer of pointer - // - used for 64-bit compatibility, native under Free Pascal Compiler - PPtrInt = ^PtrInt; - - /// unsigned Int64 doesn't exist under older Delphi, but is defined in FPC - // - and UInt64 is buggy as hell under Delphi 2007 when inlining functions: - // older compilers will fallback to signed Int64 values - // - anyway, consider using SortDynArrayQWord() to compare QWord values - // in a safe and efficient way, under a CPUX86 - // - you may use UInt64 explicitly in your computation (like in SynEcc.pas), - // if you are sure that Delphi 6-2007 compiler handles your code as expected, - // but mORMot code will expect to use QWord for its internal process - // (e.g. ORM/SOA serialization) - {$ifdef UNICODE} - QWord = UInt64; - {$else} - QWord = {$ifndef DELPHI5OROLDER}type{$endif} Int64; - {$endif} - /// points to an unsigned Int64 - PQWord = ^QWord; - - {$ifndef ISDELPHIXE2} - /// used to store the handle of a system Thread - TThreadID = cardinal; - {$endif} - -{$endif FPC} - -{$ifdef DELPHI6OROLDER} - -// some definitions not available prior to Delphi 7 -type - UInt64 = Int64; - -{$endif} - -{$ifdef DELPHI5OROLDER} - // Delphi 5 doesn't have those basic types defined :( -const - varShortInt = $0010; - varInt64 = $0014; { vt_i8 } - soBeginning = soFromBeginning; - soCurrent = soFromCurrent; - reInvalidPtr = 2; - PathDelim = '\'; - sLineBreak = #13#10; - -type - PPointer = ^Pointer; - PPAnsiChar = ^PAnsiChar; - PInteger = ^Integer; - PCardinal = ^Cardinal; - PByte = ^Byte; - PWord = ^Word; - PBoolean = ^Boolean; - PDouble = ^Double; - PComp = ^Comp; - THandle = LongWord; - PVarData = ^TVarData; - TVarData = packed record - // mostly used for varNull, varInt64, varDouble, varString and varAny - VType: word; - case Integer of - 0: (Reserved1: Word; - case Integer of - 0: (Reserved2, Reserved3: Word; - case Integer of - varSmallInt: (VSmallInt: SmallInt); - varInteger: (VInteger: Integer); - varSingle: (VSingle: Single); - varDouble: (VDouble: Double); // DOUBLE - varCurrency: (VCurrency: Currency); - varDate: (VDate: TDateTime); - varOleStr: (VOleStr: PWideChar); - varDispatch: (VDispatch: Pointer); - varError: (VError: HRESULT); - varBoolean: (VBoolean: WordBool); - varUnknown: (VUnknown: Pointer); - varByte: (VByte: Byte); - varInt64: (VInt64: Int64); // INTEGER - varString: (VString: Pointer); // TEXT - varAny: (VAny: Pointer); - varArray: (VArray: PVarArray); - varByRef: (VPointer: Pointer); - ); - 1: (VLongs: array[0..2] of LongInt); ); - end; -{$else} -{$ifndef FPC} -type - // redefined here to not use the wrong definitions from Windows.pas - PWord = System.PWord; - PSingle = System.PSingle; -{$endif FPC} -{$endif DELPHI5OROLDER} - -type - /// RawUnicode is an Unicode String stored in an AnsiString - // - faster than WideString, which are allocated in Global heap (for COM) - // - an AnsiChar(#0) is added at the end, for having a true WideChar(#0) at ending - // - length(RawUnicode) returns memory bytes count: use (length(RawUnicode) shr 1) - // for WideChar count (that's why the definition of this type since Delphi 2009 - // is AnsiString(1200) and not UnicodeString) - // - pointer(RawUnicode) is compatible with Win32 'Wide' API call - // - mimic Delphi 2009 UnicodeString, without the WideString or Ansi conversion overhead - // - all conversion to/from AnsiString or RawUTF8 must be explicit: the - // compiler is not able to make valid implicit conversion on CP_UTF16 - {$ifdef HASCODEPAGE} - RawUnicode = type AnsiString(CP_UTF16); // Codepage for an UnicodeString - {$else} - RawUnicode = type AnsiString; - {$endif} - - /// RawUTF8 is an UTF-8 String stored in an AnsiString - // - use this type instead of System.UTF8String, which behavior changed - // between Delphi 2009 compiler and previous versions: our implementation - // is consistent and compatible with all versions of Delphi compiler - // - mimic Delphi 2009 UTF8String, without the charset conversion overhead - // - all conversion to/from AnsiString or RawUnicode must be explicit - {$ifdef HASCODEPAGE} - RawUTF8 = type AnsiString(CP_UTF8); // Codepage for an UTF8 string - {$else} - RawUTF8 = type AnsiString; - {$endif} - - /// WinAnsiString is a WinAnsi-encoded AnsiString (code page 1252) - // - use this type instead of System.String, which behavior changed - // between Delphi 2009 compiler and previous versions: our implementation - // is consistent and compatible with all versions of Delphi compiler - // - all conversion to/from RawUTF8 or RawUnicode must be explicit - {$ifdef HASCODEPAGE} - WinAnsiString = type AnsiString(CODEPAGE_US); // WinAnsi Codepage - {$else} - WinAnsiString = type AnsiString; - {$endif} - - {$ifdef HASCODEPAGE} - {$ifdef FPC} - // missing declaration - PRawByteString = ^RawByteString; - {$endif} - {$else} - /// define RawByteString, as it does exist in Delphi 2009+ - // - to be used for byte storage into an AnsiString - // - use this type if you don't want the Delphi compiler not to do any - // code page conversions when you assign a typed AnsiString to a RawByteString, - // i.e. a RawUTF8 or a WinAnsiString - RawByteString = type AnsiString; - /// pointer to a RawByteString - PRawByteString = ^RawByteString; - {$endif} - - /// RawJSON will indicate that this variable content would stay in raw JSON - // - i.e. won't be serialized into values - // - could be any JSON content: number, string, object or array - // - e.g. interface-based service will use it for efficient and AJAX-ready - // transmission of TSQLTableJSON result - RawJSON = type RawUTF8; - - /// SynUnicode is the fastest available Unicode native string type, depending - // on the compiler used - // - this type is native to the compiler, so you can use Length() Copy() and - // such functions with it (this is not possible with RawUnicodeString type) - // - before Delphi 2009+, it uses slow OLE compatible WideString - // (with our Enhanced RTL, WideString allocation can be made faster by using - // an internal caching mechanism of allocation buffers - WideString allocation - // has been made much faster since Windows Vista/Seven) - // - starting with Delphi 2009, it uses fastest UnicodeString type, which - // allow Copy On Write, Reference Counting and fast heap memory allocation - {$ifdef HASVARUSTRING} - SynUnicode = UnicodeString; - {$else} - SynUnicode = WideString; - {$endif HASVARUSTRING} - - PRawUnicode = ^RawUnicode; - PRawJSON = ^RawJSON; - PRawUTF8 = ^RawUTF8; - PWinAnsiString = ^WinAnsiString; - PWinAnsiChar = type PAnsiChar; - PSynUnicode = ^SynUnicode; - - /// a simple wrapper to UTF-8 encoded zero-terminated PAnsiChar - // - PAnsiChar is used only for Win-Ansi encoded text - // - the Synopse mORMot framework uses mostly this PUTF8Char type, - // because all data is internaly stored and expected to be UTF-8 encoded - PUTF8Char = type PAnsiChar; - PPUTF8Char = ^PUTF8Char; - - /// a Row/Col array of PUTF8Char, for containing sqlite3_get_table() result - TPUtf8CharArray = array[0..MaxInt div SizeOf(PUTF8Char)-1] of PUTF8Char; - PPUtf8CharArray = ^TPUtf8CharArray; - - /// a dynamic array of PUTF8Char pointers - TPUTF8CharDynArray = array of PUTF8Char; - - /// a dynamic array of UTF-8 encoded strings - TRawUTF8DynArray = array of RawUTF8; - PRawUTF8DynArray = ^TRawUTF8DynArray; - TRawUTF8DynArrayDynArray = array of TRawUTF8DynArray; - - /// a dynamic array of TVarRec, i.e. could match an "array of const" parameter - TTVarRecDynArray = array of TVarRec; - - {$ifndef NOVARIANTS} - /// a TVarData values array - // - is not called TVarDataArray to avoid confusion with the corresponding - // type already defined in Variants.pas, and used for custom late-binding - TVarDataStaticArray = array[0..MaxInt div SizeOf(TVarData)-1] of TVarData; - PVarDataStaticArray = ^TVarDataStaticArray; - TVariantArray = array[0..MaxInt div SizeOf(Variant)-1] of Variant; - PVariantArray = ^TVariantArray; - TVariantDynArray = array of variant; - PPVariant = ^PVariant; - {$endif} - - PIntegerDynArray = ^TIntegerDynArray; - TIntegerDynArray = array of integer; - TIntegerDynArrayDynArray = array of TIntegerDynArray; - PCardinalDynArray = ^TCardinalDynArray; - TCardinalDynArray = array of cardinal; - PSingleDynArray = ^TSingleDynArray; - TSingleDynArray = array of Single; - PInt64DynArray = ^TInt64DynArray; - TInt64DynArray = array of Int64; - PQwordDynArray = ^TQwordDynArray; - TQwordDynArray = array of Qword; - TPtrUIntDynArray = array of PtrUInt; - PDoubleDynArray = ^TDoubleDynArray; - TDoubleDynArray = array of double; - PCurrencyDynArray = ^TCurrencyDynArray; - TCurrencyDynArray = array of Currency; - TWordDynArray = array of word; - PWordDynArray = ^TWordDynArray; - TByteDynArray = array of byte; - PByteDynArray = ^TByteDynArray; - {$ifndef ISDELPHI2007ANDUP} - TBytes = array of byte; - {$endif} - TObjectDynArray = array of TObject; - PObjectDynArray = ^TObjectDynArray; - TPersistentDynArray = array of TPersistent; - PPersistentDynArray = ^TPersistentDynArray; - TPointerDynArray = array of pointer; - PPointerDynArray = ^TPointerDynArray; - TPPointerDynArray = array of PPointer; - PPPointerDynArray = ^TPPointerDynArray; - TMethodDynArray = array of TMethod; - PMethodDynArray = ^TMethodDynArray; - TObjectListDynArray = array of TObjectList; - PObjectListDynArray = ^TObjectListDynArray; - TFileNameDynArray = array of TFileName; - PFileNameDynArray = ^TFileNameDynArray; - TBooleanDynArray = array of boolean; - PBooleanDynArray = ^TBooleanDynArray; - TClassDynArray = array of TClass; - TWinAnsiDynArray = array of WinAnsiString; - PWinAnsiDynArray = ^TWinAnsiDynArray; - TRawByteStringDynArray = array of RawByteString; - TStringDynArray = array of string; - PStringDynArray = ^TStringDynArray; - PShortStringDynArray = array of PShortString; - PPShortStringArray = ^PShortStringArray; - TShortStringDynArray = array of ShortString; - TDateTimeDynArray = array of TDateTime; - PDateTimeDynArray = ^TDateTimeDynArray; - {$ifndef FPC_OR_UNICODE} - TDate = type TDateTime; - TTime = type TDateTime; - {$endif FPC_OR_UNICODE} - TDateDynArray = array of TDate; - PDateDynArray = ^TDateDynArray; - TTimeDynArray = array of TTime; - PTimeDynArray = ^TTimeDynArray; - TWideStringDynArray = array of WideString; - PWideStringDynArray = ^TWideStringDynArray; - TSynUnicodeDynArray = array of SynUnicode; - PSynUnicodeDynArray = ^TSynUnicodeDynArray; - TGUIDDynArray = array of TGUID; - - PObject = ^TObject; - PClass = ^TClass; - PByteArray = ^TByteArray; - TByteArray = array[0..MaxInt-1] of Byte; // redefine here with {$R-} - PBooleanArray = ^TBooleanArray; - TBooleanArray = array[0..MaxInt-1] of Boolean; - TWordArray = array[0..MaxInt div SizeOf(word)-1] of word; - PWordArray = ^TWordArray; - TIntegerArray = array[0..MaxInt div SizeOf(integer)-1] of integer; - PIntegerArray = ^TIntegerArray; - PIntegerArrayDynArray = array of PIntegerArray; - TPIntegerArray = array[0..MaxInt div SizeOf(PIntegerArray)-1] of PInteger; - PPIntegerArray = ^TPIntegerArray; - TCardinalArray = array[0..MaxInt div SizeOf(cardinal)-1] of cardinal; - PCardinalArray = ^TCardinalArray; - TInt64Array = array[0..MaxInt div SizeOf(Int64)-1] of Int64; - PInt64Array = ^TInt64Array; - TQWordArray = array[0..MaxInt div SizeOf(QWord)-1] of QWord; - PQWordArray = ^TQWordArray; - TPtrUIntArray = array[0..MaxInt div SizeOf(PtrUInt)-1] of PtrUInt; - PPtrUIntArray = ^TPtrUIntArray; - TSmallIntArray = array[0..MaxInt div SizeOf(SmallInt)-1] of SmallInt; - PSmallIntArray = ^TSmallIntArray; - TSingleArray = array[0..MaxInt div SizeOf(Single)-1] of Single; - PSingleArray = ^TSingleArray; - TDoubleArray = array[0..MaxInt div SizeOf(Double)-1] of Double; - PDoubleArray = ^TDoubleArray; - TDateTimeArray = array[0..MaxInt div SizeOf(TDateTime)-1] of TDateTime; - PDateTimeArray = ^TDateTimeArray; - TPAnsiCharArray = array[0..MaxInt div SizeOf(PAnsiChar)-1] of PAnsiChar; - PPAnsiCharArray = ^TPAnsiCharArray; - TRawUTF8Array = array[0..MaxInt div SizeOf(RawUTF8)-1] of RawUTF8; - PRawUTF8Array = ^TRawUTF8Array; - TRawByteStringArray = array[0..MaxInt div SizeOf(RawByteString)-1] of RawByteString; - PRawByteStringArray = ^TRawByteStringArray; - PShortStringArray = array[0..MaxInt div SizeOf(pointer)-1] of PShortString; - PointerArray = array [0..MaxInt div SizeOf(Pointer)-1] of Pointer; - PPointerArray = ^PointerArray; - TObjectArray = array [0..MaxInt div SizeOf(TObject)-1] of TObject; - PObjectArray = ^TObjectArray; - TPtrIntArray = array[0..MaxInt div SizeOf(PtrInt)-1] of PtrInt; - PPtrIntArray = ^TPtrIntArray; - PInt64Rec = ^Int64Rec; - PPShortString = ^PShortString; - - {$ifndef DELPHI5OROLDER} - PIInterface = ^IInterface; - TInterfaceDynArray = array of IInterface; - PInterfaceDynArray = ^TInterfaceDynArray; - {$endif} - - {$ifndef LVCL} - TCollectionClass = class of TCollection; - TCollectionItemClass = class of TCollectionItem; - {$endif} - - /// class-reference type (metaclass) of a TStream - TStreamClass = class of TStream; - - /// class-reference type (metaclass) of a TInterfacedObject - TInterfacedObjectClass = class of TInterfacedObject; - - -{ ************ fast UTF-8 / Unicode / Ansi types and conversion routines **** } - -// some constants used for UTF-8 conversion, including surrogates -const - UTF16_HISURROGATE_MIN = $d800; - UTF16_HISURROGATE_MAX = $dbff; - UTF16_LOSURROGATE_MIN = $dc00; - UTF16_LOSURROGATE_MAX = $dfff; - UTF8_EXTRABYTES: array[$80..$ff] of byte = ( - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, - 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, - 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, 3,3,3,3,3,3,3,3,4,4,4,4,5,5,0,0); - UTF8_EXTRA: array[0..6] of record - offset, minimum: cardinal; - end = ( // http://floodyberry.wordpress.com/2007/04/14/utf-8-conversion-tricks - (offset: $00000000; minimum: $00010000), - (offset: $00003080; minimum: $00000080), - (offset: $000e2080; minimum: $00000800), - (offset: $03c82080; minimum: $00010000), - (offset: $fa082080; minimum: $00200000), - (offset: $82082080; minimum: $04000000), - (offset: $00000000; minimum: $04000000)); - UTF8_EXTRA_SURROGATE = 3; - UTF8_FIRSTBYTE: array[2..6] of byte = ($c0,$e0,$f0,$f8,$fc); - -type - /// kind of adding in a TTextWriter - TTextWriterKind = (twNone, twJSONEscape, twOnSameLine); - - /// an abstract class to handle Ansi to/from Unicode translation - // - implementations of this class will handle efficiently all Code Pages - // - this default implementation will use the Operating System APIs - // - you should not create your own class instance by yourself, but should - // better retrieve an instance using TSynAnsiConvert.Engine(), which will - // initialize either a TSynAnsiFixedWidth or a TSynAnsiConvert instance on need - TSynAnsiConvert = class - protected - fCodePage: cardinal; - fAnsiCharShift: byte; - {$ifdef KYLIX3} - fIConvCodeName: RawUTF8; - {$endif} - procedure InternalAppendUTF8(Source: PAnsiChar; SourceChars: Cardinal; - DestTextWriter: TObject; Escape: TTextWriterKind); virtual; - public - /// initialize the internal conversion engine - constructor Create(aCodePage: cardinal); reintroduce; virtual; - /// returns the engine corresponding to a given code page - // - a global list of TSynAnsiConvert instances is handled by the unit - - // therefore, caller should not release the returned instance - // - will return nil in case of unhandled code page - // - is aCodePage is 0, will return CurrentAnsiConvert value - class function Engine(aCodePage: cardinal): TSynAnsiConvert; - /// direct conversion of a PAnsiChar buffer into an Unicode buffer - // - Dest^ buffer must be reserved with at least SourceChars*2 bytes - // - this default implementation will use the Operating System APIs - // - will append a trailing #0 to the returned PWideChar, unless - // NoTrailingZero is set - function AnsiBufferToUnicode(Dest: PWideChar; Source: PAnsiChar; - SourceChars: Cardinal; NoTrailingZero: boolean=false): PWideChar; overload; virtual; - /// direct conversion of a PAnsiChar buffer into a UTF-8 encoded buffer - // - Dest^ buffer must be reserved with at least SourceChars*3 bytes - // - will append a trailing #0 to the returned PUTF8Char, unless - // NoTrailingZero is set - // - this default implementation will use the Operating System APIs - function AnsiBufferToUTF8(Dest: PUTF8Char; Source: PAnsiChar; - SourceChars: Cardinal; NoTrailingZero: boolean=false): PUTF8Char; overload; virtual; - /// convert any Ansi Text into an UTF-16 Unicode String - // - returns a value using our RawUnicode kind of string - function AnsiToRawUnicode(const AnsiText: RawByteString): RawUnicode; overload; - /// convert any Ansi buffer into an Unicode String - // - returns a value using our RawUnicode kind of string - function AnsiToRawUnicode(Source: PAnsiChar; SourceChars: Cardinal): RawUnicode; overload; virtual; - /// convert any Ansi buffer into an Unicode String - // - returns a SynUnicode, i.e. Delphi 2009+ UnicodeString or a WideString - function AnsiToUnicodeString(Source: PAnsiChar; SourceChars: Cardinal): SynUnicode; overload; - /// convert any Ansi buffer into an Unicode String - // - returns a SynUnicode, i.e. Delphi 2009+ UnicodeString or a WideString - function AnsiToUnicodeString(const Source: RawByteString): SynUnicode; overload; - /// convert any Ansi Text into an UTF-8 encoded String - // - internaly calls AnsiBufferToUTF8 virtual method - function AnsiToUTF8(const AnsiText: RawByteString): RawUTF8; virtual; - /// direct conversion of a PAnsiChar buffer into a UTF-8 encoded string - // - will call AnsiBufferToUnicode() overloaded virtual method - function AnsiBufferToRawUTF8(Source: PAnsiChar; SourceChars: Cardinal): RawUTF8; overload; virtual; - /// direct conversion of an Unicode buffer into a PAnsiChar buffer - // - Dest^ buffer must be reserved with at least SourceChars*3 bytes - // - this default implementation will rely on the Operating System for - // all non ASCII-7 chars - function UnicodeBufferToAnsi(Dest: PAnsiChar; Source: PWideChar; SourceChars: Cardinal): PAnsiChar; overload; virtual; - /// direct conversion of an Unicode buffer into an Ansi Text - function UnicodeBufferToAnsi(Source: PWideChar; SourceChars: Cardinal): RawByteString; overload; virtual; - /// convert any Unicode-encoded String into Ansi Text - // - internaly calls UnicodeBufferToAnsi virtual method - function RawUnicodeToAnsi(const Source: RawUnicode): RawByteString; - /// direct conversion of an UTF-8 encoded buffer into a PAnsiChar buffer - // - Dest^ buffer must be reserved with at least SourceChars bytes - // - no trailing #0 is appended to the buffer - function UTF8BufferToAnsi(Dest: PAnsiChar; Source: PUTF8Char; - SourceChars: Cardinal): PAnsiChar; overload; virtual; - /// convert any UTF-8 encoded buffer into Ansi Text - // - internaly calls UTF8BufferToAnsi virtual method - function UTF8BufferToAnsi(Source: PUTF8Char; SourceChars: Cardinal): RawByteString; overload; - {$ifdef HASINLINE}inline;{$endif} - /// convert any UTF-8 encoded buffer into Ansi Text - // - internaly calls UTF8BufferToAnsi virtual method - procedure UTF8BufferToAnsi(Source: PUTF8Char; SourceChars: Cardinal; - var result: RawByteString); overload; virtual; - /// convert any UTF-8 encoded String into Ansi Text - // - internaly calls UTF8BufferToAnsi virtual method - function UTF8ToAnsi(const UTF8: RawUTF8): RawByteString; virtual; - /// direct conversion of a UTF-8 encoded string into a WinAnsi buffer - // - will truncate the destination string to DestSize bytes (including the - // trailing #0), with a maximum handled size of 2048 bytes - // - returns the number of bytes stored in Dest^ (i.e. the position of #0) - function Utf8ToAnsiBuffer(const S: RawUTF8; Dest: PAnsiChar; DestSize: integer): integer; - /// convert any Ansi Text (providing a From converted) into Ansi Text - function AnsiToAnsi(From: TSynAnsiConvert; const Source: RawByteString): RawByteString; overload; - /// convert any Ansi buffer (providing a From converted) into Ansi Text - function AnsiToAnsi(From: TSynAnsiConvert; Source: PAnsiChar; SourceChars: cardinal): RawByteString; overload; - /// corresponding code page - property CodePage: Cardinal read fCodePage; - end; - - /// a class to handle Ansi to/from Unicode translation of fixed width encoding - // (i.e. non MBCS) - // - this class will handle efficiently all Code Page availables without MBCS - // encoding - like WinAnsi (1252) or Russian (1251) - // - it will use internal fast look-up tables for such encodings - // - this class could take some time to generate, and will consume more than - // 64 KB of memory: you should not create your own class instance by yourself, - // but should better retrieve an instance using TSynAnsiConvert.Engine(), which - // will initialize either a TSynAnsiFixedWidth or a TSynAnsiConvert instance - // on need - // - this class has some additional methods (e.g. IsValid*) which take - // advantage of the internal lookup tables to provide some fast process - TSynAnsiFixedWidth = class(TSynAnsiConvert) - protected - fAnsiToWide: TWordDynArray; - fWideToAnsi: TByteDynArray; - procedure InternalAppendUTF8(Source: PAnsiChar; SourceChars: Cardinal; - DestTextWriter: TObject; Escape: TTextWriterKind); override; - public - /// initialize the internal conversion engine - constructor Create(aCodePage: cardinal); override; - /// direct conversion of a PAnsiChar buffer into an Unicode buffer - // - Dest^ buffer must be reserved with at least SourceChars*2 bytes - // - will append a trailing #0 to the returned PWideChar, unless - // NoTrailingZero is set - function AnsiBufferToUnicode(Dest: PWideChar; Source: PAnsiChar; - SourceChars: Cardinal; NoTrailingZero: boolean=false): PWideChar; override; - /// direct conversion of a PAnsiChar buffer into a UTF-8 encoded buffer - // - Dest^ buffer must be reserved with at least SourceChars*3 bytes - // - will append a trailing #0 to the returned PUTF8Char, unless - // NoTrailingZero is set - function AnsiBufferToUTF8(Dest: PUTF8Char; Source: PAnsiChar; - SourceChars: Cardinal; NoTrailingZero: boolean=false): PUTF8Char; override; - /// convert any Ansi buffer into an Unicode String - // - returns a value using our RawUnicode kind of string - function AnsiToRawUnicode(Source: PAnsiChar; SourceChars: Cardinal): RawUnicode; override; - /// direct conversion of an Unicode buffer into a PAnsiChar buffer - // - Dest^ buffer must be reserved with at least SourceChars*3 bytes - // - this overridden version will use internal lookup tables for fast process - function UnicodeBufferToAnsi(Dest: PAnsiChar; Source: PWideChar; SourceChars: Cardinal): PAnsiChar; override; - /// direct conversion of an UTF-8 encoded buffer into a PAnsiChar buffer - // - Dest^ buffer must be reserved with at least SourceChars bytes - // - no trailing #0 is appended to the buffer - function UTF8BufferToAnsi(Dest: PAnsiChar; Source: PUTF8Char; - SourceChars: Cardinal): PAnsiChar; override; - /// conversion of a wide char into the corresponding Ansi character - // - return -1 for an unknown WideChar in the current code page - function WideCharToAnsiChar(wc: cardinal): integer; - /// return TRUE if the supplied unicode buffer only contains characters of - // the corresponding Ansi code page - // - i.e. if the text can be displayed using this code page - function IsValidAnsi(WideText: PWideChar; Length: PtrInt): boolean; overload; - /// return TRUE if the supplied unicode buffer only contains characters of - // the corresponding Ansi code page - // - i.e. if the text can be displayed using this code page - function IsValidAnsi(WideText: PWideChar): boolean; overload; - /// return TRUE if the supplied UTF-8 buffer only contains characters of - // the corresponding Ansi code page - // - i.e. if the text can be displayed using this code page - function IsValidAnsiU(UTF8Text: PUTF8Char): boolean; - /// return TRUE if the supplied UTF-8 buffer only contains 8 bits characters - // of the corresponding Ansi code page - // - i.e. if the text can be displayed with only 8 bit unicode characters - // (e.g. no "tm" or such) within this code page - function IsValidAnsiU8Bit(UTF8Text: PUTF8Char): boolean; - /// direct access to the Ansi-To-Unicode lookup table - // - use this array like AnsiToWide: array[byte] of word - property AnsiToWide: TWordDynArray read fAnsiToWide; - /// direct access to the Unicode-To-Ansi lookup table - // - use this array like WideToAnsi: array[word] of byte - // - any unhandled WideChar will return ord('?') - property WideToAnsi: TByteDynArray read fWideToAnsi; - end; - - /// a class to handle UTF-8 to/from Unicode translation - // - match the TSynAnsiConvert signature, for code page CP_UTF8 - // - this class is mostly a non-operation for conversion to/from UTF-8 - TSynAnsiUTF8 = class(TSynAnsiConvert) - private - function UnicodeBufferToUTF8(Dest: PAnsiChar; DestChars: Cardinal; - Source: PWideChar; SourceChars: Cardinal): PAnsiChar; - protected - procedure InternalAppendUTF8(Source: PAnsiChar; SourceChars: Cardinal; - DestTextWriter: TObject; Escape: TTextWriterKind); override; - public - /// initialize the internal conversion engine - constructor Create(aCodePage: cardinal); override; - /// direct conversion of a PAnsiChar UTF-8 buffer into an Unicode buffer - // - Dest^ buffer must be reserved with at least SourceChars*2 bytes - // - will append a trailing #0 to the returned PWideChar, unless - // NoTrailingZero is set - function AnsiBufferToUnicode(Dest: PWideChar; Source: PAnsiChar; - SourceChars: Cardinal; NoTrailingZero: boolean=false): PWideChar; override; - /// direct conversion of a PAnsiChar UTF-8 buffer into a UTF-8 encoded buffer - // - Dest^ buffer must be reserved with at least SourceChars*3 bytes - // - will append a trailing #0 to the returned PUTF8Char, unless - // NoTrailingZero is set - function AnsiBufferToUTF8(Dest: PUTF8Char; Source: PAnsiChar; - SourceChars: Cardinal; NoTrailingZero: boolean=false): PUTF8Char; override; - /// convert any UTF-8 Ansi buffer into an Unicode String - // - returns a value using our RawUnicode kind of string - function AnsiToRawUnicode(Source: PAnsiChar; SourceChars: Cardinal): RawUnicode; override; - /// direct conversion of an Unicode buffer into a PAnsiChar UTF-8 buffer - // - Dest^ buffer must be reserved with at least SourceChars*3 bytes - function UnicodeBufferToAnsi(Dest: PAnsiChar; Source: PWideChar; SourceChars: Cardinal): PAnsiChar; override; - /// direct conversion of an Unicode buffer into an Ansi Text - function UnicodeBufferToAnsi(Source: PWideChar; SourceChars: Cardinal): RawByteString; override; - /// direct conversion of an UTF-8 encoded buffer into a PAnsiChar UTF-8 buffer - // - Dest^ buffer must be reserved with at least SourceChars bytes - // - no trailing #0 is appended to the buffer - function UTF8BufferToAnsi(Dest: PAnsiChar; Source: PUTF8Char; - SourceChars: Cardinal): PAnsiChar; override; - /// convert any UTF-8 encoded buffer into Ansi Text - procedure UTF8BufferToAnsi(Source: PUTF8Char; SourceChars: Cardinal; - var result: RawByteString); override; - /// convert any UTF-8 encoded String into Ansi Text - // - directly assign the input as result, since no conversion is needed - function UTF8ToAnsi(const UTF8: RawUTF8): RawByteString; override; - /// convert any Ansi Text into an UTF-8 encoded String - // - directly assign the input as result, since no conversion is needed - function AnsiToUTF8(const AnsiText: RawByteString): RawUTF8; override; - /// direct conversion of a PAnsiChar buffer into a UTF-8 encoded string - function AnsiBufferToRawUTF8(Source: PAnsiChar; SourceChars: Cardinal): RawUTF8; override; - end; - - /// a class to handle UTF-16 to/from Unicode translation - // - match the TSynAnsiConvert signature, for code page CP_UTF16 - // - even if UTF-16 is not an Ansi format, code page CP_UTF16 may have been - // used to store UTF-16 encoded binary content - // - this class is mostly a non-operation for conversion to/from Unicode - TSynAnsiUTF16 = class(TSynAnsiConvert) - public - /// initialize the internal conversion engine - constructor Create(aCodePage: cardinal); override; - /// direct conversion of a PAnsiChar UTF-16 buffer into an Unicode buffer - // - Dest^ buffer must be reserved with at least SourceChars*2 bytes - // - will append a trailing #0 to the returned PWideChar, unless - // NoTrailingZero is set - function AnsiBufferToUnicode(Dest: PWideChar; Source: PAnsiChar; - SourceChars: Cardinal; NoTrailingZero: boolean=false): PWideChar; override; - /// direct conversion of a PAnsiChar UTF-16 buffer into a UTF-8 encoded buffer - // - Dest^ buffer must be reserved with at least SourceChars*3 bytes - // - will append a trailing #0 to the returned PUTF8Char, unless - // NoTrailingZero is set - function AnsiBufferToUTF8(Dest: PUTF8Char; Source: PAnsiChar; - SourceChars: Cardinal; NoTrailingZero: boolean=false): PUTF8Char; override; - /// convert any UTF-16 Ansi buffer into an Unicode String - // - returns a value using our RawUnicode kind of string - function AnsiToRawUnicode(Source: PAnsiChar; SourceChars: Cardinal): RawUnicode; override; - /// direct conversion of an Unicode buffer into a PAnsiChar UTF-16 buffer - // - Dest^ buffer must be reserved with at least SourceChars*3 bytes - function UnicodeBufferToAnsi(Dest: PAnsiChar; Source: PWideChar; SourceChars: Cardinal): PAnsiChar; override; - /// direct conversion of an UTF-8 encoded buffer into a PAnsiChar UTF-16 buffer - // - Dest^ buffer must be reserved with at least SourceChars bytes - // - no trailing #0 is appended to the buffer - function UTF8BufferToAnsi(Dest: PAnsiChar; Source: PUTF8Char; - SourceChars: Cardinal): PAnsiChar; override; - end; - - - /// implements a stack-based storage of some (UTF-8 or binary) text - // - avoid temporary memory allocation via the heap for up to 4KB of data - // - could be used e.g. to make a temporary copy when JSON is parsed in-place - // - call one of the Init() overloaded methods, then Done to release its memory - // - all Init() methods will allocate 16 more bytes, for a trailing #0 and - // to ensure our fast JSON parsing won't trigger any GPF (since it may read - // up to 4 bytes ahead via its PInteger() trick) or any SSE4.2 function - {$ifdef USERECORDWITHMETHODS}TSynTempBuffer = record - {$else}TSynTempBuffer = object{$endif} - public - /// the text/binary length, in bytes, excluding the trailing #0 - len: PtrInt; - /// where the text/binary is available (and any Source has been copied) - // - equals nil if len=0 - buf: pointer; - /// initialize a temporary copy of the content supplied as RawByteString - // - will also allocate and copy the ending #0 (even for binary) - procedure Init(const Source: RawByteString); overload; - /// initialize a temporary copy of the supplied text buffer, ending with #0 - function Init(Source: PUTF8Char): PUTF8Char; overload; - /// initialize a temporary copy of the supplied text buffer - procedure Init(Source: pointer; SourceLen: PtrInt); overload; - /// initialize a new temporary buffer of a given number of bytes - function Init(SourceLen: PtrInt): pointer; overload; - /// initialize a temporary buffer with the length of the internal stack - function InitOnStack: pointer; - /// initialize the buffer returning the internal buffer size (4095 bytes) - // - could be used e.g. for an API call, first trying with plain temp.Init - // and using temp.buf and temp.len safely in the call, only calling - // temp.Init(expectedsize) if the API returned an error about an insufficient - // buffer space - function Init: integer; overload; {$ifdef HASINLINE}inline;{$endif} - /// initialize a new temporary buffer of a given number of random bytes - // - will fill the buffer via FillRandom() calls - // - forcegsl is true by default, since Lecuyer's generator has no HW bug - function InitRandom(RandomLen: integer; forcegsl: boolean=true): pointer; - /// initialize a new temporary buffer filled with 32-bit integer increasing values - function InitIncreasing(Count: PtrInt; Start: PtrInt=0): PIntegerArray; - /// initialize a new temporary buffer of a given number of zero bytes - function InitZero(ZeroLen: PtrInt): pointer; - /// finalize the temporary storage - procedure Done; overload; {$ifdef HASINLINE}inline;{$endif} - /// finalize the temporary storage, and create a RawUTF8 string from it - procedure Done(EndBuf: pointer; var Dest: RawUTF8); overload; - private - // default 4KB buffer allocated on stack - after the len/buf main fields - tmp: array[0..4095] of AnsiChar; - end; - - /// function prototype to be used for hashing of an element - // - it must return a cardinal hash, with as less collision as possible - // - TDynArrayHashed.Init will use crc32c() if no custom function is supplied, - // which will run either as software or SSE4.2 hardware, with good colision - // for most used kind of data - THasher = function(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal; - -var - /// global TSynAnsiConvert instance to handle WinAnsi encoding (code page 1252) - // - this instance is global and instantied during the whole program life time - // - it will be created from hard-coded values, and not using the system API, - // since it appeared that some systems (e.g. in Russia) did tweak the registry - // so that 1252 code page maps 1251 code page - WinAnsiConvert: TSynAnsiFixedWidth; - - /// global TSynAnsiConvert instance to handle current system encoding - // - this is the encoding as used by the AnsiString Delphi, so will be used - // before Delphi 2009 to speed-up VCL string handling (especially for UTF-8) - // - this instance is global and instantied during the whole program life time - CurrentAnsiConvert: TSynAnsiConvert; - - /// global TSynAnsiConvert instance to handle UTF-8 encoding (code page CP_UTF8) - // - this instance is global and instantied during the whole program life time - UTF8AnsiConvert: TSynAnsiUTF8; - -/// check if a codepage should be handled by a TSynAnsiFixedWidth page -function IsFixedWidthCodePage(aCodePage: cardinal): boolean; - {$ifdef HASINLINE}inline;{$endif} - -const - /// HTTP header name for the content type, as defined in the corresponding RFC - HEADER_CONTENT_TYPE = 'Content-Type: '; - - /// HTTP header name for the content type, in upper case - // - as defined in the corresponding RFC - // - could be used e.g. with IdemPChar() to retrieve the Content-Type value - HEADER_CONTENT_TYPE_UPPER = 'CONTENT-TYPE: '; - - /// HTTP header name for the client IP, in upper case - // - as defined in our HTTP server classes - // - could be used e.g. with IdemPChar() to retrieve the remote IP address - HEADER_REMOTEIP_UPPER = 'REMOTEIP: '; - - /// HTTP header name for the authorization token, in upper case - // - could be used e.g. with IdemPChar() to retrieve a JWT value - // - will detect header computed e.g. by SynCrtSock.AuthorizationBearer() - HEADER_BEARER_UPPER = 'AUTHORIZATION: BEARER '; - - /// MIME content type used for JSON communication (as used by the Microsoft - // WCF framework and the YUI framework) - JSON_CONTENT_TYPE = 'application/json; charset=UTF-8'; - - /// HTTP header for MIME content type used for plain JSON - JSON_CONTENT_TYPE_HEADER = HEADER_CONTENT_TYPE+JSON_CONTENT_TYPE; - - /// MIME content type used for plain JSON, in upper case - // - could be used e.g. with IdemPChar() to retrieve the Content-Type value - JSON_CONTENT_TYPE_UPPER = 'APPLICATION/JSON'; - - /// HTTP header for MIME content type used for plain JSON, in upper case - // - could be used e.g. with IdemPChar() to retrieve the Content-Type value - JSON_CONTENT_TYPE_HEADER_UPPER = HEADER_CONTENT_TYPE_UPPER+JSON_CONTENT_TYPE_UPPER; - - /// MIME content type used for plain UTF-8 text - TEXT_CONTENT_TYPE = 'text/plain; charset=UTF-8'; - - /// HTTP header for MIME content type used for plain UTF-8 text - TEXT_CONTENT_TYPE_HEADER = HEADER_CONTENT_TYPE+TEXT_CONTENT_TYPE; - - /// MIME content type used for UTF-8 encoded HTML - HTML_CONTENT_TYPE = 'text/html; charset=UTF-8'; - - /// HTTP header for MIME content type used for UTF-8 encoded HTML - HTML_CONTENT_TYPE_HEADER = HEADER_CONTENT_TYPE+HTML_CONTENT_TYPE; - - /// MIME content type used for UTF-8 encoded XML - XML_CONTENT_TYPE = 'text/xml; charset=UTF-8'; - - /// HTTP header for MIME content type used for UTF-8 encoded XML - XML_CONTENT_TYPE_HEADER = HEADER_CONTENT_TYPE+XML_CONTENT_TYPE; - - /// MIME content type used for raw binary data - BINARY_CONTENT_TYPE = 'application/octet-stream'; - - /// MIME content type used for raw binary data, in upper case - BINARY_CONTENT_TYPE_UPPER = 'APPLICATION/OCTET-STREAM'; - - /// HTTP header for MIME content type used for raw binary data - BINARY_CONTENT_TYPE_HEADER = HEADER_CONTENT_TYPE+BINARY_CONTENT_TYPE; - - /// MIME content type used for a JPEG picture - JPEG_CONTENT_TYPE = 'image/jpeg'; - -var - /// MIME content type used for JSON communication - // - i.e. 'application/json; charset=UTF-8' - // - this global will be initialized with JSON_CONTENT_TYPE constant, to - // avoid a memory allocation each time it is assigned to a variable - JSON_CONTENT_TYPE_VAR: RawUTF8; - - /// HTTP header for MIME content type used for plain JSON - // - this global will be initialized with JSON_CONTENT_TYPE_HEADER constant, - // to avoid a memory allocation each time it is assigned to a variable - JSON_CONTENT_TYPE_HEADER_VAR: RawUTF8; - - /// can be used to avoid a memory allocation for res := 'null' - NULL_STR_VAR: RawUTF8; - -/// compute the new capacity when expanding an array of items -// - handle tiny, small, medium, large and huge sizes properly to reduce -// memory usage and maximize performance -function NextGrow(capacity: integer): integer; - -/// equivalence to SetString(s,nil,len) function -// - faster especially under FPC -procedure FastSetString(var s: RawUTF8; p: pointer; len: PtrInt); - {$ifndef HASCODEPAGE}{$ifdef HASINLINE}inline;{$endif}{$endif} - -/// equivalence to SetString(s,nil,len) function with a specific code page -// - faster especially under FPC -procedure FastSetStringCP(var s; p: pointer; len, codepage: PtrInt); - {$ifndef HASCODEPAGE}{$ifdef HASINLINE}inline;{$endif}{$endif} - -/// initialize a RawByteString, ensuring returned "aligned" pointer is 16-bytes aligned -// - to be used e.g. for proper SSE process -procedure GetMemAligned(var s: RawByteString; p: pointer; len: PtrInt; - out aligned: pointer); - -/// equivalence to @UTF8[1] expression to ensure a RawUTF8 variable is unique -// - will ensure that the string refcount is 1, and return a pointer to the text -// - under FPC, @UTF8[1] does not call UniqueString() as it does with Delphi -// - if UTF8 is a constant (refcount=-1), will create a temporary copy in heap -function UniqueRawUTF8(var UTF8: RawUTF8): pointer; - {$ifdef HASINLINE}inline;{$endif} - -/// will fast replace all #0 chars as ~ -// - could be used after UniqueRawUTF8() on a in-placed modified JSON buffer, -// in which all values have been ended with #0 -// - you can optionally specify a maximum size, in bytes (this won't reallocate -// the string, but just add a #0 at some point in the UTF8 buffer) -// - could allow logging of parsed input e.g. after an exception -procedure UniqueRawUTF8ZeroToTilde(var UTF8: RawUTF8; MaxSize: integer=maxInt); - -/// conversion of a wide char into a WinAnsi (CodePage 1252) char -// - return '?' for an unknown WideChar in code page 1252 -function WideCharToWinAnsiChar(wc: cardinal): AnsiChar; - {$ifdef HASINLINE}inline;{$endif} - -/// conversion of a wide char into a WinAnsi (CodePage 1252) char index -// - return -1 for an unknown WideChar in code page 1252 -function WideCharToWinAnsi(wc: cardinal): integer; - {$ifdef HASINLINE}inline;{$endif} - -/// return TRUE if the supplied buffer only contains 7-bits Ansi characters -function IsAnsiCompatible(PC: PAnsiChar): boolean; overload; - -/// return TRUE if the supplied UTF-16 buffer only contains 7-bits Ansi characters -function IsAnsiCompatibleW(PW: PWideChar): boolean; overload; - -/// return TRUE if the supplied buffer only contains 7-bits Ansi characters -function IsAnsiCompatible(PC: PAnsiChar; Len: PtrUInt): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// return TRUE if the supplied text only contains 7-bits Ansi characters -function IsAnsiCompatible(const Text: RawByteString): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// return TRUE if the supplied UTF-16 buffer only contains 7-bits Ansi characters -function IsAnsiCompatibleW(PW: PWideChar; Len: PtrInt): boolean; overload; - -/// return TRUE if the supplied unicode buffer only contains WinAnsi characters -// - i.e. if the text can be displayed using ANSI_CHARSET -function IsWinAnsi(WideText: PWideChar): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// return TRUE if the supplied unicode buffer only contains WinAnsi characters -// - i.e. if the text can be displayed using ANSI_CHARSET -function IsWinAnsi(WideText: PWideChar; Length: integer): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// return TRUE if the supplied UTF-8 buffer only contains WinAnsi characters -// - i.e. if the text can be displayed using ANSI_CHARSET -function IsWinAnsiU(UTF8Text: PUTF8Char): boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// return TRUE if the supplied UTF-8 buffer only contains WinAnsi 8 bit characters -// - i.e. if the text can be displayed using ANSI_CHARSET with only 8 bit unicode -// characters (e.g. no "tm" or such) -function IsWinAnsiU8Bit(UTF8Text: PUTF8Char): boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// UTF-8 encode one UTF-16 character into Dest -// - return the number of bytes written into Dest (i.e. 1,2 or 3) -// - this method does NOT handle UTF-16 surrogate pairs -function WideCharToUtf8(Dest: PUTF8Char; aWideChar: PtrUInt): integer; - {$ifdef HASINLINE}inline;{$endif} - -/// UTF-8 encode one UTF-16 encoded UCS4 character into Dest -// - return the number of bytes written into Dest (i.e. from 1 up to 6) -// - Source will contain the next UTF-16 character -// - this method DOES handle UTF-16 surrogate pairs -function UTF16CharToUtf8(Dest: PUTF8Char; var Source: PWord): integer; - -/// UTF-8 encode one UCS4 character into Dest -// - return the number of bytes written into Dest (i.e. from 1 up to 6) -// - this method DOES handle UTF-16 surrogate pairs -function UCS4ToUTF8(ucs4: cardinal; Dest: PUTF8Char): integer; - -/// direct conversion of an AnsiString with an unknown code page into an -// UTF-8 encoded String -// - will assume CurrentAnsiConvert.CodePage prior to Delphi 2009 -// - newer UNICODE versions of Delphi will retrieve the code page from string -procedure AnyAnsiToUTF8(const s: RawByteString; var result: RawUTF8); overload; - -/// direct conversion of an AnsiString with an unknown code page into an -// UTF-8 encoded String -// - will assume CurrentAnsiConvert.CodePage prior to Delphi 2009 -// - newer UNICODE versions of Delphi will retrieve the code page from string -function AnyAnsiToUTF8(const s: RawByteString): RawUTF8; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// direct conversion of a WinAnsi (CodePage 1252) string into a UTF-8 encoded String -// - faster than SysUtils: don't use Utf8Encode(WideString) -> no Windows.Global(), -// and use a fixed pre-calculated array for individual chars conversion -function WinAnsiToUtf8(const S: WinAnsiString): RawUTF8; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// direct conversion of a WinAnsi (CodePage 1252) string into a UTF-8 encoded String -// - faster than SysUtils: don't use Utf8Encode(WideString) -> no Windows.Global(), -// and use a fixed pre-calculated array for individual chars conversion -function WinAnsiToUtf8(WinAnsi: PAnsiChar; WinAnsiLen: PtrInt): RawUTF8; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// direct conversion of a WinAnsi PAnsiChar buffer into a UTF-8 encoded buffer -// - Dest^ buffer must be reserved with at least SourceChars*3 -// - call internally WinAnsiConvert fast conversion class -function WinAnsiBufferToUtf8(Dest: PUTF8Char; Source: PAnsiChar; SourceChars: Cardinal): PUTF8Char; - {$ifdef HASINLINE}inline;{$endif} - -/// direct conversion of a WinAnsi shortstring into a UTF-8 text -// - call internally WinAnsiConvert fast conversion class -function ShortStringToUTF8(const source: ShortString): RawUTF8; - {$ifdef HASINLINE}inline;{$endif} - -/// direct conversion of a WinAnsi (CodePage 1252) string into a Unicode encoded String -// - very fast, by using a fixed pre-calculated array for individual chars conversion -function WinAnsiToRawUnicode(const S: WinAnsiString): RawUnicode; - -/// direct conversion of a WinAnsi (CodePage 1252) string into a Unicode buffer -// - very fast, by using a fixed pre-calculated array for individual chars conversion -// - text will be truncated if necessary to avoid buffer overflow in Dest[] -procedure WinAnsiToUnicodeBuffer(const S: WinAnsiString; Dest: PWordArray; DestLen: PtrInt); - {$ifdef HASINLINE}inline;{$endif} - -/// direct conversion of a UTF-8 encoded string into a WinAnsi String -function Utf8ToWinAnsi(const S: RawUTF8): WinAnsiString; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// direct conversion of a UTF-8 encoded zero terminated buffer into a WinAnsi String -function Utf8ToWinAnsi(P: PUTF8Char): WinAnsiString; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// direct conversion of a UTF-8 encoded zero terminated buffer into a RawUTF8 String -procedure Utf8ToRawUTF8(P: PUTF8Char; var result: RawUTF8); - {$ifdef HASINLINE}inline;{$endif} - -/// direct conversion of a UTF-8 encoded buffer into a WinAnsi PAnsiChar buffer -function UTF8ToWinPChar(dest: PAnsiChar; source: PUTF8Char; count: integer): integer; - {$ifdef HASINLINE}inline;{$endif} - -/// direct conversion of a UTF-8 encoded buffer into a WinAnsi shortstring buffer -procedure UTF8ToShortString(var dest: shortstring; source: PUTF8Char); - -/// direct conversion of an ANSI-7 shortstring into an AnsiString -// - can be used e.g. for names retrieved from RTTI to convert them into RawUTF8 -function ShortStringToAnsi7String(const source: shortstring): RawByteString; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// direct conversion of an ANSI-7 shortstring into an AnsiString -// - can be used e.g. for names retrieved from RTTI to convert them into RawUTF8 -procedure ShortStringToAnsi7String(const source: shortstring; var result: RawUTF8); overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert an UTF-8 encoded text into a WideChar (UTF-16) buffer -// - faster than System.UTF8ToUnicode -// - sourceBytes can by 0, therefore length is computed from zero terminated source -// - enough place must be available in dest buffer (guess is sourceBytes*3+2) -// - a WideChar(#0) is added at the end (if something is written) unless -// NoTrailingZero is TRUE -// - returns the BYTE count written in dest, excluding the ending WideChar(#0) -function UTF8ToWideChar(dest: PWideChar; source: PUTF8Char; sourceBytes: PtrInt=0; - NoTrailingZero: boolean=false): PtrInt; overload; - -/// convert an UTF-8 encoded text into a WideChar (UTF-16) buffer -// - faster than System.UTF8ToUnicode -// - this overloaded function expect a MaxDestChars parameter -// - sourceBytes can not be 0 for this function -// - enough place must be available in dest buffer (guess is sourceBytes*3+2) -// - a WideChar(#0) is added at the end (if something is written) unless -// NoTrailingZero is TRUE -// - returns the BYTE COUNT (not WideChar count) written in dest, excluding the -// ending WideChar(#0) -function UTF8ToWideChar(dest: PWideChar; source: PUTF8Char; - MaxDestChars, sourceBytes: PtrInt; NoTrailingZero: boolean=false): PtrInt; overload; - -/// calculate the UTF-16 Unicode characters count, UTF-8 encoded in source^ -// - count may not match the UCS4 glyphs number, in case of UTF-16 surrogates -// - faster than System.UTF8ToUnicode with dest=nil -function Utf8ToUnicodeLength(source: PUTF8Char): PtrUInt; - -/// returns TRUE if the supplied buffer has valid UTF-8 encoding with no #1..#31 -// control characters -// - supplied input is a pointer to a #0 ended text buffer -function IsValidUTF8WithoutControlChars(source: PUTF8Char): Boolean; overload; - -/// returns TRUE if the supplied buffer has valid UTF-8 encoding with no #0..#31 -// control characters -// - supplied input is a RawUTF8 variable -function IsValidUTF8WithoutControlChars(const source: RawUTF8): Boolean; overload; - -/// will truncate the supplied UTF-8 value if its length exceeds the specified -// UTF-16 Unicode characters count -// - count may not match the UCS4 glyphs number, in case of UTF-16 surrogates -// - returns FALSE if text was not truncated, TRUE otherwise -function Utf8TruncateToUnicodeLength(var text: RawUTF8; maxUtf16: integer): boolean; - -/// will truncate the supplied UTF-8 value if its length exceeds the specified -// bytes count -// - this function will ensure that the returned content will contain only valid -// UTF-8 sequence, i.e. will trim the whole trailing UTF-8 sequence -// - returns FALSE if text was not truncated, TRUE otherwise -function Utf8TruncateToLength(var text: RawUTF8; maxBytes: PtrUInt): boolean; - -/// compute the truncated length of the supplied UTF-8 value if it exceeds the -// specified bytes count -// - this function will ensure that the returned content will contain only valid -// UTF-8 sequence, i.e. will trim the whole trailing UTF-8 sequence -// - returns maxUTF8 if text was not truncated, or the number of fitting bytes -function Utf8TruncatedLength(const text: RawUTF8; maxBytes: PtrUInt): PtrInt; overload; - -/// compute the truncated length of the supplied UTF-8 value if it exceeds the -// specified bytes count -// - this function will ensure that the returned content will contain only valid -// UTF-8 sequence, i.e. will trim the whole trailing UTF-8 sequence -// - returns maxUTF8 if text was not truncated, or the number of fitting bytes -function Utf8TruncatedLength(text: PAnsiChar; textlen,maxBytes: PtrUInt): PtrInt; overload; - -/// calculate the UTF-16 Unicode characters count of the UTF-8 encoded first line -// - count may not match the UCS4 glyphs number, in case of UTF-16 surrogates -// - end the parsing at first #13 or #10 character -function Utf8FirstLineToUnicodeLength(source: PUTF8Char): PtrInt; - -/// convert a UTF-8 encoded buffer into a RawUnicode string -// - if L is 0, L is computed from zero terminated P buffer -// - RawUnicode is ended by a WideChar(#0) -// - faster than System.Utf8Decode() which uses slow widestrings -function Utf8DecodeToRawUnicode(P: PUTF8Char; L: integer): RawUnicode; overload; - -/// convert a UTF-8 string into a RawUnicode string -function Utf8DecodeToRawUnicode(const S: RawUTF8): RawUnicode; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert a UTF-8 string into a RawUnicode string -// - this version doesn't resize the length of the result RawUnicode -// and is therefore useful before a Win32 Unicode API call (with nCount=-1) -// - if DestLen is not nil, the resulting length (in bytes) will be stored within -function Utf8DecodeToRawUnicodeUI(const S: RawUTF8; DestLen: PInteger=nil): RawUnicode; overload; - -/// convert a UTF-8 string into a RawUnicode string -// - returns the resulting length (in bytes) will be stored within Dest -function Utf8DecodeToRawUnicodeUI(const S: RawUTF8; var Dest: RawUnicode): integer; overload; - -type - /// option set for RawUnicodeToUtf8() conversion - TCharConversionFlags = set of ( - ccfNoTrailingZero, ccfReplacementCharacterForUnmatchedSurrogate); - -/// convert a RawUnicode PWideChar into a UTF-8 string -procedure RawUnicodeToUtf8(WideChar: PWideChar; WideCharCount: integer; - var result: RawUTF8; Flags: TCharConversionFlags = [ccfNoTrailingZero]); overload; - -/// convert a RawUnicode PWideChar into a UTF-8 string -function RawUnicodeToUtf8(WideChar: PWideChar; WideCharCount: integer; - Flags: TCharConversionFlags = [ccfNoTrailingZero]): RawUTF8; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert a RawUnicode UTF-16 PWideChar into a UTF-8 buffer -// - replace system.UnicodeToUtf8 implementation, which is rather slow -// since Delphi 2009+ -// - append a trailing #0 to the ending PUTF8Char, unless ccfNoTrailingZero is set -// - if ccfReplacementCharacterForUnmatchedSurrogate is set, this function will identify -// unmatched surrogate pairs and replace them with EF BF BD / FFFD Unicode -// Replacement character - see https://en.wikipedia.org/wiki/Specials_(Unicode_block) -function RawUnicodeToUtf8(Dest: PUTF8Char; DestLen: PtrInt; - Source: PWideChar; SourceLen: PtrInt; Flags: TCharConversionFlags): PtrInt; overload; - -/// convert a RawUnicode PWideChar into a UTF-8 string -// - this version doesn't resize the resulting RawUTF8 string, but return -// the new resulting RawUTF8 byte count into UTF8Length -function RawUnicodeToUtf8(WideChar: PWideChar; WideCharCount: integer; - out UTF8Length: integer): RawUTF8; overload; - -/// convert a RawUnicode string into a UTF-8 string -function RawUnicodeToUtf8(const Unicode: RawUnicode): RawUTF8; overload; - -/// convert a SynUnicode string into a UTF-8 string -function SynUnicodeToUtf8(const Unicode: SynUnicode): RawUTF8; - -/// convert a WideString into a UTF-8 string -function WideStringToUTF8(const aText: WideString): RawUTF8; - {$ifdef HASINLINE}inline;{$endif} - -/// direct conversion of a Unicode encoded buffer into a WinAnsi PAnsiChar buffer -procedure RawUnicodeToWinPChar(dest: PAnsiChar; source: PWideChar; WideCharCount: integer); - {$ifdef HASINLINE}inline;{$endif} - -/// convert a RawUnicode PWideChar into a WinAnsi (code page 1252) string -function RawUnicodeToWinAnsi(WideChar: PWideChar; WideCharCount: integer): WinAnsiString; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert a RawUnicode string into a WinAnsi (code page 1252) string -function RawUnicodeToWinAnsi(const Unicode: RawUnicode): WinAnsiString; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert a WideString into a WinAnsi (code page 1252) string -function WideStringToWinAnsi(const Wide: WideString): WinAnsiString; - {$ifdef HASINLINE}inline;{$endif} - -/// convert an AnsiChar buffer (of a given code page) into a UTF-8 string -procedure AnsiCharToUTF8(P: PAnsiChar; L: Integer; var result: RawUTF8; ACP: integer); - -/// convert any Raw Unicode encoded String into a generic SynUnicode Text -function RawUnicodeToSynUnicode(const Unicode: RawUnicode): SynUnicode; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert any Raw Unicode encoded String into a generic SynUnicode Text -function RawUnicodeToSynUnicode(WideChar: PWideChar; WideCharCount: integer): SynUnicode; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert an Unicode buffer into a WinAnsi (code page 1252) string -procedure UnicodeBufferToWinAnsi(source: PWideChar; out Dest: WinAnsiString); - -/// convert an Unicode buffer into a generic VCL string -function UnicodeBufferToString(source: PWideChar): string; - -{$ifdef HASVARUSTRING} - -/// convert a Delphi 2009+ or FPC Unicode string into our UTF-8 string -function UnicodeStringToUtf8(const S: UnicodeString): RawUTF8; inline; - -// this function is the same as direct RawUTF8=AnsiString(CP_UTF8) assignment -// but is faster, since it uses no Win32 API call -function UTF8DecodeToUnicodeString(const S: RawUTF8): UnicodeString; overload; inline; - -/// convert our UTF-8 encoded buffer into a Delphi 2009+ Unicode string -// - this function is the same as direct assignment, since RawUTF8=AnsiString(CP_UTF8), -// but is faster, since use no Win32 API call -procedure UTF8DecodeToUnicodeString(P: PUTF8Char; L: integer; var result: UnicodeString); overload; - -/// convert a Delphi 2009+ Unicode string into a WinAnsi (code page 1252) string -function UnicodeStringToWinAnsi(const S: UnicodeString): WinAnsiString; inline; - -/// convert our UTF-8 encoded buffer into a Delphi 2009+ Unicode string -// - this function is the same as direct assignment, since RawUTF8=AnsiString(CP_UTF8), -// but is faster, since use no Win32 API call -function UTF8DecodeToUnicodeString(P: PUTF8Char; L: integer): UnicodeString; overload; inline; - -/// convert a Win-Ansi encoded buffer into a Delphi 2009+ Unicode string -// - this function is faster than default RTL, since use no Win32 API call -function WinAnsiToUnicodeString(WinAnsi: PAnsiChar; WinAnsiLen: PtrInt): UnicodeString; overload; - -/// convert a Win-Ansi string into a Delphi 2009+ Unicode string -// - this function is faster than default RTL, since use no Win32 API call -function WinAnsiToUnicodeString(const WinAnsi: WinAnsiString): UnicodeString; inline; overload; - -{$endif HASVARUSTRING} - -/// convert any generic VCL Text into an UTF-8 encoded String -// - in the VCL context, it's prefered to use TLanguageFile.StringToUTF8() -// method from mORMoti18n, which will handle full i18n of your application -// - it will work as is with Delphi 2009+ (direct unicode conversion) -// - under older version of Delphi (no unicode), it will use the -// current RTL codepage, as with WideString conversion (but without slow -// WideString usage) -function StringToUTF8(const Text: string): RawUTF8; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert any generic VCL Text buffer into an UTF-8 encoded String -// - it will work as is with Delphi 2009+ (direct unicode conversion) -// - under older version of Delphi (no unicode), it will use the -// current RTL codepage, as with WideString conversion (but without slow -// WideString usage) -procedure StringToUTF8(Text: PChar; TextLen: PtrInt; var result: RawUTF8); overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert any generic VCL Text into an UTF-8 encoded String -// - this overloaded function use a faster by-reference parameter for the result -procedure StringToUTF8(const Text: string; var result: RawUTF8); overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert any generic VCL Text into an UTF-8 encoded String -function ToUTF8(const Text: string): RawUTF8; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert any UTF-8 encoded shortstring Text into an UTF-8 encoded String -// - expects the supplied content to be already ASCII-7 or UTF-8 encoded, e.g. -// a RTTI type or property name: it won't work with Ansi-encoded strings -function ToUTF8(const Ansi7Text: ShortString): RawUTF8; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert a TGUID into UTF-8 encoded text -// - will return e.g. '3F2504E0-4F89-11D3-9A0C-0305E82C3301' (without the {}) -// - if you need the embracing { }, use GUIDToRawUTF8() function instead -function ToUTF8({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID): RawUTF8; overload; - -{$ifndef NOVARIANTS} - -type - /// function prototype used internally for variant comparison - // - used in mORMot.pas unit e.g. by TDocVariantData.SortByValue - TVariantCompare = function(const V1,V2: variant): PtrInt; - -/// TVariantCompare-compatible case-sensitive comparison function -// - just a wrapper around SortDynArrayVariantComp(caseInsensitive=false) -function VariantCompare(const V1,V2: variant): PtrInt; - {$ifdef HASINLINE}inline;{$endif} - -/// TVariantCompare-compatible case-insensitive comparison function -// - just a wrapper around SortDynArrayVariantComp(caseInsensitive=true) -function VariantCompareI(const V1,V2: variant): PtrInt; - {$ifdef HASINLINE}inline;{$endif} - -/// convert any Variant into UTF-8 encoded String -// - use VariantSaveJSON() instead if you need a conversion to JSON with -// custom parameters -// - note: null will be returned as 'null' -function VariantToUTF8(const V: Variant): RawUTF8; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert any Variant into UTF-8 encoded String -// - use VariantSaveJSON() instead if you need a conversion to JSON with -// custom parameters -// - note: null will be returned as 'null' -function ToUTF8(const V: Variant): RawUTF8; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert any Variant into UTF-8 encoded String -// - use VariantSaveJSON() instead if you need a conversion to JSON with -// custom parameters -// - wasString is set if the V value was a text -// - empty and null variants will be stored as 'null' text - as expected by JSON -// - custom variant types (e.g. TDocVariant) will be stored as JSON -procedure VariantToUTF8(const V: Variant; var result: RawUTF8; - var wasString: boolean); overload; - -/// convert any Variant into UTF-8 encoded String -// - use VariantSaveJSON() instead if you need a conversion to JSON with -// custom parameters -// - returns TRUE if the V value was a text, FALSE if was not (e.g. a number) -// - empty and null variants will be stored as 'null' text - as expected by JSON -// - custom variant types (e.g. TDocVariant) will be stored as JSON -function VariantToUTF8(const V: Variant; var Text: RawUTF8): boolean; overload; - -/// convert any date/time Variant into a TDateTime value -// - would handle varDate kind of variant, or use a string conversion and -// ISO-8601 parsing if possible -function VariantToDateTime(const V: Variant; var Value: TDateTime): boolean; - -/// fast conversion from hexa chars, supplied as a variant string, into a binary buffer -function VariantHexDisplayToBin(const Hex: variant; Bin: PByte; BinBytes: integer): boolean; - -/// fast conversion of a binary buffer into hexa chars, as a variant string -function BinToHexDisplayLowerVariant(Bin: pointer; BinBytes: integer): variant; - {$ifdef HASINLINE}inline;{$endif} - -/// fast comparison of a Variant and UTF-8 encoded String (or number) -// - slightly faster than plain V=Str, which computes a temporary variant -// - here Str='' equals unassigned, null or false -// - if CaseSensitive is false, will use IdemPropNameU() for comparison -function VariantEquals(const V: Variant; const Str: RawUTF8; - CaseSensitive: boolean=true): boolean; overload; - -/// convert any Variant into a VCL string type -// - expects any varString value to be stored as a RawUTF8 -// - prior to Delphi 2009, use VariantToString(aVariant) instead of -// string(aVariant) to safely retrieve a string=AnsiString value from a variant -// generated by our framework units - otherwise, you may loose encoded characters -// - for Unicode versions of Delphi, there won't be any potential data loss, -// but this version may be slightly faster than a string(aVariant) -function VariantToString(const V: Variant): string; - -/// convert any Variant into a value encoded as with :(..:) inlined parameters -// in FormatUTF8(Format,Args,Params) -procedure VariantToInlineValue(const V: Variant; var result: RawUTF8); - -/// convert any Variant into another Variant storing an RawUTF8 of the value -// - e.g. VariantToVariantUTF8('toto')='toto' and VariantToVariantUTF8(12)='12' -function VariantToVariantUTF8(const V: Variant): variant; - -/// faster alternative to Finalize(aVariantDynArray) -// - this function will take account and optimize the release of a dynamic -// array of custom variant types values -// - for instance, an array of TDocVariant will be optimized for speed -procedure VariantDynArrayClear(var Value: TVariantDynArray); - {$ifdef HASINLINE}inline;{$endif} - -/// crc32c-based hash of a variant value -// - complex string types will make up to 255 uppercase characters conversion -// if CaseInsensitive is true -// - you can specify your own hashing function if crc32c is not what you expect -function VariantHash(const value: variant; CaseInsensitive: boolean; - Hasher: THasher=nil): cardinal; - -{$endif NOVARIANTS} - -{ note: those VariantToInteger*() functions are expected to be there } - -/// convert any numerical Variant into a 32-bit integer -// - it will expect true numerical Variant and won't convert any string nor -// floating-pointer Variant, which will return FALSE and won't change the -// Value variable content -function VariantToInteger(const V: Variant; var Value: integer): boolean; - -/// convert any numerical Variant into a 64-bit integer -// - it will expect true numerical Variant and won't convert any string nor -// floating-pointer Variant, which will return FALSE and won't change the -// Value variable content -function VariantToInt64(const V: Variant; var Value: Int64): boolean; - -/// convert any numerical Variant into a 64-bit integer -// - it will expect true numerical Variant and won't convert any string nor -// floating-pointer Variant, which will return the supplied DefaultValue -function VariantToInt64Def(const V: Variant; DefaultValue: Int64): Int64; - -/// convert any numerical Variant into a floating point value -function VariantToDouble(const V: Variant; var Value: double): boolean; - -/// convert any numerical Variant into a floating point value -function VariantToDoubleDef(const V: Variant; const default: double=0): double; - -/// convert any numerical Variant into a fixed decimals floating point value -function VariantToCurrency(const V: Variant; var Value: currency): boolean; - -/// convert any numerical Variant into a boolean value -// - text content will return true after case-insensitive 'true' comparison -function VariantToBoolean(const V: Variant; var Value: Boolean): boolean; - -/// convert any numerical Variant into an integer -// - it will expect true numerical Variant and won't convert any string nor -// floating-pointer Variant, which will return the supplied DefaultValue -function VariantToIntegerDef(const V: Variant; DefaultValue: integer): integer; overload; - -/// convert any generic VCL Text buffer into an UTF-8 encoded buffer -// - Dest must be able to receive at least SourceChars*3 bytes -// - it will work as is with Delphi 2009+ (direct unicode conversion) -// - under older version of Delphi (no unicode), it will use the -// current RTL codepage, as with WideString conversion (but without slow -// WideString usage) -function StringBufferToUtf8(Dest: PUTF8Char; Source: PChar; SourceChars: PtrInt): PUTF8Char; overload; - -/// convert any generic VCL 0-terminated Text buffer into an UTF-8 string -// - it will work as is with Delphi 2009+ (direct unicode conversion) -// - under older version of Delphi (no unicode), it will use the -// current RTL codepage, as with WideString conversion (but without slow -// WideString usage) -procedure StringBufferToUtf8(Source: PChar; out result: RawUTF8); overload; - -/// convert any generic VCL Text into a Raw Unicode encoded String -// - it's prefered to use TLanguageFile.StringToUTF8() method in mORMoti18n, -// which will handle full i18n of your application -// - it will work as is with Delphi 2009+ (direct unicode conversion) -// - under older version of Delphi (no unicode), it will use the -// current RTL codepage, as with WideString conversion (but without slow -// WideString usage) -function StringToRawUnicode(const S: string): RawUnicode; overload; - -/// convert any generic VCL Text into a SynUnicode encoded String -// - it's prefered to use TLanguageFile.StringToUTF8() method in mORMoti18n, -// which will handle full i18n of your application -// - it will work as is with Delphi 2009+ (direct unicode conversion) -// - under older version of Delphi (no unicode), it will use the -// current RTL codepage, as with WideString conversion (but without slow -// WideString usage) -function StringToSynUnicode(const S: string): SynUnicode; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert any generic VCL Text into a SynUnicode encoded String -// - overloaded to avoid a copy to a temporary result string of a function -procedure StringToSynUnicode(const S: string; var result: SynUnicode); overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert any generic VCL Text into a Raw Unicode encoded String -// - it's prefered to use TLanguageFile.StringToUTF8() method in mORMoti18n, -// which will handle full i18n of your application -// - it will work as is with Delphi 2009+ (direct unicode conversion) -// - under older version of Delphi (no unicode), it will use the -// current RTL codepage, as with WideString conversion (but without slow -// WideString usage) -function StringToRawUnicode(P: PChar; L: integer): RawUnicode; overload; - -/// convert any Raw Unicode encoded string into a generic VCL Text -// - uses StrLenW() and not length(U) to handle case when was used as buffer -function RawUnicodeToString(const U: RawUnicode): string; overload; - -/// convert any Raw Unicode encoded buffer into a generic VCL Text -function RawUnicodeToString(P: PWideChar; L: integer): string; overload; - -/// convert any Raw Unicode encoded buffer into a generic VCL Text -procedure RawUnicodeToString(P: PWideChar; L: integer; var result: string); overload; - -/// convert any SynUnicode encoded string into a generic VCL Text -function SynUnicodeToString(const U: SynUnicode): string; - {$ifdef HASINLINE}inline;{$endif} - -/// convert any UTF-8 encoded String into a generic VCL Text -// - it's prefered to use TLanguageFile.UTF8ToString() in mORMoti18n, -// which will handle full i18n of your application -// - it will work as is with Delphi 2009+ (direct unicode conversion) -// - under older version of Delphi (no unicode), it will use the -// current RTL codepage, as with WideString conversion (but without slow -// WideString usage) -function UTF8ToString(const Text: RawUTF8): string; - {$ifdef HASINLINE}inline;{$endif} - -/// convert any UTF-8 encoded buffer into a generic VCL Text -// - it's prefered to use TLanguageFile.UTF8ToString() in mORMoti18n, -// which will handle full i18n of your application -// - it will work as is with Delphi 2009+ (direct unicode conversion) -// - under older version of Delphi (no unicode), it will use the -// current RTL codepage, as with WideString conversion (but without slow -// WideString usage) -function UTF8DecodeToString(P: PUTF8Char; L: integer): string; overload; - {$ifdef UNICODE}inline;{$endif} - -/// convert any UTF-8 encoded buffer into a generic VCL Text -procedure UTF8DecodeToString(P: PUTF8Char; L: integer; var result: string); overload; - -/// convert any UTF-8 encoded String into a generic WideString Text -function UTF8ToWideString(const Text: RawUTF8): WideString; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert any UTF-8 encoded String into a generic WideString Text -procedure UTF8ToWideString(const Text: RawUTF8; var result: WideString); overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert any UTF-8 encoded String into a generic WideString Text -procedure UTF8ToWideString(Text: PUTF8Char; Len: PtrInt; var result: WideString); overload; - -/// convert any UTF-8 encoded String into a generic SynUnicode Text -function UTF8ToSynUnicode(const Text: RawUTF8): SynUnicode; overload; - -/// convert any UTF-8 encoded String into a generic SynUnicode Text -procedure UTF8ToSynUnicode(const Text: RawUTF8; var result: SynUnicode); overload; - -/// convert any UTF-8 encoded buffer into a generic SynUnicode Text -procedure UTF8ToSynUnicode(Text: PUTF8Char; Len: PtrInt; var result: SynUnicode); overload; - -/// convert any Ansi 7 bit encoded String into a generic VCL Text -// - the Text content must contain only 7 bit pure ASCII characters -function Ansi7ToString(const Text: RawByteString): string; overload; - {$ifndef UNICODE}{$ifdef HASINLINE}inline;{$endif}{$endif} - -/// convert any Ansi 7 bit encoded String into a generic VCL Text -// - the Text content must contain only 7 bit pure ASCII characters -function Ansi7ToString(Text: PWinAnsiChar; Len: PtrInt): string; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert any Ansi 7 bit encoded String into a generic VCL Text -// - the Text content must contain only 7 bit pure ASCII characters -procedure Ansi7ToString(Text: PWinAnsiChar; Len: PtrInt; var result: string); overload; - -/// convert any generic VCL Text into Ansi 7 bit encoded String -// - the Text content must contain only 7 bit pure ASCII characters -function StringToAnsi7(const Text: string): RawByteString; - -/// convert any generic VCL Text into WinAnsi (Win-1252) 8 bit encoded String -function StringToWinAnsi(const Text: string): WinAnsiString; - {$ifdef UNICODE}inline;{$endif} - -/// fast Format() function replacement, optimized for RawUTF8 -// - only supported token is %, which will be written in the resulting string -// according to each Args[] supplied items - so you will never get any exception -// as with the SysUtils.Format() when a specifier is incorrect -// - resulting string has no length limit and uses fast concatenation -// - there is no escape char, so to output a '%' character, you need to use '%' -// as place-holder, and specify '%' as value in the Args array -// - note that, due to a Delphi compiler limitation, cardinal values should be -// type-casted to Int64() (otherwise the integer mapped value will be converted) -// - any supplied TObject instance will be written as their class name -function FormatUTF8(const Format: RawUTF8; const Args: array of const): RawUTF8; overload; - -/// fast Format() function replacement, optimized for RawUTF8 -// - overloaded function, which avoid a temporary RawUTF8 instance on stack -procedure FormatUTF8(const Format: RawUTF8; const Args: array of const; - out result: RawUTF8); overload; - -/// fast Format() function replacement, tuned for direct memory buffer write -// - use the same single token % (and implementation) than FormatUTF8() -// - returns the number of UTF-8 bytes appended to Dest^ -function FormatBuffer(const Format: RawUTF8; const Args: array of const; - Dest: pointer; DestLen: PtrInt): PtrInt; - -/// fast Format() function replacement, for UTF-8 content stored in shortstring -// - use the same single token % (and implementation) than FormatUTF8() -// - shortstring allows fast stack allocation, so is perfect for small content -// - truncate result if the text size exceeds 255 bytes -procedure FormatShort(const Format: RawUTF8; const Args: array of const; - var result: shortstring); - -/// fast Format() function replacement, for UTF-8 content stored in shortstring -function FormatToShort(const Format: RawUTF8; const Args: array of const): shortstring; - -/// fast Format() function replacement, tuned for small content -// - use the same single token % (and implementation) than FormatUTF8() -procedure FormatString(const Format: RawUTF8; const Args: array of const; - out result: string); overload; - -/// fast Format() function replacement, tuned for small content -// - use the same single token % (and implementation) than FormatUTF8() -function FormatString(const Format: RawUTF8; const Args: array of const): string; overload; - {$ifdef FPC}inline;{$endif} - -type - /// used e.g. by PointerToHexShort/CardinalToHexShort/Int64ToHexShort/FormatShort16 - // - such result type would avoid a string allocation on heap, so are highly - // recommended e.g. when logging small pieces of information - TShort16 = string[16]; - PShort16 = ^TShort16; - -/// fast Format() function replacement, for UTF-8 content stored in TShort16 -// - truncate result if the text size exceeds 16 bytes -procedure FormatShort16(const Format: RawUTF8; const Args: array of const; - var result: TShort16); - -/// fast Format() function replacement, handling % and ? parameters -// - will include Args[] for every % in Format -// - will inline Params[] for every ? in Format, handling special "inlined" -// parameters, as exected by mORMot.pas unit, i.e. :(1234): for numerical -// values, and :('quoted '' string'): for textual values -// - if optional JSONFormat parameter is TRUE, ? parameters will be written -// as JSON quoted strings, without :(...): tokens, e.g. "quoted "" string" -// - resulting string has no length limit and uses fast concatenation -// - note that, due to a Delphi compiler limitation, cardinal values should be -// type-casted to Int64() (otherwise the integer mapped value will be converted) -// - any supplied TObject instance will be written as their class name -function FormatUTF8(const Format: RawUTF8; const Args, Params: array of const; - JSONFormat: boolean=false): RawUTF8; overload; - -/// read and store text into values[] according to fmt specifiers -// - %d as PInteger, %D as PInt64, %u as PCardinal, %U as PQWord, %f as PDouble, -// %F as PCurrency, %x as 8 hexa chars to PInteger, %X as 16 hexa chars to PInt64, -// %s as PShortString (UTF-8 encoded), %S as PRawUTF8, %L as PRawUTF8 (getting -// all text until the end of the line) -// - optionally, specifiers and any whitespace separated identifiers may be -// extracted and stored into the ident[] array, e.g. '%dFirstInt %s %DOneInt64' -// will store ['dFirstInt','s','DOneInt64'] into ident -function ScanUTF8(const text, fmt: RawUTF8; const values: array of pointer; - ident: PRawUTF8DynArray=nil): integer; overload; - -/// read text from P/PLen and store it into values[] according to fmt specifiers -function ScanUTF8(P: PUTF8Char; PLen: PtrInt; const fmt: RawUTF8; - const values: array of pointer; ident: PRawUTF8DynArray): integer; overload; - -/// convert an open array (const Args: array of const) argument to an UTF-8 -// encoded text -// - note that, due to a Delphi compiler limitation, cardinal values should be -// type-casted to Int64() (otherwise the integer mapped value will be converted) -// - any supplied TObject instance will be written as their class name -procedure VarRecToUTF8(const V: TVarRec; var result: RawUTF8; - wasString: PBoolean=nil); - -type - /// a memory structure which avoids a temporary RawUTF8 allocation - // - used by VarRecToTempUTF8() and FormatUTF8()/FormatShort() - TTempUTF8 = record - Len: PtrInt; - Text: PUTF8Char; - TempRawUTF8: pointer; - Temp: array[0..23] of AnsiChar; - end; - PTempUTF8 = ^TTempUTF8; - -/// convert an open array (const Args: array of const) argument to an UTF-8 -// encoded text, using a specified temporary buffer -// - this function would allocate a RawUTF8 in TempRawUTF8 only if needed, -// but use the supplied Res.Temp[] buffer for numbers to text conversion - -// caller should ensure to make RawUTF8(TempRawUTF8) := '' on the entry -// - it would return the number of UTF-8 bytes, i.e. Res.Len -// - note that, due to a Delphi compiler limitation, cardinal values should be -// type-casted to Int64() (otherwise the integer mapped value will be converted) -// - any supplied TObject instance will be written as their class name -function VarRecToTempUTF8(const V: TVarRec; var Res: TTempUTF8): integer; - -/// convert an open array (const Args: array of const) argument to an UTF-8 -// encoded text, returning FALSE if the argument was not a string value -function VarRecToUTF8IsString(const V: TVarRec; var value: RawUTF8): boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// convert an open array (const Args: array of const) argument to an Int64 -// - returns TRUE and set Value if the supplied argument is a vtInteger, vtInt64 -// or vtBoolean -// - returns FALSE if the argument is not an integer -// - note that, due to a Delphi compiler limitation, cardinal values should be -// type-casted to Int64() (otherwise the integer mapped value will be converted) -function VarRecToInt64(const V: TVarRec; out value: Int64): boolean; - -/// convert an open array (const Args: array of const) argument to a floating -// point value -// - returns TRUE and set Value if the supplied argument is a number (e.g. -// vtInteger, vtInt64, vtCurrency or vtExtended) -// - returns FALSE if the argument is not a number -// - note that, due to a Delphi compiler limitation, cardinal values should be -// type-casted to Int64() (otherwise the integer mapped value will be converted) -function VarRecToDouble(const V: TVarRec; out value: double): boolean; - -/// convert an open array (const Args: array of const) argument to a value -// encoded as with :(...): inlined parameters in FormatUTF8(Format,Args,Params) -// - note that, due to a Delphi compiler limitation, cardinal values should be -// type-casted to Int64() (otherwise the integer mapped value will be converted) -// - any supplied TObject instance will be written as their class name -procedure VarRecToInlineValue(const V: TVarRec; var result: RawUTF8); - -/// get an open array (const Args: array of const) character argument -// - only handle varChar and varWideChar kind of arguments -function VarRecAsChar(const V: TVarRec): integer; - {$ifdef HASINLINE}inline;{$endif} - -type - /// function prototype used internally for UTF-8 buffer comparison - // - used in mORMot.pas unit during TSQLTable rows sort and by TSQLQuery - TUTF8Compare = function(P1,P2: PUTF8Char): PtrInt; - -/// convert the endianness of a given unsigned 32-bit integer into BigEndian -function bswap32(a: cardinal): cardinal; - {$ifndef CPUINTEL}inline;{$endif} - -/// convert the endianness of a given unsigned 64-bit integer into BigEndian -function bswap64({$ifdef FPC_X86}constref{$else}const{$endif} a: QWord): QWord; - {$ifndef CPUINTEL}inline;{$endif} - -/// convert the endianness of an array of unsigned 64-bit integer into BigEndian -// - n is required to be > 0 -// - warning: on x86, a should be <> b -procedure bswap64array(a,b: PQWordArray; n: PtrInt); - -/// fast concatenation of several AnsiStrings -function RawByteStringArrayConcat(const Values: array of RawByteString): RawByteString; - -/// creates a TBytes from a RawByteString memory buffer -procedure RawByteStringToBytes(const buf: RawByteString; out bytes: TBytes); - -/// creates a RawByteString memory buffer from a TBytes content -procedure BytesToRawByteString(const bytes: TBytes; out buf: RawByteString); - {$ifdef HASINLINE}inline;{$endif} - -/// creates a RawByteString memory buffer from an embedded resource -// - returns '' if the resource is not found -// - warning: resources size may be rounded up to alignment -// - you can specify a library (dll) resource instance handle, if needed -procedure ResourceToRawByteString(const ResName: string; ResType: PChar; - out buf: RawByteString; Instance: THandle=0); - -/// creates a RawByteString memory buffer from an SynLZ-compressed embedded resource -// - returns '' if the resource is not found -// - this method would use SynLZDecompress() after ResourceToRawByteString(), -// with a ResType=PChar(10) (i.e. RC_DATA) -// - you can specify a library (dll) resource instance handle, if needed -procedure ResourceSynLZToRawByteString(const ResName: string; - out buf: RawByteString; Instance: THandle=0); - -{$ifndef ENHANCEDRTL} { is our Enhanced Runtime (or LVCL) library not installed? } - -/// fast dedicated RawUTF8 version of Trim() -// - implemented using x86 asm, if possible -// - this Trim() is seldom used, but this RawUTF8 specific version is needed -// e.g. by Delphi 2009+, to avoid two unnecessary conversions into UnicodeString -// - in the middle of VCL code, consider using TrimU() which won't have name -// collision ambiguity as with SysUtils' homonymous function -function Trim(const S: RawUTF8): RawUTF8; - -/// fast dedicated RawUTF8 version of Trim() -// - could be used if overloaded Trim() from SysUtils.pas is ambiguous -function TrimU(const S: RawUTF8): RawUTF8; - {$ifdef HASINLINE}inline;{$endif} - -{$define OWNNORMTOUPPER} { NormToUpper[] exists only in our enhanced RTL } - -{$endif ENHANCEDRTL} - -/// our fast version of CompareMem() with optimized asm for x86 and tune pascal -function CompareMem(P1, P2: Pointer; Length: PtrInt): Boolean; - -{$ifdef HASINLINE} -function CompareMemFixed(P1, P2: Pointer; Length: PtrInt): Boolean; inline; -{$else} -/// a CompareMem()-like function designed for small and fixed-sized content -// - here, Length is expected to be a constant value - typically from sizeof() - -// so that inlining has better performance than calling the CompareMem() function -var CompareMemFixed: function(P1, P2: Pointer; Length: PtrInt): Boolean = CompareMem; -{$endif HASINLINE} - -/// a CompareMem()-like function designed for small (a few bytes) content -function CompareMemSmall(P1, P2: Pointer; Length: PtrUInt): Boolean; {$ifdef HASINLINE}inline;{$endif} - -/// convert some ASCII-7 text into binary, using Emile Baudot code -// - as used in telegraphs, covering #10 #13 #32 a-z 0-9 - ' , ! : ( + ) $ ? @ . / ; -// charset, following a custom static-huffman-like encoding with 5-bit masks -// - any upper case char will be converted into lowercase during encoding -// - other characters (e.g. UTF-8 accents, or controls chars) will be ignored -// - resulting binary will consume 5 (or 10) bits per character -// - reverse of the BaudotToAscii() function -// - the "baud" symbol rate measurement comes from Emile's name ;) -function AsciiToBaudot(P: PAnsiChar; len: PtrInt): RawByteString; overload; - -/// convert some ASCII-7 text into binary, using Emile Baudot code -// - as used in telegraphs, covering #10 #13 #32 a-z 0-9 - ' , ! : ( + ) $ ? @ . / ; -// charset, following a custom static-huffman-like encoding with 5-bit masks -// - any upper case char will be converted into lowercase during encoding -// - other characters (e.g. UTF-8 accents, or controls chars) will be ignored -// - resulting binary will consume 5 (or 10) bits per character -// - reverse of the BaudotToAscii() function -// - the "baud" symbol rate measurement comes from Emile's name ;) -function AsciiToBaudot(const Text: RawUTF8): RawByteString; overload; - -/// convert some Baudot code binary, into ASCII-7 text -// - reverse of the AsciiToBaudot() function -// - any uppercase character would be decoded as lowercase - and some characters -// may have disapeared -// - the "baud" symbol rate measurement comes from Emile's name ;) -function BaudotToAscii(Baudot: PByteArray; len: PtrInt): RawUTF8; overload; - -/// convert some Baudot code binary, into ASCII-7 text -// - reverse of the AsciiToBaudot() function -// - any uppercase character would be decoded as lowercase - and some characters -// may have disapeared -// - the "baud" symbol rate measurement comes from Emile's name ;) -function BaudotToAscii(const Baudot: RawByteString): RawUTF8; overload; - -{$ifdef UNICODE} -/// our fast RawUTF8 version of Pos(), for Unicode only compiler -// - this Pos() is seldom used, but this RawUTF8 specific version is needed -// by Delphi 2009+, to avoid two unnecessary conversions into UnicodeString -// - just a wrapper around PosEx(substr,str,1) -function Pos(const substr, str: RawUTF8): Integer; overload; inline; -{$endif UNICODE} - -/// use our fast RawUTF8 version of IntToStr() -// - without any slow UnicodeString=String->AnsiString conversion for Delphi 2009 -// - only useful if our Enhanced Runtime (or LVCL) library is not installed -function Int64ToUtf8(Value: Int64): RawUTF8; overload; - {$ifdef PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif} - -/// fast RawUTF8 version of IntToStr(), with proper QWord conversion -procedure UInt64ToUtf8(Value: QWord; var result: RawUTF8); - -/// use our fast RawUTF8 version of IntToStr() -// - without any slow UnicodeString=String->AnsiString conversion for Delphi 2009 -// - only useful if our Enhanced Runtime (or LVCL) library is not installed -function Int32ToUtf8(Value: PtrInt): RawUTF8; overload; - {$ifdef PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif} - -/// use our fast RawUTF8 version of IntToStr() -// - without any slow UnicodeString=String->AnsiString conversion for Delphi 2009 -// - result as var parameter saves a local assignment and a try..finally -procedure Int32ToUTF8(Value: PtrInt; var result: RawUTF8); overload; - {$ifdef HASINLINE}inline;{$endif} - -/// use our fast RawUTF8 version of IntToStr() -// - without any slow UnicodeString=String->AnsiString conversion for Delphi 2009 -// - result as var parameter saves a local assignment and a try..finally -procedure Int64ToUtf8(Value: Int64; var result: RawUTF8); overload; - {$ifdef HASINLINE}inline;{$endif} - -/// use our fast RawUTF8 version of IntToStr() -function ToUTF8(Value: PtrInt): RawUTF8; overload; - {$ifdef HASINLINE}inline;{$endif} - -{$ifndef CPU64} -/// use our fast RawUTF8 version of IntToStr() -function ToUTF8(Value: Int64): RawUTF8; overload; - {$ifdef PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif} -{$endif} - -/// optimized conversion of a cardinal into RawUTF8 -function UInt32ToUtf8(Value: PtrUInt): RawUTF8; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// optimized conversion of a cardinal into RawUTF8 -procedure UInt32ToUtf8(Value: PtrUInt; var result: RawUTF8); overload; - {$ifdef HASINLINE}inline;{$endif} - -/// faster version than default SysUtils.IntToStr implementation -function IntToString(Value: integer): string; overload; - -/// faster version than default SysUtils.IntToStr implementation -function IntToString(Value: cardinal): string; overload; - -/// faster version than default SysUtils.IntToStr implementation -function IntToString(Value: Int64): string; overload; - -/// convert a floating-point value to its numerical text equivalency -function DoubleToString(Value: Double): string; - -/// convert a currency value from its Int64 binary representation into -// its numerical text equivalency -// - decimals are joined by 2 (no decimal, 2 decimals, 4 decimals) -function Curr64ToString(Value: Int64): string; - -type - /// used to store a set of 8-bit encoded characters - TSynAnsicharSet = set of AnsiChar; - /// used to store a set of 8-bit unsigned integers - TSynByteSet = set of Byte; - -/// check all character within text are spaces or control chars -// - i.e. a faster alternative to trim(text)='' -function IsVoid(const text: RawUTF8): boolean; - -/// returns the supplied text content, without any control char -// - a control char has an ASCII code #0 .. #32, i.e. text[]<=' ' -// - you can specify a custom char set to be excluded, if needed -function TrimControlChars(const text: RawUTF8; const controls: TSynAnsicharSet=[#0..' ']): RawUTF8; - -var - /// best possible precision when rendering a "single" kind of float - // - can be used as parameter for ExtendedToShort/ExtendedToStr - // - is defined as a var, so that you may be able to override the default - // settings, for the whole process - SINGLE_PRECISION: integer = 8; - /// best possible precision when rendering a "double" kind of float - // - can be used as parameter for ExtendedToShort/ExtendedToStr - // - is defined as a var, so that you may be able to override the default - // settings, for the whole process - DOUBLE_PRECISION: integer = 15; - /// best possible precision when rendering a "extended" kind of float - // - can be used as parameter for ExtendedToShort/ExtendedToStr - // - is defined as a var, so that you may be able to override the default - // settings, for the whole process - EXTENDED_PRECISION: integer = 18; - -const - /// a typical error allowed when working with double floating-point values - // - 1E-12 is too small, and triggers sometimes some unexpected errors; - // FPC RTL uses 1E-4 so we are paranoid enough - DOUBLE_SAME = 1E-11; - -type - {$ifdef TSYNEXTENDED80} - /// the floating-point type to be used for best precision and speed - // - will allow to fallback to double e.g. on x64 and ARM CPUs - TSynExtended = extended; - {$else} - /// ARM/Delphi 64-bit does not support 80bit extended -> double is enough - TSynExtended = double; - {$endif TSYNEXTENDED80} - - /// the non-number values potentially stored in an IEEE floating point - TFloatNan = (fnNumber, fnNan, fnInf, fnNegInf); - {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} - /// will actually change anything only on FPC ARM/Aarch64 plaforms - unaligned = Double; - {$endif} - - -const - /// the JavaScript-like values of non-number IEEE constants - // - as recognized by FloatToShortNan, and used by TTextWriter.Add() - // when serializing such single/double/extended floating-point values - JSON_NAN: array[TFloatNan] of string[11] = ( - '0', '"NaN"', '"Infinity"', '"-Infinity"'); - -type - /// small structure used as convenient result to Div100() procedure - TDiv100Rec = packed record - /// contains V div 100 after Div100(V) - D: cardinal; - /// contains V mod 100 after Div100(V) - M: cardinal; - end; - -/// simple wrapper to efficiently compute both division and modulo per 100 -// - compute result.D = Y div 100 and result.M = Y mod 100 -// - under FPC, will use fast multiplication by reciprocal so can be inlined -// - under Delphi, we use our own optimized asm version (which can't be inlined) -procedure Div100(Y: cardinal; var res: TDiv100Rec); - {$ifdef FPC} inline; {$endif} - -/// compare to floating point values, with IEEE 754 double precision -// - use this function instead of raw = operator -// - the precision is calculated from the A and B value range -// - faster equivalent than SameValue() in Math unit -// - if you know the precision range of A and B, it's faster to check abs(A-B)QWord(B) is wrong on older versions of Delphi, so you -// should better use this function or SortDynArrayQWord() to properly compare -// two QWord values over CPUX86 -function CompareQWord(A, B: QWord): integer; - {$ifdef HASINLINE}inline;{$endif} - -/// compute the sum of values, using a running compensation for lost low-order bits -// - a naive "Sum := Sum + Data" will be restricted to 53 bits of resolution, -// so will eventually result in an incorrect number -// - Kahan algorithm keeps track of the accumulated error in integer operations, -// to achieve a precision of more than 100 bits -// - see https://en.wikipedia.org/wiki/Kahan_summation_algorithm -procedure KahanSum(const Data: double; var Sum, Carry: double); - {$ifdef HASINLINE}inline;{$endif} - -/// convert a floating-point value to its numerical text equivalency -// - on Delphi Win32, calls FloatToText() in ffGeneral mode; on FPC uses str() -// - DOUBLE_PRECISION will redirect to DoubleToShort() and its faster Fabian -// Loitsch's Grisu algorithm if available -// - returns the count of chars stored into S, i.e. length(S) -function ExtendedToShort(var S: ShortString; Value: TSynExtended; Precision: integer): integer; - -/// convert a floating-point value to its numerical text equivalency without -// scientification notation -// - DOUBLE_PRECISION will redirect to DoubleToShortNoExp() and its faster Fabian -// Loitsch's Grisu algorithm if available - or calls str(Value:0:precision,S) -// - returns the count of chars stored into S, i.e. length(S) -function ExtendedToShortNoExp(var S: ShortString; Value: TSynExtended; - Precision: integer): integer; - -/// check if the supplied text is NAN/INF/+INF/-INF, i.e. not a number -// - as returned by ExtendedToShort/DoubleToShort textual conversion -// - such values do appear as IEEE floating points, but are not defined in JSON -function FloatToShortNan(const s: shortstring): TFloatNan; - {$ifdef HASINLINE}inline;{$endif} - -/// check if the supplied text is NAN/INF/+INF/-INF, i.e. not a number -// - as returned e.g. by ExtendedToStr/DoubleToStr textual conversion -// - such values do appear as IEEE floating points, but are not defined in JSON -function FloatToStrNan(const s: RawUTF8): TFloatNan; - {$ifdef HASINLINE}inline;{$endif} - -/// convert a floating-point value to its numerical text equivalency -function ExtendedToStr(Value: TSynExtended; Precision: integer): RawUTF8; overload; - -/// convert a floating-point value to its numerical text equivalency -procedure ExtendedToStr(Value: TSynExtended; Precision: integer; var result: RawUTF8); overload; - -/// recognize if the supplied text is NAN/INF/+INF/-INF, i.e. not a number -// - returns the number as text (stored into tmp variable), or "Infinity", -// "-Infinity", and "NaN" for corresponding IEEE special values -// - result is a PShortString either over tmp, or JSON_NAN[] -function FloatToJSONNan(const s: ShortString): PShortString; - {$ifdef HASINLINE}inline;{$endif} - -/// convert a floating-point value to its JSON text equivalency -// - depending on the platform, it may either call str() or FloatToText() -// in ffGeneral mode (the shortest possible decimal string using fixed or -// scientific format) -// - returns the number as text (stored into tmp variable), or "Infinity", -// "-Infinity", and "NaN" for corresponding IEEE special values -// - result is a PShortString either over tmp, or JSON_NAN[] -function ExtendedToJSON(var tmp: ShortString; Value: TSynExtended; - Precision: integer; NoExp: boolean): PShortString; - -/// convert a 64-bit floating-point value to its numerical text equivalency -// - on Delphi Win32, calls FloatToText() in ffGeneral mode -// - on other platforms, i.e. Delphi Win64 and all FPC targets, will use our own -// faster Fabian Loitsch's Grisu algorithm implementation -// - returns the count of chars stored into S, i.e. length(S) -function DoubleToShort(var S: ShortString; const Value: double): integer; - {$ifdef FPC}inline;{$endif} - -/// convert a 64-bit floating-point value to its numerical text equivalency -// without scientific notation -// - on Delphi Win32, calls FloatToText() in ffGeneral mode -// - on other platforms, i.e. Delphi Win64 and all FPC targets, will use our own -// faster Fabian Loitsch's Grisu algorithm implementation -// - returns the count of chars stored into S, i.e. length(S) -function DoubleToShortNoExp(var S: ShortString; const Value: double): integer; - {$ifdef FPC}inline;{$endif} - -{$ifdef DOUBLETOSHORT_USEGRISU} -const - // special text returned if the double is not a number - C_STR_INF: string[3] = 'Inf'; - C_STR_QNAN: string[3] = 'Nan'; - - // min_width parameter special value, as used internally by FPC for str(d,s) - // - DoubleToAscii() only accept C_NO_MIN_WIDTH or 0 for min_width: space - // trailing has been removed in this cut-down version - C_NO_MIN_WIDTH = -32767; - -/// raw function to convert a 64-bit double into a shortstring, stored in str -// - implements Fabian Loitsch's Grisu algorithm dedicated to double values -// - currently, SynCommnons only set min_width=0 (for DoubleToShortNoExp to avoid -// any scientific notation ) or min_width=C_NO_MIN_WIDTH (for DoubleToShort to -// force the scientific notation when the double cannot be represented as -// a simple fractinal number) -procedure DoubleToAscii(min_width, frac_digits: integer; const v: double; str: PAnsiChar); -{$endif DOUBLETOSHORT_USEGRISU} - -/// convert a 64-bit floating-point value to its JSON text equivalency -// - on Delphi Win32, calls FloatToText() in ffGeneral mode -// - on other platforms, i.e. Delphi Win64 and all FPC targets, will use our own -// faster Fabian Loitsch's Grisu algorithm -// - returns the number as text (stored into tmp variable), or "Infinity", -// "-Infinity", and "NaN" for corresponding IEEE special values -// - result is a PShortString either over tmp, or JSON_NAN[] -function DoubleToJSON(var tmp: ShortString; Value: double; NoExp: boolean): PShortString; - -/// convert a 64-bit floating-point value to its numerical text equivalency -function DoubleToStr(Value: Double): RawUTF8; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert a 64-bit floating-point value to its numerical text equivalency -procedure DoubleToStr(Value: Double; var result: RawUTF8); overload; - -/// fast retrieve the position of a given character -function PosChar(Str: PUTF8Char; Chr: AnsiChar): PUTF8Char; - {$ifdef PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif} - -/// fast retrieve the position of any value of a given set of characters -// - see also strspn() function which is likely to be faster -function PosCharAny(Str: PUTF8Char; Characters: PAnsiChar): PUTF8Char; - -/// a non case-sensitive RawUTF8 version of Pos() -// - uppersubstr is expected to be already in upper case -// - this version handle only 7 bit ASCII (no accentuated characters) -function PosI(uppersubstr: PUTF8Char; const str: RawUTF8): PtrInt; - -/// a non case-sensitive version of Pos() -// - uppersubstr is expected to be already in upper case -// - this version handle only 7 bit ASCII (no accentuated characters) -function StrPosI(uppersubstr,str: PUTF8Char): PUTF8Char; - -/// a non case-sensitive RawUTF8 version of Pos() -// - substr is expected to be already in upper case -// - this version will decode the UTF-8 content before using NormToUpper[] -function PosIU(substr: PUTF8Char; const str: RawUTF8): Integer; - -/// internal fast integer val to text conversion -// - expect the last available temporary char position in P -// - return the last written char position (write in reverse order in P^) -// - typical use: -// !function Int32ToUTF8(Value: PtrInt): RawUTF8; -// !var tmp: array[0..23] of AnsiChar; -// ! P: PAnsiChar; -// !begin -// ! P := StrInt32(@tmp[23],Value); -// ! SetString(result,P,@tmp[23]-P); -// !end; -// - convert the input value as PtrInt, so as Int64 on 64-bit CPUs -// - not to be called directly: use IntToStr() or Int32ToUTF8() instead -function StrInt32(P: PAnsiChar; val: PtrInt): PAnsiChar; - -/// internal fast unsigned integer val to text conversion -// - expect the last available temporary char position in P -// - return the last written char position (write in reverse order in P^) -// - convert the input value as PtrUInt, so as QWord on 64-bit CPUs -function StrUInt32(P: PAnsiChar; val: PtrUInt): PAnsiChar; - -/// internal fast Int64 val to text conversion -// - same calling convention as with StrInt32() above -function StrInt64(P: PAnsiChar; const val: Int64): PAnsiChar; - {$ifdef HASINLINE}inline;{$endif} - -/// internal fast unsigned Int64 val to text conversion -// - same calling convention as with StrInt32() above -function StrUInt64(P: PAnsiChar; const val: QWord): PAnsiChar; - {$ifdef CPU64}inline;{$endif} - -/// fast add some characters to a RawUTF8 string -// - faster than SetString(tmp,Buffer,BufferLen); Text := Text+tmp; -procedure AppendBufferToRawUTF8(var Text: RawUTF8; Buffer: pointer; BufferLen: PtrInt); - -/// fast add one character to a RawUTF8 string -// - faster than Text := Text + ch; -procedure AppendCharToRawUTF8(var Text: RawUTF8; Ch: AnsiChar); - -/// fast add some characters to a RawUTF8 string -// - faster than Text := Text+RawUTF8(Buffers[0])+RawUTF8(Buffers[0])+... -procedure AppendBuffersToRawUTF8(var Text: RawUTF8; const Buffers: array of PUTF8Char); - -/// fast add some characters from a RawUTF8 string into a given buffer -// - warning: the Buffer should contain enough space to store the Text, otherwise -// you may encounter buffer overflows and random memory errors -function AppendRawUTF8ToBuffer(Buffer: PUTF8Char; const Text: RawUTF8): PUTF8Char; - -/// fast add text conversion of a 32-bit unsigned integer value into a given buffer -// - warning: the Buffer should contain enough space to store the text, otherwise -// you may encounter buffer overflows and random memory errors -function AppendUInt32ToBuffer(Buffer: PUTF8Char; Value: PtrUInt): PUTF8Char; - -/// fast add text conversion of 0-999 integer value into a given buffer -// - warning: it won't check that Value is in 0-999 range -// - up to 4 bytes may be written to the buffer (including trailing #0) -function Append999ToBuffer(Buffer: PUTF8Char; Value: PtrUInt): PUTF8Char; - {$ifdef HASINLINE}inline;{$endif} - -/// buffer-safe version of StrComp(), to be used with PUTF8Char/PAnsiChar -// - pure pascal StrComp() won't access the memory beyond the string, but this -// function is defined for compatibility with SSE 4.2 expectations -function StrCompFast(Str1, Str2: pointer): PtrInt; - {$ifdef PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif} - -/// fastest available version of StrComp(), to be used with PUTF8Char/PAnsiChar -// - won't use SSE4.2 instructions on supported CPUs by default, which may read -// some bytes beyond the s string, so should be avoided e.g. over memory mapped -// files - call explicitely StrCompSSE42() if you are confident on your input -var StrComp: function (Str1, Str2: pointer): PtrInt = StrCompFast; - -/// pure pascal version of strspn(), to be used with PUTF8Char/PAnsiChar -// - please note that this optimized version may read up to 3 bytes beyond -// accept but never after s end, so is safe e.g. over memory mapped files -function strspnpas(s,accept: pointer): integer; - {$ifdef HASINLINE}inline;{$endif} - -/// pure pascal version of strcspn(), to be used with PUTF8Char/PAnsiChar -// - please note that this optimized version may read up to 3 bytes beyond -// reject but never after s end, so is safe e.g. over memory mapped files -function strcspnpas(s,reject: pointer): integer; - {$ifdef HASINLINE}inline;{$endif} - -/// fastest available version of strspn(), to be used with PUTF8Char/PAnsiChar -// - returns size of initial segment of s which appears in accept chars, e.g. -// ! strspn('abcdef','debca')=5 -// - won't use SSE4.2 instructions on supported CPUs by default, which may read -// some bytes beyond the s string, so should be avoided e.g. over memory mapped -// files - call explicitely strspnsse42() if you are confident on your input -var strspn: function (s,accept: pointer): integer = strspnpas; - -/// fastest available version of strcspn(), to be used with PUTF8Char/PAnsiChar -// - returns size of initial segment of s which doesn't appears in reject chars, e.g. -// ! strcspn('1234,6789',',')=4 -// - won't use SSE4.2 instructions on supported CPUs by default, which may read -// some bytes beyond the s string, so should be avoided e.g. over memory mapped -// files - call explicitely strcspnsse42() if you are confident on your input -var strcspn: function (s,reject: pointer): integer = strcspnpas; - -{$ifdef CPUINTEL} -{$ifndef ABSOLUTEPASCAL} -{$ifdef HASAESNI} -/// SSE 4.2 version of StrComp(), to be used with PUTF8Char/PAnsiChar -// - please note that this optimized version may read up to 15 bytes -// beyond the string; this is rarely a problem but it may generate protection -// violations, which could trigger fatal SIGABRT or SIGSEGV on Posix system -// - could be used instead of StrComp() when you are confident about your -// Str1/Str2 input buffers, checking if cfSSE42 in CpuFeatures -function StrCompSSE42(Str1, Str2: pointer): PtrInt; - -// - please note that this optimized version may read up to 15 bytes -// beyond the string; this is rarely a problem but it may generate protection -// violations, which could trigger fatal SIGABRT or SIGSEGV on Posix system -// - could be used instead of StrLen() when you are confident about your -// S input buffers, checking if cfSSE42 in CpuFeatures -function StrLenSSE42(S: pointer): PtrInt; -{$endif HASAESNI} - -/// SSE 4.2 version of strspn(), to be used with PUTF8Char/PAnsiChar -// - please note that this optimized version may read up to 15 bytes -// beyond the string; this is rarely a problem but it may generate protection -// violations, which could trigger fatal SIGABRT or SIGSEGV on Posix system -// - could be used instead of strspn() when you are confident about your -// s/accept input buffers, checking if cfSSE42 in CpuFeatures -function strspnsse42(s,accept: pointer): integer; - -/// SSE 4.2 version of strcspn(), to be used with PUTF8Char/PAnsiChar -// - please note that this optimized version may read up to 15 bytes -// beyond the string; this is rarely a problem but it may generate protection -// violations, which could trigger fatal SIGABRT or SIGSEGV on Posix system -// - could be used instead of strcspn() when you are confident about your -// s/reject input buffers, checking if cfSSE42 in CpuFeatures -function strcspnsse42(s,reject: pointer): integer; - -/// SSE 4.2 version of GetBitsCountPtrInt() -// - defined just for regression tests - call GetBitsCountPtrInt() instead -function GetBitsCountSSE42(value: PtrInt): PtrInt; -{$endif ABSOLUTEPASCAL} -{$endif CPUINTEL} - -/// use our fast version of StrIComp(), to be used with PUTF8Char/PAnsiChar -function StrIComp(Str1, Str2: pointer): PtrInt; - {$ifdef PUREPASCAL} {$ifdef HASINLINE}inline;{$endif} {$endif} - -/// slower version of StrLen(), but which will never read beyond the string -// - this version won't access the memory beyond the string, so may be -// preferred to StrLen(), when using e.g. memory mapped files or any memory -// protected buffer -function StrLenPas(S: pointer): PtrInt; - -/// our fast version of StrLen(), to be used with PUTF8Char/PAnsiChar -// - if available, a fast SSE2 asm will be used on Intel/AMD CPUs -// - won't use SSE4.2 instructions on supported CPUs by default, which may read -// some bytes beyond the string, so should be avoided e.g. over memory mapped -// files - call explicitely StrLenSSE42() if you are confident on your input -var StrLen: function(S: pointer): PtrInt = StrLenPas; - -{$ifdef ABSOLUTEPASCAL} -var FillcharFast: procedure(var Dest; count: PtrInt; Value: byte) = system.FillChar; -var MoveFast: procedure(const Source; var Dest; Count: PtrInt) = system.Move; -{$else} -{$ifdef CPUX64} // will define its own self-dispatched SSE2/AVX functions -type - /// cpuERMS is slightly slower than cpuAVX so is not available by default - TX64CpuFeatures = set of(cpuAVX, cpuAVX2 {$ifdef WITH_ERMS}, cpuERMS{$endif}); -var - /// internal flags used by FillCharFast - easier from asm that CpuFeatures - CPUIDX64: TX64CpuFeatures; -procedure FillcharFast(var dst; cnt: PtrInt; value: byte); -procedure MoveFast(const src; var dst; cnt: PtrInt); -{$else} - -/// our fast version of FillChar() -// - on Intel i386/x86_64, will use fast SSE2/ERMS instructions (if available), -// or optimized X87 assembly implementation for older CPUs -// - on non-Intel CPUs, it will fallback to the default RTL FillChar() -// - note: Delphi x86_64 is far from efficient: even ERMS was wrongly -// introduced in latest updates -var FillcharFast: procedure(var Dest; count: PtrInt; Value: byte); - -/// our fast version of move() -// - on Delphi Intel i386/x86_64, will use fast SSE2 instructions (if available), -// or optimized X87 assembly implementation for older CPUs -// - on non-Intel CPUs, it will fallback to the default RTL Move() -var MoveFast: procedure(const Source; var Dest; Count: PtrInt); - -{$endif CPUX64} -{$endif ABSOLUTEPASCAL} - -/// an alternative Move() function tuned for small unaligned counts -// - warning: expects Count>0 and Source/Dest not nil -// - warning: doesn't support buffers overlapping -procedure MoveSmall(Source, Dest: Pointer; Count: PtrUInt); - {$ifdef HASINLINE}inline;{$endif} - -/// our fast version of StrLen(), to be used with PWideChar -function StrLenW(S: PWideChar): PtrInt; - -/// use our fast version of StrComp(), to be used with PWideChar -function StrCompW(Str1, Str2: PWideChar): PtrInt; - {$ifdef HASINLINE}inline;{$endif} - -/// use our fast version of StrCompL(), to be used with PUTF8Char -function StrCompL(P1,P2: PUTF8Char; L, Default: Integer): PtrInt; - {$ifdef HASINLINE}inline;{$endif} - -/// use our fast version of StrCompIL(), to be used with PUTF8Char -function StrCompIL(P1,P2: PUTF8Char; L: Integer; Default: Integer=0): PtrInt; - {$ifdef HASINLINE}inline;{$endif} - -{$ifdef USENORMTOUPPER} -{$ifdef OWNNORMTOUPPER} -type - TNormTable = packed array[AnsiChar] of AnsiChar; - PNormTable = ^TNormTable; - TNormTableByte = packed array[byte] of byte; - PNormTableByte = ^TNormTableByte; - -var - /// the NormToUpper[] array is defined in our Enhanced RTL: define it now - // if it was not installed - // - handle 8 bit upper chars as in WinAnsi / code page 1252 (e.g. accents) - NormToUpper: TNormTable; - NormToUpperByte: TNormTableByte absolute NormToUpper; - - /// the NormToLower[] array is defined in our Enhanced RTL: define it now - // if it was not installed - // - handle 8 bit upper chars as in WinAnsi / code page 1252 (e.g. accents) - NormToLower: TNormTable; - NormToLowerByte: TNormTableByte absolute NormToLower; -{$endif} -{$else} -{$undef OWNNORMTOUPPER} -{$endif} - -var - /// this table will convert 'a'..'z' into 'A'..'Z' - // - so it will work with UTF-8 without decoding, whereas NormToUpper[] expects - // WinAnsi encoding - NormToUpperAnsi7: TNormTable; - NormToUpperAnsi7Byte: TNormTableByte absolute NormToUpperAnsi7; - /// case sensitive NormToUpper[]/NormToLower[]-like table - // - i.e. NormToNorm[c] = c - NormToNorm: TNormTable; - NormToNormByte: TNormTableByte absolute NormToNorm; - - -/// get the signed 32-bit integer value stored in P^ -// - we use the PtrInt result type, even if expected to be 32-bit, to use -// native CPU register size (don't want any 32-bit overflow here) -// - will end parsing when P^ does not contain any number (e.g. it reaches any -// ending #0 char) -function GetInteger(P: PUTF8Char): PtrInt; overload; - -/// get the signed 32-bit integer value stored in P^..PEnd^ -// - will end parsing when P^ does not contain any number (e.g. it reaches any -// ending #0 char), or when P reached PEnd (avoiding any buffer overflow) -function GetInteger(P,PEnd: PUTF8Char): PtrInt; overload; - -/// get the signed 32-bit integer value stored in P^ -// - if P if nil or not start with a valid numerical value, returns Default -function GetIntegerDef(P: PUTF8Char; Default: PtrInt): PtrInt; - {$ifdef HASINLINE}inline;{$endif} - -/// get the signed 32-bit integer value stored in P^ -// - this version return 0 in err if no error occured, and 1 if an invalid -// character was found, not its exact index as for the val() function -function GetInteger(P: PUTF8Char; var err: integer): PtrInt; overload; - -/// get the unsigned 32-bit integer value stored in P^ -// - we use the PtrUInt result type, even if expected to be 32-bit, to use -// native CPU register size (don't want any 32-bit overflow here) -function GetCardinal(P: PUTF8Char): PtrUInt; - -/// get the unsigned 32-bit integer value stored in P^ -// - if P if nil or not start with a valid numerical value, returns Default -function GetCardinalDef(P: PUTF8Char; Default: PtrUInt): PtrUInt; - -/// get the unsigned 32-bit integer value stored as Unicode string in P^ -function GetCardinalW(P: PWideChar): PtrUInt; - -/// get a boolean value stored as true/false text in P^ -// - would also recognize any non 0 integer as true -function GetBoolean(P: PUTF8Char): boolean; - -/// get the 64-bit integer value stored in P^ -function GetInt64(P: PUTF8Char): Int64; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// get the 64-bit integer value stored in P^ -// - if P if nil or not start with a valid numerical value, returns Default -function GetInt64Def(P: PUTF8Char; const Default: Int64): Int64; - -/// get the 64-bit signed integer value stored in P^ -procedure SetInt64(P: PUTF8Char; var result: Int64); - {$ifdef CPU64}inline;{$endif} - -/// get the 64-bit unsigned integer value stored in P^ -procedure SetQWord(P: PUTF8Char; var result: QWord); - {$ifdef CPU64}inline;{$endif} - -/// get the 64-bit signed integer value stored in P^ -// - set the err content to the index of any faulty character, 0 if conversion -// was successful (same as the standard val function) -function GetInt64(P: PUTF8Char; var err: integer): Int64; overload; - {$ifdef CPU64}inline;{$endif} - -/// get the 64-bit unsigned integer value stored in P^ -// - set the err content to the index of any faulty character, 0 if conversion -// was successful (same as the standard val function) -function GetQWord(P: PUTF8Char; var err: integer): QWord; - -/// get the extended floating point value stored in P^ -// - set the err content to the index of any faulty character, 0 if conversion -// was successful (same as the standard val function) -function GetExtended(P: PUTF8Char; out err: integer): TSynExtended; overload; - -/// get the extended floating point value stored in P^ -// - this overloaded version returns 0 as a result if the content of P is invalid -function GetExtended(P: PUTF8Char): TSynExtended; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// copy a floating-point text buffer with proper correction and validation -// - will correct on the fly '.5' -> '0.5' and '-.5' -> '-0.5' -// - will end not only on #0 but on any char not matching 1[.2[e[-]3]] pattern -// - is used when the input comes from a third-party source with no regular -// output, e.g. a database driver, via TTextWriter.AddFloatStr -function FloatStrCopy(s, d: PUTF8Char): PUTF8Char; - -/// get the WideChar stored in P^ (decode UTF-8 if necessary) -// - any surrogate (UCS4>$ffff) will be returned as '?' -function GetUTF8Char(P: PUTF8Char): cardinal; - {$ifdef HASINLINE}inline;{$endif} - -/// get the UCS4 char stored in P^ (decode UTF-8 if necessary) -function NextUTF8UCS4(var P: PUTF8Char): cardinal; - {$ifdef HASINLINE}inline;{$endif} - -/// get the signed 32-bit integer value stored in a RawUTF8 string -// - we use the PtrInt result type, even if expected to be 32-bit, to use -// native CPU register size (don't want any 32-bit overflow here) -function UTF8ToInteger(const value: RawUTF8; Default: PtrInt=0): PtrInt; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// get and check range of a signed 32-bit integer stored in a RawUTF8 string -// - we use the PtrInt result type, even if expected to be 32-bit, to use -// native CPU register size (don't want any 32-bit overflow here) -function UTF8ToInteger(const value: RawUTF8; Min,max: PtrInt; Default: PtrInt=0): PtrInt; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// get the signed 32-bit integer value stored in a RawUTF8 string -// - returns TRUE if the supplied text was successfully converted into an integer -function ToInteger(const text: RawUTF8; out value: integer): boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// get the unsigned 32-bit cardinal value stored in a RawUTF8 string -// - returns TRUE if the supplied text was successfully converted into a cardinal -function ToCardinal(const text: RawUTF8; out value: cardinal; minimal: cardinal=0): boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// get the signed 64-bit integer value stored in a RawUTF8 string -// - returns TRUE if the supplied text was successfully converted into an Int64 -function ToInt64(const text: RawUTF8; out value: Int64): boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// get a 64-bit floating-point value stored in a RawUTF8 string -// - returns TRUE if the supplied text was successfully converted into a double -function ToDouble(const text: RawUTF8; out value: double): boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// get the signed 64-bit integer value stored in a RawUTF8 string -// - returns the default value if the supplied text was not successfully -// converted into an Int64 -function UTF8ToInt64(const text: RawUTF8; const default: Int64=0): Int64; - -/// encode a string to be compatible with URI encoding -function UrlEncode(const svar: RawUTF8): RawUTF8; overload; - -/// encode a string to be compatible with URI encoding -function UrlEncode(Text: PUTF8Char): RawUTF8; overload; - -/// encode supplied parameters to be compatible with URI encoding -// - parameters must be supplied two by two, as Name,Value pairs, e.g. -// ! url := UrlEncode(['select','*','where','ID=12','offset',23,'object',aObject]); -// - parameters names should be plain ASCII-7 RFC compatible identifiers -// (0..9a..zA..Z_.~), otherwise their values are skipped -// - parameters values can be either textual, integer or extended, or any TObject -// - TObject serialization into UTF-8 will be processed by the ObjectToJSON() -// function -function UrlEncode(const NameValuePairs: array of const): RawUTF8; overload; - -/// encode a JSON object UTF-8 buffer into URI parameters -// - you can specify property names to ignore during the object decoding -// - you can omit the leading query delimiter ('?') by setting IncludeQueryDelimiter=false -// - warning: the ParametersJSON input buffer will be modified in-place -function UrlEncodeJsonObject(const URIName: RawUTF8; ParametersJSON: PUTF8Char; - const PropNamesToIgnore: array of RawUTF8; IncludeQueryDelimiter: Boolean=true): RawUTF8; overload; - -/// encode a JSON object UTF-8 buffer into URI parameters -// - you can specify property names to ignore during the object decoding -// - you can omit the leading query delimiter ('?') by setting IncludeQueryDelimiter=false -// - overloaded function which will make a copy of the input JSON before parsing -function UrlEncodeJsonObject(const URIName, ParametersJSON: RawUTF8; - const PropNamesToIgnore: array of RawUTF8; IncludeQueryDelimiter: Boolean=true): RawUTF8; overload; - -/// decode a string compatible with URI encoding into its original value -// - you can specify the decoding range (as in copy(s,i,len) function) -function UrlDecode(const s: RawUTF8; i: PtrInt=1; len: PtrInt=-1): RawUTF8; overload; - -/// decode a string compatible with URI encoding into its original value -function UrlDecode(U: PUTF8Char): RawUTF8; overload; - -/// decode a specified parameter compatible with URI encoding into its original -// textual value -// - UrlDecodeValue('select=%2A&where=LastName%3D%27M%C3%B4net%27','SELECT=',V,@Next) -// will return Next^='where=...' and V='*' -// - if Upper is not found, Value is not modified, and result is FALSE -// - if Upper is found, Value is modified with the supplied content, and result is TRUE -function UrlDecodeValue(U: PUTF8Char; const Upper: RawUTF8; var Value: RawUTF8; - Next: PPUTF8Char=nil): boolean; - -/// decode a specified parameter compatible with URI encoding into its original -// integer numerical value -// - UrlDecodeInteger('offset=20&where=LastName%3D%27M%C3%B4net%27','OFFSET=',O,@Next) -// will return Next^='where=...' and O=20 -// - if Upper is not found, Value is not modified, and result is FALSE -// - if Upper is found, Value is modified with the supplied content, and result is TRUE -function UrlDecodeInteger(U: PUTF8Char; const Upper: RawUTF8; var Value: integer; - Next: PPUTF8Char=nil): boolean; - -/// decode a specified parameter compatible with URI encoding into its original -// cardinal numerical value -// - UrlDecodeCardinal('offset=20&where=LastName%3D%27M%C3%B4net%27','OFFSET=',O,@Next) -// will return Next^='where=...' and O=20 -// - if Upper is not found, Value is not modified, and result is FALSE -// - if Upper is found, Value is modified with the supplied content, and result is TRUE -function UrlDecodeCardinal(U: PUTF8Char; const Upper: RawUTF8; var Value: Cardinal; - Next: PPUTF8Char=nil): boolean; - -/// decode a specified parameter compatible with URI encoding into its original -// Int64 numerical value -// - UrlDecodeInt64('offset=20&where=LastName%3D%27M%C3%B4net%27','OFFSET=',O,@Next) -// will return Next^='where=...' and O=20 -// - if Upper is not found, Value is not modified, and result is FALSE -// - if Upper is found, Value is modified with the supplied content, and result is TRUE -function UrlDecodeInt64(U: PUTF8Char; const Upper: RawUTF8; var Value: Int64; - Next: PPUTF8Char=nil): boolean; - -/// decode a specified parameter compatible with URI encoding into its original -// floating-point value -// - UrlDecodeExtended('price=20.45&where=LastName%3D%27M%C3%B4net%27','PRICE=',P,@Next) -// will return Next^='where=...' and P=20.45 -// - if Upper is not found, Value is not modified, and result is FALSE -// - if Upper is found, Value is modified with the supplied content, and result is TRUE -function UrlDecodeExtended(U: PUTF8Char; const Upper: RawUTF8; var Value: TSynExtended; - Next: PPUTF8Char=nil): boolean; - -/// decode a specified parameter compatible with URI encoding into its original -// floating-point value -// - UrlDecodeDouble('price=20.45&where=LastName%3D%27M%C3%B4net%27','PRICE=',P,@Next) -// will return Next^='where=...' and P=20.45 -// - if Upper is not found, Value is not modified, and result is FALSE -// - if Upper is found, Value is modified with the supplied content, and result is TRUE -function UrlDecodeDouble(U: PUTF8Char; const Upper: RawUTF8; var Value: double; - Next: PPUTF8Char=nil): boolean; - -/// returns TRUE if all supplied parameters do exist in the URI encoded text -// - CSVNames parameter shall provide as a CSV list of names -// - e.g. UrlDecodeNeedParameters('price=20.45&where=LastName%3D','price,where') -// will return TRUE -function UrlDecodeNeedParameters(U, CSVNames: PUTF8Char): boolean; - -/// decode the next Name=Value&.... pair from input URI -// - Name is returned directly (should be plain ASCII 7 bit text) -// - Value is returned after URI decoding (from %.. patterns) -// - if a pair is decoded, return a PUTF8Char pointer to the next pair in -// the input buffer, or points to #0 if all content has been processed -// - if a pair is not decoded, return nil -function UrlDecodeNextNameValue(U: PUTF8Char; var Name,Value: RawUTF8): PUTF8Char; - -/// decode a URI-encoded Value from an input buffer -// - decoded value is set in Value out variable -// - returns a pointer just after the decoded value (may points e.g. to -// #0 or '&') - it is up to the caller to continue the process or not -function UrlDecodeNextValue(U: PUTF8Char; out Value: RawUTF8): PUTF8Char; - -/// decode a URI-encoded Name from an input buffer -// - decoded value is set in Name out variable -// - returns a pointer just after the decoded name, after the '=' -// - returns nil if there was no name=... pattern in U -function UrlDecodeNextName(U: PUTF8Char; out Name: RawUTF8): PUTF8Char; - -/// checks if the supplied UTF-8 text don't need URI encoding -// - returns TRUE if all its chars are non-void plain ASCII-7 RFC compatible -// identifiers (0..9a..zA..Z-_.~) -function IsUrlValid(P: PUTF8Char): boolean; - -/// checks if the supplied UTF-8 text values don't need URI encoding -// - returns TRUE if all its chars of all strings are non-void plain ASCII-7 RFC -// compatible identifiers (0..9a..zA..Z-_.~) -function AreUrlValid(const Url: array of RawUTF8): boolean; - -/// ensure the supplied URI contains a trailing '/' charater -function IncludeTrailingURIDelimiter(const URI: RawByteString): RawByteString; - -/// encode name/value pairs into CSV/INI raw format -function CSVEncode(const NameValuePairs: array of const; - const KeySeparator: RawUTF8='='; const ValueSeparator: RawUTF8=#13#10): RawUTF8; - -/// find a given name in name/value pairs, and returns the value as RawUTF8 -function ArrayOfConstValueAsText(const NameValuePairs: array of const; - const aName: RawUTF8): RawUTF8; - -/// returns TRUE if the given text buffer contains a..z,A..Z,0..9,_ characters -// - should match most usual property names values or other identifier names -// in the business logic source code -// - i.e. can be tested via IdemPropName*() functions, and the MongoDB-like -// extended JSON syntax as generated by dvoSerializeAsExtendedJson -// - first char must be alphabetical or '_', following chars can be -// alphanumerical or '_' -function PropNameValid(P: PUTF8Char): boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// returns TRUE if the given text buffers contains A..Z,0..9,_ characters -// - use it with property names values (i.e. only including A..Z,0..9,_ chars) -// - this function won't check the first char the same way than PropNameValid() -function PropNamesValid(const Values: array of RawUTF8): boolean; - -type - /// kind of character used from JSON_CHARS[] for efficient JSON parsing - TJsonChar = set of (jcJsonIdentifierFirstChar, jcJsonIdentifier, - jcEndOfJSONField, jcEndOfJSONFieldOr0, jcEndOfJSONValueField, - jcDigitChar, jcDigitFirstChar, jcDigitFloatChar); - /// defines a branch-less table used for JSON parsing - TJsonCharSet = array[AnsiChar] of TJsonChar; - PJsonCharSet = ^TJsonCharSet; -var - /// branch-less table used for JSON parsing - JSON_CHARS: TJsonCharSet; - -/// returns TRUE if the given text buffer contains simple characters as -// recognized by JSON extended syntax -// - follow GetJSONPropName and GotoNextJSONObjectOrArray expectations -function JsonPropNameValid(P: PUTF8Char): boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// returns TRUE if the given text buffers would be escaped when written as JSON -// - e.g. if contains " or \ characters, as defined by -// http://www.ietf.org/rfc/rfc4627.txt -function NeedsJsonEscape(const Text: RawUTF8): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// returns TRUE if the given text buffers would be escaped when written as JSON -// - e.g. if contains " or \ characters, as defined by -// http://www.ietf.org/rfc/rfc4627.txt -function NeedsJsonEscape(P: PUTF8Char): boolean; overload; - -/// returns TRUE if the given text buffers would be escaped when written as JSON -// - e.g. if contains " or \ characters, as defined by -// http://www.ietf.org/rfc/rfc4627.txt -function NeedsJsonEscape(P: PUTF8Char; PLen: integer): boolean; overload; - -/// case insensitive comparison of ASCII identifiers -// - use it with property names values (i.e. only including A..Z,0..9,_ chars) -function IdemPropName(const P1,P2: shortstring): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// case insensitive comparison of ASCII identifiers -// - use it with property names values (i.e. only including A..Z,0..9,_ chars) -// - this version expects P2 to be a PAnsiChar with a specified length -function IdemPropName(const P1: shortstring; P2: PUTF8Char; P2Len: PtrInt): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// case insensitive comparison of ASCII identifiers -// - use it with property names values (i.e. only including A..Z,0..9,_ chars) -// - this version expects P1 and P2 to be a PAnsiChar with specified lengths -function IdemPropName(P1,P2: PUTF8Char; P1Len,P2Len: PtrInt): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// case insensitive comparison of ASCII identifiers -// - use it with property names values (i.e. only including A..Z,0..9,_ chars) -// - this version expects P2 to be a PAnsiChar with specified length -function IdemPropNameU(const P1: RawUTF8; P2: PUTF8Char; P2Len: PtrInt): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// case insensitive comparison of ASCII identifiers of same length -// - use it with property names values (i.e. only including A..Z,0..9,_ chars) -// - this version expects P1 and P2 to be a PAnsiChar with an already checked -// identical length, so may be used for a faster process, e.g. in a loop -// - if P1 and P2 are RawUTF8, you should better call overloaded function -// IdemPropNameU(const P1,P2: RawUTF8), which would be slightly faster by -// using the length stored before the actual text buffer of each RawUTF8 -function IdemPropNameUSameLen(P1,P2: PUTF8Char; P1P2Len: PtrInt): boolean; - {$ifndef ANDROID}{$ifdef PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif}{$endif} - -/// case insensitive comparison of ASCII identifiers -// - use it with property names values (i.e. only including A..Z,0..9,_ chars) -function IdemPropNameU(const P1,P2: RawUTF8): boolean; overload; - {$ifdef PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif} - -/// returns true if the beginning of p^ is the same as up^ -// - ignore case - up^ must be already Upper -// - chars are compared as 7 bit Ansi only (no accentuated characters): but when -// you only need to search for field names e.g. IdemPChar() is prefered, because -// it'll be faster than IdemPCharU(), if UTF-8 decoding is not mandatory -// - if p is nil, will return FALSE -// - if up is nil, will return TRUE -function IdemPChar(p: PUTF8Char; up: PAnsiChar): boolean; - {$ifdef PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif} - -/// returns true if the beginning of p^ is the same as up^, ignoring white spaces -// - ignore case - up^ must be already Upper -// - any white space in the input p^ buffer is just ignored -// - chars are compared as 7 bit Ansi only (no accentuated characters): but when -// you only need to search for field names e.g. IdemPChar() is prefered, because -// it'll be faster than IdemPCharU(), if UTF-8 decoding is not mandatory -// - if p is nil, will return FALSE -// - if up is nil, will return TRUE -function IdemPCharWithoutWhiteSpace(p: PUTF8Char; up: PAnsiChar): boolean; - -/// returns the index of a matching beginning of p^ in upArray[] -// - returns -1 if no item matched -// - ignore case - upArray^ must be already Upper -// - chars are compared as 7 bit Ansi only (no accentuated characters) -// - warning: this function expects upArray[] items to have AT LEAST TWO -// CHARS (it will use a fast comparison of initial 2 bytes) -function IdemPCharArray(p: PUTF8Char; const upArray: array of PAnsiChar): integer; overload; - -/// returns the index of a matching beginning of p^ in upArray two characters -// - returns -1 if no item matched -// - ignore case - upArray^ must be already Upper -// - chars are compared as 7 bit Ansi only (no accentuated characters) -function IdemPCharArray(p: PUTF8Char; const upArrayBy2Chars: RawUTF8): integer; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// returns true if the beginning of p^ is the same as up^ -// - ignore case - up^ must be already Upper -// - this version will decode the UTF-8 content before using NormToUpper[], so -// it will be slower than the IdemPChar() function above, but will handle -// WinAnsi accentuated characters (e.g. 'e' acute will be matched as 'E') -function IdemPCharU(p, up: PUTF8Char): boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// returns true if the beginning of p^ is same as up^ -// - ignore case - up^ must be already Upper -// - this version expects p^ to point to an Unicode char array -function IdemPCharW(p: PWideChar; up: PUTF8Char): boolean; - -/// check matching ending of p^ in upText -// - returns true if the item matched -// - ignore case - upText^ must be already Upper -// - chars are compared as 7 bit Ansi only (no accentuated characters) -function EndWith(const text, upText: RawUTF8): boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// returns the index of a matching ending of p^ in upArray[] -// - returns -1 if no item matched -// - ignore case - upArray^ must be already Upper -// - chars are compared as 7 bit Ansi only (no accentuated characters) -function EndWithArray(const text: RawUTF8; const upArray: array of RawUTF8): integer; - -/// returns true if the file name extension contained in p^ is the same same as extup^ -// - ignore case - extup^ must be already Upper -// - chars are compared as WinAnsi (codepage 1252), not as UTF-8 -// - could be used e.g. like IdemFileExt(aFileName,'.JP'); -function IdemFileExt(p: PUTF8Char; extup: PAnsiChar; sepChar: AnsiChar='.'): Boolean; - -/// returns matching file name extension index as extup^ -// - ignore case - extup[] must be already Upper -// - chars are compared as WinAnsi (codepage 1252), not as UTF-8 -// - could be used e.g. like IdemFileExts(aFileName,['.PAS','.INC']); -function IdemFileExts(p: PUTF8Char; const extup: array of PAnsiChar; - sepChar: AnsiChar='.'): integer; - -/// internal function, used to retrieve a UCS4 char (>127) from UTF-8 -// - not to be called directly, but from inlined higher-level functions -// - here U^ shall be always >= #80 -// - typical use is as such: -// ! ch := ord(P^); -// ! if ch and $80=0 then -// ! inc(P) else -// ! ch := GetHighUTF8UCS4(P); -function GetHighUTF8UCS4(var U: PUTF8Char): PtrUInt; - -/// retrieve the next UCS4 value stored in U, then update the U pointer -// - this function will decode the UTF-8 content before using NormToUpper[] -// - will return '?' if the UCS4 value is higher than #255: so use this function -// only if you need to deal with ASCII characters (e.g. it's used for Soundex -// and for ContainsUTF8 function) -function GetNextUTF8Upper(var U: PUTF8Char): PtrUInt; - {$ifdef HASINLINE}inline;{$endif} - -/// points to the beginning of the next word stored in U -// - returns nil if reached the end of U (i.e. #0 char) -// - here a "word" is a Win-Ansi word, i.e. '0'..'9', 'A'..'Z' -function FindNextUTF8WordBegin(U: PUTF8Char): PUTF8Char; - -/// return true if up^ is contained inside the UTF-8 buffer p^ -// - search up^ at the beginning of every UTF-8 word (aka in Soundex) -// - here a "word" is a Win-Ansi word, i.e. '0'..'9', 'A'..'Z' -// - up^ must be already Upper -function ContainsUTF8(p, up: PUTF8Char): boolean; - -/// returns TRUE if the supplied uppercased text is contained in the text buffer -function GetLineContains(p,pEnd, up: PUTF8Char): boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// copy source into a 256 chars dest^ buffer with 7 bits upper case conversion -// - used internally for short keys match or case-insensitive hash -// - returns final dest pointer -// - will copy up to 255 AnsiChar (expect the dest buffer to be defined e.g. as -// array[byte] of AnsiChar on the caller stack) -function UpperCopy255(dest: PAnsiChar; const source: RawUTF8): PAnsiChar; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// copy source^ into a 256 chars dest^ buffer with 7 bits upper case conversion -// - used internally for short keys match or case-insensitive hash -// - returns final dest pointer -// - will copy up to 255 AnsiChar (expect the dest buffer to be defined e.g. as -// array[byte] of AnsiChar on the caller stack) -// - won't use SSE4.2 instructions on supported CPUs by default, which may read -// some bytes beyond the s string, so should be avoided e.g. over memory mapped -// files - call explicitely UpperCopy255BufSSE42() if you are confident on your input -var UpperCopy255Buf: function(dest: PAnsiChar; source: PUTF8Char; sourceLen: PtrInt): PAnsiChar; - -/// copy source^ into a 256 chars dest^ buffer with 7 bits upper case conversion -// - used internally for short keys match or case-insensitive hash -// - this version is written in optimized pascal -// - you should not have to call this function, but rely on UpperCopy255Buf() -// - returns final dest pointer -// - will copy up to 255 AnsiChar (expect the dest buffer to be defined e.g. as -// array[byte] of AnsiChar on the caller stack) -function UpperCopy255BufPas(dest: PAnsiChar; source: PUTF8Char; sourceLen: PtrInt): PAnsiChar; - -{$ifndef PUREPASCAL} -{$ifndef DELPHI5OROLDER} -/// SSE 4.2 version of UpperCopy255Buf() -// - copy source^ into a 256 chars dest^ buffer with 7 bits upper case conversion -// - please note that this optimized version may read up to 15 bytes -// beyond the string; this is rarely a problem but it may generate protection -// violations, which could trigger fatal SIGABRT or SIGSEGV on Posix system -// - could be used instead of UpperCopy255Buf() when you are confident about your -// dest/source input buffers, checking if cfSSE42 in CpuFeatures -function UpperCopy255BufSSE42(dest: PAnsiChar; source: PUTF8Char; sourceLen: PtrInt): PAnsiChar; -{$endif DELPHI5OROLDER} -{$endif PUREPASCAL} - -/// copy source into dest^ with WinAnsi 8 bits upper case conversion -// - used internally for short keys match or case-insensitive hash -// - returns final dest pointer -// - will copy up to 255 AnsiChar (expect the dest buffer to be array[byte] of -// AnsiChar) -function UpperCopyWin255(dest: PWinAnsiChar; const source: RawUTF8): PWinAnsiChar; - -/// copy WideChar source into dest^ with upper case conversion -// - used internally for short keys match or case-insensitive hash -// - returns final dest pointer -// - will copy up to 255 AnsiChar (expect the dest buffer to be array[byte] of -// AnsiChar) -function UpperCopy255W(dest: PAnsiChar; const source: SynUnicode): PAnsiChar; overload; - -/// copy WideChar source into dest^ with upper case conversion -// - used internally for short keys match or case-insensitive hash -// - returns final dest pointer -// - will copy up to 255 AnsiChar (expect the dest buffer to be array[byte] of -// AnsiChar) -function UpperCopy255W(dest: PAnsiChar; source: PWideChar; L: integer): PAnsiChar; overload; - -/// copy source into dest^ with 7 bits upper case conversion -// - returns final dest pointer -// - will copy up to the source buffer end: so Dest^ should be big enough - -// which will the case e.g. if Dest := pointer(source) -function UpperCopy(dest: PAnsiChar; const source: RawUTF8): PAnsiChar; - -/// copy source into dest^ with 7 bits upper case conversion -// - returns final dest pointer -// - this special version expect source to be a shortstring -function UpperCopyShort(dest: PAnsiChar; const source: shortstring): PAnsiChar; - -{$ifdef USENORMTOUPPER} - -/// fast UTF-8 comparison using the NormToUpper[] array for all 8 bits values -// - this version expects u1 and u2 to be zero-terminated -// - this version will decode each UTF-8 glyph before using NormToUpper[] -// - current implementation handles UTF-16 surrogates -function UTF8IComp(u1, u2: PUTF8Char): PtrInt; - -/// copy WideChar source into dest^ with upper case conversion, using the -// NormToUpper[] array for all 8 bits values, encoding the result as UTF-8 -// - returns final dest pointer -// - current implementation handles UTF-16 surrogates -function UTF8UpperCopy(Dest, Source: PUTF8Char; SourceChars: Cardinal): PUTF8Char; - -/// copy WideChar source into dest^ with upper case conversion, using the -// NormToUpper[] array for all 8 bits values, encoding the result as UTF-8 -// - returns final dest pointer -// - will copy up to 255 AnsiChar (expect the dest buffer to be array[byte] of -// AnsiChar), with UTF-8 encoding -function UTF8UpperCopy255(dest: PAnsiChar; const source: RawUTF8): PUTF8Char; - {$ifdef HASINLINE}inline;{$endif} - -/// fast UTF-8 comparison using the NormToUpper[] array for all 8 bits values -// - this version expects u1 and u2 not to be necessary zero-terminated, but -// uses L1 and L2 as length for u1 and u2 respectively -// - use this function for SQLite3 collation (TSQLCollateFunc) -// - this version will decode the UTF-8 content before using NormToUpper[] -// - current implementation handles UTF-16 surrogates -function UTF8ILComp(u1, u2: PUTF8Char; L1,L2: cardinal): PtrInt; - -/// fast case-insensitive Unicode comparison -// - use the NormToUpperAnsi7Byte[] array, i.e. compare 'a'..'z' as 'A'..'Z' -// - this version expects u1 and u2 to be zero-terminated -function AnsiICompW(u1, u2: PWideChar): PtrInt; - -/// SameText() overloaded function with proper UTF-8 decoding -// - fast version using NormToUpper[] array for all Win-Ansi characters -// - this version will decode each UTF-8 glyph before using NormToUpper[] -// - current implementation handles UTF-16 surrogates as UTF8IComp() -function SameTextU(const S1, S2: RawUTF8): Boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// fast conversion of the supplied text into 8 bit uppercase -// - this will not only convert 'a'..'z' into 'A'..'Z', but also accentuated -// latin characters ('e' acute into 'E' e.g.), using NormToUpper[] array -// - it will therefore decode the supplied UTF-8 content to handle more than -// 7 bit of ascii characters (so this function is dedicated to WinAnsi code page -// 1252 characters set) -function UpperCaseU(const S: RawUTF8): RawUTF8; - -/// fast conversion of the supplied text into 8 bit lowercase -// - this will not only convert 'A'..'Z' into 'a'..'z', but also accentuated -// latin characters ('E' acute into 'e' e.g.), using NormToLower[] array -// - it will therefore decode the supplied UTF-8 content to handle more than -// 7 bit of ascii characters -function LowerCaseU(const S: RawUTF8): RawUTF8; - -/// fast conversion of the supplied text into 8 bit case sensitivity -// - convert the text in-place, returns the resulting length -// - it will decode the supplied UTF-8 content to handle more than 7 bit -// of ascii characters during the conversion (leaving not WinAnsi characters -// untouched) -// - will not set the last char to #0 (caller must do that if necessary) -function ConvertCaseUTF8(P: PUTF8Char; const Table: TNormTableByte): PtrInt; - -{$endif USENORMTOUPPER} - -/// check if the supplied text has some case-insentitive 'a'..'z','A'..'Z' chars -// - will therefore be correct with true UTF-8 content, but only for 7 bit -function IsCaseSensitive(const S: RawUTF8): boolean; overload; - -/// check if the supplied text has some case-insentitive 'a'..'z','A'..'Z' chars -// - will therefore be correct with true UTF-8 content, but only for 7 bit -function IsCaseSensitive(P: PUTF8Char; PLen: PtrInt): boolean; overload; - -/// fast conversion of the supplied text into uppercase -// - this will only convert 'a'..'z' into 'A'..'Z' (no NormToUpper use), and -// will therefore be correct with true UTF-8 content, but only for 7 bit -function UpperCase(const S: RawUTF8): RawUTF8; - -/// fast conversion of the supplied text into uppercase -// - this will only convert 'a'..'z' into 'A'..'Z' (no NormToUpper use), and -// will therefore be correct with true UTF-8 content, but only for 7 bit -procedure UpperCaseCopy(Text: PUTF8Char; Len: PtrInt; var result: RawUTF8); overload; - -/// fast conversion of the supplied text into uppercase -// - this will only convert 'a'..'z' into 'A'..'Z' (no NormToUpper use), and -// will therefore be correct with true UTF-8 content, but only for 7 bit -procedure UpperCaseCopy(const Source: RawUTF8; var Dest: RawUTF8); overload; - -/// fast in-place conversion of the supplied variable text into uppercase -// - this will only convert 'a'..'z' into 'A'..'Z' (no NormToUpper use), and -// will therefore be correct with true UTF-8 content, but only for 7 bit -procedure UpperCaseSelf(var S: RawUTF8); - -/// fast conversion of the supplied text into lowercase -// - this will only convert 'A'..'Z' into 'a'..'z' (no NormToLower use), and -// will therefore be correct with true UTF-8 content -function LowerCase(const S: RawUTF8): RawUTF8; - -/// fast conversion of the supplied text into lowercase -// - this will only convert 'A'..'Z' into 'a'..'z' (no NormToLower use), and -// will therefore be correct with true UTF-8 content -procedure LowerCaseCopy(Text: PUTF8Char; Len: PtrInt; var result: RawUTF8); - -/// fast in-place conversion of the supplied variable text into lowercase -// - this will only convert 'A'..'Z' into 'a'..'z' (no NormToLower use), and -// will therefore be correct with true UTF-8 content, but only for 7 bit -procedure LowerCaseSelf(var S: RawUTF8); - -/// accurate conversion of the supplied UTF-8 content into the corresponding -// upper-case Unicode characters -// - this version will use the Operating System API, and will therefore be -// much slower than UpperCase/UpperCaseU versions, but will handle all -// kind of unicode characters -function UpperCaseUnicode(const S: RawUTF8): RawUTF8; - -/// accurate conversion of the supplied UTF-8 content into the corresponding -// lower-case Unicode characters -// - this version will use the Operating System API, and will therefore be -// much slower than LowerCase/LowerCaseU versions, but will handle all -// kind of unicode characters -function LowerCaseUnicode(const S: RawUTF8): RawUTF8; - -/// trims leading whitespace characters from the string by removing -// new line, space, and tab characters -function TrimLeft(const S: RawUTF8): RawUTF8; - -/// trims trailing whitespace characters from the string by removing trailing -// newline, space, and tab characters -function TrimRight(const S: RawUTF8): RawUTF8; - -/// single-allocation (therefore faster) alternative to Trim(copy()) -procedure TrimCopy(const S: RawUTF8; start,count: PtrInt; - var result: RawUTF8); - -/// fast WinAnsi comparison using the NormToUpper[] array for all 8 bits values -function AnsiIComp(Str1, Str2: pointer): PtrInt; - {$ifdef PUREPASCAL} {$ifdef HASINLINE}inline;{$endif} {$endif} - -/// extract a line from source array of chars -// - next will contain the beginning of next line, or nil if source if ended -function GetNextLine(source: PUTF8Char; out next: PUTF8Char; andtrim: boolean=false): RawUTF8; - -{$ifdef UNICODE} -/// extract a line from source array of chars -// - next will contain the beginning of next line, or nil if source if ended -// - this special version expect UnicodeString pointers, and return an UnicodeString -function GetNextLineW(source: PWideChar; out next: PWideChar): string; - -/// find the Value of UpperName in P, till end of current section -// - expect UpperName as 'NAME=' -// - this special version expect UnicodeString pointer, and return a VCL string -function FindIniNameValueW(P: PWideChar; UpperName: PUTF8Char): string; - -/// find a Name= Value in a [Section] of a INI Unicode Content -// - this function scans the Content memory buffer, and is -// therefore very fast (no temporary TMemIniFile is created) -// - if Section equals '', find the Name= value before any [Section] -function FindIniEntryW(const Content: string; const Section, Name: RawUTF8): string; -{$endif UNICODE} - -{$ifdef PUREPASCAL} -{$ifdef HASINLINE} -function PosExPas(pSub, p: PUTF8Char; Offset: PtrUInt): PtrInt; -function PosEx(const SubStr, S: RawUTF8; Offset: PtrUInt=1): PtrInt; inline; -{$else} -var PosEx: function(const SubStr, S: RawUTF8; Offset: PtrUInt=1): PtrInt; -{$endif} -{$else} - -/// faster RawUTF8 Equivalent of standard StrUtils.PosEx -function PosEx(const SubStr, S: RawUTF8; Offset: PtrUInt=1): integer; - -{$endif PUREPASCAL} - -/// our own PosEx() function dedicated to VCL string process -// - Delphi XE or older don't support Pos() with an Offset -var PosExString: function(const SubStr, S: string; Offset: PtrUInt=1): PtrInt; - -/// optimized version of PosEx() with search text as one AnsiChar -function PosExChar(Chr: AnsiChar; const Str: RawUTF8): PtrInt; - {$ifdef HASINLINE}inline;{$endif} - -/// split a RawUTF8 string into two strings, according to SepStr separator -// - if SepStr is not found, LeftStr=Str and RightStr='' -// - if ToUpperCase is TRUE, then LeftStr and RightStr will be made uppercase -procedure Split(const Str, SepStr: RawUTF8; var LeftStr, RightStr: RawUTF8; ToUpperCase: boolean=false); overload; - -/// split a RawUTF8 string into two strings, according to SepStr separator -// - this overloaded function returns the right string as function result -// - if SepStr is not found, LeftStr=Str and result='' -// - if ToUpperCase is TRUE, then LeftStr and result will be made uppercase -function Split(const Str, SepStr: RawUTF8; var LeftStr: RawUTF8; ToUpperCase: boolean=false): RawUTF8; overload; - -/// returns the left part of a RawUTF8 string, according to SepStr separator -// - if SepStr is found, returns Str first chars until (and excluding) SepStr -// - if SepStr is not found, returns Str -function Split(const Str, SepStr: RawUTF8; StartPos: integer=1): RawUTF8; overload; - -/// split a RawUTF8 string into several strings, according to SepStr separator -// - this overloaded function will fill a DestPtr[] array of PRawUTF8 -// - if any DestPtr[]=nil, the item will be skipped -// - if input Str end before al SepStr[] are found, DestPtr[] is set to '' -// - returns the number of values extracted into DestPtr[] -function Split(const Str: RawUTF8; const SepStr: array of RawUTF8; - const DestPtr: array of PRawUTF8): PtrInt; overload; - -/// returns the last occurence of the given SepChar separated context -// - e.g. SplitRight('01/2/34','/')='34' -// - if SepChar doesn't appear, will return Str, e.g. SplitRight('123','/')='123' -// - if LeftStr is supplied, the RawUTF8 it points to will be filled with -// the left part just before SepChar ('' if SepChar doesn't appear) -function SplitRight(const Str: RawUTF8; SepChar: AnsiChar; LeftStr: PRawUTF8=nil): RawUTF8; - -/// returns the last occurence of the given SepChar separated context -// - e.g. SplitRight('path/one\two/file.ext','/\')='file.ext', i.e. -// SepChars='/\' will be like ExtractFileName() over RawUTF8 string -// - if SepChar doesn't appear, will return Str, e.g. SplitRight('123','/')='123' -function SplitRights(const Str, SepChar: RawUTF8): RawUTF8; - -/// actual replacement function called by StringReplaceAll() on first match -// - not to be called as such, but defined globally for proper inlining -function StringReplaceAllProcess(const S, OldPattern, NewPattern: RawUTF8; - found: integer): RawUTF8; - -/// fast version of StringReplace(S, OldPattern, NewPattern,[rfReplaceAll]); -function StringReplaceAll(const S, OldPattern, NewPattern: RawUTF8): RawUTF8; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// fast version of several cascaded StringReplaceAll() -function StringReplaceAll(const S: RawUTF8; const OldNewPatternPairs: array of RawUTF8): RawUTF8; overload; - -/// fast replace of a specified char by a given string -function StringReplaceChars(const Source: RawUTF8; OldChar, NewChar: AnsiChar): RawUTF8; - -/// fast replace of all #9 chars by a given string -function StringReplaceTabs(const Source,TabText: RawUTF8): RawUTF8; - -/// format a text content with SQL-like quotes -// - UTF-8 version of the function available in SysUtils -// - this function implements what is specified in the official SQLite3 -// documentation: "A string constant is formed by enclosing the string in single -// quotes ('). A single quote within the string can be encoded by putting two -// single quotes in a row - as in Pascal." -function QuotedStr(const S: RawUTF8; Quote: AnsiChar=''''): RawUTF8; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// format a text content with SQL-like quotes -// - UTF-8 version of the function available in SysUtils -// - this function implements what is specified in the official SQLite3 -// documentation: "A string constant is formed by enclosing the string in single -// quotes ('). A single quote within the string can be encoded by putting two -// single quotes in a row - as in Pascal." -procedure QuotedStr(const S: RawUTF8; Quote: AnsiChar; var result: RawUTF8); overload; - -/// convert UTF-8 content into a JSON string -// - with proper escaping of the content, and surounding " characters -procedure QuotedStrJSON(const aText: RawUTF8; var result: RawUTF8; - const aPrefix: RawUTF8=''; const aSuffix: RawUTF8=''); overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert UTF-8 buffer into a JSON string -// - with proper escaping of the content, and surounding " characters -procedure QuotedStrJSON(P: PUTF8Char; PLen: PtrInt; var result: RawUTF8; - const aPrefix: RawUTF8=''; const aSuffix: RawUTF8=''); overload; - -/// convert UTF-8 content into a JSON string -// - with proper escaping of the content, and surounding " characters -function QuotedStrJSON(const aText: RawUTF8): RawUTF8; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// unquote a SQL-compatible string -// - the first character in P^ must be either ' or " then internal double quotes -// are transformed into single quotes -// - 'text '' end' -> text ' end -// - "text "" end" -> text " end -// - returns nil if P doesn't contain a valid SQL string -// - returns a pointer just after the quoted text otherwise -function UnQuoteSQLStringVar(P: PUTF8Char; out Value: RawUTF8): PUTF8Char; - -/// unquote a SQL-compatible string -function UnQuoteSQLString(const Value: RawUTF8): RawUTF8; - -/// unquote a SQL-compatible symbol name -// - e.g. '[symbol]' -> 'symbol' or '"symbol"' -> 'symbol' -function UnQuotedSQLSymbolName(const ExternalDBSymbol: RawUTF8): RawUTF8; - -/// get the next character after a quoted buffer -// - the first character in P^ must be either ', either " -// - it will return the latest quote position, ignoring double quotes within -function GotoEndOfQuotedString(P: PUTF8Char): PUTF8Char; - {$ifdef HASINLINE}inline;{$endif} - -/// get the next character after a quoted buffer -// - the first character in P^ must be " -// - it will return the latest " position, ignoring \" within -function GotoEndOfJSONString(P: PUTF8Char): PUTF8Char; - {$ifdef HASINLINE}inline;{$endif} - -/// get the next character not in [#1..' '] -function GotoNextNotSpace(P: PUTF8Char): PUTF8Char; - {$ifdef HASINLINE}inline;{$endif} - -/// get the next character not in [#9,' '] -function GotoNextNotSpaceSameLine(P: PUTF8Char): PUTF8Char; - {$ifdef HASINLINE}inline;{$endif} - -/// get the next character in [#1..' '] -function GotoNextSpace(P: PUTF8Char): PUTF8Char; - {$ifdef HASINLINE}inline;{$endif} - -/// check if the next character not in [#1..' '] matchs a given value -// - first ignore any non space character -// - then returns TRUE if P^=ch, setting P to the character after ch -// - or returns FALSE if P^<>ch, leaving P at the level of the unexpected char -function NextNotSpaceCharIs(var P: PUTF8Char; ch: AnsiChar): boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// go to the beginning of the SQL statement, ignoring all blanks and comments -// - used to check the SQL statement command (e.g. is it a SELECT?) -function SQLBegin(P: PUTF8Char): PUTF8Char; - -/// add a condition to a SQL WHERE clause, with an ' and ' if where is not void -procedure SQLAddWhereAnd(var where: RawUTF8; const condition: RawUTF8); - -/// return true if the parameter is void or begin with a 'SELECT' SQL statement -// - used to avoid code injection and to check if the cache must be flushed -// - VACUUM, PRAGMA, or EXPLAIN statements also return true, since they won't -// change the data content -// - WITH recursive statement expect no INSERT/UPDATE/DELETE pattern in the SQL -// - if P^ is a SELECT and SelectClause is set to a variable, it would -// contain the field names, from SELECT ...field names... FROM -function isSelect(P: PUTF8Char; SelectClause: PRawUTF8=nil): boolean; - -/// return true if IdemPChar(source,searchUp), and go to the next line of source -function IdemPCharAndGetNextLine(var source: PUTF8Char; searchUp: PAnsiChar): boolean; - -/// return true if IdemPChar(source,searchUp), and retrieve the value item -// - typical use may be: -// ! if IdemPCharAndGetNextItem(P, -// ! 'CONTENT-DISPOSITION: FORM-DATA; NAME="',Name,'"') then ... -function IdemPCharAndGetNextItem(var source: PUTF8Char; const searchUp: RawUTF8; - var Item: RawUTF8; Sep: AnsiChar=#13): boolean; - -/// fast go to next text line, ended by #13 or #13#10 -// - returns the beginning of next line, or nil if source^=#0 was reached -function GotoNextLine(source: PUTF8Char): PUTF8Char; - {$ifdef HASINLINE}inline;{$endif} - -/// compute the line length from a size-delimited source array of chars -// - will use fast assembly on x86-64 CPU, and expects TextEnd to be not nil -// - is likely to read some bytes after the TextEnd buffer, so GetLineSize() -// may be preferred, e.g. on memory mapped files -function BufferLineLength(Text, TextEnd: PUTF8Char): PtrInt; - {$ifndef CPUX64}{$ifdef HASINLINE}inline;{$endif}{$endif} - -/// compute the line length from source array of chars -// - if PEnd = nil, end counting at either #0, #13 or #10 -// - otherwise, end counting at either #13 or #10 -// - just a wrapper around BufferLineLength() checking PEnd=nil case -function GetLineSize(P,PEnd: PUTF8Char): PtrUInt; - {$ifdef HASINLINE}inline;{$endif} - -/// returns true if the line length from source array of chars is not less than -// the specified count -function GetLineSizeSmallerThan(P,PEnd: PUTF8Char; aMinimalCount: integer): boolean; - -/// return next CSV string from P -// - P=nil after call when end of text is reached -function GetNextItem(var P: PUTF8Char; Sep: AnsiChar= ','): RawUTF8; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// return next CSV string from P -// - P=nil after call when end of text is reached -procedure GetNextItem(var P: PUTF8Char; Sep: AnsiChar; var result: RawUTF8); overload; - -/// return next CSV string (unquoted if needed) from P -// - P=nil after call when end of text is reached -procedure GetNextItem(var P: PUTF8Char; Sep, Quote: AnsiChar; var result: RawUTF8); overload; - -/// return trimmed next CSV string from P -// - P=nil after call when end of text is reached -procedure GetNextItemTrimed(var P: PUTF8Char; Sep: AnsiChar; var result: RawUTF8); - -/// return next CRLF separated value string from P, ending #10 or #13#10 trimmed -// - any kind of line feed (CRLF or LF) will be handled, on all operating systems -// - as used e.g. by TSynNameValue.InitFromCSV and TDocVariantData.InitCSV -// - P=nil after call when end of text is reached -procedure GetNextItemTrimedCRLF(var P: PUTF8Char; var result: RawUTF8); - -/// return next CSV string from P, nil if no more -// - this function returns the generic string type of the compiler, and -// therefore can be used with ready to be displayed text (e.g. for the VCL) -function GetNextItemString(var P: PChar; Sep: Char= ','): string; - -/// return next string delimited with #13#10 from P, nil if no more -// - this function returns a RawUnicode string type -function GetNextStringLineToRawUnicode(var P: PChar): RawUnicode; - -/// append some text lines with the supplied Values[] -// - if any Values[] item is '', no line is added -// - otherwise, appends 'Caption: Value', with Caption taken from CSV -procedure AppendCSVValues(const CSV: string; const Values: array of string; - var Result: string; const AppendBefore: string=#13#10); - -/// return a CSV list of the iterated same value -// - e.g. CSVOfValue('?',3)='?,?,?' -function CSVOfValue(const Value: RawUTF8; Count: cardinal; const Sep: RawUTF8=','): RawUTF8; - - /// retrieve the next CSV separated bit index -// - each bit was stored as BitIndex+1, i.e. 0 to mark end of CSV chunk -// - several bits set to one can be regrouped via 'first-last,' syntax -procedure SetBitCSV(var Bits; BitsCount: integer; var P: PUTF8Char); - -/// convert a set of bit into a CSV content -// - each bit is stored as BitIndex+1, and separated by a ',' -// - several bits set to one can be regrouped via 'first-last,' syntax -// - ',0' is always appended at the end of the CSV chunk to mark its end -function GetBitCSV(const Bits; BitsCount: integer): RawUTF8; - -/// return next CSV string from P, nil if no more -// - output text would be trimmed from any left or right space -procedure GetNextItemShortString(var P: PUTF8Char; out Dest: ShortString; Sep: AnsiChar= ','); - -/// decode next CSV hexadecimal string from P, nil if no more or not matching BinBytes -// - Bin is filled with 0 if the supplied CSV content is invalid -// - if Sep is #0, it will read the hexadecimal chars until a whitespace is reached -function GetNextItemHexDisplayToBin(var P: PUTF8Char; Bin: PByte; BinBytes: integer; - Sep: AnsiChar= ','): boolean; - - -type - /// some stack-allocated zero-terminated character buffer - // - as used by GetNextTChar64 - TChar64 = array[0..63] of AnsiChar; - -/// return next CSV string from P as a #0-ended buffer, false if no more -// - if Sep is #0, will copy all characters until next whitespace char -// - returns the number of bytes stored into Buf[] -function GetNextTChar64(var P: PUTF8Char; Sep: AnsiChar; out Buf: TChar64): PtrInt; - -/// return next CSV string as unsigned integer from P, 0 if no more -// - if Sep is #0, it won't be searched for -function GetNextItemCardinal(var P: PUTF8Char; Sep: AnsiChar=','): PtrUInt; - -/// return next CSV string as signed integer from P, 0 if no more -// - if Sep is #0, it won't be searched for -function GetNextItemInteger(var P: PUTF8Char; Sep: AnsiChar=','): PtrInt; - -/// return next CSV string as 64-bit signed integer from P, 0 if no more -// - if Sep is #0, it won't be searched for -function GetNextItemInt64(var P: PUTF8Char; Sep: AnsiChar=','): Int64; - -/// return next CSV string as 64-bit unsigned integer from P, 0 if no more -// - if Sep is #0, it won't be searched for -function GetNextItemQWord(var P: PUTF8Char; Sep: AnsiChar=','): QWord; - -/// return next CSV hexadecimal string as 64-bit unsigned integer from P -// - returns 0 if no valid hexadecimal text is available in P -// - if Sep is #0, it won't be searched for -// - will first fill the 64-bit value with 0, then decode each two hexadecimal -// characters available in P -// - could be used to decode TTextWriter.AddBinToHexDisplayMinChars() output -function GetNextItemHexa(var P: PUTF8Char; Sep: AnsiChar=','): QWord; - -/// return next CSV string as unsigned integer from P, 0 if no more -// - P^ will point to the first non digit character (the item separator, e.g. -// ',' for CSV) -function GetNextItemCardinalStrict(var P: PUTF8Char): PtrUInt; - -/// return next CSV string as unsigned integer from P, 0 if no more -// - this version expects P^ to point to an Unicode char array -function GetNextItemCardinalW(var P: PWideChar; Sep: WideChar=','): PtrUInt; - -/// return next CSV string as double from P, 0.0 if no more -// - if Sep is #0, will return all characters until next whitespace char -function GetNextItemDouble(var P: PUTF8Char; Sep: AnsiChar=','): double; - -/// return next CSV string as currency from P, 0.0 if no more -// - if Sep is #0, will return all characters until next whitespace char -function GetNextItemCurrency(var P: PUTF8Char; Sep: AnsiChar=','): currency; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// return next CSV string as currency from P, 0.0 if no more -// - if Sep is #0, will return all characters until next whitespace char -procedure GetNextItemCurrency(var P: PUTF8Char; out result: currency; Sep: AnsiChar=','); overload; - -/// return n-th indexed CSV string in P, starting at Index=0 for first one -function GetCSVItem(P: PUTF8Char; Index: PtrUInt; Sep: AnsiChar=','): RawUTF8; overload; - -/// return n-th indexed CSV string (unquoted if needed) in P, starting at Index=0 for first one -function GetUnQuoteCSVItem(P: PUTF8Char; Index: PtrUInt; Sep: AnsiChar=','; Quote: AnsiChar=''''): RawUTF8; overload; - -/// return n-th indexed CSV string in P, starting at Index=0 for first one -// - this function return the generic string type of the compiler, and -// therefore can be used with ready to be displayed text (i.e. the VCL) -function GetCSVItemString(P: PChar; Index: PtrUInt; Sep: Char=','): string; - -/// return last CSV string in the supplied UTF-8 content -function GetLastCSVItem(const CSV: RawUTF8; Sep: AnsiChar=','): RawUTF8; - -/// return the index of a Value in a CSV string -// - start at Index=0 for first one -// - return -1 if specified Value was not found in CSV items -function FindCSVIndex(CSV: PUTF8Char; const Value: RawUTF8; Sep: AnsiChar = ','; - CaseSensitive: boolean=true; TrimValue: boolean=false): integer; - -/// add the strings in the specified CSV text into a dynamic array of UTF-8 strings -procedure CSVToRawUTF8DynArray(CSV: PUTF8Char; var Result: TRawUTF8DynArray; - Sep: AnsiChar=','; TrimItems: boolean=false; AddVoidItems: boolean=false); overload; - -/// add the strings in the specified CSV text into a dynamic array of UTF-8 strings -procedure CSVToRawUTF8DynArray(const CSV,Sep,SepEnd: RawUTF8; var Result: TRawUTF8DynArray); overload; - -/// return the corresponding CSV text from a dynamic array of UTF-8 strings -function RawUTF8ArrayToCSV(const Values: array of RawUTF8; const Sep: RawUTF8= ','): RawUTF8; - -/// return the corresponding CSV quoted text from a dynamic array of UTF-8 strings -// - apply QuoteStr() function to each Values[] item -function RawUTF8ArrayToQuotedCSV(const Values: array of RawUTF8; const Sep: RawUTF8=','; - Quote: AnsiChar=''''): RawUTF8; - -/// append some prefix to all CSV values -// ! AddPrefixToCSV('One,Two,Three','Pre')='PreOne,PreTwo,PreThree' -function AddPrefixToCSV(CSV: PUTF8Char; const Prefix: RawUTF8; - Sep: AnsiChar = ','): RawUTF8; - -/// append a Value to a CSV string -procedure AddToCSV(const Value: RawUTF8; var CSV: RawUTF8; const Sep: RawUTF8 = ','); - {$ifdef HASINLINE}inline;{$endif} - -/// change a Value within a CSV string -function RenameInCSV(const OldValue, NewValue: RawUTF8; var CSV: RawUTF8; - const Sep: RawUTF8 = ','): boolean; - -/// quick helper to initialize a dynamic array of RawUTF8 from some constants -// - can be used e.g. as: -// ! MyArray := TRawUTF8DynArrayFrom(['a','b','c']); -function TRawUTF8DynArrayFrom(const Values: array of RawUTF8): TRawUTF8DynArray; - -/// check if the TypeInfo() points to an "array of RawUTF8" -// - e.g. returns true for TypeInfo(TRawUTF8DynArray) or other sub-types -// defined as "type aNewType = type TRawUTF8DynArray" -function IsRawUTF8DynArray(typeinfo: pointer): boolean; - -/// append one or several values to a local "array of const" variable -procedure AddArrayOfConst(var Dest: TTVarRecDynArray; const Values: array of const); - -/// low-level efficient search of Value in Values[] -// - CaseSensitive=false will use StrICmp() for A..Z / a..z equivalence -function FindRawUTF8(Values: PRawUTF8; const Value: RawUTF8; ValuesCount: integer; - CaseSensitive: boolean): integer; overload; - -/// return the index of Value in Values[], -1 if not found -// - CaseSensitive=false will use StrICmp() for A..Z / a..z equivalence -function FindRawUTF8(const Values: TRawUTF8DynArray; const Value: RawUTF8; - CaseSensitive: boolean=true): integer; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// return the index of Value in Values[], -1 if not found -// - CaseSensitive=false will use StrICmp() for A..Z / a..z equivalence -function FindRawUTF8(const Values: array of RawUTF8; const Value: RawUTF8; - CaseSensitive: boolean=true): integer; overload; - -/// return the index of Value in Values[], -1 if not found -// - here name search would use fast IdemPropNameU() function -function FindPropName(const Names: array of RawUTF8; const Name: RawUTF8): integer; overload; - -/// return the index of Value in Values[] using IdemPropNameU(), -1 if not found -// - typical use with a dynamic array is like: -// ! index := FindPropName(pointer(aDynArray),length(aDynArray),aValue); -function FindPropName(Values: PRawUTF8; const Value: RawUTF8; - ValuesCount: integer): integer; overload; - -/// true if Value was added successfully in Values[] -function AddRawUTF8(var Values: TRawUTF8DynArray; const Value: RawUTF8; - NoDuplicates: boolean=false; CaseSensitive: boolean=true): boolean; overload; - -/// add the Value to Values[], with an external count variable, for performance -procedure AddRawUTF8(var Values: TRawUTF8DynArray; var ValuesCount: integer; - const Value: RawUTF8); overload; - -/// true if both TRawUTF8DynArray are the same -// - comparison is case-sensitive -function RawUTF8DynArrayEquals(const A,B: TRawUTF8DynArray): boolean; overload; - -/// true if both TRawUTF8DynArray are the same for a given number of items -// - A and B are expected to have at least Count items -// - comparison is case-sensitive -function RawUTF8DynArrayEquals(const A,B: TRawUTF8DynArray; Count: integer): boolean; overload; - -/// convert the string dynamic array into a dynamic array of UTF-8 strings -procedure StringDynArrayToRawUTF8DynArray(const Source: TStringDynArray; - var Result: TRawUTF8DynArray); - -/// convert the string list into a dynamic array of UTF-8 strings -procedure StringListToRawUTF8DynArray(Source: TStringList; var Result: TRawUTF8DynArray); - -/// search for a value from its uppercased named entry -// - i.e. iterate IdemPChar(source,UpperName) over every line of the source -// - returns the text just after UpperName if it has been found at line beginning -// - returns nil if UpperName was not found was not found at any line beginning -// - could be used as alternative to FindIniNameValue() and FindIniNameValueInteger() -// if there is no section, i.e. if search should not stop at '[' but at source end -function FindNameValue(P: PUTF8Char; UpperName: PAnsiChar): PUTF8Char; overload; - -/// search and returns a value from its uppercased named entry -// - i.e. iterate IdemPChar(source,UpperName) over every line of the source -// - returns true and the trimmed text just after UpperName if it has been found -// at line beginning -// - returns false if UpperName was not found was not found at any line beginning -// - could be used e.g. to efficently extract a value from HTTP headers, whereas -// FindIniNameValue() is tuned for [section]-oriented INI files -function FindNameValue(const NameValuePairs: RawUTF8; UpperName: PAnsiChar; - var Value: RawUTF8): boolean; overload; - -/// find a Name= Value in a [Section] of a INI RawUTF8 Content -// - this function scans the Content memory buffer, and is -// therefore very fast (no temporary TMemIniFile is created) -// - if Section equals '', find the Name= value before any [Section] -function FindIniEntry(const Content, Section,Name: RawUTF8): RawUTF8; - -/// find a Name= Value in a [Section] of a INI WinAnsi Content -// - same as FindIniEntry(), but the value is converted from WinAnsi into UTF-8 -function FindWinAnsiIniEntry(const Content, Section,Name: RawUTF8): RawUTF8; - -/// find a Name= numeric Value in a [Section] of a INI RawUTF8 Content and -// return it as an integer, or 0 if not found -// - this function scans the Content memory buffer, and is -// therefore very fast (no temporary TMemIniFile is created) -// - if Section equals '', find the Name= value before any [Section] -function FindIniEntryInteger(const Content, Section,Name: RawUTF8): integer; - {$ifdef HASINLINE}inline;{$endif} - -/// find a Name= Value in a [Section] of a .INI file -// - if Section equals '', find the Name= value before any [Section] -// - use internaly fast FindIniEntry() function above -function FindIniEntryFile(const FileName: TFileName; const Section,Name: RawUTF8): RawUTF8; - -/// update a Name= Value in a [Section] of a INI RawUTF8 Content -// - this function scans and update the Content memory buffer, and is -// therefore very fast (no temporary TMemIniFile is created) -// - if Section equals '', update the Name= value before any [Section] -procedure UpdateIniEntry(var Content: RawUTF8; const Section,Name,Value: RawUTF8); - -/// update a Name= Value in a [Section] of a .INI file -// - if Section equals '', update the Name= value before any [Section] -// - use internaly fast UpdateIniEntry() function above -procedure UpdateIniEntryFile(const FileName: TFileName; const Section,Name,Value: RawUTF8); - -/// find the position of the [SEARCH] section in source -// - return true if [SEARCH] was found, and store pointer to the line after it in source -function FindSectionFirstLine(var source: PUTF8Char; search: PAnsiChar): boolean; - -/// find the position of the [SEARCH] section in source -// - return true if [SEARCH] was found, and store pointer to the line after it in source -// - this version expects source^ to point to an Unicode char array -function FindSectionFirstLineW(var source: PWideChar; search: PUTF8Char): boolean; - -/// retrieve the whole content of a section as a string -// - SectionFirstLine may have been obtained by FindSectionFirstLine() function above -function GetSectionContent(SectionFirstLine: PUTF8Char): RawUTF8; overload; - -/// retrieve the whole content of a section as a string -// - use SectionFirstLine() then previous GetSectionContent() -function GetSectionContent(const Content, SectionName: RawUTF8): RawUTF8; overload; - -/// delete a whole [Section] -// - if EraseSectionHeader is TRUE (default), then the [Section] line is also -// deleted together with its content lines -// - return TRUE if something was changed in Content -// - return FALSE if [Section] doesn't exist or is already void -function DeleteSection(var Content: RawUTF8; const SectionName: RawUTF8; - EraseSectionHeader: boolean=true): boolean; overload; - -/// delete a whole [Section] -// - if EraseSectionHeader is TRUE (default), then the [Section] line is also -// deleted together with its content lines -// - return TRUE if something was changed in Content -// - return FALSE if [Section] doesn't exist or is already void -// - SectionFirstLine may have been obtained by FindSectionFirstLine() function above -function DeleteSection(SectionFirstLine: PUTF8Char; var Content: RawUTF8; - EraseSectionHeader: boolean=true): boolean; overload; - -/// replace a whole [Section] content by a new content -// - create a new [Section] if none was existing -procedure ReplaceSection(var Content: RawUTF8; const SectionName, - NewSectionContent: RawUTF8); overload; - -/// replace a whole [Section] content by a new content -// - create a new [Section] if none was existing -// - SectionFirstLine may have been obtained by FindSectionFirstLine() function above -procedure ReplaceSection(SectionFirstLine: PUTF8Char; - var Content: RawUTF8; const NewSectionContent: RawUTF8); overload; - -/// return TRUE if Value of UpperName does exist in P, till end of current section -// - expect UpperName as 'NAME=' -function ExistsIniName(P: PUTF8Char; UpperName: PAnsiChar): boolean; - -/// find the Value of UpperName in P, till end of current section -// - expect UpperName as 'NAME=' -function FindIniNameValue(P: PUTF8Char; UpperName: PAnsiChar): RawUTF8; - -/// return TRUE if one of the Value of UpperName exists in P, till end of -// current section -// - expect UpperName e.g. as 'CONTENT-TYPE: ' -// - expect UpperValues to be any upper value with left side matching, e.g. as -// used by IsHTMLContentTypeTextual() function: -// ! result := ExistsIniNameValue(htmlHeaders,HEADER_CONTENT_TYPE_UPPER, -// ! ['TEXT/','APPLICATION/JSON','APPLICATION/XML']); -// - warning: this function calls IdemPCharArray(), so expects UpperValues[] -/// items to have AT LEAST TWO CHARS (it will use fast initial 2 bytes compare) -function ExistsIniNameValue(P: PUTF8Char; const UpperName: RawUTF8; - const UpperValues: array of PAnsiChar): boolean; - -/// find the integer Value of UpperName in P, till end of current section -// - expect UpperName as 'NAME=' -// - return 0 if no NAME= entry was found -function FindIniNameValueInteger(P: PUTF8Char; UpperName: PAnsiChar): PtrInt; - {$ifdef HASINLINE}inline;{$endif} - -/// replace a value from a given set of name=value lines -// - expect UpperName as 'UPPERNAME=', otherwise returns false -// - if no UPPERNAME= entry was found, then Name+NewValue is added to Content -// - a typical use may be: -// ! UpdateIniNameValue(headers,HEADER_CONTENT_TYPE,HEADER_CONTENT_TYPE_UPPER,contenttype); -function UpdateIniNameValue(var Content: RawUTF8; const Name, UpperName, NewValue: RawUTF8): boolean; - -/// read a File content into a String -// - content can be binary or text -// - returns '' if file was not found or any read error occured -// - wil use GetFileSize() API by default, unless HasNoSize is defined, -// and read will be done using a buffer (required e.g. for char files under Linux) -// - uses RawByteString for byte storage, whatever the codepage is -function StringFromFile(const FileName: TFileName; HasNoSize: boolean=false): RawByteString; - -/// create a File from a string content -// - uses RawByteString for byte storage, whatever the codepage is -function FileFromString(const Content: RawByteString; const FileName: TFileName; - FlushOnDisk: boolean=false; FileDate: TDateTime=0): boolean; - -/// get text File contents (even Unicode or UTF8) and convert it into a -// Charset-compatible AnsiString (for Delphi 7) or an UnicodeString (for Delphi -// 2009 and up) according to any BOM marker at the beginning of the file -// - before Delphi 2009, the current string code page is used (i.e. CurrentAnsiConvert) -function AnyTextFileToString(const FileName: TFileName; ForceUTF8: boolean=false): string; - -/// get text file contents (even Unicode or UTF8) and convert it into an -// Unicode string according to any BOM marker at the beginning of the file -// - any file without any BOM marker will be interpreted as plain ASCII: in this -// case, the current string code page is used (i.e. CurrentAnsiConvert class) -function AnyTextFileToSynUnicode(const FileName: TFileName; ForceUTF8: boolean=false): SynUnicode; - -/// get text file contents (even Unicode or UTF8) and convert it into an -// UTF-8 string according to any BOM marker at the beginning of the file -// - if AssumeUTF8IfNoBOM is FALSE, the current string code page is used (i.e. -// CurrentAnsiConvert class) for conversion from ANSI into UTF-8 -// - if AssumeUTF8IfNoBOM is TRUE, any file without any BOM marker will be -// interpreted as UTF-8 -function AnyTextFileToRawUTF8(const FileName: TFileName; AssumeUTF8IfNoBOM: boolean=false): RawUTF8; - -/// read a TStream content into a String -// - it will read binary or text content from the current position until the -// end (using TStream.Size) -// - uses RawByteString for byte storage, whatever the codepage is -function StreamToRawByteString(aStream: TStream): RawByteString; - -/// create a TStream from a string content -// - uses RawByteString for byte storage, whatever the codepage is -// - in fact, the returned TStream is a TRawByteString instance, since this -// function is just a wrapper around: -// ! result := TRawByteStringStream.Create(aString); -function RawByteStringToStream(const aString: RawByteString): TStream; - {$ifdef HASINLINE}inline;{$endif} - -/// read an UTF-8 text from a TStream -// - format is Length(Integer):Text, i.e. the one used by WriteStringToStream -// - will return '' if there is no such text in the stream -// - you can set a MaxAllowedSize value, if you know how long the size should be -// - it will read from the current position in S: so if you just write into S, -// it could be a good idea to rewind it before call, e.g.: -// ! WriteStringToStream(Stream,aUTF8Text); -// ! Stream.Seek(0,soBeginning); -// ! str := ReadStringFromStream(Stream); -function ReadStringFromStream(S: TStream; MaxAllowedSize: integer=255): RawUTF8; - -/// write an UTF-8 text into a TStream -// - format is Length(Integer):Text, i.e. the one used by ReadStringFromStream -function WriteStringToStream(S: TStream; const Text: RawUTF8): boolean; - -/// get a file date and time, from its name -// - returns 0 if file doesn't exist -// - under Windows, will use GetFileAttributesEx fast API -function FileAgeToDateTime(const FileName: TFileName): TDateTime; - -/// get a file size, from its name -// - returns 0 if file doesn't exist -// - under Windows, will use GetFileAttributesEx fast API -function FileSize(const FileName: TFileName): Int64; overload; - -/// get a file size, from its handle -// - returns 0 if file doesn't exist -function FileSize(F: THandle): Int64; overload; - -/// get low-level file information, in a cross-platform way -// - returns true on success -// - here file write/creation time are given as TUnixMSTime values, for better -// cross-platform process - note that FileCreateDateTime may not be supported -// by most Linux file systems, so the oldest timestamp available is returned -// as failover on such systems (probably the latest file metadata writing) -function FileInfoByHandle(aFileHandle: THandle; out FileId, FileSize, - LastWriteAccess, FileCreateDateTime: Int64): Boolean; - -/// get a file date and time, from a FindFirst/FindNext search -// - the returned timestamp is in local time, not UTC -// - this method would use the F.Timestamp field available since Delphi XE2 -function SearchRecToDateTime(const F: TSearchRec): TDateTime; - {$ifdef HASINLINE}inline;{$endif} - -/// check if a FindFirst/FindNext found instance is actually a file -function SearchRecValidFile(const F: TSearchRec): boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// check if a FindFirst/FindNext found instance is actually a folder -function SearchRecValidFolder(const F: TSearchRec): boolean; - {$ifdef HASINLINE}inline;{$endif} - -const - /// operating-system dependent wildchar to match all files in a folder - FILES_ALL = {$ifdef MSWINDOWS}'*.*'{$else}'*'{$endif}; - -/// delete the content of a specified directory -// - only one level of file is deleted within the folder: no recursive deletion -// is processed by this function (for safety) -// - if DeleteOnlyFilesNotDirectory is TRUE, it won't remove the folder itself, -// but just the files found in it -function DirectoryDelete(const Directory: TFileName; const Mask: TFileName=FILES_ALL; - DeleteOnlyFilesNotDirectory: Boolean=false; DeletedCount: PInteger=nil): Boolean; - -/// delete the files older than a given age in a specified directory -// - for instance, to delete all files older than one day: -// ! DirectoryDeleteOlderFiles(FolderName, 1); -// - only one level of file is deleted within the folder: no recursive deletion -// is processed by this function, unless Recursive is TRUE -// - if Recursive=true, caller should set TotalSize^=0 to have an accurate value -function DirectoryDeleteOlderFiles(const Directory: TFileName; TimePeriod: TDateTime; - const Mask: TFileName=FILES_ALL; Recursive: Boolean=false; TotalSize: PInt64=nil): Boolean; - -/// creates a directory if not already existing -// - returns the full expanded directory name, including trailing backslash -// - returns '' on error, unless RaiseExceptionOnCreationFailure=true -function EnsureDirectoryExists(const Directory: TFileName; - RaiseExceptionOnCreationFailure: boolean=false): TFileName; - -/// check if the directory is writable for the current user -// - try to write a small file with a random name -function IsDirectoryWritable(const Directory: TFileName): boolean; - -/// compute an unique temporary file name -// - following 'exename_01234567.tmp' pattern, in the system temporary folder -function TemporaryFileName: TFileName; - -type - {$A-} - /// file found result item, as returned by FindFiles() - // - Delphi "object" is buggy on stack -> also defined as record with methods - {$ifdef USERECORDWITHMETHODS}TFindFiles = record - {$else}TFindFiles = object{$endif} - public - /// the matching file name, including its folder name - Name: TFileName; - /// the matching file attributes - Attr: Integer; - /// the matching file size - Size: Int64; - /// the matching file date/time - Timestamp: TDateTime; - /// fill the item properties from a FindFirst/FindNext's TSearchRec - procedure FromSearchRec(const Directory: TFileName; const F: TSearchRec); - /// returns some ready-to-be-loggued text - function ToText: shortstring; - end; - {$A+} - /// result list, as returned by FindFiles() - TFindFilesDynArray = array of TFindFiles; - - /// a pointer to a TFileName variable - PFileName = ^TFileName; - -/// search for matching file names -// - just a wrapper around FindFirst/FindNext -// - you may specify several masks in Mask, e.g. as '*.jpg;*.jpeg' -function FindFiles(const Directory,Mask: TFileName; - const IgnoreFileName: TFileName=''; SortByName: boolean=false; - IncludesDir: boolean=true; SubFolder: Boolean=false): TFindFilesDynArray; - -/// convert a result list, as returned by FindFiles(), into an array of Files[].Name -function FindFilesDynArrayToFileNames(const Files: TFindFilesDynArray): TFileNameDynArray; - -/// ensure all files in Dest folder(s) do match the one in Reference -// - won't copy all files from Reference folders, but only update files already -// existing in Dest, which did change since last synchronization -// - will also process recursively nested folders if SubFolder is true -// - will use file content instead of file date check if ByContent is true -// - can optionally write the synched file name to the console -// - returns the number of files copied during the process -function SynchFolders(const Reference, Dest: TFileName; SubFolder: boolean=false; - ByContent: boolean=false; WriteFileNameToConsole: boolean=false): integer; - -{$ifdef DELPHI5OROLDER} - -/// DirectoryExists returns a boolean value that indicates whether the -// specified directory exists (and is actually a directory) -function DirectoryExists(const Directory: string): Boolean; - -/// case-insensitive comparison of filenames -function SameFileName(const S1, S2: TFileName): Boolean; - -/// retrieve the corresponding environment variable value -function GetEnvironmentVariable(const Name: string): string; - -/// retrieve the full path name of the given execution module (e.g. library) -function GetModuleName(Module: HMODULE): TFileName; - -/// try to encode a time -function TryEncodeTime(Hour, Min, Sec, MSec: Word; var Time: TDateTime): Boolean; - -/// alias to ExcludeTrailingBackslash() function -function ExcludeTrailingPathDelimiter(const FileName: TFileName): TFileName; - -/// alias to IncludeTrailingBackslash() function -function IncludeTrailingPathDelimiter(const FileName: TFileName): TFileName; - -type - EOSError = class(Exception) - public - ErrorCode: DWORD; - end; - -/// raise an EOSError exception corresponding to the last error reported by Windows -procedure RaiseLastOSError; - -{$endif DELPHI5OROLDER} - -{$ifdef DELPHI6OROLDER} -procedure VarCastError; -{$endif} - -/// compute the file name, including its path if supplied, but without its extension -// - e.g. GetFileNameWithoutExt('/var/toto.ext') = '/var/toto' -// - may optionally return the extracted extension, as '.ext' -function GetFileNameWithoutExt(const FileName: TFileName; - Extension: PFileName=nil): TFileName; - -/// extract a file extension from a file name, then compare with a comma -// separated list of extensions -// - e.g. GetFileNameExtIndex('test.log','exe,log,map')=1 -// - will return -1 if no file extension match -// - will return any matching extension, starting count at 0 -// - extension match is case-insensitive -function GetFileNameExtIndex(const FileName, CSVExt: TFileName): integer; - -/// copy one file to another, similar to the Windows API -function CopyFile(const Source, Target: TFileName; FailIfExists: boolean): boolean; - -/// copy the date of one file to another -function FileSetDateFrom(const Dest: TFileName; SourceHandle: integer): boolean; - -/// retrieve a property value in a text-encoded class -// - follows the Delphi serialized text object format, not standard .ini -// - if the property is a string, the simple quotes ' are trimed -function FindObjectEntry(const Content, Name: RawUTF8): RawUTF8; - -/// retrieve a filename property value in a text-encoded class -// - follows the Delphi serialized text object format, not standard .ini -// - if the property is a string, the simple quotes ' are trimed -// - any file path and any extension are trimmed -function FindObjectEntryWithoutExt(const Content, Name: RawUTF8): RawUTF8; - - -/// return true if UpperValue (Ansi) is contained in A^ (Ansi) -// - find UpperValue starting at word beginning, not inside words -function FindAnsi(A, UpperValue: PAnsiChar): boolean; - -/// return true if UpperValue (Ansi) is contained in U^ (UTF-8 encoded) -// - find UpperValue starting at word beginning, not inside words -// - UTF-8 decoding is done on the fly (no temporary decoding buffer is used) -function FindUTF8(U: PUTF8Char; UpperValue: PAnsiChar): boolean; - -/// return true if Upper (Unicode encoded) is contained in U^ (UTF-8 encoded) -// - will use the slow but accurate Operating System API to perform the -// comparison at Unicode-level -function FindUnicode(PW: PWideChar; Upper: PWideChar; UpperLen: PtrInt): boolean; - -/// trim first lowercase chars ('otDone' will return 'Done' e.g.) -// - return a PUTF8Char to avoid any memory allocation -function TrimLeftLowerCase(const V: RawUTF8): PUTF8Char; - -/// trim first lowercase chars ('otDone' will return 'Done' e.g.) -// - return an RawUTF8 string: enumeration names are pure 7bit ANSI with Delphi 7 -// to 2007, and UTF-8 encoded with Delphi 2009+ -function TrimLeftLowerCaseShort(V: PShortString): RawUTF8; - -/// trim first lowercase chars ('otDone' will return 'Done' e.g.) -// - return a shortstring: enumeration names are pure 7bit ANSI with Delphi 7 -// to 2007, and UTF-8 encoded with Delphi 2009+ -function TrimLeftLowerCaseToShort(V: PShortString): ShortString; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// trim first lowercase chars ('otDone' will return 'Done' e.g.) -// - return a shortstring: enumeration names are pure 7bit ANSI with Delphi 7 -// to 2007, and UTF-8 encoded with Delphi 2009+ -procedure TrimLeftLowerCaseToShort(V: PShortString; out result: ShortString); overload; - -/// convert a CamelCase string into a space separated one -// - 'OnLine' will return 'On line' e.g., and 'OnMyLINE' will return 'On my LINE' -// - will handle capital words at the beginning, middle or end of the text, e.g. -// 'KLMFlightNumber' will return 'KLM flight number' and 'GoodBBCProgram' will -// return 'Good BBC program' -// - will handle a number at the beginning, middle or end of the text, e.g. -// 'Email12' will return 'Email 12' -// - '_' char is transformed into ' - ' -// - '__' chars are transformed into ': ' -// - return an RawUTF8 string: enumeration names are pure 7bit ANSI with Delphi 7 -// to 2007, and UTF-8 encoded with Delphi 2009+ -function UnCamelCase(const S: RawUTF8): RawUTF8; overload; - -/// convert a CamelCase string into a space separated one -// - 'OnLine' will return 'On line' e.g., and 'OnMyLINE' will return 'On my LINE' -// - will handle capital words at the beginning, middle or end of the text, e.g. -// 'KLMFlightNumber' will return 'KLM flight number' and 'GoodBBCProgram' will -// return 'Good BBC program' -// - will handle a number at the beginning, middle or end of the text, e.g. -// 'Email12' will return 'Email 12' -// - return the char count written into D^ -// - D^ and P^ are expected to be UTF-8 encoded: enumeration and property names -// are pure 7bit ANSI with Delphi 7 to 2007, and UTF-8 encoded with Delphi 2009+ -// - '_' char is transformed into ' - ' -// - '__' chars are transformed into ': ' -function UnCamelCase(D, P: PUTF8Char): integer; overload; - -/// convert a string into an human-friendly CamelCase identifier -// - replacing spaces or punctuations by an uppercase character -// - as such, it is not the reverse function to UnCamelCase() -procedure CamelCase(P: PAnsiChar; len: PtrInt; var s: RawUTF8; - const isWord: TSynByteSet=[ord('0')..ord('9'),ord('a')..ord('z'),ord('A')..ord('Z')]); overload; - -/// convert a string into an human-friendly CamelCase identifier -// - replacing spaces or punctuations by an uppercase character -// - as such, it is not the reverse function to UnCamelCase() -procedure CamelCase(const text: RawUTF8; var s: RawUTF8; - const isWord: TSynByteSet=[ord('0')..ord('9'),ord('a')..ord('z'),ord('A')..ord('Z')]); overload; - {$ifdef HASINLINE}inline;{$endif} - -/// UnCamelCase and translate a char buffer -// - P is expected to be #0 ended -// - return "string" type, i.e. UnicodeString for Delphi 2009+ -procedure GetCaptionFromPCharLen(P: PUTF8Char; out result: string); - -/// will get a class name as UTF-8 -// - will trim 'T', 'TSyn', 'TSQL' or 'TSQLRecord' left side of the class name -// - will encode the class name as UTF-8 (for Unicode Delphi versions) -// - is used e.g. to extract the SQL table name for a TSQLRecord class -function GetDisplayNameFromClass(C: TClass): RawUTF8; - -/// UnCamelCase and translate the class name, triming any left 'T', 'TSyn', -// 'TSQL' or 'TSQLRecord' -// - return generic VCL string type, i.e. UnicodeString for Delphi 2009+ -function GetCaptionFromClass(C: TClass): string; - -/// just a wrapper around vmtClassName to avoid a string conversion -function ClassNameShort(C: TClass): PShortString; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// just a wrapper around vmtClassName to avoid a string conversion -function ClassNameShort(Instance: TObject): PShortString; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// just a wrapper around vmtParent to avoid a function call -// - slightly faster than TClass.ClassParent thanks to proper inlining -function GetClassParent(C: TClass): TClass; - {$ifdef HASINLINE}inline;{$endif} - -/// just a wrapper around vmtClassName to avoid a string/RawUTF8 conversion -function ToText(C: TClass): RawUTF8; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// just a wrapper around vmtClassName to avoid a string/RawUTF8 conversion -procedure ToText(C: TClass; var result: RawUTF8); overload; - {$ifdef HASINLINE}inline;{$endif} - -type - /// information about one method, as returned by GetPublishedMethods - TPublishedMethodInfo = record - /// the method name - Name: RawUTF8; - /// a callback to the method, for the given class instance - Method: TMethod; - end; - /// information about all methods, as returned by GetPublishedMethods - TPublishedMethodInfoDynArray = array of TPublishedMethodInfo; - -/// retrieve published methods information about any class instance -// - will optionaly accept a Class, in this case Instance is ignored -// - will work with FPC and Delphi RTTI -function GetPublishedMethods(Instance: TObject; out Methods: TPublishedMethodInfoDynArray; - aClass: TClass = nil): integer; - -{$ifdef LINUX} -const - ANSI_CHARSET = 0; - DEFAULT_CHARSET = 1; - SYMBOL_CHARSET = 2; - SHIFTJIS_CHARSET = $80; - HANGEUL_CHARSET = 129; - GB2312_CHARSET = 134; - CHINESEBIG5_CHARSET = 136; - OEM_CHARSET = 255; - JOHAB_CHARSET = 130; - HEBREW_CHARSET = 177; - ARABIC_CHARSET = 178; - GREEK_CHARSET = 161; - TURKISH_CHARSET = 162; - VIETNAMESE_CHARSET = 163; - THAI_CHARSET = 222; - EASTEUROPE_CHARSET = 238; - RUSSIAN_CHARSET = 204; - BALTIC_CHARSET = 186; -{$else} -{$ifdef FPC} -const - VIETNAMESE_CHARSET = 163; -{$endif} -{$endif} - -/// convert a char set to a code page -function CharSetToCodePage(CharSet: integer): cardinal; - -/// convert a code page to a char set -function CodePageToCharSet(CodePage: Cardinal): Integer; - -/// retrieve the MIME content type from a supplied binary buffer -// - inspect the first bytes, to guess from standard known headers -// - return the MIME type, ready to be appended to a 'Content-Type: ' HTTP header -// - returns DefaultContentType if the binary buffer has an unknown layout -function GetMimeContentTypeFromBuffer(Content: Pointer; Len: PtrInt; - const DefaultContentType: RawUTF8): RawUTF8; - -/// retrieve the MIME content type from its file name or a supplied binary buffer -// - will first check for known file extensions, then inspect the binary content -// - return the MIME type, ready to be appended to a 'Content-Type: ' HTTP header -// - default is 'application/octet-stream' (BINARY_CONTENT_TYPE) or -// 'application/fileextension' if FileName was specified -// - see @http://en.wikipedia.org/wiki/Internet_media_type for most common values -function GetMimeContentType(Content: Pointer; Len: PtrInt; - const FileName: TFileName=''): RawUTF8; - -/// retrieve the HTTP header for MIME content type from a supplied binary buffer -// - just append HEADER_CONTENT_TYPE and GetMimeContentType() result -// - can be used as such: -// ! Call.OutHead := GetMimeContentTypeHeader(Call.OutBody,aFileName); -function GetMimeContentTypeHeader(const Content: RawByteString; - const FileName: TFileName=''): RawUTF8; - -/// retrieve if some content is compressed, from a supplied binary buffer -// - returns TRUE, if the header in binary buffer "may" be compressed (this method -// can trigger false positives), e.g. begin with most common already compressed -// zip/gz/gif/png/jpeg/avi/mp3/mp4 markers (aka "magic numbers") -function IsContentCompressed(Content: Pointer; Len: PtrInt): boolean; - -/// returns TRUE if the supplied HTML Headers contains 'Content-Type: text/...', -// 'Content-Type: application/json' or 'Content-Type: application/xml' -function IsHTMLContentTypeTextual(Headers: PUTF8Char): Boolean; - -/// fast guess of the size, in pixels, of a JPEG memory buffer -// - will only scan for basic JPEG structure, up to the StartOfFrame (SOF) chunk -// - returns TRUE if the buffer is likely to be a JPEG picture, and set the -// Height + Width variable with its dimensions - but there may be false positive -// recognition, and no waranty that the memory buffer holds a valid JPEG picture -// - returns FALSE if the buffer does not have any expected SOI/SOF markers -function GetJpegSize(jpeg: PAnsiChar; len: PtrInt; out Height, Width: integer): boolean; overload; - -/// fast guess of the size, in pixels, of a JPEG file -// - will only scan for basic JPEG structure, up to the StartOfFrame (SOF) chunk -// - returns TRUE if the buffer is likely to be a JPEG picture, and set the -// Height + Width variable with its dimensions - but there may be false positive -// recognition, and no waranty that the file is a valid JPEG picture -// - returns FALSE if the file content does not have any expected SOI/SOF markers -function GetJpegSize(const jpeg: TFileName; out Height, Width: integer): boolean; overload; - -type - /// used by MultiPartFormDataDecode() to return one item of its data - TMultiPart = record - Name: RawUTF8; - FileName: RawUTF8; - ContentType: RawUTF8; - Encoding: RawUTF8; - Content: RawByteString; - end; - /// used by MultiPartFormDataDecode() to return all its data items - TMultiPartDynArray = array of TMultiPart; - -/// decode multipart/form-data POST request content -// - following RFC1867 -function MultiPartFormDataDecode(const MimeType,Body: RawUTF8; - var MultiPart: TMultiPartDynArray): boolean; - -/// encode multipart fields and files -// - only one of them can be used because MultiPartFormDataDecode must implement -// both decodings -// - MultiPart: parts to build the multipart content from, which may be created -// using MultiPartFormDataAddFile/MultiPartFormDataAddField -// - MultiPartContentType: variable returning -// $ Content-Type: multipart/form-data; boundary=xxx -// where xxx is the first generated boundary -// - MultiPartContent: generated multipart content -function MultiPartFormDataEncode(const MultiPart: TMultiPartDynArray; - var MultiPartContentType, MultiPartContent: RawUTF8): boolean; - -/// encode a file in a multipart array -// - FileName: file to encode -// - Multipart: where the part is added -// - Name: name of the part, is empty the name 'File###' is generated -function MultiPartFormDataAddFile(const FileName: TFileName; - var MultiPart: TMultiPartDynArray; const Name: RawUTF8 = ''): boolean; - -/// encode a field in a multipart array -// - FieldName: field name of the part -// - FieldValue: value of the field -// - Multipart: where the part is added -function MultiPartFormDataAddField(const FieldName, FieldValue: RawUTF8; - var MultiPart: TMultiPartDynArray): boolean; - -/// retrieve the index where to insert a PUTF8Char in a sorted PUTF8Char array -// - R is the last index of available entries in P^ (i.e. Count-1) -// - string comparison is case-sensitive StrComp (so will work with any PAnsiChar) -// - returns -1 if the specified Value was found (i.e. adding will duplicate a value) -// - will use fast O(log(n)) binary search algorithm -function FastLocatePUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt; Value: PUTF8Char): PtrInt; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// retrieve the index where to insert a PUTF8Char in a sorted PUTF8Char array -// - this overloaded function accept a custom comparison function for sorting -// - R is the last index of available entries in P^ (i.e. Count-1) -// - string comparison is case-sensitive (so will work with any PAnsiChar) -// - returns -1 if the specified Value was found (i.e. adding will duplicate a value) -// - will use fast O(log(n)) binary search algorithm -function FastLocatePUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt; Value: PUTF8Char; - Compare: TUTF8Compare): PtrInt; overload; - -/// retrieve the index where is located a PUTF8Char in a sorted PUTF8Char array -// - R is the last index of available entries in P^ (i.e. Count-1) -// - string comparison is case-sensitive StrComp (so will work with any PAnsiChar) -// - returns -1 if the specified Value was not found -// - will use inlined binary search algorithm with optimized x86_64 branchless asm -// - slightly faster than plain FastFindPUTF8CharSorted(P,R,Value,@StrComp) -function FastFindPUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt; Value: PUTF8Char): PtrInt; overload; - -/// retrieve the index where is located a PUTF8Char in a sorted uppercase PUTF8Char array -// - P[] array is expected to be already uppercased -// - searched Value is converted to uppercase before search via UpperCopy255Buf(), -// so is expected to be short, i.e. length < 250 -// - R is the last index of available entries in P^ (i.e. Count-1) -// - returns -1 if the specified Value was not found -// - will use fast O(log(n)) binary search algorithm -// - slightly faster than plain FastFindPUTF8CharSorted(P,R,Value,@StrIComp) -function FastFindUpperPUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt; - Value: PUTF8Char; ValueLen: PtrInt): PtrInt; - -/// retrieve the index where is located a PUTF8Char in a sorted PUTF8Char array -// - R is the last index of available entries in P^ (i.e. Count-1) -// - string comparison will use the specified Compare function -// - returns -1 if the specified Value was not found -// - will use fast O(log(n)) binary search algorithm -function FastFindPUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt; Value: PUTF8Char; - Compare: TUTF8Compare): PtrInt; overload; - -/// retrieve the index of a PUTF8Char in a PUTF8Char array via a sort indexed -// - will use fast O(log(n)) binary search algorithm -function FastFindIndexedPUTF8Char(P: PPUTF8CharArray; R: PtrInt; - var SortedIndexes: TCardinalDynArray; Value: PUTF8Char; - ItemComp: TUTF8Compare): PtrInt; - -/// add a RawUTF8 value in an alphaticaly sorted dynamic array of RawUTF8 -// - returns the index where the Value was added successfully in Values[] -// - returns -1 if the specified Value was alredy present in Values[] -// (we must avoid any duplicate for O(log(n)) binary search) -// - if CoValues is set, its content will be moved to allow inserting a new -// value at CoValues[result] position - a typical usage of CoValues is to store -// the corresponding ID to each RawUTF8 item -// - if FastLocatePUTF8CharSorted() has been already called, this index can -// be set to optional ForceIndex parameter -// - by default, exact (case-sensitive) match is used; you can specify a custom -// compare function if needed in Compare optional parameter -function AddSortedRawUTF8(var Values: TRawUTF8DynArray; var ValuesCount: integer; - const Value: RawUTF8; CoValues: PIntegerDynArray=nil; ForcedIndex: PtrInt=-1; - Compare: TUTF8Compare=nil): PtrInt; - -/// delete a RawUTF8 item in a dynamic array of RawUTF8 -// - if CoValues is set, the integer item at the same index is also deleted -function DeleteRawUTF8(var Values: TRawUTF8DynArray; var ValuesCount: integer; - Index: integer; CoValues: PIntegerDynArray=nil): boolean; overload; - -/// delete a RawUTF8 item in a dynamic array of RawUTF8; -function DeleteRawUTF8(var Values: TRawUTF8DynArray; Index: integer): boolean; overload; - -/// sort a dynamic array of RawUTF8 items -// - if CoValues is set, the integer items are also synchronized -// - by default, exact (case-sensitive) match is used; you can specify a custom -// compare function if needed in Compare optional parameter -procedure QuickSortRawUTF8(var Values: TRawUTF8DynArray; ValuesCount: integer; - CoValues: PIntegerDynArray=nil; Compare: TUTF8Compare=nil); - -/// sort a dynamic array of PUTF8Char items, via an external array of indexes -// - you can use FastFindIndexedPUTF8Char() for fast O(log(n)) binary search -procedure QuickSortIndexedPUTF8Char(Values: PPUtf8CharArray; Count: Integer; - var SortedIndexes: TCardinalDynArray; CaseSensitive: boolean=false); - -/// fast search of an unsigned integer position in an integer array -// - Count is the number of cardinal entries in P^ -// - returns P where P^=Value -// - returns nil if Value was not found -function IntegerScan(P: PCardinalArray; Count: PtrInt; Value: cardinal): PCardinal; - -/// fast search of an unsigned integer position in an integer array -// - Count is the number of integer entries in P^ -// - return index of P^[index]=Value -// - return -1 if Value was not found -function IntegerScanIndex(P: PCardinalArray; Count: PtrInt; Value: cardinal): PtrInt; - -/// fast search of an integer position in a 64-bit integer array -// - Count is the number of Int64 entries in P^ -// - returns P where P^=Value -// - returns nil if Value was not found -function Int64Scan(P: PInt64Array; Count: PtrInt; const Value: Int64): PInt64; - -/// fast search of an integer position in a signed 64-bit integer array -// - Count is the number of Int64 entries in P^ -// - returns index of P^[index]=Value -// - returns -1 if Value was not found -function Int64ScanIndex(P: PInt64Array; Count: PtrInt; const Value: Int64): PtrInt; - -/// fast search of an integer position in an unsigned 64-bit integer array -// - Count is the number of QWord entries in P^ -// - returns index of P^[index]=Value -// - returns -1 if Value was not found -function QWordScanIndex(P: PQWordArray; Count: PtrInt; const Value: QWord): PtrInt; - {$ifdef HASINLINE}inline;{$endif} - -/// fast search of an unsigned integer in an integer array -// - returns true if P^=Value within Count entries -// - returns false if Value was not found -function IntegerScanExists(P: PCardinalArray; Count: PtrInt; Value: cardinal): boolean; - -/// fast search of an integer value in a 64-bit integer array -// - returns true if P^=Value within Count entries -// - returns false if Value was not found -function Int64ScanExists(P: PInt64Array; Count: PtrInt; const Value: Int64): boolean; - -/// fast search of a pointer-sized unsigned integer position -// in an pointer-sized integer array -// - Count is the number of pointer-sized integer entries in P^ -// - return index of P^[index]=Value -// - return -1 if Value was not found -function PtrUIntScanIndex(P: PPtrUIntArray; Count: PtrInt; Value: PtrUInt): PtrInt; - {$ifdef HASINLINE}inline;{$endif} - -/// fast search of a pointer-sized unsigned integer in an pointer-sized integer array -// - Count is the number of pointer-sized integer entries in P^ -// - returns true if P^=Value within Count entries -// - returns false if Value was not found -function PtrUIntScan(P: PPtrUIntArray; Count: PtrInt; Value: PtrUInt): pointer; - {$ifdef HASINLINE}inline;{$endif} - -/// fast search of a pointer-sized unsigned integer position -// in an pointer-sized integer array -// - Count is the number of pointer-sized integer entries in P^ -// - returns true if P^=Value within Count entries -// - returns false if Value was not found -function PtrUIntScanExists(P: PPtrUIntArray; Count: PtrInt; Value: PtrUInt): boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// fast search of an unsigned Byte value position in a Byte array -// - Count is the number of Byte entries in P^ -// - return index of P^[index]=Value -// - return -1 if Value was not found -function ByteScanIndex(P: PByteArray; Count: PtrInt; Value: Byte): PtrInt; - {$ifdef HASINLINE}inline;{$endif} - -/// fast search of an unsigned Word value position in a Word array -// - Count is the number of Word entries in P^ -// - return index of P^[index]=Value -// - return -1 if Value was not found -function WordScanIndex(P: PWordArray; Count: PtrInt; Value: word): PtrInt; - {$ifdef HASINLINE}inline;{$endif} - -/// fast search of a binary value position in a fixed-size array -// - Count is the number of entries in P^[] -// - return index of P^[index]=Elem^, comparing ElemSize bytes -// - return -1 if Value was not found -function AnyScanIndex(P,Elem: pointer; Count,ElemSize: PtrInt): PtrInt; - -/// fast search of a binary value position in a fixed-size array -// - Count is the number of entries in P^[] -function AnyScanExists(P,Elem: pointer; Count,ElemSize: PtrInt): boolean; - -/// sort an Integer array, low values first -procedure QuickSortInteger(ID: PIntegerArray; L, R: PtrInt); overload; - -/// sort an Integer array, low values first -procedure QuickSortInteger(ID,CoValues: PIntegerArray; L, R: PtrInt); overload; - -/// sort an Integer array, low values first -procedure QuickSortInteger(var ID: TIntegerDynArray); overload; - -/// sort a 16 bit unsigned Integer array, low values first -procedure QuickSortWord(ID: PWordArray; L, R: PtrInt); - -/// sort a 64-bit signed Integer array, low values first -procedure QuickSortInt64(ID: PInt64Array; L, R: PtrInt); overload; - -/// sort a 64-bit unsigned Integer array, low values first -// - QWord comparison are implemented correctly under FPC or Delphi 2009+ - -// older compilers will use fast and exact SortDynArrayQWord() -procedure QuickSortQWord(ID: PQWordArray; L, R: PtrInt); overload; - -/// sort a 64-bit Integer array, low values first -procedure QuickSortInt64(ID,CoValues: PInt64Array; L, R: PtrInt); overload; - -type - /// event handler called by NotifySortedIntegerChanges() - // - Sender is an opaque const value, maybe a TObject or any pointer - TOnNotifySortedIntegerChange = procedure(const Sender; Value: integer) of object; - -/// compares two 32-bit signed sorted integer arrays, and call event handlers -// to notify the corresponding modifications in an O(n) time -// - items in both old[] and new[] arrays are required to be sorted -procedure NotifySortedIntegerChanges(old, new: PIntegerArray; oldn, newn: PtrInt; - const added, deleted: TOnNotifySortedIntegerChange; const sender); - -/// copy an integer array, then sort it, low values first -procedure CopyAndSortInteger(Values: PIntegerArray; ValuesCount: integer; - var Dest: TIntegerDynArray); - -/// copy an integer array, then sort it, low values first -procedure CopyAndSortInt64(Values: PInt64Array; ValuesCount: integer; - var Dest: TInt64DynArray); - -/// fast O(log(n)) binary search of an integer value in a sorted integer array -// - R is the last index of available integer entries in P^ (i.e. Count-1) -// - return index of P^[result]=Value -// - return -1 if Value was not found -function FastFindIntegerSorted(P: PIntegerArray; R: PtrInt; Value: integer): PtrInt; overload; - -/// fast O(log(n)) binary search of an integer value in a sorted integer array -// - return index of Values[result]=Value -// - return -1 if Value was not found -function FastFindIntegerSorted(const Values: TIntegerDynArray; Value: integer): PtrInt; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// fast O(log(n)) binary search of a 16 bit unsigned integer value in a sorted array -function FastFindWordSorted(P: PWordArray; R: PtrInt; Value: Word): PtrInt; - -/// fast O(log(n)) binary search of a 64-bit signed integer value in a sorted array -// - R is the last index of available integer entries in P^ (i.e. Count-1) -// - return index of P^[result]=Value -// - return -1 if Value was not found -function FastFindInt64Sorted(P: PInt64Array; R: PtrInt; const Value: Int64): PtrInt; overload; - -/// fast O(log(n)) binary search of a 64-bit unsigned integer value in a sorted array -// - R is the last index of available integer entries in P^ (i.e. Count-1) -// - return index of P^[result]=Value -// - return -1 if Value was not found -// - QWord comparison are implemented correctly under FPC or Delphi 2009+ - -// older compilers will fast and exact SortDynArrayQWord() -function FastFindQWordSorted(P: PQWordArray; R: PtrInt; const Value: QWord): PtrInt; overload; - -/// sort a PtrInt array, low values first -procedure QuickSortPtrInt(P: PPtrIntArray; L, R: PtrInt); - {$ifdef HASINLINE}inline;{$endif} - -/// fast O(log(n)) binary search of a PtrInt value in a sorted array -function FastFindPtrIntSorted(P: PPtrIntArray; R: PtrInt; Value: PtrInt): PtrInt; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// sort a pointer array, low values first -procedure QuickSortPointer(P: PPointerArray; L, R: PtrInt); - {$ifdef HASINLINE}inline;{$endif} - -/// fast O(log(n)) binary search of a Pointer value in a sorted array -function FastFindPointerSorted(P: PPointerArray; R: PtrInt; Value: Pointer): PtrInt; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// retrieve the index where to insert an integer value in a sorted integer array -// - R is the last index of available integer entries in P^ (i.e. Count-1) -// - returns -1 if the specified Value was found (i.e. adding will duplicate a value) -function FastLocateIntegerSorted(P: PIntegerArray; R: PtrInt; Value: integer): PtrInt; - -/// retrieve the index where to insert a word value in a sorted word array -// - R is the last index of available integer entries in P^ (i.e. Count-1) -// - returns -1 if the specified Value was found (i.e. adding will duplicate a value) -function FastLocateWordSorted(P: PWordArray; R: integer; Value: word): PtrInt; - -/// add an integer value in a sorted dynamic array of integers -// - returns the index where the Value was added successfully in Values[] -// - returns -1 if the specified Value was already present in Values[] -// (we must avoid any duplicate for O(log(n)) binary search) -// - if CoValues is set, its content will be moved to allow inserting a new -// value at CoValues[result] position -function AddSortedInteger(var Values: TIntegerDynArray; var ValuesCount: integer; - Value: integer; CoValues: PIntegerDynArray=nil): PtrInt; overload; - -/// add an integer value in a sorted dynamic array of integers -// - overloaded function which do not expect an external Count variable -function AddSortedInteger(var Values: TIntegerDynArray; - Value: integer; CoValues: PIntegerDynArray=nil): PtrInt; overload; - -/// insert an integer value at the specified index position of a dynamic array -// of integers -// - if Index is invalid, the Value is inserted at the end of the array -function InsertInteger(var Values: TIntegerDynArray; var ValuesCount: integer; - Value: Integer; Index: PtrInt; CoValues: PIntegerDynArray=nil): PtrInt; - -/// add an integer value at the end of a dynamic array of integers -// - returns TRUE if Value was added successfully in Values[], in this case -// length(Values) will be increased -function AddInteger(var Values: TIntegerDynArray; Value: integer; - NoDuplicates: boolean=false): boolean; overload; - -/// add an integer value at the end of a dynamic array of integers -// - this overloaded function will use a separate Count variable (faster) -// - it won't search for any existing duplicate -procedure AddInteger(var Values: TIntegerDynArray; var ValuesCount: integer; - Value: integer); overload; - {$ifdef HASINLINE}inline;{$endif} - -/// add an integer array at the end of a dynamic array of integer -function AddInteger(var Values: TIntegerDynArray; const Another: TIntegerDynArray): PtrInt; overload; - -/// add an integer value at the end of a dynamic array of integers -// - this overloaded function will use a separate Count variable (faster), -// and would allow to search for duplicates -// - returns TRUE if Value was added successfully in Values[], in this case -// ValuesCount will be increased, but length(Values) would stay fixed most -// of the time (since it stores the Values[] array capacity) -function AddInteger(var Values: TIntegerDynArray; var ValuesCount: integer; - Value: integer; NoDuplicates: boolean): boolean; overload; - -/// add a 16-bit integer value at the end of a dynamic array of integers -function AddWord(var Values: TWordDynArray; var ValuesCount: integer; Value: Word): PtrInt; - -/// add a 64-bit integer value at the end of a dynamic array of integers -function AddInt64(var Values: TInt64DynArray; var ValuesCount: integer; Value: Int64): PtrInt; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// add a 64-bit integer value at the end of a dynamic array -function AddInt64(var Values: TInt64DynArray; Value: Int64): PtrInt; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// add a 64-bit integer array at the end of a dynamic array -function AddInt64(var Values: TInt64DynArray; const Another: TInt64DynArray): PtrInt; overload; - -/// if not already existing, add a 64-bit integer value to a dynamic array -function AddInt64Once(var Values: TInt64DynArray; Value: Int64): PtrInt; - -/// if not already existing, add a 64-bit integer value to a sorted dynamic array -procedure AddInt64Sorted(var Values: TInt64DynArray; Value: Int64); - -/// delete any 32-bit integer in Values[] -procedure DeleteInteger(var Values: TIntegerDynArray; Index: PtrInt); overload; - -/// delete any 32-bit integer in Values[] -procedure DeleteInteger(var Values: TIntegerDynArray; var ValuesCount: Integer; Index: PtrInt); overload; - -/// remove some 32-bit integer from Values[] -// - Excluded is declared as var, since it will be sorted in-place during process -// if it contains more than ExcludedSortSize items (i.e. if the sort is worth it) -procedure ExcludeInteger(var Values, Excluded: TIntegerDynArray; - ExcludedSortSize: Integer=32); - -/// ensure some 32-bit integer from Values[] will only contain Included[] -// - Included is declared as var, since it will be sorted in-place during process -// if it contains more than IncludedSortSize items (i.e. if the sort is worth it) -procedure IncludeInteger(var Values, Included: TIntegerDynArray; - IncludedSortSize: Integer=32); - -/// sort and remove any 32-bit duplicated integer from Values[] -procedure DeduplicateInteger(var Values: TIntegerDynArray); overload; - -/// sort and remove any 32-bit duplicated integer from Values[] -// - returns the new Values[] length -function DeduplicateInteger(var Values: TIntegerDynArray; Count: integer): integer; overload; - -/// low-level function called by DeduplicateInteger() -function DeduplicateIntegerSorted(val: PIntegerArray; last: PtrInt): PtrInt; - -/// create a new 32-bit integer dynamic array with the values from another one -procedure CopyInteger(const Source: TIntegerDynArray; out Dest: TIntegerDynArray); - -/// delete any 16-bit integer in Values[] -procedure DeleteWord(var Values: TWordDynArray; Index: PtrInt); - -/// delete any 64-bit integer in Values[] -procedure DeleteInt64(var Values: TInt64DynArray; Index: PtrInt); overload; - -/// delete any 64-bit integer in Values[] -procedure DeleteInt64(var Values: TInt64DynArray; var ValuesCount: Integer; Index: PtrInt); overload; - -/// remove some 64-bit integer from Values[] -// - Excluded is declared as var, since it will be sorted in-place during process -// if it contains more than ExcludedSortSize items (i.e. if the sort is worth it) -procedure ExcludeInt64(var Values, Excluded: TInt64DynArray; - ExcludedSortSize: Integer=32); - -/// ensure some 64-bit integer from Values[] will only contain Included[] -// - Included is declared as var, since it will be sorted in-place during process -// if it contains more than IncludedSortSize items (i.e. if the sort is worth it) -procedure IncludeInt64(var Values, Included: TInt64DynArray; - IncludedSortSize: Integer=32); - -/// sort and remove any 64-bit duplicated integer from Values[] -procedure DeduplicateInt64(var Values: TInt64DynArray); overload; - -/// sort and remove any 64-bit duplicated integer from Values[] -// - returns the new Values[] length -function DeduplicateInt64(var Values: TInt64DynArray; Count: integer): integer; overload; - -/// low-level function called by DeduplicateInt64() -// - warning: caller should ensure that last>0 -function DeduplicateInt64Sorted(val: PInt64Array; last: PtrInt): PtrInt; - -/// create a new 64-bit integer dynamic array with the values from another one -procedure CopyInt64(const Source: TInt64DynArray; out Dest: TInt64DynArray); - -/// find the maximum 32-bit integer in Values[] -function MaxInteger(const Values: TIntegerDynArray; ValuesCount: PtrInt; - MaxStart: integer=-1): Integer; - -/// sum all 32-bit integers in Values[] -function SumInteger(const Values: TIntegerDynArray; ValuesCount: PtrInt): Integer; - -/// fill already allocated Reversed[] so that Reversed[Values[i]]=i -procedure Reverse(const Values: TIntegerDynArray; ValuesCount: PtrInt; - Reversed: PIntegerArray); - -/// fill some values with i,i+1,i+2...i+Count-1 -procedure FillIncreasing(Values: PIntegerArray; StartValue: integer; Count: PtrUInt); - -/// copy some Int64 values into an unsigned integer array -procedure Int64ToUInt32(Values64: PInt64Array; Values32: PCardinalArray; Count: PtrInt); - -/// append the strings in the specified CSV text into a dynamic array of integer -procedure CSVToIntegerDynArray(CSV: PUTF8Char; var Result: TIntegerDynArray; - Sep: AnsiChar= ','); - -/// append the strings in the specified CSV text into a dynamic array of integer -procedure CSVToInt64DynArray(CSV: PUTF8Char; var Result: TInt64DynArray; - Sep: AnsiChar= ','); overload; - -/// convert the strings in the specified CSV text into a dynamic array of integer -function CSVToInt64DynArray(CSV: PUTF8Char; Sep: AnsiChar= ','): TInt64DynArray; overload; - -/// return the corresponding CSV text from a dynamic array of 32-bit integer -// - you can set some custom Prefix and Suffix text -function IntegerDynArrayToCSV(Values: PIntegerArray; ValuesCount: integer; - const Prefix: RawUTF8=''; const Suffix: RawUTF8=''; InlinedValue: boolean=false): RawUTF8; overload; - -/// return the corresponding CSV text from a dynamic array of 32-bit integer -// - you can set some custom Prefix and Suffix text -function IntegerDynArrayToCSV(const Values: TIntegerDynArray; - const Prefix: RawUTF8=''; const Suffix: RawUTF8=''; InlinedValue: boolean=false): RawUTF8; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// return the corresponding CSV text from a dynamic array of 64-bit integers -// - you can set some custom Prefix and Suffix text -function Int64DynArrayToCSV(Values: PInt64Array; ValuesCount: integer; - const Prefix: RawUTF8=''; const Suffix: RawUTF8=''; InlinedValue: boolean=false): RawUTF8; overload; - -/// return the corresponding CSV text from a dynamic array of 64-bit integers -// - you can set some custom Prefix and Suffix text -function Int64DynArrayToCSV(const Values: TInt64DynArray; - const Prefix: RawUTF8=''; const Suffix: RawUTF8=''; InlinedValue: boolean=false): RawUTF8; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// quick helper to initialize a dynamic array of integer from some constants -// - can be used e.g. as: -// ! MyArray := TIntegerDynArrayFrom([1,2,3]); -// - see also FromI32() -function TIntegerDynArrayFrom(const Values: array of integer): TIntegerDynArray; - -/// quick helper to initialize a dynamic array of integer from 64-bit integers -// - will raise a ESynException if any Value[] can not fit into 32-bit, unless -// raiseExceptionOnOverflow is FALSE and the returned array slot is filled -// with maxInt/minInt -function TIntegerDynArrayFrom64(const Values: TInt64DynArray; - raiseExceptionOnOverflow: boolean=true): TIntegerDynArray; - -/// quick helper to initialize a dynamic array of 64-bit integers from 32-bit values -// - see also FromI64() for 64-bit signed integer values input -function TInt64DynArrayFrom(const Values: TIntegerDynArray): TInt64DynArray; - -/// quick helper to initialize a dynamic array of 64-bit integers from 32-bit values -// - see also FromU64() for 64-bit unsigned integer values input -function TQWordDynArrayFrom(const Values: TCardinalDynArray): TQWordDynArray; - -/// initializes a dynamic array from a set of 32-bit integer signed values -function FromI32(const Values: array of integer): TIntegerDynArray; - {$ifdef FPC}{$ifdef HASINLINE}inline;{$endif}{$endif} - -/// initializes a dynamic array from a set of 32-bit integer unsigned values -function FromU32(const Values: array of cardinal): TCardinalDynArray; - {$ifdef FPC}{$ifdef HASINLINE}inline;{$endif}{$endif} - -/// initializes a dynamic array from a set of 64-bit integer signed values -function FromI64(const Values: array of Int64): TInt64DynArray; - {$ifdef FPC}{$ifdef HASINLINE}inline;{$endif}{$endif} - -/// initializes a dynamic array from a set of 64-bit integer unsigned values -function FromU64(const Values: array of QWord): TQWordDynArray; - {$ifdef FPC}{$ifdef HASINLINE}inline;{$endif}{$endif} - -type - /// used to store and retrieve Words in a sorted array - // - Delphi "object" is buggy on stack -> also defined as record with methods - {$ifdef USERECORDWITHMETHODS}TSortedWordArray = record - {$else}TSortedWordArray = object{$endif} - public - /// the actual 16-bit word storage - Values: TWordDynArray; - /// how many items are currently in Values[] - Count: PtrInt; - /// add a value into the sorted array - // - return the index of the new inserted value into the Values[] array - // - return -(foundindex+1) if this value is already in the Values[] array - function Add(aValue: Word): PtrInt; - /// return the index if the supplied value in the Values[] array - // - return -1 if not found - function IndexOf(aValue: Word): PtrInt; {$ifdef HASINLINE}inline;{$endif} - end; - PSortedWordArray = ^TSortedWordArray; - - /// used to store and retrieve Integers in a sorted array - // - Delphi "object" is buggy on stack -> also defined as record with methods - {$ifdef USERECORDWITHMETHODS}TSortedIntegerArray = record - {$else}TSortedIntegerArray = object{$endif} - public - /// the actual 32-bit integers storage - Values: TIntegerDynArray; - /// how many items are currently in Values[] - Count: PtrInt; - /// add a value into the sorted array - // - return the index of the new inserted value into the Values[] array - // - return -(foundindex+1) if this value is already in the Values[] array - function Add(aValue: integer): PtrInt; - /// return the index if the supplied value in the Values[] array - // - return -1 if not found - function IndexOf(aValue: integer): PtrInt; {$ifdef HASINLINE}inline;{$endif} - end; - PSortedIntegerArray = ^TSortedIntegerArray; - - /// comparison function as expected by MedianQuickSelect() - // - should return TRUE if Values[IndexA]>Values[IndexB] - TOnValueGreater = function(IndexA,IndexB: PtrInt): boolean of object; - -/// compute the median of an integer serie of values, using "Quickselect" -// - based on the algorithm described in "Numerical recipes in C", Second Edition, -// translated from Nicolas Devillard's C code: http://ndevilla.free.fr/median/median -// - warning: the supplied Integer array is modified in-place during the process, -// and won't be fully sorted on output (this is no QuickSort alternative) -function MedianQuickSelectInteger(Values: PIntegerArray; n: integer): integer; - -/// compute the median of a serie of values, using "Quickselect" -// - based on the algorithm described in "Numerical recipes in C", Second Edition -// - expect the values information to be available from a comparison callback -// - this version will use a temporary index list to exchange items order -// (supplied as a TSynTempBuffer), so won't change the supplied values themself -// - returns the index of the median Value -function MedianQuickSelect(const OnCompare: TOnValueGreater; n: integer; - var TempBuffer: TSynTempBuffer): integer; - -/// compute GCD of two integers using substraction-based Euclidean algorithm -function gcd(a, b: cardinal): cardinal; - -/// performs a QuickSort using a comparison callback -procedure QuickSortCompare(const OnCompare: TOnValueGreater; - Index: PIntegerArray; L,R: PtrInt); - -/// convert a cardinal into a 32-bit variable-length integer buffer -function ToVarUInt32(Value: cardinal; Dest: PByte): PByte; - -/// return the number of bytes necessary to store a 32-bit variable-length integer -// - i.e. the ToVarUInt32() buffer size -function ToVarUInt32Length(Value: PtrUInt): PtrUInt; - {$ifdef HASINLINE}inline;{$endif} - -/// return the number of bytes necessary to store some data with a its -// 32-bit variable-length integer legnth -function ToVarUInt32LengthWithData(Value: PtrUInt): PtrUInt; - {$ifdef HASINLINE}inline;{$endif} - -/// convert an integer into a 32-bit variable-length integer buffer -// - store negative values as cardinal two-complement, i.e. -// 0=0,1=1,2=-1,3=2,4=-2... -function ToVarInt32(Value: PtrInt; Dest: PByte): PByte; - {$ifdef PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif} - -/// convert a 32-bit variable-length integer buffer into a cardinal -// - fast inlined process for any number < 128 -// - use overloaded FromVarUInt32() or FromVarUInt32Safe() with a SourceMax -// pointer to avoid any potential buffer overflow -function FromVarUInt32(var Source: PByte): cardinal; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// safely convert a 32-bit variable-length integer buffer into a cardinal -// - slower but safer process checking out of boundaries memory access in Source -// - SourceMax is expected to be not nil, and to point to the first byte -// just after the Source memory buffer -// - returns nil on error, or point to next input data on successful decoding -function FromVarUInt32Safe(Source, SourceMax: PByte; out Value: cardinal): PByte; - -/// convert a 32-bit variable-length integer buffer into a cardinal -// - will call FromVarUInt32() if SourceMax=nil, or FromVarUInt32Safe() if set -// - returns false on error, true if Value has been set properly -function FromVarUInt32(var Source: PByte; SourceMax: PByte; out Value: cardinal): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert a 32-bit variable-length integer buffer into a cardinal -// - this version could be called if number is likely to be > $7f, so it -// inlining the first byte won't make any benefit -function FromVarUInt32Big(var Source: PByte): cardinal; - -/// convert a 32-bit variable-length integer buffer into a cardinal -// - used e.g. when inlining FromVarUInt32() -// - this version must be called if Source^ has already been checked to be > $7f -// ! result := Source^; -// ! inc(Source); -// ! if result>$7f then -// ! result := (result and $7F) or FromVarUInt32Up128(Source); -function FromVarUInt32Up128(var Source: PByte): cardinal; - -/// convert a 32-bit variable-length integer buffer into a cardinal -// - this version must be called if Source^ has already been checked to be > $7f -function FromVarUInt32High(var Source: PByte): cardinal; - -/// convert a 32-bit variable-length integer buffer into an integer -// - decode negative values from cardinal two-complement, i.e. -// 0=0,1=1,2=-1,3=2,4=-2... -function FromVarInt32(var Source: PByte): integer; - -/// convert a UInt64 into a 64-bit variable-length integer buffer -function ToVarUInt64(Value: QWord; Dest: PByte): PByte; - -/// convert a 64-bit variable-length integer buffer into a UInt64 -function FromVarUInt64(var Source: PByte): QWord; overload; - -/// safely convert a 64-bit variable-length integer buffer into a UInt64 -// - slower but safer process checking out of boundaries memory access in Source -// - SourceMax is expected to be not nil, and to point to the first byte -// just after the Source memory buffer -// - returns nil on error, or point to next input data on successful decoding -function FromVarUInt64Safe(Source, SourceMax: PByte; out Value: QWord): PByte; - -/// convert a 64-bit variable-length integer buffer into a UInt64 -// - will call FromVarUInt64() if SourceMax=nil, or FromVarUInt64Safe() if set -// - returns false on error, true if Value has been set properly -function FromVarUInt64(var Source: PByte; SourceMax: PByte; out Value: Qword): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert a Int64 into a 64-bit variable-length integer buffer -function ToVarInt64(Value: Int64; Dest: PByte): PByte; {$ifdef HASINLINE}inline;{$endif} - -/// convert a 64-bit variable-length integer buffer into a Int64 -function FromVarInt64(var Source: PByte): Int64; - -/// convert a 64-bit variable-length integer buffer into a Int64 -// - this version won't update the Source pointer -function FromVarInt64Value(Source: PByte): Int64; - -/// jump a value in the 32-bit or 64-bit variable-length integer buffer -function GotoNextVarInt(Source: PByte): pointer; {$ifdef HASINLINE}inline;{$endif} - -/// convert a RawUTF8 into an UTF-8 encoded variable-length buffer -function ToVarString(const Value: RawUTF8; Dest: PByte): PByte; - -/// jump a value in variable-length text buffer -function GotoNextVarString(Source: PByte): pointer; {$ifdef HASINLINE}inline;{$endif} - -/// retrieve a variable-length UTF-8 encoded text buffer in a newly allocation RawUTF8 -function FromVarString(var Source: PByte): RawUTF8; overload; - -/// safe retrieve a variable-length UTF-8 encoded text buffer in a newly allocation RawUTF8 -// - supplied SourceMax value will avoid any potential buffer overflow -function FromVarString(var Source: PByte; SourceMax: PByte): RawUTF8; overload; - -/// retrieve a variable-length text buffer -// - this overloaded function will set the supplied code page to the AnsiString -procedure FromVarString(var Source: PByte; var Value: RawByteString; - CodePage: integer); overload; - -/// retrieve a variable-length text buffer -// - this overloaded function will set the supplied code page to the AnsiString -// and will also check for the SourceMax end of buffer -// - returns TRUE on success, or FALSE on any buffer overload detection -function FromVarString(var Source: PByte; SourceMax: PByte; - var Value: RawByteString; CodePage: integer): boolean; overload; - -/// retrieve a variable-length UTF-8 encoded text buffer in a temporary buffer -// - caller should call Value.Done after use of the Value.buf memory -// - this overloaded function would include a trailing #0, so Value.buf could -// be parsed as a valid PUTF8Char buffer (e.g. containing JSON) -procedure FromVarString(var Source: PByte; var Value: TSynTempBuffer); overload; - -/// retrieve a variable-length UTF-8 encoded text buffer in a temporary buffer -// - caller should call Value.Done after use of the Value.buf memory -// - this overloaded function will also check for the SourceMax end of buffer, -// returning TRUE on success, or FALSE on any buffer overload detection -function FromVarString(var Source: PByte; SourceMax: PByte; - var Value: TSynTempBuffer): boolean; overload; - -type - /// kind of result returned by FromVarBlob() function - TValueResult = record - /// start of data value - Ptr: PAnsiChar; - /// value length (in bytes) - Len: PtrInt; - end; - -/// retrieve pointer and length to a variable-length text/blob buffer -function FromVarBlob(Data: PByte): TValueResult; {$ifdef HASINLINE}inline;{$endif} - - - -{ ************ low-level RTTI types and conversion routines ***************** } - -type - /// specify ordinal (tkInteger and tkEnumeration) storage size and sign - // - note: Int64 is stored as its own TTypeKind, not as tkInteger - TOrdType = (otSByte,otUByte,otSWord,otUWord,otSLong,otULong - {$ifdef FPC_NEWRTTI},otSQWord,otUQWord{$endif}); - - /// specify floating point (ftFloat) storage size and precision - // - here ftDouble is renamed ftDoub to avoid confusion with TSQLDBFieldType - TFloatType = (ftSingle,ftDoub,ftExtended,ftComp,ftCurr); - -{$ifdef FPC} - /// available type families for FPC RTTI values - // - values differs from Delphi, and are taken from FPC typinfo.pp unit - // - here below, we defined tkLString instead of tkAString to match Delphi - - // see https://lists.freepascal.org/pipermail/fpc-devel/2013-June/032360.html - // "Compiler uses internally some LongStrings which is not possible to use - // for variable declarations" so tkLStringOld seems never used in practice - TTypeKind = (tkUnknown,tkInteger,tkChar,tkEnumeration,tkFloat, - tkSet,tkMethod,tkSString,tkLStringOld{=tkLString},tkLString{=tkAString}, - tkWString,tkVariant,tkArray,tkRecord,tkInterface, - tkClass,tkObject,tkWChar,tkBool,tkInt64,tkQWord, - tkDynArray,tkInterfaceRaw,tkProcVar,tkUString,tkUChar, - tkHelper,tkFile,tkClassRef,tkPointer); - -const - /// potentially managed types in TTypeKind RTTI enumerate - // - should match ManagedType*() functions - tkManagedTypes = [tkLStringOld,tkLString,tkWstring,tkUstring,tkArray, - tkObject,tkRecord,tkDynArray,tkInterface,tkVariant]; - /// maps record or object in TTypeKind RTTI enumerate - tkRecordTypes = [tkObject,tkRecord]; - /// maps record or object in TTypeKind RTTI enumerate - tkRecordKinds = [tkObject,tkRecord]; - -type - /// TTypeKind RTTI enumerate as defined in Delphi 6 and up - TDelphiTypeKind = (dkUnknown, dkInteger, dkChar, dkEnumeration, dkFloat, - dkString, dkSet, dkClass, dkMethod, dkWChar, dkLString, dkWString, - dkVariant, dkArray, dkRecord, dkInterface, dkInt64, dkDynArray, - dkUString, dkClassRef, dkPointer, dkProcedure); - -const - /// convert FPC's TTypeKind to Delphi's RTTI enumerate - // - used internally for cross-compiler TDynArray binary serialization - FPCTODELPHI: array[TTypeKind] of TDelphiTypeKind = ( - dkUnknown,dkInteger,dkChar,dkEnumeration,dkFloat, - dkSet,dkMethod,dkString,dkLString,dkLString, - dkWString,dkVariant,dkArray,dkRecord,dkInterface, - dkClass,dkRecord,dkWChar,dkEnumeration,dkInt64,dkInt64, - dkDynArray,dkInterface,dkProcedure,dkUString,dkWChar, - dkPointer,dkPointer,dkClassRef,dkPointer); - - /// convert Delphi's TTypeKind to FPC's RTTI enumerate - DELPHITOFPC: array[TDelphiTypeKind] of TTypeKind = ( - tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat, - tkSString, tkSet, tkClass, tkMethod, tkWChar, tkLString, tkWString, - tkVariant, tkArray, tkRecord, tkInterface, tkInt64, tkDynArray, - tkUString, tkClassRef, tkPointer, tkProcVar); - -{$else} - /// available type families for Delphi 6 and up, similar to typinfo.pas - // - redefined here to be shared between SynCommons.pas and mORMot.pas, - // also leveraging FPC compatibility as much as possible (FPC's typinfo.pp - // is not convenient to share code with Delphi - see e.g. its tkLString) - TTypeKind = (tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat, - tkString, tkSet, tkClass, tkMethod, tkWChar, tkLString, tkWString, - tkVariant, tkArray, tkRecord, tkInterface, tkInt64, tkDynArray - {$ifdef UNICODE}, tkUString, tkClassRef, tkPointer, tkProcedure{$endif}); - -const - /// maps record or object in TTypeKind RTTI enumerate - tkRecordTypes = [tkRecord]; - /// maps record or object in TTypeKind RTTI enumerate - tkRecordKinds = tkRecord; - -{$endif FPC} - - /// maps long string in TTypeKind RTTI enumerate - tkStringTypes = - [tkLString, {$ifdef FPC}tkLStringOld,{$endif} tkWString - {$ifdef HASVARUSTRING}, tkUString{$endif}]; - /// maps 1, 8, 16, 32 and 64-bit ordinal in TTypeKind RTTI enumerate - tkOrdinalTypes = - [tkInteger, tkChar, tkWChar, tkEnumeration, tkSet, tkInt64 - {$ifdef FPC},tkBool,tkQWord{$endif}]; - /// quick retrieve how many bytes an ordinal consist in - ORDTYPE_SIZE: array[TOrdType] of byte = - (1,1,2,2,4,4{$ifdef FPC_NEWRTTI},8,8{$endif}); - -type - PTypeKind = ^TTypeKind; - TTypeKinds = set of TTypeKind; - POrdType = ^TOrdType; - PFloatType = ^TFloatType; - -function ToText(k: TTypeKind): PShortString; overload; - -type - /// function prototype to be used for TDynArray Sort and Find method - // - common functions exist for base types: see e.g. SortDynArrayBoolean, - // SortDynArrayByte, SortDynArrayWord, SortDynArrayInteger, SortDynArrayCardinal, - // SortDynArrayInt64, SortDynArrayQWord, SordDynArraySingle, SortDynArrayDouble, - // SortDynArrayAnsiString, SortDynArrayAnsiStringI, SortDynArrayUnicodeString, - // SortDynArrayUnicodeStringI, SortDynArrayString, SortDynArrayStringI - // - any custom type (even records) can be compared then sort by defining - // such a custom function - // - must return 0 if A=B, -1 if AB - TDynArraySortCompare = function(const A,B): integer; - - /// event oriented version of TDynArraySortCompare - TEventDynArraySortCompare = function(const A,B): integer of object; - - /// optional event called by TDynArray.LoadFrom method after each item load - // - could be used e.g. for string interning or some custom initialization process - // - won't be called if the dynamic array has ElemType=nil - TDynArrayAfterLoadFrom = procedure(var A) of object; - - /// internal enumeration used to specify some standard Delphi arrays - // - will be used e.g. to match JSON serialization or TDynArray search - // (see TDynArray and TDynArrayHash InitSpecific method) - // - djBoolean would generate an array of JSON boolean values - // - djByte .. djTimeLog match numerical JSON values - // - djDateTime .. djHash512 match textual JSON values - // - djVariant will match standard variant JSON serialization (including - // TDocVariant or other custom types, if any) - // - djCustom will be used for registered JSON serializer (invalid for - // InitSpecific methods call) - // - see also djPointer and djObject constant aliases for a pointer or - // TObject field hashing / comparison - // - is used also by TDynArray.InitSpecific() to define the main field type - TDynArrayKind = ( - djNone, - djBoolean, djByte, djWord, djInteger, djCardinal, djSingle, - djInt64, djQWord, djDouble, djCurrency, djTimeLog, - djDateTime, djDateTimeMS, djRawUTF8, djWinAnsi, djString, - djRawByteString, djWideString, djSynUnicode, - djHash128, djHash256, djHash512, - djInterface, {$ifndef NOVARIANTS}djVariant,{$endif} - djCustom); - - /// internal set to specify some standard Delphi arrays - TDynArrayKinds = set of TDynArrayKind; - - /// cross-compiler type used for string reference counter - // - FPC and Delphi don't always use the same type - TStrCnt = {$ifdef STRCNT32} longint {$else} SizeInt {$endif}; - /// pointer to cross-compiler type used for string reference counter - PStrCnt = ^TStrCnt; - - /// cross-compiler type used for dynarray reference counter - // - FPC uses PtrInt/SizeInt, Delphi uses longint even on CPU64 - TDACnt = {$ifdef DACNT32} longint {$else} SizeInt {$endif}; - /// pointer to cross-compiler type used for dynarray reference counter - PDACnt = ^TDACnt; - - /// internal integer type used for string header length field - TStrLen = {$ifdef FPC}SizeInt{$else}longint{$endif}; - /// internal pointer integer type used for string header length field - PStrLen = ^TStrLen; - - /// internal pointer integer type used for dynamic array header length field - PDALen = PPtrInt; - -{$ifdef FPC} - /// map the Delphi/FPC dynamic array header (stored before each instance) - // - define globally for proper inlining with FPC - // - match tdynarray type definition in dynarr.inc - TDynArrayRec = {packed} record - /// dynamic array reference count (basic memory management mechanism) - refCnt: TDACnt; - /// equals length-1 - high: tdynarrayindex; - function GetLength: sizeint; inline; - procedure SetLength(len: sizeint); inline; - property length: sizeint read GetLength write SetLength; - end; - PDynArrayRec = ^TDynArrayRec; -{$endif FPC} - -const - /// cross-compiler negative offset to TStrRec.length field - // - to be used inlined e.g. as PStrLen(p-_STRLEN)^ - _STRLEN = SizeOf(TStrLen); - /// cross-compiler negative offset to TStrRec.refCnt field - // - to be used inlined e.g. as PStrCnt(p-_STRREFCNT)^ - _STRREFCNT = Sizeof(TStrCnt)+_STRLEN; - - /// cross-compiler negative offset to TDynArrayRec.high/length field - // - to be used inlined e.g. as PDALen(PtrUInt(Values)-_DALEN)^{$ifdef FPC}+1{$endif} - _DALEN = SizeOf(PtrInt); - /// cross-compiler negative offset to TDynArrayRec.refCnt field - // - to be used inlined e.g. as PDACnt(PtrUInt(Values)-_DAREFCNT)^ - _DAREFCNT = Sizeof(TDACnt)+_DALEN; - -function ToText(k: TDynArrayKind): PShortString; overload; - -{$ifndef NOVARIANTS} - -type - /// possible options for a TDocVariant JSON/BSON document storage - // - dvoIsArray and dvoIsObject will store the "Kind: TDocVariantKind" state - - // you should never have to define these two options directly - // - dvoNameCaseSensitive will be used for every name lookup - here - // case-insensitivity is restricted to a-z A-Z 0-9 and _ characters - // - dvoCheckForDuplicatedNames will be used for method - // TDocVariantData.AddValue(), but not when setting properties at - // variant level: for consistency, "aVariant.AB := aValue" will replace - // any previous value for the name "AB" - // - dvoReturnNullForUnknownProperty will be used when retrieving any value - // from its name (for dvObject kind of instance), or index (for dvArray or - // dvObject kind of instance) - // - by default, internal values will be copied by-value from one variant - // instance to another, to ensure proper safety - but it may be too slow: - // if you set dvoValueCopiedByReference, the internal - // TDocVariantData.VValue/VName instances will be copied by-reference, - // to avoid memory allocations, BUT it may break internal process if you change - // some values in place (since VValue/VName and VCount won't match) - as such, - // if you set this option, ensure that you use the content as read-only - // - any registered custom types may have an extended JSON syntax (e.g. - // TBSONVariant does for MongoDB types), and will be searched during JSON - // parsing, unless dvoJSONParseDoNotTryCustomVariants is set (slightly faster) - // - by default, it will only handle direct JSON [array] of {object}: but if - // you define dvoJSONObjectParseWithinString, it will also try to un-escape - // a JSON string first, i.e. handle "[array]" or "{object}" content (may be - // used e.g. when JSON has been retrieved from a database TEXT column) - is - // used for instance by VariantLoadJSON() - // - JSON serialization will follow the standard layout, unless - // dvoSerializeAsExtendedJson is set so that the property names would not - // be escaped with double quotes, writing '{name:"John",age:123}' instead of - // '{"name":"John","age":123}': this extended json layout is compatible with - // http://docs.mongodb.org/manual/reference/mongodb-extended-json and with - // TDocVariant JSON unserialization, also our SynCrossPlatformJSON unit, but - // NOT recognized by most JSON clients, like AJAX/JavaScript or C#/Java - // - by default, only integer/Int64/currency number values are allowed, unless - // dvoAllowDoubleValue is set and 32-bit floating-point conversion is tried, - // with potential loss of precision during the conversion - // - dvoInternNames and dvoInternValues will use shared TRawUTF8Interning - // instances to maintain a list of RawUTF8 names/values for all TDocVariant, - // so that redundant text content will be allocated only once on heap - TDocVariantOption = - (dvoIsArray, dvoIsObject, - dvoNameCaseSensitive, dvoCheckForDuplicatedNames, - dvoReturnNullForUnknownProperty, - dvoValueCopiedByReference, dvoJSONParseDoNotTryCustomVariants, - dvoJSONObjectParseWithinString, dvoSerializeAsExtendedJson, - dvoAllowDoubleValue, dvoInternNames, dvoInternValues); - - /// set of options for a TDocVariant storage - // - you can use JSON_OPTIONS[true] if you want to create a fast by-reference - // local document as with _ObjFast/_ArrFast/_JsonFast - i.e. - // [dvoReturnNullForUnknownProperty,dvoValueCopiedByReference] - // - when specifying the options, you should not include dvoIsArray nor - // dvoIsObject directly in the set, but explicitly define TDocVariantDataKind - TDocVariantOptions = set of TDocVariantOption; - - /// pointer to a set of options for a TDocVariant storage - // - you may use e.g. @JSON_OPTIONS[true], @JSON_OPTIONS[false], - // @JSON_OPTIONS_FAST_STRICTJSON or @JSON_OPTIONS_FAST_EXTENDED - PDocVariantOptions = ^TDocVariantOptions; - -const - /// some convenient TDocVariant options, as JSON_OPTIONS[CopiedByReference] - // - JSON_OPTIONS[false] is e.g. _Json() and _JsonFmt() functions default - // - JSON_OPTIONS[true] are used e.g. by _JsonFast() and _JsonFastFmt() functions - // - warning: exclude dvoAllowDoubleValue so won't parse any float, just currency - JSON_OPTIONS: array[Boolean] of TDocVariantOptions = ( - [dvoReturnNullForUnknownProperty], - [dvoReturnNullForUnknownProperty,dvoValueCopiedByReference]); - - /// same as JSON_OPTIONS[true], but can not be used as PDocVariantOptions - // - warning: exclude dvoAllowDoubleValue so won't parse any float, just currency - // - as used by _JsonFast() - JSON_OPTIONS_FAST = - [dvoReturnNullForUnknownProperty,dvoValueCopiedByReference]; - - /// same as JSON_OPTIONS_FAST, but including dvoAllowDoubleValue to parse any float - // - as used by _JsonFastFloat() - JSON_OPTIONS_FAST_FLOAT = - [dvoReturnNullForUnknownProperty,dvoValueCopiedByReference,dvoAllowDoubleValue]; - - /// TDocVariant options which may be used for plain JSON parsing - // - this won't recognize any extended syntax - JSON_OPTIONS_FAST_STRICTJSON: TDocVariantOptions = - [dvoReturnNullForUnknownProperty,dvoValueCopiedByReference, - dvoJSONParseDoNotTryCustomVariants]; - - /// TDocVariant options to be used for case-sensitive TSynNameValue-like - // storage, with optional extended JSON syntax serialization - // - consider using JSON_OPTIONS_FAST_EXTENDED for case-insensitive objects - JSON_OPTIONS_NAMEVALUE: array[boolean] of TDocVariantOptions = ( - [dvoReturnNullForUnknownProperty,dvoValueCopiedByReference, - dvoNameCaseSensitive], - [dvoReturnNullForUnknownProperty,dvoValueCopiedByReference, - dvoNameCaseSensitive,dvoSerializeAsExtendedJson]); - - /// TDocVariant options to be used for case-sensitive TSynNameValue-like - // storage, RawUTF8 interning and optional extended JSON syntax serialization - // - consider using JSON_OPTIONS_FAST_EXTENDED for case-insensitive objects, - // or JSON_OPTIONS_NAMEVALUE[] if you don't expect names and values interning - JSON_OPTIONS_NAMEVALUEINTERN: array[boolean] of TDocVariantOptions = ( - [dvoReturnNullForUnknownProperty,dvoValueCopiedByReference, - dvoNameCaseSensitive,dvoInternNames,dvoInternValues], - [dvoReturnNullForUnknownProperty,dvoValueCopiedByReference, - dvoNameCaseSensitive,dvoInternNames,dvoInternValues, - dvoSerializeAsExtendedJson]); - - /// TDocVariant options to be used so that JSON serialization would - // use the unquoted JSON syntax for field names - // - you could use it e.g. on a TSQLRecord variant published field to - // reduce the JSON escape process during storage in the database, by - // customizing your TSQLModel instance: - // ! (aModel.Props[TSQLMyRecord]['VariantProp'] as TSQLPropInfoRTTIVariant). - // ! DocVariantOptions := JSON_OPTIONS_FAST_EXTENDED; - // or - in a cleaner way - by overriding TSQLRecord.InternalDefineModel(): - // ! class procedure TSQLMyRecord.InternalDefineModel(Props: TSQLRecordProperties); - // ! begin - // ! (Props.Fields.ByName('VariantProp') as TSQLPropInfoRTTIVariant). - // ! DocVariantOptions := JSON_OPTIONS_FAST_EXTENDED; - // ! end; - // or to set all variant fields at once: - // ! class procedure TSQLMyRecord.InternalDefineModel(Props: TSQLRecordProperties); - // ! begin - // ! Props.SetVariantFieldsDocVariantOptions(JSON_OPTIONS_FAST_EXTENDED); - // ! end; - // - consider using JSON_OPTIONS_NAMEVALUE[true] for case-sensitive - // TSynNameValue-like storage, or JSON_OPTIONS_FAST_EXTENDEDINTERN if you - // expect RawUTF8 names and values interning - JSON_OPTIONS_FAST_EXTENDED: TDocVariantOptions = - [dvoReturnNullForUnknownProperty,dvoValueCopiedByReference, - dvoSerializeAsExtendedJson]; - - /// TDocVariant options for JSON serialization with efficient storage - // - i.e. unquoted JSON syntax for field names and RawUTF8 interning - // - may be used e.g. for efficient persistence of similar data - // - consider using JSON_OPTIONS_FAST_EXTENDED if you don't expect - // RawUTF8 names and values interning, or need BSON variants parsing - JSON_OPTIONS_FAST_EXTENDEDINTERN: TDocVariantOptions = - [dvoReturnNullForUnknownProperty,dvoValueCopiedByReference, - dvoSerializeAsExtendedJson,dvoJSONParseDoNotTryCustomVariants, - dvoInternNames,dvoInternValues]; - -{$endif NOVARIANTS} - -const - /// TDynArrayKind alias for a pointer field hashing / comparison - djPointer = {$ifdef CPU64}djInt64{$else}djCardinal{$endif}; - - /// TDynArrayKind alias for a TObject field hashing / comparison - djObject = djPointer; - -type - /// the available JSON format, for TTextWriter.AddJSONReformat() and its - // JSONBufferReformat() and JSONReformat() wrappers - // - jsonCompact is the default machine-friendly single-line layout - // - jsonHumanReadable will add line feeds and indentation, for a more - // human-friendly result - // - jsonUnquotedPropName will emit the jsonHumanReadable layout, but - // with all property names being quoted only if necessary: this format - // could be used e.g. for configuration files - this format, similar to the - // one used in the MongoDB extended syntax, is not JSON compatible: do not - // use it e.g. with AJAX clients, but is would be handled as expected by all - // our units as valid JSON input, without previous correction - // - jsonUnquotedPropNameCompact will emit single-line layout with unquoted - // property names - TTextWriterJSONFormat = ( - jsonCompact, jsonHumanReadable, - jsonUnquotedPropName, jsonUnquotedPropNameCompact); - - TDynArrayObjArray = (oaUnknown, oaFalse, oaTrue); - - /// a wrapper around a dynamic array with one dimension - // - provide TList-like methods using fast RTTI information - // - can be used to fast save/retrieve all memory content to a TStream - // - note that the "const Elem" is not checked at compile time nor runtime: - // you must ensure that Elem matchs the element type of the dynamic array - // - can use external Count storage to make Add() and Delete() much faster - // (avoid most reallocation of the memory buffer) - // - Note that TDynArray is just a wrapper around an existing dynamic array: - // methods can modify the content of the associated variable but the TDynArray - // doesn't contain any data by itself. It is therefore aimed to initialize - // a TDynArray wrapper on need, to access any existing dynamic array. - // - is defined as an object or as a record, due to a bug - // in Delphi 2009/2010 compiler (at least): this structure is not initialized - // if defined as an object on the stack, but will be as a record :( - {$ifdef UNDIRECTDYNARRAY}TDynArray = record - {$else}TDynArray = object {$endif} - private - fValue: PPointer; - fTypeInfo: pointer; - fElemType{$ifdef DYNARRAYELEMTYPE2}, fElemType2{$endif}: pointer; - fCountP: PInteger; - fCompare: TDynArraySortCompare; - fElemSize: cardinal; - fKnownSize: integer; - fParser: integer; // index to GlobalJSONCustomParsers.fParsers[] - fSorted: boolean; - fKnownType: TDynArrayKind; - fIsObjArray: TDynArrayObjArray; - function GetCount: PtrInt; {$ifdef HASINLINE}inline;{$endif} - procedure SetCount(aCount: PtrInt); - function GetCapacity: PtrInt; {$ifdef HASINLINE}inline;{$endif} - procedure SetCapacity(aCapacity: PtrInt); - procedure SetCompare(const aCompare: TDynArraySortCompare); {$ifdef HASINLINE}inline;{$endif} - function FindIndex(const Elem; aIndex: PIntegerDynArray; - aCompare: TDynArraySortCompare): PtrInt; - function GetArrayTypeName: RawUTF8; - function GetArrayTypeShort: PShortString; - function GetIsObjArray: boolean; {$ifdef HASINLINE}inline;{$endif} - function ComputeIsObjArray: boolean; - procedure SetIsObjArray(aValue: boolean); {$ifdef HASINLINE}inline;{$endif} - function LoadFromHeader(var Source: PByte; SourceMax: PByte): integer; - function LoadKnownType(Data,Source,SourceMax: PAnsiChar): boolean; - /// faster than RTL + handle T*ObjArray + ensure unique - procedure InternalSetLength(OldLength,NewLength: PtrUInt); - public - /// initialize the wrapper with a one-dimension dynamic array - // - the dynamic array must have been defined with its own type - // (e.g. TIntegerDynArray = array of Integer) - // - if aCountPointer is set, it will be used instead of length() to store - // the dynamic array items count - it will be much faster when adding - // elements to the array, because the dynamic array won't need to be - // resized each time - but in this case, you should use the Count property - // instead of length(array) or high(array) when accessing the data: in fact - // length(array) will store the memory size reserved, not the items count - // - if aCountPointer is set, its content will be set to 0, whatever the - // array length is, or the current aCountPointer^ value is - // - a sample usage may be: - // !var DA: TDynArray; - // ! A: TIntegerDynArray; - // !begin - // ! DA.Init(TypeInfo(TIntegerDynArray),A); - // ! (...) - // - a sample usage may be (using a count variable): - // !var DA: TDynArray; - // ! A: TIntegerDynArray; - // ! ACount: integer; - // ! i: integer; - // !begin - // ! DA.Init(TypeInfo(TIntegerDynArray),A,@ACount); - // ! for i := 1 to 100000 do - // ! DA.Add(i); // MUCH faster using the ACount variable - // ! (...) // now you should use DA.Count or Count instead of length(A) - procedure Init(aTypeInfo: pointer; var aValue; aCountPointer: PInteger=nil); - /// initialize the wrapper with a one-dimension dynamic array - // - this version accepts to specify how comparison should occur, using - // TDynArrayKind kind of first field - // - djNone and djCustom are too vague, and will raise an exception - // - no RTTI check is made over the corresponding array layout: you shall - // ensure that the aKind parameter matches the dynamic array element definition - // - aCaseInsensitive will be used for djRawUTF8..djHash512 text comparison - procedure InitSpecific(aTypeInfo: pointer; var aValue; aKind: TDynArrayKind; - aCountPointer: PInteger=nil; aCaseInsensitive: boolean=false); - /// define the reference to an external count integer variable - // - Init and InitSpecific methods will reset the aCountPointer to 0: you - // can use this method to set the external count variable without overriding - // the current value - procedure UseExternalCount(var aCountPointer: Integer); - {$ifdef HASINLINE}inline;{$endif} - /// low-level computation of KnownType and KnownSize fields from RTTI - // - do nothing if has already been set at initialization, or already computed - function GuessKnownType(exactType: boolean=false): TDynArrayKind; - /// check this dynamic array from the GlobalJSONCustomParsers list - // - returns TRUE if this array has a custom JSON parser - function HasCustomJSONParser: boolean; - /// initialize the wrapper to point to no dynamic array - procedure Void; - /// check if the wrapper points to a dynamic array - function IsVoid: boolean; - /// add an element to the dynamic array - // - warning: Elem must be of the same exact type than the dynamic array, - // and must be a reference to a variable (you can't write Add(i+10) e.g.) - // - returns the index of the added element in the dynamic array - // - note that because of dynamic array internal memory managment, adding - // may reallocate the list every time a record is added, unless an external - // count variable has been specified in Init(...,@Count) method - function Add(const Elem): PtrInt; - /// add an element to the dynamic array - // - this version add a void element to the array, and returns its index - // - note: if you use this method to add a new item with a reference to the - // dynamic array, using a local variable is needed under FPC: - // ! i := DynArray.New; - // ! with Values[i] do begin // otherwise Values is nil -> GPF - // ! Field1 := 1; - // ! ... - function New: integer; - /// add an element to the dynamic array at the position specified by Index - // - warning: Elem must be of the same exact type than the dynamic array, - // and must be a reference to a variable (you can't write Insert(10,i+10) e.g.) - procedure Insert(Index: PtrInt; const Elem); - /// get and remove the last element stored in the dynamic array - // - Add + Pop/Peek will implement a LIFO (Last-In-First-Out) stack - // - warning: Elem must be of the same exact type than the dynamic array - // - returns true if the item was successfully copied and removed - // - use Peek() if you don't want to remove the item - function Pop(var Dest): boolean; - /// get the last element stored in the dynamic array - // - Add + Pop/Peek will implement a LIFO (Last-In-First-Out) stack - // - warning: Elem must be of the same exact type than the dynamic array - // - returns true if the item was successfully copied into Dest - // - use Pop() if you also want to remove the item - function Peek(var Dest): boolean; - /// delete the whole dynamic array content - // - this method will recognize T*ObjArray types and free all instances - procedure Clear; {$ifdef HASINLINE}inline;{$endif} - /// delete the whole dynamic array content, ignoring exceptions - // - returns true if no exception occured when calling Clear, false otherwise - // - you should better not call this method, which will catch and ignore - // all exceptions - but it may somewhat make sense in a destructor - // - this method will recognize T*ObjArray types and free all instances - function ClearSafe: boolean; - /// delete one item inside the dynamic array - // - the deleted element is finalized if necessary - // - this method will recognize T*ObjArray types and free all instances - function Delete(aIndex: PtrInt): boolean; - /// search for an element value inside the dynamic array - // - return the index found (0..Count-1), or -1 if Elem was not found - // - will search for all properties content of the eLement: TList.IndexOf() - // searches by address, this method searches by content using the RTTI - // element description (and not the Compare property function) - // - use the Find() method if you want the search via the Compare property - // function, or e.g. to search only with some part of the element content - // - will work with simple types: binaries (byte, word, integer, Int64, - // Currency, array[0..255] of byte, packed records with no reference-counted - // type within...), string types (e.g. array of string), and packed records - // with binary and string types within (like TFileVersion) - // - won't work with not packed types (like a shorstring, or a record - // with byte or word fields with {$A+}): in this case, the padding data - // (i.e. the bytes between the aligned feeds can be filled as random, and - // there is no way with standard RTTI do know which they are) - // - warning: Elem must be of the same exact type than the dynamic array, - // and must be a reference to a variable (you can't write IndexOf(i+10) e.g.) - function IndexOf(const Elem): PtrInt; - /// search for an element value inside the dynamic array - // - this method will use the Compare property function for the search - // - return the index found (0..Count-1), or -1 if Elem was not found - // - if the array is sorted, it will use fast O(log(n)) binary search - // - if the array is not sorted, it will use slower O(n) iterating search - // - warning: Elem must be of the same exact type than the dynamic array, - // and must be a reference to a variable (you can't write Find(i+10) e.g.) - function Find(const Elem): PtrInt; overload; - /// search for an element value inside the dynamic array, from an external - // indexed lookup table - // - return the index found (0..Count-1), or -1 if Elem was not found - // - this method will use a custom comparison function, with an external - // integer table, as created by the CreateOrderedIndex() method: it allows - // multiple search orders in the same dynamic array content - // - if an indexed lookup is supplied, it must already be sorted: - // this function will then use fast O(log(n)) binary search - // - if an indexed lookup is not supplied (i.e aIndex=nil), - // this function will use slower but accurate O(n) iterating search - // - warning; the lookup index should be synchronized if array content - // is modified (in case of adding or deletion) - function Find(const Elem; const aIndex: TIntegerDynArray; - aCompare: TDynArraySortCompare): PtrInt; overload; - /// search for an element value, then fill all properties if match - // - this method will use the Compare property function for the search, - // or the supplied indexed lookup table and its associated compare function - // - if Elem content matches, all Elem fields will be filled with the record - // - can be used e.g. as a simple dictionary: if Compare will match e.g. the - // first string field (i.e. set to SortDynArrayString), you can fill the - // first string field with the searched value (if returned index is >= 0) - // - return the index found (0..Count-1), or -1 if Elem was not found - // - if the array is sorted, it will use fast O(log(n)) binary search - // - if the array is not sorted, it will use slower O(n) iterating search - // - warning: Elem must be of the same exact type than the dynamic array, - // and must be a reference to a variable (you can't write Find(i+10) e.g.) - function FindAndFill(var Elem; aIndex: PIntegerDynArray=nil; - aCompare: TDynArraySortCompare=nil): integer; - /// search for an element value, then delete it if match - // - this method will use the Compare property function for the search, - // or the supplied indexed lookup table and its associated compare function - // - if Elem content matches, this item will be deleted from the array - // - can be used e.g. as a simple dictionary: if Compare will match e.g. the - // first string field (i.e. set to SortDynArrayString), you can fill the - // first string field with the searched value (if returned index is >= 0) - // - return the index deleted (0..Count-1), or -1 if Elem was not found - // - if the array is sorted, it will use fast O(log(n)) binary search - // - if the array is not sorted, it will use slower O(n) iterating search - // - warning: Elem must be of the same exact type than the dynamic array, - // and must be a reference to a variable (you can't write Find(i+10) e.g.) - function FindAndDelete(const Elem; aIndex: PIntegerDynArray=nil; - aCompare: TDynArraySortCompare=nil): integer; - /// search for an element value, then update the item if match - // - this method will use the Compare property function for the search, - // or the supplied indexed lookup table and its associated compare function - // - if Elem content matches, this item will be updated with the supplied value - // - can be used e.g. as a simple dictionary: if Compare will match e.g. the - // first string field (i.e. set to SortDynArrayString), you can fill the - // first string field with the searched value (if returned index is >= 0) - // - return the index found (0..Count-1), or -1 if Elem was not found - // - if the array is sorted, it will use fast O(log(n)) binary search - // - if the array is not sorted, it will use slower O(n) iterating search - // - warning: Elem must be of the same exact type than the dynamic array, - // and must be a reference to a variable (you can't write Find(i+10) e.g.) - function FindAndUpdate(const Elem; aIndex: PIntegerDynArray=nil; - aCompare: TDynArraySortCompare=nil): integer; - /// search for an element value, then add it if none matched - // - this method will use the Compare property function for the search, - // or the supplied indexed lookup table and its associated compare function - // - if no Elem content matches, the item will added to the array - // - can be used e.g. as a simple dictionary: if Compare will match e.g. the - // first string field (i.e. set to SortDynArrayString), you can fill the - // first string field with the searched value (if returned index is >= 0) - // - return the index found (0..Count-1), or -1 if Elem was not found and - // the supplied element has been succesfully added - // - if the array is sorted, it will use fast O(log(n)) binary search - // - if the array is not sorted, it will use slower O(n) iterating search - // - warning: Elem must be of the same exact type than the dynamic array, - // and must be a reference to a variable (you can't write Find(i+10) e.g.) - function FindAndAddIfNotExisting(const Elem; aIndex: PIntegerDynArray=nil; - aCompare: TDynArraySortCompare=nil): integer; - /// sort the dynamic array elements, using the Compare property function - // - it will change the dynamic array content, and exchange all elements - // in order to be sorted in increasing order according to Compare function - procedure Sort(aCompare: TDynArraySortCompare=nil); overload; - /// sort some dynamic array elements, using the Compare property function - // - this method allows to sort only some part of the items - // - it will change the dynamic array content, and exchange all elements - // in order to be sorted in increasing order according to Compare function - procedure SortRange(aStart, aStop: integer; aCompare: TDynArraySortCompare=nil); - /// sort the dynamic array elements, using a Compare method (not function) - // - it will change the dynamic array content, and exchange all elements - // in order to be sorted in increasing order according to Compare function, - // unless aReverse is true - // - it won't mark the array as Sorted, since the comparer is local - procedure Sort(const aCompare: TEventDynArraySortCompare; aReverse: boolean=false); overload; - /// search the elements range which match a given value in a sorted dynamic array - // - this method will use the Compare property function for the search - // - returns TRUE and the matching indexes, or FALSE if none found - // - if the array is not sorted, returns FALSE - function FindAllSorted(const Elem; out FirstIndex,LastIndex: Integer): boolean; - /// search for an element value inside a sorted dynamic array - // - this method will use the Compare property function for the search - // - will be faster than a manual FindAndAddIfNotExisting+Sort process - // - returns TRUE and the index of existing Elem, or FALSE and the index - // where the Elem is to be inserted so that the array remains sorted - // - you should then call FastAddSorted() later with the returned Index - // - if the array is not sorted, returns FALSE and Index=-1 - // - warning: Elem must be of the same exact type than the dynamic array, - // and must be a reference to a variable (no FastLocateSorted(i+10) e.g.) - function FastLocateSorted(const Elem; out Index: Integer): boolean; - /// insert a sorted element value at the proper place - // - the index should have been computed by FastLocateSorted(): false - // - you may consider using FastLocateOrAddSorted() instead - procedure FastAddSorted(Index: Integer; const Elem); - /// search and add an element value inside a sorted dynamic array - // - this method will use the Compare property function for the search - // - will be faster than a manual FindAndAddIfNotExisting+Sort process - // - returns the index of the existing Elem and wasAdded^=false - // - returns the sorted index of the inserted Elem and wasAdded^=true - // - if the array is not sorted, returns -1 and wasAdded^=false - // - is just a wrapper around FastLocateSorted+FastAddSorted - function FastLocateOrAddSorted(const Elem; wasAdded: PBoolean=nil): integer; - /// delete a sorted element value at the proper place - // - plain Delete(Index) would reset the fSorted flag to FALSE, so use - // this method with a FastLocateSorted/FastAddSorted array - procedure FastDeleteSorted(Index: Integer); - /// will reverse all array elements, in place - procedure Reverse; - /// sort the dynamic array elements using a lookup array of indexes - // - in comparison to the Sort method, this CreateOrderedIndex won't change - // the dynamic array content, but only create (or update) the supplied - // integer lookup array, using the specified comparison function - // - if aCompare is not supplied, the method will use fCompare (if defined) - // - you should provide either a void either a valid lookup table, that is - // a table with one to one lookup (e.g. created with FillIncreasing) - // - if the lookup table has less elements than the main dynamic array, - // its content will be recreated - procedure CreateOrderedIndex(var aIndex: TIntegerDynArray; - aCompare: TDynArraySortCompare); overload; - /// sort the dynamic array elements using a lookup array of indexes - // - this overloaded method will use the supplied TSynTempBuffer for - // index storage, so use PIntegerArray(aIndex.buf) to access the values - // - caller should always make aIndex.Done once done - procedure CreateOrderedIndex(out aIndex: TSynTempBuffer; - aCompare: TDynArraySortCompare); overload; - /// sort using a lookup array of indexes, after a Add() - // - will resize aIndex if necessary, and set aIndex[Count-1] := Count-1 - procedure CreateOrderedIndexAfterAdd(var aIndex: TIntegerDynArray; - aCompare: TDynArraySortCompare); - /// save the dynamic array content into a (memory) stream - // - will handle array of binaries values (byte, word, integer...), array of - // strings or array of packed records, with binaries and string properties - // - will use a proprietary binary format, with some variable-length encoding - // of the string length - note that if you change the type definition, any - // previously-serialized content will fail, maybe triggering unexpected GPF: - // use SaveToTypeInfoHash if you share this binary data accross executables - // - Stream position will be set just after the added data - // - is optimized for memory streams, but will work with any kind of TStream - procedure SaveToStream(Stream: TStream); - /// load the dynamic array content from a (memory) stream - // - stream content must have been created using SaveToStream method - // - will handle array of binaries values (byte, word, integer...), array of - // strings or array of packed records, with binaries and string properties - // - will use a proprietary binary format, with some variable-length encoding - // of the string length - note that if you change the type definition, any - // previously-serialized content will fail, maybe triggering unexpected GPF: - // use SaveToTypeInfoHash if you share this binary data accross executables - procedure LoadFromStream(Stream: TCustomMemoryStream); - /// save the dynamic array content into an allocated memory buffer - // - Dest buffer must have been allocated to contain at least the number - // of bytes returned by the SaveToLength method - // - return a pointer at the end of the data written in Dest, nil in case - // of an invalid input buffer - // - will use a proprietary binary format, with some variable-length encoding - // of the string length - note that if you change the type definition, any - // previously-serialized content will fail, maybe triggering unexpected GPF: - // use SaveToTypeInfoHash if you share this binary data accross executables - // - this method will raise an ESynException for T*ObjArray types - // - use TDynArray.LoadFrom or TDynArrayLoadFrom to decode the saved buffer - function SaveTo(Dest: PAnsiChar): PAnsiChar; overload; - /// compute the number of bytes needed by SaveTo() to persist a dynamic array - // - will use a proprietary binary format, with some variable-length encoding - // of the string length - note that if you change the type definition, any - // previously-serialized content will fail, maybe triggering unexpected GPF: - // use SaveToTypeInfoHash if you share this binary data accross executables - // - this method will raise an ESynException for T*ObjArray types - function SaveToLength: integer; - /// save the dynamic array content into a RawByteString - // - will use a proprietary binary format, with some variable-length encoding - // of the string length - note that if you change the type definition, any - // previously-serialized content will fail, maybe triggering unexpected GPF: - // use SaveToTypeInfoHash if you share this binary data accross executables - // - this method will raise an ESynException for T*ObjArray types - // - use TDynArray.LoadFrom or TDynArrayLoadFrom to decode the saved buffer - function SaveTo: RawByteString; overload; - /// compute a crc32c-based hash of the RTTI for this dynamic array - // - can be used to ensure that the TDynArray.SaveTo binary layout - // is compatible accross executables - // - won't include the RTTI type kind, as TypeInfoToHash(), but only - // ElemSize or ElemType information, or any previously registered - // TTextWriter.RegisterCustomJSONSerializerFromText definition - function SaveToTypeInfoHash(crc: cardinal=0): cardinal; - /// unserialize dynamic array content from binary written by TDynArray.SaveTo - // - return nil if the Source buffer is incorrect: invalid type, wrong - // checksum, or optional SourceMax overflow - // - return a non nil pointer just after the Source content on success - // - this method will raise an ESynException for T*ObjArray types - // - you can optionally call AfterEach callback for each row loaded - // - if you don't want to allocate all items on memory, but just want to - // iterate over all items stored in a TDynArray.SaveTo memory buffer, - // consider using TDynArrayLoadFrom object - function LoadFrom(Source: PAnsiChar; AfterEach: TDynArrayAfterLoadFrom=nil; - NoCheckHash: boolean=false; SourceMax: PAnsiChar=nil): PAnsiChar; - /// unserialize the dynamic array content from a TDynArray.SaveTo binary string - // - same as LoadFrom, and will check for any buffer overflow since we - // know the actual end of input buffer - function LoadFromBinary(const Buffer: RawByteString; - NoCheckHash: boolean=false): boolean; - /// serialize the dynamic array content as JSON - // - is just a wrapper around TTextWriter.AddDynArrayJSON() - // - this method will therefore recognize T*ObjArray types - function SaveToJSON(EnumSetsAsText: boolean=false; - reformat: TTextWriterJSONFormat=jsonCompact): RawUTF8; overload; - {$ifdef HASINLINE}inline;{$endif} - /// serialize the dynamic array content as JSON - // - is just a wrapper around TTextWriter.AddDynArrayJSON() - // - this method will therefore recognize T*ObjArray types - procedure SaveToJSON(out Result: RawUTF8; EnumSetsAsText: boolean=false; - reformat: TTextWriterJSONFormat=jsonCompact); overload; - /// load the dynamic array content from an UTF-8 encoded JSON buffer - // - expect the format as saved by TTextWriter.AddDynArrayJSON method, i.e. - // handling TBooleanDynArray, TIntegerDynArray, TInt64DynArray, TCardinalDynArray, - // TDoubleDynArray, TCurrencyDynArray, TWordDynArray, TByteDynArray, - // TRawUTF8DynArray, TWinAnsiDynArray, TRawByteStringDynArray, - // TStringDynArray, TWideStringDynArray, TSynUnicodeDynArray, - // TTimeLogDynArray and TDateTimeDynArray as JSON array - or any customized - // valid JSON serialization as set by TTextWriter.RegisterCustomJSONSerializer - // - or any other kind of array as Base64 encoded binary stream precessed - // via JSON_BASE64_MAGIC (UTF-8 encoded \uFFF0 special code) - // - typical handled content could be - // ! '[1,2,3,4]' or '["\uFFF0base64encodedbinary"]' - // - return a pointer at the end of the data read from P, nil in case - // of an invalid input buffer - // - this method will recognize T*ObjArray types, and will first free - // any existing instance before unserializing, to avoid memory leak - // - warning: the content of P^ will be modified during parsing: please - // make a local copy if it will be needed later (using e.g. TSynTempBufer) - function LoadFromJSON(P: PUTF8Char; aEndOfObject: PUTF8Char=nil{$ifndef NOVARIANTS}; - CustomVariantOptions: PDocVariantOptions=nil{$endif}): PUTF8Char; - {$ifndef NOVARIANTS} - /// load the dynamic array content from a TDocVariant instance - // - will convert the TDocVariant into JSON, the call LoadFromJSON - function LoadFromVariant(const DocVariant: variant): boolean; - {$endif NOVARIANTS} - /// select a sub-section (slice) of a dynamic array content - procedure Slice(var Dest; aCount: Cardinal; aFirstIndex: cardinal=0); - /// add elements from a given dynamic array variable - // - the supplied source DynArray MUST be of the same exact type as the - // current used for this TDynArray - warning: pass here a reference to - // a "array of ..." variable, not another TDynArray instance; if you - // want to add another TDynArray, use AddDynArray() method - // - you can specify the start index and the number of items to take from - // the source dynamic array (leave as -1 to add till the end) - // - returns the number of items added to the array - function AddArray(const DynArrayVar; aStartIndex: integer=0; aCount: integer=-1): integer; - {$ifndef DELPHI5OROLDER} - /// fast initialize a wrapper for an existing dynamic array of the same type - // - is slightly faster than - // ! Init(aAnother.ArrayType,aValue,nil); - procedure InitFrom(const aAnother: TDynArray; var aValue); - {$ifdef HASINLINE}inline;{$endif} - /// add elements from a given TDynArray - // - the supplied source TDynArray MUST be of the same exact type as the - // current used for this TDynArray, otherwise it won't do anything - // - you can specify the start index and the number of items to take from - // the source dynamic array (leave as -1 to add till the end) - procedure AddDynArray(const aSource: TDynArray; aStartIndex: integer=0; aCount: integer=-1); - /// compare the content of the two arrays, returning TRUE if both match - // - this method compares using any supplied Compare property (unless - // ignorecompare=true), or by content using the RTTI element description - // of the whole array items - // - will call SaveToJSON to compare T*ObjArray kind of arrays - function Equals(const B: TDynArray; ignorecompare: boolean=false): boolean; - /// set all content of one dynamic array to the current array - // - both must be of the same exact type - // - T*ObjArray will be reallocated and copied by content (using a temporary - // JSON serialization), unless ObjArrayByRef is true and pointers are copied - procedure Copy(const Source: TDynArray; ObjArrayByRef: boolean=false); - /// set all content of one dynamic array to the current array - // - both must be of the same exact type - // - T*ObjArray will be reallocated and copied by content (using a temporary - // JSON serialization), unless ObjArrayByRef is true and pointers are copied - procedure CopyFrom(const Source; MaxElem: integer; ObjArrayByRef: boolean=false); - /// set all content of the current dynamic array to another array variable - // - both must be of the same exact type - // - resulting length(Dest) will match the exact items count, even if an - // external Count integer variable is used by this instance - // - T*ObjArray will be reallocated and copied by content (using a temporary - // JSON serialization), unless ObjArrayByRef is true and pointers are copied - procedure CopyTo(out Dest; ObjArrayByRef: boolean=false); - {$endif DELPHI5OROLDER} - /// returns a pointer to an element of the array - // - returns nil if aIndex is out of range - // - since TDynArray is just a wrapper around an existing array, you should - // better use direct access to its wrapped variable, and not using this - // slower and more error prone method (such pointer access lacks of strong - // typing abilities), which was designed for TDynArray internal use - function ElemPtr(index: PtrInt): pointer; {$ifdef HASINLINE}inline;{$endif} - /// will copy one element content from its index into another variable - // - do nothing if index is out of range - procedure ElemCopyAt(index: PtrInt; var Dest); {$ifdef FPC}inline;{$endif} - /// will move one element content from its index into another variable - // - will erase the internal item after copy - // - do nothing if index is out of range - procedure ElemMoveTo(index: PtrInt; var Dest); - /// will copy one variable content into an indexed element - // - do nothing if index is out of range - // - ClearBeforeCopy will call ElemClear() before the copy, which may be safer - // if the source item is a copy of Values[index] with some dynamic arrays - procedure ElemCopyFrom(const Source; index: PtrInt; - ClearBeforeCopy: boolean=false); {$ifdef FPC}inline;{$endif} - /// compare the content of two elements, returning TRUE if both values equal - // - this method compares first using any supplied Compare property, - // then by content using the RTTI element description of the whole record - function ElemEquals(const A,B): boolean; - /// will reset the element content - procedure ElemClear(var Elem); - /// will copy one element content - procedure ElemCopy(const A; var B); {$ifdef FPC}inline;{$endif} - /// will copy the first field value of an array element - // - will use the array KnownType to guess the copy routine to use - // - returns false if the type information is not enough for a safe copy - function ElemCopyFirstField(Source,Dest: Pointer): boolean; - /// save an array element into a serialized binary content - // - use the same layout as TDynArray.SaveTo, but for a single item - // - you can use ElemLoad method later to retrieve its content - // - warning: Elem must be of the same exact type than the dynamic array, - // and must be a reference to a variable (you can't write ElemSave(i+10) e.g.) - function ElemSave(const Elem): RawByteString; - /// load an array element as saved by the ElemSave method into Elem variable - // - warning: Elem must be of the same exact type than the dynamic array, - // and must be a reference to a variable (you can't write ElemLoad(P,i+10) e.g.) - procedure ElemLoad(Source: PAnsiChar; var Elem; SourceMax: PAnsiChar=nil); overload; - /// load an array element as saved by the ElemSave method - // - this overloaded method will retrieve the element as a memory buffer, - // which should be cleared by ElemLoadClear() before release - function ElemLoad(Source: PAnsiChar; SourceMax: PAnsiChar=nil): RawByteString; overload; - /// search for an array element as saved by the ElemSave method - // - same as ElemLoad() + Find()/IndexOf() + ElemLoadClear() - // - will call Find() method if Compare property is set - // - will call generic IndexOf() method if no Compare property is set - function ElemLoadFind(Source: PAnsiChar; SourceMax: PAnsiChar=nil): integer; - /// finalize a temporary buffer used to store an element via ElemLoad() - // - will release any managed type referenced inside the RawByteString, - // then void the variable - // - is just a wrapper around ElemClear(pointer(ElemTemp)) + ElemTemp := '' - procedure ElemLoadClear(var ElemTemp: RawByteString); - - /// retrieve or set the number of elements of the dynamic array - // - same as length(DynArray) or SetLength(DynArray) - // - this property will recognize T*ObjArray types, so will free any stored - // instance if the array is sized down - property Count: PtrInt read GetCount write SetCount; - /// the internal buffer capacity - // - if no external Count pointer was set with Init, is the same as Count - // - if an external Count pointer is set, you can set a value to this - // property before a massive use of the Add() method e.g. - // - if no external Count pointer is set, set a value to this property - // will affect the Count value, i.e. Add() will append after this count - // - this property will recognize T*ObjArray types, so will free any stored - // instance if the array is sized down - property Capacity: PtrInt read GetCapacity write SetCapacity; - /// the compare function to be used for Sort and Find methods - // - by default, no comparison function is set - // - common functions exist for base types: e.g. SortDynArrayByte, SortDynArrayBoolean, - // SortDynArrayWord, SortDynArrayInteger, SortDynArrayCardinal, SortDynArraySingle, - // SortDynArrayInt64, SortDynArrayDouble, SortDynArrayAnsiString, - // SortDynArrayAnsiStringI, SortDynArrayString, SortDynArrayStringI, - // SortDynArrayUnicodeString, SortDynArrayUnicodeStringI - property Compare: TDynArraySortCompare read fCompare write SetCompare; - /// must be TRUE if the array is currently in sorted order according to - // the compare function - // - Add/Delete/Insert/Load* methods will reset this property to false - // - Sort method will set this property to true - // - you MUST set this property to false if you modify the dynamic array - // content in your code, so that Find() won't try to wrongly use binary - // search in an unsorted array, and miss its purpose - property Sorted: boolean read fSorted write fSorted; - /// low-level direct access to the storage variable - property Value: PPointer read fValue; - /// the first field recognized type - // - could have been set at initialization, or after a GuessKnownType call - property KnownType: TDynArrayKind read fKnownType; - /// the raw storage size of the first field KnownType - property KnownSize: integer read fKnownSize; - /// the known RTTI information of the whole array - property ArrayType: pointer read fTypeInfo; - /// the known type name of the whole array, as RawUTF8 - property ArrayTypeName: RawUTF8 read GetArrayTypeName; - /// the known type name of the whole array, as PShortString - property ArrayTypeShort: PShortString read GetArrayTypeShort; - /// the internal in-memory size of one element, as retrieved from RTTI - property ElemSize: cardinal read fElemSize; - /// the internal type information of one element, as retrieved from RTTI - property ElemType: pointer read fElemType; - /// if this dynamic aray is a T*ObjArray - property IsObjArray: boolean read GetIsObjArray write SetIsObjArray; - end; - /// a pointer to a TDynArray wrapper instance - PDynArray = ^TDynArray; - - /// allows to iterate over a TDynArray.SaveTo binary buffer - // - may be used as alternative to TDynArray.LoadFrom, if you don't want - // to allocate all items at once, but retrieve items one by one - TDynArrayLoadFrom = object - protected - DynArray: TDynArray; // used to access RTTI - Hash: PCardinalArray; - PositionEnd: PAnsiChar; - public - /// how many items were saved in the TDynArray.SaveTo binary buffer - // - equals -1 if Init() failed to unserialize its header - Count: integer; - /// the zero-based index of the current item pointed by next Step() call - // - is in range 0..Count-1 until Step() returns false - Current: integer; - /// current position in the TDynArray.SaveTo binary buffer - // - after Step() returned false, points just after the binary buffer, - // like a regular TDynArray.LoadFrom - Position: PAnsiChar; - /// initialize iteration over a TDynArray.SaveTo binary buffer - // - returns true on success, with Count and Position being set - // - returns false if the supplied binary buffer is not correct - // - you can specify an optional SourceMaxLen to avoid any buffer overflow - function Init(ArrayTypeInfo: pointer; Source: PAnsiChar; - SourceMaxLen: PtrInt=0): boolean; overload; - /// initialize iteration over a TDynArray.SaveTo binary buffer - // - returns true on success, with Count and Position being set - // - returns false if the supplied binary buffer is not correct - function Init(ArrayTypeInfo: pointer; const Source: RawByteString): boolean; overload; - /// iterate over the current stored item - // - Elem should point to a variable of the exact item type stored in this - // dynamic array - // - returns true if Elem was filled with one value, or false if all - // items were read, and Position contains the end of the binary buffer - function Step(out Elem): boolean; - /// extract the first field value of the current stored item - // - returns true if Field was filled with one value, or false if all - // items were read, and Position contains the end of the binary buffer - // - could be called before Step(), to pre-allocate a new item instance, - // or update an existing instance - function FirstField(out Field): boolean; - /// after all items are read by Step(), validate the stored hash - // - returns true if items hash is correct, false otherwise - function CheckHash: boolean; - end; - - /// function prototype to be used for hashing of a dynamic array element - // - this function must use the supplied hasher on the Elem data - TDynArrayHashOne = function(const Elem; Hasher: THasher): cardinal; - - /// event handler to be used for hashing of a dynamic array element - // - can be set as an alternative to TDynArrayHashOne - TEventDynArrayHashOne = function(const Elem): cardinal of object; - - {.$define DYNARRAYHASHCOLLISIONCOUNT} - - /// allow O(1) lookup to any dynamic array content - // - this won't handle the storage process (like add/update), just efficiently - // maintain a hash table over an existing dynamic array: several TDynArrayHasher - // could be applied to a single TDynArray wrapper - // - TDynArrayHashed will use a TDynArrayHasher for its own store - {$ifdef USERECORDWITHMETHODS}TDynArrayHasher = record - {$else}TDynArrayHasher = object {$endif} - private - DynArray: PDynArray; - HashElement: TDynArrayHashOne; - EventHash: TEventDynArrayHashOne; - Hasher: THasher; - HashTable: TIntegerDynArray; // store 0 for void entry, or Index+1 - HashTableSize: integer; - ScanCounter: integer; // Scan()>=0 up to CountTrigger*2 - State: set of (hasHasher, canHash); - function HashTableIndex(aHashCode: cardinal): cardinal; {$ifdef HASINLINE}inline;{$endif} - procedure HashAdd(aHashCode: cardinal; var result: integer); - procedure HashDelete(aArrayIndex, aHashTableIndex: integer; aHashCode: cardinal); - procedure RaiseFatalCollision(const caller: RawUTF8; aHashCode: cardinal); - public - /// associated item comparison - may differ from DynArray^.Compare - Compare: TDynArraySortCompare; - /// custom method-based comparison function - EventCompare: TEventDynArraySortCompare; - /// after how many FindBeforeAdd() or Scan() the hashing starts - default 32 - CountTrigger: integer; - {$ifdef DYNARRAYHASHCOLLISIONCOUNT} - /// low-level access to an hash collisions counter - FindCollisions: cardinal; - {$endif} - /// initialize the hash table for a given dynamic array storage - // - you can call this method several times, e.g. if aCaseInsensitive changed - procedure Init(aDynArray: PDynArray; aHashElement: TDynArrayHashOne; - aEventHash: TEventDynArrayHashOne; aHasher: THasher; aCompare: TDynArraySortCompare; - aEventCompare: TEventDynArraySortCompare; aCaseInsensitive: boolean); - /// initialize a known hash table for a given dynamic array storage - // - you can call this method several times, e.g. if aCaseInsensitive changed - procedure InitSpecific(aDynArray: PDynArray; aKind: TDynArrayKind; aCaseInsensitive: boolean); - /// allow custom hashing via a method event - procedure SetEventHash(const event: TEventDynArrayHashOne); - /// search for an element value inside the dynamic array without hashing - // - trigger hashing if ScanCounter reaches CountTrigger*2 - function Scan(Elem: pointer): integer; - /// search for an element value inside the dynamic array with hashing - function Find(Elem: pointer): integer; overload; - /// search for a hashed element value inside the dynamic array with hashing - function Find(Elem: pointer; aHashCode: cardinal): integer; overload; - /// search for a hash position inside the dynamic array with hashing - function Find(aHashCode: cardinal; aForAdd: boolean): integer; overload; - /// returns position in array, or next void index in HashTable[] as -(index+1) - function FindOrNew(aHashCode: cardinal; Elem: pointer; aHashTableIndex: PInteger=nil): integer; - /// search an hashed element value for adding, updating the internal hash table - // - trigger hashing if Count reaches CountTrigger - function FindBeforeAdd(Elem: pointer; out wasAdded: boolean; aHashCode: cardinal): integer; - /// search and delete an element value, updating the internal hash table - function FindBeforeDelete(Elem: pointer): integer; - /// reset the hash table - no rehash yet - procedure Clear; - /// full computation of the internal hash table - // - returns the number of duplicated values found - function ReHash(forced: boolean): integer; - /// compute the hash of a given item - function HashOne(Elem: pointer): cardinal; {$ifdef FPC_OR_DELPHIXE4}inline;{$endif} - { not inlined to circumvent Delphi 2007=C1632, 2010=C1872, XE3=C2130 } - /// retrieve the low-level hash of a given item - function GetHashFromIndex(aIndex: PtrInt): cardinal; - end; - - /// pointer to a TDynArrayHasher instance - PDynArrayHasher = ^TDynArrayHasher; - - /// used to access any dynamic arrray elements using fast hash - // - by default, binary sort could be used for searching items for TDynArray: - // using a hash is faster on huge arrays for implementing a dictionary - // - in this current implementation, modification (update or delete) of an - // element is not handled yet: you should rehash all content - only - // TDynArrayHashed.FindHashedForAdding / FindHashedAndUpdate / - // FindHashedAndDelete will refresh the internal hash - // - this object extends the TDynArray type, since presence of Hashs[] dynamic - // array will increase code size if using TDynArrayHashed instead of TDynArray - // - in order to have the better performance, you should use an external Count - // variable, AND set the Capacity property to the expected maximum count (this - // will avoid most ReHash calls for FindHashedForAdding+FindHashedAndUpdate) - {$ifdef UNDIRECTDYNARRAY} - TDynArrayHashed = record - // pseudo inheritance for most used methods - private - function GetCount: PtrInt; inline; - procedure SetCount(aCount: PtrInt) ; inline; - procedure SetCapacity(aCapacity: PtrInt); inline; - function GetCapacity: PtrInt; inline; - public - InternalDynArray: TDynArray; - function Value: PPointer; inline; - function ElemSize: PtrUInt; inline; - function ElemType: Pointer; inline; - function KnownType: TDynArrayKind; inline; - procedure Clear; inline; - procedure ElemCopy(const A; var B); inline; - function ElemPtr(index: PtrInt): pointer; inline; - procedure ElemCopyAt(index: PtrInt; var Dest); inline; - // warning: you shall call ReHash() after manual Add/Delete - function Add(const Elem): integer; inline; - procedure Delete(aIndex: PtrInt); inline; - function SaveTo: RawByteString; overload; inline; - function SaveTo(Dest: PAnsiChar): PAnsiChar; overload; inline; - function SaveToJSON(EnumSetsAsText: boolean=false; - reformat: TTextWriterJSONFormat=jsonCompact): RawUTF8; inline; - procedure Sort(aCompare: TDynArraySortCompare=nil); inline; - function LoadFromJSON(P: PUTF8Char; aEndOfObject: PUTF8Char=nil{$ifndef NOVARIANTS}; - CustomVariantOptions: PDocVariantOptions=nil{$endif}): PUTF8Char; inline; - function SaveToLength: integer; inline; - function LoadFrom(Source: PAnsiChar; AfterEach: TDynArrayAfterLoadFrom=nil; - NoCheckHash: boolean=false; SourceMax: PAnsiChar=nil): PAnsiChar; inline; - function LoadFromBinary(const Buffer: RawByteString; - NoCheckHash: boolean=false): boolean; inline; - procedure CreateOrderedIndex(var aIndex: TIntegerDynArray; - aCompare: TDynArraySortCompare); - property Count: PtrInt read GetCount write SetCount; - property Capacity: PtrInt read GetCapacity write SetCapacity; - private - {$else UNDIRECTDYNARRAY} - TDynArrayHashed = object(TDynArray) - protected - {$endif UNDIRECTDYNARRAY} - fHash: TDynArrayHasher; - procedure SetEventHash(const event: TEventDynArrayHashOne); {$ifdef HASINLINE}inline;{$endif} - function GetHashFromIndex(aIndex: PtrInt): Cardinal; {$ifdef HASINLINE}inline;{$endif} - public - /// initialize the wrapper with a one-dimension dynamic array - // - this version accepts some hash-dedicated parameters: aHashElement to - // set how to hash each element, aCompare to handle hash collision - // - if no aHashElement is supplied, it will hash according to the RTTI, i.e. - // strings or binary types, and the first field for records (strings included) - // - if no aCompare is supplied, it will use default Equals() method - // - if no THasher function is supplied, it will use the one supplied in - // DefaultHasher global variable, set to crc32c() by default - using - // SSE4.2 instruction if available - // - if CaseInsensitive is set to TRUE, it will ignore difference in 7 bit - // alphabetic characters (e.g. compare 'a' and 'A' as equal) - procedure Init(aTypeInfo: pointer; var aValue; - aHashElement: TDynArrayHashOne=nil; aCompare: TDynArraySortCompare=nil; - aHasher: THasher=nil; aCountPointer: PInteger=nil; aCaseInsensitive: boolean=false); - /// initialize the wrapper with a one-dimension dynamic array - // - this version accepts to specify how both hashing and comparison should - // occur, setting the TDynArrayKind kind of first/hashed field - // - djNone and djCustom are too vague, and will raise an exception - // - no RTTI check is made over the corresponding array layout: you shall - // ensure that aKind matches the dynamic array element definition - // - aCaseInsensitive will be used for djRawUTF8..djHash512 text comparison - procedure InitSpecific(aTypeInfo: pointer; var aValue; aKind: TDynArrayKind; - aCountPointer: PInteger=nil; aCaseInsensitive: boolean=false); - /// will compute all hash from the current elements of the dynamic array - // - is called within the TDynArrayHashed.Init method to initialize the - // internal hash array - // - can be called on purpose, when modifications have been performed on - // the dynamic array content (e.g. in case of element deletion or update, - // or after calling LoadFrom/Clear method) - this is not necessary after - // FindHashedForAdding / FindHashedAndUpdate / FindHashedAndDelete methods - // - returns the number of duplicated items found - which won't be available - // by hashed FindHashed() by definition - function ReHash(forAdd: boolean=false): integer; - /// search for an element value inside the dynamic array using hashing - // - Elem should be of the type expected by both the hash function and - // Equals/Compare methods: e.g. if the searched/hashed field in a record is - // a string as first field, you can safely use a string variable as Elem - // - Elem must refer to a variable: e.g. you can't write FindHashed(i+10) - // - will call fHashElement(Elem,fHasher) to compute the needed hash - // - returns -1 if not found, or the index in the dynamic array if found - function FindHashed(const Elem): integer; - /// search for an element value inside the dynamic array using its hash - // - returns -1 if not found, or the index in the dynamic array if found - // - aHashCode parameter constains an already hashed value of the item, - // to be used e.g. after a call to HashFind() - function FindFromHash(const Elem; aHashCode: cardinal): integer; - /// search for an element value inside the dynamic array using hashing, and - // fill Elem with the found content - // - return the index found (0..Count-1), or -1 if Elem was not found - // - ElemToFill should be of the type expected by the dynamic array, since - // all its fields will be set on match - function FindHashedAndFill(var ElemToFill): integer; - /// search for an element value inside the dynamic array using hashing, and - // add a void entry to the array if was not found (unless noAddEntry is set) - // - this method will use hashing for fast retrieval - // - Elem should be of the type expected by both the hash function and - // Equals/Compare methods: e.g. if the searched/hashed field in a record is - // a string as first field, you can safely use a string variable as Elem - // - returns either the index in the dynamic array if found (and set wasAdded - // to false), either the newly created index in the dynamic array (and set - // wasAdded to true) - // - for faster process (avoid ReHash), please set the Capacity property - // - warning: in contrast to the Add() method, if an entry is added to the - // array (wasAdded=true), the entry is left VOID: you must set the field - // content to expecting value - in short, Elem is used only for searching, - // not copied to the newly created entry in the array - check - // FindHashedAndUpdate() for a method actually copying Elem fields - function FindHashedForAdding(const Elem; out wasAdded: boolean; - noAddEntry: boolean=false): integer; overload; - /// search for an element value inside the dynamic array using hashing, and - // add a void entry to the array if was not found (unless noAddEntry is set) - // - overloaded method acepting an already hashed value of the item, to be used - // e.g. after a call to HashFind() - function FindHashedForAdding(const Elem; out wasAdded: boolean; - aHashCode: cardinal; noAddEntry: boolean=false): integer; overload; - /// ensure a given element name is unique, then add it to the array - // - expected element layout is to have a RawUTF8 field at first position - // - the aName is searched (using hashing) to be unique, and if not the case, - // an ESynException.CreateUTF8() is raised with the supplied arguments - // - use internaly FindHashedForAdding method - // - this version will set the field content with the unique value - // - returns a pointer to the newly added element (to set other fields) - function AddUniqueName(const aName: RawUTF8; const ExceptionMsg: RawUTF8; - const ExceptionArgs: array of const; aNewIndex: PInteger=nil): pointer; overload; - /// ensure a given element name is unique, then add it to the array - // - just a wrapper to AddUniqueName(aName,'',[],aNewIndex) - function AddUniqueName(const aName: RawUTF8; aNewIndex: PInteger=nil): pointer; overload; - /// search for a given element name, make it unique, and add it to the array - // - expected element layout is to have a RawUTF8 field at first position - // - the aName is searched (using hashing) to be unique, and if not the case, - // some suffix is added to make it unique - // - use internaly FindHashedForAdding method - // - this version will set the field content with the unique value - // - returns a pointer to the newly added element (to set other fields) - function AddAndMakeUniqueName(aName: RawUTF8): pointer; - /// search for an element value inside the dynamic array using hashing, then - // update any matching item, or add the item if none matched - // - by design, hashed field shouldn't have been modified by this update, - // otherwise the method won't be able to find and update the old hash: in - // this case, you should first call FindHashedAndDelete(OldElem) then - // FindHashedForAdding(NewElem) to properly handle the internal hash table - // - if AddIfNotExisting is FALSE, returns the index found (0..Count-1), - // or -1 if Elem was not found - update will force slow rehash all content - // - if AddIfNotExisting is TRUE, returns the index found (0..Count-1), - // or the index newly created/added is the Elem value was not matching - - // add won't rehash all content - for even faster process (avoid ReHash), - // please set the Capacity property - // - Elem should be of the type expected by the dynamic array, since its - // content will be copied into the dynamic array, and it must refer to a - // variable: e.g. you can't write FindHashedAndUpdate(i+10) - function FindHashedAndUpdate(const Elem; AddIfNotExisting: boolean): integer; - /// search for an element value inside the dynamic array using hashing, and - // delete it if matchs - // - return the index deleted (0..Count-1), or -1 if Elem was not found - // - can optionally copy the deleted item to FillDeleted^ before erased - // - Elem should be of the type expected by both the hash function and - // Equals/Compare methods, and must refer to a variable: e.g. you can't - // write FindHashedAndDelete(i+10) - // - it won't call slow ReHash but refresh the hash table as needed - function FindHashedAndDelete(const Elem; FillDeleted: pointer=nil; - noDeleteEntry: boolean=false): integer; - /// will search for an element value inside the dynamic array without hashing - // - is used internally when Count < HashCountTrigger - // - is preferred to Find(), since EventCompare would be used if defined - // - Elem should be of the type expected by both the hash function and - // Equals/Compare methods, and must refer to a variable: e.g. you can't - // write Scan(i+10) - // - returns -1 if not found, or the index in the dynamic array if found - // - an internal algorithm can switch to hashing if Scan() is called often, - // even if the number of items is lower than HashCountTrigger - function Scan(const Elem): integer; - /// retrieve the hash value of a given item, from its index - property Hash[aIndex: PtrInt]: Cardinal read GetHashFromIndex; - /// alternative event-oriented Compare function to be used for Sort and Find - // - will be used instead of Compare, to allow object-oriented callbacks - property EventCompare: TEventDynArraySortCompare read fHash.EventCompare write fHash.EventCompare; - /// custom hash function to be used for hashing of a dynamic array element - property HashElement: TDynArrayHashOne read fHash.HashElement; - /// alternative event-oriented Hash function for ReHash - // - this object-oriented callback will be used instead of HashElement - // on each dynamic array entries - HashElement will still be used on - // const Elem values, since they may be just a sub part of the stored entry - property EventHash: TEventDynArrayHashOne read fHash.EventHash write SetEventHash; - /// after how many items the hashing take place - // - for smallest arrays, O(n) search if faster than O(1) hashing, since - // maintaining internal hash table has some CPU and memory costs - // - internal search is able to switch to hashing if it founds out that it - // may have some benefit, e.g. if Scan() is called 2*HashCountTrigger times - // - equals 32 by default, i.e. start hashing when Count reaches 32 or - // manual Scan() is called 64 times - property HashCountTrigger: integer read fHash.CountTrigger write fHash.CountTrigger; - /// access to the internal hash table - // - you can call e.g. Hasher.Clear to invalidate the whole hash table - property Hasher: TDynArrayHasher read fHash; - end; - - - /// defines a wrapper interface around a dynamic array of TObject - // - implemented by TObjectDynArrayWrapper for instance - // - i.e. most common methods are available to work with a dynamic array - // - warning: the IObjectDynArray MUST be defined in the stack, class or - // record BEFORE the dynamic array it is wrapping, otherwise you may leak - // memory - see for instance TSQLRestServer class: - // ! fSessionAuthentications: IObjectDynArray; // defined before the array - // ! fSessionAuthentication: TSQLRestServerAuthenticationDynArray; - // note that allocation time as variable on the local stack may depend on the - // compiler, and its optimization - IObjectDynArray = interface - ['{A0D50BD0-0D20-4552-B365-1D63393511FC}'] - /// search one element within the TObject instances - function Find(Instance: TObject): integer; - /// add one element to the dynamic array of TObject instances - // - once added, the Instance will be owned by this TObjectDynArray instance - function Add(Instance: TObject): integer; - /// delete one element from the TObject dynamic array - // - deleted TObject instance will be freed as expected - procedure Delete(Index: integer); - /// sort the dynamic array content according to a specified comparer - procedure Sort(Compare: TDynArraySortCompare); - /// delete all TObject instances, and release the memory - // - is not to be called for most use, thanks to reference-counting memory - // handling, but can be handy for quick release - procedure Clear; - /// ensure the internal list capacity is set to the current Count - // - may be used to publish the associated dynamic array with the expected - // final size, once IObjectDynArray is out of scope - procedure Slice; - /// returns the number of TObject instances available - // - note that the length of the associated dynamic array is used to store - // the capacity of the list, so won't probably never match with this value - function Count: integer; - /// returns the internal array capacity of TObject instances available - // - which is in fact the length() of the associated dynamic array - function Capacity: integer; - end; - - /// a wrapper to own a dynamic array of TObject - // - this version behave list a TObjectList (i.e. owning the class instances) - // - but the dynamic array is NOT owned by the instance - // - will define an internal Count property, using the dynamic array length - // as capacity: adding and deleting will be much faster - // - implements IObjectDynArray, so that most common methods are available - // to work with the dynamic array - // - does not need any sub-classing of generic overhead to work, and will be - // reference counted - // - warning: the IObjectDynArray MUST be defined in the stack, class or - // record BEFORE the dynamic array it is wrapping, otherwise you may leak - // memory, and TObjectDynArrayWrapper.Destroy will raise an ESynException - // - warning: issues with Delphi 10.4 Sydney were reported, which seemed to - // change the order of fields finalization, so the whole purpose of this - // wrapper may have become incompatible with Delphi 10.4 and up - // - a sample usage may be: - // !var DA: IObjectDynArray; // defined BEFORE the dynamic array itself - // ! A: array of TMyObject; - // ! i: integer; - // !begin - // ! DA := TObjectDynArrayWrapper.Create(A); - // ! DA.Add(TMyObject.Create('one')); - // ! DA.Add(TMyObject.Create('two')); - // ! DA.Delete(0); - // ! assert(DA.Count=1); - // ! assert(A[0].Name='two'); - // ! DA.Clear; - // ! assert(DA.Count=0); - // ! DA.Add(TMyObject.Create('new')); - // ! assert(DA.Count=1); - // !end; // will auto-release DA (no need of try..finally DA.Free) - TObjectDynArrayWrapper = class(TInterfacedObject, IObjectDynArray) - protected - fValue: PPointer; - fCount: integer; - fOwnObjects: boolean; - public - /// initialize the wrapper with a one-dimension dynamic array of TObject - // - by default, objects will be owned by this class, but you may set - // aOwnObjects=false if you expect the dynamic array to remain available - constructor Create(var aValue; aOwnObjects: boolean=true); - /// will release all associated TObject instances - destructor Destroy; override; - /// search one element within the TObject instances - function Find(Instance: TObject): integer; - /// add one element to the dynamic array of TObject instances - // - once added, the Instance will be owned by this TObjectDynArray instance - // (unless aOwnObjects was false in Create) - function Add(Instance: TObject): integer; - /// delete one element from the TObject dynamic array - // - deleted TObject instance will be freed as expected (unless aOwnObjects - // was defined as false in Create) - procedure Delete(Index: integer); - /// sort the dynamic array content according to a specified comparer - procedure Sort(Compare: TDynArraySortCompare); - /// delete all TObject instances, and release the memory - // - is not to be called for most use, thanks to reference-counting memory - // handling, but can be handy for quick release - // - warning: won't release the instances if aOwnObjects was false in Create - procedure Clear; - /// ensure the internal list capacity is set to the current Count - // - may be used to publish the associated dynamic array with the expected - // final size, once IObjectDynArray is out of scope - procedure Slice; - /// returns the number of TObject instances available - // - note that the length() of the associated dynamic array is used to store - // the capacity of the list, so won't probably never match with this value - function Count: integer; - /// returns the internal array capacity of TObject instances available - // - which is in fact the length() of the associated dynamic array - function Capacity: integer; - end; - - /// abstract parent class with a virtual constructor, ready to be overridden - // to initialize the instance - // - you can specify such a class if you need an object including published - // properties (like TPersistent) with a virtual constructor (e.g. to - // initialize some nested class properties) - TPersistentWithCustomCreate = class(TPersistent) - public - /// this virtual constructor will be called at instance creation - // - this constructor does nothing, but is declared as virtual so that - // inherited classes may safely override this default void implementation - constructor Create; virtual; - end; - - {$M+} - /// abstract parent class with threadsafe implementation of IInterface and - // a virtual constructor - // - you can specify e.g. such a class to TSQLRestServer.ServiceRegister() if - // you need an interfaced object with a virtual constructor, ready to be - // overridden to initialize the instance - TInterfacedObjectWithCustomCreate = class(TInterfacedObject) - public - /// this virtual constructor will be called at instance creation - // - this constructor does nothing, but is declared as virtual so that - // inherited classes may safely override this default void implementation - constructor Create; virtual; - /// used to mimic TInterfacedObject reference counting - // - Release=true will call TInterfacedObject._Release - // - Release=false will call TInterfacedObject._AddRef - // - could be used to emulate proper reference counting of the instance - // via interfaces variables, but still storing plain class instances - // (e.g. in a global list of instances) - procedure RefCountUpdate(Release: boolean); virtual; - end; - - /// our own empowered TPersistent-like parent class - // - TPersistent has an unexpected speed overhead due a giant lock introduced - // to manage property name fixup resolution (which we won't use outside the VCL) - // - this class has a virtual constructor, so is a preferred alternative - // to both TPersistent and TPersistentWithCustomCreate classes - // - for best performance, any type inheriting from this class will bypass - // some regular steps: do not implement interfaces or use TMonitor with them! - TSynPersistent = class(TObject) - protected - // this default implementation will call AssignError() - procedure AssignTo(Dest: TSynPersistent); virtual; - procedure AssignError(Source: TSynPersistent); - public - /// this virtual constructor will be called at instance creation - // - this constructor does nothing, but is declared as virtual so that - // inherited classes may safely override this default void implementation - constructor Create; virtual; - /// allows to implement a TPersistent-like assignement mechanism - // - inherited class should override AssignTo() protected method - // to implement the proper assignment - procedure Assign(Source: TSynPersistent); virtual; - /// optimized initialization code - // - somewhat faster than the regular RTL implementation - especially - // since rewritten in pure asm on Delphi/x86 - // - warning: this optimized version won't initialize the vmtIntfTable - // for this class hierarchy: as a result, you would NOT be able to - // implement an interface with a TSynPersistent descendent (but you should - // not need to, but inherit from TInterfacedObject) - // - warning: under FPC, it won't initialize fields management operators - class function NewInstance: TObject; override; - {$ifndef FPC_OR_PUREPASCAL} - /// optimized x86 asm finalization code - // - warning: this version won't release either any allocated TMonitor - // (as available since Delphi 2009) - do not use TMonitor with - // TSynPersistent, but rather the faster TSynPersistentLock class - procedure FreeInstance; override; - {$endif} - end; - {$M-} - - /// simple and efficient TList, without any notification - // - regular TList has an internal notification mechanism which slows down - // basic process, and most used methods were not defined as virtual, so can't - // be easily inherited - // - stateless methods (like Add/Clear/Exists/Remove) are defined as virtual - // since can be overriden e.g. by TSynObjectListLocked to add a TSynLocker - TSynList = class(TSynPersistent) - protected - fCount: integer; - fList: TPointerDynArray; - function Get(index: Integer): pointer; {$ifdef HASINLINE} inline; {$endif} - public - /// add one item to the list - function Add(item: pointer): integer; virtual; - /// delete all items of the list - procedure Clear; virtual; - /// delete one item from the list - procedure Delete(index: integer); virtual; - /// fast retrieve one item in the list - function IndexOf(item: pointer): integer; virtual; - /// fast check if one item exists in the list - function Exists(item: pointer): boolean; virtual; - /// fast delete one item in the list - function Remove(item: pointer): integer; virtual; - /// how many items are stored in this TList instance - property Count: integer read fCount; - /// low-level access to the items stored in this TList instance - property List: TPointerDynArray read fList; - /// low-level array-like access to the items stored in this TList instance - // - warning: if index is out of range, will return nil and won't raise - // any exception - property Items[index: Integer]: pointer read Get; default; - end; - - /// simple and efficient TObjectList, without any notification - TSynObjectList = class(TSynList) - protected - fOwnObjects: boolean; - public - /// initialize the object list - constructor Create(aOwnObjects: boolean=true); reintroduce; - /// delete one object from the list - procedure Delete(index: integer); override; - /// delete all objects of the list - procedure Clear; override; - /// delete all objects of the list in reverse order - // - for some kind of processes, owned objects should be removed from the - // last added to the first - procedure ClearFromLast; virtual; - /// finalize the store items - destructor Destroy; override; - end; - - /// allow to add cross-platform locking methods to any class instance - // - typical use is to define a Safe: TSynLocker property, call Safe.Init - // and Safe.Done in constructor/destructor methods, and use Safe.Lock/UnLock - // methods in a try ... finally section - // - in respect to the TCriticalSection class, fix a potential CPU cache line - // conflict which may degrade the multi-threading performance, as reported by - // @http://www.delphitools.info/2011/11/30/fixing-tcriticalsection - // - internal padding is used to safely store up to 7 values protected - // from concurrent access with a mutex, so that SizeOf(TSynLocker)>128 - // - for object-level locking, see TSynPersistentLock which owns one such - // instance, or call low-level fSafe := NewSynLocker in your constructor, - // then fSafe^.DoneAndFreemem in your destructor - TSynLocker = object - protected - fSection: TRTLCriticalSection; - fLockCount: integer; - fInitialized: boolean; - {$ifndef NOVARIANTS} - function GetVariant(Index: integer): Variant; - procedure SetVariant(Index: integer; const Value: Variant); - function GetInt64(Index: integer): Int64; - procedure SetInt64(Index: integer; const Value: Int64); - function GetBool(Index: integer): boolean; - procedure SetBool(Index: integer; const Value: boolean); - function GetUnlockedInt64(Index: integer): Int64; - procedure SetUnlockedInt64(Index: integer; const Value: Int64); - function GetPointer(Index: integer): Pointer; - procedure SetPointer(Index: integer; const Value: Pointer); - function GetUTF8(Index: integer): RawUTF8; - procedure SetUTF8(Index: integer; const Value: RawUTF8); - function GetIsLocked: boolean; {$ifdef HASINLINE}inline;{$endif} - {$endif NOVARIANTS} - public - /// number of values stored in the internal Padding[] array - // - equals 0 if no value is actually stored, or a 1..7 number otherwise - // - you should not have to use this field, but for optimized low-level - // direct access to Padding[] values, within a Lock/UnLock safe block - PaddingUsedCount: integer; - /// internal padding data, also used to store up to 7 variant values - // - this memory buffer will ensure no CPU cache line mixup occurs - // - you should not use this field directly, but rather the Locked[], - // LockedInt64[], LockedUTF8[] or LockedPointer[] methods - // - if you want to access those array values, ensure you protect them - // using a Safe.Lock; try ... Padding[n] ... finally Safe.Unlock structure, - // and maintain the PaddingUsedCount field accurately - Padding: array[0..6] of TVarData; - /// initialize the mutex - // - calling this method is mandatory (e.g. in the class constructor owning - // the TSynLocker instance), otherwise you may encounter unexpected - // behavior, like access violations or memory leaks - procedure Init; - /// finalize the mutex - // - calling this method is mandatory (e.g. in the class destructor owning - // the TSynLocker instance), otherwise you may encounter unexpected - // behavior, like access violations or memory leaks - procedure Done; - /// finalize the mutex, and call FreeMem() on the pointer of this instance - // - should have been initiazed with a NewSynLocker call - procedure DoneAndFreeMem; - /// lock the instance for exclusive access - // - this method is re-entrant from the same thread (you can nest Lock/UnLock - // calls in the same thread), but would block any other Lock attempt in - // another thread - // - use as such to avoid race condition (from a Safe: TSynLocker property): - // ! Safe.Lock; - // ! try - // ! ... - // ! finally - // ! Safe.Unlock; - // ! end; - procedure Lock; {$ifdef HASINLINE}inline;{$endif} - /// will try to acquire the mutex - // - use as such to avoid race condition (from a Safe: TSynLocker property): - // ! if Safe.TryLock then - // ! try - // ! ... - // ! finally - // ! Safe.Unlock; - // ! end; - function TryLock: boolean; {$ifdef HASINLINE}inline;{$endif} - /// will try to acquire the mutex for a given time - // - use as such to avoid race condition (from a Safe: TSynLocker property): - // ! if Safe.TryLockMS(100) then - // ! try - // ! ... - // ! finally - // ! Safe.Unlock; - // ! end; - function TryLockMS(retryms: integer): boolean; - /// release the instance for exclusive access - // - each Lock/TryLock should have its exact UnLock opposite, so a - // try..finally block is mandatory for safe code - procedure UnLock; {$ifdef HASINLINE}inline;{$endif} - /// will enter the mutex until the IUnknown reference is released - // - could be used as such under Delphi: - // !begin - // ! ... // unsafe code - // ! Safe.ProtectMethod; - // ! ... // thread-safe code - // !end; // local hidden IUnknown will release the lock for the method - // - warning: under FPC, you should assign its result to a local variable - - // see bug http://bugs.freepascal.org/view.php?id=26602 - // !var LockFPC: IUnknown; - // !begin - // ! ... // unsafe code - // ! LockFPC := Safe.ProtectMethod; - // ! ... // thread-safe code - // !end; // LockFPC will release the lock for the method - // or - // !begin - // ! ... // unsafe code - // ! with Safe.ProtectMethod do begin - // ! ... // thread-safe code - // ! end; // local hidden IUnknown will release the lock for the method - // !end; - function ProtectMethod: IUnknown; - /// returns true if the mutex is currently locked by another thread - property IsLocked: boolean read GetIsLocked; - /// returns true if the Init method has been called for this mutex - // - is only relevant if the whole object has been previously filled with 0, - // i.e. as part of a class or as global variable, but won't be accurate - // when allocated on stack - property IsInitialized: boolean read fInitialized; - {$ifndef NOVARIANTS} - /// safe locked access to a Variant value - // - you may store up to 7 variables, using an 0..6 index, shared with - // LockedBool, LockedInt64, LockedPointer and LockedUTF8 array properties - // - returns null if the Index is out of range - property Locked[Index: integer]: Variant read GetVariant write SetVariant; - /// safe locked access to a Int64 value - // - you may store up to 7 variables, using an 0..6 index, shared with - // Locked and LockedUTF8 array properties - // - Int64s will be stored internally as a varInt64 variant - // - returns nil if the Index is out of range, or does not store a Int64 - property LockedInt64[Index: integer]: Int64 read GetInt64 write SetInt64; - /// safe locked access to a boolean value - // - you may store up to 7 variables, using an 0..6 index, shared with - // Locked, LockedInt64, LockedPointer and LockedUTF8 array properties - // - value will be stored internally as a varBoolean variant - // - returns nil if the Index is out of range, or does not store a boolean - property LockedBool[Index: integer]: boolean read GetBool write SetBool; - /// safe locked access to a pointer/TObject value - // - you may store up to 7 variables, using an 0..6 index, shared with - // Locked, LockedBool, LockedInt64 and LockedUTF8 array properties - // - pointers will be stored internally as a varUnknown variant - // - returns nil if the Index is out of range, or does not store a pointer - property LockedPointer[Index: integer]: Pointer read GetPointer write SetPointer; - /// safe locked access to an UTF-8 string value - // - you may store up to 7 variables, using an 0..6 index, shared with - // Locked and LockedPointer array properties - // - UTF-8 string will be stored internally as a varString variant - // - returns '' if the Index is out of range, or does not store a string - property LockedUTF8[Index: integer]: RawUTF8 read GetUTF8 write SetUTF8; - /// safe locked in-place increment to an Int64 value - // - you may store up to 7 variables, using an 0..6 index, shared with - // Locked and LockedUTF8 array properties - // - Int64s will be stored internally as a varInt64 variant - // - returns the newly stored value - // - if the internal value is not defined yet, would use 0 as default value - function LockedInt64Increment(Index: integer; const Increment: Int64): Int64; - /// safe locked in-place exchange of a Variant value - // - you may store up to 7 variables, using an 0..6 index, shared with - // Locked and LockedUTF8 array properties - // - returns the previous stored value, or null if the Index is out of range - function LockedExchange(Index: integer; const Value: variant): variant; - /// safe locked in-place exchange of a pointer/TObject value - // - you may store up to 7 variables, using an 0..6 index, shared with - // Locked and LockedUTF8 array properties - // - pointers will be stored internally as a varUnknown variant - // - returns the previous stored value, nil if the Index is out of range, - // or does not store a pointer - function LockedPointerExchange(Index: integer; Value: pointer): pointer; - /// unsafe access to a Int64 value - // - you may store up to 7 variables, using an 0..6 index, shared with - // Locked and LockedUTF8 array properties - // - Int64s will be stored internally as a varInt64 variant - // - returns nil if the Index is out of range, or does not store a Int64 - // - you should rather call LockedInt64[] property, or use this property - // with a Lock; try ... finally UnLock block - property UnlockedInt64[Index: integer]: Int64 read GetUnlockedInt64 write SetUnlockedInt64; - {$endif NOVARIANTS} - end; - PSynLocker = ^TSynLocker; - - /// adding locking methods to a TSynPersistent with virtual constructor - // - you may use this class instead of the RTL TCriticalSection, since it - // would use a TSynLocker which does not suffer from CPU cache line conflit - TSynPersistentLock = class(TSynPersistent) - protected - fSafe: PSynLocker; // TSynLocker would increase inherited fields offset - public - /// initialize the instance, and its associated lock - constructor Create; override; - /// finalize the instance, and its associated lock - destructor Destroy; override; - /// access to the associated instance critical section - // - call Safe.Lock/UnLock to protect multi-thread access on this storage - property Safe: PSynLocker read fSafe; - end; - - /// used for backward compatibility only with existing code - TSynPersistentLocked = class(TSynPersistentLock); - - /// adding locking methods to a TInterfacedObject with virtual constructor - TInterfacedObjectLocked = class(TInterfacedObjectWithCustomCreate) - protected - fSafe: PSynLocker; // TSynLocker would increase inherited fields offset - public - /// initialize the object instance, and its associated lock - constructor Create; override; - /// release the instance (including the locking resource) - destructor Destroy; override; - /// access to the locking methods of this instance - // - use Safe.Lock/TryLock with a try ... finally Safe.Unlock block - property Safe: PSynLocker read fSafe; - end; - - /// used to determine the exact class type of a TInterfacedObjectWithCustomCreate - // - could be used to create instances using its virtual constructor - TInterfacedObjectWithCustomCreateClass = class of TInterfacedObjectWithCustomCreate; - - /// used to determine the exact class type of a TPersistentWithCustomCreateClass - // - could be used to create instances using its virtual constructor - TPersistentWithCustomCreateClass = class of TPersistentWithCustomCreate; - - /// used to determine the exact class type of a TSynPersistent - // - could be used to create instances using its virtual constructor - TSynPersistentClass = class of TSynPersistent; - - - /// used to store one list of hashed RawUTF8 in TRawUTF8Interning pool - // - Delphi "object" is buggy on stack -> also defined as record with methods - {$ifdef USERECORDWITHMETHODS}TRawUTF8InterningSlot = record - {$else}TRawUTF8InterningSlot = object{$endif} - public - /// actual RawUTF8 storage - Value: TRawUTF8DynArray; - /// hashed access to the Value[] list - Values: TDynArrayHashed; - /// associated mutex for thread-safe process - Safe: TSynLocker; - /// initialize the RawUTF8 slot (and its Safe mutex) - procedure Init; - /// finalize the RawUTF8 slot - mainly its associated Safe mutex - procedure Done; - /// returns the interned RawUTF8 value - procedure Unique(var aResult: RawUTF8; const aText: RawUTF8; aTextHash: cardinal); - /// ensure the supplied RawUTF8 value is interned - procedure UniqueText(var aText: RawUTF8; aTextHash: cardinal); - /// delete all stored RawUTF8 values - procedure Clear; - /// reclaim any unique RawUTF8 values - function Clean(aMaxRefCount: integer): integer; - /// how many items are currently stored in Value[] - function Count: integer; - end; - - /// allow to store only one copy of distinct RawUTF8 values - // - thanks to the Copy-On-Write feature of string variables, this may - // reduce a lot the memory overhead of duplicated text content - // - this class is thread-safe and optimized for performance - TRawUTF8Interning = class(TSynPersistent) - protected - fPool: array of TRawUTF8InterningSlot; - fPoolLast: integer; - public - /// initialize the storage and its internal hash pools - // - aHashTables is the pool size, and should be a power of two <= 512 - constructor Create(aHashTables: integer=4); reintroduce; - /// finalize the storage - destructor Destroy; override; - /// return a RawUTF8 variable stored within this class - // - if aText occurs for the first time, add it to the internal string pool - // - if aText does exist in the internal string pool, return the shared - // instance (with its reference counter increased), to reduce memory usage - function Unique(const aText: RawUTF8): RawUTF8; overload; - /// return a RawUTF8 variable stored within this class from a text buffer - // - if aText occurs for the first time, add it to the internal string pool - // - if aText does exist in the internal string pool, return the shared - // instance (with its reference counter increased), to reduce memory usage - function Unique(aText: PUTF8Char; aTextLen: PtrInt): RawUTF8; overload; - /// return a RawUTF8 variable stored within this class - // - if aText occurs for the first time, add it to the internal string pool - // - if aText does exist in the internal string pool, return the shared - // instance (with its reference counter increased), to reduce memory usage - procedure Unique(var aResult: RawUTF8; const aText: RawUTF8); overload; - /// return a RawUTF8 variable stored within this class from a text buffer - // - if aText occurs for the first time, add it to the internal string pool - // - if aText does exist in the internal string pool, return the shared - // instance (with its reference counter increased), to reduce memory usage - procedure Unique(var aResult: RawUTF8; aText: PUTF8Char; aTextLen: PtrInt); overload; - {$ifdef HASINLINE}inline;{$endif} - /// ensure a RawUTF8 variable is stored within this class - // - if aText occurs for the first time, add it to the internal string pool - // - if aText does exist in the internal string pool, set the shared - // instance (with its reference counter increased), to reduce memory usage - procedure UniqueText(var aText: RawUTF8); - {$ifndef NOVARIANTS} - /// return a variant containing a RawUTF8 stored within this class - // - similar to RawUTF8ToVariant(), but with string interning - procedure UniqueVariant(var aResult: variant; const aText: RawUTF8); overload; - {$ifdef HASINLINE}inline;{$endif} - /// return a variant containing a RawUTF8 stored within this class - // - similar to RawUTF8ToVariant(StringToUTF8()), but with string interning - // - this method expects the text to be supplied as a VCL string, which will - // be converted into a variant containing a RawUTF8 varString instance - procedure UniqueVariantString(var aResult: variant; const aText: string); - /// return a variant, may be containing a RawUTF8 stored within this class - // - similar to TextToVariant(), but with string interning - // - first try with GetNumericVariantFromJSON(), then fallback to - // RawUTF8ToVariant() with string variable interning - procedure UniqueVariant(var aResult: variant; aText: PUTF8Char; aTextLen: PtrInt; - aAllowVarDouble: boolean=false); overload; - /// ensure a variant contains only RawUTF8 stored within this class - // - supplied variant should be a varString containing a RawUTF8 value - procedure UniqueVariant(var aResult: variant); overload; {$ifdef HASINLINE}inline;{$endif} - {$endif NOVARIANTS} - /// delete any previous storage pool - procedure Clear; - /// reclaim any unique RawUTF8 values - // - i.e. run a garbage collection process of all values with RefCount=1 - // by default, i.e. all string which are not used any more; you may set - // aMaxRefCount to a higher value, depending on your expecations, i.e. 2 to - // delete all string which are referenced only once outside of the pool - // - returns the number of unique RawUTF8 cleaned from the internal pool - // - to be executed on a regular basis - but not too often, since the - // process can be time consumming, and void the benefit of interning - function Clean(aMaxRefCount: integer=1): integer; - /// how many items are currently stored in this instance - function Count: integer; - end; - - /// store one Name/Value pair, as used by TSynNameValue class - TSynNameValueItem = record - /// the name of the Name/Value pair - // - this property is hashed by TSynNameValue for fast retrieval - Name: RawUTF8; - /// the value of the Name/Value pair - Value: RawUTF8; - /// any associated Pointer or numerical value - Tag: PtrInt; - end; - - /// Name/Value pairs storage, as used by TSynNameValue class - TSynNameValueItemDynArray = array of TSynNameValueItem; - - /// event handler used to convert on the fly some UTF-8 text content - TOnSynNameValueConvertRawUTF8 = function(const text: RawUTF8): RawUTF8 of object; - - /// callback event used by TSynNameValue - TOnSynNameValueNotify = procedure(const Item: TSynNameValueItem; Index: PtrInt) of object; - - /// pseudo-class used to store Name/Value RawUTF8 pairs - // - use internaly a TDynArrayHashed instance for fast retrieval - // - is therefore faster than TRawUTF8List - // - is defined as an object, not as a class: you can use this in any - // class, without the need to destroy the content - // - Delphi "object" is buggy on stack -> also defined as record with methods - {$ifdef USERECORDWITHMETHODS}TSynNameValue = record - {$else}TSynNameValue = object {$endif} - private - fOnAdd: TOnSynNameValueNotify; - function GetBlobData: RawByteString; - procedure SetBlobData(const aValue: RawByteString); - function GetStr(const aName: RawUTF8): RawUTF8; {$ifdef HASINLINE}inline;{$endif} - function GetInt(const aName: RawUTF8): Int64; {$ifdef HASINLINE}inline;{$endif} - function GetBool(const aName: RawUTF8): Boolean; {$ifdef HASINLINE}inline;{$endif} - public - /// the internal Name/Value storage - List: TSynNameValueItemDynArray; - /// the number of Name/Value pairs - Count: integer; - /// low-level access to the internal storage hasher - DynArray: TDynArrayHashed; - /// initialize the storage - // - will also reset the internal List[] and the internal hash array - procedure Init(aCaseSensitive: boolean); - /// add an element to the array - // - if aName already exists, its associated Value will be updated - procedure Add(const aName, aValue: RawUTF8; aTag: PtrInt=0); - /// reset content, then add all name=value pairs from a supplied .ini file - // section content - // - will first call Init(false) to initialize the internal array - // - Section can be retrieved e.g. via FindSectionFirstLine() - procedure InitFromIniSection(Section: PUTF8Char; OnTheFlyConvert: TOnSynNameValueConvertRawUTF8=nil; - OnAdd: TOnSynNameValueNotify=nil); - /// reset content, then add all name=value; CSV pairs - // - will first call Init(false) to initialize the internal array - // - if ItemSep=#10, then any kind of line feed (CRLF or LF) will be handled - procedure InitFromCSV(CSV: PUTF8Char; NameValueSep: AnsiChar='='; - ItemSep: AnsiChar=#10); - /// reset content, then add all fields from an JSON object - // - will first call Init() to initialize the internal array - // - then parse the incoming JSON object, storing all its field values - // as RawUTF8, and returning TRUE if the supplied content is correct - // - warning: the supplied JSON buffer will be decoded and modified in-place - function InitFromJSON(JSON: PUTF8Char; aCaseSensitive: boolean=false): boolean; - /// reset content, then add all name, value pairs - // - will first call Init(false) to initialize the internal array - procedure InitFromNamesValues(const Names, Values: array of RawUTF8); - /// search for a Name, return the index in List - // - using fast O(1) hash algoritm - function Find(const aName: RawUTF8): integer; - /// search for the first chars of a Name, return the index in List - // - using O(n) calls of IdemPChar() function - // - here aUpperName should be already uppercase, as expected by IdemPChar() - function FindStart(const aUpperName: RawUTF8): integer; - /// search for a Value, return the index in List - // - using O(n) brute force algoritm with case-sensitive aValue search - function FindByValue(const aValue: RawUTF8): integer; - /// search for a Name, and delete its entry in the List if it exists - function Delete(const aName: RawUTF8): boolean; - /// search for a Value, and delete its entry in the List if it exists - // - returns the number of deleted entries - // - you may search for more than one match, by setting a >1 Limit value - function DeleteByValue(const aValue: RawUTF8; Limit: integer=1): integer; - /// search for a Name, return the associated Value as a UTF-8 string - function Value(const aName: RawUTF8; const aDefaultValue: RawUTF8=''): RawUTF8; - /// search for a Name, return the associated Value as integer - function ValueInt(const aName: RawUTF8; const aDefaultValue: Int64=0): Int64; - /// search for a Name, return the associated Value as boolean - // - returns true only if the value is exactly '1' - function ValueBool(const aName: RawUTF8): Boolean; - /// search for a Name, return the associated Value as an enumerate - // - returns true and set aEnum if aName was found, and associated value - // matched an aEnumTypeInfo item - // - returns false if no match was found - function ValueEnum(const aName: RawUTF8; aEnumTypeInfo: pointer; out aEnum; - aEnumDefault: byte=0): boolean; overload; - /// returns all values, as CSV or INI content - function AsCSV(const KeySeparator: RawUTF8='='; - const ValueSeparator: RawUTF8=#13#10; const IgnoreKey: RawUTF8=''): RawUTF8; - /// returns all values as a JSON object of string fields - function AsJSON: RawUTF8; - /// fill the supplied two arrays of RawUTF8 with the stored values - procedure AsNameValues(out Names,Values: TRawUTF8DynArray); - {$ifndef NOVARIANTS} - /// search for a Name, return the associated Value as variant - // - returns null if the name was not found - function ValueVariantOrNull(const aName: RawUTF8): variant; - /// compute a TDocVariant document from the stored values - // - output variant will be reset and filled as a TDocVariant instance, - // ready to be serialized as a JSON object - // - if there is no value stored (i.e. Count=0), set null - procedure AsDocVariant(out DocVariant: variant; - ExtendedJson: boolean=false; ValueAsString: boolean=true; - AllowVarDouble: boolean=false); overload; - /// compute a TDocVariant document from the stored values - function AsDocVariant(ExtendedJson: boolean=false; ValueAsString: boolean=true): variant; overload; {$ifdef HASINLINE}inline;{$endif} - /// merge the stored values into a TDocVariant document - // - existing properties would be updated, then new values will be added to - // the supplied TDocVariant instance, ready to be serialized as a JSON object - // - if ValueAsString is TRUE, values would be stored as string - // - if ValueAsString is FALSE, numerical values would be identified by - // IsString() and stored as such in the resulting TDocVariant - // - if you let ChangedProps point to a TDocVariantData, it would contain - // an object with the stored values, just like AsDocVariant - // - returns the number of updated values in the TDocVariant, 0 if - // no value was changed - function MergeDocVariant(var DocVariant: variant; - ValueAsString: boolean; ChangedProps: PVariant=nil; - ExtendedJson: boolean=false; AllowVarDouble: boolean=false): integer; - {$endif} - /// returns true if the Init() method has been called - function Initialized: boolean; - /// can be used to set all data from one BLOB memory buffer - procedure SetBlobDataPtr(aValue: pointer); - /// can be used to set or retrieve all stored data as one BLOB content - property BlobData: RawByteString read GetBlobData write SetBlobData; - /// event triggerred after an item has just been added to the list - property OnAfterAdd: TOnSynNameValueNotify read fOnAdd write fOnAdd; - /// search for a Name, return the associated Value as a UTF-8 string - // - returns '' if aName is not found in the stored keys - property Str[const aName: RawUTF8]: RawUTF8 read GetStr; default; - /// search for a Name, return the associated Value as integer - // - returns 0 if aName is not found, or not a valid Int64 in the stored keys - property Int[const aName: RawUTF8]: Int64 read GetInt; - /// search for a Name, return the associated Value as boolean - // - returns true if aName stores '1' as associated value - property Bool[const aName: RawUTF8]: Boolean read GetBool; - end; - - /// a reference pointer to a Name/Value RawUTF8 pairs storage - PSynNameValue = ^TSynNameValue; - -/// allocate and initialize a TSynLocker instance -// - caller should call result^.DoneAndFreemem when not used any more -function NewSynLocker: PSynLocker; - {$ifdef HASINLINE}inline;{$endif} - -/// wrapper to add an item to a array of pointer dynamic array storage -function PtrArrayAdd(var aPtrArray; aItem: pointer): integer; - {$ifdef HASINLINE}inline;{$endif} - -/// wrapper to add once an item to a array of pointer dynamic array storage -function PtrArrayAddOnce(var aPtrArray; aItem: pointer): integer; - -/// wrapper to delete an item from a array of pointer dynamic array storage -function PtrArrayDelete(var aPtrArray; aItem: pointer; aCount: PInteger=nil): integer; overload; - -/// wrapper to delete an item from a array of pointer dynamic array storage -procedure PtrArrayDelete(var aPtrArray; aIndex: integer; aCount: PInteger=nil); overload; - -/// wrapper to find an item to a array of pointer dynamic array storage -function PtrArrayFind(var aPtrArray; aItem: pointer): integer; - {$ifdef HASINLINE}inline;{$endif} - -/// wrapper to add an item to a T*ObjArray dynamic array storage -// - as expected by TJSONSerializer.RegisterObjArrayForJSON() -// - could be used as such (note the T*ObjArray type naming convention): -// ! TUserObjArray = array of TUser; -// ! ... -// ! var arr: TUserObjArray; -// ! user: TUser; -// ! .. -// ! try -// ! user := TUser.Create; -// ! user.Name := 'Name'; -// ! index := ObjArrayAdd(arr,user); -// ! ... -// ! finally -// ! ObjArrayClear(arr); // release all items -// ! end; -// - return the index of the item in the dynamic array -function ObjArrayAdd(var aObjArray; aItem: TObject): PtrInt; - {$ifdef HASINLINE}inline;{$endif} - -/// wrapper to add items to a T*ObjArray dynamic array storage -// - aSourceObjArray[] items are just copied to aDestObjArray, which remains untouched -// - return the new number of the items in aDestObjArray -function ObjArrayAddFrom(var aDestObjArray; const aSourceObjArray): PtrInt; - -/// wrapper to add and move items to a T*ObjArray dynamic array storage -// - aSourceObjArray[] items will be owned by aDestObjArray[], therefore -// aSourceObjArray is set to nil -// - return the new number of the items in aDestObjArray -function ObjArrayAppend(var aDestObjArray, aSourceObjArray): PtrInt; - -/// wrapper to add an item to a T*ObjArray dynamic array storage -// - this overloaded function will use a separated variable to store the items -// count, so will be slightly faster: but you should call SetLength() when done, -// to have an array as expected by TJSONSerializer.RegisterObjArrayForJSON() -// - return the index of the item in the dynamic array -function ObjArrayAddCount(var aObjArray; aItem: TObject; var aObjArrayCount: integer): PtrInt; - -/// wrapper to add once an item to a T*ObjArray dynamic array storage -// - as expected by TJSONSerializer.RegisterObjArrayForJSON() -// - if the object is already in the array (searching by address/reference, -// not by content), return its current index in the dynamic array -// - if the object does not appear in the array, add it at the end -procedure ObjArrayAddOnce(var aObjArray; aItem: TObject); - -// - aSourceObjArray[] items are just copied to aDestObjArray, which remains untouched -// - will first check if aSourceObjArray[] items are not already in aDestObjArray -// - return the new number of the items in aDestObjArray -function ObjArrayAddOnceFrom(var aDestObjArray; const aSourceObjArray): PtrInt; - -/// wrapper to set the length of a T*ObjArray dynamic array storage -// - could be used as an alternative to SetLength() when you do not -// know the exact T*ObjArray type -procedure ObjArraySetLength(var aObjArray; aLength: integer); - {$ifdef HASINLINE}inline;{$endif} - -/// wrapper to search an item in a T*ObjArray dynamic array storage -// - as expected by TJSONSerializer.RegisterObjArrayForJSON() -// - search is performed by address/reference, not by content -// - returns -1 if the item is not found in the dynamic array -function ObjArrayFind(const aObjArray; aItem: TObject): PtrInt; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// wrapper to search an item in a T*ObjArray dynamic array storage -// - as expected by TJSONSerializer.RegisterObjArrayForJSON() -// - search is performed by address/reference, not by content -// - returns -1 if the item is not found in the dynamic array -function ObjArrayFind(const aObjArray; aCount: integer; aItem: TObject): PtrInt; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// wrapper to count all not nil items in a T*ObjArray dynamic array storage -// - as expected by TJSONSerializer.RegisterObjArrayForJSON() -function ObjArrayCount(const aObjArray): integer; - -/// wrapper to delete an item in a T*ObjArray dynamic array storage -// - as expected by TJSONSerializer.RegisterObjArrayForJSON() -// - do nothing if the index is out of range in the dynamic array -procedure ObjArrayDelete(var aObjArray; aItemIndex: PtrInt; - aContinueOnException: boolean=false; aCount: PInteger=nil); overload; - -/// wrapper to delete an item in a T*ObjArray dynamic array storage -// - as expected by TJSONSerializer.RegisterObjArrayForJSON() -// - search is performed by address/reference, not by content -// - do nothing if the item is not found in the dynamic array -function ObjArrayDelete(var aObjArray; aItem: TObject): PtrInt; overload; - -/// wrapper to delete an item in a T*ObjArray dynamic array storage -// - as expected by TJSONSerializer.RegisterObjArrayForJSON() -// - search is performed by address/reference, not by content -// - do nothing if the item is not found in the dynamic array -function ObjArrayDelete(var aObjArray; aCount: integer; aItem: TObject): PtrInt; overload; - -/// wrapper to sort the items stored in a T*ObjArray dynamic array -// - as expected by TJSONSerializer.RegisterObjArrayForJSON() -procedure ObjArraySort(var aObjArray; Compare: TDynArraySortCompare); - -/// wrapper to release all items stored in a T*ObjArray dynamic array -// - as expected by TJSONSerializer.RegisterObjArrayForJSON() -// - you should always use ObjArrayClear() before the array storage is released, -// e.g. in the owner class destructor -// - will also set the dynamic array length to 0, so could be used to re-use -// an existing T*ObjArray -procedure ObjArrayClear(var aObjArray); overload; - -/// wrapper to release all items stored in a T*ObjArray dynamic array -// - this overloaded function will use the supplied array length as parameter -// - you should always use ObjArrayClear() before the array storage is released, -// e.g. in the owner class destructor -// - will also set the dynamic array length to 0, so could be used to re-use -// an existing T*ObjArray -procedure ObjArrayClear(var aObjArray; aCount: integer); overload; - -/// wrapper to release all items stored in a T*ObjArray dynamic array -// - as expected by TJSONSerializer.RegisterObjArrayForJSON() -// - you should always use ObjArrayClear() before the array storage is released, -// e.g. in the owner class destructor -// - will also set the dynamic array length to 0, so could be used to re-use -// an existing T*ObjArray -procedure ObjArrayClear(var aObjArray; aContinueOnException: boolean; - aCount: PInteger=nil); overload; - -/// wrapper to release all items stored in an array of T*ObjArray dynamic array -// - e.g. aObjArray may be defined as "array of array of TSynFilter" -procedure ObjArrayObjArrayClear(var aObjArray); - -/// wrapper to release all items stored in several T*ObjArray dynamic arrays -// - as expected by TJSONSerializer.RegisterObjArrayForJSON() -procedure ObjArraysClear(const aObjArray: array of pointer); - -/// low-level function calling FreeAndNil(o^) successively n times -procedure RawObjectsClear(o: PObject; n: integer); - -{$ifndef DELPHI5OROLDER} - -/// wrapper to add an item to a T*InterfaceArray dynamic array storage -function InterfaceArrayAdd(var aInterfaceArray; const aItem: IUnknown): PtrInt; - -/// wrapper to add once an item to a T*InterfaceArray dynamic array storage -procedure InterfaceArrayAddOnce(var aInterfaceArray; const aItem: IUnknown); - -/// wrapper to search an item in a T*InterfaceArray dynamic array storage -// - search is performed by address/reference, not by content -// - return -1 if the item is not found in the dynamic array, or the index of -// the matching entry otherwise -function InterfaceArrayFind(const aInterfaceArray; const aItem: IUnknown): PtrInt; - {$ifdef HASINLINE}inline;{$endif} - -/// wrapper to delete an item in a T*InterfaceArray dynamic array storage -// - search is performed by address/reference, not by content -// - do nothing if the item is not found in the dynamic array -function InterfaceArrayDelete(var aInterfaceArray; const aItem: IUnknown): PtrInt; overload; - -/// wrapper to delete an item in a T*InterfaceArray dynamic array storage -// - do nothing if the item is not found in the dynamic array -procedure InterfaceArrayDelete(var aInterfaceArray; aItemIndex: PtrInt); overload; - -{$endif DELPHI5OROLDER} - - -/// helper to retrieve the text of an enumerate item -// - see also RTTI related classes of mORMot.pas unit, e.g. TEnumType -function GetEnumName(aTypeInfo: pointer; aIndex: integer): PShortString; - -/// helper to retrieve all texts of an enumerate -// - may be used as cache for overloaded ToText() content -procedure GetEnumNames(aTypeInfo: pointer; aDest: PPShortString); - -/// helper to retrieve all trimmed texts of an enumerate -// - may be used as cache to retrieve UTF-8 text without lowercase 'a'..'z' chars -procedure GetEnumTrimmedNames(aTypeInfo: pointer; aDest: PRawUTF8); overload; - -/// helper to retrieve all trimmed texts of an enumerate as UTF-8 strings -function GetEnumTrimmedNames(aTypeInfo: pointer): TRawUTF8DynArray; overload; - -/// helper to retrieve all (translated) caption texts of an enumerate -// - may be used as cache for overloaded ToCaption() content -procedure GetEnumCaptions(aTypeInfo: pointer; aDest: PString); - -/// UnCamelCase and translate the enumeration item -function GetCaptionFromEnum(aTypeInfo: pointer; aIndex: integer): string; - -/// low-level helper to retrieve a (translated) caption from a PShortString -// - as used e.g. by GetEnumCaptions or GetCaptionFromEnum -procedure GetCaptionFromTrimmed(PS: PShortString; var result: string); - -/// helper to retrieve the index of an enumerate item from its text -// - returns -1 if aValue was not found -// - will search for the exact text and also trim the lowercase 'a'..'z' chars on -// left side of the text if no exact match is found and AlsoTrimLowerCase is TRUE -// - see also RTTI related classes of mORMot.pas unit, e.g. TEnumType -function GetEnumNameValue(aTypeInfo: pointer; aValue: PUTF8Char; aValueLen: PtrInt; - AlsoTrimLowerCase: boolean=false): Integer; overload; - -/// retrieve the index of an enumerate item from its left-trimmed text -// - text comparison is case-insensitive for A-Z characters -// - will trim the lowercase 'a'..'z' chars on left side of the supplied aValue text -// - returns -1 if aValue was not found -function GetEnumNameValueTrimmed(aTypeInfo: pointer; aValue: PUTF8Char; aValueLen: PtrInt): integer; - -/// retrieve the index of an enumerate item from its left-trimmed text -// - text comparison is case-sensitive for A-Z characters -// - will trim the lowercase 'a'..'z' chars on left side of the supplied aValue text -// - returns -1 if aValue was not found -function GetEnumNameValueTrimmedExact(aTypeInfo: pointer; aValue: PUTF8Char; aValueLen: PtrInt): integer; - -/// helper to retrieve the index of an enumerate item from its text -function GetEnumNameValue(aTypeInfo: pointer; const aValue: RawUTF8; - AlsoTrimLowerCase: boolean=false): Integer; overload; - -/// helper to retrieve the bit mapped integer value of a set from its JSON text -// - if supplied P^ is a JSON integer number, will read it directly -// - if P^ maps some ["item1","item2"] content, would fill all matching bits -// - if P^ contains ['*'], would fill all bits -// - returns P=nil if reached prematurly the end of content, or returns -// the value separator (e.g. , or }) in EndOfObject (like GetJsonField) -function GetSetNameValue(aTypeInfo: pointer; var P: PUTF8Char; - out EndOfObject: AnsiChar): cardinal; - -/// helper to retrieve the CSV text of all enumerate items defined in a set -// - you'd better use RTTI related classes of mORMot.pas unit, e.g. TEnumType -function GetSetName(aTypeInfo: pointer; const value): RawUTF8; - -/// helper to retrieve the CSV text of all enumerate items defined in a set -// - you'd better use RTTI related classes of mORMot.pas unit, e.g. TEnumType -procedure GetSetNameShort(aTypeInfo: pointer; const value; out result: ShortString; - trimlowercase: boolean=false); - -/// low-level helper to retrive the base enumeration RTTI of a given set -function GetSetBaseEnum(aTypeInfo: pointer): pointer; - -/// fast append some UTF-8 text into a shortstring, with an ending ',' -procedure AppendShortComma(text: PAnsiChar; len: PtrInt; var result: shortstring; - trimlowercase: boolean); - -/// fast search of an exact case-insensitive match of a RTTI's PShortString array -function FindShortStringListExact(List: PShortString; MaxValue: integer; - aValue: PUTF8Char; aValueLen: PtrInt): integer; - -/// fast case-insensitive search of a left-trimmed lowercase match -// of a RTTI's PShortString array -function FindShortStringListTrimLowerCase(List: PShortString; MaxValue: integer; - aValue: PUTF8Char; aValueLen: PtrInt): integer; - -/// fast case-sensitive search of a left-trimmed lowercase match -// of a RTTI's PShortString array -function FindShortStringListTrimLowerCaseExact(List: PShortString; MaxValue: integer; - aValue: PUTF8Char; aValueLen: PtrInt): integer; - -/// retrieve the type name from its low-level RTTI -function TypeInfoToName(aTypeInfo: pointer): RawUTF8; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// retrieve the type name from its low-level RTTI -procedure TypeInfoToName(aTypeInfo: pointer; var result: RawUTF8; - const default: RawUTF8=''); overload; - -/// retrieve the unit name and type name from its low-level RTTI -procedure TypeInfoToQualifiedName(aTypeInfo: pointer; var result: RawUTF8; - const default: RawUTF8=''); - -/// compute a crc32c-based hash of the RTTI for a managed given type -// - can be used to ensure that the RecordSave/TDynArray.SaveTo binary layout -// is compatible accross executables, even between FPC and Delphi -// - will ignore the type names, but will check the RTTI type kind and any -// nested fields (for records or arrays) - for a record/object type, will use -// TTextWriter.RegisterCustomJSONSerializerFromText definition, if available -function TypeInfoToHash(aTypeInfo: pointer): cardinal; - -/// retrieve the record size from its low-level RTTI -function RecordTypeInfoSize(aRecordTypeInfo: pointer): integer; - -/// retrieve the item type information of a dynamic array low-level RTTI -function DynArrayTypeInfoToRecordInfo(aDynArrayTypeInfo: pointer; - aDataSize: PInteger=nil): pointer; - -/// sort any dynamic array, via an external array of indexes -// - this function will use the supplied TSynTempBuffer for index storage, -// so use PIntegerArray(Indexes.buf) to access the values -// - caller should always make Indexes.Done once done -procedure DynArraySortIndexed(Values: pointer; ElemSize, Count: Integer; - out Indexes: TSynTempBuffer; Compare: TDynArraySortCompare); - -/// compare two TGUID values -// - this version is faster than the one supplied by SysUtils -function IsEqualGUID(const guid1, guid2: TGUID): Boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// compare two TGUID values -// - this version is faster than the one supplied by SysUtils -function IsEqualGUID(guid1, guid2: PGUID): Boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// returns the index of a matching TGUID in an array -// - returns -1 if no item matched -function IsEqualGUIDArray(const guid: TGUID; const guids: array of TGUID): integer; - -/// check if a TGUID value contains only 0 bytes -// - this version is faster than the one supplied by SysUtils -function IsNullGUID({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID): Boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// append one TGUID item to a TGUID dynamic array -// - returning the newly inserted index in guids[], or an existing index in -// guids[] if NoDuplicates is TRUE and TGUID already exists -function AddGUID(var guids: TGUIDDynArray; const guid: TGUID; - NoDuplicates: boolean=false): integer; - -/// append a TGUID binary content as text -// - will store e.g. '3F2504E0-4F89-11D3-9A0C-0305E82C3301' (without any {}) -// - this will be the format used for JSON encoding, e.g. -// $ { "UID": "C9A646D3-9C61-4CB7-BFCD-EE2522C8F633" } -function GUIDToText(P: PUTF8Char; guid: PByteArray): PUTF8Char; - -/// convert a TGUID into UTF-8 encoded text -// - will return e.g. '{3F2504E0-4F89-11D3-9A0C-0305E82C3301}' (with the {}) -// - if you do not need the embracing { }, use ToUTF8() overloaded function -function GUIDToRawUTF8({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID): RawUTF8; - -/// convert a TGUID into text -// - will return e.g. '{3F2504E0-4F89-11D3-9A0C-0305E82C3301}' (with the {}) -// - this version is faster than the one supplied by SysUtils -function GUIDToString({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID): string; - -type - /// low-level object implementing a 32-bit Pierre L'Ecuyer software generator - // - as used by Random32gsl, and Random32 if no RDRAND hardware is available - // - is not thread-safe by itself, but cross-compiler and cross-platform, still - // very fast with a much better distribution than Delphi system's Random() function - // - Random32gsl/Random32 will use a threadvar to have thread safety - TLecuyer = object - public - rs1, rs2, rs3, seedcount: cardinal; - /// force an immediate seed of the generator from current system state - // - should be called before any call to the Next method - procedure Seed(entropy: PByteArray; entropylen: PtrInt); - /// compute the next 32-bit generated value - // - will automatically reseed after around 65,000 generated values - function Next: cardinal; overload; - /// compute the next 32-bit generated value, in range [0..max-1] - // - will automatically reseed after around 65,000 generated values - function Next(max: cardinal): cardinal; overload; - end; - -/// fast compute of some 32-bit random value -// - will use (slow but) hardware-derivated RDRAND Intel x86/x64 opcode if -// available, or fast gsl_rng_taus2 generator by Pierre L'Ecuyer (which period -// is 2^88, i.e. about 10^26) if the CPU doesn't support it -// - will detect known AMD CPUs RDRAND bugs, and fallback to gsl_rng_taus2 -// - consider Random32gsl to avoid slow RDRAND call (up to 1500 cycles needed!) -// - use rather TAESPRNG.Main.FillRandom() for cryptographic-level randomness -// - thread-safe function: each thread will maintain its own TLecuyer table -function Random32: cardinal; overload; - -/// fast compute of some 32-bit random value, with a maximum (excluded) upper value -// - i.e. returns a value in range [0..max-1] -// - calls internally the overloaded Random32 function -function Random32(max: cardinal): cardinal; overload; - -/// fast compute of some 32-bit random value, using the gsl_rng_taus2 generator -// - Random32 may call RDRAND opcode on Intel CPUs, wherease this function will use -// well documented, much faster, and proven Pierre L'Ecuyer software generator -// - may be used if you don't want/trust RDRAND, if you expect a well defined -// cross-platform generator, or have higher performance expectations -// - use rather TAESPRNG.Main.FillRandom() for cryptographic-level randomness -// - thread-safe function: each thread will maintain its own TLecuyer table -function Random32gsl: cardinal; overload; - -/// fast compute of bounded 32-bit random value, using the gsl_rng_taus2 generator -// - calls internally the overloaded Random32gsl function -function Random32gsl(max: cardinal): cardinal; overload; - -/// seed the gsl_rng_taus2 Random32/Random32gsl generator -// - this seeding won't affect RDRAND Intel x86/x64 opcode generation -// - by default, gsl_rng_taus2 generator is re-seeded every 256KB, much more -// often than the Pierre L'Ecuyer's algorithm period of 2^88 -// - you can specify some additional entropy buffer; note that calling this -// function with the same entropy again WON'T seed the generator with the same -// sequence (as with RTL's RandomSeed function), but initiate a new one -// - thread-specific function: each thread will maintain its own seed table -procedure Random32Seed(entropy: pointer=nil; entropylen: PtrInt=0); - -/// fill some memory buffer with random values -// - the destination buffer is expected to be allocated as 32-bit items -// - use internally crc32c() with some rough entropy source, and Random32 -// gsl_rng_taus2 generator or hardware RDRAND Intel x86/x64 opcode if available -// (and ForceGsl is kept to its default false) -// - consider using instead the cryptographic secure TAESPRNG.Main.FillRandom() -// method from the SynCrypto unit, or set ForceGsl=true - in particular, RDRAND -// is reported as very slow: see https://en.wikipedia.org/wiki/RdRand#Performance -procedure FillRandom(Dest: PCardinalArray; CardinalCount: integer; ForceGsl: boolean=false); - -/// compute a random GUID value -procedure RandomGUID(out result: TGUID); overload; - {$ifdef HASINLINE}inline;{$endif} - -/// compute a random GUID value -function RandomGUID: TGUID; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// fill a GUID with 0 -procedure FillZero(var result: TGUID); overload; {$ifdef HASINLINE}inline;{$endif} - -type - /// stack-allocated ASCII string, used by GUIDToShort() function - TGUIDShortString = string[38]; - -const - /// a TGUID containing '{00000000-0000-0000-0000-00000000000}' - GUID_NULL: TGUID = (); - -/// convert a TGUID into text -// - will return e.g. '{3F2504E0-4F89-11D3-9A0C-0305E82C3301}' (with the {}) -// - using a shortstring will allow fast allocation on the stack, so is -// preferred e.g. when providing a GUID to a ESynException.CreateUTF8() -function GUIDToShort({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} - guid: TGUID): TGUIDShortString; overload; {$ifdef HASINLINE}inline;{$endif} - -/// convert a TGUID into text -// - will return e.g. '{3F2504E0-4F89-11D3-9A0C-0305E82C3301}' (with the {}) -// - using a shortstring will allow fast allocation on the stack, so is -// preferred e.g. when providing a GUID to a ESynException.CreateUTF8() -procedure GUIDToShort({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} - guid: TGUID; out dest: TGUIDShortString); overload; - -/// convert some text into its TGUID binary value -// - expect e.g. '3F2504E0-4F89-11D3-9A0C-0305E82C3301' (without any {}) -// - return nil if the supplied text buffer is not a valid TGUID -// - this will be the format used for JSON encoding, e.g. -// $ { "UID": "C9A646D3-9C61-4CB7-BFCD-EE2522C8F633" } -function TextToGUID(P: PUTF8Char; guid: PByteArray): PUTF8Char; - -/// convert some text into a TGUID -// - expect e.g. '{3F2504E0-4F89-11D3-9A0C-0305E82C3301}' (with the {}) -// - return {00000000-0000-0000-0000-000000000000} if the supplied text buffer -// is not a valid TGUID -function StringToGUID(const text: string): TGUID; - -/// convert some UTF-8 encoded text into a TGUID -// - expect e.g. '{3F2504E0-4F89-11D3-9A0C-0305E82C3301}' (with the {}) -// - return {00000000-0000-0000-0000-000000000000} if the supplied text buffer -// is not a valid TGUID -function RawUTF8ToGUID(const text: RawByteString): TGUID; - - -/// check equality of two records by content -// - will handle packed records, with binaries (byte, word, integer...) and -// string types properties -// - will use binary-level comparison: it could fail to match two floating-point -// values because of rounding issues (Currency won't have this problem) -function RecordEquals(const RecA, RecB; TypeInfo: pointer; - PRecSize: PInteger=nil): boolean; - -/// save a record content into a RawByteString -// - will handle packed records, with binaries (byte, word, integer...) and -// string types properties (but not with internal raw pointers, of course) -// - will use a proprietary binary format, with some variable-length encoding -// of the string length - note that if you change the type definition, any -// previously-serialized content will fail, maybe triggering unexpected GPF: you -// may use TypeInfoToHash() if you share this binary data accross executables -// - warning: will encode generic string fields as AnsiString (one byte per char) -// prior to Delphi 2009, and as UnicodeString (two bytes per char) since Delphi -// 2009: if you want to use this function between UNICODE and NOT UNICODE -// versions of Delphi, you should use some explicit types like RawUTF8, -// WinAnsiString, SynUnicode or even RawUnicode/WideString -function RecordSave(const Rec; TypeInfo: pointer): RawByteString; overload; - -/// save a record content into a TBytes dynamic array -// - could be used as an alternative to RawByteString's RecordSave() -function RecordSaveBytes(const Rec; TypeInfo: pointer): TBytes; - -/// save a record content into a destination memory buffer -// - Dest must be at least RecordSaveLength() bytes long -// - will return the Rec size, in bytes, into Len reference variable -// - will handle packed records, with binaries (byte, word, integer...) and -// string types properties (but not with internal raw pointers, of course) -// - will use a proprietary binary format, with some variable-length encoding -// of the string length - note that if you change the type definition, any -// previously-serialized content will fail, maybe triggering unexpected GPF: you -// may use TypeInfoToHash() if you share this binary data accross executables -// - warning: will encode generic string fields as AnsiString (one byte per char) -// prior to Delphi 2009, and as UnicodeString (two bytes per char) since Delphi -// 2009: if you want to use this function between UNICODE and NOT UNICODE -// versions of Delphi, you should use some explicit types like RawUTF8, -// WinAnsiString, SynUnicode or even RawUnicode/WideString -function RecordSave(const Rec; Dest: PAnsiChar; TypeInfo: pointer; - out Len: integer): PAnsiChar; overload; - -/// save a record content into a destination memory buffer -// - Dest must be at least RecordSaveLength() bytes long -// - will handle packed records, with binaries (byte, word, integer...) and -// string types properties (but not with internal raw pointers, of course) -// - will use a proprietary binary format, with some variable-length encoding -// of the string length - note that if you change the type definition, any -// previously-serialized content will fail, maybe triggering unexpected GPF: you -// may use TypeInfoToHash() if you share this binary data accross executables -// - warning: will encode generic string fields as AnsiString (one byte per char) -// prior to Delphi 2009, and as UnicodeString (two bytes per char) since Delphi -// 2009: if you want to use this function between UNICODE and NOT UNICODE -// versions of Delphi, you should use some explicit types like RawUTF8, -// WinAnsiString, SynUnicode or even RawUnicode/WideString -function RecordSave(const Rec; Dest: PAnsiChar; TypeInfo: pointer): PAnsiChar; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// save a record content into a destination memory buffer -// - caller should make Dest.Done once finished with Dest.buf/Dest.len buffer -procedure RecordSave(const Rec; var Dest: TSynTempBuffer; TypeInfo: pointer); overload; - -/// save a record content into a Base-64 encoded UTF-8 text content -// - will use RecordSave() format, with a left-sided binary CRC32C -function RecordSaveBase64(const Rec; TypeInfo: pointer; UriCompatible: boolean=false): RawUTF8; - -/// compute the number of bytes needed to save a record content -// using the RecordSave() function -// - will return 0 in case of an invalid (not handled) record type (e.g. if -// it contains an unknown variant) -// - optional Len parameter will contain the Rec memory buffer length, in bytes -function RecordSaveLength(const Rec; TypeInfo: pointer; Len: PInteger=nil): integer; - -/// save record into its JSON serialization as saved by TTextWriter.AddRecordJSON -// - will use default Base64 encoding over RecordSave() binary - or custom true -// JSON format (as set by TTextWriter.RegisterCustomJSONSerializer or via -// enhanced RTTI), if available (following EnumSetsAsText optional parameter -// for nested enumerates and sets) -function RecordSaveJSON(const Rec; TypeInfo: pointer; - EnumSetsAsText: boolean=false): RawUTF8; - {$ifdef HASINLINE}inline;{$endif} - -/// fill a record content from a memory buffer as saved by RecordSave() -// - return nil if the Source buffer is incorrect -// - in case of success, return the memory buffer pointer just after the -// read content, and set the Rec size, in bytes, into Len reference variable -// - will use a proprietary binary format, with some variable-length encoding -// of the string length - note that if you change the type definition, any -// previously-serialized content will fail, maybe triggering unexpected GPF: you -// may use TypeInfoToHash() if you share this binary data accross executables -// - you can optionally provide in SourceMax the first byte after the input -// memory buffer, which will be used to avoid any unexpected buffer overflow - -// would be mandatory when decoding the content from any external process -// (e.g. a maybe-forged client) - only with slightly performance penalty -function RecordLoad(var Rec; Source: PAnsiChar; TypeInfo: pointer; - Len: PInteger=nil; SourceMax: PAnsiChar=nil): PAnsiChar; overload; - -/// fill a record content from a memory buffer as saved by RecordSave() -// - will use the Source length to detect and avoid any buffer overlow -// - returns false if the Source buffer was incorrect, true on success -function RecordLoad(var Res; const Source: RawByteString; TypeInfo: pointer): boolean; overload; - -/// read a record content from a Base-64 encoded content -// - expects RecordSaveBase64() format, with a left-sided binary CRC -function RecordLoadBase64(Source: PAnsiChar; Len: PtrInt; var Rec; TypeInfo: pointer; - UriCompatible: boolean=false): boolean; - -/// fill a record content from a JSON serialization as saved by -// TTextWriter.AddRecordJSON / RecordSaveJSON -// - will use default Base64 encoding over RecordSave() binary - or custom true -// JSON format (as set by TTextWriter.RegisterCustomJSONSerializer or via -// enhanced RTTI), if available -// - returns nil on error, or the end of buffer on success -// - warning: the JSON buffer will be modified in-place during process - use -// a temporary copy if you need to access it later or if the string comes from -// a constant (refcount=-1) - see e.g. the overloaded RecordLoadJSON() -function RecordLoadJSON(var Rec; JSON: PUTF8Char; TypeInfo: pointer; - EndOfObject: PUTF8Char=nil{$ifndef NOVARIANTS}; - CustomVariantOptions: PDocVariantOptions=nil{$endif}): PUTF8Char; overload; - -/// fill a record content from a JSON serialization as saved by -// TTextWriter.AddRecordJSON / RecordSaveJSON -// - this overloaded function will make a private copy before parsing it, -// so is safe with a read/only or shared string - but slightly slower -// - will use default Base64 encoding over RecordSave() binary - or custom true -// JSON format (as set by TTextWriter.RegisterCustomJSONSerializer or via -// enhanced RTTI), if available -function RecordLoadJSON(var Rec; const JSON: RawUTF8; TypeInfo: pointer{$ifndef NOVARIANTS}; - CustomVariantOptions: PDocVariantOptions=nil{$endif}): boolean; overload; - -/// copy a record content from source to Dest -// - this unit includes a fast optimized asm version for x86 on Delphi -procedure RecordCopy(var Dest; const Source; TypeInfo: pointer); {$ifdef FPC}inline;{$endif} - -/// clear a record content -// - this unit includes a fast optimized asm version for x86 on Delphi -procedure RecordClear(var Dest; TypeInfo: pointer); {$ifdef FPC}inline;{$endif} - -/// initialize a record content -// - calls RecordClear() and FillCharFast() with 0 -// - do nothing if the TypeInfo is not from a record/object -procedure RecordZero(var Dest; TypeInfo: pointer); - -/// low-level finalization of a dynamic array of variants -// - faster than RTL Finalize() or setting nil -procedure FastDynArrayClear(Value: PPointer; ElemTypeInfo: pointer); - -/// low-level finalization of a dynamic array of RawUTF8 -// - faster than RTL Finalize() or setting nil -procedure RawUTF8DynArrayClear(var Value: TRawUTF8DynArray); - {$ifdef HASINLINE}inline;{$endif} - -{$ifndef DELPHI5OROLDER} -/// copy a dynamic array content from source to Dest -// - uses internally the TDynArray.CopyFrom() method and two temporary -// TDynArray wrappers -procedure DynArrayCopy(var Dest; const Source; SourceMaxElem: integer; - TypeInfo: pointer); -{$endif DELPHI5OROLDER} - -/// fill a dynamic array content from a binary serialization as saved by -// DynArraySave() / TDynArray.Save() -// - Value shall be set to the target dynamic array field -// - just a function helper around TDynArray.Init + TDynArray.* -function DynArrayLoad(var Value; Source: PAnsiChar; TypeInfo: pointer): PAnsiChar; - -/// serialize a dynamic array content as binary, ready to be loaded by -// DynArrayLoad() / TDynArray.Load() -// - Value shall be set to the source dynamic arry field -// - just a function helper around TDynArray.Init + TDynArray.SaveTo -function DynArraySave(var Value; TypeInfo: pointer): RawByteString; - -/// fill a dynamic array content from a JSON serialization as saved by -// TTextWriter.AddDynArrayJSON -// - Value shall be set to the target dynamic array field -// - is just a wrapper around TDynArray.LoadFromJSON(), creating a temporary -// TDynArray wrapper on the stack -// - return a pointer at the end of the data read from JSON, nil in case -// of an invalid input buffer -// - to be used e.g. for custom record JSON unserialization, within a -// TDynArrayJSONCustomReader callback -// - warning: the JSON buffer will be modified in-place during process - use -// a temporary copy if you need to access it later or if the string comes from -// a constant (refcount=-1) - see e.g. the overloaded DynArrayLoadJSON() -function DynArrayLoadJSON(var Value; JSON: PUTF8Char; TypeInfo: pointer; - EndOfObject: PUTF8Char=nil): PUTF8Char; overload; - -/// fill a dynamic array content from a JSON serialization as saved by -// TTextWriter.AddDynArrayJSON, which won't be modified -// - this overloaded function will make a private copy before parsing it, -// so is safe with a read/only or shared string - but slightly slower -function DynArrayLoadJSON(var Value; const JSON: RawUTF8; TypeInfo: pointer): boolean; overload; - -/// serialize a dynamic array content as JSON -// - Value shall be set to the source dynamic array field -// - is just a wrapper around TTextWriter.AddDynArrayJSON(), creating -// a temporary TDynArray wrapper on the stack -// - to be used e.g. for custom record JSON serialization, within a -// TDynArrayJSONCustomWriter callback or RegisterCustomJSONSerializerFromText() -// (following EnumSetsAsText optional parameter for nested enumerates and sets) -function DynArraySaveJSON(const Value; TypeInfo: pointer; - EnumSetsAsText: boolean=false): RawUTF8; - {$ifdef HASINLINE}inline;{$endif} - -{$ifndef DELPHI5OROLDER} -/// compare two dynamic arrays by calling TDynArray.Equals -function DynArrayEquals(TypeInfo: pointer; var Array1, Array2; - Array1Count: PInteger=nil; Array2Count: PInteger=nil): boolean; -{$endif DELPHI5OROLDER} - -/// serialize a dynamic array content, supplied as raw binary buffer, as JSON -// - Value shall be set to the source dynamic array field -// - is just a wrapper around TTextWriter.AddDynArrayJSON(), creating -// a temporary TDynArray wrapper on the stack -// - to be used e.g. for custom record JSON serialization, within a -// TDynArrayJSONCustomWriter callback or RegisterCustomJSONSerializerFromText() -function DynArrayBlobSaveJSON(TypeInfo, BlobValue: pointer): RawUTF8; - -/// compute a dynamic array element information -// - will raise an exception if the supplied RTTI is not a dynamic array -// - will return the element type name and set ElemTypeInfo otherwise -// - if there is no element type information, an approximative element type name -// will be returned (e.g. 'byte' for an array of 1 byte items), and ElemTypeInfo -// will be set to nil -// - this low-level function is used e.g. by mORMotWrappers unit -function DynArrayElementTypeName(TypeInfo: pointer; ElemTypeInfo: PPointer=nil; - ExactType: boolean=false): RawUTF8; - -/// trim ending 'DynArray' or 's' chars from a dynamic array type name -// - used internally to guess the associated item type name -function DynArrayItemTypeLen(const aDynArrayTypeName: RawUTF8): PtrInt; - -/// was dynamic array item after RegisterCustomJSONSerializerFromTextBinaryType() -// - calls DynArrayItemTypeLen() to guess the internal type name -function DynArrayItemTypeIsSimpleBinary(const aDynArrayTypeName: RawUTF8): boolean; - - -/// compare two "array of boolean" elements -function SortDynArrayBoolean(const A,B): integer; - -/// compare two "array of shortint" elements -function SortDynArrayShortint(const A,B): integer; - -/// compare two "array of byte" elements -function SortDynArrayByte(const A,B): integer; - -/// compare two "array of smallint" elements -function SortDynArraySmallint(const A,B): integer; - -/// compare two "array of word" elements -function SortDynArrayWord(const A,B): integer; - -/// compare two "array of integer" elements -function SortDynArrayInteger(const A,B): integer; - -/// compare two "array of cardinal" elements -function SortDynArrayCardinal(const A,B): integer; - -/// compare two "array of Int64" or "array of Currency" elements -function SortDynArrayInt64(const A,B): integer; - -/// compare two "array of QWord" elements -// - note that QWord(A)>QWord(B) is wrong on older versions of Delphi, so you -// should better use this function or CompareQWord() to properly compare two -// QWord values over CPUX86 -function SortDynArrayQWord(const A,B): integer; - -/// compare two "array of THash128" elements -function SortDynArray128(const A,B): integer; - -/// compare two "array of THash256" elements -function SortDynArray256(const A,B): integer; - -/// compare two "array of THash512" elements -function SortDynArray512(const A,B): integer; - -/// compare two "array of TObject/pointer" elements -function SortDynArrayPointer(const A,B): integer; - -/// compare two "array of single" elements -function SortDynArraySingle(const A,B): integer; - -/// compare two "array of double" elements -function SortDynArrayDouble(const A,B): integer; - -/// compare two "array of AnsiString" elements, with case sensitivity -function SortDynArrayAnsiString(const A,B): integer; - -/// compare two "array of RawByteString" elements, with case sensitivity -// - can't use StrComp() or similar functions since RawByteString may contain #0 -function SortDynArrayRawByteString(const A,B): integer; - -/// compare two "array of AnsiString" elements, with no case sensitivity -function SortDynArrayAnsiStringI(const A,B): integer; - -/// compare two "array of PUTF8Char/PAnsiChar" elements, with case sensitivity -function SortDynArrayPUTF8Char(const A,B): integer; - -/// compare two "array of PUTF8Char/PAnsiChar" elements, with no case sensitivity -function SortDynArrayPUTF8CharI(const A,B): integer; - -/// compare two "array of WideString/UnicodeString" elements, with case sensitivity -function SortDynArrayUnicodeString(const A,B): integer; - -/// compare two "array of WideString/UnicodeString" elements, with no case sensitivity -function SortDynArrayUnicodeStringI(const A,B): integer; - -/// compare two "array of generic string" elements, with case sensitivity -// - the expected string type is the generic VCL string -function SortDynArrayString(const A,B): integer; - -/// compare two "array of generic string" elements, with no case sensitivity -// - the expected string type is the generic VCL string -function SortDynArrayStringI(const A,B): integer; - -/// compare two "array of TFileName" elements, as file names -// - i.e. with no case sensitivity, and grouped by file extension -// - the expected string type is the generic RTL string, i.e. TFileName -// - calls internally GetFileNameWithoutExt() and AnsiCompareFileName() -function SortDynArrayFileName(const A,B): integer; - -{$ifndef NOVARIANTS} -/// compare two "array of variant" elements, with case sensitivity -function SortDynArrayVariant(const A,B): integer; - -/// compare two "array of variant" elements, with no case sensitivity -function SortDynArrayVariantI(const A,B): integer; - -/// compare two "array of variant" elements, with or without case sensitivity -// - this low-level function is called by SortDynArrayVariant/VariantCompare -// - more optimized than the RTL function if A and B share the same type -function SortDynArrayVariantComp(const A,B: TVarData; caseInsensitive: boolean): integer; -{$endif NOVARIANTS} - - -{$ifdef CPU32DELPHI} -const - /// defined for inlining bitwise division in TDynArrayHasher.HashTableIndex - // - HashTableSize<=HASH_PO2 is expected to be a power of two (fast binary op); - // limit is set to 262,144 hash table slots (=1MB), for Capacity=131,072 items - // - above this limit, a set of increasing primes is used; using a prime as - // hashtable modulo enhances its distribution, especially for a weak hash function - // - 64-bit CPU and FPC can efficiently compute a prime reduction using Lemire - // algorithm, so no power of two is defined on those targets - HASH_PO2 = 1 shl 18; -{$endif CPU32DELPHI} - -/// compute the 32-bit default hash of a file content -// - you can specify your own hashing function if DefaultHasher is not what you expect -function HashFile(const FileName: TFileName; Hasher: THasher=nil): cardinal; - -/// hash one AnsiString content with the suppplied Hasher() function -function HashAnsiString(const Elem; Hasher: THasher): cardinal; - -/// case-insensitive hash one AnsiString content with the suppplied Hasher() function -function HashAnsiStringI(const Elem; Hasher: THasher): cardinal; - -/// hash one SynUnicode content with the suppplied Hasher() function -// - work with WideString for all Delphi versions, or UnicodeString in Delphi 2009+ -function HashSynUnicode(const Elem; Hasher: THasher): cardinal; - -/// case-insensitive hash one SynUnicode content with the suppplied Hasher() function -// - work with WideString for all Delphi versions, or UnicodeString in Delphi 2009+ -function HashSynUnicodeI(const Elem; Hasher: THasher): cardinal; - -/// hash one WideString content with the suppplied Hasher() function -// - work with WideString for all Delphi versions -function HashWideString(const Elem; Hasher: THasher): cardinal; - -/// case-insensitive hash one WideString content with the suppplied Hasher() function -// - work with WideString for all Delphi versions -function HashWideStringI(const Elem; Hasher: THasher): cardinal; - -{$ifdef UNICODE} -/// hash one UnicodeString content with the suppplied Hasher() function -// - work with UnicodeString in Delphi 2009+ -function HashUnicodeString(const Elem; Hasher: THasher): cardinal; - -/// case-insensitive hash one UnicodeString content with the suppplied Hasher() function -// - work with UnicodeString in Delphi 2009+ -function HashUnicodeStringI(const Elem; Hasher: THasher): cardinal; -{$endif UNICODE} - -{$ifndef NOVARIANTS} -/// case-sensitive hash one variant content with the suppplied Hasher() function -function HashVariant(const Elem; Hasher: THasher): cardinal; - -/// case-insensitive hash one variant content with the suppplied Hasher() function -function HashVariantI(const Elem; Hasher: THasher): cardinal; -{$endif NOVARIANTS} - -/// hash one PtrUInt (=NativeUInt) value with the suppplied Hasher() function -function HashPtrUInt(const Elem; Hasher: THasher): cardinal; - -/// hash one Byte value -function HashByte(const Elem; Hasher: THasher): cardinal; - -/// hash one Word value -function HashWord(const Elem; Hasher: THasher): cardinal; - -/// hash one Integer/cardinal value - simply return the value ignore Hasher() parameter -function HashInteger(const Elem; Hasher: THasher): cardinal; - -/// hash one Int64/Qword value with the suppplied Hasher() function -function HashInt64(const Elem; Hasher: THasher): cardinal; - -/// hash one THash128 value with the suppplied Hasher() function -function Hash128(const Elem; Hasher: THasher): cardinal; - -/// hash one THash256 value with the suppplied Hasher() function -function Hash256(const Elem; Hasher: THasher): cardinal; - -/// hash one THash512 value with the suppplied Hasher() function -function Hash512(const Elem; Hasher: THasher): cardinal; - -/// hash one pointer value with the suppplied Hasher() function -// - this version is not the same as HashPtrUInt, since it will always -// use the hasher function -function HashPointer(const Elem; Hasher: THasher): cardinal; - -var - /// helper array to get the comparison function corresponding to a given - // standard array type - // - e.g. as DYNARRAY_SORTFIRSTFIELD[CaseInSensitive,djRawUTF8] - // - not to be used as such, but e.g. when inlining TDynArray methods - DYNARRAY_SORTFIRSTFIELD: array[boolean,TDynArrayKind] of TDynArraySortCompare = ( - (nil, SortDynArrayBoolean, SortDynArrayByte, SortDynArrayWord, - SortDynArrayInteger, SortDynArrayCardinal, SortDynArraySingle, - SortDynArrayInt64, SortDynArrayQWord, SortDynArrayDouble, - SortDynArrayInt64, SortDynArrayInt64, SortDynArrayDouble, SortDynArrayDouble, - SortDynArrayAnsiString, SortDynArrayAnsiString, SortDynArrayString, - SortDynArrayRawByteString, SortDynArrayUnicodeString, - SortDynArrayUnicodeString, SortDynArray128, SortDynArray256, - SortDynArray512, SortDynArrayPointer, - {$ifndef NOVARIANTS}SortDynArrayVariant,{$endif} nil), - (nil, SortDynArrayBoolean, SortDynArrayByte, SortDynArrayWord, - SortDynArrayInteger, SortDynArrayCardinal, SortDynArraySingle, - SortDynArrayInt64, SortDynArrayQWord, SortDynArrayDouble, - SortDynArrayInt64, SortDynArrayInt64, SortDynArrayDouble, SortDynArrayDouble, - SortDynArrayAnsiStringI, SortDynArrayAnsiStringI, SortDynArrayStringI, - SortDynArrayRawByteString, SortDynArrayUnicodeStringI, - SortDynArrayUnicodeStringI, SortDynArray128, SortDynArray256, - SortDynArray512, SortDynArrayPointer, - {$ifndef NOVARIANTS}SortDynArrayVariantI,{$endif} nil)); - - /// helper array to get the hashing function corresponding to a given - // standard array type - // - e.g. as DYNARRAY_HASHFIRSTFIELD[CaseInSensitive,djRawUTF8] - // - not to be used as such, but e.g. when inlining TDynArray methods - DYNARRAY_HASHFIRSTFIELD: array[boolean,TDynArrayKind] of TDynArrayHashOne = ( - (nil, HashByte, HashByte, HashWord, HashInteger, - HashInteger, HashInteger, HashInt64, HashInt64, HashInt64, - HashInt64, HashInt64, HashInt64, HashInt64, - HashAnsiString, HashAnsiString, - {$ifdef UNICODE}HashUnicodeString{$else}HashAnsiString{$endif}, - HashAnsiString, HashWideString, HashSynUnicode, Hash128, - Hash256, Hash512, HashPointer, - {$ifndef NOVARIANTS}HashVariant,{$endif} nil), - (nil, HashByte, HashByte, HashWord, HashInteger, - HashInteger, HashInteger, HashInt64, HashInt64, HashInt64, - HashInt64, HashInt64, HashInt64, HashInt64, - HashAnsiStringI, HashAnsiStringI, - {$ifdef UNICODE}HashUnicodeStringI{$else}HashAnsiStringI{$endif}, - HashAnsiStringI, HashWideStringI, HashSynUnicodeI, Hash128, - Hash256, Hash512, HashPointer, - {$ifndef NOVARIANTS}HashVariantI,{$endif} nil)); - - -/// initialize the structure with a one-dimension dynamic array -// - the dynamic array must have been defined with its own type -// (e.g. TIntegerDynArray = array of Integer) -// - if aCountPointer is set, it will be used instead of length() to store -// the dynamic array items count - it will be much faster when adding -// elements to the array, because the dynamic array won't need to be -// resized each time - but in this case, you should use the Count property -// instead of length(array) or high(array) when accessing the data: in fact -// length(array) will store the memory size reserved, not the items count -// - if aCountPointer is set, its content will be set to 0, whatever the -// array length is, or the current aCountPointer^ value is -// - a typical usage could be: -// !var IntArray: TIntegerDynArray; -// !begin -// ! with DynArray(TypeInfo(TIntegerDynArray),IntArray) do -// ! begin -// ! (...) -// ! end; -// ! (...) -// ! DynArray(TypeInfo(TIntegerDynArray),IntArrayA).SaveTo -function DynArray(aTypeInfo: pointer; var aValue; aCountPointer: PInteger=nil): TDynArray; - {$ifdef HASINLINE}inline;{$endif} - -/// wrap a simple dynamic array BLOB content as stored by TDynArray.SaveTo -// - a "simple" dynamic array contains data with no reference count, e.g. byte, -// word, integer, cardinal, Int64, double or Currency -// - same as TDynArray.LoadFrom() with no memory allocation nor memory copy: so -// is much faster than creating a temporary dynamic array to load the data -// - will return nil if no or invalid data, or a pointer to the data -// array otherwise, with the items number stored in Count and the individual -// element size in ElemSize (e.g. 2 for a TWordDynArray) -function SimpleDynArrayLoadFrom(Source: PAnsiChar; aTypeInfo: pointer; - var Count, ElemSize: integer; NoHash32Check: boolean=false): pointer; - -/// wrap an Integer dynamic array BLOB content as stored by TDynArray.SaveTo -// - same as TDynArray.LoadFrom() with no memory allocation nor memory copy: so -// is much faster than creating a temporary dynamic array to load the data -// - will return nil if no or invalid data, or a pointer to the integer -// array otherwise, with the items number stored in Count -// - sligtly faster than SimpleDynArrayLoadFrom(Source,TypeInfo(TIntegerDynArray),Count) -function IntegerDynArrayLoadFrom(Source: PAnsiChar; var Count: integer; - NoHash32Check: boolean=false): PIntegerArray; - -/// search in a RawUTF8 dynamic array BLOB content as stored by TDynArray.SaveTo -// - same as search within TDynArray.LoadFrom() with no memory allocation nor -// memory copy: so is much faster -// - will return -1 if no match or invalid data, or the matched entry index -function RawUTF8DynArrayLoadFromContains(Source: PAnsiChar; - Value: PUTF8Char; ValueLen: PtrInt; CaseSensitive: boolean): PtrInt; - - -{ ****************** text buffer and JSON functions and classes ************ } - -const - /// maximum number of fields in a database Table - // - is included in SynCommons so that all DB-related work will be able to - // share the same low-level types and functions (e.g. TSQLFieldBits, - // TJSONWriter, TSynTableStatement, TSynTable, TSQLRecordProperties) - // - default is 64, but can be set to any value (64, 128, 192 and 256 optimized) - // changing the source below or using MAX_SQLFIELDS_128, MAX_SQLFIELDS_192 or - // MAX_SQLFIELDS_256 conditional directives for your project - // - this constant is used internaly to optimize memory usage in the - // generated asm code, and statically allocate some arrays for better speed - // - note that due to compiler restriction, 256 is the maximum value - // (this is the maximum number of items in a Delphi/FPC set) - {$ifdef MAX_SQLFIELDS_128} - MAX_SQLFIELDS = 128; - {$else} - {$ifdef MAX_SQLFIELDS_192} - MAX_SQLFIELDS = 192; - {$else} - {$ifdef MAX_SQLFIELDS_256} - MAX_SQLFIELDS = 256; - {$else} - MAX_SQLFIELDS = 64; - {$endif} - {$endif} - {$endif} - - /// sometimes, the ID field is included in a bits set - MAX_SQLFIELDS_INCLUDINGID = MAX_SQLFIELDS+1; - - /// UTF-8 encoded \uFFF0 special code to mark Base64 binary content in JSON - // - Unicode special char U+FFF0 is UTF-8 encoded as EF BF B0 bytes - // - as generated by BinToBase64WithMagic() functions, and expected by - // SQLParamContent() and ExtractInlineParameters() functions - // - used e.g. when transmitting TDynArray.SaveTo() content - JSON_BASE64_MAGIC = $b0bfef; - - /// '"' + UTF-8 encoded \uFFF0 special code to mark Base64 binary in JSON - JSON_BASE64_MAGIC_QUOTE = ord('"')+cardinal(JSON_BASE64_MAGIC) shl 8; - - /// '"' + UTF-8 encoded \uFFF0 special code to mark Base64 binary in JSON - // - defined as a cardinal variable to be used as: - // ! AddNoJSONEscape(@JSON_BASE64_MAGIC_QUOTE_VAR,4); - JSON_BASE64_MAGIC_QUOTE_VAR: cardinal = JSON_BASE64_MAGIC_QUOTE; - - /// UTF-8 encoded \uFFF1 special code to mark ISO-8601 SQLDATE in JSON - // - e.g. '"\uFFF12012-05-04"' pattern - // - Unicode special char U+FFF1 is UTF-8 encoded as EF BF B1 bytes - // - as generated by DateToSQL/DateTimeToSQL/TimeLogToSQL functions, and - // expected by SQLParamContent() and ExtractInlineParameters() functions - JSON_SQLDATE_MAGIC = $b1bfef; - - /// '"' + UTF-8 encoded \uFFF1 special code to mark ISO-8601 SQLDATE in JSON - JSON_SQLDATE_MAGIC_QUOTE = ord('"')+cardinal(JSON_SQLDATE_MAGIC) shl 8; - - ///'"' + UTF-8 encoded \uFFF1 special code to mark ISO-8601 SQLDATE in JSON - // - defined as a cardinal variable to be used as: - // ! AddNoJSONEscape(@JSON_SQLDATE_MAGIC_QUOTE_VAR,4); - JSON_SQLDATE_MAGIC_QUOTE_VAR: cardinal = JSON_SQLDATE_MAGIC_QUOTE; - - -type - TTextWriter = class; - TTextWriterWithEcho = class; - - /// method prototype for custom serialization of a dynamic array item - // - each element of the dynamic array will be called as aValue parameter - // of this callback - // - can be used also at record level, if the record has a type information - // (i.e. shall contain a managed type within its fields) - // - to be used with TTextWriter.RegisterCustomJSONSerializer() method - // - note that the generated JSON content will be appended after a '[' and - // before a ']' as a normal JSON arrray, but each item can be any JSON - // structure (i.e. a number, a string, but also an object or an array) - // - implementation code could call aWriter.Add/AddJSONEscapeString... - // - implementation code shall follow the same exact format for the - // associated TDynArrayJSONCustomReader callback - TDynArrayJSONCustomWriter = procedure(const aWriter: TTextWriter; const aValue) of object; - - /// method prototype for custom unserialization of a dynamic array item - // - each element of the dynamic array will be called as aValue parameter - // of this callback - // - can be used also at record level, if the record has a type information - // (i.e. shall contain a managed type within its fields) - // - to be used with TTextWriter.RegisterCustomJSONSerializer() method - // - implementation code could call e.g. GetJSONField() low-level function, and - // returns a pointer to the last handled element of the JSON input buffer, - // as such (aka EndOfBuffer variable as expected by GetJSONField): - // ! var V: TFV absolute aValue; - // ! begin - // ! (...) - // ! V.Detailed := UTF8ToString(GetJSONField(P,P)); - // ! if P=nil then - // ! exit; - // ! aValid := true; - // ! result := P; // ',' or ']' for last item of array - // ! end; - // - implementation code shall follow the same exact format for the - // associated TDynArrayJSONCustomWriter callback - TDynArrayJSONCustomReader = function(P: PUTF8Char; var aValue; out aValid: Boolean - {$ifndef NOVARIANTS}; CustomVariantOptions: PDocVariantOptions{$endif}): PUTF8Char of object; - - /// the kind of variables handled by TJSONCustomParser - // - the last item should be ptCustom, for non simple types - TJSONCustomParserRTTIType = ( - ptArray, ptBoolean, ptByte, ptCardinal, ptCurrency, ptDouble, ptExtended, - ptInt64, ptInteger, ptQWord, ptRawByteString, ptRawJSON, ptRawUTF8, ptRecord, - ptSingle, ptString, ptSynUnicode, ptDateTime, ptDateTimeMS, ptGUID, - ptID, ptTimeLog, {$ifdef HASVARUSTRING} ptUnicodeString, {$endif} - {$ifndef NOVARIANTS} ptVariant, {$endif} ptWideString, ptWord, ptCustom); - - /// how TJSONCustomParser would serialize/unserialize JSON content - TJSONCustomParserSerializationOption = ( - soReadIgnoreUnknownFields, soWriteHumanReadable, - soCustomVariantCopiedByReference, soWriteIgnoreDefault); - - /// how TJSONCustomParser would serialize/unserialize JSON content - // - by default, during reading any unexpected field will stop and fail the - // process - if soReadIgnoreUnknownFields is defined, such properties will - // be ignored (can be very handy when parsing JSON from a remote service) - // - by default, JSON content will be written in its compact standard form, - // ready to be parsed by any client - you can specify soWriteHumanReadable - // so that some line feeds and indentation will make the content more readable - // - by default, internal TDocVariant variants will be copied by-value from - // one instance to another, to ensure proper safety - but it may be too slow: - // if you set soCustomVariantCopiedByReference, any internal - // TDocVariantData.VValue/VName instances will be copied by-reference, - // to avoid memory allocations, BUT it may break internal process if you change - // some values in place (since VValue/VName and VCount won't match) - as such, - // if you set this option, ensure that you use the content as read-only - // - by default, all fields are persistented, unless soWriteIgnoreDefault is - // defined and void values (e.g. "" or 0) won't be written - // - you may use TTextWriter.RegisterCustomJSONSerializerSetOptions() class - // method to customize the serialization for a given type - TJSONCustomParserSerializationOptions = set of TJSONCustomParserSerializationOption; - - TJSONCustomParserRTTI = class; - - /// an array of RTTI properties information - // - we use dynamic arrays, since all the information is static and we - // do not need to remove any RTTI information - TJSONCustomParserRTTIs = array of TJSONCustomParserRTTI; - - /// used to store additional RTTI in TJSONCustomParser internal structures - TJSONCustomParserRTTI = class - protected - fPropertyName: RawUTF8; - fFullPropertyName: RawUTF8; - fPropertyType: TJSONCustomParserRTTIType; - fCustomTypeName: RawUTF8; - fNestedProperty: TJSONCustomParserRTTIs; - fDataSize: integer; - fNestedDataSize: integer; - procedure ComputeDataSizeAfterAdd; virtual; - procedure ComputeNestedDataSize; - procedure ComputeFullPropertyName; - procedure FinalizeNestedRecord(var Data: PByte); - procedure FinalizeNestedArray(var Data: PtrUInt); - procedure AllocateNestedArray(var Data: PtrUInt; NewLength: integer); - procedure ReAllocateNestedArray(var Data: PtrUInt; NewLength: integer); - function IfDefaultSkipped(var Value: PByte): boolean; - procedure WriteOneSimpleValue(aWriter: TTextWriter; var Value: PByte; - Options: TJSONCustomParserSerializationOptions); - public - /// initialize the instance - constructor Create(const aPropertyName: RawUTF8; - aPropertyType: TJSONCustomParserRTTIType); - /// initialize an instance from the RTTI type information - // - will return an instance of this class of any inherited class - class function CreateFromRTTI(const PropertyName: RawUTF8; - Info: pointer; ItemSize: integer): TJSONCustomParserRTTI; - /// create an instance from a specified type name - // - will return an instance of this class of any inherited class - class function CreateFromTypeName(const aPropertyName, - aCustomRecordTypeName: RawUTF8): TJSONCustomParserRTTI; - /// recognize a simple type from a supplied type name - // - will return ptCustom for any unknown type - // - see also TypeInfoToRttiType() function - class function TypeNameToSimpleRTTIType( - const TypeName: RawUTF8): TJSONCustomParserRTTIType; overload; - /// recognize a simple type from a supplied type name - // - will return ptCustom for any unknown type - // - see also TypeInfoToRttiType() function - class function TypeNameToSimpleRTTIType( - TypeName: PShortString): TJSONCustomParserRTTIType; overload; - /// recognize a simple type from a supplied type name - // - will return ptCustom for any unknown type - // - see also TypeInfoToRttiType() function - class function TypeNameToSimpleRTTIType(TypeName: PUTF8Char; TypeNameLen: PtrInt; - ItemTypeName: PRawUTF8): TJSONCustomParserRTTIType; overload; - /// recognize a simple type from a supplied type information - // - to be called if TypeNameToSimpleRTTIType() did fail, i.e. return ptCustom - // - will return ptCustom for any complex type (e.g. a record) - // - see also TypeInfoToRttiType() function - class function TypeInfoToSimpleRTTIType(Info: pointer): TJSONCustomParserRTTIType; - /// recognize a ktBinary simple type from a supplied type name - // - as registered by TTextWriter.RegisterCustomJSONSerializerFromTextBinaryType - class function TypeNameToSimpleBinary(const aTypeName: RawUTF8; - out aDataSize, aFieldSize: integer): boolean; - /// unserialize some JSON content into its binary internal representation - // - on error, returns false and P should point to the faulty text input - function ReadOneLevel(var P: PUTF8Char; var Data: PByte; - Options: TJSONCustomParserSerializationOptions{$ifndef NOVARIANTS}; - CustomVariantOptions: PDocVariantOptions{$endif}): boolean; virtual; - /// serialize a binary internal representation into JSON content - // - this method won't append a trailing ',' character - procedure WriteOneLevel(aWriter: TTextWriter; var P: PByte; - Options: TJSONCustomParserSerializationOptions); virtual; - /// the associated type name, e.g. for a record - property CustomTypeName: RawUTF8 read fCustomTypeName; - /// the property name - // - may be void for the Root element - // - e.g. 'SubProp' - property PropertyName: RawUTF8 read fPropertyName; - /// the property name, including all parent elements - // - may be void for the Root element - // - e.g. 'MainProp.SubProp' - property FullPropertyName: RawUTF8 read fFullPropertyName; - /// the property type - // - support only a limited set of simple types, or ptRecord for a nested - // record, or ptArray for a nested array - property PropertyType: TJSONCustomParserRTTIType read fPropertyType; - /// the nested array of properties (if any) - // - assigned only if PropertyType is [ptRecord,ptArray] - // - is either the record type of each ptArray item: - // ! SubProp: array of record ... - // - or one NestedProperty[0] entry with PropertyName='' and PropertyType - // not in [ptRecord,ptArray]: - // ! SubPropNumber: array of integer; - // ! SubPropText: array of RawUTF8; - property NestedProperty: TJSONCustomParserRTTIs read fNestedProperty; - end; - - /// used to store additional RTTI as a ptCustom kind of property - TJSONCustomParserCustom = class(TJSONCustomParserRTTI) - protected - fCustomTypeInfo: pointer; - public - /// initialize the instance - constructor Create(const aPropertyName, aCustomTypeName: RawUTF8); virtual; - /// abstract method to write the instance as JSON - procedure CustomWriter(const aWriter: TTextWriter; const aValue); virtual; abstract; - /// abstract method to read the instance from JSON - // - should return nil on parsing error - function CustomReader(P: PUTF8Char; var aValue; out EndOfObject: AnsiChar{$ifndef NOVARIANTS}; - CustomVariantOptions: PDocVariantOptions{$endif}): PUTF8Char; virtual; abstract; - /// release any memory used by the instance - procedure FinalizeItem(Data: Pointer); virtual; - /// the associated RTTI structure - property CustomTypeInfo: pointer read fCustomTypeInfo; - end; - - /// which kind of property does TJSONCustomParserCustomSimple refer to - TJSONCustomParserCustomSimpleKnownType = ( - ktNone, ktEnumeration, ktSet, ktGUID, - ktFixedArray, ktStaticArray, ktDynamicArray, ktBinary); - - /// used to store additional RTTI for simple type as a ptCustom kind - // - this class handle currently enumerate, TGUID or static/dynamic arrays - TJSONCustomParserCustomSimple = class(TJSONCustomParserCustom) - protected - fKnownType: TJSONCustomParserCustomSimpleKnownType; - fTypeData: pointer; - fFixedSize: integer; - fNestedArray: TJSONCustomParserRTTI; - public - /// initialize the instance from the given RTTI structure - constructor Create(const aPropertyName, aCustomTypeName: RawUTF8; - aCustomType: pointer); reintroduce; - /// initialize the instance for a static array - constructor CreateFixedArray(const aPropertyName: RawUTF8; - aFixedSize: cardinal); - /// initialize the instance for a binary blob - constructor CreateBinary(const aPropertyName: RawUTF8; - aDataSize, aFixedSize: cardinal); - /// released used memory - destructor Destroy; override; - /// method to write the instance as JSON - procedure CustomWriter(const aWriter: TTextWriter; const aValue); override; - /// method to read the instance from JSON - function CustomReader(P: PUTF8Char; var aValue; out EndOfObject: AnsiChar{$ifndef NOVARIANTS}; - CustomVariantOptions: PDocVariantOptions{$endif}): PUTF8Char; override; - /// which kind of simple property this instance does refer to - property KnownType: TJSONCustomParserCustomSimpleKnownType read fKnownType; - /// the element type for ktStaticArray and ktDynamicArray - property NestedArray: TJSONCustomParserRTTI read fNestedArray; - end; - - /// implement a reference to a registered record type - // - i.e. ptCustom kind of property, handled by the - // TTextWriter.RegisterCustomJSONSerializer*() internal list - TJSONCustomParserCustomRecord = class(TJSONCustomParserCustom) - protected - fCustomTypeIndex: integer; - function GetJSONCustomParserRegistration: pointer; - public - /// initialize the instance from the given record custom serialization index - constructor Create(const aPropertyName: RawUTF8; - aCustomTypeIndex: integer); reintroduce; overload; - /// method to write the instance as JSON - procedure CustomWriter(const aWriter: TTextWriter; const aValue); override; - /// method to read the instance from JSON - function CustomReader(P: PUTF8Char; var aValue; out EndOfObject: AnsiChar{$ifndef NOVARIANTS}; - CustomVariantOptions: PDocVariantOptions{$endif}): PUTF8Char; override; - /// release any memory used by the instance - procedure FinalizeItem(Data: Pointer); override; - end; - - /// how an RTTI expression is expected to finish - TJSONCustomParserRTTIExpectedEnd = (eeNothing, eeSquare, eeCurly, eeEndKeyWord); - - TJSONRecordAbstract = class; - - /// used to handle additional RTTI for JSON record serialization - // - this class is used to define how a record is defined, and will work - // with any version of Delphi - // - this Abstract class is not to be used as-this, but contains all - // needed information to provide CustomWriter/CustomReader methods - // - you can use e.g. TJSONRecordTextDefinition for text-based RTTI - // manual definition, or (not yet provided) a version based on Delphi 2010+ - // new RTTI information - TJSONRecordAbstract = class - protected - /// internal storage of TJSONCustomParserRTTI instances - fItems: TSynObjectList; - fRoot: TJSONCustomParserRTTI; - fOptions: TJSONCustomParserSerializationOptions; - function AddItem(const aPropertyName: RawUTF8; aPropertyType: TJSONCustomParserRTTIType; - const aCustomRecordTypeName: RawUTF8): TJSONCustomParserRTTI; - public - /// initialize the class instance - constructor Create; - /// callback for custom JSON serialization - // - will follow the RTTI textual information as supplied to the constructor - procedure CustomWriter(const aWriter: TTextWriter; const aValue); - /// callback for custom JSON unserialization - // - will follow the RTTI textual information as supplied to the constructor - function CustomReader(P: PUTF8Char; var aValue; out aValid: Boolean{$ifndef NOVARIANTS}; - CustomVariantOptions: PDocVariantOptions{$endif}): PUTF8Char; - /// release used memory - // - when created via Compute() call, instances of this class are managed - // via a GarbageCollector() global list, so you do not need to free them - destructor Destroy; override; - /// store the RTTI information of properties at root level - // - is one instance with PropertyType=ptRecord and PropertyName='' - property Root: TJSONCustomParserRTTI read fRoot; - /// how this class would serialize/unserialize JSON content - // - by default, no option is defined - // - you can customize the expected options with the instance returned by - // TTextWriter.RegisterCustomJSONSerializerFromText() method, or via the - // TTextWriter.RegisterCustomJSONSerializerSetOptions() overloaded methods - property Options: TJSONCustomParserSerializationOptions read fOptions write fOptions; - end; - - /// used to handle JSON record serialization using RTTI - // - is able to handle any kind of record since Delphi 2010, thanks to - // enhanced RTTI - TJSONRecordRTTI = class(TJSONRecordAbstract) - protected - fRecordTypeInfo: pointer; - function AddItemFromRTTI(const PropertyName: RawUTF8; - Info: pointer; ItemSize: integer): TJSONCustomParserRTTI; - {$ifdef ISDELPHI2010} - procedure FromEnhancedRTTI(Props: TJSONCustomParserRTTI; Info: pointer); - {$endif} - public - /// initialize the instance - // - you should NOT use this constructor directly, but let e.g. - // TJSONCustomParsers.TryToGetFromRTTI() create it for you - constructor Create(aRecordTypeInfo: pointer; aRoot: TJSONCustomParserRTTI); reintroduce; - /// the low-level address of the enhanced RTTI - property RecordTypeInfo: pointer read fRecordTypeInfo; - end; - - /// used to handle text-defined additional RTTI for JSON record serialization - // - is used by TTextWriter.RegisterCustomJSONSerializerFromText() method - TJSONRecordTextDefinition = class(TJSONRecordAbstract) - protected - fDefinition: RawUTF8; - procedure Parse(Props: TJSONCustomParserRTTI; var P: PUTF8Char; - PEnd: TJSONCustomParserRTTIExpectedEnd); - public - /// initialize a custom JSON serializer/unserializer from pseudo RTTI - // - you should NOT use this constructor directly, but call the FromCache() - // class function, which will use an internal definition cache - constructor Create(aRecordTypeInfo: pointer; const aDefinition: RawUTF8); reintroduce; - /// retrieve a custom cached JSON serializer/unserializer from pseudo RTTI - // - returned class instance will be cached for any further use - // - the record where the data will be stored should be defined as PACKED: - // ! type TMyRecord = packed record - // ! A,B,C: integer; - // ! D: RawUTF8; - // ! E: record; // or array of record/integer/string/... - // ! E1,E2: double; - // ! end; - // ! end; - // - only known sub types are integer, cardinal, Int64, single, double, - // currency, TDateTime, TTimeLog, RawUTF8, String, WideString, SynUnicode, - // or a nested record or dynamic array - // - RTTI textual information shall be supplied as text, with the - // same format as with a pascal record, or with some shorter variations: - // ! FromCache('A,B,C: integer; D: RawUTF8; E: record E1,E2: double; end;'); - // ! FromCache('A,B,C: integer; D: RawUTF8; E: array of record E1,E2: double; end;'); - // ! 'A,B,C: integer; D: RawUTF8; E: array of SynUnicode; F: array of integer' - // or a shorter alternative syntax for records and arrays: - // ! FromCache('A,B,C: integer; D: RawUTF8; E: {E1,E2: double}'); - // ! FromCache('A,B,C: integer; D: RawUTF8; E: [E1,E2: double]'); - // in fact ; could be ignored: - // ! FromCache('A,B,C:integer D:RawUTF8 E:{E1,E2:double}'); - // ! FromCache('A,B,C:integer D:RawUTF8 E:[E1,E2:double]'); - // or even : could be ignored: - // ! FromCache('A,B,C integer D RawUTF8 E{E1,E2 double}'); - // ! FromCache('A,B,C integer D RawUTF8 E[E1,E2 double]'); - class function FromCache(aTypeInfo: pointer; - const aDefinition: RawUTF8): TJSONRecordTextDefinition; - /// the textual definition of this RTTI information - property Definition: RawUTF8 read fDefinition; - end; - - /// the available logging events, as handled by TSynLog - // - defined in SynCommons so that it may be used with TTextWriter.AddEndOfLine - // - sllInfo will log general information events - // - sllDebug will log detailed debugging information - // - sllTrace will log low-level step by step debugging information - // - sllWarning will log unexpected values (not an error) - // - sllError will log errors - // - sllEnter will log every method start - // - sllLeave will log every method exit - // - sllLastError will log the GetLastError OS message - // - sllException will log all exception raised - available since Windows XP - // - sllExceptionOS will log all OS low-level exceptions (EDivByZero, - // ERangeError, EAccessViolation...) - // - sllMemory will log memory statistics - // - sllStackTrace will log caller's stack trace (it's by default part of - // TSynLogFamily.LevelStackTrace like sllError, sllException, sllExceptionOS, - // sllLastError and sllFail) - // - sllFail was defined for TSynTestsLogged.Failed method, and can be used - // to log some customer-side assertions (may be notifications, not errors) - // - sllSQL is dedicated to trace the SQL statements - // - sllCache should be used to trace the internal caching mechanism - // - sllResult could trace the SQL results, JSON encoded - // - sllDB is dedicated to trace low-level database engine features - // - sllHTTP could be used to trace HTTP process - // - sllClient/sllServer could be used to trace some Client or Server process - // - sllServiceCall/sllServiceReturn to trace some remote service or library - // - sllUserAuth to trace user authentication (e.g. for individual requests) - // - sllCustom* items can be used for any purpose - // - sllNewRun will be written when a process opens a rotated log - // - sllDDDError will log any DDD-related low-level error information - // - sllDDDInfo will log any DDD-related low-level debugging information - // - sllMonitoring will log the statistics information (if available), - // or may be used for real-time chat among connected people to ToolsAdmin - TSynLogInfo = ( - sllNone, sllInfo, sllDebug, sllTrace, sllWarning, sllError, - sllEnter, sllLeave, - sllLastError, sllException, sllExceptionOS, sllMemory, sllStackTrace, - sllFail, sllSQL, sllCache, sllResult, sllDB, sllHTTP, sllClient, sllServer, - sllServiceCall, sllServiceReturn, sllUserAuth, - sllCustom1, sllCustom2, sllCustom3, sllCustom4, sllNewRun, - sllDDDError, sllDDDInfo, sllMonitoring); - - /// used to define a set of logging level abilities - // - i.e. a combination of none or several logging event - // - e.g. use LOG_VERBOSE constant to log all events, or LOG_STACKTRACE - // to log all errors and exceptions - TSynLogInfos = set of TSynLogInfo; - - /// a dynamic array of logging event levels - TSynLogInfoDynArray = array of TSynLogInfo; - - - /// event signature for TTextWriter.OnFlushToStream callback - TOnTextWriterFlush = procedure(Text: PUTF8Char; Len: PtrInt) of object; - - /// available options for TTextWriter.WriteObject() method - // - woHumanReadable will add some line feeds and indentation to the content, - // to make it more friendly to the human eye - // - woDontStoreDefault (which is set by default for WriteObject method) will - // avoid serializing properties including a default value (JSONToObject function - // will set the default values, so it may help saving some bandwidth or storage) - // - woFullExpand will generate a debugger-friendly layout, including instance - // class name, sets/enumerates as text, and reference pointer - as used by - // TSynLog and ObjectToJSONFull() - // - woStoreClassName will add a "ClassName":"TMyClass" field - // - woStorePointer will add a "Address":"0431298A" field, and .map/.mab - // source code line number corresponding to ESynException.RaisedAt - // - woStoreStoredFalse will write the 'stored false' properties, even - // if they are marked as such (used e.g. to persist all settings on file, - // but disallow the sensitive - password - fields be logged) - // - woHumanReadableFullSetsAsStar will store an human-readable set with - // all its enumerates items set to be stored as ["*"] - // - woHumanReadableEnumSetAsComment will add a comment at the end of the - // line, containing all available values of the enumaration or set, e.g: - // $ "Enum": "Destroying", // Idle,Started,Finished,Destroying - // - woEnumSetsAsText will store sets and enumerables as text (is also - // included in woFullExpand or woHumanReadable) - // - woDateTimeWithMagic will append the JSON_SQLDATE_MAGIC (i.e. U+FFF1) - // before the ISO-8601 encoded TDateTime value - // - woDateTimeWithZSuffix will append the Z suffix to the ISO-8601 encoded - // TDateTime value, to identify the content as strict UTC value - // - TTimeLog would be serialized as Int64, unless woTimeLogAsText is defined - // - since TSQLRecord.ID could be huge Int64 numbers, they may be truncated - // on client side, e.g. to 53-bit range in JavaScript: you could define - // woIDAsIDstr to append an additional "ID_str":"##########" field - // - by default, TSQLRawBlob properties are serialized as null, unless - // woSQLRawBlobAsBase64 is defined - // - if woHideSynPersistentPassword is set, TSynPersistentWithPassword.Password - // field will be serialized as "***" to prevent security issues (e.g. in log) - // - by default, TObjectList will set the woStoreClassName for its nested - // objects, unless woObjectListWontStoreClassName is defined - // - void strings would be serialized as "", unless woDontStoreEmptyString - // is defined so that such properties would not be written - // - all inherited properties would be serialized, unless woDontStoreInherited - // is defined, and only the topmost class level properties would be serialized - // - woInt64AsHex will force Int64/QWord to be written as hexadecimal string - - // see j2oAllowInt64Hex reverse option fot Json2Object - // - woDontStore0 will avoid serializating number properties equal to 0 - TTextWriterWriteObjectOption = ( - woHumanReadable, woDontStoreDefault, woFullExpand, - woStoreClassName, woStorePointer, woStoreStoredFalse, - woHumanReadableFullSetsAsStar, woHumanReadableEnumSetAsComment, - woEnumSetsAsText, woDateTimeWithMagic, woDateTimeWithZSuffix, woTimeLogAsText, - woIDAsIDstr, woSQLRawBlobAsBase64, woHideSynPersistentPassword, - woObjectListWontStoreClassName, woDontStoreEmptyString, - woDontStoreInherited, woInt64AsHex, woDontStore0); - /// options set for TTextWriter.WriteObject() method - TTextWriterWriteObjectOptions = set of TTextWriterWriteObjectOption; - - /// callback used to echo each line of TTextWriter class - // - should return TRUE on success, FALSE if the log was not echoed: but - // TSynLog will continue logging, even if this event returned FALSE - TOnTextWriterEcho = function(Sender: TTextWriter; Level: TSynLogInfo; - const Text: RawUTF8): boolean of object; - /// callback used by TTextWriter.WriteObject to customize class instance - // serialization - // - should return TRUE if the supplied property has been written (including - // the property name and the ending ',' character), and doesn't need to be - // processed with the default RTTI-based serializer - TOnTextWriterObjectProp = function(Sender: TTextWriter; Value: TObject; - PropInfo: pointer; Options: TTextWriterWriteObjectOptions): boolean of object; - - /// the potential places were TTextWriter.AddHtmlEscape should process - // proper HTML string escaping, unless hfNone is used - // $ < > & " -> < > & "e; - // by default (hfAnyWhere) - // $ < > & -> < > & - // outside HTML attributes (hfOutsideAttributes) - // $ & " -> & "e; - // within HTML attributes (hfWithinAttributes) - TTextWriterHTMLFormat = ( - hfNone, hfAnyWhere, hfOutsideAttributes, hfWithinAttributes); - - /// available global options for a TTextWriter instance - // - TTextWriter.WriteObject() method behavior would be set via their own - // TTextWriterWriteObjectOptions, and work in conjunction with those settings - // - twoStreamIsOwned would be set if the associated TStream is owned by - // the TTextWriter instance - // - twoFlushToStreamNoAutoResize would forbid FlushToStream to resize the - // internal memory buffer when it appears undersized - FlushFinal will set it - // before calling a last FlushToStream - // - by default, custom serializers defined via RegisterCustomJSONSerializer() - // would let AddRecordJSON() and AddDynArrayJSON() write enumerates and sets - // as integer numbers, unless twoEnumSetsAsTextInRecord or - // twoEnumSetsAsBooleanInRecord (exclusively) are set - for Mustache data - // context, twoEnumSetsAsBooleanInRecord will return a JSON object with - // "setname":true/false fields - // - variants and nested objects would be serialized with their default - // JSON serialization options, unless twoForceJSONExtended or - // twoForceJSONStandard is defined - // - when enumerates and sets are serialized as text into JSON, you may force - // the identifiers to be left-trimed for all their lowercase characters - // (e.g. sllError -> 'Error') by setting twoTrimLeftEnumSets: this option - // would default to the global TTextWriter.SetDefaultEnumTrim setting - // - twoEndOfLineCRLF would reflect the TTextWriter.EndOfLineCRLF property - // - twoBufferIsExternal would be set if the temporary buffer is not handled - // by the instance, but specified at constructor, maybe from the stack - // - twoIgnoreDefaultInRecord will force custom record serialization to avoid - // writing the fields with default values, i.e. enable soWriteIgnoreDefault - // when TJSONCustomParserRTTI.WriteOneLevel is called - // - twoDateTimeWithZ appends an ending 'Z' to TDateTime/TDateTimeMS values - TTextWriterOption = ( - twoStreamIsOwned, - twoFlushToStreamNoAutoResize, - twoEnumSetsAsTextInRecord, - twoEnumSetsAsBooleanInRecord, - twoFullSetsAsStar, - twoTrimLeftEnumSets, - twoForceJSONExtended, - twoForceJSONStandard, - twoEndOfLineCRLF, - twoBufferIsExternal, - twoIgnoreDefaultInRecord, - twoDateTimeWithZ); - /// options set for a TTextWriter instance - // - allows to override e.g. AddRecordJSON() and AddDynArrayJSON() behavior; - // or set global process customization for a TTextWriter - TTextWriterOptions = set of TTextWriterOption; - - /// may be used to allocate on stack a 8KB work buffer for a TTextWriter - // - via the TTextWriter.CreateOwnedStream overloaded constructor - TTextWriterStackBuffer = array[0..8191] of AnsiChar; - PTextWriterStackBuffer = ^TTextWriterStackBuffer; - - /// simple writer to a Stream, specialized for the TEXT format - // - use an internal buffer, faster than string+string - // - some dedicated methods is able to encode any data with JSON/XML escape - // - see TTextWriterWithEcho below for optional output redirection (for TSynLog) - // - see SynTable.pas for SQL resultset export via TJSONWriter - // - see mORMot.pas for proper class serialization via TJSONSerializer.WriteObject - TTextWriter = class - protected - B, BEnd: PUTF8Char; - fStream: TStream; - fInitialStreamPosition: PtrUInt; - fTotalFileSize: PtrUInt; - fCustomOptions: TTextWriterOptions; - // internal temporary buffer - fTempBufSize: Integer; - fTempBuf: PUTF8Char; - fOnFlushToStream: TOnTextWriterFlush; - fOnWriteObject: TOnTextWriterObjectProp; - /// used by WriteObjectAsString/AddDynArrayJSONAsString methods - fInternalJSONWriter: TTextWriter; - fHumanReadableLevel: integer; - procedure WriteToStream(data: pointer; len: PtrUInt); virtual; - function GetTextLength: PtrUInt; - procedure SetStream(aStream: TStream); - procedure SetBuffer(aBuf: pointer; aBufSize: integer); - procedure InternalAddFixedAnsi(Source: PAnsiChar; SourceChars: Cardinal; - AnsiToWide: PWordArray; Escape: TTextWriterKind); - public - /// the data will be written to the specified Stream - // - aStream may be nil: in this case, it MUST be set before using any - // Add*() method - // - default internal buffer size if 8192 - constructor Create(aStream: TStream; aBufSize: integer=8192); overload; - /// the data will be written to the specified Stream - // - aStream may be nil: in this case, it MUST be set before using any - // Add*() method - // - will use an external buffer (which may be allocated on stack) - constructor Create(aStream: TStream; aBuf: pointer; aBufSize: integer); overload; - /// the data will be written to an internal TRawByteStringStream - // - TRawByteStringStream.DataString method will be used by TTextWriter.Text - // to retrieve directly the content without any data move nor allocation - // - default internal buffer size if 4096 (enough for most JSON objects) - // - consider using a stack-allocated buffer and the overloaded method - constructor CreateOwnedStream(aBufSize: integer=4096); overload; - /// the data will be written to an internal TRawByteStringStream - // - will use an external buffer (which may be allocated on stack) - // - TRawByteStringStream.DataString method will be used by TTextWriter.Text - // to retrieve directly the content without any data move nor allocation - constructor CreateOwnedStream(aBuf: pointer; aBufSize: integer); overload; - /// the data will be written to an internal TRawByteStringStream - // - will use the stack-allocated TTextWriterStackBuffer if possible - // - TRawByteStringStream.DataString method will be used by TTextWriter.Text - // to retrieve directly the content without any data move nor allocation - constructor CreateOwnedStream(var aStackBuf: TTextWriterStackBuffer; - aBufSize: integer=SizeOf(TTextWriterStackBuffer)); overload; - /// the data will be written to an external file - // - you should call explicitly FlushFinal or FlushToStream to write - // any pending data to the file - constructor CreateOwnedFileStream(const aFileName: TFileName; aBufSize: integer=8192); - /// release all internal structures - // - e.g. free fStream if the instance was owned by this class - destructor Destroy; override; - /// allow to override the default JSON serialization of enumerations and - // sets as text, which would write the whole identifier (e.g. 'sllError') - // - calling SetDefaultEnumTrim(true) would force the enumerations to - // be trimmed for any lower case char, e.g. sllError -> 'Error' - // - this is global to the current process, and should be use mainly for - // compatibility purposes for the whole process - // - you may change the default behavior by setting twoTrimLeftEnumSets - // in the TTextWriter.CustomOptions property of a given serializer - // - note that unserialization process would recognize both formats - class procedure SetDefaultEnumTrim(aShouldTrimEnumsAsText: boolean); - - /// retrieve the data as a string - function Text: RawUTF8; - {$ifdef HASINLINE}inline;{$endif} - /// retrieve the data as a string - // - will avoid creation of a temporary RawUTF8 variable as for Text function - procedure SetText(var result: RawUTF8; reformat: TTextWriterJSONFormat=jsonCompact); - /// set the internal stream content with the supplied UTF-8 text - procedure ForceContent(const text: RawUTF8); - /// write pending data to the Stream, with automatic buffer resizal - // - you should not have to call FlushToStream in most cases, but FlushFinal - // at the end of the process, just before using the resulting Stream - // - FlushToStream may be used to force immediate writing of the internal - // memory buffer to the destination Stream - // - you can set FlushToStreamNoAutoResize=true or call FlushFinal if you - // do not want the automatic memory buffer resizal to take place - procedure FlushToStream; virtual; - /// write pending data to the Stream, without automatic buffer resizal - // - will append the internal memory buffer to the Stream - // - in short, FlushToStream may be called during the adding process, and - // FlushFinal at the end of the process, just before using the resulting Stream - // - if you don't call FlushToStream or FlushFinal, some pending characters - // may not be copied to the Stream: you should call it before using the Stream - procedure FlushFinal; - /// gives access to an internal temporary TTextWriter - // - may be used to escape some JSON espaced value (i.e. escape it twice), - // in conjunction with AddJSONEscape(Source: TTextWriter) - function InternalJSONWriter: TTextWriter; - - /// append one ASCII char to the buffer - procedure Add(c: AnsiChar); overload; {$ifdef HASINLINE}inline;{$endif} - /// append one ASCII char to the buffer, if not already there as LastChar - procedure AddOnce(c: AnsiChar); overload; {$ifdef HASINLINE}inline;{$endif} - /// append two chars to the buffer - procedure Add(c1,c2: AnsiChar); overload; {$ifdef HASINLINE}inline;{$endif} - {$ifndef CPU64} // already implemented by Add(Value: PtrInt) method - /// append a 64-bit signed Integer Value as text - procedure Add(Value: Int64); overload; - {$endif} - /// append a 32-bit signed Integer Value as text - procedure Add(Value: PtrInt); overload; - /// append a boolean Value as text - // - write either 'true' or 'false' - procedure Add(Value: boolean); overload; {$ifdef HASINLINE}inline;{$endif} - /// append a Currency from its Int64 in-memory representation - procedure AddCurr64(const Value: Int64); overload; - /// append a Currency from its Int64 in-memory representation - procedure AddCurr64(const Value: currency); overload; {$ifdef HASINLINE}inline;{$endif} - /// append a TTimeLog value, expanded as Iso-8601 encoded text - procedure AddTimeLog(Value: PInt64); - /// append a TUnixTime value, expanded as Iso-8601 encoded text - procedure AddUnixTime(Value: PInt64); - /// append a TUnixMSTime value, expanded as Iso-8601 encoded text - procedure AddUnixMSTime(Value: PInt64; WithMS: boolean=false); - /// append a TDateTime value, expanded as Iso-8601 encoded text - // - use 'YYYY-MM-DDThh:mm:ss' format (with FirstChar='T') - // - if twoDateTimeWithZ CustomOption is set, will append an ending 'Z' - // - if WithMS is TRUE, will append '.sss' for milliseconds resolution - // - if QuoteChar is not #0, it will be written before and after the date - procedure AddDateTime(Value: PDateTime; FirstChar: AnsiChar='T'; QuoteChar: AnsiChar=#0; - WithMS: boolean=false); overload; - /// append a TDateTime value, expanded as Iso-8601 encoded text - // - use 'YYYY-MM-DDThh:mm:ss' format - // - if twoDateTimeWithZ CustomOption is set, will append an ending 'Z' - // - append nothing if Value=0 - // - if WithMS is TRUE, will append '.sss' for milliseconds resolution - procedure AddDateTime(const Value: TDateTime; WithMS: boolean=false); overload; - /// append a TDateTime value, expanded as Iso-8601 text with milliseconds - // and Time Zone designator - // - twoDateTimeWithZ CustomOption is ignored in favor of the TZD parameter - // - i.e. 'YYYY-MM-DDThh:mm:ss.sssZ' format - // - TZD is the ending time zone designator ('', 'Z' or '+hh:mm' or '-hh:mm') - procedure AddDateTimeMS(const Value: TDateTime; Expanded: boolean=true; - FirstTimeChar: AnsiChar = 'T'; const TZD: RawUTF8='Z'); - /// append an Unsigned 32-bit Integer Value as a String - procedure AddU(Value: cardinal); - /// append an Unsigned 64-bit Integer Value as a String - procedure AddQ(Value: QWord); - /// append an Unsigned 64-bit Integer Value as a quoted hexadecimal String - procedure AddQHex(Value: Qword); {$ifdef HASINLINE}inline;{$endif} - /// append a GUID value, encoded as text without any {} - // - will store e.g. '3F2504E0-4F89-11D3-9A0C-0305E82C3301' - procedure Add({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID); overload; - /// append a floating-point Value as a String - // - write "Infinity", "-Infinity", and "NaN" for corresponding IEEE values - // - noexp=true will call ExtendedToShortNoExp() to avoid any scientific - // notation in the resulting text - procedure AddDouble(Value: double; noexp: boolean=false); {$ifdef HASINLINE}inline;{$endif} - /// append a floating-point Value as a String - // - write "Infinity", "-Infinity", and "NaN" for corresponding IEEE values - // - noexp=true will call ExtendedToShortNoExp() to avoid any scientific - // notation in the resulting text - procedure AddSingle(Value: single; noexp: boolean=false); {$ifdef HASINLINE}inline;{$endif} - /// append a floating-point Value as a String - // - write "Infinity", "-Infinity", and "NaN" for corresponding IEEE values - // - noexp=true will call ExtendedToShortNoExp() to avoid any scientific - // notation in the resulting text - procedure Add(Value: Extended; precision: integer; noexp: boolean=false); overload; - /// append a floating-point text buffer - // - will correct on the fly '.5' -> '0.5' and '-.5' -> '-0.5' - // - will end not only on #0 but on any char not matching 1[.2[e[-]3]] pattern - // - is used when the input comes from a third-party source with no regular - // output, e.g. a database driver - procedure AddFloatStr(P: PUTF8Char); - /// append strings or integers with a specified format - // - % = #37 marks a string, integer, floating-point, or class parameter - // to be appended as text (e.g. class name) - // - if StringEscape is false (by default), the text won't be escaped before - // adding; but if set to true text will be JSON escaped at writing - // - note that due to a limitation of the "array of const" format, cardinal - // values should be type-casted to Int64() - otherwise the integer mapped - // value will be transmitted, therefore wrongly - {$ifdef OLDTEXTWRITERFORMAT} - // - $ dollar = #36 indicates an integer to be written with 2 digits and a comma - // - | vertical = #124 will write the next char e.g. Add('%|$',[10]) will write '10$' - // - pound = #163 indicates an integer to be written with 4 digits and a comma - // - micro = #181 indicates an integer to be written with 3 digits without any comma - // - currency = #164 indicates CR+LF chars - // - section = #167 indicates to trim last comma - // - since some of this characters above are > #127, they are not UTF-8 - // ready, so we expect the input format to be WinAnsi, i.e. mostly English - // text (with chars < #128) with some values to be inserted inside - {$endif} - procedure Add(const Format: RawUTF8; const Values: array of const; - Escape: TTextWriterKind=twNone; WriteObjectOptions: TTextWriterWriteObjectOptions=[woFullExpand]); overload; - /// append some values at once - // - text values (e.g. RawUTF8) will be escaped as JSON - procedure Add(const Values: array of const); overload; - /// append CR+LF (#13#10) chars - // - this method won't call EchoAdd() registered events - use AddEndOfLine() - // method instead - // - AddEndOfLine() will append either CR+LF (#13#10) or LF (#10) depending - // on a flag - procedure AddCR; - /// append CR+LF (#13#10) chars and #9 indentation - // - indentation depth is defined by fHumanReadableLevel protected field - procedure AddCRAndIndent; - /// write the same character multiple times - procedure AddChars(aChar: AnsiChar; aCount: integer); - /// append an Integer Value as a 2 digits String with comma - procedure Add2(Value: PtrUInt); - /// append the current UTC date and time, in our log-friendly format - // - e.g. append '20110325 19241502' - with no trailing space nor tab - // - you may set LocalTime=TRUE to write the local date and time instead - // - this method is very fast, and avoid most calculation or API calls - procedure AddCurrentLogTime(LocalTime: boolean); - /// append the current UTC date and time, in our log-friendly format - // - e.g. append '19/Feb/2019:06:18:55 ' - including a trailing space - // - you may set LocalTime=TRUE to write the local date and time instead - // - this method is very fast, and avoid most calculation or API calls - procedure AddCurrentNCSALogTime(LocalTime: boolean); - /// append a time period, specified in micro seconds, in 00.000.000 TSynLog format - procedure AddMicroSec(MS: cardinal); - /// append an Integer Value as a 4 digits String with comma - procedure Add4(Value: PtrUInt); - /// append an Integer Value as a 3 digits String without any added comma - procedure Add3(Value: PtrUInt); - /// append a line of text with CR+LF at the end - procedure AddLine(const Text: shortstring); - /// append an UTF-8 String, with no JSON escaping - procedure AddString(const Text: RawUTF8); - /// append several UTF-8 strings - procedure AddStrings(const Text: array of RawUTF8); overload; - /// append an UTF-8 string several times - procedure AddStrings(const Text: RawUTF8; count: integer); overload; - /// append a ShortString - procedure AddShort(const Text: ShortString); - /// append a sub-part of an UTF-8 String - // - emulates AddString(copy(Text,start,len)) - procedure AddStringCopy(const Text: RawUTF8; start,len: PtrInt); - /// append after trim first lowercase chars ('otDone' will add 'Done' e.g.) - procedure AddTrimLeftLowerCase(Text: PShortString); - /// append a UTF-8 String excluding any space or control char - // - this won't escape the text as expected by JSON - procedure AddTrimSpaces(const Text: RawUTF8); overload; - {$ifdef HASINLINE}inline;{$endif} - /// append a UTF-8 String excluding any space or control char - // - this won't escape the text as expected by JSON - procedure AddTrimSpaces(P: PUTF8Char); overload; - /// append a property name, as '"PropName":' - // - PropName content should not need to be JSON escaped (e.g. no " within, - // and only ASCII 7-bit characters) - // - if twoForceJSONExtended is defined in CustomOptions, it would append - // 'PropName:' without the double quotes - procedure AddProp(PropName: PUTF8Char; PropNameLen: PtrInt); - /// append a ShortString property name, as '"PropName":' - // - PropName content should not need to be JSON escaped (e.g. no " within, - // and only ASCII 7-bit characters) - // - if twoForceJSONExtended is defined in CustomOptions, it would append - // 'PropName:' without the double quotes - // - is a wrapper around AddProp() - procedure AddPropName(const PropName: ShortString); - {$ifdef HASINLINE}inline;{$endif} - /// append a JSON field name, followed by an escaped UTF-8 JSON String and - // a comma (',') - procedure AddPropJSONString(const PropName: shortstring; const Text: RawUTF8); - /// append a JSON field name, followed by a number value and a comma (',') - procedure AddPropJSONInt64(const PropName: shortstring; Value: Int64); - /// append a RawUTF8 property name, as '"FieldName":' - // - FieldName content should not need to be JSON escaped (e.g. no " within) - // - if twoForceJSONExtended is defined in CustomOptions, it would append - // 'PropName:' without the double quotes - // - is a wrapper around AddProp() - procedure AddFieldName(const FieldName: RawUTF8); - {$ifdef HASINLINE}inline;{$endif} - /// append the class name of an Object instance as text - // - aClass must be not nil - procedure AddClassName(aClass: TClass); - /// append an Instance name and pointer, as '"TObjectList(00425E68)"'+SepChar - // - Instance must be not nil - procedure AddInstanceName(Instance: TObject; SepChar: AnsiChar); - /// append an Instance name and pointer, as 'TObjectList(00425E68)'+SepChar - // - Instance must be not nil - // - overriden version in TJSONSerializer would implement IncludeUnitName - procedure AddInstancePointer(Instance: TObject; SepChar: AnsiChar; - IncludeUnitName, IncludePointer: boolean); virtual; - /// append a quoted string as JSON, with in-place decoding - // - if QuotedString does not start with ' or ", it will written directly - // (i.e. expects to be a number, or null/true/false constants) - // - as used e.g. by TJSONObjectDecoder.EncodeAsJSON method and - // JSONEncodeNameSQLValue() function - procedure AddQuotedStringAsJSON(const QuotedString: RawUTF8); - /// append an array of integers as CSV - procedure AddCSVInteger(const Integers: array of Integer); overload; - /// append an array of doubles as CSV - procedure AddCSVDouble(const Doubles: array of double); overload; - /// append an array of RawUTF8 as CSV of JSON strings - procedure AddCSVUTF8(const Values: array of RawUTF8); overload; - /// append an array of const as CSV of JSON values - procedure AddCSVConst(const Values: array of const); - /// write some data Base64 encoded - // - if withMagic is TRUE, will write as '"\uFFF0base64encodedbinary"' - procedure WrBase64(P: PAnsiChar; Len: PtrUInt; withMagic: boolean); - /// write some record content as binary, Base64 encoded with our magic prefix - procedure WrRecord(const Rec; TypeInfo: pointer); - /// write some #0 ended UTF-8 text, according to the specified format - // - if Escape is a constant, consider calling directly AddNoJSONEscape, - // AddJSONEscape or AddOnSameLine methods - procedure Add(P: PUTF8Char; Escape: TTextWriterKind); overload; - /// write some #0 ended UTF-8 text, according to the specified format - // - if Escape is a constant, consider calling directly AddNoJSONEscape, - // AddJSONEscape or AddOnSameLine methods - procedure Add(P: PUTF8Char; Len: PtrInt; Escape: TTextWriterKind); overload; - /// write some #0 ended Unicode text as UTF-8, according to the specified format - // - if Escape is a constant, consider calling directly AddNoJSONEscapeW, - // AddJSONEscapeW or AddOnSameLineW methods - procedure AddW(P: PWord; Len: PtrInt; Escape: TTextWriterKind); - /// append some UTF-8 encoded chars to the buffer, from the main AnsiString type - // - use the current system code page for AnsiString parameter - procedure AddAnsiString(const s: AnsiString; Escape: TTextWriterKind); overload; - /// append some UTF-8 encoded chars to the buffer, from any AnsiString value - // - if CodePage is left to its default value of -1, it will assume - // CurrentAnsiConvert.CodePage prior to Delphi 2009, but newer UNICODE - // versions of Delphi will retrieve the code page from string - // - if CodePage is defined to a >= 0 value, the encoding will take place - procedure AddAnyAnsiString(const s: RawByteString; Escape: TTextWriterKind; - CodePage: Integer=-1); - /// append some UTF-8 encoded chars to the buffer, from any Ansi buffer - // - the codepage should be specified, e.g. CP_UTF8, CP_RAWBYTESTRING, - // CODEPAGE_US, or any version supported by the Operating System - // - if codepage is 0, the current CurrentAnsiConvert.CodePage would be used - // - will use TSynAnsiConvert to perform the conversion to UTF-8 - procedure AddAnyAnsiBuffer(P: PAnsiChar; Len: PtrInt; - Escape: TTextWriterKind; CodePage: Integer); - /// append some UTF-8 chars to the buffer - // - input length is calculated from zero-ended char - // - don't escapes chars according to the JSON RFC - procedure AddNoJSONEscape(P: Pointer); overload; - /// append some UTF-8 chars to the buffer - // - don't escapes chars according to the JSON RFC - procedure AddNoJSONEscape(P: Pointer; Len: PtrInt); overload; - /// append some UTF-8 chars to the buffer - // - don't escapes chars according to the JSON RFC - procedure AddNoJSONEscapeUTF8(const text: RawByteString); - {$ifdef HASINLINE}inline;{$endif} - /// flush a supplied TTextWriter, and write pending data as JSON escaped text - // - may be used with InternalJSONWriter, as a faster alternative to - // ! AddNoJSONEscapeUTF8(Source.Text); - procedure AddNoJSONEscape(Source: TTextWriter); overload; - /// append some UTF-8 chars to the buffer - // - if supplied json is '', will write 'null' - procedure AddRawJSON(const json: RawJSON); - /// append some UTF-8 text, quoting all " chars - // - same algorithm than AddString(QuotedStr()) - without memory allocation, - // and with an optional maximum text length (truncated with ending '...') - // - this function implements what is specified in the official SQLite3 - // documentation: "A string constant is formed by enclosing the string in single - // quotes ('). A single quote within the string can be encoded by putting two - // single quotes in a row - as in Pascal." - procedure AddQuotedStr(Text: PUTF8Char; Quote: AnsiChar; TextMaxLen: PtrInt=0); - /// append some chars, escaping all HTML special chars as expected - procedure AddHtmlEscape(Text: PUTF8Char; Fmt: TTextWriterHTMLFormat=hfAnyWhere); overload; - /// append some chars, escaping all HTML special chars as expected - procedure AddHtmlEscape(Text: PUTF8Char; TextLen: PtrInt; - Fmt: TTextWriterHTMLFormat=hfAnyWhere); overload; - /// append some chars, escaping all HTML special chars as expected - procedure AddHtmlEscapeString(const Text: string; - Fmt: TTextWriterHTMLFormat=hfAnyWhere); - /// append some chars, escaping all HTML special chars as expected - procedure AddHtmlEscapeUTF8(const Text: RawUTF8; - Fmt: TTextWriterHTMLFormat=hfAnyWhere); - /// append some chars, escaping all XML special chars as expected - // - i.e. < > & " ' as < > & "e; ' - // - and all control chars (i.e. #1..#31) as &#..; - // - see @http://www.w3.org/TR/xml/#syntax - procedure AddXmlEscape(Text: PUTF8Char); - /// append some chars, replacing a given character with another - procedure AddReplace(Text: PUTF8Char; Orig,Replaced: AnsiChar); - /// append some binary data as hexadecimal text conversion - procedure AddBinToHex(Bin: Pointer; BinBytes: integer); - /// fast conversion from binary data into hexa chars, ready to be displayed - // - using this function with Bin^ as an integer value will serialize it - // in big-endian order (most-significant byte first), as used by humans - // - up to the internal buffer bytes may be converted - procedure AddBinToHexDisplay(Bin: pointer; BinBytes: integer); - /// fast conversion from binary data into MSB hexa chars - // - up to the internal buffer bytes may be converted - procedure AddBinToHexDisplayLower(Bin: pointer; BinBytes: integer); - /// fast conversion from binary data into quoted MSB lowercase hexa chars - // - up to the internal buffer bytes may be converted - procedure AddBinToHexDisplayQuoted(Bin: pointer; BinBytes: integer); - /// append a Value as significant hexadecimal text - // - append its minimal size, i.e. excluding highest bytes containing 0 - // - use GetNextItemHexa() to decode such a text value - procedure AddBinToHexDisplayMinChars(Bin: pointer; BinBytes: PtrInt); - /// add the pointer into significant hexa chars, ready to be displayed - procedure AddPointer(P: PtrUInt); {$ifdef HASINLINE}inline;{$endif} - /// write a byte as hexa chars - procedure AddByteToHex(Value: byte); - /// write a Int18 value (0..262143) as 3 chars - // - this encoding is faster than Base64, and has spaces on the left side - // - use function Chars3ToInt18() to decode the textual content - procedure AddInt18ToChars3(Value: cardinal); - /// append some unicode chars to the buffer - // - WideCharCount is the unicode chars count, not the byte size - // - don't escapes chars according to the JSON RFC - // - will convert the Unicode chars into UTF-8 - procedure AddNoJSONEscapeW(WideChar: PWord; WideCharCount: integer); - /// append some UTF-8 encoded chars to the buffer - // - escapes chars according to the JSON RFC - // - if Len is 0, writing will stop at #0 (default Len=0 is slightly faster - // than specifying Len>0 if you are sure P is zero-ended - e.g. from RawUTF8) - procedure AddJSONEscape(P: Pointer; Len: PtrInt=0); overload; - /// append some UTF-8 encoded chars to the buffer, from a generic string type - // - faster than AddJSONEscape(pointer(StringToUTF8(string)) - // - escapes chars according to the JSON RFC - procedure AddJSONEscapeString(const s: string); {$ifdef HASINLINE}inline;{$endif} - /// append some UTF-8 encoded chars to the buffer, from the main AnsiString type - // - escapes chars according to the JSON RFC - procedure AddJSONEscapeAnsiString(const s: AnsiString); - /// append some UTF-8 encoded chars to the buffer, from a generic string type - // - faster than AddNoJSONEscape(pointer(StringToUTF8(string)) - // - don't escapes chars according to the JSON RFC - // - will convert the Unicode chars into UTF-8 - procedure AddNoJSONEscapeString(const s: string); {$ifdef UNICODE}inline;{$endif} - /// append some Unicode encoded chars to the buffer - // - if Len is 0, Len is calculated from zero-ended widechar - // - escapes chars according to the JSON RFC - procedure AddJSONEscapeW(P: PWord; Len: PtrInt=0); - /// append an open array constant value to the buffer - // - "" will be added if necessary - // - escapes chars according to the JSON RFC - // - very fast (avoid most temporary storage) - procedure AddJSONEscape(const V: TVarRec); overload; - /// flush a supplied TTextWriter, and write pending data as JSON escaped text - // - may be used with InternalJSONWriter, as a faster alternative to - // ! AddJSONEscape(Pointer(fInternalJSONWriter.Text),0); - procedure AddJSONEscape(Source: TTextWriter); overload; - /// append a UTF-8 JSON String, between double quotes and with JSON escaping - procedure AddJSONString(const Text: RawUTF8); - /// append an open array constant value to the buffer - // - "" won't be added for string values - // - string values may be escaped, depending on the supplied parameter - // - very fast (avoid most temporary storage) - procedure Add(const V: TVarRec; Escape: TTextWriterKind=twNone; - WriteObjectOptions: TTextWriterWriteObjectOptions=[woFullExpand]); overload; - /// encode the supplied data as an UTF-8 valid JSON object content - // - data must be supplied two by two, as Name,Value pairs, e.g. - // ! aWriter.AddJSONEscape(['name','John','year',1972]); - // will append to the buffer: - // ! '{"name":"John","year":1972}' - // - or you can specify nested arrays or objects with '['..']' or '{'..'}': - // ! aWriter.AddJSONEscape(['doc','{','name','John','ab','[','a','b']','}','id',123]); - // will append to the buffer: - // ! '{"doc":{"name":"John","abc":["a","b"]},"id":123}' - // - note that, due to a Delphi compiler limitation, cardinal values should be - // type-casted to Int64() (otherwise the integer mapped value will be converted) - // - you can pass nil as parameter for a null JSON value - procedure AddJSONEscape(const NameValuePairs: array of const); overload; - {$ifndef NOVARIANTS} - /// encode the supplied (extended) JSON content, with parameters, - // as an UTF-8 valid JSON object content - // - in addition to the JSON RFC specification strict mode, this method will - // handle some BSON-like extensions, e.g. unquoted field names: - // ! aWriter.AddJSON('{id:?,%:{name:?,birthyear:?}}',['doc'],[10,'John',1982]); - // - you can use nested _Obj() / _Arr() instances - // ! aWriter.AddJSON('{%:{$in:[?,?]}}',['type'],['food','snack']); - // ! aWriter.AddJSON('{type:{$in:?}}',[],[_Arr(['food','snack'])]); - // ! // which are the same as: - // ! aWriter.AddShort('{"type":{"$in":["food","snack"]}}'); - // - if the SynMongoDB unit is used in the application, the MongoDB Shell - // syntax will also be recognized to create TBSONVariant, like - // ! new Date() ObjectId() MinKey MaxKey // - // see @http://docs.mongodb.org/manual/reference/mongodb-extended-json - // ! aWriter.AddJSON('{name:?,field:/%/i}',['acme.*corp'],['John'])) - // ! // will write - // ! '{"name":"John","field":{"$regex":"acme.*corp","$options":"i"}}' - // - will call internally _JSONFastFmt() to create a temporary TDocVariant - // with all its features - so is slightly slower than other AddJSON* methods - procedure AddJSON(const Format: RawUTF8; const Args,Params: array of const); - {$endif} - /// append two JSON arrays of keys and values as one JSON object - // - i.e. makes the following transformation: - // $ [key1,key2...] + [value1,value2...] -> {key1:value1,key2,value2...} - // - this method won't allocate any memory during its process, nor - // modify the keys and values input buffers - // - is the reverse of the JSONObjectAsJSONArrays() function - procedure AddJSONArraysAsJSONObject(keys,values: PUTF8Char); - /// append a dynamic array content as UTF-8 encoded JSON array - // - expect a dynamic array TDynArray wrapper as incoming parameter - // - TIntegerDynArray, TInt64DynArray, TCardinalDynArray, TDoubleDynArray, - // TCurrencyDynArray, TWordDynArray and TByteDynArray will be written as - // numerical JSON values - // - TRawUTF8DynArray, TWinAnsiDynArray, TRawByteStringDynArray, - // TStringDynArray, TWideStringDynArray, TSynUnicodeDynArray, TTimeLogDynArray, - // and TDateTimeDynArray will be written as escaped UTF-8 JSON strings - // (and Iso-8601 textual encoding if necessary) - // - you can add some custom serializers via RegisterCustomJSONSerializer() - // class method, to serialize any dynamic array as valid JSON - // - any other non-standard or non-registered kind of dynamic array (including - // array of records) will be written as Base64 encoded binary stream, with a - // JSON_BASE64_MAGIC prefix (UTF-8 encoded \uFFF0 special code) - this will - // include TBytes (i.e. array of bytes) content, which is a good candidate - // for BLOB stream - // - typical content could be - // ! '[1,2,3,4]' or '["\uFFF0base64encodedbinary"]' - // - by default, custom serializers defined via RegisterCustomJSONSerializer() - // would write enumerates and sets as integer numbers, unless - // twoEnumSetsAsTextInRecord is set in the instance Options - procedure AddDynArrayJSON(var aDynArray: TDynArray); overload; - /// append a dynamic array content as UTF-8 encoded JSON array - // - expect a dynamic array TDynArrayHashed wrapper as incoming parameter - procedure AddDynArrayJSON(var aDynArray: TDynArrayHashed); overload; - {$ifdef HASINLINE}inline;{$endif} - /// append a dynamic array content as UTF-8 encoded JSON array - // - just a wrapper around the other overloaded method, creating a - // temporary TDynArray wrapper on the stack - // - to be used e.g. for custom record JSON serialization, within a - // TDynArrayJSONCustomWriter callback - procedure AddDynArrayJSON(aTypeInfo: pointer; const aValue); overload; - /// same as AddDynArrayJSON(), but will double all internal " and bound with " - // - this implementation will avoid most memory allocations - procedure AddDynArrayJSONAsString(aTypeInfo: pointer; var aValue); - /// append a T*ObjArray dynamic array as a JSON array - // - as expected by TJSONSerializer.RegisterObjArrayForJSON() - procedure AddObjArrayJSON(const aObjArray; - aOptions: TTextWriterWriteObjectOptions=[woDontStoreDefault]); - /// append a record content as UTF-8 encoded JSON or custom serialization - // - default serialization will use Base64 encoded binary stream, or - // a custom serialization, in case of a previous registration via - // RegisterCustomJSONSerializer() class method - from a dynamic array - // handling this kind of records, or directly from TypeInfo() of the record - // - by default, custom serializers defined via RegisterCustomJSONSerializer() - // would write enumerates and sets as integer numbers, unless - // twoEnumSetsAsTextInRecord or twoEnumSetsAsBooleanInRecord is set in - // the instance CustomOptions - procedure AddRecordJSON(const Rec; TypeInfo: pointer); - {$ifndef NOVARIANTS} - /// append a variant content as number or string - // - default Escape=twJSONEscape will create valid JSON content, which - // can be converted back to a variant value using VariantLoadJSON() - // - default JSON serialization options would apply, unless - // twoForceJSONExtended or twoForceJSONStandard is defined - // - note that before Delphi 2009, any varString value is expected to be - // a RawUTF8 instance - which does make sense in the mORMot context - procedure AddVariant(const Value: variant; Escape: TTextWriterKind=twJSONEscape); - {$endif} - /// append a void record content as UTF-8 encoded JSON or custom serialization - // - this method will first create a void record (i.e. filled with #0 bytes) - // then save its content with default or custom serialization - procedure AddVoidRecordJSON(TypeInfo: pointer); - /// append a JSON value from its RTTI type - // - handle tkClass,tkEnumeration,tkSet,tkRecord,tkDynArray,tkVariant types - // - write null for other types - procedure AddTypedJSON(aTypeInfo: pointer; const aValue); - /// serialize as JSON the given object - // - this default implementation will write null, or only write the - // class name and pointer if FullExpand is true - use - // TJSONSerializer.WriteObject method for full RTTI handling - // - default implementation will write TList/TCollection/TStrings/TRawUTF8List - // as appropriate array of class name/pointer (if woFullExpand is set) - procedure WriteObject(Value: TObject; - Options: TTextWriterWriteObjectOptions=[woDontStoreDefault]); virtual; - /// same as WriteObject(), but will double all internal " and bound with " - // - this implementation will avoid most memory allocations - procedure WriteObjectAsString(Value: TObject; - Options: TTextWriterWriteObjectOptions=[woDontStoreDefault]); - /// append a JSON value, array or document as simple XML content - // - you can use JSONBufferToXML() and JSONToXML() functions as wrappers - // - this method is called recursively to handle all kind of JSON values - // - WARNING: the JSON buffer is decoded in-place, so will be changed - // - returns the end of the current JSON converted level, or nil if the - // supplied content was not correct JSON - function AddJSONToXML(JSON: PUTF8Char; ArrayName: PUTF8Char=nil; - EndOfObject: PUTF8Char=nil): PUTF8Char; - /// append a JSON value, array or document, in a specified format - // - will parse the JSON buffer and write its content with proper line - // feeds and indentation, according to the supplied TTextWriterJSONFormat - // - see also JSONReformat() and JSONBufferReformat() wrappers - // - this method is called recursively to handle all kind of JSON values - // - WARNING: the JSON buffer is decoded in-place, so will be changed - // - returns the end of the current JSON converted level, or nil if the - // supplied content was not valid JSON - function AddJSONReformat(JSON: PUTF8Char; Format: TTextWriterJSONFormat; - EndOfObject: PUTF8Char): PUTF8Char; - - /// define a custom serialization for a given dynamic array or record - // - expects TypeInfo() from a dynamic array or a record (will raise an - // exception otherwise) - // - for a dynamic array, the associated item record RTTI will be registered - // - for a record, any matching dynamic array will also be registered - // - by default, TIntegerDynArray and such known classes are processed as - // true JSON arrays: but you can specify here some callbacks to perform - // the serialization process for any kind of dynamic array - // - any previous registration is overridden - // - setting both aReader=aWriter=nil will return back to the default - // binary + Base64 encoding serialization (i.e. undefine custom serializer) - class procedure RegisterCustomJSONSerializer(aTypeInfo: pointer; - aReader: TDynArrayJSONCustomReader; aWriter: TDynArrayJSONCustomWriter); - {$ifndef NOVARIANTS} - /// define a custom serialization for a given variant custom type - // - used e.g. to serialize TBCD values - class procedure RegisterCustomJSONSerializerForVariant(aClass: TCustomVariantType; - aReader: TDynArrayJSONCustomReader; aWriter: TDynArrayJSONCustomWriter); - /// define a custom serialization for a given variant custom type - // - used e.g. to serialize TBCD values - class procedure RegisterCustomJSONSerializerForVariantByType(aVarType: TVarType; - aReader: TDynArrayJSONCustomReader; aWriter: TDynArrayJSONCustomWriter); - {$endif NOVARIANTS} - /// define a custom serialization for a given dynamic array or record - // - the RTTI information will here be defined as plain text - // - since Delphi 2010, you can call directly - // RegisterCustomJSONSerializerFromTextSimpleType() - // - aTypeInfo may be valid TypeInfo(), or any fixed pointer value if the - // record does not have any RTTI (e.g. a record without any nested reference- - // counted types) - // - the record where the data will be stored should be defined as PACKED: - // ! type TMyRecord = packed record - // ! A,B,C: integer; - // ! D: RawUTF8; - // ! E: record; // or array of record/integer/string/... - // ! E1,E2: double; - // ! end; - // ! end; - // - call this method with aRTTIDefinition='' to return back to the default - // binary + Base64 encoding serialization (i.e. undefine custom serializer) - // - only known sub types are byte, word, integer, cardinal, Int64, single, - // double, currency, TDateTime, TTimeLog, RawUTF8, String, WideString, - // SynUnicode, TGUID (encoded via GUIDToText) or a nested record or dynamic - // array of the same simple types or record - // - RTTI textual information shall be supplied as text, with the - // same format as with a pascal record: - // ! 'A,B,C: integer; D: RawUTF8; E: record E1,E2: double;' - // ! 'A,B,C: integer; D: RawUTF8; E: array of record E1,E2: double;' - // ! 'A,B,C: integer; D: RawUTF8; E: array of SynUnicode; F: array of TGUID' - // or a shorter alternative syntax for records and arrays: - // ! 'A,B,C: integer; D: RawUTF8; E: {E1,E2: double}' - // ! 'A,B,C: integer; D: RawUTF8; E: [E1,E2: double]' - // in fact ; could be ignored: - // ! 'A,B,C:integer D:RawUTF8 E:{E1,E2:double}' - // ! 'A,B,C:integer D:RawUTF8 E:[E1,E2:double]' - // or even : could be ignored: - // ! 'A,B,C integer D RawUTF8 E{E1,E2 double}' - // ! 'A,B,C integer D RawUTF8 E[E1,E2 double]' - // - it will return the cached TJSONRecordTextDefinition - // instance corresponding to the supplied RTTI text definition - class function RegisterCustomJSONSerializerFromText(aTypeInfo: pointer; - const aRTTIDefinition: RawUTF8): TJSONRecordAbstract; overload; - /// define a custom serialization for several dynamic arrays or records - // - the TypeInfo() and textual RTTI information will here be defined as - // ([TypeInfo(TType1),_TType1,TypeInfo(TType2),_TType2]) pairs - // - a wrapper around the overloaded RegisterCustomJSONSerializerFromText() - class procedure RegisterCustomJSONSerializerFromText( - const aTypeInfoTextDefinitionPairs: array of const); overload; - /// change options for custom serialization of dynamic array or record - // - will return TRUE if the options have been changed, FALSE if the - // supplied type info was not previously registered - // - if AddIfNotExisting is TRUE, and enhanced RTTI is available (since - // Delphi 2010), you would be able to customize the options of this type - class function RegisterCustomJSONSerializerSetOptions(aTypeInfo: pointer; - aOptions: TJSONCustomParserSerializationOptions; - aAddIfNotExisting: boolean=false): boolean; overload; - /// change options for custom serialization of dynamic arrays or records - // - will return TRUE if the options have been changed, FALSE if the - // supplied type info was not previously registered for at least one type - // - if AddIfNotExisting is TRUE, and enhanced RTTI is available (since - // Delphi 2010), you would be able to customize the options of this type - class function RegisterCustomJSONSerializerSetOptions( - const aTypeInfo: array of pointer; aOptions: TJSONCustomParserSerializationOptions; - aAddIfNotExisting: boolean=false): boolean; overload; - /// retrieve a previously registered custom parser instance from its type - // - will return nil if the type info was not available, or defined just - // with some callbacks - // - if AddIfNotExisting is TRUE, and enhanced RTTI is available (since - // Delphi 2010), you would be able to retrieve this type's parser even - // if the record type has not been previously used - class function RegisterCustomJSONSerializerFindParser( - aTypeInfo: pointer; aAddIfNotExisting: boolean=false): TJSONRecordAbstract; - /// define a custom serialization for a given simple type - // - you should be able to use this type in the RTTI text definition - // of any further RegisterCustomJSONSerializerFromText() call - // - the RTTI information should be enough to serialize the type from - // its name (e.g. an enumeration for older Delphi revision, but all records - // since Delphi 2010) - // - you can supply a custom type name, which will be registered in addition - // to the "official" name defined at RTTI level - // - on older Delphi versions (up to Delphi 2009), it will handle only - // enumerations, which will be transmitted as JSON string instead of numbers - // - since Delphi 2010, any record type can be supplied - which is more - // convenient than calling RegisterCustomJSONSerializerFromText() - class procedure RegisterCustomJSONSerializerFromTextSimpleType(aTypeInfo: pointer; - const aTypeName: RawUTF8=''); overload; - /// define a custom binary serialization for a given simple type - // - you should be able to use this type in the RTTI text definition - // of any further RegisterCustomJSONSerializerFromText() call - // - data will be serialized as BinToHexDisplayLower() JSON hexadecimal string - // - you can truncate the original data size (e.g. if all bits of an integer - // are not used) by specifying the aFieldSize optional parameter - class procedure RegisterCustomJSONSerializerFromTextBinaryType(aTypeInfo: pointer; - aDataSize: integer; aFieldSize: integer=0); overload; - /// define custom binary serialization for several simple types - // - data will be serialized as BinToHexDisplayLower() JSON hexadecimal string - // - the TypeInfo() and associated size information will here be defined as triplets: - // ([TypeInfo(TType1),SizeOf(TType1),TYPE1_BYTES,TypeInfo(TType2),SizeOf(TType2),TYPE2_BYTES]) - // - a wrapper around the overloaded RegisterCustomJSONSerializerFromTextBinaryType() - class procedure RegisterCustomJSONSerializerFromTextBinaryType( - const aTypeInfoDataFieldSize: array of const); overload; - /// define a custom serialization for several simple types - // - will call the overloaded RegisterCustomJSONSerializerFromTextSimpleType - // method for each supplied type information - class procedure RegisterCustomJSONSerializerFromTextSimpleType( - const aTypeInfos: array of pointer); overload; - /// undefine a custom serialization for a given dynamic array or record - // - it will un-register any callback or text-based custom serialization - // i.e. any previous RegisterCustomJSONSerializer() or - // RegisterCustomJSONSerializerFromText() call - // - expects TypeInfo() from a dynamic array or a record (will raise an - // exception otherwise) - // - it will set back to the default binary + Base64 encoding serialization - class procedure UnRegisterCustomJSONSerializer(aTypeInfo: pointer); - /// retrieve low-level custom serialization callbaks for a dynamic array - // - returns TRUE if this array has a custom JSON parser, and set the - // corresponding serialization/unserialization callbacks - class function GetCustomJSONParser(var DynArray: TDynArray; - out CustomReader: TDynArrayJSONCustomReader; - out CustomWriter: TDynArrayJSONCustomWriter): boolean; - - /// append some chars to the buffer in one line - // - P should be ended with a #0 - // - will write #1..#31 chars as spaces (so content will stay on the same line) - procedure AddOnSameLine(P: PUTF8Char); overload; - /// append some chars to the buffer in one line - // - will write #0..#31 chars as spaces (so content will stay on the same line) - procedure AddOnSameLine(P: PUTF8Char; Len: PtrInt); overload; - /// append some wide chars to the buffer in one line - // - will write #0..#31 chars as spaces (so content will stay on the same line) - procedure AddOnSameLineW(P: PWord; Len: PtrInt); - - /// return the last char appended - // - returns #0 if no char has been written yet - function LastChar: AnsiChar; - /// how many bytes are currently in the internal buffer and not on disk - // - see TextLength for the total number of bytes, on both disk and memory - function PendingBytes: PtrUInt; - {$ifdef HASINLINE}inline;{$endif} - /// how many bytes were currently written on disk - // - excluding the bytes in the internal buffer - // - see TextLength for the total number of bytes, on both disk and memory - property WrittenBytes: PtrUInt read fTotalFileSize; - /// low-level access to the current indentation level - property HumanReadableLevel: integer read fHumanReadableLevel write fHumanReadableLevel; - /// the last char appended is canceled - // - only one char cancelation is allowed at the same position: don't call - // CancelLastChar/CancelLastComma more than once without appending text inbetween - procedure CancelLastChar; overload; {$ifdef HASINLINE}inline;{$endif} - /// the last char appended is canceled, if match the supplied one - // - only one char cancelation is allowed at the same position: don't call - // CancelLastChar/CancelLastComma more than once without appending text inbetween - procedure CancelLastChar(aCharToCancel: AnsiChar); overload; {$ifdef HASINLINE}inline;{$endif} - /// the last char appended is canceled if it was a ',' - // - only one char cancelation is allowed at the same position: don't call - // CancelLastChar/CancelLastComma more than once without appending text inbetween - procedure CancelLastComma; {$ifdef HASINLINE}inline;{$endif} - /// rewind the Stream to the position when Create() was called - // - note that this does not clear the Stream content itself, just - // move back its writing position to its initial place - procedure CancelAll; - - /// count of added bytes to the stream - // - see PendingBytes for the number of bytes currently in the memory buffer - // or WrittenBytes for the number of bytes already written to disk - property TextLength: PtrUInt read GetTextLength; - /// optional event called before FlushToStream method process - property OnFlushToStream: TOnTextWriterFlush read fOnFlushToStream write fOnFlushToStream; - /// allows to override default WriteObject property JSON serialization - property OnWriteObject: TOnTextWriterObjectProp read fOnWriteObject write fOnWriteObject; - /// the internal TStream used for storage - // - you should call the FlushFinal (or FlushToStream) methods before using - // this TStream content, to flush all pending characters - // - if the TStream instance has not been specified when calling the - // TTextWriter constructor, it can be forced via this property, before - // any writting - property Stream: TStream read fStream write SetStream; - /// global options to customize this TTextWriter instance process - // - allows to override e.g. AddRecordJSON() and AddDynArrayJSON() behavior - property CustomOptions: TTextWriterOptions read fCustomOptions write fCustomOptions; - end; - - /// class of our simple TEXT format writer to a Stream, with echoing - // - as used by TSynLog for writing its content - // - see TTextWriterWithEcho.SetAsDefaultJSONClass - TTextWriterClass = class of TTextWriterWithEcho; - - /// Stream TEXT writer, with optional echoing of the lines - // - as used e.g. by TSynLog writer for log optional redirection - // - is defined as a sub-class to reduce plain TTextWriter scope - // - see SynTable.pas for SQL resultset export via TJSONWriter - // - see mORMot.pas for proper class serialization via TJSONSerializer.WriteObject - TTextWriterWithEcho = class(TTextWriter) - protected - fEchoStart: PtrInt; - fEchoBuf: RawUTF8; - fEchos: array of TOnTextWriterEcho; - function EchoFlush: PtrInt; - function GetEndOfLineCRLF: boolean; {$ifdef HASINLINE}inline;{$endif} - procedure SetEndOfLineCRLF(aEndOfLineCRLF: boolean); - public - /// write pending data to the Stream, with automatic buffer resizal and echoing - // - this overriden method will handle proper echoing - procedure FlushToStream; override; - /// mark an end of line, ready to be "echoed" to registered listeners - // - append a LF (#10) char or CR+LF (#13#10) chars to the buffer, depending - // on the EndOfLineCRLF property value (default is LF, to minimize storage) - // - any callback registered via EchoAdd() will monitor this line - // - used e.g. by TSynLog for console output, as stated by Level parameter - procedure AddEndOfLine(aLevel: TSynLogInfo=sllNone); - /// add a callback to echo each line written by this class - // - this class expects AddEndOfLine to mark the end of each line - procedure EchoAdd(const aEcho: TOnTextWriterEcho); - /// remove a callback to echo each line written by this class - // - event should have been previously registered by a EchoAdd() call - procedure EchoRemove(const aEcho: TOnTextWriterEcho); - /// reset the internal buffer used for echoing content - procedure EchoReset; - /// define how AddEndOfLine method stores its line feed characters - // - by default (FALSE), it will append a LF (#10) char to the buffer - // - you can set this property to TRUE, so that CR+LF (#13#10) chars will - // be appended instead - // - is just a wrapper around twoEndOfLineCRLF item in CustomOptions - property EndOfLineCRLF: boolean read GetEndOfLineCRLF write SetEndOfLineCRLF; - end; - -var - /// contains the default JSON serialization class for WriteObject - // - if only SynCommons.pas is used, it will be TTextWriterWithEcho - // - mORMot.pas will assign TJSONSerializer which uses RTTI to serialize - // TSQLRecord and any class published properties as JSON - DefaultTextWriterSerializer: TTextWriterClass = TTextWriterWithEcho; - -/// recognize a simple type from a supplied type information -// - first try by name via TJSONCustomParserRTTI.TypeNameToSimpleRTTIType, -// then from RTTI via TJSONCustomParserRTTI.TypeInfoToSimpleRTTIType -// - will return ptCustom for any unknown type -function TypeInfoToRttiType(aTypeInfo: pointer): TJSONCustomParserRTTIType; - -/// serialize most kind of content as JSON, using its RTTI -// - is just a wrapper around TTextWriter.AddTypedJSON() -// - so would handle tkClass, tkEnumeration, tkSet, tkRecord, tkDynArray, -// tkVariant kind of content - other kinds would return 'null' -// - you can override serialization options if needed -procedure SaveJSON(const Value; TypeInfo: pointer; - Options: TTextWriterOptions; var result: RawUTF8); overload; - -/// serialize most kind of content as JSON, using its RTTI -// - is just a wrapper around TTextWriter.AddTypedJSON() -// - so would handle tkClass, tkEnumeration, tkSet, tkRecord, tkDynArray, -// tkVariant kind of content - other kinds would return 'null' -function SaveJSON(const Value; TypeInfo: pointer; - EnumSetsAsText: boolean=false): RawUTF8; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// will serialize any TObject into its UTF-8 JSON representation -/// - serialize as JSON the published integer, Int64, floating point values, -// TDateTime (stored as ISO 8601 text), string, variant and enumerate -// (e.g. boolean) properties of the object (and its parents) -// - would set twoForceJSONStandard to force standard (non-extended) JSON -// - the enumerates properties are stored with their integer index value -// - will write also the properties published in the parent classes -// - nested properties are serialized as nested JSON objects -// - any TCollection property will also be serialized as JSON arrays -// - you can add some custom serializers for ANY Delphi class, via mORMot.pas' -// TJSONSerializer.RegisterCustomSerializer() class method -// - call internaly TJSONSerializer.WriteObject() method (or fallback to -// TJSONWriter if mORMot.pas is not linked to the executable) -function ObjectToJSON(Value: TObject; - Options: TTextWriterWriteObjectOptions=[woDontStoreDefault]): RawUTF8; - -/// will serialize set of TObject into its UTF-8 JSON representation -// - follows ObjectToJSON()/TTextWriter.WriterObject() functions output -// - if Names is not supplied, the corresponding class names would be used -function ObjectsToJSON(const Names: array of RawUTF8; const Values: array of TObject; - Options: TTextWriterWriteObjectOptions=[woDontStoreDefault]): RawUTF8; - - -type - /// abstract ancestor to manage a dynamic array of TObject - // - do not use this abstract class directly, but rather the inherited - // TObjectListHashed and TObjectListPropertyHashed - TObjectListHashedAbstract = class - protected - fList: TObjectDynArray; - fCount: integer; - fHash: TDynArrayHashed; - public - /// initialize the class instance - // - if aFreeItems is TRUE (default), will behave like a TObjectList - // - if aFreeItems is FALSE, will behave like a TList - constructor Create(aFreeItems: boolean=true); reintroduce; - /// release used memory - destructor Destroy; override; - /// search and add an object reference to the list - // - returns the found/added index - function Add(aObject: TObject; out wasAdded: boolean): integer; virtual; abstract; - /// retrieve an object index within the list, using a fast hash table - // - returns -1 if not found - function IndexOf(aObject: TObject): integer; virtual; abstract; - /// delete an object from the list - // - the internal hash table is not recreated, just invalidated - // (i.e. this method calls HashInvalidate not FindHashedAndDelete) - // - will invalide the whole hash table - procedure Delete(aIndex: integer); overload; - /// delete an object from the list - // - will invalide the whole hash table - procedure Delete(aObject: TObject); overload; virtual; - /// direct access to the items list array - property List: TObjectDynArray read fList; - /// returns the count of stored objects - property Count: integer read fCount; - /// direct access to the underlying hashing engine - property Hash: TDynArrayHashed read fHash; - end; - - /// this class behaves like TList/TObjectList, but will use hashing - // for (much) faster IndexOf() method - TObjectListHashed = class(TObjectListHashedAbstract) - public - /// search and add an object reference to the list - // - returns the found/added index - // - if added, hash is stored and Items[] := aObject - function Add(aObject: TObject; out wasAdded: boolean): integer; override; - /// retrieve an object index within the list, using a fast hash table - // - returns -1 if not found - function IndexOf(aObject: TObject): integer; override; - /// delete an object from the list - // - overriden method won't invalidate the whole hash table, but refresh it - procedure Delete(aObject: TObject); override; - end; - - /// function prototype used to retrieve a pointer to the hashed property - // value of a TObjectListPropertyHashed list - TObjectListPropertyHashedAccessProp = function(aObject: TObject): pointer; - - /// this class will hash and search for a sub property of the stored objects - TObjectListPropertyHashed = class(TObjectListHashedAbstract) - protected - fSubPropAccess: TObjectListPropertyHashedAccessProp; - function IntHash(const Elem): cardinal; - function IntComp(const A,B): integer; - public - /// initialize the class instance with the corresponding callback in order - // to handle sub-property hashing and search - // - see TSetWeakZeroClass in mORMot.pas unit as example: - // ! function WeakZeroClassSubProp(aObject: TObject): TObject; - // ! begin - // ! result := TSetWeakZeroInstance(aObject).fInstance; - // ! end; - // - by default, aHashElement/aCompare will hash/search for pointers: - // you can specify the hash/search methods according to your sub property - // (e.g. HashAnsiStringI/SortDynArrayAnsiStringI for a RawUTF8) - // - if aFreeItems is TRUE (default), will behave like a TObjectList; - // if aFreeItems is FALSE, will behave like a TList - constructor Create(aSubPropAccess: TObjectListPropertyHashedAccessProp; - aHashElement: TDynArrayHashOne=nil; aCompare: TDynArraySortCompare=nil; - aFreeItems: boolean=true); reintroduce; - /// search and add an object reference to the list - // - returns the found/added index - // - if added, only the hash is stored: caller has to set List[i] - function Add(aObject: TObject; out wasAdded: boolean): integer; override; - /// retrieve an object index within the list, using a fast hash table - // - returns -1 if not found - function IndexOf(aObject: TObject): integer; override; - end; - - /// abstract class stored by a TPointerClassHash list - TPointerClassHashed = class - protected - fInfo: pointer; - public - /// initialize the instance - constructor Create(aInfo: pointer); - /// the associated information of this instance - // - may be e.g. a PTypeInfo value, when caching RTTI information - property Info: pointer read fInfo write fInfo; - end; - /// a reference to a TPointerClassHashed instance - PPointerClassHashed = ^TPointerClassHashed; - - /// handle a O(1) hashed-based storage of TPointerClassHashed, from a pointer - // - used e.g. to store RTTI information from its PTypeInfo value - // - if not thread safe, but could be used to store RTTI, since all type - // information should have been initialized before actual process - TPointerClassHash = class(TObjectListPropertyHashed) - public - /// initialize the storage list - constructor Create; - /// try to add an entry to the storage - // - returns nil if the supplied information is already in the list - // - returns a pointer to where a newly created TPointerClassHashed - // instance should be stored - // - this method is not thread-safe - function TryAdd(aInfo: pointer): PPointerClassHashed; - /// search for a stored instance, from its supplied pointer reference - // - returns nil if aInfo was not previously added by FindOrAdd() - // - this method is not thread-safe - function Find(aInfo: pointer): TPointerClassHashed; - end; - - /// handle a O(1) hashed-based storage of TPointerClassHashed, from a pointer - // - this inherited class add a mutex to be thread-safe - TPointerClassHashLocked = class(TPointerClassHash) - protected - fSafe: TSynLocker; - public - /// initialize the storage list - constructor Create; - /// finalize the storage list - destructor Destroy; override; - /// try to add an entry to the storage - // - returns false if the supplied information is already in the list - // - returns true, and a pointer to where a newly created TPointerClassHashed - // instance should be stored: in this case, you should call UnLock once set - // - could be used as such: - // !var entry: PPointerClassHashed; - // !... - // ! if HashList.TryAddLocked(aTypeInfo,entry) then - // ! try - // ! entry^ := TMyCustomPointerClassHashed.Create(aTypeInfo,...); - // ! finally - // ! HashList.Unlock; - // ! end; - // !... - function TryAddLocked(aInfo: pointer; out aNewEntry: PPointerClassHashed): boolean; - /// release the lock after a previous TryAddLocked()=true call - procedure Unlock; - /// search for a stored instance, from its supplied pointer reference - // - returns nil if aInfo was not previously added by FindOrAdd() - // - this overriden method is thread-safe, unless returned TPointerClassHashed - // instance is deleted in-between - function FindLocked(aInfo: pointer): TPointerClassHashed; - end; - - /// add locking methods to a TSynObjectList - // - this class overrides the regular TSynObjectList, and do not share any - // code with the TObjectListHashedAbstract/TObjectListHashed classes - // - you need to call the Safe.Lock/Unlock methods by hand to protect the - // execution of index-oriented methods (like Delete/Items/Count...): the - // list content may change in the background, so using indexes is thread-safe - // - on the other hand, Add/Clear/ClearFromLast/Remove stateless methods have - // been overriden in this class to call Safe.Lock/Unlock, and therefore are - // thread-safe and protected to any background change - TSynObjectListLocked = class(TSynObjectList) - protected - fSafe: TSynLocker; - public - /// initialize the list instance - // - the stored TObject instances will be owned by this TSynObjectListLocked, - // unless AOwnsObjects is set to false - constructor Create(aOwnsObjects: boolean=true); reintroduce; - /// release the list instance (including the locking resource) - destructor Destroy; override; - /// add one item to the list using the global critical section - function Add(item: pointer): integer; override; - /// delete all items of the list using the global critical section - procedure Clear; override; - /// delete all items of the list in reverse order, using the global critical section - procedure ClearFromLast; override; - /// fast delete one item in the list - function Remove(item: pointer): integer; override; - /// check an item using the global critical section - function Exists(item: pointer): boolean; override; - /// the critical section associated to this list instance - // - could be used to protect shared resources within the internal process, - // for index-oriented methods like Delete/Items/Count... - // - use Safe.Lock/TryLock with a try ... finally Safe.Unlock block - property Safe: TSynLocker read fSafe; - end; - - /// deprecated class name, for backward compatibility only - TObjectListLocked = TSynObjectListLocked; - - /// possible values used by TRawUTF8List.Flags - TRawUTF8ListFlags = set of ( - fObjectsOwned, fCaseSensitive, fNoDuplicate, fOnChangeTrigerred); - - /// TStringList-class optimized to work with our native UTF-8 string type - // - can optionally store associated some TObject instances - // - high-level methods of this class are thread-safe - // - if fNoDuplicate flag is defined, an internal hash table will be - // maintained to perform IndexOf() lookups in O(1) linear way - TRawUTF8List = class - protected - fCount: PtrInt; - fValue: TRawUTF8DynArray; - fValues: TDynArrayHashed; - fObjects: TObjectDynArray; - fFlags: TRawUTF8ListFlags; - fNameValueSep: AnsiChar; - fOnChange, fOnChangeBackupForBeginUpdate: TNotifyEvent; - fOnChangeLevel: integer; - fSafe: TSynLocker; - function GetCount: PtrInt; {$ifdef HASINLINE}inline;{$endif} - procedure SetCapacity(const capa: PtrInt); - function GetCapacity: PtrInt; - function Get(Index: PtrInt): RawUTF8; {$ifdef HASINLINE}inline;{$endif} - procedure Put(Index: PtrInt; const Value: RawUTF8); - function GetObject(Index: PtrInt): pointer; {$ifdef HASINLINE}inline;{$endif} - procedure PutObject(Index: PtrInt; Value: pointer); - function GetName(Index: PtrInt): RawUTF8; - function GetValue(const Name: RawUTF8): RawUTF8; - procedure SetValue(const Name, Value: RawUTF8); - function GetTextCRLF: RawUTF8; - procedure SetTextCRLF(const Value: RawUTF8); - procedure SetTextPtr(P,PEnd: PUTF8Char; const Delimiter: RawUTF8); - function GetTextPtr: PPUtf8CharArray; {$ifdef HASINLINE}inline;{$endif} - function GetNoDuplicate: boolean; {$ifdef HASINLINE}inline;{$endif} - function GetObjectPtr: PPointerArray; {$ifdef HASINLINE}inline;{$endif} - function GetCaseSensitive: boolean; {$ifdef HASINLINE}inline;{$endif} - procedure SetCaseSensitive(Value: boolean); virtual; - procedure Changed; virtual; - procedure InternalDelete(Index: PtrInt); - procedure OnChangeHidden(Sender: TObject); - public - /// initialize the RawUTF8/Objects storage - // - by default, any associated Objects[] are just weak references; - // you may supply fOwnObjects flag to force object instance management - // - if you want the stored text items to be unique, set fNoDuplicate - // and then an internal hash table will be maintained for fast IndexOf() - // - you can unset fCaseSensitive to let the UTF-8 lookup be case-insensitive - constructor Create(aFlags: TRawUTF8ListFlags=[fCaseSensitive]); overload; - /// backward compatiliby overloaded constructor - // - please rather use the overloaded Create(TRawUTF8ListFlags) - constructor Create(aOwnObjects: boolean; aNoDuplicate: boolean=false; - aCaseSensitive: boolean=true); overload; - /// finalize the internal objects stored - // - if instance was created with fOwnObjects flag - destructor Destroy; override; - /// get a stored Object item by its associated UTF-8 text - // - returns nil and raise no exception if aText doesn't exist - // - thread-safe method, unless returned TObject is deleted in the background - function GetObjectFrom(const aText: RawUTF8): pointer; - /// store a new RawUTF8 item - // - without the fNoDuplicate flag, it will always add the supplied value - // - if fNoDuplicate was set and aText already exists (using the internal - // hash table), it will return -1 unless aRaiseExceptionIfExisting is forced - // - thread-safe method - function Add(const aText: RawUTF8; aRaiseExceptionIfExisting: boolean=false): PtrInt; {$ifdef HASINLINE}inline;{$endif} - /// store a new RawUTF8 item, and its associated TObject - // - without the fNoDuplicate flag, it will always add the supplied value - // - if fNoDuplicate was set and aText already exists (using the internal hash - // table), it will return -1 unless aRaiseExceptionIfExisting is forced; - // optionally freeing the supplied aObject if aFreeAndReturnExistingObject - // is true, in which pointer the existing Objects[] is copied (see - // AddObjectUnique as a convenient wrapper around this behavior) - // - thread-safe method - function AddObject(const aText: RawUTF8; aObject: TObject; - aRaiseExceptionIfExisting: boolean=false; aFreeAndReturnExistingObject: PPointer=nil): PtrInt; - /// try to store a new RawUTF8 item and its associated TObject - // - fNoDuplicate should have been specified in the list flags - // - if aText doesn't exist, will add the values - // - if aText exist, will call aObjectToAddOrFree.Free and set the value - // already stored in Objects[] into aObjectToAddOrFree - allowing dual - // commit thread-safe update of the list, e.g. after a previous unsuccessful - // call to GetObjectFrom(aText) - // - thread-safe method, using an internal Hash Table to speedup IndexOf() - // - in fact, this method is just a wrapper around - // ! AddObject(aText,aObjectToAddOrFree^,false,@aObjectToAddOrFree); - procedure AddObjectUnique(const aText: RawUTF8; aObjectToAddOrFree: PPointer); - {$ifdef HASINLINE}inline;{$endif} - /// append a specified list to the current content - // - thread-safe method - procedure AddRawUTF8List(List: TRawUTF8List); - /// delete a stored RawUTF8 item, and its associated TObject - // - raise no exception in case of out of range supplied index - // - this method is not thread-safe: use Safe.Lock/UnLock if needed - procedure Delete(Index: PtrInt); overload; - /// delete a stored RawUTF8 item, and its associated TObject - // - will search for the value using IndexOf(aText), and returns its index - // - returns -1 if no entry was found and deleted - // - thread-safe method, using the internal Hash Table if fNoDuplicate is set - function Delete(const aText: RawUTF8): PtrInt; overload; - /// delete a stored RawUTF8 item, and its associated TObject, from - // a given Name when stored as 'Name=Value' pairs - // - raise no exception in case of out of range supplied index - // - thread-safe method, but not using the internal Hash Table - // - consider using TSynNameValue if you expect efficient name/value process - function DeleteFromName(const Name: RawUTF8): PtrInt; virtual; - /// find the index of a given Name when stored as 'Name=Value' pairs - // - search on Name is case-insensitive with 'Name=Value' pairs - // - this method is not thread-safe, and won't use the internal Hash Table - // - consider using TSynNameValue if you expect efficient name/value process - function IndexOfName(const Name: RawUTF8): PtrInt; - /// access to the Value of a given 'Name=Value' pair at a given position - // - this method is not thread-safe - // - consider using TSynNameValue if you expect efficient name/value process - function GetValueAt(Index: PtrInt): RawUTF8; - /// retrieve Value from an existing Name=Value, then optinally delete the entry - // - if Name is found, will fill Value with the stored content and return true - // - if Name is not found, Value is not modified, and false is returned - // - thread-safe method, but not using the internal Hash Table - // - consider using TSynNameValue if you expect efficient name/value process - function UpdateValue(const Name: RawUTF8; var Value: RawUTF8; ThenDelete: boolean): boolean; - /// retrieve and delete the first RawUTF8 item in the list - // - could be used as a FIFO, calling Add() as a "push" method - // - thread-safe method - function PopFirst(out aText: RawUTF8; aObject: PObject=nil): boolean; - /// retrieve and delete the last RawUTF8 item in the list - // - could be used as a FILO, calling Add() as a "push" method - // - thread-safe method - function PopLast(out aText: RawUTF8; aObject: PObject=nil): boolean; - /// erase all stored RawUTF8 items - // - and corresponding objects (if aOwnObjects was true at constructor) - // - thread-safe method, also clearing the internal Hash Table - procedure Clear; virtual; - /// find a RawUTF8 item in the stored Strings[] list - // - this search is case sensitive if fCaseSensitive flag was set (which - // is the default) - // - this method is not thread-safe since the internal list may change - // and the returned index may not be accurate any more - // - see also GetObjectFrom() - // - uses the internal Hash Table if fNoDuplicate was set - function IndexOf(const aText: RawUTF8): PtrInt; - /// find a TObject item index in the stored Objects[] list - // - this method is not thread-safe since the internal list may change - // and the returned index may not be accurate any more - // - aObject lookup won't use the internal Hash Table - function IndexOfObject(aObject: TObject): PtrInt; - /// search for any RawUTF8 item containing some text - // - uses PosEx() on the stored lines - // - this method is not thread-safe since the internal list may change - // and the returned index may not be accurate any more - // - by design, aText lookup can't use the internal Hash Table - function Contains(const aText: RawUTF8; aFirstIndex: integer=0): PtrInt; - /// retrieve the all lines, separated by the supplied delimiter - // - this method is thread-safe - function GetText(const Delimiter: RawUTF8=#13#10): RawUTF8; - /// the OnChange event will be raised only when EndUpdate will be called - // - this method will also call Safe.Lock for thread-safety - procedure BeginUpdate; - /// call the OnChange event if changes occured - // - this method will also call Safe.UnLock for thread-safety - procedure EndUpdate; - /// set low-level text and objects from existing arrays - procedure SetFrom(const aText: TRawUTF8DynArray; const aObject: TObjectDynArray); - /// set all lines, separated by the supplied delimiter - // - this method is thread-safe - procedure SetText(const aText: RawUTF8; const Delimiter: RawUTF8=#13#10); - /// set all lines from an UTF-8 text file - // - expect the file is explicitly an UTF-8 file - // - will ignore any trailing UTF-8 BOM in the file content, but will not - // expect one either - // - this method is thread-safe - procedure LoadFromFile(const FileName: TFileName); - /// write all lines into the supplied stream - // - this method is thread-safe - procedure SaveToStream(Dest: TStream; const Delimiter: RawUTF8=#13#10); - /// write all lines into a new file - // - this method is thread-safe - procedure SaveToFile(const FileName: TFileName; const Delimiter: RawUTF8=#13#10); - /// return the count of stored RawUTF8 - // - reading this property is not thread-safe, since size may change - property Count: PtrInt read GetCount; - /// set or retrieve the current memory capacity of the RawUTF8 list - // - reading this property is not thread-safe, since size may change - property Capacity: PtrInt read GetCapacity write SetCapacity; - /// set if IndexOf() shall be case sensitive or not - // - default is TRUE - // - matches fCaseSensitive in Flags - property CaseSensitive: boolean read GetCaseSensitive write SetCaseSensitive; - /// set if the list doesn't allow duplicated UTF-8 text - // - if true, an internal hash table is maintained for faster IndexOf() - // - matches fNoDuplicate in Flags - property NoDuplicate: boolean read GetNoDuplicate; - /// access to the low-level flags of this list - property Flags: TRawUTF8ListFlags read fFlags write fFlags; - /// get or set a RawUTF8 item - // - returns '' and raise no exception in case of out of range supplied index - // - if you want to use it with the VCL, use UTF8ToString() function - // - reading this property is not thread-safe, since content may change - property Strings[Index: PtrInt]: RawUTF8 read Get write Put; default; - /// get or set a Object item - // - returns nil and raise no exception in case of out of range supplied index - // - reading this property is not thread-safe, since content may change - property Objects[Index: PtrInt]: pointer read GetObject write PutObject; - /// retrieve the corresponding Name when stored as 'Name=Value' pairs - // - reading this property is not thread-safe, since content may change - // - consider TSynNameValue if you expect more efficient name/value process - property Names[Index: PtrInt]: RawUTF8 read GetName; - /// access to the corresponding 'Name=Value' pairs - // - search on Name is case-insensitive with 'Name=Value' pairs - // - reading this property is thread-safe, but won't use the hash table - // - consider TSynNameValue if you expect more efficient name/value process - property Values[const Name: RawUTF8]: RawUTF8 read GetValue write SetValue; - /// the char separator between 'Name=Value' pairs - // - equals '=' by default - // - consider TSynNameValue if you expect more efficient name/value process - property NameValueSep: AnsiChar read fNameValueSep write fNameValueSep; - /// set or retrieve all items as text lines - // - lines are separated by #13#10 (CRLF) by default; use GetText and - // SetText methods if you want to use another line delimiter (even a comma) - // - this property is thread-safe - property Text: RawUTF8 read GetTextCRLF write SetTextCRLF; - /// Event triggered when an entry is modified - property OnChange: TNotifyEvent read fOnChange write fOnChange; - /// direct access to the memory of the TRawUTF8DynArray items - // - reading this property is not thread-safe, since content may change - property TextPtr: PPUtf8CharArray read GetTextPtr; - /// direct access to the memory of the TObjectDynArray items - // - reading this property is not thread-safe, since content may change - property ObjectPtr: PPointerArray read GetObjectPtr; - /// direct access to the TRawUTF8DynArray items dynamic array wrapper - // - using this property is not thread-safe, since content may change - property ValuesArray: TDynArrayHashed read fValues; - /// access to the locking methods of this instance - // - use Safe.Lock/TryLock with a try ... finally Safe.Unlock block - property Safe: TSynLocker read fSafe; - end; - - // some declarations used for backward compatibility only - TRawUTF8ListLocked = type TRawUTF8List; - TRawUTF8ListHashed = type TRawUTF8List; - TRawUTF8ListHashedLocked = type TRawUTF8ListHashed; - // deprecated TRawUTF8MethodList should be replaced by a TSynDictionary - - /// define the implemetation used by TAlgoCompress.Decompress() - TAlgoCompressLoad = (aclNormal, aclSafeSlow, aclNoCrcFast); - - /// abstract low-level parent class for generic compression/decompression algorithms - // - will encapsulate the compression algorithm with crc32c hashing - // - all Algo* abstract methods should be overriden by inherited classes - TAlgoCompress = class(TSynPersistent) - public - /// should return a genuine byte identifier - // - 0 is reserved for stored, 1 for TAlgoSynLz, 2/3 for TAlgoDeflate/Fast - // (in mORMot.pas), 4/5/6 for TAlgoLizard/Fast/Huffman (in SynLizard.pas) - function AlgoID: byte; virtual; abstract; - /// computes by default the crc32c() digital signature of the buffer - function AlgoHash(Previous: cardinal; Data: pointer; DataLen: integer): cardinal; virtual; - /// get maximum possible (worse) compressed size for the supplied length - function AlgoCompressDestLen(PlainLen: integer): integer; virtual; abstract; - /// this method will compress the supplied data - function AlgoCompress(Plain: pointer; PlainLen: integer; Comp: pointer): integer; virtual; abstract; - /// this method will return the size of the decompressed data - function AlgoDecompressDestLen(Comp: pointer): integer; virtual; abstract; - /// this method will decompress the supplied data - function AlgoDecompress(Comp: pointer; CompLen: integer; Plain: pointer): integer; virtual; abstract; - /// this method will partially and safely decompress the supplied data - // - expects PartialLen <= result < PartialLenMax, depending on the algorithm - function AlgoDecompressPartial(Comp: pointer; CompLen: integer; - Partial: pointer; PartialLen, PartialLenMax: integer): integer; virtual; abstract; - public - /// will register AlgoID in the global list, for Algo() class methods - // - no need to free this instance, since it will be owned by the global list - // - raise a ESynException if the class or its AlgoID are already registered - // - you should never have to call this constructor, but define a global - // variable holding a reference to a shared instance - constructor Create; override; - /// get maximum possible (worse) compressed size for the supplied length - // - including the crc32c + algo 9 bytes header - function CompressDestLen(PlainLen: integer): integer; - {$ifdef HASINLINE}inline;{$endif} - /// compress a memory buffer with crc32c hashing to a RawByteString - function Compress(const Plain: RawByteString; CompressionSizeTrigger: integer=100; - CheckMagicForCompressed: boolean=false; BufferOffset: integer=0): RawByteString; overload; - {$ifdef HASINLINE}inline;{$endif} - /// compress a memory buffer with crc32c hashing to a RawByteString - function Compress(Plain: PAnsiChar; PlainLen: integer; CompressionSizeTrigger: integer=100; - CheckMagicForCompressed: boolean=false; BufferOffset: integer=0): RawByteString; overload; - /// compress a memory buffer with crc32c hashing - // - supplied Comp buffer should contain at least CompressDestLen(PlainLen) bytes - function Compress(Plain, Comp: PAnsiChar; PlainLen, CompLen: integer; - CompressionSizeTrigger: integer=100; CheckMagicForCompressed: boolean=false): integer; overload; - /// compress a memory buffer with crc32c hashing to a TByteDynArray - function CompressToBytes(const Plain: RawByteString; CompressionSizeTrigger: integer=100; - CheckMagicForCompressed: boolean=false): TByteDynArray; overload; - {$ifdef HASINLINE}inline;{$endif} - /// compress a memory buffer with crc32c hashing to a TByteDynArray - function CompressToBytes(Plain: PAnsiChar; PlainLen: integer; CompressionSizeTrigger: integer=100; - CheckMagicForCompressed: boolean=false): TByteDynArray; overload; - /// uncompress a RawByteString memory buffer with crc32c hashing - function Decompress(const Comp: RawByteString; Load: TAlgoCompressLoad=aclNormal; - BufferOffset: integer=0): RawByteString; overload; - {$ifdef HASINLINE}inline;{$endif} - /// uncompress a RawByteString memory buffer with crc32c hashing - // - returns TRUE on success - function TryDecompress(const Comp: RawByteString; out Dest: RawByteString; - Load: TAlgoCompressLoad=aclNormal): boolean; - /// uncompress a memory buffer with crc32c hashing - procedure Decompress(Comp: PAnsiChar; CompLen: integer; out Result: RawByteString; - Load: TAlgoCompressLoad=aclNormal; BufferOffset: integer=0); overload; - /// uncompress a RawByteString memory buffer with crc32c hashing - function Decompress(const Comp: TByteDynArray): RawByteString; overload; - {$ifdef HASINLINE}inline;{$endif} - /// uncompress a RawByteString memory buffer with crc32c hashing - // - returns nil if crc32 hash failed, i.e. if the supplied Comp is not correct - // - returns a pointer to the uncompressed data and fill PlainLen variable, - // after crc32c hash - // - avoid any memory allocation in case of a stored content - otherwise, would - // uncompress to the tmp variable, and return pointer(tmp) and length(tmp) - function Decompress(const Comp: RawByteString; out PlainLen: integer; - var tmp: RawByteString; Load: TAlgoCompressLoad=aclNormal): pointer; overload; - {$ifdef HASINLINE}inline;{$endif} - /// uncompress a RawByteString memory buffer with crc32c hashing - // - returns nil if crc32 hash failed, i.e. if the supplied Data is not correct - // - returns a pointer to an uncompressed data buffer of PlainLen bytes - // - avoid any memory allocation in case of a stored content - otherwise, would - // uncompress to the tmp variable, and return pointer(tmp) and length(tmp) - function Decompress(Comp: PAnsiChar; CompLen: integer; out PlainLen: integer; - var tmp: RawByteString; Load: TAlgoCompressLoad=aclNormal): pointer; overload; - /// decode the header of a memory buffer compressed via the Compress() method - // - validates the crc32c of the compressed data (unless Load=aclNoCrcFast), - // then return the uncompressed size in bytes, or 0 if the crc32c does not match - // - should call DecompressBody() later on to actually retrieve the content - function DecompressHeader(Comp: PAnsiChar; CompLen: integer; - Load: TAlgoCompressLoad=aclNormal): integer; - /// decode the content of a memory buffer compressed via the Compress() method - // - PlainLen has been returned by a previous call to DecompressHeader() - function DecompressBody(Comp,Plain: PAnsiChar; CompLen,PlainLen: integer; - Load: TAlgoCompressLoad=aclNormal): boolean; - /// partial decoding of a memory buffer compressed via the Compress() method - // - returns 0 on error, or how many bytes have been written to Partial - // - will call virtual AlgoDecompressPartial() which is slower, but expected - // to avoid any buffer overflow on the Partial destination buffer - // - some algorithms (e.g. Lizard) may need some additional bytes in the - // decode buffer, so PartialLenMax bytes should be allocated in Partial^, - // with PartialLenMax > expected PartialLen, and returned bytes may be > - // PartialLen, but always <= PartialLenMax - function DecompressPartial(Comp,Partial: PAnsiChar; CompLen,PartialLen,PartialLenMax: integer): integer; - /// get the TAlgoCompress instance corresponding to the AlgoID stored - // in the supplied compressed buffer - // - returns nil if no algorithm was identified - class function Algo(Comp: PAnsiChar; CompLen: integer): TAlgoCompress; overload; - {$ifdef HASINLINE}inline;{$endif} - /// get the TAlgoCompress instance corresponding to the AlgoID stored - // in the supplied compressed buffer - // - returns nil if no algorithm was identified - // - also identifies "stored" content in IsStored variable - class function Algo(Comp: PAnsiChar; CompLen: integer; out IsStored: boolean): TAlgoCompress; overload; - /// get the TAlgoCompress instance corresponding to the AlgoID stored - // in the supplied compressed buffer - // - returns nil if no algorithm was identified - class function Algo(const Comp: RawByteString): TAlgoCompress; overload; - {$ifdef HASINLINE}inline;{$endif} - /// get the TAlgoCompress instance corresponding to the AlgoID stored - // in the supplied compressed buffer - // - returns nil if no algorithm was identified - class function Algo(const Comp: TByteDynArray): TAlgoCompress; overload; - {$ifdef HASINLINE}inline;{$endif} - /// get the TAlgoCompress instance corresponding to the supplied AlgoID - // - returns nil if no algorithm was identified - // - stored content is identified as TAlgoSynLZ - class function Algo(AlgoID: byte): TAlgoCompress; overload; - /// quickly validate a compressed buffer content, without uncompression - // - extract the TAlgoCompress, and call DecompressHeader() to check the - // hash of the compressed data, and return then uncompressed size - // - returns 0 on error (e.g. unknown algorithm or incorrect hash) - class function UncompressedSize(const Comp: RawByteString): integer; - /// returns the algorithm name, from its classname - // - e.g. TAlgoSynLZ->'synlz' TAlgoLizard->'lizard' nil->'none' - function AlgoName: TShort16; - end; - - /// implement our fast SynLZ compression as a TAlgoCompress class - // - please use the AlgoSynLZ global variable methods instead of the deprecated - // SynLZCompress/SynLZDecompress wrapper functions - TAlgoSynLZ = class(TAlgoCompress) - public - /// returns 1 as genuine byte identifier for SynLZ - function AlgoID: byte; override; - /// get maximum possible (worse) SynLZ compressed size for the supplied length - function AlgoCompressDestLen(PlainLen: integer): integer; override; - /// compress the supplied data using SynLZ - function AlgoCompress(Plain: pointer; PlainLen: integer; Comp: pointer): integer; override; - /// return the size of the SynLZ decompressed data - function AlgoDecompressDestLen(Comp: pointer): integer; override; - /// decompress the supplied data using SynLZ - function AlgoDecompress(Comp: pointer; CompLen: integer; Plain: pointer): integer; override; - /// partial (and safe) decompression of the supplied data using SynLZ - function AlgoDecompressPartial(Comp: pointer; CompLen: integer; - Partial: pointer; PartialLen, PartialLenMax: integer): integer; override; - end; - - TAlgoCompressWithNoDestLenProcess = (doCompress, doUnCompress, doUncompressPartial); - - /// abstract class storing the plain length before calling compression API - // - some libraries (e.g. Deflate or Lizard) don't provide the uncompressed - // length from its output buffer - inherit from this class to store this value - // as ToVarUInt32, and override the RawProcess abstract protected method - TAlgoCompressWithNoDestLen = class(TAlgoCompress) - protected - /// inherited classes should implement this single method for the actual process - // - dstMax is oinly used for doUncompressPartial - function RawProcess(src,dst: pointer; srcLen,dstLen,dstMax: integer; - process: TAlgoCompressWithNoDestLenProcess): integer; virtual; abstract; - public - /// performs the compression, storing PlainLen and calling protected RawProcess - function AlgoCompress(Plain: pointer; PlainLen: integer; Comp: pointer): integer; override; - /// return the size of the decompressed data (using FromVarUInt32) - function AlgoDecompressDestLen(Comp: pointer): integer; override; - /// performs the decompression, retrieving PlainLen and calling protected RawProcess - function AlgoDecompress(Comp: pointer; CompLen: integer; Plain: pointer): integer; override; - /// performs the decompression, retrieving PlainLen and calling protected RawProcess - function AlgoDecompressPartial(Comp: pointer; CompLen: integer; - Partial: pointer; PartialLen, PartialLenMax: integer): integer; override; - end; - - // internal flag, used only by TSynDictionary.InArray protected method - TSynDictionaryInArray = ( - iaFind, iaFindAndDelete, iaFindAndUpdate, iaFindAndAddIfNotExisting, iaAdd); - - /// event called by TSynDictionary.ForEach methods to iterate over stored items - // - if the implementation method returns TRUE, will continue the loop - // - if the implementation method returns FALSE, will stop values browsing - // - aOpaque is a custom value specified at ForEach() method call - TSynDictionaryEvent = function(const aKey; var aValue; aIndex,aCount: integer; - aOpaque: pointer): boolean of object; - - /// event called by TSynDictionary.DeleteDeprecated - // - called just before deletion: return false to by-pass this item - TSynDictionaryCanDeleteEvent = function(const aKey, aValue; aIndex: integer): boolean of object; - - /// thread-safe dictionary to store some values from associated keys - // - will maintain a dynamic array of values, associated with a hash table - // for the keys, so that setting or retrieving values would be O(1) - // - all process is protected by a TSynLocker, so will be thread-safe - // - TDynArray is a wrapper which do not store anything, whereas this class - // is able to store both keys and values, and provide convenient methods to - // access the stored data, including JSON serialization and binary storage - TSynDictionary = class(TSynPersistentLock) - protected - fKeys: TDynArrayHashed; - fValues: TDynArray; - fTimeOut: TCardinalDynArray; - fTimeOuts: TDynArray; - fCompressAlgo: TAlgoCompress; - fOnCanDelete: TSynDictionaryCanDeleteEvent; - function InArray(const aKey,aArrayValue; aAction: TSynDictionaryInArray): boolean; - procedure SetTimeouts; - function ComputeNextTimeOut: cardinal; - function KeyFullHash(const Elem): cardinal; - function KeyFullCompare(const A,B): integer; - function GetCapacity: integer; - procedure SetCapacity(const Value: integer); - function GetTimeOutSeconds: cardinal; - public - /// initialize the dictionary storage, specifyng dynamic array keys/values - // - aKeyTypeInfo should be a dynamic array TypeInfo() RTTI pointer, which - // would store the keys within this TSynDictionary instance - // - aValueTypeInfo should be a dynamic array TypeInfo() RTTI pointer, which - // would store the values within this TSynDictionary instance - // - by default, string keys would be searched following exact case, unless - // aKeyCaseInsensitive is TRUE - // - you can set an optional timeout period, in seconds - you should call - // DeleteDeprecated periodically to search for deprecated items - constructor Create(aKeyTypeInfo,aValueTypeInfo: pointer; - aKeyCaseInsensitive: boolean=false; aTimeoutSeconds: cardinal=0; - aCompressAlgo: TAlgoCompress=nil); reintroduce; virtual; - /// finalize the storage - // - would release all internal stored values - destructor Destroy; override; - /// try to add a value associated with a primary key - // - returns the index of the inserted item, -1 if aKey is already existing - // - this method is thread-safe, since it will lock the instance - function Add(const aKey, aValue): integer; - /// store a value associated with a primary key - // - returns the index of the matching item - // - if aKey does not exist, a new entry is added - // - if aKey does exist, the existing entry is overriden with aValue - // - this method is thread-safe, since it will lock the instance - function AddOrUpdate(const aKey, aValue): integer; - /// clear the value associated via aKey - // - does not delete the entry, but reset its value - // - returns the index of the matching item, -1 if aKey was not found - // - this method is thread-safe, since it will lock the instance - function Clear(const aKey): integer; - /// delete all key/value stored in the current instance - procedure DeleteAll; - /// delete a key/value association from its supplied aKey - // - this would delete the entry, i.e. matching key and value pair - // - returns the index of the deleted item, -1 if aKey was not found - // - this method is thread-safe, since it will lock the instance - function Delete(const aKey): integer; - /// delete a key/value association from its internal index - // - this method is not thread-safe: you should use fSafe.Lock/Unlock - // e.g. then Find/FindValue to retrieve the index value - function DeleteAt(aIndex: integer): boolean; - /// search and delete all deprecated items according to TimeoutSeconds - // - returns how many items have been deleted - // - you can call this method very often: it will ensure that the - // search process will take place at most once every second - // - this method is thread-safe, but blocking during the process - function DeleteDeprecated: integer; - /// search of a primary key within the internal hashed dictionary - // - returns the index of the matching item, -1 if aKey was not found - // - if you want to access the value, you should use fSafe.Lock/Unlock: - // consider using Exists or FindAndCopy thread-safe methods instead - // - aUpdateTimeOut will update the associated timeout value of the entry - function Find(const aKey; aUpdateTimeOut: boolean=false): integer; - /// search of a primary key within the internal hashed dictionary - // - returns a pointer to the matching item, nil if aKey was not found - // - if you want to access the value, you should use fSafe.Lock/Unlock: - // consider using Exists or FindAndCopy thread-safe methods instead - // - aUpdateTimeOut will update the associated timeout value of the entry - function FindValue(const aKey; aUpdateTimeOut: boolean=false; aIndex: PInteger=nil): pointer; - /// search of a primary key within the internal hashed dictionary - // - returns a pointer to the matching or already existing item - // - if you want to access the value, you should use fSafe.Lock/Unlock: - // consider using Exists or FindAndCopy thread-safe methods instead - // - will update the associated timeout value of the entry, if applying - function FindValueOrAdd(const aKey; var added: boolean; aIndex: PInteger=nil): pointer; - /// search of a stored value by its primary key, and return a local copy - // - so this method is thread-safe - // - returns TRUE if aKey was found, FALSE if no match exists - // - will update the associated timeout value of the entry, unless - // aUpdateTimeOut is set to false - function FindAndCopy(const aKey; out aValue; aUpdateTimeOut: boolean=true): boolean; - /// search of a stored value by its primary key, then delete and return it - // - returns TRUE if aKey was found, fill aValue with its content, - // and delete the entry in the internal storage - // - so this method is thread-safe - // - returns FALSE if no match exists - function FindAndExtract(const aKey; out aValue): boolean; - /// search for a primary key presence - // - returns TRUE if aKey was found, FALSE if no match exists - // - this method is thread-safe - function Exists(const aKey): boolean; - /// apply a specified event over all items stored in this dictionnary - // - would browse the list in the adding order - // - returns the number of times OnEach has been called - // - this method is thread-safe, since it will lock the instance - function ForEach(const OnEach: TSynDictionaryEvent; Opaque: pointer=nil): integer; overload; - /// apply a specified event over matching items stored in this dictionnary - // - would browse the list in the adding order, comparing each key and/or - // value item with the supplied comparison functions and aKey/aValue content - // - returns the number of times OnMatch has been called, i.e. how many times - // KeyCompare(aKey,Keys[#])=0 or ValueCompare(aValue,Values[#])=0 - // - this method is thread-safe, since it will lock the instance - function ForEach(const OnMatch: TSynDictionaryEvent; - KeyCompare,ValueCompare: TDynArraySortCompare; const aKey,aValue; - Opaque: pointer=nil): integer; overload; - /// touch the entry timeout field so that it won't be deprecated sooner - // - this method is not thread-safe, and is expected to be execute e.g. - // from a ForEach() TSynDictionaryEvent callback - procedure SetTimeoutAtIndex(aIndex: integer); - /// search aArrayValue item in a dynamic-array value associated via aKey - // - expect the stored value to be a dynamic array itself - // - would search for aKey as primary key, then use TDynArray.Find - // to delete any aArrayValue match in the associated dynamic array - // - returns FALSE if Values is not a tkDynArray, or if aKey or aArrayValue - // were not found - // - this method is thread-safe, since it will lock the instance - function FindInArray(const aKey, aArrayValue): boolean; - /// search of a stored key by its associated key, and return a key local copy - // - won't use any hashed index but TDynArray.IndexOf over fValues, - // so is much slower than FindAndCopy() - // - will update the associated timeout value of the entry, unless - // aUpdateTimeOut is set to false - // - so this method is thread-safe - // - returns TRUE if aValue was found, FALSE if no match exists - function FindKeyFromValue(const aValue; out aKey; aUpdateTimeOut: boolean=true): boolean; - /// add aArrayValue item within a dynamic-array value associated via aKey - // - expect the stored value to be a dynamic array itself - // - would search for aKey as primary key, then use TDynArray.Add - // to add aArrayValue to the associated dynamic array - // - returns FALSE if Values is not a tkDynArray, or if aKey was not found - // - this method is thread-safe, since it will lock the instance - function AddInArray(const aKey, aArrayValue): boolean; - /// add once aArrayValue within a dynamic-array value associated via aKey - // - expect the stored value to be a dynamic array itself - // - would search for aKey as primary key, then use - // TDynArray.FindAndAddIfNotExisting to add once aArrayValue to the - // associated dynamic array - // - returns FALSE if Values is not a tkDynArray, or if aKey was not found - // - this method is thread-safe, since it will lock the instance - function AddOnceInArray(const aKey, aArrayValue): boolean; - /// clear aArrayValue item of a dynamic-array value associated via aKey - // - expect the stored value to be a dynamic array itself - // - would search for aKey as primary key, then use TDynArray.FindAndDelete - // to delete any aArrayValue match in the associated dynamic array - // - returns FALSE if Values is not a tkDynArray, or if aKey or aArrayValue were - // not found - // - this method is thread-safe, since it will lock the instance - function DeleteInArray(const aKey, aArrayValue): boolean; - /// replace aArrayValue item of a dynamic-array value associated via aKey - // - expect the stored value to be a dynamic array itself - // - would search for aKey as primary key, then use TDynArray.FindAndUpdate - // to delete any aArrayValue match in the associated dynamic array - // - returns FALSE if Values is not a tkDynArray, or if aKey or aArrayValue were - // not found - // - this method is thread-safe, since it will lock the instance - function UpdateInArray(const aKey, aArrayValue): boolean; - {$ifndef DELPHI5OROLDER} - /// make a copy of the stored values - // - this method is thread-safe, since it will lock the instance during copy - // - resulting length(Dest) will match the exact values count - // - T*ObjArray will be reallocated and copied by content (using a temporary - // JSON serialization), unless ObjArrayByRef is true and pointers are copied - procedure CopyValues(out Dest; ObjArrayByRef: boolean=false); - {$endif DELPHI5OROLDER} - /// serialize the content as a "key":value JSON object - procedure SaveToJSON(W: TTextWriter; EnumSetsAsText: boolean=false); overload; - /// serialize the content as a "key":value JSON object - function SaveToJSON(EnumSetsAsText: boolean=false): RawUTF8; overload; - /// serialize the Values[] as a JSON array - function SaveValuesToJSON(EnumSetsAsText: boolean=false): RawUTF8; - /// unserialize the content from "key":value JSON object - // - if the JSON input may not be correct (i.e. if not coming from SaveToJSON), - // you may set EnsureNoKeyCollision=TRUE for a slow but safe keys validation - function LoadFromJSON(const JSON: RawUTF8 {$ifndef NOVARIANTS}; - CustomVariantOptions: PDocVariantOptions=nil{$endif}): boolean; overload; - /// unserialize the content from "key":value JSON object - // - note that input JSON buffer is not modified in place: no need to create - // a temporary copy if the buffer is about to be re-used - function LoadFromJSON(JSON: PUTF8Char {$ifndef NOVARIANTS}; - CustomVariantOptions: PDocVariantOptions=nil{$endif}): boolean; overload; - /// save the content as SynLZ-compressed raw binary data - // - warning: this format is tied to the values low-level RTTI, so if you - // change the value/key type definitions, LoadFromBinary() would fail - function SaveToBinary(NoCompression: boolean=false): RawByteString; - /// load the content from SynLZ-compressed raw binary data - // - as previously saved by SaveToBinary method - function LoadFromBinary(const binary: RawByteString): boolean; - /// can be assigned to OnCanDeleteDeprecated to check TSynPersistentLock(aValue).Safe.IsLocked - class function OnCanDeleteSynPersistentLock(const aKey, aValue; aIndex: integer): boolean; - /// can be assigned to OnCanDeleteDeprecated to check TSynPersistentLock(aValue).Safe.IsLocked - class function OnCanDeleteSynPersistentLocked(const aKey, aValue; aIndex: integer): boolean; - /// returns how many items are currently stored in this dictionary - // - this method is thread-safe - function Count: integer; - /// fast returns how many items are currently stored in this dictionary - // - this method is NOT thread-safe so should be protected by fSafe.Lock/UnLock - function RawCount: integer; {$ifdef HASINLINE}inline;{$endif} - /// direct access to the primary key identifiers - // - if you want to access the keys, you should use fSafe.Lock/Unlock - property Keys: TDynArrayHashed read fKeys; - /// direct access to the associated stored values - // - if you want to access the values, you should use fSafe.Lock/Unlock - property Values: TDynArray read fValues; - /// defines how many items are currently stored in Keys/Values internal arrays - property Capacity: integer read GetCapacity write SetCapacity; - /// direct low-level access to the internal access tick (GetTickCount64 shr 10) - // - may be nil if TimeOutSeconds=0 - property TimeOut: TCardinalDynArray read fTimeOut; - /// returns the aTimeOutSeconds parameter value, as specified to Create() - property TimeOutSeconds: cardinal read GetTimeOutSeconds; - /// the compression algorithm used for binary serialization - property CompressAlgo: TAlgoCompress read fCompressAlgo write fCompressAlgo; - /// callback to by-pass DeleteDeprecated deletion by returning false - // - can be assigned e.g. to OnCanDeleteSynPersistentLock if Value is a - // TSynPersistentLock instance, to avoid any potential access violation - property OnCanDeleteDeprecated: TSynDictionaryCanDeleteEvent read fOnCanDelete write fOnCanDelete; - end; - - /// event signature to locate a service for a given string key - // - used e.g. by TRawUTF8ObjectCacheList.OnKeyResolve property - TOnKeyResolve = function(const aInterface: TGUID; const Key: RawUTF8; out Obj): boolean of object; - /// event signature to notify a given string key - TOnKeyNotify = procedure(Sender: TObject; const Key: RawUTF8) of object; - -var - /// mORMot.pas will registry here its T*ObjArray serialization process - // - will be used by TDynArray.GetIsObjArray - DynArrayIsObjArray: function(aDynArrayTypeInfo: Pointer): TPointerClassHashed; - -type - /// handle memory mapping of a file content - TMemoryMap = object - protected - fBuf: PAnsiChar; - fBufSize: PtrUInt; - fFile: THandle; - {$ifdef MSWINDOWS} - fMap: THandle; - {$endif} - fFileSize: Int64; - fFileLocal: boolean; - public - /// map the corresponding file handle - // - if aCustomSize and aCustomOffset are specified, the corresponding - // map view if created (by default, will map whole file) - function Map(aFile: THandle; aCustomSize: PtrUInt=0; aCustomOffset: Int64=0): boolean; overload; - /// map the file specified by its name - // - file will be closed when UnMap will be called - function Map(const aFileName: TFileName): boolean; overload; - /// set a fixed buffer for the content - // - emulated a memory-mapping from an existing buffer - procedure Map(aBuffer: pointer; aBufferSize: PtrUInt); overload; - /// unmap the file - procedure UnMap; - /// retrieve the memory buffer mapped to the file content - property Buffer: PAnsiChar read fBuf; - /// retrieve the buffer size - property Size: PtrUInt read fBufSize; - /// retrieve the mapped file size - property FileSize: Int64 read fFileSize; - /// access to the low-level associated File handle (if any) - property FileHandle: THandle read fFile; - end; - - {$M+} - /// able to read a UTF-8 text file using memory map - // - much faster than TStringList.LoadFromFile() - // - will ignore any trailing UTF-8 BOM in the file content, but will not - // expect one either - TMemoryMapText = class - protected - fLines: PPointerArray; - fLinesMax: integer; - fCount: integer; - fMapEnd: PUTF8Char; - fMap: TMemoryMap; - fFileName: TFileName; - fAppendedLines: TRawUTF8DynArray; - fAppendedLinesCount: integer; - function GetLine(aIndex: integer): RawUTF8; {$ifdef HASINLINE}inline;{$endif} - function GetString(aIndex: integer): string; {$ifdef HASINLINE}inline;{$endif} - /// call once by Create constructors when fMap has been initialized - procedure LoadFromMap(AverageLineLength: integer=32); virtual; - /// call once per line, from LoadFromMap method - // - default implementation will set fLines[fCount] := LineBeg; - // - override this method to add some per-line process at loading: it will - // avoid reading the entire file more than once - procedure ProcessOneLine(LineBeg, LineEnd: PUTF8Char); virtual; - public - /// initialize the memory mapped text file - // - this default implementation just do nothing but is called by overloaded - // constructors so may be overriden to initialize an inherited class - constructor Create; overload; virtual; - /// read an UTF-8 encoded text file - // - every line beginning is stored into LinePointers[] - constructor Create(const aFileName: TFileName); overload; - /// read an UTF-8 encoded text file content - // - every line beginning is stored into LinePointers[] - // - this overloaded constructor accept an existing memory buffer (some - // uncompressed data e.g.) - constructor Create(aFileContent: PUTF8Char; aFileSize: integer); overload; - /// release the memory map and internal LinePointers[] - destructor Destroy; override; - /// save the whole content into a specified stream - // - including any runtime appended values via AddInMemoryLine() - procedure SaveToStream(Dest: TStream; const Header: RawUTF8); - /// save the whole content into a specified file - // - including any runtime appended values via AddInMemoryLine() - // - an optional header text can be added to the beginning of the file - procedure SaveToFile(FileName: TFileName; const Header: RawUTF8=''); - /// add a new line to the already parsed content - // - this line won't be stored in the memory mapped file, but stay in memory - // and appended to the existing lines, until this instance is released - procedure AddInMemoryLine(const aNewLine: RawUTF8); virtual; - /// clear all in-memory appended rows - procedure AddInMemoryLinesClear; virtual; - /// retrieve the number of UTF-8 chars of the given line - // - warning: no range check is performed about supplied index - function LineSize(aIndex: integer): integer; - {$ifdef HASINLINE}inline;{$endif} - /// check if there is at least a given number of UTF-8 chars in the given line - // - this is faster than LineSize(aIndex) use this function to safe access files > 2 GB -// (thanks to sanyin for the report) -function FileSeek64(Handle: THandle; const Offset: Int64; Origin: cardinal): Int64; - -/// wrapper to serialize a T*ObjArray dynamic array as JSON -// - as expected by TJSONSerializer.RegisterObjArrayForJSON() -function ObjArrayToJSON(const aObjArray; - aOptions: TTextWriterWriteObjectOptions=[woDontStoreDefault]): RawUTF8; - -/// encode the supplied data as an UTF-8 valid JSON object content -// - data must be supplied two by two, as Name,Value pairs, e.g. -// ! JSONEncode(['name','John','year',1972]) = '{"name":"John","year":1972}' -// - or you can specify nested arrays or objects with '['..']' or '{'..'}': -// ! J := JSONEncode(['doc','{','name','John','abc','[','a','b','c',']','}','id',123]); -// ! assert(J='{"doc":{"name":"John","abc":["a","b","c"]},"id":123}'); -// - note that, due to a Delphi compiler limitation, cardinal values should be -// type-casted to Int64() (otherwise the integer mapped value will be converted) -// - you can pass nil as parameter for a null JSON value -function JSONEncode(const NameValuePairs: array of const): RawUTF8; overload; - -{$ifndef NOVARIANTS} -/// encode the supplied (extended) JSON content, with parameters, -// as an UTF-8 valid JSON object content -// - in addition to the JSON RFC specification strict mode, this method will -// handle some BSON-like extensions, e.g. unquoted field names: -// ! aJSON := JSONEncode('{id:?,%:{name:?,birthyear:?}}',['doc'],[10,'John',1982]); -// - you can use nested _Obj() / _Arr() instances -// ! aJSON := JSONEncode('{%:{$in:[?,?]}}',['type'],['food','snack']); -// ! aJSON := JSONEncode('{type:{$in:?}}',[],[_Arr(['food','snack'])]); -// ! // will both return -// ! '{"type":{"$in":["food","snack"]}}') -// - if the SynMongoDB unit is used in the application, the MongoDB Shell -// syntax will also be recognized to create TBSONVariant, like -// ! new Date() ObjectId() MinKey MaxKey // -// see @http://docs.mongodb.org/manual/reference/mongodb-extended-json -// ! aJSON := JSONEncode('{name:?,field:/%/i}',['acme.*corp'],['John'])) -// ! // will return -// ! '{"name":"John","field":{"$regex":"acme.*corp","$options":"i"}}' -// - will call internally _JSONFastFmt() to create a temporary TDocVariant with -// all its features - so is slightly slower than other JSONEncode* functions -function JSONEncode(const Format: RawUTF8; const Args,Params: array of const): RawUTF8; overload; -{$endif} - -/// encode the supplied RawUTF8 array data as an UTF-8 valid JSON array content -function JSONEncodeArrayUTF8(const Values: array of RawUTF8): RawUTF8; overload; - -/// encode the supplied integer array data as a valid JSON array -function JSONEncodeArrayInteger(const Values: array of integer): RawUTF8; overload; - -/// encode the supplied floating-point array data as a valid JSON array -function JSONEncodeArrayDouble(const Values: array of double): RawUTF8; overload; - -/// encode the supplied array data as a valid JSON array content -// - if WithoutBraces is TRUE, no [ ] will be generated -// - note that, due to a Delphi compiler limitation, cardinal values should be -// type-casted to Int64() (otherwise the integer mapped value will be converted) -function JSONEncodeArrayOfConst(const Values: array of const; - WithoutBraces: boolean=false): RawUTF8; overload; - -/// encode the supplied array data as a valid JSON array content -// - if WithoutBraces is TRUE, no [ ] will be generated -// - note that, due to a Delphi compiler limitation, cardinal values should be -// type-casted to Int64() (otherwise the integer mapped value will be converted) -procedure JSONEncodeArrayOfConst(const Values: array of const; - WithoutBraces: boolean; var result: RawUTF8); overload; - -/// encode as JSON {"name":value} object, from a potential SQL quoted value -// - will unquote the SQLValue using TTextWriter.AddQuotedStringAsJSON() -procedure JSONEncodeNameSQLValue(const Name,SQLValue: RawUTF8; var result: RawUTF8); - -type - /// points to one value of raw UTF-8 content, decoded from a JSON buffer - // - used e.g. by JSONDecode() overloaded function to returns names/values - TValuePUTF8Char = object - public - /// a pointer to the actual UTF-8 text - Value: PUTF8Char; - /// how many UTF-8 bytes are stored in Value - ValueLen: PtrInt; - /// convert the value into a UTF-8 string - procedure ToUTF8(var Text: RawUTF8); overload; {$ifdef HASINLINE}inline;{$endif} - /// convert the value into a UTF-8 string - function ToUTF8: RawUTF8; overload; {$ifdef HASINLINE}inline;{$endif} - /// convert the value into a VCL/generic string - function ToString: string; - /// convert the value into a signed integer - function ToInteger: PtrInt; {$ifdef HASINLINE}inline;{$endif} - /// convert the value into an unsigned integer - function ToCardinal: PtrUInt; {$ifdef HASINLINE}inline;{$endif} - /// will call IdemPropNameU() over the stored text Value - function Idem(const Text: RawUTF8): boolean; {$ifdef HASINLINE}inline;{$endif} - end; - /// used e.g. by JSONDecode() overloaded function to returns values - TValuePUTF8CharArray = array[0..maxInt div SizeOf(TValuePUTF8Char)-1] of TValuePUTF8Char; - PValuePUTF8CharArray = ^TValuePUTF8CharArray; - - /// store one name/value pair of raw UTF-8 content, from a JSON buffer - // - used e.g. by JSONDecode() overloaded function or UrlEncodeJsonObject() - // to returns names/values - TNameValuePUTF8Char = record - /// a pointer to the actual UTF-8 name text - Name: PUTF8Char; - /// a pointer to the actual UTF-8 value text - Value: PUTF8Char; - /// how many UTF-8 bytes are stored in Name (should be integer, not PtrInt) - NameLen: integer; - /// how many UTF-8 bytes are stored in Value - ValueLen: integer; - end; - /// used e.g. by JSONDecode() overloaded function to returns name/value pairs - TNameValuePUTF8CharDynArray = array of TNameValuePUTF8Char; - -/// decode the supplied UTF-8 JSON content for the supplied names -// - data will be set in Values, according to the Names supplied e.g. -// ! JSONDecode(JSON,['name','year'],@Values) -> Values[0].Value='John'; Values[1].Value='1972'; -// - if any supplied name wasn't found its corresponding Values[] will be nil -// - this procedure will decode the JSON content in-memory, i.e. the PUtf8Char -// array is created inside JSON, which is therefore modified: make a private -// copy first if you want to reuse the JSON content -// - if HandleValuesAsObjectOrArray is TRUE, then this procedure will handle -// JSON arrays or objects -// - support enhanced JSON syntax, e.g. '{name:'"John",year:1972}' is decoded -// just like '{"name":'"John","year":1972}' -procedure JSONDecode(var JSON: RawUTF8; const Names: array of RawUTF8; - Values: PValuePUTF8CharArray; HandleValuesAsObjectOrArray: Boolean=false); overload; - -/// decode the supplied UTF-8 JSON content for the supplied names -// - an overloaded function when the JSON is supplied as a RawJSON variable -procedure JSONDecode(var JSON: RawJSON; const Names: array of RawUTF8; - Values: PValuePUTF8CharArray; HandleValuesAsObjectOrArray: Boolean=false); overload; - -/// decode the supplied UTF-8 JSON content for the supplied names -// - data will be set in Values, according to the Names supplied e.g. -// ! JSONDecode(P,['name','year'],Values) -> Values[0]^='John'; Values[1]^='1972'; -// - if any supplied name wasn't found its corresponding Values[] will be nil -// - this procedure will decode the JSON content in-memory, i.e. the PUtf8Char -// array is created inside P, which is therefore modified: make a private -// copy first if you want to reuse the JSON content -// - if HandleValuesAsObjectOrArray is TRUE, then this procedure will handle -// JSON arrays or objects -// - if ValuesLen is set, ValuesLen[] will contain the length of each Values[] -// - returns a pointer to the next content item in the JSON buffer -function JSONDecode(P: PUTF8Char; const Names: array of RawUTF8; - Values: PValuePUTF8CharArray; HandleValuesAsObjectOrArray: Boolean=false): PUTF8Char; overload; - -/// decode the supplied UTF-8 JSON content into an array of name/value pairs -// - this procedure will decode the JSON content in-memory, i.e. the PUtf8Char -// array is created inside JSON, which is therefore modified: make a private -// copy first if you want to reuse the JSON content -// - the supplied JSON buffer should stay available until Name/Value pointers -// from returned Values[] are accessed -// - if HandleValuesAsObjectOrArray is TRUE, then this procedure will handle -// JSON arrays or objects -// - support enhanced JSON syntax, e.g. '{name:'"John",year:1972}' is decoded -// just like '{"name":'"John","year":1972}' -function JSONDecode(P: PUTF8Char; out Values: TNameValuePUTF8CharDynArray; - HandleValuesAsObjectOrArray: Boolean=false): PUTF8Char; overload; - -/// decode the supplied UTF-8 JSON content for the one supplied name -// - this function will decode the JSON content in-memory, so will unescape it -// in-place: it must be called only once with the same JSON data -function JSONDecode(var JSON: RawUTF8; const aName: RawUTF8='result'; - wasString: PBoolean=nil; HandleValuesAsObjectOrArray: Boolean=false): RawUTF8; overload; - -/// retrieve a pointer to JSON string field content -// - returns either ':' for name field, either '}',',' for value field -// - returns nil on JSON content error -// - this function won't touch the JSON buffer, so you can call it before -// using in-place escape process via JSONDecode() or GetJSONField() -function JSONRetrieveStringField(P: PUTF8Char; out Field: PUTF8Char; - out FieldLen: integer; ExpectNameField: boolean): PUTF8Char; - {$ifdef HASINLINE}inline;{$endif} - -/// efficient JSON field in-place decoding, within a UTF-8 encoded buffer -// - this function decodes in the P^ buffer memory itself (no memory allocation -// or copy), for faster process - so take care that P^ is not shared -// - PDest points to the next field to be decoded, or nil on JSON parsing error -// - EndOfObject (if not nil) is set to the JSON value char (',' ':' or '}' e.g.) -// - optional wasString is set to true if the JSON value was a JSON "string" -// - returns a PUTF8Char to the decoded value, with its optional length in Len^ -// - '"strings"' are decoded as 'strings', with wasString=true, properly JSON -// unescaped (e.g. any \u0123 pattern would be converted into UTF-8 content) -// - null is decoded as nil, with wasString=false -// - true/false boolean values are returned as 'true'/'false', with wasString=false -// - any number value is returned as its ascii representation, with wasString=false -// - works for both field names or values (e.g. '"FieldName":' or 'Value,') -function GetJSONField(P: PUTF8Char; out PDest: PUTF8Char; - wasString: PBoolean=nil; EndOfObject: PUTF8Char=nil; Len: PInteger=nil): PUTF8Char; - -/// decode a JSON field name in an UTF-8 encoded buffer -// - this function decodes in the P^ buffer memory itself (no memory allocation -// or copy), for faster process - so take care that P^ is not shared -// - it will return the property name (with an ending #0) or nil on error -// - this function will handle strict JSON property name (i.e. a "string"), but -// also MongoDB extended syntax, e.g. {age:{$gt:18}} or {'people.age':{$gt:18}} -// see @http://docs.mongodb.org/manual/reference/mongodb-extended-json -function GetJSONPropName(var P: PUTF8Char; Len: PInteger=nil): PUTF8Char; overload; - -/// decode a JSON field name in an UTF-8 encoded shortstring variable -// - this function would left the P^ buffer memory untouched, so may be safer -// than the overloaded GetJSONPropName() function in some cases -// - it will return the property name as a local UTF-8 encoded shortstring, -// or PropName='' on error -// - this function won't unescape the property name, as strict JSON (i.e. a "st\"ring") -// - but it will handle MongoDB syntax, e.g. {age:{$gt:18}} or {'people.age':{$gt:18}} -// see @http://docs.mongodb.org/manual/reference/mongodb-extended-json -procedure GetJSONPropName(var P: PUTF8Char; out PropName: shortstring); overload; - -/// decode a JSON content in an UTF-8 encoded buffer -// - GetJSONField() will only handle JSON "strings" or numbers - if -// HandleValuesAsObjectOrArray is TRUE, this function will process JSON { -// objects } or [ arrays ] and add a #0 at the end of it -// - this function decodes in the P^ buffer memory itself (no memory allocation -// or copy), for faster process - so take care that it is an unique string -// - returns a pointer to the value start, and moved P to the next field to -// be decoded, or P=nil in case of any unexpected input -// - wasString is set to true if the JSON value was a "string" -// - EndOfObject (if not nil) is set to the JSON value end char (',' ':' or '}') -// - if Len is set, it will contain the length of the returned pointer value -function GetJSONFieldOrObjectOrArray(var P: PUTF8Char; wasString: PBoolean=nil; - EndOfObject: PUTF8Char=nil; HandleValuesAsObjectOrArray: Boolean=false; - NormalizeBoolean: Boolean=true; Len: PInteger=nil): PUTF8Char; - -/// retrieve the next JSON item as a RawJSON variable -// - buffer can be either any JSON item, i.e. a string, a number or even a -// JSON array (ending with ]) or a JSON object (ending with }) -// - EndOfObject (if not nil) is set to the JSON value end char (',' ':' or '}') -procedure GetJSONItemAsRawJSON(var P: PUTF8Char; var result: RawJSON; - EndOfObject: PAnsiChar=nil); - -/// retrieve the next JSON item as a RawUTF8 decoded buffer -// - buffer can be either any JSON item, i.e. a string, a number or even a -// JSON array (ending with ]) or a JSON object (ending with }) -// - EndOfObject (if not nil) is set to the JSON value end char (',' ':' or '}') -// - just call GetJSONField(), and create a new RawUTF8 from the returned value, -// after proper unescape if wasString^=true -function GetJSONItemAsRawUTF8(var P: PUTF8Char; var output: RawUTF8; - wasString: PBoolean=nil; EndOfObject: PUTF8Char=nil): boolean; - -/// test if the supplied buffer is a "string" value or a numerical value -// (floating point or integer), according to the characters within -// - this version will recognize null/false/true as strings -// - e.g. IsString('0')=false, IsString('abc')=true, IsString('null')=true -function IsString(P: PUTF8Char): boolean; - -/// test if the supplied buffer is a "string" value or a numerical value -// (floating or integer), according to the JSON encoding schema -// - this version will NOT recognize JSON null/false/true as strings -// - e.g. IsStringJSON('0')=false, IsStringJSON('abc')=true, -// but IsStringJSON('null')=false -// - will follow the JSON definition of number, i.e. '0123' is a string (i.e. -// '0' is excluded at the begining of a number) and '123' is not a string -function IsStringJSON(P: PUTF8Char): boolean; - -/// test if the supplied buffer is a correct JSON value -function IsValidJSON(P: PUTF8Char; len: PtrInt): boolean; overload; - -/// test if the supplied buffer is a correct JSON value -function IsValidJSON(const s: RawUTF8): boolean; overload; - -/// reach positon just after the current JSON item in the supplied UTF-8 buffer -// - buffer can be either any JSON item, i.e. a string, a number or even a -// JSON array (ending with ]) or a JSON object (ending with }) -// - returns nil if the specified buffer is not valid JSON content -// - returns the position in buffer just after the item excluding the separator -// character - i.e. result^ may be ',','}',']' -function GotoEndJSONItem(P: PUTF8Char; strict: boolean=false): PUTF8Char; - -/// reach the positon of the next JSON item in the supplied UTF-8 buffer -// - buffer can be either any JSON item, i.e. a string, a number or even a -// JSON array (ending with ]) or a JSON object (ending with }) -// - returns nil if the specified number of items is not available in buffer -// - returns the position in buffer after the item including the separator -// character (optionally in EndOfObject) - i.e. result will be at the start of -// the next object, and EndOfObject may be ',','}',']' -function GotoNextJSONItem(P: PUTF8Char; NumberOfItemsToJump: cardinal=1; - EndOfObject: PAnsiChar=nil): PUTF8Char; - -/// read the position of the JSON value just after a property identifier -// - this function will handle strict JSON property name (i.e. a "string"), but -// also MongoDB extended syntax, e.g. {age:{$gt:18}} or {'people.age':{$gt:18}} -// see @http://docs.mongodb.org/manual/reference/mongodb-extended-json -function GotoNextJSONPropName(P: PUTF8Char): PUTF8Char; - -/// reach the position of the next JSON object of JSON array -// - first char is expected to be either '[' or '{' -// - will return nil in case of parsing error or unexpected end (#0) -// - will return the next character after ending ] or } - i.e. may be , } ] -function GotoNextJSONObjectOrArray(P: PUTF8Char): PUTF8Char; overload; - {$ifdef FPC}inline;{$endif} - -/// reach the position of the next JSON object of JSON array -// - first char is expected to be just after the initial '[' or '{' -// - specify ']' or '}' as the expected EndChar -// - will return nil in case of parsing error or unexpected end (#0) -// - will return the next character after ending ] or } - i.e. may be , } ] -function GotoNextJSONObjectOrArray(P: PUTF8Char; EndChar: AnsiChar): PUTF8Char; overload; - {$ifdef FPC}inline;{$endif} - -/// reach the position of the next JSON object of JSON array -// - first char is expected to be either '[' or '{' -// - this version expects a maximum position in PMax: it may be handy to break -// the parsing for HUGE content - used e.g. by JSONArrayCount(P,PMax) -// - will return nil in case of parsing error or if P reached PMax limit -// - will return the next character after ending ] or { - i.e. may be , } ] -function GotoNextJSONObjectOrArrayMax(P,PMax: PUTF8Char): PUTF8Char; - -/// compute the number of elements of a JSON array -// - this will handle any kind of arrays, including those with nested -// JSON objects or arrays -// - incoming P^ should point to the first char AFTER the initial '[' (which -// may be a closing ']') -// - returns -1 if the supplied input is invalid, or the number of identified -// items in the JSON array buffer -function JSONArrayCount(P: PUTF8Char): integer; overload; - -/// compute the number of elements of a JSON array -// - this will handle any kind of arrays, including those with nested -// JSON objects or arrays -// - incoming P^ should point to the first char after the initial '[' (which -// may be a closing ']') -// - this overloaded method will abort if P reaches a certain position: for -// really HUGE arrays, it is faster to allocate the content within the loop, -// not ahead of time -function JSONArrayCount(P,PMax: PUTF8Char): integer; overload; - -/// go to the #nth item of a JSON array -// - implemented via a fast SAX-like approach: the input buffer is not changed, -// nor no memory buffer allocated neither content copied -// - returns nil if the supplied index is out of range -// - returns a pointer to the index-nth item in the JSON array (first index=0) -// - this will handle any kind of arrays, including those with nested -// JSON objects or arrays -// - incoming P^ should point to the first initial '[' char -function JSONArrayItem(P: PUTF8Char; Index: integer): PUTF8Char; - -/// retrieve all elements of a JSON array -// - this will handle any kind of arrays, including those with nested -// JSON objects or arrays -// - incoming P^ should point to the first char AFTER the initial '[' (which -// may be a closing ']') -// - returns false if the supplied input is invalid -// - returns true on success, with Values[] pointing to each unescaped value, -// may be a JSON string, object, array of constant -function JSONArrayDecode(P: PUTF8Char; out Values: TPUTF8CharDynArray): boolean; - -/// compute the number of fields in a JSON object -// - this will handle any kind of objects, including those with nested -// JSON objects or arrays -// - incoming P^ should point to the first char after the initial '{' (which -// may be a closing '}') -function JSONObjectPropCount(P: PUTF8Char): integer; - -/// go to a named property of a JSON object -// - implemented via a fast SAX-like approach: the input buffer is not changed, -// nor no memory buffer allocated neither content copied -// - returns nil if the supplied property name does not exist -// - returns a pointer to the matching item in the JSON object -// - this will handle any kind of objects, including those with nested -// JSON objects or arrays -// - incoming P^ should point to the first initial '{' char -function JsonObjectItem(P: PUTF8Char; const PropName: RawUTF8; - PropNameFound: PRawUTF8=nil): PUTF8Char; - -/// go to a property of a JSON object, by its full path, e.g. 'parent.child' -// - implemented via a fast SAX-like approach: the input buffer is not changed, -// nor no memory buffer allocated neither content copied -// - returns nil if the supplied property path does not exist -// - returns a pointer to the matching item in the JSON object -// - this will handle any kind of objects, including those with nested -// JSON objects or arrays -// - incoming P^ should point to the first initial '{' char -function JsonObjectByPath(JsonObject,PropPath: PUTF8Char): PUTF8Char; - -/// return all matching properties of a JSON object -// - here the PropPath could be a comma-separated list of full paths, -// e.g. 'Prop1,Prop2' or 'Obj1.Obj2.Prop1,Obj1.Prop2' -// - returns '' if no property did match -// - returns a JSON object of all matching properties -// - this will handle any kind of objects, including those with nested -// JSON objects or arrays -// - incoming P^ should point to the first initial '{' char -function JsonObjectsByPath(JsonObject,PropPath: PUTF8Char): RawUTF8; - -/// convert one JSON object into two JSON arrays of keys and values -// - i.e. makes the following transformation: -// $ {key1:value1,key2,value2...} -> [key1,key2...] + [value1,value2...] -// - this function won't allocate any memory during its process, nor -// modify the JSON input buffer -// - is the reverse of the TTextWriter.AddJSONArraysAsJSONObject() method -function JSONObjectAsJSONArrays(JSON: PUTF8Char; out keys,values: RawUTF8): boolean; - -/// remove comments and trailing commas from a text buffer before passing it to JSON parser -// - handle two types of comments: starting from // till end of line -// or /* ..... */ blocks anywhere in the text content -// - trailing commas is replaced by ' ', so resulting JSON is valid for parsers -// what not allows trailing commas (browsers for example) -// - may be used to prepare configuration files before loading; -// for example we store server configuration in file config.json and -// put some comments in this file then code for loading is: -// !var cfg: RawUTF8; -// ! cfg := StringFromFile(ExtractFilePath(paramstr(0))+'Config.json'); -// ! RemoveCommentsFromJSON(@cfg[1]); -// ! pLastChar := JSONToObject(sc,pointer(cfg),configValid); -procedure RemoveCommentsFromJSON(P: PUTF8Char); - -const - /// standard header for an UTF-8 encoded XML file - XMLUTF8_HEADER = ''#13#10; - - /// standard namespace for a generic XML File - XMLUTF8_NAMESPACE = ''; - -/// convert a JSON array or document into a simple XML content -// - just a wrapper around TTextWriter.AddJSONToXML, with an optional -// header before the XML converted data (e.g. XMLUTF8_HEADER), and an optional -// name space content node which will nest the generated XML data (e.g. -// '') - the -// corresponding ending token will be appended after (e.g. '') -// - WARNING: the JSON buffer is decoded in-place, so P^ WILL BE modified -procedure JSONBufferToXML(P: PUTF8Char; const Header,NameSpace: RawUTF8; out result: RawUTF8); - -/// convert a JSON array or document into a simple XML content -// - just a wrapper around TTextWriter.AddJSONToXML, making a private copy -// of the supplied JSON buffer using TSynTempBuffer (so that JSON content -// would stay untouched) -// - the optional header is added at the beginning of the resulting string -// - an optional name space content node could be added around the generated XML, -// e.g. '' -function JSONToXML(const JSON: RawUTF8; const Header: RawUTF8=XMLUTF8_HEADER; - const NameSpace: RawUTF8=''): RawUTF8; - -/// formats and indents a JSON array or document to the specified layout -// - just a wrapper around TTextWriter.AddJSONReformat() method -// - WARNING: the JSON buffer is decoded in-place, so P^ WILL BE modified -procedure JSONBufferReformat(P: PUTF8Char; out result: RawUTF8; - Format: TTextWriterJSONFormat=jsonHumanReadable); - -/// formats and indents a JSON array or document to the specified layout -// - just a wrapper around TTextWriter.AddJSONReformat, making a private -// of the supplied JSON buffer (so that JSON content would stay untouched) -function JSONReformat(const JSON: RawUTF8; - Format: TTextWriterJSONFormat=jsonHumanReadable): RawUTF8; - -/// formats and indents a JSON array or document as a file -// - just a wrapper around TTextWriter.AddJSONReformat() method -// - WARNING: the JSON buffer is decoded in-place, so P^ WILL BE modified -function JSONBufferReformatToFile(P: PUTF8Char; const Dest: TFileName; - Format: TTextWriterJSONFormat=jsonHumanReadable): boolean; - -/// formats and indents a JSON array or document as a file -// - just a wrapper around TTextWriter.AddJSONReformat, making a private -// of the supplied JSON buffer (so that JSON content would stay untouched) -function JSONReformatToFile(const JSON: RawUTF8; const Dest: TFileName; - Format: TTextWriterJSONFormat=jsonHumanReadable): boolean; - - -const - /// map a PtrInt type to the TJSONCustomParserRTTIType set - ptPtrInt = {$ifdef CPU64}ptInt64{$else}ptInteger{$endif}; - /// map a PtrUInt type to the TJSONCustomParserRTTIType set - ptPtrUInt = {$ifdef CPU64}ptQWord{$else}ptCardinal{$endif}; - /// which TJSONCustomParserRTTIType types are not simple types - // - ptTimeLog is complex, since could be also TCreateTime or TModTime - PT_COMPLEXTYPES = [ptArray, ptRecord, ptCustom, ptTimeLog]; - /// could be used to compute the index in a pointer list from its position - POINTERSHR = {$ifdef CPU64}3{$else}2{$endif}; - /// could be used to compute the bitmask of a pointer integer - POINTERAND = {$ifdef CPU64}7{$else}3{$endif}; - /// could be used to check all bits on a pointer - POINTERBITS = {$ifdef CPU64}64{$else}32{$endif}; - - -{ ************ some other common types and conversion routines ************** } - -type - /// timestamp stored as second-based Unix Time - // - i.e. the number of seconds since 1970-01-01 00:00:00 UTC - // - is stored as 64-bit value, so that it won't be affected by the - // "Year 2038" overflow issue - // - see TUnixMSTime for a millisecond resolution Unix Timestamp - // - use UnixTimeToDateTime/DateTimeToUnixTime functions to convert it to/from - // a regular TDateTime - // - use UnixTimeUTC to return the current timestamp, using fast OS API call - // - also one of the encodings supported by SQLite3 date/time functions - TUnixTime = type Int64; - - /// timestamp stored as millisecond-based Unix Time - // - i.e. the number of milliseconds since 1970-01-01 00:00:00 UTC - // - see TUnixTime for a second resolution Unix Timestamp - // - use UnixMSTimeToDateTime/DateTimeToUnixMSTime functions to convert it - // to/from a regular TDateTime - // - also one of the JavaScript date encodings - TUnixMSTime = type Int64; - - /// pointer to a timestamp stored as second-based Unix Time - PUnixTime = ^TUnixTime; - /// pointer to a timestamp stored as millisecond-based Unix Time - PUnixMSTime = ^TUnixMSTime; - /// dynamic array of timestamps stored as second-based Unix Time - TUnixTimeDynArray = array of TUnixTime; - /// dynamic array of timestamps stored as millisecond-based Unix Time - TUnixMSTimeDynArray = array of TUnixMSTime; - -type - /// calling context of TSynLogExceptionToStr callbacks - TSynLogExceptionContext = record - /// the raised exception class - EClass: ExceptClass; - /// the Delphi Exception instance - // - may be nil for external/OS exceptions - EInstance: Exception; - /// the OS-level exception code - // - could be $0EEDFAE0 of $0EEDFADE for Delphi-generated exceptions - ECode: DWord; - /// the address where the exception occured - EAddr: PtrUInt; - /// the optional stack trace - EStack: PPtrUInt; - /// = FPC's RaiseProc() FrameCount if EStack is Frame: PCodePointer - EStackCount: integer; - /// the timestamp of this exception, as number of seconds since UNIX Epoch - // - UnixTimeUTC is faster than NowUTC or GetSystemTime - // - use UnixTimeToDateTime() to convert it into a regular TDateTime - ETimestamp: TUnixTime; - /// the logging level corresponding to this exception - // - may be either sllException or sllExceptionOS - ELevel: TSynLogInfo; - end; - - /// global hook callback to customize exceptions logged by TSynLog - // - should return TRUE if all needed information has been logged by the - // event handler - // - should return FALSE if Context.EAddr and Stack trace is to be appended - TSynLogExceptionToStr = function(WR: TTextWriter; const Context: TSynLogExceptionContext): boolean; - - {$M+} - /// generic parent class of all custom Exception types of this unit - // - all our classes inheriting from ESynException are serializable, - // so you could use ObjectToJSONDebug(anyESynException) to retrieve some - // extended information - ESynException = class(Exception) - protected - fRaisedAt: pointer; - public - /// constructor which will use FormatUTF8() instead of Format() - // - expect % as delimiter, so is less error prone than %s %d %g - // - will handle vtPointer/vtClass/vtObject/vtVariant kind of arguments, - // appending class name for any class or object, the hexa value for a - // pointer, or the JSON representation of any supplied TDocVariant - constructor CreateUTF8(const Format: RawUTF8; const Args: array of const); - /// constructor appending some FormatUTF8() content to the GetLastError - // - message will contain GetLastError value followed by the formatted text - // - expect % as delimiter, so is less error prone than %s %d %g - // - will handle vtPointer/vtClass/vtObject/vtVariant kind of arguments, - // appending class name for any class or object, the hexa value for a - // pointer, or the JSON representation of any supplied TDocVariant - constructor CreateLastOSError(const Format: RawUTF8; const Args: array of const; - const Trailer: RawUtf8 = 'OSError'); - {$ifndef NOEXCEPTIONINTERCEPT} - /// can be used to customize how the exception is logged - // - this default implementation will call the DefaultSynLogExceptionToStr() - // function or the TSynLogExceptionToStrCustom global callback, if defined - // - override this method to provide a custom logging content - // - should return TRUE if Context.EAddr and Stack trace is not to be - // written (i.e. as for any TSynLogExceptionToStr callback) - function CustomLog(WR: TTextWriter; const Context: TSynLogExceptionContext): boolean; virtual; - {$endif} - /// the code location when this exception was triggered - // - populated by SynLog unit, during interception - so may be nil - // - you can use TSynMapFile.FindLocation(ESynException) class function to - // guess the corresponding source code line - // - will be serialized as "Address": hexadecimal and source code location - // (using TSynMapFile .map/.mab information) in TJSONSerializer.WriteObject - // when woStorePointer option is defined - e.g. with ObjectToJSONDebug() - property RaisedAt: pointer read fRaisedAt write fRaisedAt; - published - property Message; - end; - {$M-} - ESynExceptionClass = class of ESynException; - - /// exception class associated to TDocVariant JSON/BSON document - EDocVariant = class(ESynException); - - /// exception raised during TFastReader decoding - EFastReader = class(ESynException); - -var - /// allow to customize the ESynException logging message - TSynLogExceptionToStrCustom: TSynLogExceptionToStr = nil; - - {$ifndef NOEXCEPTIONINTERCEPT} - /// default exception logging callback - will be set by the SynLog unit - // - will add the default Exception details, including any Exception.Message - // - if the exception inherits from ESynException - // - returns TRUE: caller will then append ' at EAddr' and the stack trace - DefaultSynLogExceptionToStr: TSynLogExceptionToStr = nil; - {$endif} - - -/// convert a string into its INTEGER Curr64 (value*10000) representation -// - this type is compatible with Delphi currency memory map with PInt64(@Curr)^ -// - fast conversion, using only integer operations -// - if NoDecimal is defined, will be set to TRUE if there is no decimal, AND -// the returned value will be an Int64 (not a PInt64(@Curr)^) -function StrToCurr64(P: PUTF8Char; NoDecimal: PBoolean=nil): Int64; - -/// convert a string into its currency representation -// - will call StrToCurr64() -function StrToCurrency(P: PUTF8Char): currency; - {$ifdef HASINLINE}inline;{$endif} - -/// convert a currency value into a string -// - fast conversion, using only integer operations -// - decimals are joined by 2 (no decimal, 2 decimals, 4 decimals) -function CurrencyToStr(Value: currency): RawUTF8; - {$ifdef HASINLINE}inline;{$endif} - -/// convert an INTEGER Curr64 (value*10000) into a string -// - this type is compatible with Delphi currency memory map with PInt64(@Curr)^ -// - fast conversion, using only integer operations -// - decimals are joined by 2 (no decimal, 2 decimals, 4 decimals) -function Curr64ToStr(const Value: Int64): RawUTF8; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert an INTEGER Curr64 (value*10000) into a string -// - this type is compatible with Delphi currency memory map with PInt64(@Curr)^ -// - fast conversion, using only integer operations -// - decimals are joined by 2 (no decimal, 2 decimals, 4 decimals) -procedure Curr64ToStr(const Value: Int64; var result: RawUTF8); overload; - -/// convert an INTEGER Curr64 (value*10000) into a string -// - this type is compatible with Delphi currency memory map with PInt64(@Curr)^ -// - fast conversion, using only integer operations -// - decimals are joined by 2 (no decimal, 2 decimals, 4 decimals) -// - return the number of chars written to Dest^ -function Curr64ToPChar(const Value: Int64; Dest: PUTF8Char): PtrInt; - -/// internal fast INTEGER Curr64 (value*10000) value to text conversion -// - expect the last available temporary char position in P -// - return the last written char position (write in reverse order in P^) -// - will return 0 for Value=0, or a string representation with always 4 decimals -// (e.g. 1->'0.0001' 500->'0.0500' 25000->'2.5000' 30000->'3.0000') -// - is called by Curr64ToPChar() and Curr64ToStr() functions -function StrCurr64(P: PAnsiChar; const Value: Int64): PAnsiChar; - -/// truncate a Currency value to only 2 digits -// - implementation will use fast Int64 math to avoid any precision loss due to -// temporary floating-point conversion -function TruncTo2Digits(Value: Currency): Currency; - -/// truncate a Currency value, stored as Int64, to only 2 digits -// - implementation will use fast Int64 math to avoid any precision loss due to -// temporary floating-point conversion -procedure TruncTo2DigitsCurr64(var Value: Int64); - {$ifdef HASINLINE}inline;{$endif} - -/// truncate a Currency value, stored as Int64, to only 2 digits -// - implementation will use fast Int64 math to avoid any precision loss due to -// temporary floating-point conversion -function TruncTo2Digits64(Value: Int64): Int64; - {$ifdef HASINLINE}inline;{$endif} - -/// simple, no banker rounding of a Currency value to only 2 digits -// - #.##51 will round to #.##+0.01 and #.##50 will be truncated to #.## -// - implementation will use fast Int64 math to avoid any precision loss due to -// temporary floating-point conversion -function SimpleRoundTo2Digits(Value: Currency): Currency; - -/// simple, no banker rounding of a Currency value, stored as Int64, to only 2 digits -// - #.##51 will round to #.##+0.01 and #.##50 will be truncated to #.## -// - implementation will use fast Int64 math to avoid any precision loss due to -// temporary floating-point conversion -procedure SimpleRoundTo2DigitsCurr64(var Value: Int64); - -var - /// a conversion table from hexa chars into binary data - // - returns 255 for any character out of 0..9,A..Z,a..z range - // - used e.g. by HexToBin() function - // - is defined globally, since may be used from an inlined function - ConvertHexToBin: TNormTableByte; - - /// naive but efficient cache to avoid string memory allocation for - // 0..999 small numbers by Int32ToUTF8/UInt32ToUTF8 - // - use around 16KB of heap (since each item consumes 16 bytes), but increase - // overall performance and reduce memory allocation (and fragmentation), - // especially during multi-threaded execution - // - noticeable when strings are used as array indexes (e.g. in SynMongoDB BSON) - // - is defined globally, since may be used from an inlined function - SmallUInt32UTF8: array[0..999] of RawUTF8; - -/// fast conversion from hexa chars into binary data -// - BinBytes contain the bytes count to be converted: Hex^ must contain -// at least BinBytes*2 chars to be converted, and Bin^ enough space -// - if Bin=nil, no output data is written, but the Hex^ format is checked -// - return false if any invalid (non hexa) char is found in Hex^ -// - using this function with Bin^ as an integer value will decode in big-endian -// order (most-signignifican byte first) -function HexToBin(Hex: PAnsiChar; Bin: PByte; BinBytes: Integer): boolean; overload; - -/// fast conversion with no validity check from hexa chars into binary data -procedure HexToBinFast(Hex: PAnsiChar; Bin: PByte; BinBytes: Integer); - -/// conversion from octal C-like escape into binary data -// - \xxx is converted into a single xxx byte from octal, and \\ into \ -// - will stop the conversion when Oct^=#0 or when invalid \xxx is reached -// - returns the number of bytes written to Bin^ -function OctToBin(Oct: PAnsiChar; Bin: PByte): PtrInt; overload; - -/// conversion from octal C-like escape into binary data -// - \xxx is converted into a single xxx byte from octal, and \\ into \ -function OctToBin(const Oct: RawUTF8): RawByteString; overload; - -/// fast conversion from one hexa char pair into a 8 bit AnsiChar -// - return false if any invalid (non hexa) char is found in Hex^ -// - similar to HexToBin(Hex,nil,1) -function HexToCharValid(Hex: PAnsiChar): boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// fast check if the supplied Hex buffer is an hexadecimal representation -// of a binary buffer of a given number of bytes -function IsHex(const Hex: RawByteString; BinBytes: integer): boolean; - -/// fast conversion from one hexa char pair into a 8 bit AnsiChar -// - return false if any invalid (non hexa) char is found in Hex^ -// - similar to HexToBin(Hex,Bin,1) but with Bin<>nil -// - use HexToCharValid if you want to check a hexadecimal char content -function HexToChar(Hex: PAnsiChar; Bin: PUTF8Char): boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// fast conversion from two hexa bytes into a 16 bit UTF-16 WideChar -// - similar to HexToBin(Hex,@wordvar,2) + bswap(wordvar) -function HexToWideChar(Hex: PAnsiChar): cardinal; - {$ifdef HASINLINE}inline;{$endif} - -/// fast conversion from binary data into hexa chars -// - BinBytes contain the bytes count to be converted: Hex^ must contain -// enough space for at least BinBytes*2 chars -// - using this function with BinBytes^ as an integer value will encode it -// in low-endian order (less-signignifican byte first): don't use it for display -procedure BinToHex(Bin, Hex: PAnsiChar; BinBytes: integer); overload; - -/// fast conversion from hexa chars into binary data -function HexToBin(const Hex: RawUTF8): RawByteString; overload; - -/// fast conversion from binary data into hexa chars -function BinToHex(const Bin: RawByteString): RawUTF8; overload; - -/// fast conversion from binary data into hexa chars -function BinToHex(Bin: PAnsiChar; BinBytes: integer): RawUTF8; overload; - -/// fast conversion from binary data into hexa chars, ready to be displayed -// - BinBytes contain the bytes count to be converted: Hex^ must contain -// enough space for at least BinBytes*2 chars -// - using this function with Bin^ as an integer value will encode it -// in big-endian order (most-signignifican byte first): use it for display -procedure BinToHexDisplay(Bin, Hex: PAnsiChar; BinBytes: integer); overload; - -/// fast conversion from binary data into hexa chars, ready to be displayed -function BinToHexDisplay(Bin: PAnsiChar; BinBytes: integer): RawUTF8; overload; - -/// fast conversion from binary data into lowercase hexa chars -// - BinBytes contain the bytes count to be converted: Hex^ must contain -// enough space for at least BinBytes*2 chars -// - using this function with BinBytes^ as an integer value will encode it -// in low-endian order (less-signignifican byte first): don't use it for display -procedure BinToHexLower(Bin, Hex: PAnsiChar; BinBytes: integer); overload; - -/// fast conversion from binary data into lowercase hexa chars -function BinToHexLower(const Bin: RawByteString): RawUTF8; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// fast conversion from binary data into lowercase hexa chars -function BinToHexLower(Bin: PAnsiChar; BinBytes: integer): RawUTF8; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// fast conversion from binary data into lowercase hexa chars -procedure BinToHexLower(Bin: PAnsiChar; BinBytes: integer; var result: RawUTF8); overload; - -/// fast conversion from binary data into lowercase hexa chars -// - BinBytes contain the bytes count to be converted: Hex^ must contain -// enough space for at least BinBytes*2 chars -// - using this function with Bin^ as an integer value will encode it -// in big-endian order (most-signignifican byte first): use it for display -procedure BinToHexDisplayLower(Bin, Hex: PAnsiChar; BinBytes: PtrInt); overload; - -/// fast conversion from binary data into lowercase hexa chars -function BinToHexDisplayLower(Bin: PAnsiChar; BinBytes: integer): RawUTF8; overload; - -/// fast conversion from up to 127 bytes of binary data into lowercase hexa chars -function BinToHexDisplayLowerShort(Bin: PAnsiChar; BinBytes: integer): shortstring; - -/// fast conversion from up to 64-bit of binary data into lowercase hexa chars -function BinToHexDisplayLowerShort16(Bin: Int64; BinBytes: integer): TShort16; - -/// fast conversion from binary data into hexa lowercase chars, ready to be -// used as a convenient TFileName prefix -function BinToHexDisplayFile(Bin: PAnsiChar; BinBytes: integer): TFileName; - -/// append one byte as hexadecimal char pairs, into a text buffer -function ByteToHex(P: PAnsiChar; Value: byte): PAnsiChar; - -/// fast conversion from binary data to escaped text -// - non printable characters will be written as $xx hexadecimal codes -// - will be #0 terminated, with '...' characters trailing on overflow -// - ensure the destination buffer contains at least max*3+3 bytes, which is -// always the case when using LogEscape() and its local TLogEscape variable -function EscapeBuffer(s,d: PAnsiChar; len,max: integer): PAnsiChar; - -const - /// maximum size, in bytes, of a TLogEscape / LogEscape() buffer - LOGESCAPELEN = 200; -type - /// buffer to be allocated on stack when using LogEscape() - TLogEscape = array[0..LOGESCAPELEN*3+5] of AnsiChar; - -/// fill TLogEscape stack buffer with the (hexadecimal) chars of the input binary -// - up to LOGESCAPELEN (i.e. 200) bytes will be escaped and appended to a -// Local temp: TLogEscape variable, using the EscapeBuffer() low-level function -// - you can then log the resulting escaped text by passing the returned -// PAnsiChar as % parameter to a TSynLog.Log() method -// - the "enabled" parameter can be assigned from a process option, avoiding to -// process the escape if verbose logs are disabled -// - used e.g. to implement logBinaryFrameContent option for WebSockets -function LogEscape(source: PAnsiChar; sourcelen: integer; var temp: TLogEscape; - enabled: boolean=true): PAnsiChar; - {$ifdef HASINLINE}inline;{$endif} - -/// returns a text buffer with the (hexadecimal) chars of the input binary -// - is much slower than LogEscape/EscapeToShort, but has no size limitation -function LogEscapeFull(source: PAnsiChar; sourcelen: integer): RawUTF8; overload; - -/// returns a text buffer with the (hexadecimal) chars of the input binary -// - is much slower than LogEscape/EscapeToShort, but has no size limitation -function LogEscapeFull(const source: RawByteString): RawUTF8; overload; - -/// fill a shortstring with the (hexadecimal) chars of the input text/binary -function EscapeToShort(source: PAnsiChar; sourcelen: integer): shortstring; overload; - -/// fill a shortstring with the (hexadecimal) chars of the input text/binary -function EscapeToShort(const source: RawByteString): shortstring; overload; - -/// fast conversion from a pointer data into hexa chars, ready to be displayed -// - use internally BinToHexDisplay() -function PointerToHex(aPointer: Pointer): RawUTF8; overload; - -/// fast conversion from a pointer data into hexa chars, ready to be displayed -// - use internally BinToHexDisplay() -procedure PointerToHex(aPointer: Pointer; var result: RawUTF8); overload; - -/// fast conversion from a pointer data into hexa chars, ready to be displayed -// - use internally BinToHexDisplay() -// - such result type would avoid a string allocation on heap -function PointerToHexShort(aPointer: Pointer): TShort16; overload; - -/// fast conversion from a Cardinal value into hexa chars, ready to be displayed -// - use internally BinToHexDisplay() -// - reverse function of HexDisplayToCardinal() -function CardinalToHex(aCardinal: Cardinal): RawUTF8; - -/// fast conversion from a Cardinal value into hexa chars, ready to be displayed -// - use internally BinToHexDisplayLower() -// - reverse function of HexDisplayToCardinal() -function CardinalToHexLower(aCardinal: Cardinal): RawUTF8; - -/// fast conversion from a Cardinal value into hexa chars, ready to be displayed -// - use internally BinToHexDisplay() -// - such result type would avoid a string allocation on heap -function CardinalToHexShort(aCardinal: Cardinal): TShort16; - -/// fast conversion from a Int64 value into hexa chars, ready to be displayed -// - use internally BinToHexDisplay() -// - reverse function of HexDisplayToInt64() -function Int64ToHex(aInt64: Int64): RawUTF8; overload; - -/// fast conversion from a Int64 value into hexa chars, ready to be displayed -// - use internally BinToHexDisplay() -// - reverse function of HexDisplayToInt64() -procedure Int64ToHex(aInt64: Int64; var result: RawUTF8); overload; - -/// fast conversion from a Int64 value into hexa chars, ready to be displayed -// - use internally BinToHexDisplay() -// - such result type would avoid a string allocation on heap -procedure Int64ToHexShort(aInt64: Int64; out result: TShort16); overload; - -/// fast conversion from a Int64 value into hexa chars, ready to be displayed -// - use internally BinToHexDisplay() -// - such result type would avoid a string allocation on heap -function Int64ToHexShort(aInt64: Int64): TShort16; overload; - -/// fast conversion from a Int64 value into hexa chars, ready to be displayed -// - use internally BinToHexDisplay() -// - reverse function of HexDisplayToInt64() -function Int64ToHexString(aInt64: Int64): string; - -/// fast conversion from hexa chars into a binary buffer -function HexDisplayToBin(Hex: PAnsiChar; Bin: PByte; BinBytes: integer): boolean; - -/// fast conversion from hexa chars into a cardinal -// - reverse function of CardinalToHex() -// - returns false and set aValue=0 if Hex is not a valid hexadecimal 32-bit -// unsigned integer -// - returns true and set aValue with the decoded number, on success -function HexDisplayToCardinal(Hex: PAnsiChar; out aValue: cardinal): boolean; - {$ifndef FPC}{$ifdef HASINLINE}inline;{$endif}{$endif} - // inline gives an error under release conditions with FPC - -/// fast conversion from hexa chars into a cardinal -// - reverse function of Int64ToHex() -// - returns false and set aValue=0 if Hex is not a valid hexadecimal 64-bit -// signed integer -// - returns true and set aValue with the decoded number, on success -function HexDisplayToInt64(Hex: PAnsiChar; out aValue: Int64): boolean; overload; - {$ifndef FPC}{$ifdef HASINLINE}inline;{$endif}{$endif} - { inline gives an error under release conditions with FPC } - -/// fast conversion from hexa chars into a cardinal -// - reverse function of Int64ToHex() -// - returns 0 if the supplied text buffer is not a valid hexadecimal 64-bit -// signed integer -function HexDisplayToInt64(const Hex: RawByteString): Int64; overload; - {$ifdef HASINLINE}inline;{$endif} - - -/// fast conversion from binary data into Base64 encoded UTF-8 text -function BinToBase64(const s: RawByteString): RawUTF8; overload; - -/// fast conversion from binary data into Base64 encoded UTF-8 text -function BinToBase64(Bin: PAnsiChar; BinBytes: integer): RawUTF8; overload; - -/// fast conversion from a small binary data into Base64 encoded UTF-8 text -function BinToBase64Short(const s: RawByteString): shortstring; overload; - -/// fast conversion from a small binary data into Base64 encoded UTF-8 text -function BinToBase64Short(Bin: PAnsiChar; BinBytes: integer): shortstring; overload; - -/// fast conversion from binary data into prefixed/suffixed Base64 encoded UTF-8 text -// - with optional JSON_BASE64_MAGIC prefix (UTF-8 encoded \uFFF0 special code) -function BinToBase64(const data, Prefix, Suffix: RawByteString; WithMagic: boolean): RawUTF8; overload; - -/// fast conversion from binary data into Base64 encoded UTF-8 text -// with JSON_BASE64_MAGIC prefix (UTF-8 encoded \uFFF0 special code) -function BinToBase64WithMagic(const data: RawByteString): RawUTF8; overload; - -/// fast conversion from binary data into Base64 encoded UTF-8 text -// with JSON_BASE64_MAGIC prefix (UTF-8 encoded \uFFF0 special code) -function BinToBase64WithMagic(Data: pointer; DataLen: integer): RawUTF8; overload; - -/// fast conversion from Base64 encoded text into binary data -// - is now just an alias to Base64ToBinSafe() overloaded function -// - returns '' if s was not a valid Base64-encoded input -function Base64ToBin(const s: RawByteString): RawByteString; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// fast conversion from Base64 encoded text into binary data -// - is now just an alias to Base64ToBinSafe() overloaded function -// - returns '' if sp/len buffer was not a valid Base64-encoded input -function Base64ToBin(sp: PAnsiChar; len: PtrInt): RawByteString; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// fast conversion from Base64 encoded text into binary data -// - is now just an alias to Base64ToBinSafe() overloaded function -// - returns false and data='' if sp/len buffer was invalid -function Base64ToBin(sp: PAnsiChar; len: PtrInt; var data: RawByteString): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// fast conversion from Base64 encoded text into binary data -// - returns TRUE on success, FALSE if sp/len buffer was invvalid -function Base64ToBin(sp: PAnsiChar; len: PtrInt; var Blob: TSynTempBuffer): boolean; overload; - -/// fast conversion from Base64 encoded text into binary data -// - returns TRUE on success, FALSE if base64 does not match binlen -// - nofullcheck is deprecated and not used any more, since nofullcheck=false -// is now processed with no performance cost -function Base64ToBin(base64, bin: PAnsiChar; base64len, binlen: PtrInt; - nofullcheck: boolean=true): boolean; overload; - -/// fast conversion from Base64 encoded text into binary data -// - returns TRUE on success, FALSE if base64 does not match binlen -// - nofullcheck is deprecated and not used any more, since nofullcheck=false -// is now processed with no performance cost -function Base64ToBin(const base64: RawByteString; bin: PAnsiChar; binlen: PtrInt; - nofullcheck: boolean=true): boolean; overload; - -/// fast conversion from Base64 encoded text into binary data -// - will check supplied text is a valid Base64 encoded stream -function Base64ToBinSafe(const s: RawByteString): RawByteString; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// fast conversion from Base64 encoded text into binary data -// - will check supplied text is a valid Base64 encoded stream -function Base64ToBinSafe(sp: PAnsiChar; len: PtrInt): RawByteString; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// fast conversion from Base64 encoded text into binary data -// - will check supplied text is a valid Base64 encoded stream -function Base64ToBinSafe(sp: PAnsiChar; len: PtrInt; var data: RawByteString): boolean; overload; - -/// just a wrapper around Base64ToBin() for in-place decode of JSON_BASE64_MAGIC -// '\uFFF0base64encodedbinary' content into binary -// - input ParamValue shall have been checked to match the expected pattern -procedure Base64MagicDecode(var ParamValue: RawUTF8); - -/// check and decode '\uFFF0base64encodedbinary' content into binary -// - this method will check the supplied value to match the expected -// JSON_BASE64_MAGIC pattern, decode and set Blob and return TRUE -function Base64MagicCheckAndDecode(Value: PUTF8Char; var Blob: RawByteString): boolean; overload; - -/// check and decode '\uFFF0base64encodedbinary' content into binary -// - this method will check the supplied value to match the expected -// JSON_BASE64_MAGIC pattern, decode and set Blob and return TRUE -function Base64MagicCheckAndDecode(Value: PUTF8Char; ValueLen: Integer; - var Blob: RawByteString): boolean; overload; - -/// check and decode '\uFFF0base64encodedbinary' content into binary -// - this method will check the supplied value to match the expected -// JSON_BASE64_MAGIC pattern, decode and set Blob and return TRUE -function Base64MagicCheckAndDecode(Value: PUTF8Char; var Blob: TSynTempBuffer): boolean; overload; - -/// check if the supplied text is a valid Base64 encoded stream -function IsBase64(const s: RawByteString): boolean; overload; - -/// check if the supplied text is a valid Base64 encoded stream -function IsBase64(sp: PAnsiChar; len: PtrInt): boolean; overload; - -/// retrieve the expected encoded length after Base64 process -function BinToBase64Length(len: PtrUInt): PtrUInt; - {$ifdef HASINLINE}inline;{$endif} - -/// retrieve the expected undecoded length of a Base64 encoded buffer -// - here len is the number of bytes in sp -function Base64ToBinLength(sp: PAnsiChar; len: PtrInt): PtrInt; - -/// retrieve the expected undecoded length of a Base64 encoded buffer -// - here len is the number of bytes in sp -// - will check supplied text is a valid Base64 encoded stream -function Base64ToBinLengthSafe(sp: PAnsiChar; len: PtrInt): PtrInt; - -/// direct low-level decoding of a Base64 encoded buffer -// - here len is the number of 4 chars chunks in sp input -// - deprecated low-level function: use Base64ToBin/Base64ToBinSafe instead -function Base64Decode(sp,rp: PAnsiChar; len: PtrInt): boolean; - -/// fast conversion from binary data into Base64-like URI-compatible encoded text -// - in comparison to Base64 standard encoding, will trim any right-sided '=' -// unsignificant characters, and replace '+' or '/' by '_' or '-' -function BinToBase64uri(const s: RawByteString): RawUTF8; overload; - -/// fast conversion from a binary buffer into Base64-like URI-compatible encoded text -// - in comparison to Base64 standard encoding, will trim any right-sided '=' -// unsignificant characters, and replace '+' or '/' by '_' or '-' -function BinToBase64uri(Bin: PAnsiChar; BinBytes: integer): RawUTF8; overload; - -/// fast conversion from a binary buffer into Base64-like URI-compatible encoded shortstring -// - in comparison to Base64 standard encoding, will trim any right-sided '=' -// unsignificant characters, and replace '+' or '/' by '_' or '-' -// - returns '' if BinBytes void or too big for the resulting shortstring -function BinToBase64uriShort(Bin: PAnsiChar; BinBytes: integer): shortstring; - -/// conversion from any Base64 encoded value into URI-compatible encoded text -// - warning: will modify the supplied base64 string in-place -// - in comparison to Base64 standard encoding, will trim any right-sided '=' -// unsignificant characters, and replace '+' or '/' by '_' or '-' -procedure Base64ToURI(var base64: RawUTF8); - -/// low-level conversion from a binary buffer into Base64-like URI-compatible encoded text -// - you should rather use the overloaded BinToBase64uri() functions -procedure Base64uriEncode(rp, sp: PAnsiChar; len: cardinal); - -/// retrieve the expected encoded length after Base64-URI process -// - in comparison to Base64 standard encoding, will trim any right-sided '=' -// unsignificant characters, and replace '+' or '/' by '_' or '-' -function BinToBase64uriLength(len: PtrUInt): PtrUInt; - {$ifdef HASINLINE}inline;{$endif} - -/// retrieve the expected undecoded length of a Base64-URI encoded buffer -// - here len is the number of bytes in sp -// - in comparison to Base64 standard encoding, will trim any right-sided '=' -// unsignificant characters, and replace '+' or '/' by '_' or '-' -function Base64uriToBinLength(len: PtrInt): PtrInt; - -/// fast conversion from Base64-URI encoded text into binary data -// - in comparison to Base64 standard encoding, will trim any right-sided '=' -// unsignificant characters, and replace '+' or '/' by '_' or '-' -function Base64uriToBin(sp: PAnsiChar; len: PtrInt): RawByteString; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// fast conversion from Base64-URI encoded text into binary data -// - in comparison to Base64 standard encoding, will trim any right-sided '=' -// unsignificant characters, and replace '+' or '/' by '_' or '-' -procedure Base64uriToBin(sp: PAnsiChar; len: PtrInt; var result: RawByteString); overload; - -/// fast conversion from Base64-URI encoded text into binary data -// - caller should always execute temp.Done when finished with the data -// - in comparison to Base64 standard encoding, will trim any right-sided '=' -// unsignificant characters, and replace '+' or '/' by '_' or '-' -function Base64uriToBin(sp: PAnsiChar; len: PtrInt; var temp: TSynTempBuffer): boolean; overload; - -/// fast conversion from Base64-URI encoded text into binary data -// - in comparison to Base64 standard encoding, will trim any right-sided '=' -// unsignificant characters, and replace '+' or '/' by '_' or '-' -function Base64uriToBin(const s: RawByteString): RawByteString; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// fast conversion from Base64-URI encoded text into binary data -// - in comparison to Base64 standard encoding, will trim any right-sided '=' -// unsignificant characters, and replace '+' or '/' by '_' or '-' -// - will check supplied text is a valid Base64-URI encoded stream -function Base64uriToBin(base64, bin: PAnsiChar; base64len, binlen: PtrInt): boolean; overload; - -/// fast conversion from Base64-URI encoded text into binary data -// - in comparison to Base64 standard encoding, will trim any right-sided '=' -// unsignificant characters, and replace '+' or '/' by '_' or '-' -// - will check supplied text is a valid Base64-URI encoded stream -function Base64uriToBin(const base64: RawByteString; bin: PAnsiChar; binlen: PtrInt): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// direct low-level decoding of a Base64-URI encoded buffer -// - the buffer is expected to be at least Base64uriToBinLength() bytes long -// - returns true if the supplied sp[] buffer has been successfully decoded -// into rp[] - will break at any invalid character, so is always safe to use -// - in comparison to Base64 standard encoding, will trim any right-sided '=' -// unsignificant characters, and replace '+' or '/' by '_' or '-' -// - you should better not use this, but Base64uriToBin() overloaded functions -function Base64uriDecode(sp,rp: PAnsiChar; len: PtrInt): boolean; - - -/// generate some pascal source code holding some data binary as constant -// - can store sensitive information (e.g. certificates) within the executable -// - generates a source code snippet of the following format: -// ! const -// ! // Comment -// ! ConstName: array[0..2] of byte = ( -// ! $01,$02,$03); -procedure BinToSource(Dest: TTextWriter; const ConstName, Comment: RawUTF8; - Data: pointer; Len: integer; PerLine: integer=16); overload; - -/// generate some pascal source code holding some data binary as constant -// - can store sensitive information (e.g. certificates) within the executable -// - generates a source code snippet of the following format: -// ! const -// ! // Comment -// ! ConstName: array[0..2] of byte = ( -// ! $01,$02,$03); -function BinToSource(const ConstName, Comment: RawUTF8; Data: pointer; - Len: integer; PerLine: integer=16; const Suffix: RawUTF8=''): RawUTF8; overload; - - -/// revert the value as encoded by TTextWriter.AddInt18ToChars3() or Int18ToChars3() -// - no range check is performed: you should ensure that the incoming text -// follows the expected 3-chars layout -function Chars3ToInt18(P: pointer): cardinal; - {$ifdef HASINLINE}inline;{$endif} - -/// compute the value as encoded by TTextWriter.AddInt18ToChars3() method -function Int18ToChars3(Value: cardinal): RawUTF8; overload; - -/// compute the value as encoded by TTextWriter.AddInt18ToChars3() method -procedure Int18ToChars3(Value: cardinal; var result: RawUTF8); overload; - -/// add the 4 digits of integer Y to P^ as '0000'..'9999' -procedure YearToPChar(Y: PtrUInt; P: PUTF8Char); - {$ifdef PUREPASCAL} {$ifdef HASINLINE}inline;{$endif} {$endif} - -/// creates a 3 digits string from a 0..999 value as '000'..'999' -// - consider using UInt3DigitsToShort() to avoid temporary memory allocation, -// e.g. when used as FormatUTF8() parameter -function UInt3DigitsToUTF8(Value: Cardinal): RawUTF8; - {$ifdef HASINLINE}inline;{$endif} - -/// creates a 4 digits string from a 0..9999 value as '0000'..'9999' -// - consider using UInt4DigitsToShort() to avoid temporary memory allocation, -// e.g. when used as FormatUTF8() parameter -function UInt4DigitsToUTF8(Value: Cardinal): RawUTF8; - {$ifdef HASINLINE}inline;{$endif} - -type - /// used e.g. by UInt4DigitsToShort/UInt3DigitsToShort/UInt2DigitsToShort - // - such result type would avoid a string allocation on heap - TShort4 = string[4]; - -/// creates a 4 digits short string from a 0..9999 value -// - using TShort4 as returned string would avoid a string allocation on heap -// - could be used e.g. as parameter to FormatUTF8() -function UInt4DigitsToShort(Value: Cardinal): TShort4; - {$ifdef HASINLINE}inline;{$endif} - -/// creates a 3 digits short string from a 0..999 value -// - using TShort4 as returned string would avoid a string allocation on heap -// - could be used e.g. as parameter to FormatUTF8() -function UInt3DigitsToShort(Value: Cardinal): TShort4; - {$ifdef HASINLINE}inline;{$endif} - -/// creates a 2 digits short string from a 0..99 value -// - using TShort4 as returned string would avoid a string allocation on heap -// - could be used e.g. as parameter to FormatUTF8() -function UInt2DigitsToShort(Value: byte): TShort4; - {$ifdef HASINLINE}inline;{$endif} - -/// creates a 2 digits short string from a 0..99 value -// - won't test Value>99 as UInt2DigitsToShort() -function UInt2DigitsToShortFast(Value: byte): TShort4; - {$ifdef HASINLINE}inline;{$endif} - - -/// compute CRC16-CCITT checkum on the supplied buffer -// - i.e. 16-bit CRC-CCITT, with polynomial x^16 + x^12 + x^5 + 1 ($1021) -// and $ffff as initial value -// - this version is not optimized for speed, but for correctness -function crc16(Data: PAnsiChar; Len: integer): cardinal; - -// our custom efficient 32-bit hash/checksum function -// - a Fletcher-like checksum algorithm, not a hash function: has less colisions -// than Adler32 for short strings, but more than xxhash32 or crc32/crc32c -// - written in simple plain pascal, with no L1 CPU cache pollution, but we -// also provide optimized x86/x64 assembly versions, since the algorithm is used -// heavily e.g. for TDynArray binary serialization, TSQLRestStorageInMemory -// binary persistence, or CompressSynLZ/StreamSynLZ/FileSynLZ -// - some numbers on Linux x86_64: -// $ 2500 hash32 in 707us i.e. 3536067/s or 7.3 GB/s -// $ 2500 xxhash32 in 1.34ms i.e. 1861504/s or 3.8 GB/s -// $ 2500 crc32c in 943us i.e. 2651113/s or 5.5 GB/s (SSE4.2 disabled) -// $ 2500 crc32c in 387us i.e. 6459948/s or 13.4 GB/s (SSE4.2 enabled) -function Hash32(Data: PCardinalArray; Len: integer): cardinal; overload; - -// our custom efficient 32-bit hash/checksum function -// - a Fletcher-like checksum algorithm, not a hash function: has less colisions -// than Adler32 for short strings, but more than xxhash32 or crc32/crc32c -// - overloaded function using RawByteString for binary content hashing, -// whatever the codepage is -function Hash32(const Text: RawByteString): cardinal; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// standard Kernighan & Ritchie hash from "The C programming Language", 3rd edition -// - simple and efficient code, but too much collisions for THasher -// - kr32() is 898.8 MB/s - crc32cfast() 1.7 GB/s, crc32csse42() 4.3 GB/s -function kr32(crc: cardinal; buf: PAnsiChar; len: PtrInt): cardinal; - -/// simple FNV-1a hashing function -// - when run over our regression suite, is similar to crc32c() about collisions, -// and 4 times better than kr32(), but also slower than the others -// - fnv32() is 715.5 MB/s - kr32() 898.8 MB/s -// - this hash function should not be usefull, unless you need several hashing -// algorithms at once (e.g. if crc32c with diverse seeds is not enough) -function fnv32(crc: cardinal; buf: PAnsiChar; len: PtrInt): cardinal; - -/// perform very fast xxHash hashing in 32-bit mode -// - will use optimized asm for x86/x64, or a pascal version on other CPUs -function xxHash32(crc: cardinal; P: PAnsiChar; len: integer): cardinal; - -type - TCrc32tab = array[0..7,byte] of cardinal; - PCrc32tab = ^TCrc32tab; - -var - /// tables used by crc32cfast() function - // - created with a polynom diverse from zlib's crc32() algorithm, but - // compatible with SSE 4.2 crc32 instruction - // - tables content is created from code in initialization section below - // - will also be used internally by SymmetricEncrypt, FillRandom and - // TSynUniqueIdentifierGenerator as 1KB master/reference key tables - crc32ctab: TCrc32tab; - -/// compute CRC32C checksum on the supplied buffer on processor-neutral code -// - result is compatible with SSE 4.2 based hardware accelerated instruction -// - will use fast x86/x64 asm or efficient pure pascal implementation on ARM -// - result is not compatible with zlib's crc32() - not the same polynom -// - crc32cfast() is 1.7 GB/s, crc32csse42() is 4.3 GB/s -// - you should use crc32c() function instead of crc32cfast() or crc32csse42() -function crc32cfast(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal; - -/// compute CRC32C checksum on the supplied buffer using inlined code -// - if the compiler supports inlining, will compute a slow but safe crc32c -// checksum of the binary buffer, without calling the main crc32c() function -// - may be used e.g. to identify patched executable at runtime, for a licensing -// protection system -function crc32cinlined(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal; - {$ifdef HASINLINE}inline;{$endif} - -/// compute CRC64C checksum on the supplied buffer, cascading two crc32c -// - will use SSE 4.2 hardware accelerated instruction, if available -// - will combine two crc32c() calls into a single Int64 result -// - by design, such combined hashes cannot be cascaded -function crc64c(buf: PAnsiChar; len: cardinal): Int64; - -/// compute CRC63C checksum on the supplied buffer, cascading two crc32c -// - similar to crc64c, but with 63-bit, so no negative value: may be used -// safely e.g. as mORMot's TID source -// - will use SSE 4.2 hardware accelerated instruction, if available -// - will combine two crc32c() calls into a single Int64 result -// - by design, such combined hashes cannot be cascaded -function crc63c(buf: PAnsiChar; len: cardinal): Int64; - -type - /// binary access to an unsigned 32-bit value (4 bytes in memory) - TDWordRec = record - case integer of - 0: (V: DWord); - 1: (L,H: word); - 2: (B: array[0..3] of byte); - end; - /// points to the binary of an unsigned 32-bit value - PDWordRec = ^TDWordRec; - - /// binary access to an unsigned 64-bit value (8 bytes in memory) - TQWordRec = record - case integer of - 0: (V: Qword); - 1: (L,H: cardinal); - 2: (W: array[0..3] of word); - 3: (B: array[0..7] of byte); - end; - /// points to the binary of an unsigned 64-bit value - PQWordRec = ^TQWordRec; - - /// store a 128-bit hash value - // - e.g. a MD5 digest, or array[0..3] of cardinal (TBlock128) - // - consumes 16 bytes of memory - THash128 = array[0..15] of byte; - /// pointer to a 128-bit hash value - PHash128 = ^THash128; - /// store a 160-bit hash value - // - e.g. a SHA-1 digest - // - consumes 20 bytes of memory - THash160 = array[0..19] of byte; - /// pointer to a 160-bit hash value - PHash160 = ^THash160; - /// store a 192-bit hash value - // - consumes 24 bytes of memory - THash192 = array[0..23] of byte; - /// pointer to a 192-bit hash value - PHash192 = ^THash192; - /// store a 256-bit hash value - // - e.g. a SHA-256 digest, a TECCSignature result, or array[0..7] of cardinal - // - consumes 32 bytes of memory - THash256 = array[0..31] of byte; - /// pointer to a 256-bit hash value - PHash256 = ^THash256; - /// store a 384-bit hash value - // - e.g. a SHA-384 digest - // - consumes 48 bytes of memory - THash384 = array[0..47] of byte; - /// pointer to a 384-bit hash value - PHash384 = ^THash384; - /// store a 512-bit hash value - // - e.g. a SHA-512 digest, a TECCSignature result, or array[0..15] of cardinal - // - consumes 64 bytes of memory - THash512 = array[0..63] of byte; - /// pointer to a 512-bit hash value - PHash512 = ^THash512; - - /// store a 128-bit buffer - // - e.g. an AES block - // - consumes 16 bytes of memory - TBlock128 = array[0..3] of cardinal; - /// pointer to a 128-bit buffer - PBlock128 = ^TBlock128; - - /// map an infinite array of 128-bit hash values - // - each item consumes 16 bytes of memory - THash128Array = array[0..(maxInt div SizeOf(THash128))-1] of THash128; - /// pointer to an infinite array of 128-bit hash values - PHash128Array = ^THash128Array; - /// store several 128-bit hash values - // - e.g. MD5 digests - // - consumes 16 bytes of memory per item - THash128DynArray = array of THash128; - /// map a 128-bit hash as an array of lower bit size values - // - consumes 16 bytes of memory - THash128Rec = packed record - case integer of - 0: (Lo,Hi: Int64); - 1: (L,H: QWord); - 2: (i0,i1,i2,i3: integer); - 3: (c0,c1,c2,c3: cardinal); - 4: (c: TBlock128); - 5: (b: THash128); - 6: (w: array[0..7] of word); - 7: (l64,h64: Int64Rec); - end; - /// pointer to 128-bit hash map variable record - PHash128Rec = ^THash128Rec; - - /// map an infinite array of 256-bit hash values - // - each item consumes 32 bytes of memory - THash256Array = array[0..(maxInt div SizeOf(THash256))-1] of THash256; - /// pointer to an infinite array of 256-bit hash values - PHash256Array = ^THash256Array; - /// store several 256-bit hash values - // - e.g. SHA-256 digests, TECCSignature results, or array[0..7] of cardinal - // - consumes 32 bytes of memory per item - THash256DynArray = array of THash256; - /// map a 256-bit hash as an array of lower bit size values - // - consumes 32 bytes of memory - THash256Rec = packed record - case integer of - 0: (Lo,Hi: THash128); - 1: (d0,d1,d2,d3: Int64); - 2: (i0,i1,i2,i3,i4,i5,i6,i7: integer); - 3: (c0,c1: TBlock128); - 4: (b: THash256); - 5: (q: array[0..3] of QWord); - 6: (c: array[0..7] of cardinal); - 7: (w: array[0..15] of word); - 8: (l,h: THash128Rec); - end; - /// pointer to 256-bit hash map variable record - PHash256Rec = ^THash256Rec; - - /// map an infinite array of 512-bit hash values - // - each item consumes 64 bytes of memory - THash512Array = array[0..(maxInt div SizeOf(THash512))-1] of THash512; - /// pointer to an infinite array of 512-bit hash values - PHash512Array = ^THash512Array; - /// store several 512-bit hash values - // - e.g. SHA-512 digests, or array[0..15] of cardinal - // - consumes 64 bytes of memory per item - THash512DynArray = array of THash512; - /// map a 512-bit hash as an array of lower bit size values - // - consumes 64 bytes of memory - THash512Rec = packed record - case integer of - 0: (Lo,Hi: THash256); - 1: (h0,h1,h2,h3: THash128); - 2: (d0,d1,d2,d3,d4,d5,d6,d7: Int64); - 3: (i0,i1,i2,i3,i4,i5,i6,i7,i8,i9,i10,i11,i12,i13,i14,i15: integer); - 4: (c0,c1,c2,c3: TBlock128); - 5: (b: THash512); - 6: (b160: THash160); - 7: (b384: THash384); - 8: (w: array[0..31] of word); - 9: (c: array[0..15] of cardinal); - 10: (i: array[0..7] of Int64); - 11: (r: array[0..3] of THash128Rec); - 12: (l,h: THash256Rec); - end; - /// pointer to 512-bit hash map variable record - PHash512Rec = ^THash512Rec; - -/// compute a 128-bit checksum on the supplied buffer, cascading two crc32c -// - will use SSE 4.2 hardware accelerated instruction, if available -// - will combine two crc32c() calls into a single TAESBlock result -// - by design, such combined hashes cannot be cascaded -procedure crc128c(buf: PAnsiChar; len: cardinal; out crc: THash128); - -/// compute a proprietary 128-bit CRC of 128-bit binary buffers -// - to be used for regression tests only: crcblocks will use the fastest -// implementation available on the current CPU (e.g. with SSE 4.2 opcodes) -procedure crcblocksfast(crc128, data128: PBlock128; count: integer); - -/// compute a proprietary 128-bit CRC of 128-bit binary buffers -// - apply four crc32c() calls on the 128-bit input chunks, into a 128-bit crc -// - its output won't match crc128c() value, which works on 8-bit input -// - will use SSE 4.2 hardware accelerated instruction, if available -// - is used e.g. by SynEcc's TECDHEProtocol.ComputeMAC for macCrc128c -var crcblocks: procedure(crc128, data128: PBlock128; count: integer)=crcblocksfast; - -/// computation of our 128-bit CRC of a 128-bit binary buffer without SSE4.2 -// - to be used for regression tests only: crcblock will use the fastest -// implementation available on the current CPU (e.g. with SSE 4.2 opcodes) -procedure crcblockNoSSE42(crc128, data128: PBlock128); - -/// compute a proprietary 128-bit CRC of a 128-bit binary buffer -// - apply four crc32c() calls on the 128-bit input chunk, into a 128-bit crc -// - its output won't match crc128c() value, which works on 8-bit input -// - will use SSE 4.2 hardware accelerated instruction, if available -// - is used e.g. by SynCrypto's TAESCFBCRC to check for data integrity -var crcblock: procedure(crc128, data128: PBlock128) = crcblockNoSSE42; - -/// returns TRUE if all 16 bytes of this 128-bit buffer equal zero -// - e.g. a MD5 digest, or an AES block -function IsZero(const dig: THash128): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// returns TRUE if all 16 bytes of both 128-bit buffers do match -// - e.g. a MD5 digest, or an AES block -// - this function is not sensitive to any timing attack, so is designed -// for cryptographic purpose - and it is also branchless therefore fast -function IsEqual(const A,B: THash128): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// fill all 16 bytes of this 128-bit buffer with zero -// - may be used to cleanup stack-allocated content -// ! ... finally FillZero(digest); end; -procedure FillZero(out dig: THash128); overload; - -/// fast O(n) search of a 128-bit item in an array of such values -function Hash128Index(P: PHash128Rec; Count: integer; h: PHash128Rec): integer; - {$ifdef CPU64} inline; {$endif} - -/// convert a 32-bit integer (storing a IP4 address) into its full notation -// - returns e.g. '1.2.3.4' for any valid address, or '' if ip4=0 -function IP4Text(ip4: cardinal): shortstring; overload; - -/// convert a 128-bit buffer (storing an IP6 address) into its full notation -// - returns e.g. '2001:0db8:0a0b:12f0:0000:0000:0000:0001' -function IP6Text(ip6: PHash128): shortstring; overload; {$ifdef HASINLINE}inline;{$endif} - -/// convert a 128-bit buffer (storing an IP6 address) into its full notation -// - returns e.g. '2001:0db8:0a0b:12f0:0000:0000:0000:0001' -procedure IP6Text(ip6: PHash128; result: PShortString); overload; - -/// compute a 256-bit checksum on the supplied buffer using crc32c -// - will use SSE 4.2 hardware accelerated instruction, if available -// - will combine two crc32c() calls into a single THash256 result -// - by design, such combined hashes cannot be cascaded -procedure crc256c(buf: PAnsiChar; len: cardinal; out crc: THash256); - -/// returns TRUE if all 20 bytes of this 160-bit buffer equal zero -// - e.g. a SHA-1 digest -function IsZero(const dig: THash160): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// returns TRUE if all 20 bytes of both 160-bit buffers do match -// - e.g. a SHA-1 digest -// - this function is not sensitive to any timing attack, so is designed -// for cryptographic purpose -function IsEqual(const A,B: THash160): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// fill all 20 bytes of this 160-bit buffer with zero -// - may be used to cleanup stack-allocated content -// ! ... finally FillZero(digest); end; -procedure FillZero(out dig: THash160); overload; - -/// returns TRUE if all 32 bytes of this 256-bit buffer equal zero -// - e.g. a SHA-256 digest, or a TECCSignature result -function IsZero(const dig: THash256): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// returns TRUE if all 32 bytes of both 256-bit buffers do match -// - e.g. a SHA-256 digest, or a TECCSignature result -// - this function is not sensitive to any timing attack, so is designed -// for cryptographic purpose -function IsEqual(const A,B: THash256): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// fill all 32 bytes of this 256-bit buffer with zero -// - may be used to cleanup stack-allocated content -// ! ... finally FillZero(digest); end; -procedure FillZero(out dig: THash256); overload; - -/// fast O(n) search of a 256-bit item in an array of such values -function Hash256Index(P: PHash256Rec; Count: integer; h: PHash256Rec): integer; overload; - -/// returns TRUE if all 48 bytes of this 384-bit buffer equal zero -// - e.g. a SHA-384 digest -function IsZero(const dig: THash384): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// returns TRUE if all 48 bytes of both 384-bit buffers do match -// - e.g. a SHA-384 digest -// - this function is not sensitive to any timing attack, so is designed -// for cryptographic purpose -function IsEqual(const A,B: THash384): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// fill all 32 bytes of this 384-bit buffer with zero -// - may be used to cleanup stack-allocated content -// ! ... finally FillZero(digest); end; -procedure FillZero(out dig: THash384); overload; - -/// returns TRUE if all 64 bytes of this 512-bit buffer equal zero -// - e.g. a SHA-512 digest -function IsZero(const dig: THash512): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// returns TRUE if all 64 bytes of both 512-bit buffers do match -// - e.g. two SHA-512 digests -// - this function is not sensitive to any timing attack, so is designed -// for cryptographic purpose -function IsEqual(const A,B: THash512): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// fill all 64 bytes of this 512-bit buffer with zero -// - may be used to cleanup stack-allocated content -// ! ... finally FillZero(digest); end; -procedure FillZero(out dig: THash512); overload; - -/// compute a 512-bit checksum on the supplied buffer using crc32c -// - will use SSE 4.2 hardware accelerated instruction, if available -// - will combine two crc32c() calls into a single THash512 result -// - by design, such combined hashes cannot be cascaded -procedure crc512c(buf: PAnsiChar; len: cardinal; out crc: THash512); - -/// fill all bytes of this memory buffer with zeros, i.e. 'toto' -> #0#0#0#0 -// - will write the memory buffer directly, so if this string instance is shared -// (i.e. has refcount>1), all other variables will contains zeros -// - may be used to cleanup stack-allocated content -// ! ... finally FillZero(secret); end; -procedure FillZero(var secret: RawByteString); overload; - {$ifdef FPC}inline;{$endif} - -/// fill all bytes of this UTF-8 string with zeros, i.e. 'toto' -> #0#0#0#0 -// - will write the memory buffer directly, so if this string instance is shared -// (i.e. has refcount>1), all other variables will contains zeros -// - may be used to cleanup stack-allocated content -// ! ... finally FillZero(secret); end; -procedure FillZero(var secret: RawUTF8); overload; - {$ifdef FPC}inline;{$endif} - -/// fill all bytes of a memory buffer with zero -// - just redirect to FillCharFast(..,...,0) -procedure FillZero(var dest; count: PtrInt); overload; - {$ifdef HASINLINE}inline;{$endif} - -/// returns TRUE if all bytes of both buffers do match -// - this function is not sensitive to any timing attack, so is designed -// for cryptographic purposes - use CompareMem/CompareMemSmall/CompareMemFixed -// as faster alternatives for general-purpose code -function IsEqual(const A,B; count: PtrInt): boolean; overload; - -/// fast computation of two 64-bit unsigned integers into a 128-bit value -procedure mul64x64(const left, right: QWord; out product: THash128Rec); - {$ifndef CPUINTEL}inline;{$endif} - -type - /// the potential features, retrieved from an Intel CPU - // - see https://en.wikipedia.org/wiki/CPUID#EAX.3D1:_Processor_Info_and_Feature_Bits - // - is defined on all platforms, since an ARM desktop could browse Intel logs - TIntelCpuFeature = ( - { CPUID 1 in EDX } - cfFPU, cfVME, cfDE, cfPSE, cfTSC, cfMSR, cfPAE, cfMCE, - cfCX8, cfAPIC, cf_d10, cfSEP, cfMTRR, cfPGE, cfMCA, cfCMOV, - cfPAT, cfPSE36, cfPSN, cfCLFSH, cf_d20, cfDS, cfACPI, cfMMX, - cfFXSR, cfSSE, cfSSE2, cfSS, cfHTT, cfTM, cfIA64, cfPBE, - { CPUID 1 in ECX } - cfSSE3, cfCLMUL, cfDS64, cfMON, cfDSCPL, cfVMX, cfSMX, cfEST, - cfTM2, cfSSSE3, cfCID, cfSDBG, cfFMA, cfCX16, cfXTPR, cfPDCM, - cf_c16, cfPCID, cfDCA, cfSSE41, cfSSE42, cfX2A, cfMOVBE, cfPOPCNT, - cfTSC2, cfAESNI, cfXS, cfOSXS, cfAVX, cfF16C, cfRAND, cfHYP, - { extended features CPUID 7 in EBX, ECX, EDX } - cfFSGS, cfTSCADJ, cfSGX, cfBMI1, cfHLE, cfAVX2, cfFDPEO, cfSMEP, - cfBMI2, cfERMS, cfINVPCID, cfRTM, cfPQM, cf_b13, cfMPX, cfPQE, - cfAVX512F, cfAVX512DQ, cfRDSEED, cfADX, cfSMAP, cfAVX512IFMA, cfPCOMMIT, cfCLFLUSH, - cfCLWB, cfIPT, cfAVX512PF, cfAVX512ER, cfAVX512CD, cfSHA, cfAVX512BW, cfAVX512VL, - cfPREFW1, cfAVX512VBMI, cfUMIP, cfPKU, cfOSPKE, cf_c05, cfAVX512VBMI2, cfCETSS, - cfGFNI, cfVAES, cfVCLMUL, cfAVX512NNI, cfAVX512BITALG, cf_c13, cfAVX512VPC, cf_c15, - cfFLP, cf_c17, cf_c18, cf_c19, cf_c20, cf_c21, cfRDPID, cf_c23, - cf_c24, cfCLDEMOTE, cf_c26, cfMOVDIRI, cfMOVDIR64B, cfENQCMD, cfSGXLC, cfPKS, - cf_d0, cf_d1, cfAVX512NNIW, cfAVX512MAPS, cfFSRM, cf_d5, cf_d6, cf_d7, - cfAVX512VP2I, cfSRBDS, cfMDCLR, cf_d11, cf_d12, cfTSXFA, cfSER, cfHYBRID, - cfTSXLDTRK, cf_d17, cfPCFG, cfLBR, cfIBT, cf_d21, cfAMXBF16, cf_d23, - cfAMXTILE, cfAMXINT8, cfIBRSPB, cfSTIBP, cfL1DFL, cfARCAB, cfCORCAB, cfSSBD); - - /// all features, as retrieved from an Intel CPU - TIntelCpuFeatures = set of TIntelCpuFeature; - -/// convert Intel CPU features as plain CSV text -function ToText(const aIntelCPUFeatures: TIntelCpuFeatures; - const Sep: RawUTF8=','): RawUTF8; overload; - -{$ifdef CPUINTEL} -var - /// the available CPU features, as recognized at program startup - CpuFeatures: TIntelCpuFeatures; - -/// compute CRC32C checksum on the supplied buffer using SSE 4.2 -// - use Intel Streaming SIMD Extensions 4.2 hardware accelerated instruction -// - SSE 4.2 shall be available on the processor (i.e. cfSSE42 in CpuFeatures) -// - result is not compatible with zlib's crc32() - not the same polynom -// - crc32cfast() is 1.7 GB/s, crc32csse42() is 4.3 GB/s -// - you should use crc32c() function instead of crc32cfast() or crc32csse42() -function crc32csse42(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal; -{$endif CPUINTEL} - -/// naive symmetric encryption scheme using a 32-bit key -// - fast, but not very secure, since uses crc32ctab[] content as master cypher -// key: consider using SynCrypto proven AES-based algorithms instead -procedure SymmetricEncrypt(key: cardinal; var data: RawByteString); - -type - TCrc32cBy4 = function(crc, value: cardinal): cardinal; - -var - /// compute CRC32C checksum on the supplied buffer - // - result is not compatible with zlib's crc32() - Intel/SCSI CRC32C is not - // the same polynom - but will use the fastest mean available, e.g. SSE 4.2, - // to achieve up to 16GB/s with the optimized implementation from SynCrypto.pas - // - you should use this function instead of crc32cfast() or crc32csse42() - crc32c: THasher; - /// compute CRC32C checksum on one 32-bit unsigned integer - // - can be used instead of crc32c() for inlined process during data acquisition - // - doesn't make "crc := not crc" before and after the computation: caller has - // to start with "crc := cardinal(not 0)" and make "crc := not crc" at the end, - // to compute the very same hash value than regular crc32c() - // - this variable will use the fastest mean available, e.g. SSE 4.2 - crc32cBy4: TCrc32cBy4; - -/// compute the hexadecimal representation of the crc32 checkum of a given text -// - wrapper around CardinalToHex(crc32c(...)) -function crc32cUTF8ToHex(const str: RawUTF8): RawUTF8; - -var - /// the default hasher used by TDynArrayHashed - // - set to crc32csse42() if SSE4.2 instructions are available on this CPU, - // or fallback to xxHash32() which performs better than crc32cfast() - DefaultHasher: THasher; - - /// the hash function used by TRawUTF8Interning - // - set to crc32csse42() if SSE4.2 instructions are available on this CPU, - // or fallback to xxHash32() which performs better than crc32cfast() - InterningHasher: THasher; - -/// retrieve a particular bit status from a bit array -// - this function can't be inlined, whereas GetBitPtr() function can -function GetBit(const Bits; aIndex: PtrInt): boolean; - -/// set a particular bit into a bit array -// - this function can't be inlined, whereas SetBitPtr() function can -procedure SetBit(var Bits; aIndex: PtrInt); - -/// unset/clear a particular bit into a bit array -// - this function can't be inlined, whereas UnSetBitPtr() function can -procedure UnSetBit(var Bits; aIndex: PtrInt); - -/// retrieve a particular bit status from a bit array -// - GetBit() can't be inlined, whereas this pointer-oriented function can -function GetBitPtr(Bits: pointer; aIndex: PtrInt): boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// set a particular bit into a bit array -// - SetBit() can't be inlined, whereas this pointer-oriented function can -procedure SetBitPtr(Bits: pointer; aIndex: PtrInt); - {$ifdef HASINLINE}inline;{$endif} - -/// unset/clear a particular bit into a bit array -// - UnSetBit() can't be inlined, whereas this pointer-oriented function can -procedure UnSetBitPtr(Bits: pointer; aIndex: PtrInt); - {$ifdef HASINLINE}inline;{$endif} - -/// compute the number of bits set in a bit array -// - Count is the bit count, not byte size -// - will use fast SSE4.2 popcnt instruction if available on the CPU -function GetBitsCount(const Bits; Count: PtrInt): PtrInt; - -/// pure pascal version of GetBitsCountPtrInt() -// - defined just for regression tests - call GetBitsCountPtrInt() instead -// - has optimized asm on x86_64 and i386 -function GetBitsCountPas(value: PtrInt): PtrInt; - -/// compute how many bits are set in a given pointer-sized integer -// - the PopCnt() intrinsic under FPC doesn't have any fallback on older CPUs, -// and default implementation is 5 times slower than our GetBitsCountPas() on x64 -// - this redirected function will use fast SSE4.2 popcnt opcode, if available -var GetBitsCountPtrInt: function(value: PtrInt): PtrInt = GetBitsCountPas; - -const - /// constant array used by GetAllBits() function (when inlined) - ALLBITS_CARDINAL: array[1..32] of Cardinal = ( - 1 shl 1-1, 1 shl 2-1, 1 shl 3-1, 1 shl 4-1, 1 shl 5-1, 1 shl 6-1, - 1 shl 7-1, 1 shl 8-1, 1 shl 9-1, 1 shl 10-1, 1 shl 11-1, 1 shl 12-1, - 1 shl 13-1, 1 shl 14-1, 1 shl 15-1, 1 shl 16-1, 1 shl 17-1, 1 shl 18-1, - 1 shl 19-1, 1 shl 20-1, 1 shl 21-1, 1 shl 22-1, 1 shl 23-1, 1 shl 24-1, - 1 shl 25-1, 1 shl 26-1, 1 shl 27-1, 1 shl 28-1, 1 shl 29-1, 1 shl 30-1, - $7fffffff, $ffffffff); - -/// returns TRUE if all BitCount bits are set in the input 32-bit cardinal -function GetAllBits(Bits, BitCount: cardinal): boolean; - {$ifdef HASINLINE}inline;{$endif} - -type - /// fast access to 8-bit integer bits - // - the compiler will generate bt/btr/bts opcodes - TBits8 = set of 0..7; - PBits8 = ^TBits8; - TBits8Array = array[0..maxInt-1] of TBits8; - /// fast access to 32-bit integer bits - // - the compiler will generate bt/btr/bts opcodes - TBits32 = set of 0..31; - PBits32 = ^TBits32; - /// fast access to 64-bit integer bits - // - the compiler will generate bt/btr/bts opcodes - // - as used by GetBit64/SetBit64/UnSetBit64 - TBits64 = set of 0..63; - PBits64 = ^TBits64; - -/// retrieve a particular bit status from a 64-bit integer bits (max aIndex is 63) -function GetBit64(const Bits: Int64; aIndex: PtrInt): boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// set a particular bit into a 64-bit integer bits (max aIndex is 63) -procedure SetBit64(var Bits: Int64; aIndex: PtrInt); - {$ifdef HASINLINE}inline;{$endif} - -/// unset/clear a particular bit into a 64-bit integer bits (max aIndex is 63) -procedure UnSetBit64(var Bits: Int64; aIndex: PtrInt); - {$ifdef HASINLINE}inline;{$endif} - -/// logical OR of two memory buffers -// - will perform on all buffer bytes: -// ! Dest[i] := Dest[i] or Source[i]; -procedure OrMemory(Dest,Source: PByteArray; size: PtrInt); - {$ifdef HASINLINE}inline;{$endif} - -/// logical XOR of two memory buffers -// - will perform on all buffer bytes: -// ! Dest[i] := Dest[i] xor Source[i]; -procedure XorMemory(Dest,Source: PByteArray; size: PtrInt); overload; - {$ifdef HASINLINE}inline;{$endif} - -/// logical XOR of two memory buffers into a third -// - will perform on all buffer bytes: -// ! Dest[i] := Source1[i] xor Source2[i]; -procedure XorMemory(Dest,Source1,Source2: PByteArray; size: PtrInt); overload; - {$ifdef HASINLINE}inline;{$endif} - -/// logical AND of two memory buffers -// - will perform on all buffer bytes: -// ! Dest[i] := Dest[i] and Source[i]; -procedure AndMemory(Dest,Source: PByteArray; size: PtrInt); - {$ifdef HASINLINE}inline;{$endif} - -/// returns TRUE if all bytes equal zero -function IsZero(P: pointer; Length: integer): boolean; overload; - -/// returns TRUE if all of a few bytes equal zero -// - to be called instead of IsZero() e.g. for 1..8 bytes -function IsZeroSmall(P: pointer; Length: PtrInt): boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// returns TRUE if Value is nil or all supplied Values[] equal '' -function IsZero(const Values: TRawUTF8DynArray): boolean; overload; - -/// returns TRUE if Value is nil or all supplied Values[] equal 0 -function IsZero(const Values: TIntegerDynArray): boolean; overload; - -/// returns TRUE if Value is nil or all supplied Values[] equal 0 -function IsZero(const Values: TInt64DynArray): boolean; overload; - -/// fill all entries of a supplied array of RawUTF8 with '' -procedure FillZero(var Values: TRawUTF8DynArray); overload; - -/// fill all entries of a supplied array of 32-bit integers with 0 -procedure FillZero(var Values: TIntegerDynArray); overload; - -/// fill all entries of a supplied array of 64-bit integers with 0 -procedure FillZero(var Values: TInt64DynArray); overload; - - -/// name the current thread so that it would be easily identified in the IDE debugger -procedure SetCurrentThreadName(const Format: RawUTF8; const Args: array of const); - -/// name a thread so that it would be easily identified in the IDE debugger -// - you can force this function to do nothing by setting the NOSETTHREADNAME -// conditional, if you have issues with this feature when debugging your app -// - most meanling less characters (like 'TSQL') are trimmed to reduce the -// resulting length - which is convenient e.g. with POSIX truncation to 16 chars -procedure SetThreadName(ThreadID: TThreadID; const Format: RawUTF8; - const Args: array of const); - -/// could be used to override SetThreadNameInternal() -// - under Linux/FPC, calls pthread_setname_np API which truncates to 16 chars -procedure SetThreadNameDefault(ThreadID: TThreadID; const Name: RawUTF8); - -var - /// is overriden e.g. by mORMot.pas to log the thread name - SetThreadNameInternal: procedure(ThreadID: TThreadID; const Name: RawUTF8) = SetThreadNameDefault; - - - -/// low-level wrapper to add a callback to a dynamic list of events -// - by default, you can assign only one callback to an Event: but by storing -// it as a dynamic array of events, you can use this wrapper to add one callback -// to this list of events -// - if the event was already registered, do nothing (i.e. won't call it twice) -// - since this function uses an unsafe typeless EventList parameter, you should -// not use it in high-level code, but only as wrapper within dedicated methods -// - will add Event to EventList[] unless Event is already registered -// - is used e.g. by TTextWriter as such: -// ! ... -// ! fEchos: array of TOnTextWriterEcho; -// ! ... -// ! procedure EchoAdd(const aEcho: TOnTextWriterEcho); -// ! ... -// ! procedure TTextWriter.EchoAdd(const aEcho: TOnTextWriterEcho); -// ! begin -// ! MultiEventAdd(fEchos,TMethod(aEcho)); -// ! end; -// then callbacks are then executed as such: -// ! if fEchos<>nil then -// ! for i := 0 to length(fEchos)-1 do -// ! fEchos[i](self,fEchoBuf); -// - use MultiEventRemove() to un-register a callback from the list -function MultiEventAdd(var EventList; const Event: TMethod): boolean; - -/// low-level wrapper to remove a callback from a dynamic list of events -// - by default, you can assign only one callback to an Event: but by storing -// it as a dynamic array of events, you can use this wrapper to remove one -// callback already registered by MultiEventAdd() to this list of events -// - since this function uses an unsafe typeless EventList parameter, you should -// not use it in high-level code, but only as wrapper within dedicated methods -// - is used e.g. by TTextWriter as such: -// ! ... -// ! fEchos: array of TOnTextWriterEcho; -// ! ... -// ! procedure EchoRemove(const aEcho: TOnTextWriterEcho); -// ! ... -// ! procedure TTextWriter.EchoRemove(const aEcho: TOnTextWriterEcho); -// ! begin -// ! MultiEventRemove(fEchos,TMethod(aEcho)); -// ! end; -procedure MultiEventRemove(var EventList; const Event: TMethod); overload; - -/// low-level wrapper to remove a callback from a dynamic list of events -// - same as the same overloaded procedure, but accepting an EventList[] index -// to identify the Event to be suppressed -procedure MultiEventRemove(var EventList; Index: Integer); overload; - -/// low-level wrapper to check if a callback is in a dynamic list of events -// - by default, you can assign only one callback to an Event: but by storing -// it as a dynamic array of events, you can use this wrapper to check if -// a callback has already been registered to this list of events -// - used internally by MultiEventAdd() and MultiEventRemove() functions -function MultiEventFind(const EventList; const Event: TMethod): integer; - -/// low-level wrapper to add one or several callbacks from another list of events -// - all events of the ToBeAddedList would be added to DestList -// - the list is not checked for duplicates -procedure MultiEventMerge(var DestList; const ToBeAddedList); - -/// compare two TMethod instances -function EventEquals(const eventA,eventB): boolean; - - -{ ************ fast ISO-8601 types and conversion routines ***************** } - -type - /// a type alias, which will be serialized as ISO-8601 with milliseconds - // - i.e. 'YYYY-MM-DD hh:mm:ss.sss' or 'YYYYMMDD hhmmss.sss' format - TDateTimeMS = type TDateTime; - - /// a dynamic array of TDateTimeMS values - TDateTimeMSDynArray = array of TDateTimeMS; - PDateTimeMSDynArray = ^TDateTimeMSDynArray; - - {$A-} - /// a simple way to store a date as Year/Month/Day - // - with no needed computation as with TDate/TUnixTime values - // - consider using TSynSystemTime if you need to handle both Date and Time - // - match the first 4 fields of TSynSystemTime - so PSynDate(@aSynSystemTime)^ - // is safe to be used - // - DayOfWeek field is not handled by its methods by default, but could be - // filled on demand via ComputeDayOfWeek - making this record 64-bit long - // - some Delphi revisions have trouble with "object" as own method parameters - // (e.g. IsEqual) so we force to use "record" type if possible - {$ifdef USERECORDWITHMETHODS}TSynDate = record{$else} - TSynDate = object{$endif} - Year, Month, DayOfWeek, Day: word; - /// set all fields to 0 - procedure Clear; {$ifdef HASINLINE}inline;{$endif} - /// set internal date to 9999-12-31 - procedure SetMax; {$ifdef HASINLINE}inline;{$endif} - /// returns true if all fields are zero - function IsZero: boolean; {$ifdef HASINLINE}inline;{$endif} - /// try to parse a YYYY-MM-DD or YYYYMMDD ISO-8601 date from the supplied buffer - // - on success, move P^ just after the date, and return TRUE - function ParseFromText(var P: PUTF8Char): boolean; {$ifdef HASINLINE}inline;{$endif} - /// fill fields with the current UTC/local date, using a 8-16ms thread-safe cache - procedure FromNow(localtime: boolean=false); - /// fill fields with the supplied date - procedure FromDate(date: TDate); - /// returns true if all fields do match - ignoring DayOfWeek field value - function IsEqual({$ifdef FPC}constref{$else}const{$endif} another{$ifndef DELPHI5OROLDER}: TSynDate{$endif}): boolean; - /// compare the stored value to a supplied value - // - returns <0 if the stored value is smaller than the supplied value, - // 0 if both are equals, and >0 if the stored value is bigger - // - DayOfWeek field value is not compared - function Compare({$ifdef FPC}constref{$else}const{$endif} another{$ifndef DELPHI5OROLDER}: TSynDate{$endif}): integer; - {$ifdef HASINLINE}inline;{$endif} - /// fill the DayOfWeek field from the stored Year/Month/Day - // - by default, most methods will just store 0 in the DayOfWeek field - // - sunday is DayOfWeek 1, saturday is 7 - procedure ComputeDayOfWeek; - /// convert the stored date into a Delphi TDate floating-point value - function ToDate: TDate; {$ifdef HASINLINE}inline;{$endif} - /// encode the stored date as ISO-8601 text - // - returns '' if the stored date is 0 (i.e. after Clear) - function ToText(Expanded: boolean=true): RawUTF8; - end; - /// store several dates as Year/Month/Day - TSynDateDynArray = array of TSynDate; - /// a pointer to a TSynDate instance - PSynDate = ^TSynDate; - - /// a cross-platform and cross-compiler TSystemTime 128-bit structure - // - FPC's TSystemTime in datih.inc does NOT match Windows TSystemTime fields! - // - also used to store a Date/Time in TSynTimeZone internal structures, or - // for fast conversion from TDateTime to its ready-to-display members - // - DayOfWeek field is not handled by most methods by default (left as 0), - // but could be filled on demand via ComputeDayOfWeek into its 1..7 value - // - some Delphi revisions have trouble with "object" as own method parameters - // (e.g. IsEqual) so we force to use "record" type if possible - {$ifdef USERECORDWITHMETHODS}TSynSystemTime = record{$else} - TSynSystemTime = object{$endif} - public - Year, Month, DayOfWeek, Day, - Hour, Minute, Second, MilliSecond: word; - /// set all fields to 0 - procedure Clear; {$ifdef HASINLINE}inline;{$endif} - /// returns true if all fields are zero - function IsZero: boolean; {$ifdef HASINLINE}inline;{$endif} - /// returns true if all fields do match - function IsEqual(const another{$ifndef DELPHI5OROLDER}: TSynSystemTime{$endif}): boolean; - /// returns true if date fields do match (ignoring DayOfWeek) - function IsDateEqual(const date{$ifndef DELPHI5OROLDER}: TSynDate{$endif}): boolean; - /// used by TSynTimeZone - function EncodeForTimeChange(const aYear: word): TDateTime; - /// fill fields with the current UTC time, using a 8-16ms thread-safe cache - procedure FromNowUTC; - /// fill fields with the current Local time, using a 8-16ms thread-safe cache - procedure FromNowLocal; - /// fill fields from the given value - but not DayOfWeek - procedure FromDateTime(const dt: TDateTime); - /// fill Year/Month/Day fields from the given value - but not DayOfWeek - // - faster than the RTL DecodeDate() function - procedure FromDate(const dt: TDateTime); - /// fill Hour/Minute/Second/Millisecond fields from the given number of milliseconds - // - faster than the RTL DecodeTime() function - procedure FromMS(ms: PtrUInt); - /// fill Hour/Minute/Second/Millisecond fields from the given number of seconds - // - faster than the RTL DecodeTime() function - procedure FromSec(s: PtrUInt); - /// fill Hour/Minute/Second/Millisecond fields from the given TDateTime value - // - faster than the RTL DecodeTime() function - procedure FromTime(const dt: TDateTime); - /// fill Year/Month/Day and Hour/Minute/Second fields from the given ISO-8601 text - // - returns true on success - function FromText(const iso: RawUTF8): boolean; - /// encode the stored date/time as ISO-8601 text with Milliseconds - function ToText(Expanded: boolean=true; FirstTimeChar: AnsiChar='T'; const TZD: RawUTF8=''): RawUTF8; - /// append the stored date and time, in a log-friendly format - // - e.g. append '20110325 19241502' - with no trailing space nor tab - // - as called by TTextWriter.AddCurrentLogTime() - procedure AddLogTime(WR: TTextWriter); - /// append the stored date and time, in apache-like format, to a TTextWriter - // - e.g. append '19/Feb/2019:06:18:55 ' - including a trailing space - procedure AddNCSAText(WR: TTextWriter); - /// append the stored date and time, in apache-like format, to a memory buffer - // - e.g. append '19/Feb/2019:06:18:55 ' - including a trailing space - // - returns the number of chars added to P, i.e. always 21 - function ToNCSAText(P: PUTF8Char): PtrInt; - /// convert the stored date and time to its text in HTTP-like format - // - i.e. "Tue, 15 Nov 1994 12:45:26 GMT" to be used as a value of - // "Date", "Expires" or "Last-Modified" HTTP header - // - handle UTC/GMT time zone by default - procedure ToHTTPDate(out text: RawUTF8; const tz: RawUTF8='GMT'); - /// convert the stored date and time into its Iso-8601 text, with no Milliseconds - procedure ToIsoDateTime(out text: RawUTF8; const FirstTimeChar: AnsiChar='T'); - /// convert the stored date into its Iso-8601 text with no time part - procedure ToIsoDate(out text: RawUTF8); - /// convert the stored time into its Iso-8601 text with no date part nor Milliseconds - procedure ToIsoTime(out text: RawUTF8; const FirstTimeChar: RawUTF8='T'); - /// convert the stored time into a TDateTime - function ToDateTime: TDateTime; - /// copy Year/Month/DayOfWeek/Day fields to a TSynDate - procedure ToSynDate(out date: TSynDate); {$ifdef HASINLINE}inline;{$endif} - /// fill the DayOfWeek field from the stored Year/Month/Day - // - by default, most methods will just store 0 in the DayOfWeek field - // - sunday is DayOfWeek 1, saturday is 7 - procedure ComputeDayOfWeek; {$ifdef HASINLINE}inline;{$endif} - /// add some 1..999 milliseconds to the stored time - // - not to be used for computation, but e.g. for fast AddLogTime generation - procedure IncrementMS(ms: integer); - end; - PSynSystemTime = ^TSynSystemTime; - {$A+} - - /// fast bit-encoded date and time value - // - faster than Iso-8601 text and TDateTime, e.g. can be used as published - // property field in mORMot's TSQLRecord (see also TModTime and TCreateTime) - // - use internally for computation an abstract "year" of 16 months of 32 days - // of 32 hours of 64 minutes of 64 seconds - same as Iso8601ToTimeLog() - // - use TimeLogFromDateTime/TimeLogToDateTime/TimeLogNow functions, or - // type-cast any TTimeLog value with the TTimeLogBits memory structure for - // direct access to its bit-oriented content (or via PTimeLogBits pointer) - // - since TTimeLog type is bit-oriented, you can't just add or substract two - // TTimeLog values when doing date/time computation: use a TDateTime temporary - // conversion in such case: - // ! aTimestamp := TimeLogFromDateTime(IncDay(TimeLogToDateTime(aTimestamp))); - TTimeLog = type Int64; - - /// dynamic array of TTimeLog - // - used by TDynArray JSON serialization to handle textual serialization - TTimeLogDynArray = array of TTimeLog; - - /// pointer to a memory structure for direct access to a TTimeLog type value - PTimeLogBits = ^TTimeLogBits; - - /// internal memory structure for direct access to a TTimeLog type value - // - most of the time, you should not use this object, but higher level - // TimeLogFromDateTime/TimeLogToDateTime/TimeLogNow/Iso8601ToTimeLog functions - // - since TTimeLogBits.Value is bit-oriented, you can't just add or substract - // two TTimeLog values when doing date/time computation: use a TDateTime - // temporary conversion in such case - // - TTimeLogBits.Value needs up to 40-bit precision, so features exact - // representation as JavaScript numbers (stored in a 52-bit mantissa) - TTimeLogBits = object - public - /// the bit-encoded value itself, which follows an abstract "year" of 16 - // months of 32 days of 32 hours of 64 minutes of 64 seconds - // - bits 0..5 = Seconds (0..59) - // - bits 6..11 = Minutes (0..59) - // - bits 12..16 = Hours (0..23) - // - bits 17..21 = Day-1 (0..31) - // - bits 22..25 = Month-1 (0..11) - // - bits 26..40 = Year (0..9999) - Value: Int64; - /// extract the date and time content in Value into individual values - procedure Expand(out Date: TSynSystemTime); - /// convert to Iso-8601 encoded text, truncated to date/time only if needed - function Text(Expanded: boolean; FirstTimeChar: AnsiChar = 'T'): RawUTF8; overload; - /// convert to Iso-8601 encoded text, truncated to date/time only if needed - function Text(Dest: PUTF8Char; Expanded: boolean; - FirstTimeChar: AnsiChar = 'T'): integer; overload; - /// convert to Iso-8601 encoded text with date and time part - // - never truncate to date/time nor return '' as Text() does - function FullText(Expanded: boolean; FirstTimeChar: AnsiChar = 'T'; - QuotedChar: AnsiChar = #0): RawUTF8; overload; - {$ifdef FPC}inline;{$endif} // URW1111 on Delphi 2010 and URW1136 on XE - /// convert to Iso-8601 encoded text with date and time part - // - never truncate to date/time or return '' as Text() does - function FullText(Dest: PUTF8Char; Expanded: boolean; - FirstTimeChar: AnsiChar = 'T'; QuotedChar: AnsiChar = #0): PUTF8Char; overload; - /// convert to ready-to-be displayed text - // - using i18nDateText global event, if set (e.g. by mORMoti18n.pas) - function i18nText: string; - /// convert to a Delphi Time - function ToTime: TDateTime; - /// convert to a Delphi Date - // - will return 0 if the stored value is not a valid date - function ToDate: TDateTime; - /// convert to a Delphi Date and Time - // - will return 0 if the stored value is not a valid date - function ToDateTime: TDateTime; - /// convert to a second-based c-encoded time (from Unix epoch 1/1/1970) - function ToUnixTime: TUnixTime; - /// convert to a millisecond-based c-encoded time (from Unix epoch 1/1/1970) - // - of course, milliseconds will be 0 due to TTimeLog second resolution - function ToUnixMSTime: TUnixMSTime; - /// fill Value from specified Date and Time - procedure From(Y,M,D, HH,MM,SS: cardinal); overload; - /// fill Value from specified TDateTime - procedure From(DateTime: TDateTime; DateOnly: Boolean=false); overload; - /// fill Value from specified File Date - procedure From(FileDate: integer); overload; - /// fill Value from Iso-8601 encoded text - procedure From(P: PUTF8Char; L: integer); overload; {$ifdef HASINLINE}inline;{$endif} - /// fill Value from Iso-8601 encoded text - procedure From(const S: RawUTF8); overload; - /// fill Value from specified Date/Time individual fields - procedure From(Time: PSynSystemTime); overload; - /// fill Value from second-based c-encoded time (from Unix epoch 1/1/1970) - procedure FromUnixTime(const UnixTime: TUnixTime); - /// fill Value from millisecond-based c-encoded time (from Unix epoch 1/1/1970) - // - of course, millisecond resolution will be lost during conversion - procedure FromUnixMSTime(const UnixMSTime: TUnixMSTime); - /// fill Value from current local system Date and Time - procedure FromNow; - /// fill Value from current UTC system Date and Time - // - FromNow uses local time: this function retrieves the system time - // expressed in Coordinated Universal Time (UTC) - procedure FromUTCTime; - /// get the year (e.g. 2015) of the TTimeLog value - function Year: Integer; {$ifdef HASINLINE}inline;{$endif} - /// get the month (1..12) of the TTimeLog value - function Month: Integer; {$ifdef HASINLINE}inline;{$endif} - /// get the day (1..31) of the TTimeLog value - function Day: Integer; {$ifdef HASINLINE}inline;{$endif} - /// get the hour (0..23) of the TTimeLog value - function Hour: integer; {$ifdef HASINLINE}inline;{$endif} - /// get the minute (0..59) of the TTimeLog value - function Minute: integer; {$ifdef HASINLINE}inline;{$endif} - /// get the second (0..59) of the TTimeLog value - function Second: integer; {$ifdef HASINLINE}inline;{$endif} - end; - -/// get TTimeLog value from current local system date and time -// - handle TTimeLog bit-encoded Int64 format -function TimeLogNow: TTimeLog; - {$ifdef HASINLINE}inline;{$endif} - -/// get TTimeLog value from current UTC system Date and Time -// - handle TTimeLog bit-encoded Int64 format -function TimeLogNowUTC: TTimeLog; - {$ifdef HASINLINE}inline;{$endif} - -/// get TTimeLog value from a file date and time -// - handle TTimeLog bit-encoded Int64 format -function TimeLogFromFile(const FileName: TFileName): TTimeLog; - -/// get TTimeLog value from a given Delphi date and time -// - handle TTimeLog bit-encoded Int64 format -// - just a wrapper around PTimeLogBits(@aTime)^.From() -// - we defined such a function since TTimeLogBits(aTimeLog).From() won't change -// the aTimeLog variable content -function TimeLogFromDateTime(const DateTime: TDateTime): TTimeLog; - {$ifdef HASINLINE}inline;{$endif} - -/// get TTimeLog value from a given Unix seconds since epoch timestamp -// - handle TTimeLog bit-encoded Int64 format -// - just a wrapper around PTimeLogBits(@aTime)^.FromUnixTime() -function TimeLogFromUnixTime(const UnixTime: TUnixTime): TTimeLog; - {$ifdef HASINLINE}inline;{$endif} - -/// Date/Time conversion from a TTimeLog value -// - handle TTimeLog bit-encoded Int64 format -// - just a wrapper around PTimeLogBits(@Timestamp)^.ToDateTime -// - we defined such a function since TTimeLogBits(aTimeLog).ToDateTime gives an -// internall compiler error on some Delphi IDE versions (e.g. Delphi 6) -function TimeLogToDateTime(const Timestamp: TTimeLog): TDateTime; - {$ifdef HASINLINE}inline;{$endif} - -/// Unix seconds since epoch timestamp conversion from a TTimeLog value -// - handle TTimeLog bit-encoded Int64 format -// - just a wrapper around PTimeLogBits(@Timestamp)^.ToUnixTime -function TimeLogToUnixTime(const Timestamp: TTimeLog): TUnixTime; - {$ifdef HASINLINE}inline;{$endif} - -/// convert a Iso8601 encoded string into a TTimeLog value -// - handle TTimeLog bit-encoded Int64 format -// - use this function only for fast comparison between two Iso8601 date/time -// - conversion is faster than Iso8601ToDateTime: use only binary integer math -// - ContainsNoTime optional pointer can be set to a boolean, which will be -// set according to the layout in P (e.g. TRUE for '2012-05-26') -// - returns 0 in case of invalid input string -function Iso8601ToTimeLogPUTF8Char(P: PUTF8Char; L: integer; ContainsNoTime: PBoolean=nil): TTimeLog; - -/// convert a Iso8601 encoded string into a TTimeLog value -// - handle TTimeLog bit-encoded Int64 format -// - use this function only for fast comparison between two Iso8601 date/time -// - conversion is faster than Iso8601ToDateTime: use only binary integer math -function Iso8601ToTimeLog(const S: RawByteString): TTimeLog; - {$ifdef PUREPASCAL} {$ifdef HASINLINE}inline;{$endif} {$endif} - -/// test if P^ contains a valid ISO-8601 text encoded value -// - calls internally Iso8601ToTimeLogPUTF8Char() and returns true if contains -// at least a valid year (YYYY) -function IsIso8601(P: PUTF8Char; L: integer): boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// Date/Time conversion from ISO-8601 -// - handle 'YYYYMMDDThhmmss' and 'YYYY-MM-DD hh:mm:ss' format -// - will also recognize '.sss' milliseconds suffix, if any -function Iso8601ToDateTime(const S: RawByteString): TDateTime; overload; - {$ifdef PUREPASCAL} {$ifdef HASINLINE}inline;{$endif} {$endif} - -/// Date/Time conversion from ISO-8601 -// - handle 'YYYYMMDDThhmmss' and 'YYYY-MM-DD hh:mm:ss' format -// - will also recognize '.sss' milliseconds suffix, if any -// - if L is left to default 0, it will be computed from StrLen(P) -function Iso8601ToDateTimePUTF8Char(P: PUTF8Char; L: integer=0): TDateTime; - {$ifdef HASINLINE}inline;{$endif} - -/// Date/Time conversion from ISO-8601 -// - handle 'YYYYMMDDThhmmss' and 'YYYY-MM-DD hh:mm:ss' format, with potentially -// shorten versions has handled by the ISO-8601 standard (e.g. 'YYYY') -// - will also recognize '.sss' milliseconds suffix, if any -// - if L is left to default 0, it will be computed from StrLen(P) -procedure Iso8601ToDateTimePUTF8CharVar(P: PUTF8Char; L: integer; var result: TDateTime); - -/// Date/Time conversion from strict ISO-8601 content -// - recognize 'YYYY-MM-DDThh:mm:ss[.sss]' or 'YYYY-MM-DD' or 'Thh:mm:ss[.sss]' -// patterns, as e.g. generated by TTextWriter.AddDateTime() or RecordSaveJSON() -// - will also recognize '.sss' milliseconds suffix, if any -function Iso8601CheckAndDecode(P: PUTF8Char; L: integer; var Value: TDateTime): boolean; - -/// Time conversion from ISO-8601 (with no Date part) -// - handle 'hhmmss' and 'hh:mm:ss' format -// - will also recognize '.sss' milliseconds suffix, if any -// - if L is left to default 0, it will be computed from StrLen(P) -function Iso8601ToTimePUTF8Char(P: PUTF8Char; L: integer=0): TDateTime; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// Time conversion from ISO-8601 (with no Date part) -// - handle 'hhmmss' and 'hh:mm:ss' format -// - will also recognize '.sss' milliseconds suffix, if any -// - if L is left to default 0, it will be computed from StrLen(P) -procedure Iso8601ToTimePUTF8CharVar(P: PUTF8Char; L: integer; var result: TDateTime); - -/// Time conversion from ISO-8601 (with no Date part) -// - recognize 'hhmmss' and 'hh:mm:ss' format into H,M,S variables -// - will also recognize '.sss' milliseconds suffix, if any, into MS -// - if L is left to default 0, it will be computed from StrLen(P) -function Iso8601ToTimePUTF8Char(P: PUTF8Char; L: integer; var H,M,S,MS: cardinal): boolean; overload; - -/// Date conversion from ISO-8601 (with no Time part) -// - recognize 'YYYY-MM-DD' and 'YYYYMMDD' format into Y,M,D variables -// - if L is left to default 0, it will be computed from StrLen(P) -function Iso8601ToDatePUTF8Char(P: PUTF8Char; L: integer; var Y,M,D: cardinal): boolean; - -/// Interval date/time conversion from simple text -// - expected format does not match ISO-8601 Time intervals format, but Oracle -// interval litteral representation, i.e. '+/-D HH:MM:SS' -// - e.g. IntervalTextToDateTime('+0 06:03:20') will return 0.25231481481 and -// IntervalTextToDateTime('-20 06:03:20') -20.252314815 -// - as a consequence, negative intervals will be written as TDateTime values: -// !DateTimeToIso8601Text(IntervalTextToDateTime('+0 06:03:20'))='T06:03:20' -// !DateTimeToIso8601Text(IntervalTextToDateTime('+1 06:03:20'))='1899-12-31T06:03:20' -// !DateTimeToIso8601Text(IntervalTextToDateTime('-2 06:03:20'))='1899-12-28T06:03:20' -function IntervalTextToDateTime(Text: PUTF8Char): TDateTime; - {$ifdef HASINLINE}inline;{$endif} - -/// Interval date/time conversion from simple text -// - expected format does not match ISO-8601 Time intervals format, but Oracle -// interval litteral representation, i.e. '+/-D HH:MM:SS' -// - e.g. '+1 06:03:20' will return 1.25231481481 -procedure IntervalTextToDateTimeVar(Text: PUTF8Char; var result: TDateTime); - -/// basic Date/Time conversion into ISO-8601 -// - use 'YYYYMMDDThhmmss' format if not Expanded -// - use 'YYYY-MM-DDThh:mm:ss' format if Expanded -// - if WithMS is TRUE, will append '.sss' for milliseconds resolution -// - if QuotedChar is not default #0, will (double) quote the resulted text -// - you may rather use DateTimeToIso8601Text() to handle 0 or date-only values -function DateTimeToIso8601(D: TDateTime; Expanded: boolean; - FirstChar: AnsiChar='T'; WithMS: boolean=false; QuotedChar: AnsiChar=#0): RawUTF8; overload; - -/// basic Date/Time conversion into ISO-8601 -// - use 'YYYYMMDDThhmmss' format if not Expanded -// - use 'YYYY-MM-DDThh:mm:ss' format if Expanded -// - if WithMS is TRUE, will append '.sss' for milliseconds resolution -// - if QuotedChar is not default #0, will (double) quote the resulted text -// - you may rather use DateTimeToIso8601Text() to handle 0 or date-only values -// - returns the number of chars written to P^ buffer -function DateTimeToIso8601(P: PUTF8Char; D: TDateTime; Expanded: boolean; - FirstChar: AnsiChar='T'; WithMS: boolean=false; QuotedChar: AnsiChar=#0): integer; overload; - -/// basic Date conversion into ISO-8601 -// - use 'YYYYMMDD' format if not Expanded -// - use 'YYYY-MM-DD' format if Expanded -function DateToIso8601(Date: TDateTime; Expanded: boolean): RawUTF8; overload; - -/// basic Date conversion into ISO-8601 -// - use 'YYYYMMDD' format if not Expanded -// - use 'YYYY-MM-DD' format if Expanded -function DateToIso8601(Y,M,D: cardinal; Expanded: boolean): RawUTF8; overload; - -/// basic Date period conversion into ISO-8601 -// - will convert an elapsed number of days as ISO-8601 text -// - use 'YYYYMMDD' format if not Expanded -// - use 'YYYY-MM-DD' format if Expanded -function DaysToIso8601(Days: cardinal; Expanded: boolean): RawUTF8; - -/// basic Time conversion into ISO-8601 -// - use 'Thhmmss' format if not Expanded -// - use 'Thh:mm:ss' format if Expanded -// - if WithMS is TRUE, will append '.sss' for milliseconds resolution -function TimeToIso8601(Time: TDateTime; Expanded: boolean; FirstChar: AnsiChar='T'; - WithMS: boolean=false): RawUTF8; - -/// Write a Date to P^ Ansi buffer -// - if Expanded is false, 'YYYYMMDD' date format is used -// - if Expanded is true, 'YYYY-MM-DD' date format is used -function DateToIso8601PChar(P: PUTF8Char; Expanded: boolean; Y,M,D: PtrUInt): PUTF8Char; overload; - -/// convert a date into 'YYYY-MM-DD' date format -// - resulting text is compatible with all ISO-8601 functions -function DateToIso8601Text(Date: TDateTime): RawUTF8; - -/// Write a Date/Time to P^ Ansi buffer -function DateToIso8601PChar(Date: TDateTime; P: PUTF8Char; Expanded: boolean): PUTF8Char; overload; - -/// Write a TDateTime value, expanded as Iso-8601 encoded text into P^ Ansi buffer -// - if DT=0, returns '' -// - if DT contains only a date, returns the date encoded as 'YYYY-MM-DD' -// - if DT contains only a time, returns the time encoded as 'Thh:mm:ss' -// - otherwise, returns the ISO-8601 date and time encoded as 'YYYY-MM-DDThh:mm:ss' -// - if WithMS is TRUE, will append '.sss' for milliseconds resolution -function DateTimeToIso8601ExpandedPChar(const Value: TDateTime; Dest: PUTF8Char; - FirstChar: AnsiChar='T'; WithMS: boolean=false): PUTF8Char; - -/// write a TDateTime into strict ISO-8601 date and/or time text -// - if DT=0, returns '' -// - if DT contains only a date, returns the date encoded as 'YYYY-MM-DD' -// - if DT contains only a time, returns the time encoded as 'Thh:mm:ss' -// - otherwise, returns the ISO-8601 date and time encoded as 'YYYY-MM-DDThh:mm:ss' -// - if WithMS is TRUE, will append '.sss' for milliseconds resolution -// - used e.g. by TPropInfo.GetValue() and TPropInfo.NormalizeValue() methods -function DateTimeToIso8601Text(DT: TDateTime; FirstChar: AnsiChar='T'; - WithMS: boolean=false): RawUTF8; - {$ifdef HASINLINE}inline;{$endif} - -/// write a TDateTime into strict ISO-8601 date and/or time text -// - if DT=0, returns '' -// - if DT contains only a date, returns the date encoded as 'YYYY-MM-DD' -// - if DT contains only a time, returns the time encoded as 'Thh:mm:ss' -// - otherwise, returns the ISO-8601 date and time encoded as 'YYYY-MM-DDThh:mm:ss' -// - if WithMS is TRUE, will append '.sss' for milliseconds resolution -// - used e.g. by TPropInfo.GetValue() and TPropInfo.NormalizeValue() methods -procedure DateTimeToIso8601TextVar(DT: TDateTime; FirstChar: AnsiChar; var result: RawUTF8; - WithMS: boolean=false); - -/// write a TDateTime into strict ISO-8601 date and/or time text -// - if DT=0, returns '' -// - if DT contains only a date, returns the date encoded as 'YYYY-MM-DD' -// - if DT contains only a time, returns the time encoded as 'Thh:mm:ss' -// - otherwise, returns the ISO-8601 date and time encoded as 'YYYY-MM-DDThh:mm:ss' -// - if WithMS is TRUE, will append '.sss' for milliseconds resolution -// - used e.g. by TPropInfo.GetValue() and TPropInfo.NormalizeValue() methods -procedure DateTimeToIso8601StringVar(DT: TDateTime; FirstChar: AnsiChar; var result: string; - WithMS: boolean=false); - -/// Write a Time to P^ Ansi buffer -// - if Expanded is false, 'Thhmmss' time format is used -// - if Expanded is true, 'Thh:mm:ss' time format is used -// - you can custom the first char in from of the resulting text time -// - if WithMS is TRUE, will append MS as '.sss' for milliseconds resolution -function TimeToIso8601PChar(P: PUTF8Char; Expanded: boolean; H,M,S,MS: PtrUInt; - FirstChar: AnsiChar = 'T'; WithMS: boolean=false): PUTF8Char; overload; - -/// Write a Time to P^ Ansi buffer -// - if Expanded is false, 'Thhmmss' time format is used -// - if Expanded is true, 'Thh:mm:ss' time format is used -// - you can custom the first char in from of the resulting text time -// - if WithMS is TRUE, will append '.sss' for milliseconds resolution -function TimeToIso8601PChar(Time: TDateTime; P: PUTF8Char; Expanded: boolean; - FirstChar: AnsiChar = 'T'; WithMS: boolean=false): PUTF8Char; overload; - -var - /// custom TTimeLog date to ready to be displayed text function - // - you can override this pointer in order to display the text according - // to your expected i18n settings - // - this callback will therefore be set by the mORMoti18n.pas unit - // - used e.g. by TTimeLogBits.i18nText and by TSQLTable.ExpandAsString() - // methods, i.e. TSQLTableToGrid.DrawCell() - i18nDateText: function(const Iso: TTimeLog): string = nil; - /// custom date to ready to be displayed text function - // - you can override this pointer in order to display the text according - // to your expected i18n settings - // - this callback will therefore be set by the mORMoti18n.pas unit - // - used e.g. by TSQLTable.ExpandAsString() method, - // i.e. TSQLTableToGrid.DrawCell() - i18nDateTimeText: function(const DateTime: TDateTime): string = nil; - -/// wrapper calling global i18nDateTimeText() callback if set, -// or returning ISO-8601 standard layout on default -function DateTimeToi18n(const DateTime: TDateTime): string; - - -/// fast conversion of 2 digit characters into a 0..99 value -// - returns FALSE on success, TRUE if P^ is not correct -function Char2ToByte(P: PUTF8Char; out Value: Cardinal): Boolean; - -/// fast conversion of 3 digit characters into a 0..9999 value -// - returns FALSE on success, TRUE if P^ is not correct -function Char3ToWord(P: PUTF8Char; out Value: Cardinal): Boolean; - -/// fast conversion of 4 digit characters into a 0..9999 value -// - returns FALSE on success, TRUE if P^ is not correct -function Char4ToWord(P: PUTF8Char; out Value: Cardinal): Boolean; - -/// our own fast version of the corresponding low-level RTL function -function TryEncodeDate(Year, Month, Day: cardinal; out Date: TDateTime): Boolean; - -/// our own fast version of the corresponding low-level RTL function -function IsLeapYear(Year: cardinal): boolean; - {$ifdef HASINLINE} inline; {$endif} - -/// retrieve the current Date, in the ISO 8601 layout, but expanded and -// ready to be displayed -function NowToString(Expanded: boolean=true; FirstTimeChar: AnsiChar=' '): RawUTF8; - -/// retrieve the current UTC Date, in the ISO 8601 layout, but expanded and -// ready to be displayed -function NowUTCToString(Expanded: boolean=true; FirstTimeChar: AnsiChar=' '): RawUTF8; - -/// convert some date/time to the ISO 8601 text layout, including milliseconds -// - i.e. 'YYYY-MM-DD hh:mm:ss.sssZ' or 'YYYYMMDD hhmmss.sssZ' format -// - TZD is the ending time zone designator ('', 'Z' or '+hh:mm' or '-hh:mm') -// - see also TTextWriter.AddDateTimeMS method -function DateTimeMSToString(DateTime: TDateTime; Expanded: boolean=true; - FirstTimeChar: AnsiChar=' '; const TZD: RawUTF8='Z'): RawUTF8; overload; - -/// convert some date/time to the ISO 8601 text layout, including milliseconds -// - i.e. 'YYYY-MM-DD hh:mm:ss.sssZ' or 'YYYYMMDD hhmmss.sssZ' format -// - TZD is the ending time zone designator ('', 'Z' or '+hh:mm' or '-hh:mm') -// - see also TTextWriter.AddDateTimeMS method -function DateTimeMSToString(HH,MM,SS,MS,Y,M,D: cardinal; Expanded: boolean; - FirstTimeChar: AnsiChar=' '; const TZD: RawUTF8='Z'): RawUTF8; overload; - -/// convert some date/time to the "HTTP-date" format as defined by RFC 7231 -// - i.e. "Tue, 15 Nov 1994 12:45:26 GMT" to be used as a value of -// "Date", "Expires" or "Last-Modified" HTTP header -// - if you care about timezones Value must be converted to UTC first -// using TSynTimeZone.LocalToUtc, or tz should be properly set -function DateTimeToHTTPDate(dt: TDateTime; const tz: RawUTF8='GMT'): RawUTF8; overload; - -/// convert some TDateTime to a small text layout, perfect e.g. for naming a local file -// - use 'YYMMDDHHMMSS' format so year is truncated to last 2 digits, expecting -// a date > 1999 (a current date would be fine) -function DateTimeToFileShort(const DateTime: TDateTime): TShort16; overload; - {$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell - -/// convert some TDateTime to a small text layout, perfect e.g. for naming a local file -// - use 'YYMMDDHHMMSS' format so year is truncated to last 2 digits, expecting -// a date > 1999 (a current date would be fine) -procedure DateTimeToFileShort(const DateTime: TDateTime; out result: TShort16); overload; - -/// retrieve the current Time (whithout Date), in the ISO 8601 layout -// - useful for direct on screen logging e.g. -function TimeToString: RawUTF8; - -const - /// a contemporary, but elapsed, TUnixTime second-based value - // - corresponds to Thu, 08 Dec 2016 08:50:20 GMT - // - may be used to check for a valid just-generated Unix timestamp value - UNIXTIME_MINIMAL = 1481187020; - -/// convert a second-based c-encoded time as TDateTime -// - i.e. number of seconds elapsed since Unix epoch 1/1/1970 into TDateTime -function UnixTimeToDateTime(const UnixTime: TUnixTime): TDateTime; - {$ifdef HASINLINE}inline;{$endif} - -/// convert a TDateTime into a second-based c-encoded time -// - i.e. TDateTime into number of seconds elapsed since Unix epoch 1/1/1970 -function DateTimeToUnixTime(const AValue: TDateTime): TUnixTime; - {$ifdef HASINLINE}inline;{$endif} - -/// returns the current UTC date/time as a second-based c-encoded time -// - i.e. current number of seconds elapsed since Unix epoch 1/1/1970 -// - faster than NowUTC or GetTickCount64, on Windows or Unix platforms -// (will use e.g. fast clock_gettime(CLOCK_REALTIME_COARSE) under Linux, -// or GetSystemTimeAsFileTime under Windows) -// - returns a 64-bit unsigned value, so is "Year2038bug" free -function UnixTimeUTC: TUnixTime; - {$ifndef MSWINDOWS}{$ifdef HASINLINE}inline;{$endif}{$endif} - -/// convert some second-based c-encoded time (from Unix epoch 1/1/1970) to -// the ISO 8601 text layout -// - use 'YYYYMMDDThhmmss' format if not Expanded -// - use 'YYYY-MM-DDThh:mm:ss' format if Expanded -function UnixTimeToString(const UnixTime: TUnixTime; Expanded: boolean=true; - FirstTimeChar: AnsiChar='T'): RawUTF8; - -/// convert some second-based c-encoded time (from Unix epoch 1/1/1970) to -// a small text layout, perfect e.g. for naming a local file -// - use 'YYMMDDHHMMSS' format so year is truncated to last 2 digits, expecting -// a date > 1999 (a current date would be fine) -procedure UnixTimeToFileShort(const UnixTime: TUnixTime; out result: TShort16); overload; - -/// convert some second-based c-encoded time (from Unix epoch 1/1/1970) to -// a small text layout, perfect e.g. for naming a local file -// - use 'YYMMDDHHMMSS' format so year is truncated to last 2 digits, expecting -// a date > 1999 (a current date would be fine) -function UnixTimeToFileShort(const UnixTime: TUnixTime): TShort16; overload; - {$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell - -/// convert some second-based c-encoded time to the ISO 8601 text layout, either -// as time or date elapsed period -// - this function won't add the Unix epoch 1/1/1970 offset to the timestamp -// - returns 'Thh:mm:ss' or 'YYYY-MM-DD' format, depending on the supplied value -function UnixTimePeriodToString(const UnixTime: TUnixTime; FirstTimeChar: AnsiChar='T'): RawUTF8; - -/// returns the current UTC date/time as a millisecond-based c-encoded time -// - i.e. current number of milliseconds elapsed since Unix epoch 1/1/1970 -// - faster and more accurate than NowUTC or GetTickCount64, on Windows or Unix -// - will use e.g. fast clock_gettime(CLOCK_REALTIME_COARSE) under Linux, -// or GetSystemTimeAsFileTime/GetSystemTimePreciseAsFileTime under Windows - the -// later being more accurate, but slightly slower than the former, so you may -// consider using UnixMSTimeUTCFast on Windows if its 10-16ms accuracy is enough -function UnixMSTimeUTC: TUnixMSTime; - {$ifndef MSWINDOWS}{$ifdef HASINLINE}inline;{$endif}{$endif} - -/// returns the current UTC date/time as a millisecond-based c-encoded time -// - under Linux/POSIX, is the very same than UnixMSTimeUTC -// - under Windows 8+, will call GetSystemTimeAsFileTime instead of -// GetSystemTimePreciseAsFileTime, which has higher precision, but is slower -// - prefer it under Windows, if a dozen of ms resolution is enough for your task -function UnixMSTimeUTCFast: TUnixMSTime; - {$ifndef MSWINDOWS}{$ifdef HASINLINE}inline;{$endif}{$endif} - -/// convert a millisecond-based c-encoded time (from Unix epoch 1/1/1970) as TDateTime -function UnixMSTimeToDateTime(const UnixMSTime: TUnixMSTime): TDateTime; - {$ifdef HASINLINE}inline;{$endif} - -/// convert a TDateTime into a millisecond-based c-encoded time (from Unix epoch 1/1/1970) -// - if AValue is 0, will return 0 (since is likely to be an error constant) -function DateTimeToUnixMSTime(const AValue: TDateTime): TUnixMSTime; - {$ifdef HASINLINE}inline;{$endif} - -/// convert some millisecond-based c-encoded time (from Unix epoch 1/1/1970) to -// the ISO 8601 text layout, including milliseconds -// - i.e. 'YYYY-MM-DDThh:mm:ss.sssZ' or 'YYYYMMDDThhmmss.sssZ' format -// - TZD is the ending time zone designator ('', 'Z' or '+hh:mm' or '-hh:mm') -function UnixMSTimeToString(const UnixMSTime: TUnixMSTime; Expanded: boolean=true; - FirstTimeChar: AnsiChar='T'; const TZD: RawUTF8=''): RawUTF8; - -/// convert some milllisecond-based c-encoded time (from Unix epoch 1/1/1970) to -// a small text layout, trimming to the second resolution, perfect e.g. for -// naming a local file -// - use 'YYMMDDHHMMSS' format so year is truncated to last 2 digits, expecting -// a date > 1999 (a current date would be fine) -function UnixMSTimeToFileShort(const UnixMSTime: TUnixMSTime): TShort16; - {$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell - -/// convert some millisecond-based c-encoded time to the ISO 8601 text layout, -// as time or date elapsed period -// - this function won't add the Unix epoch 1/1/1970 offset to the timestamp -// - returns 'Thh:mm:ss' or 'YYYY-MM-DD' format, depending on the supplied value -function UnixMSTimePeriodToString(const UnixMSTime: TUnixMSTime; FirstTimeChar: AnsiChar='T'): RawUTF8; - -/// returns the current UTC system date and time -// - SysUtils.Now returns local time: this function returns the system time -// expressed in Coordinated Universal Time (UTC) -// - under Windows, will use GetSystemTimeAsFileTime() so will achieve about -// 16 ms of resolution -// - under POSIX, will call clock_gettime(CLOCK_REALTIME_COARSE) -function NowUTC: TDateTime; - -{$ifndef ENHANCEDRTL} -{$ifndef LVCL} { don't define these twice } - -var - /// these procedure type must be defined if a default system.pas is used - // - mORMoti18n.pas unit will hack default LoadResString() procedure - // - already defined in our Extended system.pas unit - // - needed with FPC, Delphi 2009 and up, i.e. when ENHANCEDRTL is not defined - // - expect generic "string" type, i.e. UnicodeString for Delphi 2009+ - // - not needed with the LVCL framework (we should be on server side) - LoadResStringTranslate: procedure(var Text: string) = nil; - - /// current LoadResString() cached entries count - // - i.e. resourcestring caching for faster use - // - used only if a default system.pas is used, not our Extended version - // - defined here, but resourcestring caching itself is implemented in the - // mORMoti18n.pas unit, if the ENHANCEDRTL conditional is not defined - CacheResCount: integer = -1; - -{$endif} -{$endif} - -type - /// a generic callback, which can be used to translate some text on the fly - // - maps procedure TLanguageFile.Translate(var English: string) signature - // as defined in mORMoti18n.pas - // - can be used e.g. for TSynMustache's {{"English text}} callback - TOnStringTranslate = procedure (var English: string) of object; - - -const - /// Rotate local log file if reached this size (1MB by default) - // - .log file will be save as .log.bak file - // - a new .log file is created - // - used by AppendToTextFile() and LogToTextFile() functions (not TSynLog) - MAXLOGSIZE = 1024*1024; - -/// log a message to a local text file -// - the text file is located in the executable directory, and its name is -// simply the executable file name with the '.log' extension instead of '.exe' -// - format contains the current date and time, then the Msg on one line -// - date and time format used is 'YYYYMMDD hh:mm:ss (i.e. ISO-8601)' -procedure LogToTextFile(Msg: RawUTF8); - -/// log a message to a local text file -// - this version expects the filename to be specified -// - format contains the current date and time, then the Msg on one line -// - date and time format used is 'YYYYMMDD hh:mm:ss' -procedure AppendToTextFile(aLine: RawUTF8; const aFileName: TFileName; aMaxSize: Int64=MAXLOGSIZE; - aUTCTimeStamp: boolean=false); - - -{ ************ fast low-level lookup types used by internal conversion routines } - -{$ifndef ENHANCEDRTL} -{$ifndef LVCL} { don't define these const twice } - -const - /// fast lookup table for converting any decimal number from - // 0 to 99 into their ASCII equivalence - // - our enhanced SysUtils.pas (normal and LVCL) contains the same array - TwoDigitLookup: packed array[0..99] of array[1..2] of AnsiChar = - ('00','01','02','03','04','05','06','07','08','09', - '10','11','12','13','14','15','16','17','18','19', - '20','21','22','23','24','25','26','27','28','29', - '30','31','32','33','34','35','36','37','38','39', - '40','41','42','43','44','45','46','47','48','49', - '50','51','52','53','54','55','56','57','58','59', - '60','61','62','63','64','65','66','67','68','69', - '70','71','72','73','74','75','76','77','78','79', - '80','81','82','83','84','85','86','87','88','89', - '90','91','92','93','94','95','96','97','98','99'); - -{$endif} -{$endif} - -var - /// fast lookup table for converting any decimal number from - // 0 to 99 into their ASCII ('0'..'9') equivalence - TwoDigitLookupW: packed array[0..99] of word absolute TwoDigitLookup; - /// fast lookup table for converting any decimal number from - // 0 to 99 into their byte digits (0..9) equivalence - // - used e.g. by DoubleToAscii() implementing Grisu algorithm - TwoDigitByteLookupW: packed array[0..99] of word; - -type - /// char categories for text line/word/identifiers/uri parsing - TTextChar = set of (tcNot01013, tc1013, tcCtrlNotLF, tcCtrlNot0Comma, - tcWord, tcIdentifierFirstChar, tcIdentifier, tcURIUnreserved); - TTextCharSet = array[AnsiChar] of TTextChar; - PTextCharSet = ^TTextCharSet; - TTextByteSet = array[byte] of TTextChar; - PTextByteSet = ^TTextByteSet; -var - /// branch-less table used for text line/word/identifiers/uri parsing - TEXT_CHARS: TTextCharSet; - TEXT_BYTES: TTextByteSet absolute TEXT_CHARS; - -{$M+} // to have existing RTTI for published properties -type - /// used to retrieve version information from any EXE - // - under Linux, all version numbers are set to 0 by default - // - you should not have to use this class directly, but via the - // ExeVersion global variable - TFileVersion = class - protected - fDetailed: string; - fFileName: TFileName; - fBuildDateTime: TDateTime; - /// change the version (not to be used in most cases) - procedure SetVersion(aMajor,aMinor,aRelease,aBuild: integer); - public - /// executable major version number - Major: Integer; - /// executable minor version number - Minor: Integer; - /// executable release version number - Release: Integer; - /// executable release build number - Build: Integer; - /// build year of this exe file - BuildYear: word; - /// version info of the exe file as '3.1' - // - return "string" type, i.e. UnicodeString for Delphi 2009+ - Main: string; - /// associated CompanyName string version resource - // - only available on Windows - contains '' under Linux/POSIX - CompanyName: RawUTF8; - /// associated FileDescription string version resource - // - only available on Windows - contains '' under Linux/POSIX - FileDescription: RawUTF8; - /// associated FileVersion string version resource - // - only available on Windows - contains '' under Linux/POSIX - FileVersion: RawUTF8; - /// associated InternalName string version resource - // - only available on Windows - contains '' under Linux/POSIX - InternalName: RawUTF8; - /// associated LegalCopyright string version resource - // - only available on Windows - contains '' under Linux/POSIX - LegalCopyright: RawUTF8; - /// associated OriginalFileName string version resource - // - only available on Windows - contains '' under Linux/POSIX - OriginalFilename: RawUTF8; - /// associated ProductName string version resource - // - only available on Windows - contains '' under Linux/POSIX - ProductName: RawUTF8; - /// associated ProductVersion string version resource - // - only available on Windows - contains '' under Linux/POSIX - ProductVersion: RawUTF8; - /// associated Comments string version resource - // - only available on Windows - contains '' under Linux/POSIX - Comments: RawUTF8; - /// retrieve application version from exe file name - // - DefaultVersion32 is used if no information Version was included into - // the executable resources (on compilation time) - // - you should not have to use this constructor, but rather access the - // ExeVersion global variable - constructor Create(const aFileName: TFileName; aMajor: integer=0; - aMinor: integer=0; aRelease: integer=0; aBuild: integer=0); - /// retrieve the version as a 32-bit integer with Major.Minor.Release - // - following Major shl 16+Minor shl 8+Release bit pattern - function Version32: integer; - /// build date and time of this exe file, as plain text - function BuildDateTimeString: string; - /// version info of the exe file as '3.1.0.123' or '' - // - this method returns '' if Detailed is '0.0.0.0' - function DetailedOrVoid: string; - /// returns the version information of this exe file as text - // - includes FileName (without path), Detailed and BuildDateTime properties - // - e.g. 'myprogram.exe 3.1.0.123 (2016-06-14 19:07:55)' - function VersionInfo: RawUTF8; - /// returns a ready-to-use User-Agent header with exe name, version and OS - // - e.g. 'myprogram/3.1.0.123W32' for myprogram running on Win32 - // - here OS_INITIAL[] character is used to identify the OS, with '32' - // appended on Win32 only (e.g. 'myprogram/3.1.0.2W', is for Win64) - function UserAgent: RawUTF8; - /// returns the version information of a specified exe file as text - // - includes FileName (without path), Detailed and BuildDateTime properties - // - e.g. 'myprogram.exe 3.1.0.123 2016-06-14 19:07:55' - class function GetVersionInfo(const aFileName: TFileName): RawUTF8; - published - /// version info of the exe file as '3.1.0.123' - // - return "string" type, i.e. UnicodeString for Delphi 2009+ - // - under Linux, always return '0.0.0.0' if no custom version number - // has been defined - // - consider using DetailedOrVoid method if '0.0.0.0' is not expected - property Detailed: string read fDetailed write fDetailed; - /// build date and time of this exe file - property BuildDateTime: TDateTime read fBuildDateTime write fBuildDateTime; - end; -{$M-} - - -{$ifdef DELPHI6OROLDER} - -// define some common constants not available prior to Delphi 7 -const - HoursPerDay = 24; - MinsPerHour = 60; - SecsPerMin = 60; - MSecsPerSec = 1000; - MinsPerDay = HoursPerDay * MinsPerHour; - SecsPerDay = MinsPerDay * SecsPerMin; - MSecsPerDay = SecsPerDay * MSecsPerSec; - DateDelta = 693594; - UnixDateDelta = 25569; - -/// GetFileVersion returns the most significant 32-bit of a file's binary -// version number -// - typically, this includes the major and minor version placed -// together in one 32-bit integer -// - generally does not include the release or build numbers -// - returns Cardinal(-1) in case of failure -function GetFileVersion(const FileName: TFileName): cardinal; - -{$endif DELPHI6OROLDER} - -type - /// the recognized operating systems - // - it will also recognize some Linux distributions - TOperatingSystem = (osUnknown, osWindows, osLinux, osOSX, osBSD, osPOSIX, - osArch, osAurox, osDebian, osFedora, osGentoo, osKnoppix, osMint, osMandrake, - osMandriva, osNovell, osUbuntu, osSlackware, osSolaris, osSuse, osSynology, - osTrustix, osClear, osUnited, osRedHat, osLFS, osOracle, osMageia, osCentOS, - osCloud, osXen, osAmazon, osCoreOS, osAlpine, osAndroid); - /// the recognized Windows versions - // - defined even outside MSWINDOWS to allow process e.g. from monitoring tools - TWindowsVersion = ( - wUnknown, w2000, wXP, wXP_64, wServer2003, wServer2003_R2, - wVista, wVista_64, wServer2008, wServer2008_64, - wSeven, wSeven_64, wServer2008_R2, wServer2008_R2_64, - wEight, wEight_64, wServer2012, wServer2012_64, - wEightOne, wEightOne_64, wServer2012R2, wServer2012R2_64, - wTen, wTen_64, wServer2016, wServer2016_64, - wEleven, wEleven_64, wServer2019_64); - /// the running Operating System, encoded as a 32-bit integer - TOperatingSystemVersion = packed record - case os: TOperatingSystem of - osUnknown: (b: array[0..2] of byte); - osWindows: (win: TWindowsVersion); - osLinux: (utsrelease: array[0..2] of byte); - end; - -const - /// the recognized Windows versions, as plain text - // - defined even outside MSWINDOWS to allow process e.g. from monitoring tools - WINDOWS_NAME: array[TWindowsVersion] of RawUTF8 = ( - '', '2000', 'XP', 'XP 64bit', 'Server 2003', 'Server 2003 R2', - 'Vista', 'Vista 64bit', 'Server 2008', 'Server 2008 64bit', - '7', '7 64bit', 'Server 2008 R2', 'Server 2008 R2 64bit', - '8', '8 64bit', 'Server 2012', 'Server 2012 64bit', - '8.1', '8.1 64bit', 'Server 2012 R2', 'Server 2012 R2 64bit', - '10', '10 64bit', 'Server 2016', 'Server 2016 64bit', - '11', '11 64bit', 'Server 2019 64bit'); - /// the recognized Windows versions which are 32-bit - WINDOWS_32 = [w2000, wXP, wServer2003, wServer2003_R2, wVista, wServer2008, - wSeven, wServer2008_R2, wEight, wServer2012, wEightOne, wServer2012R2, - wTen, wServer2016, wEleven]; - /// translate one operating system (and distribution) into a single character - // - may be used internally e.g. for a HTTP User-Agent header, as with - // TFileVersion.UserAgent - OS_INITIAL: array[TOperatingSystem] of AnsiChar = - ('?', 'W', 'L', 'X', 'B', 'P', 'A', 'a', 'D', 'F', 'G', 'K', 'M', 'm', - 'n', 'N', 'U', 'S', 's', 'u', 'Y', 'T', 'C', 't', 'R', 'l', 'O', 'G', - 'c', 'd', 'x', 'Z', 'r', 'p', 'J'); // for Android ... J = Java VM - /// the operating systems items which actually are Linux distributions - OS_LINUX = [osLinux, osArch .. osAndroid]; - - /// the compiler family used - COMP_TEXT = {$ifdef FPC}'Fpc'{$else}'Delphi'{$endif}; - /// the target Operating System used for compilation, as text - OS_TEXT = {$ifdef MSWINDOWS}'Win'{$else}{$ifdef DARWIN}'OSX'{$else} - {$ifdef BSD}'BSD'{$else}{$ifdef ANDROID}'Android'{$else}{$ifdef LINUX}'Linux'{$else}'Posix' - {$endif}{$endif}{$endif}{$endif}{$endif}; - /// the CPU architecture used for compilation - CPU_ARCH_TEXT = {$ifdef CPUX86}'x86'{$else}{$ifdef CPUX64}'x64'{$else} - {$ifdef CPUARM}'arm'+{$else} - {$ifdef CPUAARCH64}'arm'+{$else} - {$ifdef CPUPOWERPC}'ppc'+{$else} - {$ifdef CPUSPARC}'sparc'+{$endif}{$endif}{$endif}{$endif} - {$ifdef CPU32}'32'{$else}'64'{$endif}{$endif}{$endif}; - -function ToText(os: TOperatingSystem): PShortString; overload; -function ToText(const osv: TOperatingSystemVersion): ShortString; overload; -function ToTextOS(osint32: integer): RawUTF8; - -var - /// the target Operating System used for compilation, as TOperatingSystem - // - a specific Linux distribution may be detected instead of plain osLinux - OS_KIND: TOperatingSystem = {$ifdef MSWINDOWS}osWindows{$else}{$ifdef DARWIN}osOSX{$else} - {$ifdef BSD}osBSD{$else}{$ifdef Android}osAndroid{$else}{$ifdef LINUX}osLinux{$else}osPOSIX - {$endif}{$endif}{$endif}{$endif}{$endif}; - /// the current Operating System version, as retrieved for the current process - // - contains e.g. 'Windows Seven 64 SP1 (6.1.7601)' or - // 'Ubuntu 16.04.5 LTS - Linux 3.13.0 110 generic#157 Ubuntu SMP Mon Feb 20 11:55:25 UTC 2017' - OSVersionText: RawUTF8; - /// some addition system information as text, e.g. 'Wine 1.1.5' - // - also always appended to OSVersionText high-level description - OSVersionInfoEx: RawUTF8; - /// some textual information about the current CPU - CpuInfoText: RawUTF8; - /// some textual information about the current computer hardware, from BIOS - BiosInfoText: RawUTF8; - /// the running Operating System - OSVersion32: TOperatingSystemVersion; - OSVersionInt32: integer absolute OSVersion32; - -{$ifdef MSWINDOWS} - {$ifndef UNICODE} -type - /// low-level API structure, not defined in older Delphi versions - TOSVersionInfoEx = record - dwOSVersionInfoSize: DWORD; - dwMajorVersion: DWORD; - dwMinorVersion: DWORD; - dwBuildNumber: DWORD; - dwPlatformId: DWORD; - szCSDVersion: array[0..127] of char; - wServicePackMajor: WORD; - wServicePackMinor: WORD; - wSuiteMask: WORD; - wProductType: BYTE; - wReserved: BYTE; - end; - {$endif UNICODE} - -var - /// is set to TRUE if the current process is a 32-bit image running under WOW64 - // - WOW64 is the x86 emulator that allows 32-bit Windows-based applications - // to run seamlessly on 64-bit Windows - // - equals always FALSE if the current executable is a 64-bit image - IsWow64: boolean; - /// the current System information, as retrieved for the current process - // - under a WOW64 process, it will use the GetNativeSystemInfo() new API - // to retrieve the real top-most system information - // - note that the lpMinimumApplicationAddress field is replaced by a - // more optimistic/realistic value ($100000 instead of default $10000) - // - under BSD/Linux, only contain dwPageSize and dwNumberOfProcessors fields - SystemInfo: TSystemInfo; - /// the current Operating System information, as retrieved for the current process - OSVersionInfo: TOSVersionInfoEx; - /// the current Operating System version, as retrieved for the current process - OSVersion: TWindowsVersion; - -/// this function can be used to create a GDI compatible window, able to -// receive Windows Messages for fast local communication -// - will return 0 on failure (window name already existing e.g.), or -// the created HWND handle on success -// - it will call the supplied message handler defined for a given Windows Message: -// for instance, define such a method in any object definition: -// ! procedure WMCopyData(var Msg : TWMCopyData); message WM_COPYDATA; -function CreateInternalWindow(const aWindowName: string; aObject: TObject): HWND; - -/// delete the window resources used to receive Windows Messages -// - must be called for each CreateInternalWindow() function -// - both parameter values are then reset to ''/0 -function ReleaseInternalWindow(var aWindowName: string; var aWindow: HWND): boolean; - -/// under Windows 7 and later, will set an unique application-defined -// Application User Model ID (AppUserModelID) that identifies the current -// process to the taskbar -// - this identifier allows an application to group its associated processes -// and windows under a single taskbar button -// - value can have no more than 128 characters, cannot contain spaces, and -// each section should be camel-cased, as such: -// $ CompanyName.ProductName.SubProduct.VersionInformation -// CompanyName and ProductName should always be used, while the SubProduct and -// VersionInformation portions are optional and depend on the application's requirements -// - if the supplied text does not contain an '.', 'ID.ID' will be used -function SetAppUserModelID(const AppUserModelID: string): boolean; - -var - /// the number of milliseconds that have elapsed since the system was started - // - compatibility function, to be implemented according to the running OS - // - will use the corresponding native API function under Vista+, or - // will emulate it for older Windows versions (XP) - // - warning: FPC's SysUtils.GetTickCount64 or TThread.GetTickCount64 don't - // handle properly 49 days wrapping under XP -> always use this safe version - GetTickCount64: function: Int64; stdcall; - - /// returns the highest resolution possible UTC timestamp on this system - // - detects newer API available since Windows 8, or fallback to good old - // GetSystemTimeAsFileTime() which may have the resolution of the HW timer, - // i.e. typically around 16 ms - // - GetSystemTimeAsFileTime() is always faster, so is to be preferred - // if second resolution is enough (e.g. for UnixTimeUTC) - // - see http://www.windowstimestamp.com/description - GetSystemTimePreciseAsFileTime: procedure(var ft: TFILETIME); stdcall; - -/// similar to Windows sleep() API call, to be truly cross-platform -// - it should have a millisecond resolution, and handle ms=0 as a switch to -// another pending thread, i.e. under Windows will call SwitchToThread API -procedure SleepHiRes(ms: cardinal); - -/// low-level wrapper to get the 64-bit value from a TFileTime -// - as recommended by MSDN to avoid dword alignment issue -procedure FileTimeToInt64(const FT: TFileTime; out I64: Int64); - {$ifdef HASINLINE}inline;{$endif} - -/// low-level conversion of a Windows 64-bit TFileTime into a Unix time seconds stamp -function FileTimeToUnixTime(const FT: TFileTime): TUnixTime; - -/// low-level conversion of a Windows 64-bit TFileTime into a Unix time ms stamp -function FileTimeToUnixMSTime(const FT: TFileTime): TUnixMSTime; - -type - /// direct access to the Windows Registry - // - could be used as alternative to TRegistry, which doesn't behave the same on - // all Delphi versions, and is enhanced on FPC (e.g. which supports REG_MULTI_SZ) - // - is also Unicode ready for text, using UTF-8 conversion on all compilers - TWinRegistry = object - public - /// the opened HKEY handle - key: HKEY; - /// start low-level read access to a Windows Registry node - // - on success (returned true), ReadClose() should be called - function ReadOpen(root: HKEY; const keyname: RawUTF8; closefirst: boolean=false): boolean; - /// finalize low-level read access to the Windows Registry after ReadOpen() - procedure Close; - /// low-level read a string from the Windows Registry after ReadOpen() - // - in respect to Delphi's TRegistry, will properly handle REG_MULTI_SZ - // (return the first value of the multi-list) - function ReadString(const entry: SynUnicode; andtrim: boolean=true): RawUTF8; - /// low-level read a Windows Registry content after ReadOpen() - // - works with any kind of key, but was designed for REG_BINARY - function ReadData(const entry: SynUnicode): RawByteString; - /// low-level read a Windows Registry 32-bit REG_DWORD value after ReadOpen() - function ReadDword(const entry: SynUnicode): cardinal; - /// low-level read a Windows Registry 64-bit REG_QWORD value after ReadOpen() - function ReadQword(const entry: SynUnicode): QWord; - /// low-level enumeration of all sub-entries names of a Windows Registry key - function ReadEnumEntries: TRawUTF8DynArray; - end; - -{$else MSWINDOWS} - -var - /// emulate only some used fields of Windows' TSystemInfo - SystemInfo: record - // retrieved from libc's getpagesize() - is expected to not be 0 - dwPageSize: cardinal; - // retrieved from HW_NCPU (BSD) or /proc/cpuinfo (Linux) - dwNumberOfProcessors: cardinal; - // as returned by fpuname() - uts: UtsName; - // as from /etc/*-release - release: RawUTF8; - end; - -{$ifdef KYLIX3} - -/// compatibility function for Linux -function GetCurrentThreadID: TThreadID; cdecl; - external 'libpthread.so.0' name 'pthread_self'; - -/// overloaded function using open64() to allow 64-bit positions -function FileOpen(const FileName: string; Mode: LongWord): Integer; - -{$endif} - -/// compatibility function, to be implemented according to the running OS -// - expect more or less the same result as the homonymous Win32 API function, -// but usually with a better resolution (Windows has only around 10-16 ms) -// - will call the corresponding function in SynKylix.pas or SynFPCLinux.pas, -// using the very fast CLOCK_MONOTONIC_COARSE if available on the kernel -function GetTickCount64: Int64; - -{$endif MSWINDOWS} - -/// overloaded function optimized for one pass file reading -// - will use e.g. the FILE_FLAG_SEQUENTIAL_SCAN flag under Windows, as stated -// by http://blogs.msdn.com/b/oldnewthing/archive/2012/01/20/10258690.aspx -// - note: under XP, we observed ERROR_NO_SYSTEM_RESOURCES problems when calling -// FileRead() for chunks bigger than 32MB on files opened with this flag, -// so it would use regular FileOpen() on this deprecated OS -// - under POSIX, calls plain fpOpen(FileName,O_RDONLY) which would avoid a -// syscall to fpFlock() which is not needed here -// - is used e.g. by StringFromFile() and TSynMemoryStreamMapped.Create() -function FileOpenSequentialRead(const FileName: string): Integer; - {$ifdef HASINLINE}inline;{$endif} - -/// returns a TFileStream optimized for one pass file reading -// - will use FileOpenSequentialRead(), i.e. FILE_FLAG_SEQUENTIAL_SCAN under -// Windows, and plain fpOpen(FileName, O_RDONLY) on POSIX -function FileStreamSequentialRead(const FileName: string): THandleStream; - -/// check if the current timestamp, in ms, matched a given period -// - will compare the current GetTickCount64 to the supplied PreviousTix -// - returns TRUE if the Internal ms period was not elapsed -// - returns TRUE, and set PreviousTix, if the Interval ms period was elapsed -// - possible use case may be: -// !var Last: Int64; -// !... -// ! Last := GetTickCount64; -// ! repeat -// ! ... -// ! if Elapsed(Last,1000) then begin -// ! ... // do something every second -// ! end; -// ! until Terminated; -// !... -function Elapsed(var PreviousTix: Int64; Interval: Integer): Boolean; - -/// thread-safe move of a 32-bit value using a simple Read-Copy-Update pattern -procedure RCU32(var src,dst); - -/// thread-safe move of a 64-bit value using a simple Read-Copy-Update pattern -procedure RCU64(var src,dst); - -/// thread-safe move of a 128-bit value using a simple Read-Copy-Update pattern -procedure RCU128(var src,dst); - -/// thread-safe move of a pointer value using a simple Read-Copy-Update pattern -procedure RCUPtr(var src,dst); - -/// thread-safe move of a memory buffer using a simple Read-Copy-Update pattern -procedure RCU(var src,dst; len: integer); - -{$ifndef FPC} { FPC defines those functions as built-in } - -/// compatibility function, to be implemented according to the running CPU -// - expect the same result as the homonymous Win32 API function -function InterlockedIncrement(var I: Integer): Integer; - {$ifdef PUREPASCAL}{$ifndef MSWINDOWS}{$ifdef HASINLINE}inline;{$endif}{$endif}{$endif} - -/// compatibility function, to be implemented according to the running CPU -// - expect the same result as the homonymous Win32 API function -function InterlockedDecrement(var I: Integer): Integer; - {$ifdef PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif} - -{$endif FPC} - -/// low-level string reference counter unprocess -// - caller should have tested that refcnt>=0 -// - returns true if the managed variable should be released (i.e. refcnt was 1) -function StrCntDecFree(var refcnt: TStrCnt): boolean; - {$ifndef CPUINTEL} inline; {$endif} - -/// low-level dynarray reference counter unprocess -// - caller should have tested that refcnt>=0 -function DACntDecFree(var refcnt: TDACnt): boolean; - {$ifndef CPUINTEL} inline; {$endif} - -type - /// stores some global information about the current executable and computer - TExeVersion = record - /// the main executable name, without any path nor extension - // - e.g. 'Test' for 'c:\pathto\Test.exe' - ProgramName: RawUTF8; - /// the main executable details, as used e.g. by TSynLog - // - e.g. 'C:\Dev\lib\SQLite3\exe\TestSQL3.exe 1.2.3.123 (2011-03-29 11:09:06)' - ProgramFullSpec: RawUTF8; - /// the main executable file name (including full path) - // - same as paramstr(0) - ProgramFileName: TFileName; - /// the main executable full path (excluding .exe file name) - // - same as ExtractFilePath(paramstr(0)) - ProgramFilePath: TFileName; - /// the full path of the running executable or library - // - for an executable, same as paramstr(0) - // - for a library, will contain the whole .dll file name - InstanceFileName: TFileName; - /// the current executable version - Version: TFileVersion; - /// the current computer host name - Host: RawUTF8; - /// the current computer user name - User: RawUTF8; - /// some hash representation of this information - // - the very same executable on the very same computer run by the very - // same user will always have the same Hash value - // - is computed from the crc32c of this TExeVersion fields: c0 from - // Version32, CpuFeatures and Host, c1 from User, c2 from ProgramFullSpec - // and c3 from InstanceFileName - // - may be used as an entropy seed, or to identify a process execution - Hash: THash128Rec; - end; - -var - /// global information about the current executable and computer - // - this structure is initialized in this unit's initialization block below - // - you can call SetExecutableVersion() with a custom version, if needed - ExeVersion: TExeVersion; - -/// initialize ExeVersion global variable, supplying a custom version number -// - by default, the version numbers will be retrieved at startup from the -// executable itself (if it was included at build time) -// - but you can use this function to set any custom version numbers -procedure SetExecutableVersion(aMajor,aMinor,aRelease,aBuild: integer); overload; - -/// initialize ExeVersion global variable, supplying the version as text -// - e.g. SetExecutableVersion('7.1.2.512'); -procedure SetExecutableVersion(const aVersionText: RawUTF8); overload; - -type - /// identify an operating system folder - TSystemPath = ( - spCommonData, spUserData, spCommonDocuments, spUserDocuments, spTempFolder, spLog); - -/// returns an operating system folder -// - will return the full path of a given kind of private or shared folder, -// depending on the underlying operating system -// - will use SHGetFolderPath and the corresponding CSIDL constant under Windows -// - under POSIX, will return $TMP/$TMPDIR folder for spTempFolder, ~/.cache/appname -// for spUserData, /var/log for spLog, or the $HOME folder -// - returned folder name contains the trailing path delimiter (\ or /) -function GetSystemPath(kind: TSystemPath): TFileName; - -/// self-modifying code - change some memory buffer in the code segment -// - if Backup is not nil, it should point to a Size array of bytes, ready -// to contain the overridden code buffer, for further hook disabling -procedure PatchCode(Old,New: pointer; Size: integer; Backup: pointer=nil; - LeaveUnprotected: boolean=false); - -/// self-modifying code - change one PtrUInt in the code segment -procedure PatchCodePtrUInt(Code: PPtrUInt; Value: PtrUInt; - LeaveUnprotected: boolean=false); - -{$ifdef CPUINTEL} -type - /// small memory buffer used to backup a RedirectCode() redirection hook - TPatchCode = array[0..4] of byte; - /// pointer to a small memory buffer used to backup a RedirectCode() hook - PPatchCode = ^TPatchCode; - -/// self-modifying code - add an asm JUMP to a redirected function -// - if Backup is not nil, it should point to a TPatchCode buffer, ready -// to contain the overridden code buffer, for further hook disabling -procedure RedirectCode(Func, RedirectFunc: Pointer; Backup: PPatchCode=nil); - -/// self-modifying code - restore a code from its RedirectCode() backup -procedure RedirectCodeRestore(Func: pointer; const Backup: TPatchCode); -{$endif CPUINTEL} - -type - /// to be used instead of TMemoryStream, for speed - // - allocates memory from Delphi heap (i.e. FastMM4/SynScaleMM) - // and not GlobalAlloc(), as was the case for oldest versions of Delphi - // - uses bigger growing size of the capacity - // - consider using TRawByteStringStream, as we do in our units -{$ifdef LVCL} // LVCL already use Delphi heap instead of GlobalAlloc() - THeapMemoryStream = TMemoryStream; -{$else} - {$ifdef FPC} // FPC already use heap instead of GlobalAlloc() - THeapMemoryStream = TMemoryStream; - {$else} - {$ifndef UNICODE} // old Delphi used GlobalAlloc() - THeapMemoryStream = class(TMemoryStream) - protected - function Realloc(var NewCapacity: longint): Pointer; override; - end; - {$else} - THeapMemoryStream = TMemoryStream; - {$endif} - {$endif} -{$endif} - -var - /// a global "Garbage collector", for some classes instances which must - // live during whole main executable process - // - used to avoid any memory leak with e.g. 'class var RecordProps', i.e. - // some singleton or static objects - // - to be used, e.g. as: - // ! Version := TFileVersion.Create(InstanceFileName,DefaultVersion32); - // ! GarbageCollector.Add(Version); - // - see also GarbageCollectorFreeAndNil() as an alternative - GarbageCollector: TSynObjectList; - - /// set to TRUE when the global "Garbage collector" are beeing freed - GarbageCollectorFreeing: boolean; - -/// a global "Garbage collector" for some TObject global variables which must -// live during whole main executable process -// - this list expects a pointer to the TObject instance variable to be -// specified, and will be set to nil (like a FreeAndNil) -// - this may be useful when used when targetting Delphi IDE packages, -// to circumvent the bug of duplicated finalization of units, in the scope -// of global variables -// - to be used, e.g. as: -// ! if SynAnsiConvertList=nil then -// ! GarbageCollectorFreeAndNil(SynAnsiConvertList,TObjectList.Create); -procedure GarbageCollectorFreeAndNil(var InstanceVariable; Instance: TObject); - -/// force the global "Garbage collector" list to be released immediately -// - this function is called in the finalization section of this unit -// - you should NEVER have to call this function, unless some specific cases -// (e.g. when using Delphi packages, just before releasing the package) -procedure GarbageCollectorFree; - -/// enter a giant lock for thread-safe shared process -// - shall be protected as such: -// ! GlobalLock; -// ! try -// ! .... do something thread-safe but as short as possible -// ! finally -// ! GlobalUnLock; -// ! end; -// - you should better not use such a giant-lock, but an instance-dedicated -// critical section - these functions are just here to be convenient, for -// non time-critical process -procedure GlobalLock; - -/// release the giant lock for thread-safe shared process -// - you should better not use such a giant-lock, but an instance-dedicated -// critical section - these functions are just here to be convenient, for -// non time-critical process -procedure GlobalUnLock; - - -var - /// JSON compatible representation of a boolean value, i.e. 'false' and 'true' - // - can be used when a RawUTF8 string is expected - BOOL_UTF8: array[boolean] of RawUTF8; - -const - /// JSON compatible representation of a boolean value, i.e. 'false' and 'true' - // - can be used e.g. in logs, or anything accepting a shortstring - BOOL_STR: array[boolean] of string[7] = ('false','true'); - - /// can be used to append to most English nouns to form a plural - // - see also the Plural function - PLURAL_FORM: array[boolean] of RawUTF8 = ('','s'); - -/// write count number and append 's' (if needed) to form a plural English noun -// - for instance, Plural('row',100) returns '100 rows' with no heap allocation -function Plural(const itemname: shortstring; itemcount: cardinal): shortstring; - -/// returns TRUE if the specified field name is either 'ID', either 'ROWID' -function IsRowID(FieldName: PUTF8Char): boolean; - {$ifdef HASINLINE}inline;{$endif} overload; - -/// returns TRUE if the specified field name is either 'ID', either 'ROWID' -function IsRowID(FieldName: PUTF8Char; FieldLen: integer): boolean; - {$ifdef HASINLINE}inline;{$endif} overload; - -/// returns TRUE if the specified field name is either 'ID', either 'ROWID' -function IsRowIDShort(const FieldName: shortstring): boolean; - {$ifdef HASINLINE}inline;{$endif} overload; - -/// retrieve the next SQL-like identifier within the UTF-8 buffer -// - will also trim any space (or line feeds) and trailing ';' -// - any comment like '/*nocache*/' will be ignored -// - returns true if something was set to Prop -function GetNextFieldProp(var P: PUTF8Char; var Prop: RawUTF8): boolean; - -/// retrieve the next identifier within the UTF-8 buffer on the same line -// - GetNextFieldProp() will just handle line feeds (and ';') as spaces - which -// is fine e.g. for SQL, but not for regular config files with name/value pairs -// - returns true if something was set to Prop -function GetNextFieldPropSameLine(var P: PUTF8Char; var Prop: ShortString): boolean; - - -{ ************ variant-based process, including JSON/BSON document content } - -const - /// unsigned 64bit integer variant type - // - currently called varUInt64 in Delphi (not defined in older versions), - // and varQWord in FPC - varWord64 = 21; - - /// this variant type will map the current SynUnicode type - // - depending on the compiler version - varSynUnicode = {$ifdef HASVARUSTRING}varUString{$else}varOleStr{$endif}; - - /// this variant type will map the current string type - // - depending on the compiler version - varNativeString = {$ifdef UNICODE}varUString{$else}varString{$endif}; - -{$ifdef HASINLINE} -/// overloaded function which can be properly inlined -procedure VarClear(var v: variant); inline; -{$endif HASINLINE} - -/// same as Dest := TVarData(Source) for simple values -// - will return TRUE for all simple values after varByRef unreference, and -// copying the unreferenced Source value into Dest raw storage -// - will return FALSE for not varByRef values, or complex values (e.g. string) -function SetVariantUnRefSimpleValue(const Source: variant; var Dest: TVarData): boolean; - {$ifdef HASINLINE}inline;{$endif} - -{$ifndef LVCL} - -/// convert a raw binary buffer into a variant RawByteString varString -// - you can then use VariantToRawByteString() to retrieve the binary content -procedure RawByteStringToVariant(Data: PByte; DataLen: Integer; var Value: variant); overload; - -/// convert a RawByteString content into a variant varString -// - you can then use VariantToRawByteString() to retrieve the binary content -procedure RawByteStringToVariant(const Data: RawByteString; var Value: variant); overload; - -/// convert back a RawByteString from a variant -// - the supplied variant should have been created via a RawByteStringToVariant() -// function call -procedure VariantToRawByteString(const Value: variant; var Dest: RawByteString); - -/// same as Value := Null, but slightly faster -procedure SetVariantNull(var Value: variant); - {$ifdef HASINLINE}inline;{$endif} - -const - NullVarData: TVarData = (VType: varNull); -var - /// a slightly faster alternative to Variants.Null function - Null: variant absolute NullVarData; - -{$endif LVCL} - -/// same as VarIsEmpty(V) or VarIsEmpty(V), but faster -// - we also discovered some issues with FPC's Variants unit, so this function -// may be used even in end-user cross-compiler code -function VarIsEmptyOrNull(const V: Variant): Boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// same as VarIsEmpty(PVariant(V)^) or VarIsEmpty(PVariant(V)^), but faster -// - we also discovered some issues with FPC's Variants unit, so this function -// may be used even in end-user cross-compiler code -function VarDataIsEmptyOrNull(VarData: pointer): Boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// fastcheck if a variant hold a value -// - varEmpty, varNull or a '' string would be considered as void -// - varBoolean=false or varDate=0 would be considered as void -// - a TDocVariantData with Count=0 would be considered as void -// - any other value (e.g. integer) would be considered as not void -function VarIsVoid(const V: Variant): boolean; - -/// returns a supplied string as variant, or null if v is void ('') -function VarStringOrNull(const v: RawUTF8): variant; - -type - TVarDataTypes = set of 0..255; - -/// allow to check for a specific set of TVarData.VType -function VarIs(const V: Variant; const VTypes: TVarDataTypes): Boolean; - {$ifdef HASINLINE}inline;{$endif} - -{$ifndef NOVARIANTS} - -type - /// custom variant handler with easier/faster access of variant properties, - // and JSON serialization support - // - default GetProperty/SetProperty methods are called via some protected - // virtual IntGet/IntSet methods, with less overhead (to be overriden) - // - these kind of custom variants will be faster than the default - // TInvokeableVariantType for properties getter/setter, but you should - // manually register each type by calling SynRegisterCustomVariantType() - // - also feature custom JSON parsing, via TryJSONToVariant() protected method - TSynInvokeableVariantType = class(TInvokeableVariantType) - protected - {$ifndef FPC} - {$ifndef DELPHI6OROLDER} - /// our custom call backs do not want the function names to be uppercased - function FixupIdent(const AText: string): string; override; - {$endif} - {$endif} - /// override those two abstract methods for fast getter/setter implementation - function IntGet(var Dest: TVarData; const Instance: TVarData; - Name: PAnsiChar; NameLen: PtrInt): boolean; virtual; - function IntSet(const Instance, Value: TVarData; - Name: PAnsiChar; NameLen: PtrInt): boolean; virtual; - public - /// search of a registered custom variant type from its low-level VarType - // - will first compare with its own VarType for efficiency - function FindSynVariantType(aVarType: Word; out CustomType: TSynInvokeableVariantType): boolean; - /// customization of JSON parsing into variants - // - will be called by e.g. by VariantLoadJSON() or GetVariantFromJSON() - // with Options: PDocVariantOptions parameter not nil - // - this default implementation will always returns FALSE, - // meaning that the supplied JSON is not to be handled by this custom - // (abstract) variant type - // - this method could be overridden to identify any custom JSON content - // and convert it into a dedicated variant instance, then return TRUE - // - warning: should NOT modify JSON buffer in-place, unless it returns true - function TryJSONToVariant(var JSON: PUTF8Char; var Value: variant; - EndOfObject: PUTF8Char): boolean; virtual; - /// customization of variant into JSON serialization - procedure ToJSON(W: TTextWriter; const Value: variant; Escape: TTextWriterKind); overload; virtual; - /// retrieve the field/column value - // - this method will call protected IntGet abstract method - function GetProperty(var Dest: TVarData; const V: TVarData; - const Name: String): Boolean; override; - /// set the field/column value - // - this method will call protected IntSet abstract method - {$ifdef FPC_VARIANTSETVAR} // see http://mantis.freepascal.org/view.php?id=26773 - function SetProperty(var V: TVarData; const Name: string; - const Value: TVarData): Boolean; override; - {$else} - function SetProperty(const V: TVarData; const Name: string; - const Value: TVarData): Boolean; override; - {$endif} - /// clear the content - // - this default implementation will set VType := varEmpty - // - override it if your custom type needs to manage its internal memory - procedure Clear(var V: TVarData); override; - /// copy two variant content - // - this default implementation will copy the TVarData memory - // - override it if your custom type needs to manage its internal structure - procedure Copy(var Dest: TVarData; const Source: TVarData; - const Indirect: Boolean); override; - /// copy two variant content by value - // - this default implementation will call the Copy() method - // - override it if your custom types may use a by reference copy pattern - procedure CopyByValue(var Dest: TVarData; const Source: TVarData); virtual; - /// this method will allow to look for dotted name spaces, e.g. 'parent.child' - // - should return Unassigned if the FullName does not match any value - // - will identify TDocVariant storage, or resolve and call the generic - // TSynInvokeableVariantType.IntGet() method until nested value match - procedure Lookup(var Dest: TVarData; const Instance: TVarData; FullName: PUTF8Char); - /// will check if the value is an array, and return the number of items - // - if the document is an array, will return the items count (0 meaning - // void array) - used e.g. by TSynMustacheContextVariant - // - this default implementation will return -1 (meaning this is not an array) - // - overridden method could implement it, e.g. for TDocVariant of kind dvArray - function IterateCount(const V: TVarData): integer; virtual; - /// allow to loop over an array document - // - Index should be in 0..IterateCount-1 range - // - this default implementation will do nothing - procedure Iterate(var Dest: TVarData; const V: TVarData; Index: integer); virtual; - /// returns TRUE if the supplied variant is of the exact custom type - function IsOfType(const V: variant): boolean; - {$ifdef HASINLINE}inline;{$endif} - end; - - /// class-reference type (metaclass) of custom variant type definition - // - used by SynRegisterCustomVariantType() function - TSynInvokeableVariantTypeClass = class of TSynInvokeableVariantType; - -/// register a custom variant type to handle properties -// - this will implement an internal mechanism used to bypass the default -// _DispInvoke() implementation in Variant.pas, to use a faster version -// - is called in case of TSynTableVariant, TDocVariant, TBSONVariant or -// TSQLDBRowVariant -function SynRegisterCustomVariantType(aClass: TSynInvokeableVariantTypeClass): TSynInvokeableVariantType; - -/// same as Dest := Source, but copying by reference -// - i.e. VType is defined as varVariant or varByRef -// - for instance, it will be used for late binding of TDocVariant properties, -// to let following statements work as expected: -// ! V := _Json('{arr:[1,2]}'); -// ! V.arr.Add(3); // will work, since V.arr will be returned by reference -// ! writeln(V); // will write '{"arr":[1,2,3]}' -procedure SetVariantByRef(const Source: Variant; var Dest: Variant); - -/// same as Dest := Source, but copying by value -// - will unreference any varByRef content -// - will convert any string value into RawUTF8 (varString) for consistency -procedure SetVariantByValue(const Source: Variant; var Dest: Variant); - -/// same as FillChar(Value^,SizeOf(TVarData),0) -// - so can be used for TVarData or Variant -// - it will set V.VType := varEmpty, so Value will be Unassigned -// - it won't call VarClear(variant(Value)): it should have been cleaned before -procedure ZeroFill(Value: PVarData); {$ifdef HASINLINE}inline;{$endif} - -/// fill all bytes of the value's memory buffer with zeros, i.e. 'toto' -> #0#0#0#0 -// - may be used to cleanup stack-allocated content -procedure FillZero(var value: variant); overload; - -/// retrieve a variant value from variable-length buffer -// - matches TFileBufferWriter.Write() -// - how custom type variants are created can be defined via CustomVariantOptions -// - is just a wrapper around VariantLoad() -procedure FromVarVariant(var Source: PByte; var Value: variant; - CustomVariantOptions: PDocVariantOptions=nil); {$ifdef HASINLINE}inline;{$endif} - -/// compute the number of bytes needed to save a Variant content -// using the VariantSave() function -// - will return 0 in case of an invalid (not handled) Variant type -function VariantSaveLength(const Value: variant): integer; - -/// save a Variant content into a destination memory buffer -// - Dest must be at least VariantSaveLength() bytes long -// - will handle standard Variant types and custom types (serialized as JSON) -// - will return nil in case of an invalid (not handled) Variant type -// - will use a proprietary binary format, with some variable-length encoding -// of the string length -// - warning: will encode generic string fields as within the variant type -// itself: using this function between UNICODE and NOT UNICODE -// versions of Delphi, will propably fail - you have been warned! -function VariantSave(const Value: variant; Dest: PAnsiChar): PAnsiChar; overload; - -/// save a Variant content into a binary buffer -// - will handle standard Variant types and custom types (serialized as JSON) -// - will return '' in case of an invalid (not handled) Variant type -// - just a wrapper around VariantSaveLength()+VariantSave() -// - warning: will encode generic string fields as within the variant type -// itself: using this function between UNICODE and NOT UNICODE -// versions of Delphi, will propably fail - you have been warned! -function VariantSave(const Value: variant): RawByteString; overload; - -/// retrieve a variant value from our optimized binary serialization format -// - follow the data layout as used by RecordLoad() or VariantSave() function -// - return nil if the Source buffer is incorrect -// - in case of success, return the memory buffer pointer just after the -// read content -// - how custom type variants are created can be defined via CustomVariantOptions -function VariantLoad(var Value: variant; Source: PAnsiChar; - CustomVariantOptions: PDocVariantOptions; SourceMax: PAnsiChar=nil): PAnsiChar; overload; - -/// retrieve a variant value from our optimized binary serialization format -// - follow the data layout as used by RecordLoad() or VariantSave() function -// - return varEmpty if the Source buffer is incorrect -// - just a wrapper around VariantLoad() -// - how custom type variants are created can be defined via CustomVariantOptions -function VariantLoad(const Bin: RawByteString; - CustomVariantOptions: PDocVariantOptions): variant; overload; - -/// retrieve a variant value from a JSON number or string -// - follows TTextWriter.AddVariant() format (calls GetVariantFromJSON) -// - will instantiate either an Integer, Int64, currency, double or string value -// (as RawUTF8), guessing the best numeric type according to the textual content, -// and string in all other cases, except TryCustomVariants points to some options -// (e.g. @JSON_OPTIONS[true] for fast instance) and input is a known object or -// array, either encoded as strict-JSON (i.e. {..} or [..]), or with some -// extended (e.g. BSON) syntax -// - warning: the JSON buffer will be modified in-place during process - use -// a temporary copy or the overloaded functions with RawUTF8 parameter -// if you need to access it later -function VariantLoadJSON(var Value: variant; JSON: PUTF8Char; - EndOfObject: PUTF8Char=nil; TryCustomVariants: PDocVariantOptions=nil; - AllowDouble: boolean=false): PUTF8Char; overload; - -/// retrieve a variant value from a JSON number or string -// - follows TTextWriter.AddVariant() format (calls GetVariantFromJSON) -// - will instantiate either an Integer, Int64, currency, double or string value -// (as RawUTF8), guessing the best numeric type according to the textual content, -// and string in all other cases, except TryCustomVariants points to some options -// (e.g. @JSON_OPTIONS[true] for fast instance) and input is a known object or -// array, either encoded as strict-JSON (i.e. {..} or [..]), or with some -// extended (e.g. BSON) syntax -// - this overloaded procedure will make a temporary copy before JSON parsing -// and return the variant as result -procedure VariantLoadJSON(var Value: Variant; const JSON: RawUTF8; - TryCustomVariants: PDocVariantOptions=nil; AllowDouble: boolean=false); overload; - -/// retrieve a variant value from a JSON number or string -// - follows TTextWriter.AddVariant() format (calls GetVariantFromJSON) -// - will instantiate either an Integer, Int64, currency, double or string value -// (as RawUTF8), guessing the best numeric type according to the textual content, -// and string in all other cases, except TryCustomVariants points to some options -// (e.g. @JSON_OPTIONS[true] for fast instance) and input is a known object or -// array, either encoded as strict-JSON (i.e. {..} or [..]), or with some -// extended (e.g. BSON) syntax -// - this overloaded procedure will make a temporary copy before JSON parsing -// and return the variant as result -function VariantLoadJSON(const JSON: RawUTF8; - TryCustomVariants: PDocVariantOptions=nil; AllowDouble: boolean=false): variant; overload; - -/// save a variant value into a JSON content -// - follows the TTextWriter.AddVariant() and VariantLoadJSON() format -// - is able to handle simple and custom variant types, for instance: -// ! VariantSaveJSON(1.5)='1.5' -// ! VariantSaveJSON('test')='"test"' -// ! o := _Json('{ BSON: [ "test", 5.05, 1986 ] }'); -// ! VariantSaveJSON(o)='{"BSON":["test",5.05,1986]}' -// ! o := _Obj(['name','John','doc',_Obj(['one',1,'two',_Arr(['one',2])])]); -// ! VariantSaveJSON(o)='{"name":"John","doc":{"one":1,"two":["one",2]}}' -// - note that before Delphi 2009, any varString value is expected to be -// a RawUTF8 instance - which does make sense in the mORMot area -function VariantSaveJSON(const Value: variant; Escape: TTextWriterKind=twJSONEscape): RawUTF8; overload; - -/// save a variant value into a JSON content -// - follows the TTextWriter.AddVariant() and VariantLoadJSON() format -// - is able to handle simple and custom variant types, for instance: -// ! VariantSaveJSON(1.5)='1.5' -// ! VariantSaveJSON('test')='"test"' -// ! o := _Json('{BSON: ["test", 5.05, 1986]}'); -// ! VariantSaveJSON(o)='{"BSON":["test",5.05,1986]}' -// ! o := _Obj(['name','John','doc',_Obj(['one',1,'two',_Arr(['one',2])])]); -// ! VariantSaveJSON(o)='{"name":"John","doc":{"one":1,"two":["one",2]}}' -// - note that before Delphi 2009, any varString value is expected to be -// a RawUTF8 instance - which does make sense in the mORMot area -procedure VariantSaveJSON(const Value: variant; Escape: TTextWriterKind; - var result: RawUTF8); overload; - -/// compute the number of chars needed to save a variant value into a JSON content -// - follows the TTextWriter.AddVariant() and VariantLoadJSON() format -// - this will be much faster than length(VariantSaveJSON()) for huge content -// - note that before Delphi 2009, any varString value is expected to be -// a RawUTF8 instance - which does make sense in the mORMot area -function VariantSaveJSONLength(const Value: variant; Escape: TTextWriterKind=twJSONEscape): integer; - -/// low-level function to set a variant from an unescaped JSON number or string -// - expect the JSON input buffer to be already unescaped, e.g. by GetJSONField() -// - is called e.g. by function VariantLoadJSON() -// - will instantiate either a null, boolean, Integer, Int64, currency, double -// (if AllowDouble is true or dvoAllowDoubleValue is in TryCustomVariants^) or -// string value (as RawUTF8), guessing the best numeric type according to the textual content, -// and string in all other cases, except if TryCustomVariants points to some -// options (e.g. @JSON_OPTIONS[true] for fast instance) and input is a known -// object or array, either encoded as strict-JSON (i.e. {..} or [..]), -// or with some extended (e.g. BSON) syntax -procedure GetVariantFromJSON(JSON: PUTF8Char; wasString: Boolean; var Value: variant; - TryCustomVariants: PDocVariantOptions=nil; AllowDouble: boolean=false); - -/// low-level function to set a variant from an unescaped JSON non string -// - expect the JSON input buffer to be already unescaped, e.g. by GetJSONField(), -// and having returned wasString=TRUE (i.e. not surrounded by double quotes) -// - is called e.g. by function GetVariantFromJSON() -// - will recognize null, boolean, Integer, Int64, currency, double -// (if AllowDouble is true) input, then set Value and return TRUE -// - returns FALSE if the supplied input has no expected JSON format -function GetVariantFromNotStringJSON(JSON: PUTF8Char; var Value: TVarData; - AllowDouble: boolean): boolean; - -/// identify either varInt64, varDouble, varCurrency types following JSON format -// - any non valid number is returned as varString -// - is used e.g. by GetVariantFromJSON() to guess the destination variant type -// - warning: supplied JSON is expected to be not nil -function TextToVariantNumberType(JSON: PUTF8Char): cardinal; - -/// identify either varInt64 or varCurrency types following JSON format -// - this version won't return varDouble, i.e. won't handle more than 4 exact -// decimals (as varCurrency), nor scientific notation with exponent (1.314e10) -// - this will ensure that any incoming JSON will converted back with its exact -// textual representation, without digit truncation due to limited precision -// - any non valid number is returned as varString -// - is used e.g. by GetVariantFromJSON() to guess the destination variant type -// - warning: supplied JSON is expected to be not nil -function TextToVariantNumberTypeNoDouble(JSON: PUTF8Char): cardinal; - -/// low-level function to set a numerical variant from an unescaped JSON number -// - returns TRUE if TextToVariantNumberType/TextToVariantNumberTypeNoDouble(JSON) -// identified it as a number and set Value to the corresponding content -// - returns FALSE if JSON is a string, or null/true/false -function GetNumericVariantFromJSON(JSON: PUTF8Char; var Value: TVarData; - AllowVarDouble: boolean): boolean; - -/// convert the next CSV item from an UTF-8 encoded text buffer -// into a variant number or RawUTF8 varString -// - first try with GetNumericVariantFromJSON(), then fallback to RawUTF8ToVariant -// - is a wrapper around GetNextItem() + TextToVariant() -function GetNextItemToVariant(var P: PUTF8Char; out Value: Variant; - Sep: AnsiChar= ','; AllowDouble: boolean=true): boolean; - -/// retrieve a variant value from a JSON buffer as per RFC 8259, RFC 7159, RFC 7158 -// - follows TTextWriter.AddVariant() format (calls GetVariantFromJSON) -// - will instantiate either an Integer, Int64, currency, double or string value -// (as RawUTF8), guessing the best numeric type according to the textual content, -// and string in all other cases, except TryCustomVariants points to some options -// (e.g. @JSON_OPTIONS[true] for fast instance) and input is a known object or -// array, either encoded as strict-JSON (i.e. {..} or [..]), or with some -// extended (e.g. BSON) syntax -// - warning: the JSON buffer will be modified in-place during process - use -// a temporary copy or the overloaded functions with RawUTF8 parameter -// if you need to access it later -procedure JSONToVariantInPlace(var Value: Variant; JSON: PUTF8Char; - Options: TDocVariantOptions=[dvoReturnNullForUnknownProperty]; - AllowDouble: boolean=false); - -/// retrieve a variant value from a JSON UTF-8 text as per RFC 8259, RFC 7159, RFC 7158 -// - follows TTextWriter.AddVariant() format (calls GetVariantFromJSON) -// - will instantiate either an Integer, Int64, currency, double or string value -// (as RawUTF8), guessing the best numeric type according to the textual content, -// and string in all other cases, except TryCustomVariants points to some options -// (e.g. @JSON_OPTIONS[true] for fast instance) and input is a known object or -// array, either encoded as strict-JSON (i.e. {..} or [..]), or with some -// extended (e.g. BSON) syntax -// - this overloaded procedure will make a temporary copy before JSON parsing -// and return the variant as result -function JSONToVariant(const JSON: RawUTF8; - Options: TDocVariantOptions=[dvoReturnNullForUnknownProperty]; - AllowDouble: boolean=false): variant; - -/// convert an UTF-8 encoded text buffer into a variant number or RawUTF8 varString -// - first try with GetNumericVariantFromJSON(), then fallback to RawUTF8ToVariant -procedure TextToVariant(const aValue: RawUTF8; AllowVarDouble: boolean; - out aDest: variant); - -/// convert an UTF-8 encoded text buffer into a variant RawUTF8 varString -procedure RawUTF8ToVariant(Txt: PUTF8Char; TxtLen: integer; var Value: variant); overload; - -/// convert an UTF-8 encoded string into a variant RawUTF8 varString -procedure RawUTF8ToVariant(const Txt: RawUTF8; var Value: variant); overload; - -/// convert a FormatUTF8() UTF-8 encoded string into a variant RawUTF8 varString -procedure FormatUTF8ToVariant(const Fmt: RawUTF8; const Args: array of const; var Value: variant); - -/// convert an UTF-8 encoded string into a variant RawUTF8 varString -function RawUTF8ToVariant(const Txt: RawUTF8): variant; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert an UTF-8 encoded text buffer into a variant RawUTF8 varString -// - this overloaded version expects a destination variant type (e.g. varString -// varOleStr / varUString) - if the type is not handled, will raise an -// EVariantTypeCastError -procedure RawUTF8ToVariant(const Txt: RawUTF8; var Value: TVarData; - ExpectedValueType: cardinal); overload; - -/// convert an open array (const Args: array of const) argument to a variant -// - note that, due to a Delphi compiler limitation, cardinal values should be -// type-casted to Int64() (otherwise the integer mapped value will be converted) -procedure VarRecToVariant(const V: TVarRec; var result: variant); overload; - -/// convert an open array (const Args: array of const) argument to a variant -// - note that, due to a Delphi compiler limitation, cardinal values should be -// type-casted to Int64() (otherwise the integer mapped value will be converted) -function VarRecToVariant(const V: TVarRec): variant; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert a variant to an open array (const Args: array of const) argument -// - will always map to a vtVariant kind of argument -procedure VariantToVarRec(const V: variant; var result: TVarRec); - {$ifdef HASINLINE}inline;{$endif} - -/// convert a dynamic array of variants into its JSON serialization -// - will use a TDocVariantData temporary storage -function VariantDynArrayToJSON(const V: TVariantDynArray): RawUTF8; - -/// convert a JSON array into a dynamic array of variants -// - will use a TDocVariantData temporary storage -function JSONToVariantDynArray(const JSON: RawUTF8): TVariantDynArray; - -/// convert an open array list into a dynamic array of variants -// - will use a TDocVariantData temporary storage -function ValuesToVariantDynArray(const items: array of const): TVariantDynArray; - -type - /// pointer to a TDocVariant storage - // - since variants may be stored by reference (i.e. as varByRef), it may - // be a good idea to use such a pointer via DocVariantData(aVariant)^ or - // _Safe(aVariant)^ instead of TDocVariantData(aVariant), - // if you are not sure how aVariant was allocated (may be not _Obj/_Json) - PDocVariantData = ^TDocVariantData; - - /// a custom variant type used to store any JSON/BSON document-based content - // - i.e. name/value pairs for objects, or an array of values (including - // nested documents), stored in a TDocVariantData memory structure - // - you can use _Obj()/_ObjFast() _Arr()/_ArrFast() _Json()/_JsonFast() or - // _JsonFmt()/_JsonFastFmt() functions to create instances of such variants - // - property access may be done via late-binding - with some restrictions - // for older versions of FPC, e.g. allowing to write: - // ! TDocVariant.NewFast(aVariant); - // ! aVariant.Name := 'John'; - // ! aVariant.Age := 35; - // ! writeln(aVariant.Name,' is ',aVariant.Age,' years old'); - // - it also supports a small set of pseudo-properties or pseudo-methods: - // ! aVariant._Count = DocVariantData(aVariant).Count - // ! aVariant._Kind = ord(DocVariantData(aVariant).Kind) - // ! aVariant._JSON = DocVariantData(aVariant).JSON - // ! aVariant._(i) = DocVariantData(aVariant).Value[i] - // ! aVariant.Value(i) = DocVariantData(aVariant).Value[i] - // ! aVariant.Value(aName) = DocVariantData(aVariant).Value[aName] - // ! aVariant.Name(i) = DocVariantData(aVariant).Name[i] - // ! aVariant.Add(aItem) = DocVariantData(aVariant).AddItem(aItem) - // ! aVariant._ := aItem = DocVariantData(aVariant).AddItem(aItem) - // ! aVariant.Add(aName,aValue) = DocVariantData(aVariant).AddValue(aName,aValue) - // ! aVariant.Exists(aName) = DocVariantData(aVariant).GetValueIndex(aName)>=0 - // ! aVariant.Delete(i) = DocVariantData(aVariant).Delete(i) - // ! aVariant.Delete(aName) = DocVariantData(aVariant).Delete(aName) - // ! aVariant.NameIndex(aName) = DocVariantData(aVariant).GetValueIndex(aName) - // - it features direct JSON serialization/unserialization, e.g.: - // ! assert(_Json('["one",2,3]')._JSON='["one",2,3]'); - // - it features direct trans-typing into a string encoded as JSON, e.g.: - // ! assert(_Json('["one",2,3]')='["one",2,3]'); - TDocVariant = class(TSynInvokeableVariantType) - protected - /// name and values interning are shared among all TDocVariantData instances - fInternNames, fInternValues: TRawUTF8Interning; - /// fast getter/setter implementation - function IntGet(var Dest: TVarData; const Instance: TVarData; - Name: PAnsiChar; NameLen: PtrInt): boolean; override; - function IntSet(const Instance, Value: TVarData; Name: PAnsiChar; NameLen: PtrInt): boolean; override; - public - /// initialize a variant instance to store some document-based content - // - by default, every internal value will be copied, so access of nested - // properties can be slow - if you expect the data to be read-only or not - // propagated into another place, set aOptions=[dvoValueCopiedByReference] - // will increase the process speed a lot - class procedure New(out aValue: variant; - aOptions: TDocVariantOptions=[]); overload; - {$ifdef HASINLINE}inline;{$endif} - /// initialize a variant instance to store per-reference document-based content - // - same as New(aValue,JSON_OPTIONS[true]); - // - to be used e.g. as - // !var v: variant; - // !begin - // ! TDocVariant.NewFast(v); - // ! ... - class procedure NewFast(out aValue: variant); overload; - {$ifdef HASINLINE}inline;{$endif} - /// ensure a variant is a TDocVariant instance - // - if aValue is not a TDocVariant, will create a new JSON_OPTIONS[true] - class procedure IsOfTypeOrNewFast(var aValue: variant); - /// initialize several variant instances to store document-based content - // - replace several calls to TDocVariantData.InitFast - // - to be used e.g. as - // !var v1,v2,v3: TDocVariantData; - // !begin - // ! TDocVariant.NewFast([@v1,@v2,@v3]); - // ! ... - class procedure NewFast(const aValues: array of PDocVariantData); overload; - /// initialize a variant instance to store some document-based content - // - you can use this function to create a variant, which can be nested into - // another document, e.g.: - // ! aVariant := TDocVariant.New; - // ! aVariant.id := 10; - // - by default, every internal value will be copied, so access of nested - // properties can be slow - if you expect the data to be read-only or not - // propagated into another place, set Options=[dvoValueCopiedByReference] - // will increase the process speed a lot - // - in practice, you should better use _Obj()/_ObjFast() _Arr()/_ArrFast() - // functions or TDocVariant.NewFast() - class function New(Options: TDocVariantOptions=[]): variant; overload; - {$ifdef HASINLINE}inline;{$endif} - /// initialize a variant instance to store some document-based object content - // - object will be initialized with data supplied two by two, as Name,Value - // pairs, e.g. - // ! aVariant := TDocVariant.NewObject(['name','John','year',1972]); - // which is the same as: - // ! TDocVariant.New(aVariant); - // ! TDocVariantData(aVariant).AddValue('name','John'); - // ! TDocVariantData(aVariant).AddValue('year',1972); - // - by default, every internal value will be copied, so access of nested - // properties can be slow - if you expect the data to be read-only or not - // propagated into another place, set Options=[dvoValueCopiedByReference] - // will increase the process speed a lot - // - in practice, you should better use the function _Obj() which is a - // wrapper around this class method - class function NewObject(const NameValuePairs: array of const; - Options: TDocVariantOptions=[]): variant; - /// initialize a variant instance to store some document-based array content - // - array will be initialized with data supplied as parameters, e.g. - // ! aVariant := TDocVariant.NewArray(['one',2,3.0]); - // which is the same as: - // ! TDocVariant.New(aVariant); - // ! TDocVariantData(aVariant).AddItem('one'); - // ! TDocVariantData(aVariant).AddItem(2); - // ! TDocVariantData(aVariant).AddItem(3.0); - // - by default, every internal value will be copied, so access of nested - // properties can be slow - if you expect the data to be read-only or not - // propagated into another place, set aOptions=[dvoValueCopiedByReference] - // will increase the process speed a lot - // - in practice, you should better use the function _Arr() which is a - // wrapper around this class method - class function NewArray(const Items: array of const; - Options: TDocVariantOptions=[]): variant; overload; - /// initialize a variant instance to store some document-based array content - // - array will be initialized with data supplied dynamic array of variants - class function NewArray(const Items: TVariantDynArray; - Options: TDocVariantOptions=[]): variant; overload; - /// initialize a variant instance to store some document-based object content - // from a supplied (extended) JSON content - // - in addition to the JSON RFC specification strict mode, this method will - // handle some BSON-like extensions, e.g. unquoted field names - // - a private copy of the incoming JSON buffer will be used, then - // it will call the TDocVariantData.InitJSONInPlace() method - // - to be used e.g. as: - // ! var V: variant; - // ! begin - // ! V := TDocVariant.NewJSON('{"id":10,"doc":{"name":"John","birthyear":1972}}'); - // ! assert(V.id=10); - // ! assert(V.doc.name='John'); - // ! assert(V.doc.birthYear=1972); - // ! // and also some pseudo-properties: - // ! assert(V._count=2); - // ! assert(V.doc._kind=ord(dvObject)); - // - or with a JSON array: - // ! V := TDocVariant.NewJSON('["one",2,3]'); - // ! assert(V._kind=ord(dvArray)); - // ! for i := 0 to V._count-1 do - // ! writeln(V._(i)); - // - by default, every internal value will be copied, so access of nested - // properties can be slow - if you expect the data to be read-only or not - // propagated into another place, add dvoValueCopiedByReference in Options - // will increase the process speed a lot - // - warning: exclude dvoAllowDoubleValue so won't parse any float, just currency - // - in practice, you should better use the function _Json()/_JsonFast() - // which are handy wrappers around this class method - class function NewJSON(const JSON: RawUTF8; - Options: TDocVariantOptions=[dvoReturnNullForUnknownProperty]): variant; - {$ifdef HASINLINE}inline;{$endif} - /// initialize a variant instance to store some document-based object content - // from a supplied existing TDocVariant instance - // - use it on a value returned as varByRef (e.g. by _() pseudo-method), - // to ensure the returned variant will behave as a stand-alone value - // - for instance, the following: - // ! oSeasons := TDocVariant.NewUnique(o.Seasons); - // is the same as: - // ! oSeasons := o.Seasons; - // ! _Unique(oSeasons); - // or even: - // ! oSeasons := _Copy(o.Seasons); - class function NewUnique(const SourceDocVariant: variant; - Options: TDocVariantOptions=[dvoReturnNullForUnknownProperty]): variant; - {$ifdef HASINLINE}inline;{$endif} - /// will return the unique element of a TDocVariant array or a default - // - if the value is a dvArray with one single item, it will this value - // - if the value is not a TDocVariant nor a dvArray with one single item, - // it wil return the default value - class procedure GetSingleOrDefault(const docVariantArray, default: variant; - var result: variant); - - /// finalize the stored information - destructor Destroy; override; - /// used by dvoInternNames for string interning of all Names[] values - function InternNames: TRawUTF8Interning; {$ifdef HASINLINE}inline;{$endif} - /// used by dvoInternValues for string interning of all RawUTF8 Values[] - function InternValues: TRawUTF8Interning; {$ifdef HASINLINE}inline;{$endif} - // this implementation will write the content as JSON object or array - procedure ToJSON(W: TTextWriter; const Value: variant; Escape: TTextWriterKind); override; - /// will check if the value is an array, and return the number of items - // - if the document is an array, will return the items count (0 meaning - // void array) - used e.g. by TSynMustacheContextVariant - // - this overridden method will implement it for dvArray instance kind - function IterateCount(const V: TVarData): integer; override; - /// allow to loop over an array document - // - Index should be in 0..IterateCount-1 range - // - this default implementation will do handle dvArray instance kind - procedure Iterate(var Dest: TVarData; const V: TVarData; Index: integer); override; - /// low-level callback to access internal pseudo-methods - // - mainly the _(Index: integer): variant method to retrieve an item - // if the document is an array - function DoFunction(var Dest: TVarData; const V: TVarData; - const Name: string; const Arguments: TVarDataArray): Boolean; override; - /// low-level callback to clear the content - procedure Clear(var V: TVarData); override; - /// low-level callback to copy two variant content - // - such copy will by default be done by-value, for safety - // - if you are sure you will use the variants as read-only, you can set - // the dvoValueCopiedByReference Option to use faster by-reference copy - procedure Copy(var Dest: TVarData; const Source: TVarData; - const Indirect: Boolean); override; - /// copy two variant content by value - // - overridden method since instance may use a by-reference copy pattern - procedure CopyByValue(var Dest: TVarData; const Source: TVarData); override; - /// handle type conversion - // - only types processed by now are string/OleStr/UnicodeString/date - procedure Cast(var Dest: TVarData; const Source: TVarData); override; - /// handle type conversion - // - only types processed by now are string/OleStr/UnicodeString/date - procedure CastTo(var Dest: TVarData; const Source: TVarData; - const AVarType: TVarType); override; - /// compare two variant values - // - it uses case-sensitive text comparison of the JSON representation - // of each variant (including TDocVariant instances) - procedure Compare(const Left, Right: TVarData; - var Relationship: TVarCompareResult); override; - end; - - /// define the TDocVariant storage layout - // - if it has one or more named properties, it is a dvObject - // - if it has no name property, it is a dvArray - TDocVariantKind = (dvUndefined, dvObject, dvArray); - - /// method used by TDocVariantData.ReduceAsArray to filter each object - // - should return TRUE if the item match the expectations - TOnReducePerItem = function(Item: PDocVariantData): boolean of object; - - /// method used by TDocVariantData.ReduceAsArray to filter each object - // - should return TRUE if the item match the expectations - TOnReducePerValue = function(const Value: variant): boolean of object; - - {$A-} { packet object not allowed since Delphi 2009 :( } - /// memory structure used for TDocVariant storage of any JSON/BSON - // document-based content as variant - // - i.e. name/value pairs for objects, or an array of values (including - // nested documents) - // - you can use _Obj()/_ObjFast() _Arr()/_ArrFast() _Json()/_JsonFast() or - // _JsonFmt()/_JsonFastFmt() functions to create instances of such variants - // - you can transtype such an allocated variant into TDocVariantData - // to access directly its internals (like Count or Values[]/Names[]): - // ! aVariantObject := TDocVariant.NewObject(['name','John','year',1972]); - // ! aVariantObject := _ObjFast(['name','John','year',1972]); - // ! with _Safe(aVariantObject)^ do - // ! for i := 0 to Count-1 do - // ! writeln(Names[i],'=',Values[i]); // for an object - // ! aVariantArray := TDocVariant.NewArray(['one',2,3.0]); - // ! aVariantArray := _JsonFast('["one",2,3.0]'); - // ! with _Safe(aVariantArray)^ do - // ! for i := 0 to Count-1 do - // ! writeln(Values[i]); // for an array - // - use "with _Safe(...)^ do" and not "with TDocVariantData(...) do" as the - // former will handle internal variant redirection (varByRef), e.g. from late - // binding or assigned another TDocVariant - // - Delphi "object" is buggy on stack -> also defined as record with methods - {$ifdef USERECORDWITHMETHODS}TDocVariantData = record - {$else}TDocVariantData = object {$endif} - private - VType: TVarType; - VOptions: TDocVariantOptions; - (* this structure uses all TVarData available space: no filler needed! - {$HINTS OFF} // does not complain if Filler is declared but never used - Filler: array[1..SizeOf(TVarData)-SizeOf(TVarType)-SizeOf(TDocVariantOptions)- - SizeOf(TDocVariantKind)-SizeOf(TRawUTF8DynArray)-SizeOf(TVariantDynArray)- - SizeOf(integer)] of byte; - {$HINTS ON} *) - VName: TRawUTF8DynArray; - VValue: TVariantDynArray; - VCount: integer; - // retrieve the value as varByRef - function GetValueOrItem(const aNameOrIndex: variant): variant; - procedure SetValueOrItem(const aNameOrIndex, aValue: variant); - function GetKind: TDocVariantKind; {$ifdef HASINLINE}inline;{$endif} - procedure SetOptions(const opt: TDocVariantOptions); // keep dvoIsObject/Array - {$ifdef HASINLINE}inline;{$endif} - procedure SetCapacity(aValue: integer); - function GetCapacity: integer; - {$ifdef HASINLINE}inline;{$endif} - // implement U[] I[] B[] D[] O[] O_[] A[] A_[] _[] properties - function GetOrAddIndexByName(const aName: RawUTF8): integer; - {$ifdef HASINLINE}inline;{$endif} - function GetOrAddPVariantByName(const aName: RawUTF8): PVariant; - {$ifdef HASINLINE}inline;{$endif} - function GetPVariantByName(const aName: RawUTF8): PVariant; - function GetRawUTF8ByName(const aName: RawUTF8): RawUTF8; - procedure SetRawUTF8ByName(const aName, aValue: RawUTF8); - function GetStringByName(const aName: RawUTF8): string; - procedure SetStringByName(const aName: RawUTF8; const aValue: string); - function GetInt64ByName(const aName: RawUTF8): Int64; - procedure SetInt64ByName(const aName: RawUTF8; const aValue: Int64); - function GetBooleanByName(const aName: RawUTF8): Boolean; - procedure SetBooleanByName(const aName: RawUTF8; aValue: Boolean); - function GetDoubleByName(const aName: RawUTF8): Double; - procedure SetDoubleByName(const aName: RawUTF8; const aValue: Double); - function GetDocVariantExistingByName(const aName: RawUTF8; - aNotMatchingKind: TDocVariantKind): PDocVariantData; - function GetObjectExistingByName(const aName: RawUTF8): PDocVariantData; - function GetDocVariantOrAddByName(const aName: RawUTF8; - aKind: TDocVariantKind): PDocVariantData; - function GetObjectOrAddByName(const aName: RawUTF8): PDocVariantData; - function GetArrayExistingByName(const aName: RawUTF8): PDocVariantData; - function GetArrayOrAddByName(const aName: RawUTF8): PDocVariantData; - function GetAsDocVariantByIndex(aIndex: integer): PDocVariantData; - public - /// initialize a TDocVariantData to store some document-based content - // - can be used with a stack-allocated TDocVariantData variable: - // !var Doc: TDocVariantData; // stack-allocated variable - // !begin - // ! Doc.Init; - // ! Doc.AddValue('name','John'); - // ! assert(Doc.Value['name']='John'); - // ! assert(variant(Doc).name='John'); - // !end; - // - if you call Init*() methods in a row, ensure you call Clear in-between - procedure Init(aOptions: TDocVariantOptions=[]; aKind: TDocVariantKind=dvUndefined); - /// initialize a TDocVariantData to store per-reference document-based content - // - same as Doc.Init(JSON_OPTIONS[true]); - // - can be used with a stack-allocated TDocVariantData variable: - // !var Doc: TDocVariantData; // stack-allocated variable - // !begin - // ! Doc.InitFast; - // ! Doc.AddValue('name','John'); - // ! assert(Doc.Value['name']='John'); - // ! assert(variant(Doc).name='John'); - // !end; - // - see also TDocVariant.NewFast() if you want to initialize several - // TDocVariantData variable instances at once - // - if you call Init*() methods in a row, ensure you call Clear in-between - procedure InitFast; overload; - /// initialize a TDocVariantData to store per-reference document-based content - // - this overloaded method allows to specify an estimation of how many - // properties or items this aKind document would contain - procedure InitFast(InitialCapacity: integer; aKind: TDocVariantKind); overload; - /// initialize a TDocVariantData to store document-based object content - // - object will be initialized with data supplied two by two, as Name,Value - // pairs, e.g. - // !var Doc: TDocVariantData; // stack-allocated variable - // !begin - // ! Doc.InitObject(['name','John','year',1972]); - // which is the same as: - // ! var Doc: TDocVariantData; - // !begin - // ! Doc.Init; - // ! Doc.AddValue('name','John'); - // ! Doc.AddValue('year',1972); - // - this method is called e.g. by _Obj() and _ObjFast() global functions - // - if you call Init*() methods in a row, ensure you call Clear in-between - procedure InitObject(const NameValuePairs: array of const; - aOptions: TDocVariantOptions=[]); - /// initialize a variant instance to store some document-based array content - // - array will be initialized with data supplied as parameters, e.g. - // !var Doc: TDocVariantData; // stack-allocated variable - // !begin - // ! Doc.InitArray(['one',2,3.0]); - // ! assert(Doc.Count=3); - // !end; - // which is the same as: - // ! var Doc: TDocVariantData; - // ! i: integer; - // !begin - // ! Doc.Init; - // ! Doc.AddItem('one'); - // ! Doc.AddItem(2); - // ! Doc.AddItem(3.0); - // ! assert(Doc.Count=3); - // ! for i := 0 to Doc.Count-1 do - // ! writeln(Doc.Value[i]); - // !end; - // - this method is called e.g. by _Arr() and _ArrFast() global functions - // - if you call Init*() methods in a row, ensure you call Clear in-between - procedure InitArray(const Items: array of const; - aOptions: TDocVariantOptions=[]); - /// initialize a variant instance to store some document-based array content - // - array will be initialized with data supplied as variant dynamic array - // - if Items is [], the variant will be set as null - // - will be almost immediate, since TVariantDynArray is reference-counted, - // unless ItemsCopiedByReference is set to FALSE - // - if you call Init*() methods in a row, ensure you call Clear in-between - procedure InitArrayFromVariants(const Items: TVariantDynArray; - aOptions: TDocVariantOptions=[]; ItemsCopiedByReference: boolean=true); - /// initialize a variant instance to store some RawUTF8 array content - procedure InitArrayFrom(const Items: TRawUTF8DynArray; aOptions: TDocVariantOptions); overload; - /// initialize a variant instance to store some 32-bit integer array content - procedure InitArrayFrom(const Items: TIntegerDynArray; aOptions: TDocVariantOptions); overload; - /// initialize a variant instance to store some 64-bit integer array content - procedure InitArrayFrom(const Items: TInt64DynArray; aOptions: TDocVariantOptions); overload; - /// initialize a variant instance to store a T*ObjArray content - // - will call internally ObjectToVariant() to make the conversion - procedure InitArrayFromObjArray(const ObjArray; aOptions: TDocVariantOptions; - aWriterOptions: TTextWriterWriteObjectOptions=[woDontStoreDefault]); - /// initialize a variant instance to store document-based array content - // - array will be initialized from the supplied variable (which would be - // e.g. a T*ObjArray or a dynamic array), using RTTI - // - will use a temporary JSON serialization via SaveJSON() - procedure InitFromTypeInfo(const aValue; aTypeInfo: pointer; - aEnumSetsAsText: boolean; aOptions: TDocVariantOptions); - /// initialize a variant instance to store some document-based object content - // - object will be initialized with names and values supplied as dynamic arrays - // - if aNames and aValues are [] or do have matching sizes, the variant - // will be set as null - // - will be almost immediate, since Names and Values are reference-counted - // - if you call Init*() methods in a row, ensure you call Clear in-between - procedure InitObjectFromVariants(const aNames: TRawUTF8DynArray; - const aValues: TVariantDynArray; aOptions: TDocVariantOptions=[]); - /// initialize a variant instance to store a document-based object with a - // single property - // - the supplied path could be 'Main.Second.Third', to create nested - // objects, e.g. {"Main":{"Second":{"Third":value}}} - // - if you call Init*() methods in a row, ensure you call Clear in-between - procedure InitObjectFromPath(const aPath: RawUTF8; const aValue: variant; - aOptions: TDocVariantOptions=[]); - /// initialize a variant instance to store some document-based object content - // from a supplied JSON array or JSON object content - // - warning: the incoming JSON buffer will be modified in-place: so you should - // make a private copy before running this method, e.g. using TSynTempBuffer - // - this method is called e.g. by _JsonFmt() _JsonFastFmt() global functions - // with a temporary JSON buffer content created from a set of parameters - // - if you call Init*() methods in a row, ensure you call Clear in-between - function InitJSONInPlace(JSON: PUTF8Char; - aOptions: TDocVariantOptions=[]; aEndOfObject: PUTF8Char=nil): PUTF8Char; - /// initialize a variant instance to store some document-based object content - // from a supplied JSON array of JSON object content - // - a private copy of the incoming JSON buffer will be used, then - // it will call the other overloaded InitJSONInPlace() method - // - this method is called e.g. by _Json() and _JsonFast() global functions - // - if you call Init*() methods in a row, ensure you call Clear in-between - function InitJSON(const JSON: RawUTF8; aOptions: TDocVariantOptions=[]): boolean; - /// initialize a variant instance to store some document-based object content - // from a JSON array of JSON object content, stored in a file - // - any kind of file encoding will be handled, via AnyTextFileToRawUTF8() - // - you can optionally remove any comment from the file content - // - if you call Init*() methods in a row, ensure you call Clear in-between - function InitJSONFromFile(const JsonFile: TFileName; aOptions: TDocVariantOptions=[]; - RemoveComments: boolean=false): boolean; - /// ensure a document-based variant instance will have one unique options set - // - this will create a copy of the supplied TDocVariant instance, forcing - // all nested events to have the same set of Options - // - you can use this function to ensure that all internal properties of this - // variant will be copied e.g. per-reference (if you set JSON_OPTIONS[false]) - // or per-value (if you set JSON_OPTIONS[false]) whatever options the nested - // objects or arrays were created with - // - will raise an EDocVariant if the supplied variant is not a TDocVariant - // - you may rather use _Unique() or _UniqueFast() wrappers if you want to - // ensure that a TDocVariant instance is unique - // - if you call Init*() methods in a row, ensure you call Clear in-between - procedure InitCopy(const SourceDocVariant: variant; aOptions: TDocVariantOptions); - /// initialize a variant instance to store some document-based object content - // from a supplied CSV UTF-8 encoded text - // - the supplied content may have been generated by ToTextPairs() method - // - if ItemSep=#10, then any kind of line feed (CRLF or LF) will be handled - // - if you call Init*() methods in a row, ensure you call Clear in-between - procedure InitCSV(CSV: PUTF8Char; aOptions: TDocVariantOptions; - NameValueSep: AnsiChar='='; ItemSep: AnsiChar=#10; DoTrim: boolean=true); overload; - /// initialize a variant instance to store some document-based object content - // from a supplied CSV UTF-8 encoded text - // - the supplied content may have been generated by ToTextPairs() method - // - if ItemSep=#10, then any kind of line feed (CRLF or LF) will be handled - // - if you call Init*() methods in a row, ensure you call Clear in-between - procedure InitCSV(const CSV: RawUTF8; aOptions: TDocVariantOptions; - NameValueSep: AnsiChar='='; ItemSep: AnsiChar=#10; DoTrim: boolean=true); overload; - {$ifdef HASINLINE}inline;{$endif} - - /// to be called before any Init*() method call, when a previous Init*() - // has already be performed on the same instance, to avoid memory leaks - // - for instance: - // !var Doc: TDocVariantData; // stack-allocated variable - // !begin - // ! Doc.InitArray(['one',2,3.0]); // no need of any Doc.Clear here - // ! assert(Doc.Count=3); - // ! Doc.Clear; // to release memory before following InitObject() - // ! Doc.InitObject(['name','John','year',1972]); - // !end; - // - implemented as just a wrapper around DocVariantType.Clear() - procedure Clear; - /// delete all internal stored values - // - like Clear + Init() with the same options - // - will reset Kind to dvUndefined - procedure Reset; - /// fill all Values[] with #0, then delete all values - // - could be used to specifically remove sensitive information from memory - procedure FillZero; - /// low-level method to force a number of items - // - could be used to fast add items to the internal Values[]/Names[] arrays - // - just set protected VCount field, do not resize the arrays: caller - // should ensure that Capacity is big enough - procedure SetCount(aCount: integer); {$ifdef HASINLINE}inline;{$endif} - /// low-level method called internally to reserve place for new values - // - returns the index of the newly created item in Values[]/Names[] arrays - // - you should not have to use it, unless you want to add some items - // directly within the Values[]/Names[] arrays, using e.g. - // InitFast(InitialCapacity) to initialize the document - // - if aName='', append a dvArray item, otherwise append a dvObject field - // - warning: FPC optimizer is confused by Values[InternalAdd(name)] so - // you should call InternalAdd() in an explicit previous step - function InternalAdd(const aName: RawUTF8): integer; - - /// save a document as UTF-8 encoded JSON - // - will write either a JSON object or array, depending of the internal - // layout of this instance (i.e. Kind property value) - // - will write 'null' if Kind is dvUndefined - // - implemented as just a wrapper around VariantSaveJSON() - function ToJSON(const Prefix: RawUTF8=''; const Suffix: RawUTF8=''; - Format: TTextWriterJSONFormat=jsonCompact): RawUTF8; - /// save an array of objects as UTF-8 encoded non expanded layout JSON - // - returned content would be a JSON object in mORMot's TSQLTable non - // expanded format, with reduced JSON size, i.e. - // $ {"fieldCount":3,"values":["ID","FirstName","LastName",...']} - // - will write '' if Kind is dvUndefined or dvObject - // - will raise an exception if the array document is not an array of - // objects with identical field names - function ToNonExpandedJSON: RawUTF8; - /// save a document as an array of UTF-8 encoded JSON - // - will expect the document to be a dvArray - otherwise, will raise a - // EDocVariant exception - // - will use VariantToUTF8() to populate the result array: as a consequence, - // any nested custom variant types (e.g. TDocVariant) will be stored as JSON - procedure ToRawUTF8DynArray(out Result: TRawUTF8DynArray); overload; - /// save a document as an array of UTF-8 encoded JSON - // - will expect the document to be a dvArray - otherwise, will raise a - // EDocVariant exception - // - will use VariantToUTF8() to populate the result array: as a consequence, - // any nested custom variant types (e.g. TDocVariant) will be stored as JSON - function ToRawUTF8DynArray: TRawUTF8DynArray; overload; - {$ifdef HASINLINE}inline;{$endif} - /// save a document as an CSV of UTF-8 encoded JSON - // - will expect the document to be a dvArray - otherwise, will raise a - // EDocVariant exception - // - will use VariantToUTF8() to populate the result array: as a consequence, - // any nested custom variant types (e.g. TDocVariant) will be stored as JSON - function ToCSV(const Separator: RawUTF8=','): RawUTF8; - /// save a document as UTF-8 encoded Name=Value pairs - // - will follow by default the .INI format, but you can specify your - // own expected layout - procedure ToTextPairsVar(out result: RawUTF8; const NameValueSep: RawUTF8='='; - const ItemSep: RawUTF8=#13#10; Escape: TTextWriterKind=twJSONEscape); - /// save a document as UTF-8 encoded Name=Value pairs - // - will follow by default the .INI format, but you can specify your - // own expected layout - function ToTextPairs(const NameValueSep: RawUTF8='='; - const ItemSep: RawUTF8=#13#10; Escape: TTextWriterKind=twJSONEscape): RawUTF8; - {$ifdef HASINLINE}inline;{$endif} - /// save an array document as an array of TVarRec, i.e. an array of const - // - will expect the document to be a dvArray - otherwise, will raise a - // EDocVariant exception - // - would allow to write code as such: - // ! Doc.InitArray(['one',2,3]); - // ! Doc.ToArrayOfConst(vr); - // ! s := FormatUTF8('[%,%,%]',vr,[],true); - // ! // here s='[one,2,3]') since % would be replaced by Args[] parameters - // ! s := FormatUTF8('[?,?,?]',[],vr,true); - // ! // here s='["one",2,3]') since ? would be escaped by Params[] parameters - procedure ToArrayOfConst(out Result: TTVarRecDynArray); overload; - /// save an array document as an array of TVarRec, i.e. an array of const - // - will expect the document to be a dvArray - otherwise, will raise a - // EDocVariant exception - // - would allow to write code as such: - // ! Doc.InitArray(['one',2,3]); - // ! s := FormatUTF8('[%,%,%]',Doc.ToArrayOfConst,[],true); - // ! // here s='[one,2,3]') since % would be replaced by Args[] parameters - // ! s := FormatUTF8('[?,?,?]',[],Doc.ToArrayOfConst,true); - // ! // here s='["one",2,3]') since ? would be escaped by Params[] parameters - function ToArrayOfConst: TTVarRecDynArray; overload; - {$ifdef HASINLINE}inline;{$endif} - /// save an object document as an URI-encoded list of parameters - // - object field names should be plain ASCII-7 RFC compatible identifiers - // (0..9a..zA..Z_.~), otherwise their values are skipped - function ToUrlEncode(const UriRoot: RawUTF8): RawUTF8; - - /// find an item index in this document from its name - // - search will follow dvoNameCaseSensitive option of this document - // - lookup the value by name for an object document, or accept an integer - // text as index for an array document - // - returns -1 if not found - function GetValueIndex(const aName: RawUTF8): integer; overload; - {$ifdef HASINLINE}inline;{$endif} - /// find an item index in this document from its name - // - lookup the value by name for an object document, or accept an integer - // text as index for an array document - // - returns -1 if not found - function GetValueIndex(aName: PUTF8Char; aNameLen: PtrInt; aCaseSensitive: boolean): integer; overload; - /// find an item in this document, and returns its value - // - raise an EDocVariant if not found and dvoReturnNullForUnknownProperty - // is not set in Options (in this case, it will return Null) - function GetValueOrRaiseException(const aName: RawUTF8): variant; - /// find an item in this document, and returns its value - // - return the supplied default if aName is not found, or if the instance - // is not a TDocVariant - function GetValueOrDefault(const aName: RawUTF8; const aDefault: variant): variant; - /// find an item in this document, and returns its value - // - return null if aName is not found, or if the instance is not a TDocVariant - function GetValueOrNull(const aName: RawUTF8): variant; - /// find an item in this document, and returns its value - // - return a cleared variant if aName is not found, or if the instance is - // not a TDocVariant - function GetValueOrEmpty(const aName: RawUTF8): variant; - /// find an item in this document, and returns its value as enumerate - // - return false if aName is not found, if the instance is not a TDocVariant, - // or if the value is not a string corresponding to the supplied enumerate - // - return true if the name has been found, and aValue stores the value - // - will call Delete() on the found entry, if aDeleteFoundEntry is true - function GetValueEnumerate(const aName: RawUTF8; aTypeInfo: pointer; - out aValue; aDeleteFoundEntry: boolean=false): Boolean; - /// returns a TDocVariant object containing all properties matching the - // first characters of the supplied property name - // - returns null if the document is not a dvObject - // - will use IdemPChar(), so search would be case-insensitive - function GetValuesByStartName(const aStartName: RawUTF8; - TrimLeftStartName: boolean=false): variant; - /// returns a JSON object containing all properties matching the - // first characters of the supplied property name - // - returns null if the document is not a dvObject - // - will use IdemPChar(), so search would be case-insensitive - function GetJsonByStartName(const aStartName: RawUTF8): RawUTF8; - /// find an item in this document, and returns its value as TVarData - // - return false if aName is not found, or if the instance is not a TDocVariant - // - return true and set aValue if the name has been found - // - will use simple loop lookup to identify the name, unless aSortedCompare is - // set, and would let use a faster O(log(n)) binary search after a SortByName() - function GetVarData(const aName: RawUTF8; var aValue: TVarData; - aSortedCompare: TUTF8Compare=nil): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - /// find an item in this document, and returns its value as TVarData pointer - // - return nil if aName is not found, or if the instance is not a TDocVariant - // - return a pointer to the value if the name has been found - // - after a SortByName(aSortedCompare), could use faster binary search - function GetVarData(const aName: RawUTF8; - aSortedCompare: TUTF8Compare=nil): PVarData; overload; - /// find an item in this document, and returns its value as boolean - // - return false if aName is not found, or if the instance is not a TDocVariant - // - return true if the name has been found, and aValue stores the value - // - after a SortByName(aSortedCompare), could use faster binary search - // - consider using B[] property if you want simple read/write typed access - function GetAsBoolean(const aName: RawUTF8; out aValue: boolean; - aSortedCompare: TUTF8Compare=nil): Boolean; - /// find an item in this document, and returns its value as integer - // - return false if aName is not found, or if the instance is not a TDocVariant - // - return true if the name has been found, and aValue stores the value - // - after a SortByName(aSortedCompare), could use faster binary search - // - consider using I[] property if you want simple read/write typed access - function GetAsInteger(const aName: RawUTF8; out aValue: integer; - aSortedCompare: TUTF8Compare=nil): Boolean; - /// find an item in this document, and returns its value as integer - // - return false if aName is not found, or if the instance is not a TDocVariant - // - return true if the name has been found, and aValue stores the value - // - after a SortByName(aSortedCompare), could use faster binary search - // - consider using I[] property if you want simple read/write typed access - function GetAsInt64(const aName: RawUTF8; out aValue: Int64; - aSortedCompare: TUTF8Compare=nil): Boolean; - /// find an item in this document, and returns its value as floating point - // - return false if aName is not found, or if the instance is not a TDocVariant - // - return true if the name has been found, and aValue stores the value - // - after a SortByName(aSortedCompare), could use faster binary search - // - consider using D[] property if you want simple read/write typed access - function GetAsDouble(const aName: RawUTF8; out aValue: double; - aSortedCompare: TUTF8Compare=nil): Boolean; - /// find an item in this document, and returns its value as RawUTF8 - // - return false if aName is not found, or if the instance is not a TDocVariant - // - return true if the name has been found, and aValue stores the value - // - after a SortByName(aSortedCompare), could use faster binary search - // - consider using U[] property if you want simple read/write typed access - function GetAsRawUTF8(const aName: RawUTF8; out aValue: RawUTF8; - aSortedCompare: TUTF8Compare=nil): Boolean; - /// find an item in this document, and returns its value as a TDocVariantData - // - return false if aName is not found, or if the instance is not a TDocVariant - // - return true if the name has been found and points to a TDocVariant: - // then aValue stores a pointer to the value - // - after a SortByName(aSortedCompare), could use faster binary search - function GetAsDocVariant(const aName: RawUTF8; out aValue: PDocVariantData; - aSortedCompare: TUTF8Compare=nil): boolean; overload; - /// find an item in this document, and returns its value as a TDocVariantData - // - returns a void TDocVariant if aName is not a document - // - after a SortByName(aSortedCompare), could use faster binary search - // - consider using O[] or A[] properties if you want simple read-only - // access, or O_[] or A_[] properties if you want the ability to add - // a missing object or array in the document - function GetAsDocVariantSafe(const aName: RawUTF8; - aSortedCompare: TUTF8Compare=nil): PDocVariantData; - /// find an item in this document, and returns pointer to its value - // - return false if aName is not found - // - return true if the name has been found: then aValue stores a pointer - // to the value - // - after a SortByName(aSortedCompare), could use faster binary search - function GetAsPVariant(const aName: RawUTF8; out aValue: PVariant; - aSortedCompare: TUTF8Compare=nil): boolean; overload; {$ifdef HASINLINE}inline;{$endif} - /// find an item in this document, and returns pointer to its value - // - lookup the value by aName/aNameLen for an object document, or accept - // an integer text as index for an array document - // - return nil if aName is not found, or if the instance is not a TDocVariant - // - return a pointer to the stored variant, if the name has been found - function GetAsPVariant(aName: PUTF8Char; aNameLen: PtrInt): PVariant; overload; - {$ifdef HASINLINE}inline;{$endif} - /// retrieve a value, given its path - // - path is defined as a dotted name-space, e.g. 'doc.glossary.title' - // - it will return Unassigned if the path does match the supplied aPath - function GetValueByPath(const aPath: RawUTF8): variant; overload; - /// retrieve a value, given its path - // - path is defined as a dotted name-space, e.g. 'doc.glossary.title' - // - it will return FALSE if the path does not match the supplied aPath - // - returns TRUE and set the found value in aValue - function GetValueByPath(const aPath: RawUTF8; out aValue: variant): boolean; overload; - /// retrieve a value, given its path - // - path is defined as a list of names, e.g. ['doc','glossary','title'] - // - it will return Unassigned if the path does not match the data - // - this method will only handle nested TDocVariant values: use the - // slightly slower GetValueByPath() overloaded method, if any nested object - // may be of another type (e.g. a TBSONVariant) - function GetValueByPath(const aDocVariantPath: array of RawUTF8): variant; overload; - /// retrieve a reference to a value, given its path - // - path is defined as a dotted name-space, e.g. 'doc.glossary.title' - // - if the supplied aPath does not match any object, it will return nil - // - if aPath is found, returns a pointer to the corresponding value - function GetPVariantByPath(const aPath: RawUTF8): PVariant; - /// retrieve a reference to a TDocVariant, given its path - // - path is defined as a dotted name-space, e.g. 'doc.glossary.title' - // - if the supplied aPath does not match any object, it will return false - // - if aPath stores a valid TDocVariant, returns true and a pointer to it - function GetDocVariantByPath(const aPath: RawUTF8; out aValue: PDocVariantData): boolean; - /// retrieve a dvObject in the dvArray, from a property value - // - {aPropName:aPropValue} will be searched within the stored array, - // and the corresponding item will be copied into Dest, on match - // - returns FALSE if no match is found, TRUE if found and copied - // - create a copy of the variant by default, unless DestByRef is TRUE - // - will call VariantEquals() for value comparison - function GetItemByProp(const aPropName,aPropValue: RawUTF8; - aPropValueCaseSensitive: boolean; var Dest: variant; DestByRef: boolean=false): boolean; - /// retrieve a reference to a dvObject in the dvArray, from a property value - // - {aPropName:aPropValue} will be searched within the stored array, - // and the corresponding item will be copied into Dest, on match - // - returns FALSE if no match is found, TRUE if found and copied by reference - function GetDocVariantByProp(const aPropName,aPropValue: RawUTF8; - aPropValueCaseSensitive: boolean; out Dest: PDocVariantData): boolean; - /// find an item in this document, and returns its value - // - raise an EDocVariant if not found and dvoReturnNullForUnknownProperty - // is not set in Options (in this case, it will return Null) - // - create a copy of the variant by default, unless DestByRef is TRUE - function RetrieveValueOrRaiseException(aName: PUTF8Char; aNameLen: integer; - aCaseSensitive: boolean; var Dest: variant; DestByRef: boolean): boolean; overload; - /// retrieve an item in this document from its index, and returns its value - // - raise an EDocVariant if the supplied Index is not in the 0..Count-1 - // range and dvoReturnNullForUnknownProperty is set in Options - // - create a copy of the variant by default, unless DestByRef is TRUE - procedure RetrieveValueOrRaiseException(Index: integer; - var Dest: variant; DestByRef: boolean); overload; - /// retrieve an item in this document from its index, and returns its Name - // - raise an EDocVariant if the supplied Index is not in the 0..Count-1 - // range and dvoReturnNullForUnknownProperty is set in Options - procedure RetrieveNameOrRaiseException(Index: integer; var Dest: RawUTF8); - /// set an item in this document from its index - // - raise an EDocVariant if the supplied Index is not in 0..Count-1 range - procedure SetValueOrRaiseException(Index: integer; const NewValue: variant); - - /// add a value in this document - // - if aName is set, if dvoCheckForDuplicatedNames option is set, any - // existing duplicated aName will raise an EDocVariant; if instance's - // kind is dvArray and aName is defined, it will raise an EDocVariant - // - aName may be '' e.g. if you want to store an array: in this case, - // dvoCheckForDuplicatedNames option should not be set; if instance's Kind - // is dvObject, it will raise an EDocVariant exception - // - if aValueOwned is true, then the supplied aValue will be assigned to - // the internal values - by default, it will use SetVariantByValue() - // - you can therefore write e.g.: - // ! TDocVariant.New(aVariant); - // ! Assert(TDocVariantData(aVariant).Kind=dvUndefined); - // ! TDocVariantData(aVariant).AddValue('name','John'); - // ! Assert(TDocVariantData(aVariant).Kind=dvObject); - // - returns the index of the corresponding newly added value - function AddValue(const aName: RawUTF8; const aValue: variant; - aValueOwned: boolean=false): integer; overload; - /// add a value in this document - // - overloaded function accepting a UTF-8 encoded buffer for the name - function AddValue(aName: PUTF8Char; aNameLen: integer; const aValue: variant; - aValueOwned: boolean=false): integer; overload; - /// add a value in this document, or update an existing entry - // - if instance's Kind is dvArray, it will raise an EDocVariant exception - // - any existing Name would be updated with the new Value, unless - // OnlyAddMissing is set to TRUE, in which case existing values would remain - // - returns the index of the corresponding value, which may be just added - function AddOrUpdateValue(const aName: RawUTF8; const aValue: variant; - wasAdded: PBoolean=nil; OnlyAddMissing: boolean=false): integer; - /// add a value in this document, from its text representation - // - this function expects a UTF-8 text for the value, which would be - // converted to a variant number, if possible (as varInt/varInt64/varCurrency - // and/or as varDouble is AllowVarDouble is set) - // - if Update=TRUE, will set the property, even if it is existing - function AddValueFromText(const aName,aValue: RawUTF8; Update: boolean=false; - AllowVarDouble: boolean=false): integer; - /// add some properties to a TDocVariantData dvObject - // - data is supplied two by two, as Name,Value pairs - // - caller should ensure that Kind=dvObject, otherwise it won't do anything - // - any existing Name would be duplicated - procedure AddNameValuesToObject(const NameValuePairs: array of const); - /// merge some properties to a TDocVariantData dvObject - // - data is supplied two by two, as Name,Value pairs - // - caller should ensure that Kind=dvObject, otherwise it won't do anything - // - any existing Name would be updated with the new Value - procedure AddOrUpdateNameValuesToObject(const NameValuePairs: array of const); - /// merge some TDocVariantData dvObject properties to a TDocVariantData dvObject - // - data is supplied two by two, as Name,Value pairs - // - caller should ensure that both variants have Kind=dvObject, otherwise - // it won't do anything - // - any existing Name would be updated with the new Value, unless - // OnlyAddMissing is set to TRUE, in which case existing values would remain - procedure AddOrUpdateObject(const NewValues: variant; OnlyAddMissing: boolean=false; - RecursiveUpdate: boolean=false); - /// add a value to this document, handled as array - // - if instance's Kind is dvObject, it will raise an EDocVariant exception - // - you can therefore write e.g.: - // ! TDocVariant.New(aVariant); - // ! Assert(TDocVariantData(aVariant).Kind=dvUndefined); - // ! TDocVariantData(aVariant).AddItem('one'); - // ! Assert(TDocVariantData(aVariant).Kind=dvArray); - // - returns the index of the corresponding newly added item - function AddItem(const aValue: variant): integer; - /// add a value to this document, handled as array, from its text representation - // - this function expects a UTF-8 text for the value, which would be - // converted to a variant number, if possible (as varInt/varInt64/varCurrency - // unless AllowVarDouble is set) - // - if instance's Kind is dvObject, it will raise an EDocVariant exception - // - returns the index of the corresponding newly added item - function AddItemFromText(const aValue: RawUTF8; - AllowVarDouble: boolean=false): integer; - /// add a RawUTF8 value to this document, handled as array - // - if instance's Kind is dvObject, it will raise an EDocVariant exception - // - returns the index of the corresponding newly added item - function AddItemText(const aValue: RawUTF8): integer; - /// add one or several values to this document, handled as array - // - if instance's Kind is dvObject, it will raise an EDocVariant exception - procedure AddItems(const aValue: array of const); - /// add one or several values from another document - // - supplied document should be of the same kind than the current one, - // otherwise nothing is added - procedure AddFrom(const aDocVariant: Variant); - /// add or update or on several valeus from another object - // - current document should be an object - procedure AddOrUpdateFrom(const aDocVariant: Variant; aOnlyAddMissing: boolean=false); - /// add one or several properties, specified by path, from another object - // - path are defined as a dotted name-space, e.g. 'doc.glossary.title' - // - matching values would be added as root values, with the path as name - // - instance and supplied aSource should be a dvObject - procedure AddByPath(const aSource: TDocVariantData; const aPaths: array of RawUTF8); - /// delete a value/item in this document, from its index - // - return TRUE on success, FALSE if the supplied index is not correct - function Delete(Index: integer): boolean; overload; - /// delete a value/item in this document, from its name - // - return TRUE on success, FALSE if the supplied name does not exist - function Delete(const aName: RawUTF8): boolean; overload; - /// delete a value in this document, by property name match - // - {aPropName:aPropValue} will be searched within the stored array or - // object, and the corresponding item will be deleted, on match - // - returns FALSE if no match is found, TRUE if found and deleted - // - will call VariantEquals() for value comparison - function DeleteByProp(const aPropName,aPropValue: RawUTF8; - aPropValueCaseSensitive: boolean): boolean; - /// delete one or several value/item in this document, from its value - // - returns the number of deleted items - // - returns 0 if the document is not a dvObject, or if no match was found - // - if the value exists several times, all occurences would be removed - // - is optimized for DeleteByValue(null) call - function DeleteByValue(const aValue: Variant; CaseInsensitive: boolean=false): integer; - /// delete all values matching the first characters of a property name - // - returns the number of deleted items - // - returns 0 if the document is not a dvObject, or if no match was found - // - will use IdemPChar(), so search would be case-insensitive - function DeleteByStartName(aStartName: PUTF8Char; aStartNameLen: integer): integer; - /// search a property match in this document, handled as array or object - // - {aPropName:aPropValue} will be searched within the stored array or - // object, and the corresponding item index will be returned, on match - // - returns -1 if no match is found - // - will call VariantEquals() for value comparison - function SearchItemByProp(const aPropName,aPropValue: RawUTF8; - aPropValueCaseSensitive: boolean): integer; overload; - /// search a property match in this document, handled as array or object - // - {aPropName:aPropValue} will be searched within the stored array or - // object, and the corresponding item index will be returned, on match - // - returns -1 if no match is found - // - will call VariantEquals() for value comparison - function SearchItemByProp(const aPropNameFmt: RawUTF8; const aPropNameArgs: array of const; - const aPropValue: RawUTF8; aPropValueCaseSensitive: boolean): integer; overload; - /// search a value in this document, handled as array - // - aValue will be searched within the stored array - // and the corresponding item index will be returned, on match - // - returns -1 if no match is found - // - you could make several searches, using the StartIndex optional parameter - function SearchItemByValue(const aValue: Variant; - CaseInsensitive: boolean=false; StartIndex: integer=0): integer; - /// sort the document object values by name - // - do nothing if the document is not a dvObject - // - will follow case-insensitive order (@StrIComp) by default, but you - // can specify @StrComp as comparer function for case-sensitive ordering - // - once sorted, you can use GetVarData(..,Compare) or GetAs*(..,Compare) - // methods for much faster O(log(n)) binary search - procedure SortByName(Compare: TUTF8Compare=nil); - /// sort the document object values by value - // - work for both dvObject and dvArray documents - // - will sort by UTF-8 text (VariantCompare) if no custom aCompare is supplied - procedure SortByValue(Compare: TVariantCompare = nil); - /// sort the document array values by a field of some stored objet values - // - do nothing if the document is not a dvArray, or if the items are no dvObject - // - will sort by UTF-8 text (VariantCompare) if no custom aValueCompare is supplied - procedure SortArrayByField(const aItemPropName: RawUTF8; - aValueCompare: TVariantCompare=nil; aValueCompareReverse: boolean=false; - aNameSortedCompare: TUTF8Compare=nil); - /// reverse the order of the document object or array items - procedure Reverse; - /// create a TDocVariant object, from a selection of properties of this - // document, by property name - // - if the document is a dvObject, to reduction will be applied to all - // its properties - // - if the document is a dvArray, the reduction will be applied to each - // stored item, if it is a document - procedure Reduce(const aPropNames: array of RawUTF8; aCaseSensitive: boolean; - out result: TDocVariantData; aDoNotAddVoidProp: boolean=false); overload; - /// create a TDocVariant object, from a selection of properties of this - // document, by property name - // - always returns a TDocVariantData, even if no property name did match - // (in this case, it is dvUndefined) - function Reduce(const aPropNames: array of RawUTF8; aCaseSensitive: boolean; - aDoNotAddVoidProp: boolean=false): variant; overload; - /// create a TDocVariant array, from the values of a single properties of - // this document, specified by name - // - you can optionally apply an additional filter to each reduced item - procedure ReduceAsArray(const aPropName: RawUTF8; out result: TDocVariantData; - OnReduce: TOnReducePerItem=nil); overload; - /// create a TDocVariant array, from the values of a single properties of - // this document, specified by name - // - always returns a TDocVariantData, even if no property name did match - // (in this case, it is dvUndefined) - // - you can optionally apply an additional filter to each reduced item - function ReduceAsArray(const aPropName: RawUTF8; OnReduce: TOnReducePerItem=nil): variant; overload; - /// create a TDocVariant array, from the values of a single properties of - // this document, specified by name - // - this overloaded method accepts an additional filter to each reduced item - procedure ReduceAsArray(const aPropName: RawUTF8; out result: TDocVariantData; - OnReduce: TOnReducePerValue); overload; - /// create a TDocVariant array, from the values of a single properties of - // this document, specified by name - // - always returns a TDocVariantData, even if no property name did match - // (in this case, it is dvUndefined) - // - this overloaded method accepts an additional filter to each reduced item - function ReduceAsArray(const aPropName: RawUTF8; OnReduce: TOnReducePerValue): variant; overload; - /// rename some properties of a TDocVariant object - // - returns the number of property names modified - function Rename(const aFromPropName, aToPropName: TRawUTF8DynArray): integer; - /// map {"obj.prop1"..,"obj.prop2":..} into {"obj":{"prop1":..,"prop2":...}} - // - the supplied aObjectPropName should match the incoming dotted value - // of all properties (e.g. 'obj' for "obj.prop1") - // - if any of the incoming property is not of "obj.prop#" form, the - // whole process would be ignored - // - return FALSE if the TDocVariant did not change - // - return TRUE if the TDocVariant has been flattened - function FlattenAsNestedObject(const aObjectPropName: RawUTF8): boolean; - - /// how this document will behave - // - those options are set when creating the instance - // - dvoArray and dvoObject are not options, but define the document Kind, - // so those items are ignored when assigned to this property - property Options: TDocVariantOptions read VOptions write SetOptions; - /// returns the document internal layout - // - just after initialization, it will return dvUndefined - // - most of the time, you will add named values with AddValue() or by - // setting the variant properties: it will return dvObject - // - but is you use AddItem(), values will have no associated names: the - // document will be a dvArray - // - value computed from the dvoArray and dvoObject presence in Options - property Kind: TDocVariantKind read GetKind; - /// return the custom variant type identifier, i.e. DocVariantType.VarType - property VarType: word read VType; - /// number of items stored in this document - // - is 0 if Kind=dvUndefined - // - is the number of name/value pairs for Kind=dvObject - // - is the number of items for Kind=dvArray - property Count: integer read VCount; - /// the current capacity of this document - // - allow direct access to VValue[] length - property Capacity: integer read GetCapacity write SetCapacity; - /// direct acces to the low-level internal array of values - // - transtyping a variant and direct access to TDocVariantData is the - // fastest way of accessing all properties of a given dvObject: - // ! with TDocVariantData(aVariantObject) do - // ! for i := 0 to Count-1 do - // ! writeln(Names[i],'=',Values[i]); - // - or to access a dvArray items (e.g. a MongoDB collection): - // ! with TDocVariantData(aVariantArray) do - // ! for i := 0 to Count-1 do - // ! writeln(Values[i]); - property Values: TVariantDynArray read VValue; - /// direct acces to the low-level internal array of names - // - is void (nil) if Kind is not dvObject - // - transtyping a variant and direct access to TDocVariantData is the - // fastest way of accessing all properties of a given dvObject: - // ! with TDocVariantData(aVariantObject) do - // ! for i := 0 to Count-1 do - // ! writeln(Names[i],'=',Values[i]); - property Names: TRawUTF8DynArray read VName; - /// find an item in this document, and returns its value - // - raise an EDocVariant if aNameOrIndex is neither an integer nor a string - // - raise an EDocVariant if Kind is dvArray and aNameOrIndex is a string - // or if Kind is dvObject and aNameOrIndex is an integer - // - raise an EDocVariant if Kind is dvObject and if aNameOrIndex is a - // string, which is not found within the object property names and - // dvoReturnNullForUnknownProperty is set in Options - // - raise an EDocVariant if Kind is dvArray and if aNameOrIndex is a - // integer, which is not within 0..Count-1 and dvoReturnNullForUnknownProperty - // is set in Options - // - so you can use directly: - // ! // for an array document: - // ! aVariant := TDocVariant.NewArray(['one',2,3.0]); - // ! for i := 0 to TDocVariantData(aVariant).Count-1 do - // ! aValue := TDocVariantData(aVariant).Value[i]; - // ! // for an object document: - // ! aVariant := TDocVariant.NewObject(['name','John','year',1972]); - // ! assert(aVariant.Name=TDocVariantData(aVariant)['name']); - // ! assert(aVariant.year=TDocVariantData(aVariant)['year']); - // - due to the internal implementation of variant execution (somewhat - // slow _DispInvoke() function), it is a bit faster to execute: - // ! aValue := TDocVariantData(aVariant).Value['name']; - // instead of - // ! aValue := aVariant.name; - // but of course, if want to want to access the content by index (typically - // for a dvArray), using Values[] - and Names[] - properties is much faster - // than this variant-indexed pseudo-property: - // ! with TDocVariantData(aVariant) do - // ! for i := 0 to Count-1 do - // ! Writeln(Values[i]); - // is faster than: - // ! with TDocVariantData(aVariant) do - // ! for i := 0 to Count-1 do - // ! Writeln(Value[i]); - // which is faster than: - // ! for i := 0 to aVariant.Count-1 do - // ! Writeln(aVariant._(i)); - // - this property will return the value as varByRef (just like with - // variant late binding of any TDocVariant instance), so you can write: - // !var Doc: TDocVariantData; // stack-allocated variable - // !begin - // ! Doc.InitJSON('{arr:[1,2]}'); - // ! assert(Doc.Count=2); - // ! Doc.Value['arr'].Add(3); // works since Doc.Value['arr'] is varByRef - // ! writeln(Doc.ToJSON); // will write '{"arr":[1,2,3]}' - // !end; - // - if you want to access a property as a copy, i.e. to assign it to a - // variant variable which will stay alive after this TDocVariant instance - // is release, you should not use Value[] but rather - // GetValueOrRaiseException or GetValueOrNull/GetValueOrEmpty - // - see U[] I[] B[] D[] O[] O_[] A[] A_[] _[] properties for direct access - // of strong typed values - property Value[const aNameOrIndex: Variant]: Variant read GetValueOrItem - write SetValueOrItem; default; - - /// direct access to a dvObject UTF-8 stored property value from its name - // - slightly faster than the variant-based Value[] default property - // - follows dvoNameCaseSensitive and dvoReturnNullForUnknownProperty options - // - use GetAsRawUTF8() if you want to check the availability of the field - // - U['prop'] := 'value' would add a new property, or overwrite an existing - property U[const aName: RawUTF8]: RawUTF8 read GetRawUTF8ByName write SetRawUTF8ByName; - /// direct string access to a dvObject UTF-8 stored property value from its name - // - just a wrapper around U[] property, to avoid a compilation warning when - // using plain string variables (internaly, RawUTF8 will be used for storage) - // - slightly faster than the variant-based Value[] default property - // - follows dvoNameCaseSensitive and dvoReturnNullForUnknownProperty options - // - use GetAsRawUTF8() if you want to check the availability of the field - // - S['prop'] := 'value' would add a new property, or overwrite an existing - property S[const aName: RawUTF8]: string read GetStringByName write SetStringByName; - /// direct access to a dvObject Integer stored property value from its name - // - slightly faster than the variant-based Value[] default property - // - follows dvoNameCaseSensitive and dvoReturnNullForUnknownProperty options - // - use GetAsInt/GetAsInt64 if you want to check the availability of the field - // - I['prop'] := 123 would add a new property, or overwrite an existing - property I[const aName: RawUTF8]: Int64 read GetInt64ByName write SetInt64ByName; - /// direct access to a dvObject Boolean stored property value from its name - // - slightly faster than the variant-based Value[] default property - // - follows dvoNameCaseSensitive and dvoReturnNullForUnknownProperty options - // - use GetAsBoolean if you want to check the availability of the field - // - B['prop'] := true would add a new property, or overwrite an existing - property B[const aName: RawUTF8]: Boolean read GetBooleanByName write SetBooleanByName; - /// direct access to a dvObject floating-point stored property value from its name - // - slightly faster than the variant-based Value[] default property - // - follows dvoNameCaseSensitive and dvoReturnNullForUnknownProperty options - // - use GetAsDouble if you want to check the availability of the field - // - D['prop'] := 1.23 would add a new property, or overwrite an existing - property D[const aName: RawUTF8]: Double read GetDoubleByName write SetDoubleByName; - /// direct access to a dvObject existing dvObject property from its name - // - follows dvoNameCaseSensitive and dvoReturnNullForUnknownProperty options - // - O['prop'] would return a fake void TDocVariant if the property is not - // existing or not a dvObject, just like GetAsDocVariantSafe() - // - use O_['prop'] to force adding any missing property - property O[const aName: RawUTF8]: PDocVariantData read GetObjectExistingByName; - /// direct access or add a dvObject's dvObject property from its name - // - follows dvoNameCaseSensitive and dvoReturnNullForUnknownProperty options - // - O_['prop'] would add a new property if there is none existing, or - // overwrite an existing property which is not a dvObject - property O_[const aName: RawUTF8]: PDocVariantData read GetObjectOrAddByName; - /// direct access to a dvObject existing dvArray property from its name - // - follows dvoNameCaseSensitive and dvoReturnNullForUnknownProperty options - // - A['prop'] would return a fake void TDocVariant if the property is not - // existing or not a dvArray, just like GetAsDocVariantSafe() - // - use A_['prop'] to force adding any missing property - property A[const aName: RawUTF8]: PDocVariantData read GetArrayExistingByName; - /// direct access or add a dvObject's dvArray property from its name - // - follows dvoNameCaseSensitive and dvoReturnNullForUnknownProperty options - // - A_['prop'] would add a new property if there is none existing, or - // overwrite an existing property which is not a dvArray - property A_[const aName: RawUTF8]: PDocVariantData read GetArrayOrAddByName; - /// direct access to a dvArray's TDocVariant property from its index - // - simple values may directly use Values[] dynamic array, but to access - // a TDocVariantData members, this property is safer - // - follows dvoReturnNullForUnknownProperty option to raise an exception - // - _[ndx] would return a fake void TDocVariant if aIndex is out of range, - // if the property is not existing or not a TDocVariantData (just like - // GetAsDocVariantSafe) - property _[aIndex: integer]: PDocVariantData read GetAsDocVariantByIndex; - end; - {$A+} { packet object not allowed since Delphi 2009 :( } - -var - /// the internal custom variant type used to register TDocVariant - DocVariantType: TDocVariant = nil; - /// copy of DocVariantType.VarType - // - as used by inlined functions of TDocVariantData - DocVariantVType: integer = -1; - -/// retrieve the text representation of a TDocVairnatKind -function ToText(kind: TDocVariantKind): PShortString; overload; - -/// direct access to a TDocVariantData from a given variant instance -// - return a pointer to the TDocVariantData corresponding to the variant -// instance, which may be of kind varByRef (e.g. when retrieved by late binding) -// - raise an EDocVariant exception if the instance is not a TDocVariant -// - the following direct trans-typing may fail, e.g. for varByRef value: -// ! TDocVariantData(aVarDoc.ArrayProp).Add('new item'); -// - so you can write the following: -// ! DocVariantData(aVarDoc.ArrayProp).AddItem('new item'); -function DocVariantData(const DocVariant: variant): PDocVariantData; - -const - /// constant used e.g. by _Safe() overloaded functions - // - will be in code section of the exe, so will be read-only by design - // - would have Kind=dvUndefined and Count=0, so _Safe() would return - // a valid, but void document - // - its VType is varNull, so would be viewed as a null variant - // - dvoReturnNullForUnknownProperty is defined, so that U[]/I[]... methods - // won't raise any exception about unexpected field name - DocVariantDataFake: TDocVariantData = ( - VType:1; VOptions:[dvoReturnNullForUnknownProperty]); - -/// direct access to a TDocVariantData from a given variant instance -// - return a pointer to the TDocVariantData corresponding to the variant -// instance, which may be of kind varByRef (e.g. when retrieved by late binding) -// - will return a read-only fake TDocVariantData with Kind=dvUndefined if the -// supplied variant is not a TDocVariant instance, so could be safely used -// in a with block (use "with" moderation, of course): -// ! with _Safe(aDocVariant)^ do -// ! for ndx := 0 to Count-1 do // here Count=0 for the "fake" result -// ! writeln(Names[ndx]); -// or excluding the "with" statement, as more readable code: -// ! var dv: PDocVariantData; -// ! ndx: PtrInt; -// ! begin -// ! dv := _Safe(aDocVariant); -// ! for ndx := 0 to dv.Count-1 do // here Count=0 for the "fake" result -// ! writeln(dv.Names[ndx]); -function _Safe(const DocVariant: variant): PDocVariantData; overload; - {$ifdef FPC}inline;{$endif} // Delphi has problems inlining this :( - -/// direct access to a TDocVariantData from a given variant instance -// - return a pointer to the TDocVariantData corresponding to the variant -// instance, which may be of kind varByRef (e.g. when retrieved by late binding) -// - will check the supplied document kind, i.e. either dvObject or dvArray and -// raise a EDocVariant exception if it does not match -function _Safe(const DocVariant: variant; ExpectedKind: TDocVariantKind): PDocVariantData; overload; - -/// initialize a variant instance to store some document-based object content -// - object will be initialized with data supplied two by two, as Name,Value -// pairs, e.g. -// ! aVariant := _Obj(['name','John','year',1972]); -// or even with nested objects: -// ! aVariant := _Obj(['name','John','doc',_Obj(['one',1,'two',2.0])]); -// - this global function is an alias to TDocVariant.NewObject() -// - by default, every internal value will be copied, so access of nested -// properties can be slow - if you expect the data to be read-only or not -// propagated into another place, set Options=[dvoValueCopiedByReference] -// or using _ObjFast() will increase the process speed a lot -function _Obj(const NameValuePairs: array of const; - Options: TDocVariantOptions=[]): variant; - -/// add some property values to a document-based object content -// - if Obj is a TDocVariant object, will add the Name/Value pairs -// - if Obj is not a TDocVariant, will create a new fast document, -// initialized with supplied the Name/Value pairs -// - this function will also ensure that ensure Obj is not stored by reference, -// but as a true TDocVariantData -procedure _ObjAddProps(const NameValuePairs: array of const; var Obj: variant); overload; - -/// add the property values of a document to a document-based object content -// - if Document is not a TDocVariant object, will do nothing -// - if Obj is a TDocVariant object, will add Document fields to its content -// - if Obj is not a TDocVariant object, Document will be copied to Obj -procedure _ObjAddProps(const Document: variant; var Obj: variant); overload; - -/// initialize a variant instance to store some document-based array content -// - array will be initialized with data supplied as parameters, e.g. -// ! aVariant := _Arr(['one',2,3.0]); -// - this global function is an alias to TDocVariant.NewArray() -// - by default, every internal value will be copied, so access of nested -// properties can be slow - if you expect the data to be read-only or not -// propagated into another place, set Options=[dvoValueCopiedByReference] -// or using _ArrFast() will increase the process speed a lot -function _Arr(const Items: array of const; - Options: TDocVariantOptions=[]): variant; - -/// initialize a variant instance to store some document-based content -// from a supplied (extended) JSON content -// - this global function is an alias to TDocVariant.NewJSON(), and -// will return an Unassigned variant if JSON content was not correctly converted -// - warning: exclude dvoAllowDoubleValue so won't parse any float, just currency -// - object or array will be initialized from the supplied JSON content, e.g. -// ! aVariant := _Json('{"id":10,"doc":{"name":"John","birthyear":1972}}'); -// ! // now you can access to the properties via late binding -// ! assert(aVariant.id=10); -// ! assert(aVariant.doc.name='John'); -// ! assert(aVariant.doc.birthYear=1972); -// ! // and also some pseudo-properties: -// ! assert(aVariant._count=2); -// ! assert(aVariant.doc._kind=ord(dvObject)); -// ! // or with a JSON array: -// ! aVariant := _Json('["one",2,3]'); -// ! assert(aVariant._kind=ord(dvArray)); -// ! for i := 0 to aVariant._count-1 do -// ! writeln(aVariant._(i)); -// - in addition to the JSON RFC specification strict mode, this method will -// handle some BSON-like extensions, e.g. unquoted field names: -// ! aVariant := _Json('{id:10,doc:{name:"John",birthyear:1972}}'); -// - if the SynMongoDB unit is used in the application, the MongoDB Shell -// syntax will also be recognized to create TBSONVariant, like -// ! new Date() ObjectId() MinKey MaxKey // -// see @http://docs.mongodb.org/manual/reference/mongodb-extended-json -// - by default, every internal value will be copied, so access of nested -// properties can be slow - if you expect the data to be read-only or not -// propagated into another place, add dvoValueCopiedByReference in Options -// will increase the process speed a lot, or use _JsonFast() -function _Json(const JSON: RawUTF8; - Options: TDocVariantOptions=[dvoReturnNullForUnknownProperty]): variant; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// initialize a variant instance to store some document-based content -// from a supplied (extended) JSON content, with parameters formating -// - wrapper around the _Json(FormatUTF8(...,JSONFormat=true)) function, -// i.e. every Args[] will be inserted for each % and Params[] for each ?, -// with proper JSON escaping of string values, and writing nested _Obj() / -// - warning: exclude dvoAllowDoubleValue so won't parse any float, just currency -// _Arr() instances as expected JSON objects / arrays -// - typical use (in the context of SynMongoDB unit) could be: -// ! aVariant := _JSONFmt('{%:{$in:[?,?]}}',['type'],['food','snack']); -// ! aVariant := _JSONFmt('{type:{$in:?}}',[],[_Arr(['food','snack'])]); -// ! // which are the same as: -// ! aVariant := _JSONFmt('{type:{$in:["food","snack"]}}'); -// ! // in this context: -// ! u := VariantSaveJSON(aVariant); -// ! assert(u='{"type":{"$in":["food","snack"]}}'); -// ! u := VariantSaveMongoJSON(aVariant,modMongoShell); -// ! assert(u='{type:{$in:["food","snack"]}}'); -// - by default, every internal value will be copied, so access of nested -// properties can be slow - if you expect the data to be read-only or not -// propagated into another place, add dvoValueCopiedByReference in Options -// will increase the process speed a lot, or use _JsonFast() -function _JsonFmt(const Format: RawUTF8; const Args,Params: array of const; - Options: TDocVariantOptions=[dvoReturnNullForUnknownProperty]): variant; overload; - -/// initialize a variant instance to store some document-based content -// from a supplied (extended) JSON content, with parameters formating -// - this overload function will set directly a local variant variable, -// and would be used by inlined _JsonFmt/_JsonFastFmt functions -procedure _JsonFmt(const Format: RawUTF8; const Args,Params: array of const; - Options: TDocVariantOptions; out result: variant); overload; - -/// initialize a variant instance to store some document-based content -// from a supplied (extended) JSON content -// - this global function is an alias to TDocVariant.NewJSON(), and -// will return TRUE if JSON content was correctly converted into a variant -// - warning: exclude dvoAllowDoubleValue so won't parse any float, just currency -// - in addition to the JSON RFC specification strict mode, this method will -// handle some BSON-like extensions, e.g. unquoted field names or ObjectID() -// - by default, every internal value will be copied, so access of nested -// properties can be slow - if you expect the data to be read-only or not -// propagated into another place, add dvoValueCopiedByReference in Options -// will increase the process speed a lot, or use _JsonFast() -function _Json(const JSON: RawUTF8; var Value: variant; - Options: TDocVariantOptions=[dvoReturnNullForUnknownProperty]): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// initialize a variant instance to store some document-based object content -// - this global function is an handy alias to: -// ! Obj(NameValuePairs,JSON_OPTIONS[true]); -// - so all created objects and arrays will be handled by reference, for best -// speed - but you should better write on the resulting variant tree with caution -function _ObjFast(const NameValuePairs: array of const): variant; overload; - -/// initialize a variant instance to store any object as a TDocVariant -// - is a wrapper around _JsonFast(ObjectToJson(aObject,aOptions)) -function _ObjFast(aObject: TObject; - aOptions: TTextWriterWriteObjectOptions=[woDontStoreDefault]): variant; overload; - -/// initialize a variant instance to store some document-based array content -// - this global function is an handy alias to: -// ! _Array(Items,JSON_OPTIONS[true]); -// - so all created objects and arrays will be handled by reference, for best -// speed - but you should better write on the resulting variant tree with caution -function _ArrFast(const Items: array of const): variant; overload; - -/// initialize a variant instance to store some document-based content -// from a supplied (extended) JSON content -// - warning: exclude dvoAllowDoubleValue so won't parse any float, just currency -// - this global function is an handy alias to: -// ! _Json(JSON,JSON_OPTIONS[true]); or _Json(JSON,JSON_OPTIONS_FAST) -// so it will return an Unassigned variant if JSON content was not correct -// - so all created objects and arrays will be handled by reference, for best -// speed - but you should better write on the resulting variant tree with caution -// - in addition to the JSON RFC specification strict mode, this method will -// handle some BSON-like extensions, e.g. unquoted field names or ObjectID() -function _JsonFast(const JSON: RawUTF8): variant; - {$ifdef HASINLINE}inline;{$endif} - -/// initialize a variant instance to store some document-based content -// from a supplied (extended) JSON content, parsing any kind of float -// - use JSON_OPTIONS_FAST_FLOAT including the dvoAllowDoubleValue option -function _JsonFastFloat(const JSON: RawUTF8): variant; - {$ifdef HASINLINE}inline;{$endif} - -/// initialize a variant instance to store some extended document-based content -// - this global function is an handy alias to: -// ! _Json(JSON,JSON_OPTIONS_FAST_EXTENDED); -function _JsonFastExt(const JSON: RawUTF8): variant; - {$ifdef HASINLINE}inline;{$endif} - -/// initialize a variant instance to store some document-based content -// from a supplied (extended) JSON content, with parameters formating -// - warning: exclude dvoAllowDoubleValue so won't parse any float, just currency -// - this global function is an handy alias e.g. to: -// ! aVariant := _JSONFmt('{%:{$in:[?,?]}}',['type'],['food','snack'],JSON_OPTIONS[true]); -// - so all created objects and arrays will be handled by reference, for best -// speed - but you should better write on the resulting variant tree with caution -// - in addition to the JSON RFC specification strict mode, this method will -// handle some BSON-like extensions, e.g. unquoted field names or ObjectID(): -function _JsonFastFmt(const Format: RawUTF8; const Args,Params: array of const): variant; - -/// ensure a document-based variant instance will have only per-value nested -// objects or array documents -// - is just a wrapper around: -// ! TDocVariantData(DocVariant).InitCopy(DocVariant,JSON_OPTIONS[false]) -// - you can use this function to ensure that all internal properties of this -// variant will be copied per-value whatever options the nested objects or -// arrays were created with -// - for huge document with a big depth of nested objects or arrays, a full -// per-value copy may be time and resource consuming, but will be also safe -// - will raise an EDocVariant if the supplied variant is not a TDocVariant or -// a varByRef pointing to a TDocVariant -procedure _Unique(var DocVariant: variant); - -/// ensure a document-based variant instance will have only per-value nested -// objects or array documents -// - is just a wrapper around: -// ! TDocVariantData(DocVariant).InitCopy(DocVariant,JSON_OPTIONS[true]) -// - you can use this function to ensure that all internal properties of this -// variant will be copied per-reference whatever options the nested objects or -// arrays were created with -// - for huge document with a big depth of nested objects or arrays, it will -// first create a whole copy of the document nodes, but further assignments -// of the resulting value will be per-reference, so will be almost instant -// - will raise an EDocVariant if the supplied variant is not a TDocVariant or -// a varByRef pointing to a TDocVariant -procedure _UniqueFast(var DocVariant: variant); - -/// return a full nested copy of a document-based variant instance -// - is just a wrapper around: -// ! TDocVariant.NewUnique(DocVariant,JSON_OPTIONS[false]) -// - you can use this function to ensure that all internal properties of this -// variant will be copied per-value whatever options the nested objects or -// arrays were created with: to be used on a value returned as varByRef -// (e.g. by _() pseudo-method) -// - for huge document with a big depth of nested objects or arrays, a full -// per-value copy may be time and resource consuming, but will be also safe - -// consider using _ByRef() instead if a fast copy-by-reference is enough -// - will raise an EDocVariant if the supplied variant is not a TDocVariant or -// a varByRef pointing to a TDocVariant -function _Copy(const DocVariant: variant): variant; - {$ifdef HASINLINE}inline;{$endif} - -/// return a full nested copy of a document-based variant instance -// - is just a wrapper around: -// ! TDocVariant.NewUnique(DocVariant,JSON_OPTIONS[true]) -// - you can use this function to ensure that all internal properties of this -// variant will be copied per-value whatever options the nested objects or -// arrays were created with: to be used on a value returned as varByRef -// (e.g. by _() pseudo-method) -// - for huge document with a big depth of nested objects or arrays, a full -// per-value copy may be time and resource consuming, but will be also safe - -// consider using _ByRef() instead if a fast copy-by-reference is enough -// - will raise an EDocVariant if the supplied variant is not a TDocVariant or -// a varByRef pointing to a TDocVariant -function _CopyFast(const DocVariant: variant): variant; - {$ifdef HASINLINE}inline;{$endif} - -/// copy a TDocVariant to another variable, changing the options on the fly -// - note that the content (items or properties) is copied by reference, -// so consider using _Copy() instead if you expect to safely modify its content -// - will return null if the supplied variant is not a TDocVariant -function _ByRef(const DocVariant: variant; Options: TDocVariantOptions): variant; overload; - -/// copy a TDocVariant to another variable, changing the options on the fly -// - note that the content (items or properties) is copied by reference, -// so consider using _Copy() instead if you expect to safely modify its content -// - will return null if the supplied variant is not a TDocVariant -procedure _ByRef(const DocVariant: variant; out Dest: variant; - Options: TDocVariantOptions); overload; - -/// convert a TDocVariantData array or a string value into a CSV -// - will call either TDocVariantData.ToCSV, or return the string -// - returns '' if the supplied value is neither a TDocVariant or a string -// - could be used e.g. to store either a JSON CSV string or a JSON array of -// strings in a settings property -function _CSV(const DocVariantOrString: variant): RawUTF8; - -/// will convert any TObject into a TDocVariant document instance -// - a slightly faster alternative to Dest := _JsonFast(ObjectToJSON(Value)) -// - this would convert the TObject by representation, using only serializable -// published properties: do not use this function to store temporary a class -// instance, but e.g. to store an object values in a NoSQL database -// - if you expect lazy-loading of a TObject, see TObjectVariant.New() -procedure ObjectToVariant(Value: TObject; out Dest: variant); overload; - {$ifdef HASINLINE}inline;{$endif} - -/// will convert any TObject into a TDocVariant document instance -// - a faster alternative to _JsonFast(ObjectToJSON(Value)) -// - if you expect lazy-loading of a TObject, see TObjectVariant.New() -function ObjectToVariant(Value: TObject; EnumSetsAsText: boolean=false): variant; overload; - -/// will convert any TObject into a TDocVariant document instance -// - a faster alternative to _Json(ObjectToJSON(Value),Options) -// - note that the result variable should already be cleared: no VarClear() -// is done by this function -// - would be used e.g. by VarRecToVariant() function -// - if you expect lazy-loading of a TObject, see TObjectVariant.New() -procedure ObjectToVariant(Value: TObject; var result: variant; - Options: TTextWriterWriteObjectOptions); overload; - -{$endif NOVARIANTS} - - -{ ******************* process monitoring / statistics ********************** } - -type - /// the kind of value stored in a TSynMonitor / TSynMonitorUsage property - // - i.e. match TSynMonitorTotalMicroSec, TSynMonitorOneMicroSec, - // TSynMonitorOneCount, TSynMonitorOneBytes, TSynMonitorBytesPerSec, - // TSynMonitorTotalBytes, TSynMonitorCount and TSynMonitorCount64 types as - // used to store statistic information - // - "cumulative" values would sum each process values, e.g. total elapsed - // time for SOA execution, task count or total I/O bytes - // - "immediate" (e.g. svOneBytes or smvBytesPerSec) values would be an evolving - // single value, e.g. an average value or current disk free size - // - use SYNMONITORVALUE_CUMULATIVE = [smvMicroSec,smvBytes,smvCount,smvCount64] - // constant to identify the kind of value - // - TSynMonitorUsage.Track() would use MonitorPropUsageValue() to guess - // the tracked properties type from class RTTI - TSynMonitorType = ( - smvUndefined, smvOneMicroSec, smvOneBytes, smvOneCount, smvBytesPerSec, - smvMicroSec, smvBytes, smvCount, smvCount64); - /// value types as stored in TSynMonitor / TSynMonitorUsage - TSynMonitorTypes = set of TSynMonitorType; - - /// would identify a cumulative time process information in micro seconds, during monitoring - // - "cumulative" time would add each process timing, e.g. for statistics about - // SOA computation of a given service - // - any property defined with this type would be identified by TSynMonitorUsage - TSynMonitorTotalMicroSec = type QWord; - - /// would identify an immediate time count information, during monitoring - // - "immediate" counts won't accumulate, e.g. may store the current number - // of thread used by a process - // - any property defined with this type would be identified by TSynMonitorUsage - TSynMonitorOneCount = type cardinal; - - /// would identify an immediate time process information in micro seconds, during monitoring - // - "immediate" time won't accumulate, i.e. may store the duration of the - // latest execution of a SOA computation - // - any property defined with this type would be identified by TSynMonitorUsage - TSynMonitorOneMicroSec = type QWord; - - /// would identify a process information as cumulative bytes count, during monitoring - // - "cumulative" size would add some byte for each process, e.g. input/output - // - any property defined with this type would be identified by TSynMonitorUsage - TSynMonitorTotalBytes = type QWord; - - /// would identify an immediate process information as bytes count, during monitoring - // - "immediate" size won't accumulate, i.e. may be e.g. computer free memory - // at a given time - // - any property defined with this type would be identified by TSynMonitorUsage - TSynMonitorOneBytes = type QWord; - - /// would identify the process throughput, during monitoring - // - it indicates e.g. "immediate" bandwith usage - // - any property defined with this type would be identified by TSynMonitorUsage - TSynMonitorBytesPerSec = type QWord; - - /// would identify a cumulative number of processes, during monitoring - // - any property defined with this type would be identified by TSynMonitorUsage - TSynMonitorCount = type cardinal; - - /// would identify a cumulative number of processes, during monitoring - // - any property defined with this type would be identified by TSynMonitorUsage - TSynMonitorCount64 = type QWord; - - /// pointer to a high resolution timer object/record - PPrecisionTimer = ^TPrecisionTimer; - - /// indirect reference to a pointer to a high resolution timer object/record - PPPrecisionTimer = ^PPrecisionTimer; - - /// high resolution timer (for accurate speed statistics) - // - WARNING: under Windows, this record MUST be aligned to 32-bit, otherwise - // iFreq=0 - so you can use TLocalPrecisionTimer/ILocalPrecisionTimer if you - // want to alllocate a local timer instance on the stack - TPrecisionTimer = object - protected - fStart,fStop: Int64; - {$ifndef LINUX} // use QueryPerformanceMicroSeconds() fast API - fWinFreq: Int64; - {$endif} - /// contains the time elapsed in micro seconds between Start and Stop - fTime: TSynMonitorTotalMicroSec; - /// contains the time elapsed in micro seconds between Resume and Pause - fLastTime: TSynMonitorOneMicroSec; - fPauseCount: TSynMonitorCount; - public - /// initialize the timer - // - will fill all internal state with 0 - // - not necessary e.g. if TPrecisionTimer is defined as a TObject field - procedure Init; {$ifdef HASINLINE}inline;{$endif} - /// initialize and start the high resolution timer - // - similar to Init + Resume - procedure Start; - /// stop the timer, returning the total time elapsed as text - // - with appended time resolution (us,ms,s) - from MicroSecToString() - // - is just a wrapper around Pause + Time - // - you can call Resume to continue adding time to this timer - function Stop: TShort16; {$ifdef HASINLINE}inline;{$endif} - /// stop the timer, returning the total time elapsed as microseconds - // - is just a wrapper around Pause + Time - // - you can call Resume to continue adding time to this timer - function StopInMicroSec: TSynMonitorTotalMicroSec; {$ifdef HASINLINE}inline;{$endif} - /// stop the timer, ready to continue its time measurement via Resume - // - will also compute the global Time value - // - do nothing if no previous Start/Resume call is pending - procedure Pause; - /// resume a paused timer, or start an initialized timer - // - do nothing if no timer has been initialized or paused just before - // - if the previous method called was Init, will act like Start - // - if the previous method called was Pause, it will continue counting - procedure Resume; {$ifdef HASINLINE}inline;{$endif} - /// resume a paused timer until the method ends - // - will internaly create a TInterfaceObject class to let the compiler - // generate a try..finally block as expected to call Pause at method ending - // - is therefore very convenient to have consistent Resume/Pause calls - // - for proper use, expect TPrecisionTimer to be initialized to 0 before - // execution (e.g. define it as a protected member of a class) - // - typical use is to declare a fTimeElapsed: TPrecisionTimer protected - // member, then call fTimeElapsed.ProfileCurrentMethod at the beginning of - // all process expecting some timing, then log/save fTimeElapsed.Stop content - // - FPC TIP: result should be assigned to a local variable of IUnknown type - function ProfileCurrentMethod: IUnknown; - /// low-level method to force values settings to allow thread safe timing - // - by default, this timer is not thread safe: you can use this method to - // set the timing values from manually computed performance counters - // - the caller should also use a mutex to prevent from race conditions: - // see e.g. TSynMonitor.FromExternalMicroSeconds implementation - // - warning: Start, Stop, Pause and Resume methods are then disallowed - procedure FromExternalMicroSeconds(const MicroSeconds: QWord); - {$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell - /// low-level method to force values settings to allow thread safe timing - // - by default, this timer is not thread safe: you can use this method to - // set the timing values from manually computed performance counters - // - the caller should also use a mutex to prevent from race conditions: - // see e.g. TSynMonitor.FromExternalQueryPerformanceCounters implementation - // - returns the time elapsed, in micro seconds (i.e. LastTime value) - // - warning: Start, Stop, Pause and Resume methods are then disallowed - function FromExternalQueryPerformanceCounters(const CounterDiff: QWord): QWord; - {$ifdef FPCLINUX}inline;{$endif} - /// compute the per second count - function PerSec(const Count: QWord): QWord; - /// compute the time elapsed by count, with appened time resolution (us,ms,s) - function ByCount(Count: QWord): TShort16; - /// returns e.g. '16.9 MB in 102.20ms i.e. 165.5 MB/s' - function SizePerSec(Size: QWord): shortstring; - /// textual representation of total time elapsed - // - with appened time resolution (us,ms,s) - from MicroSecToString() - // - not to be used in normal code (which could rather call the Stop method), - // but e.g. for custom performance analysis - function Time: TShort16; - /// textual representation of last process timing after counter stopped - // - Time returns a total elapsed time, whereas this method only returns - // the latest resumed time - // - with appened time resolution (us,ms,s) - from MicroSecToString() - // - not to be used in normal code, but e.g. for custom performance analysis - function LastTime: TShort16; - /// check if Start/Resume were called at least once - function Started: boolean; - /// time elapsed in micro seconds after counter stopped - // - not to be used in normal code, but e.g. for custom performance analysis - property TimeInMicroSec: TSynMonitorTotalMicroSec read fTime write fTime; - /// timing in micro seconds of the last process - // - not to be used in normal code, but e.g. for custom performance analysis - property LastTimeInMicroSec: TSynMonitorOneMicroSec read fLastTime write fLastTime; - /// how many times the Pause method was called, i.e. the number of tasks - // processeed - property PauseCount: TSynMonitorCount read fPauseCount; - end; - - /// interface to a reference counted high resolution timer instance - // - implemented by TLocalPrecisionTimer - ILocalPrecisionTimer = interface - /// start the high resolution timer - procedure Start; - /// stop the timer, returning the time elapsed, with appened time resolution (us,ms,s) - function Stop: TShort16; - /// stop the timer, ready to continue its time measure - procedure Pause; - /// resume a paused timer, or start it if it hasn't be started - procedure Resume; - /// compute the per second count - function PerSec(Count: cardinal): cardinal; - /// compute the time elapsed by count, with appened time resolution (us,ms,s) - function ByCount(Count: cardinal): RawUTF8; - end; - - /// reference counted high resolution timer (for accurate speed statistics) - // - since TPrecisionTimer shall be 32-bit aligned, you can use this class - // to initialize a local auto-freeing ILocalPrecisionTimer variable on stack - // - to be used as such: - // ! var Timer: ILocalPrecisionTimer; - // ! (...) - // ! Timer := TLocalPrecisionTimer.Create; - // ! Timer.Start; - // ! (...) - TLocalPrecisionTimer = class(TInterfacedObject,ILocalPrecisionTimer) - protected - fTimer: TPrecisionTimer; - public - /// initialize the instance, and start the high resolution timer - constructor CreateAndStart; - /// start the high resolution timer - procedure Start; - /// stop the timer, returning the time elapsed, with appened time resolution (us,ms,s) - function Stop: TShort16; - /// stop the timer, ready to continue its time measure - procedure Pause; - /// resume a paused timer, or start the timer - procedure Resume; - /// compute the per second count - function PerSec(Count: cardinal): cardinal; - /// compute the time elapsed by count, with appened time resolution (us,ms,s) - function ByCount(Count: cardinal): RawUTF8; - end; - - /// able to serialize any cumulative timing as raw micro-seconds number or text - // - "cumulative" time would add each process value, e.g. SOA methods execution - TSynMonitorTime = class(TSynPersistent) - protected - fMicroSeconds: TSynMonitorTotalMicroSec; - function GetAsText: TShort16; - public - /// compute a number per second, of the current value - function PerSecond(const Count: QWord): QWord; - {$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell - published - /// micro seconds time elapsed, as raw number - property MicroSec: TSynMonitorTotalMicroSec read fMicroSeconds write fMicroSeconds; - /// micro seconds time elapsed, as '... us-ns-ms-s' text - property Text: TShort16 read GetAsText; - end; - - /// able to serialize any immediate timing as raw micro-seconds number or text - // - "immediate" size won't accumulate, i.e. may be e.g. last process time - TSynMonitorOneTime = class(TSynPersistent) - protected - fMicroSeconds: TSynMonitorOneMicroSec; - function GetAsText: TShort16; - public - /// compute a number per second, of the current value - function PerSecond(const Count: QWord): QWord; - {$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell - published - /// micro seconds time elapsed, as raw number - property MicroSec: TSynMonitorOneMicroSec read fMicroSeconds write fMicroSeconds; - /// micro seconds time elapsed, as '... us-ns-ms-s' text - property Text: TShort16 read GetAsText; - end; - - TSynMonitorSizeParent = class(TSynPersistent) - protected - fTextNoSpace: boolean; - public - /// initialize the instance - constructor Create(aTextNoSpace: boolean); reintroduce; - end; - - /// able to serialize any cumulative size as bytes number - // - "cumulative" time would add each process value, e.g. global IO consumption - TSynMonitorSize = class(TSynMonitorSizeParent) - protected - fBytes: TSynMonitorTotalBytes; - function GetAsText: TShort16; - published - /// number of bytes, as raw number - property Bytes: TSynMonitorTotalBytes read fBytes write fBytes; - /// number of bytes, as '... B-KB-MB-GB' text - property Text: TShort16 read GetAsText; - end; - - /// able to serialize any immediate size as bytes number - // - "immediate" size won't accumulate, i.e. may be e.g. computer free memory - // at a given time - TSynMonitorOneSize = class(TSynMonitorSizeParent) - protected - fBytes: TSynMonitorOneBytes; - function GetAsText: TShort16; - published - /// number of bytes, as raw number - property Bytes: TSynMonitorOneBytes read fBytes write fBytes; - /// number of bytes, as '... B-KB-MB-GB' text - property Text: TShort16 read GetAsText; - end; - - /// able to serialize any bandwith as bytes count per second - // - is usually associated with TSynMonitorOneSize properties, - // e.g. to monitor IO activity - TSynMonitorThroughput = class(TSynMonitorSizeParent) - protected - fBytesPerSec: QWord; - function GetAsText: TShort16; - published - /// number of bytes per second, as raw number - property BytesPerSec: QWord read fBytesPerSec write fBytesPerSec; - /// number of bytes per second, as '... B-KB-MB-GB/s' text - property Text: TShort16 read GetAsText; - end; - - /// a generic value object able to handle any task / process statistic - // - base class shared e.g. for ORM, SOA or DDD, when a repeatable data - // process is to be monitored - // - this class is thread-safe for its methods, but you should call explicitly - // Lock/UnLock to access its individual properties - TSynMonitor = class(TSynPersistentLock) - protected - fName: RawUTF8; - fTaskCount: TSynMonitorCount64; - fTotalTime: TSynMonitorTime; - fLastTime: TSynMonitorOneTime; - fMinimalTime: TSynMonitorOneTime; - fAverageTime: TSynMonitorOneTime; - fMaximalTime: TSynMonitorOneTime; - fPerSec: QWord; - fInternalErrors: TSynMonitorCount; - fProcessing: boolean; - fTaskStatus: (taskNotStarted,taskStarted); - fLastInternalError: variant; - procedure LockedPerSecProperties; virtual; - procedure LockedFromProcessTimer; virtual; - procedure LockedSum(another: TSynMonitor); virtual; - procedure WriteDetailsTo(W: TTextWriter); virtual; - procedure Changed; virtual; - public - /// low-level high-precision timer instance - InternalTimer: TPrecisionTimer; - /// initialize the instance nested class properties - // - you can specify identifier associated to this monitored resource - // which would be used for TSynMonitorUsage persistence - constructor Create(const aName: RawUTF8); reintroduce; overload; virtual; - /// initialize the instance nested class properties - constructor Create; overload; override; - /// finalize the instance - destructor Destroy; override; - /// lock the instance for exclusive access - // - needed only if you access directly the instance properties - procedure Lock; {$ifdef HASINLINE}inline;{$endif} - /// release the instance for exclusive access - // - needed only if you access directly the instance properties - procedure UnLock; {$ifdef HASINLINE}inline;{$endif} - /// create Count instances of this actual class in the supplied ObjArr[] - class procedure InitializeObjArray(var ObjArr; Count: integer); virtual; - /// should be called when the process starts, to resume the internal timer - // - thread-safe method - procedure ProcessStart; virtual; - /// should be called each time a pending task is processed - // - will increase the TaskCount property - // - thread-safe method - procedure ProcessDoTask; virtual; - /// should be called when the process starts, and a task is processed - // - similar to ProcessStart + ProcessDoTask - // - thread-safe method - procedure ProcessStartTask; virtual; - /// should be called when an error occurred - // - typical use is with ObjectToVariantDebug(E,...) kind of information - // - thread-safe method - procedure ProcessError(const info: variant); virtual; - /// should be called when an error occurred - // - typical use is with a HTTP status, e.g. as ProcessError(Call.OutStatus) - // - just a wraper around overloaded ProcessError(), so a thread-safe method - procedure ProcessErrorNumber(info: integer); - /// should be called when an error occurred - // - just a wraper around overloaded ProcessError(), so a thread-safe method - procedure ProcessErrorFmt(const Fmt: RawUTF8; const Args: array of const); - /// should be called when an Exception occurred - // - just a wraper around overloaded ProcessError(), so a thread-safe method - procedure ProcessErrorRaised(E: Exception); - /// should be called when the process stops, to pause the internal timer - // - thread-safe method - procedure ProcessEnd; virtual; - /// could be used to manage information average or sums - // - thread-safe method calling LockedSum protected virtual method - procedure Sum(another: TSynMonitor); - /// returns a JSON content with all published properties information - // - thread-safe method - function ComputeDetailsJSON: RawUTF8; - /// appends a JSON content with all published properties information - // - thread-safe method - procedure ComputeDetailsTo(W: TTextWriter); virtual; - {$ifndef NOVARIANTS} - /// returns a TDocVariant with all published properties information - // - thread-safe method - function ComputeDetails: variant; - {$endif NOVARIANTS} - /// used to allow thread safe timing - // - by default, the internal TPrecisionTimer is not thread safe: you can - // use this method to update the timing from many threads - // - if you use this method, ProcessStart, ProcessDoTask and ProcessEnd - // methods are disallowed, and the global fTimer won't be used any more - // - will return the processing time, converted into micro seconds, ready - // to be logged if needed - // - thread-safe method - function FromExternalQueryPerformanceCounters(const CounterDiff: QWord): QWord; - /// used to allow thread safe timing - // - by default, the internal TPrecisionTimer is not thread safe: you can - // use this method to update the timing from many threads - // - if you use this method, ProcessStart, ProcessDoTask and ProcessEnd - // methods are disallowed, and the global fTimer won't be used any more - // - thread-safe method - procedure FromExternalMicroSeconds(const MicroSecondsElapsed: QWord); - /// an identifier associated to this monitored resource - // - is used e.g. for TSynMonitorUsage persistence/tracking - property Name: RawUTF8 read fName write fName; - published - /// indicates if this thread is currently working on some process - property Processing: boolean read fProcessing write fProcessing; - /// how many times the task was performed - property TaskCount: TSynMonitorCount64 read fTaskCount write fTaskCount; - /// the whole time spend during all working process - property TotalTime: TSynMonitorTime read fTotalTime; - /// the time spend during the last task processing - property LastTime: TSynMonitorOneTime read fLastTime; - /// the lowest time spent during any working process - property MinimalTime: TSynMonitorOneTime read fMinimalTime; - /// the time spent in average during any working process - property AverageTime: TSynMonitorOneTime read fAverageTime; - /// the highest time spent during any working process - property MaximalTime: TSynMonitorOneTime read fMaximalTime; - /// average of how many tasks did occur per second - property PerSec: QWord read fPerSec; - /// how many errors did occur during the processing - property Errors: TSynMonitorCount read fInternalErrors; - /// information about the last error which occured during the processing - property LastError: variant read fLastInternalError; - end; - /// references a TSynMonitor instance - PSynMonitor = ^TSynMonitor; - - /// handle generic process statistic with a processing data size and bandwitdh - TSynMonitorWithSize = class(TSynMonitor) - protected - fSize: TSynMonitorSize; - fThroughput: TSynMonitorThroughput; - procedure LockedPerSecProperties; override; - procedure LockedSum(another: TSynMonitor); override; - public - /// initialize the instance nested class properties - constructor Create; override; - /// finalize the instance - destructor Destroy; override; - /// increase the internal size counter - // - thread-safe method - procedure AddSize(const Bytes: QWord); - published - /// how many total data has been hanlded during all working process - property Size: TSynMonitorSize read fSize; - /// data processing bandwith, returned as B/KB/MB per second - property Throughput: TSynMonitorThroughput read fThroughput; - end; - - /// handle generic process statistic with a incoming and outgoing processing - // data size and bandwitdh - TSynMonitorInputOutput = class(TSynMonitor) - protected - fInput: TSynMonitorSize; - fOutput: TSynMonitorSize; - fInputThroughput: TSynMonitorThroughput; - fOutputThroughput: TSynMonitorThroughput; - procedure LockedPerSecProperties; override; - procedure LockedSum(another: TSynMonitor); override; - public - /// initialize the instance nested class properties - constructor Create; override; - /// finalize the instance - destructor Destroy; override; - /// increase the internal size counters - // - thread-safe method - procedure AddSize(const Incoming, Outgoing: QWord); - published - /// how many data has been received - property Input: TSynMonitorSize read fInput; - /// how many data has been sent back - property Output: TSynMonitorSize read fOutput; - /// incoming data processing bandwith, returned as B/KB/MB per second - property InputThroughput: TSynMonitorThroughput read fInputThroughput; - /// outgoing data processing bandwith, returned as B/KB/MB per second - property OutputThroughput: TSynMonitorThroughput read fOutputThroughput; - end; - - /// could monitor a standard Server - // - including Input/Output statistics and connected Clients count - TSynMonitorServer = class(TSynMonitorInputOutput) - protected - fCurrentRequestCount: integer; - fClientsCurrent: TSynMonitorOneCount; - fClientsMax: TSynMonitorOneCount; - public - /// update ClientsCurrent and ClientsMax - // - thread-safe method - procedure ClientConnect; - /// update ClientsCurrent and ClientsMax - // - thread-safe method - procedure ClientDisconnect; - /// update ClientsCurrent to 0 - // - thread-safe method - procedure ClientDisconnectAll; - /// retrieve the number of connected clients - // - thread-safe method - function GetClientsCurrent: TSynMonitorOneCount; - /// how many concurrent requests are currently processed - // - returns the updated number of requests - // - thread-safe method - function AddCurrentRequestCount(diff: integer): integer; - published - /// current count of connected clients - property ClientsCurrent: TSynMonitorOneCount read fClientsCurrent; - /// max count of connected clients - property ClientsMax: TSynMonitorOneCount read fClientsMax; - /// how many concurrent requests are currently processed - // - modified via AddCurrentRequestCount() in TSQLRestServer.URI() - property CurrentRequestCount: integer read fCurrentRequestCount; - end; - - /// a list of simple process statistics - TSynMonitorObjArray = array of TSynMonitor; - - /// a list of data process statistics - TSynMonitorWithSizeObjArray = array of TSynMonitorWithSize; - - /// a list of incoming/outgoing data process statistics - TSynMonitorInputOutputObjArray = array of TSynMonitorInputOutput; - - /// class-reference type (metaclass) of a process statistic information - TSynMonitorClass = class of TSynMonitor; - - -{ ******************* cross-cutting classes and functions ***************** } - -type - /// an abstract ancestor, for implementing a custom TInterfacedObject like class - // - by default, will do nothing: no instance would be retrieved by - // QueryInterface unless the VirtualQueryInterface protected method is - // overriden, and _AddRef/_Release methods would call VirtualAddRef and - // VirtualRelease pure abstract methods - // - using this class will leverage the signature difference between Delphi - // and FPC, among all supported platforms - // - the class includes a RefCount integer field - TSynInterfacedObject = class(TObject,IUnknown) - protected - fRefCount: integer; - // returns E_NOINTERFACE - function VirtualQueryInterface(const IID: TGUID; out Obj): HResult; virtual; - // always return 1 for a "non allocated" instance (0 triggers release) - function VirtualAddRef: Integer; virtual; abstract; - function VirtualRelease: Integer; virtual; abstract; - {$ifdef FPC} - function QueryInterface( - {$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID; - out Obj): longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; - function _AddRef: longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; - function _Release: longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; - {$else} - function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; - function _AddRef: Integer; stdcall; - function _Release: Integer; stdcall; - {$endif} - public - /// the associated reference count - property RefCount: integer read fRefCount write fRefCount; - end; - -{$ifdef CPUINTEL} -{$ifndef DELPHI5OROLDER} - /// a simple class which will set FPU exception flags for a code block - // - using an IUnknown interface to let the compiler auto-generate a - // try..finally block statement to reset the FPU exception register - // - to be used e.g. as such: - // !begin - // ! TSynFPUException.ForLibrayCode; - // ! ... now FPU exceptions will be ignored - // ! ... so here it is safe to call external libray code - // !end; // now FPU exception will be reset as with standard Delphi - // - it will avoid any unexpected invalid floating point operation in Delphi - // code, whereas it was in fact triggerred in some external library code - TSynFPUException = class(TSynInterfacedObject) - protected - {$ifndef CPU64} - fExpected8087, fSaved8087: word; - {$else} - fExpectedMXCSR, fSavedMXCSR: word; - {$endif} - function VirtualAddRef: Integer; override; - function VirtualRelease: Integer; override; - public - /// internal constructor - // - do not call this constructor directly, but rather use - // ForLibraryCode/ForDelphiCode class methods - // - for cpu32 flags are $1372 for Delphi, or $137F for library (mask all exceptions) - // - for cpu64 flags are $1920 for Delphi, or $1FA0 for library (mask all exceptions) - {$ifndef CPU64} - constructor Create(Expected8087Flag: word); reintroduce; - {$else} - constructor Create(ExpectedMXCSR: word); reintroduce; - {$endif} - /// after this method call, all FPU exceptions will be ignored - // - until the method finishes (a try..finally block is generated by - // the compiler), then FPU exceptions will be reset into "Delphi" mode - // - you have to put this e.g. before calling an external libray - // - this method is thread-safe and re-entrant (by reference-counting) - class function ForLibraryCode: IUnknown; - /// after this method call, all FPU exceptions will be enabled - // - this is the Delphi normal behavior - // - until the method finishes (a try..finally block is generated by - // the compiler), then FPU execptions will be disabled again - // - you have to put this e.g. before running an Delphi code from - // a callback executed in an external libray - // - this method is thread-safe and re-entrant (by reference-counting) - class function ForDelphiCode: IUnknown; - end; -{$endif DELPHI5OROLDER} -{$endif CPUINTEL} - - /// interface for TAutoFree to register another TObject instance - // to an existing IAutoFree local variable - IAutoFree = interface - procedure Another(var objVar; obj: TObject); - end; - - /// simple reference-counted storage for local objects - // - WARNING: both FPC and Delphi 10.4+ don't keep the IAutoFree instance - // up to the end-of-method -> you should not use TAutoFree for new projects - // :( - see https://quality.embarcadero.com/browse/RSP-30050 - // - be aware that it won't implement a full ARC memory model, but may be - // just used to avoid writing some try ... finally blocks on local variables - // - use with caution, only on well defined local scope - TAutoFree = class(TInterfacedObject,IAutoFree) - protected - fObject: TObject; - fObjectList: array of TObject; - public - /// initialize the TAutoFree class for one local variable - // - do not call this constructor, but class function One() instead - constructor Create(var localVariable; obj: TObject); reintroduce; overload; - /// initialize the TAutoFree class for several local variables - // - do not call this constructor, but class function Several() instead - constructor Create(const varObjPairs: array of pointer); reintroduce; overload; - /// protect one local TObject variable instance life time - // - for instance, instead of writing: - // !var myVar: TMyClass; - // !begin - // ! myVar := TMyClass.Create; - // ! try - // ! ... use myVar - // ! finally - // ! myVar.Free; - // ! end; - // !end; - // - you may write: - // !var myVar: TMyClass; - // !begin - // ! TAutoFree.One(myVar,TMyClass.Create); - // ! ... use myVar - // !end; // here myVar will be released - // - warning: under FPC, you should assign the result of this method to a local - // IAutoFree variable - see bug http://bugs.freepascal.org/view.php?id=26602 - // - Delphi 10.4 also did change it and release the IAutoFree before the - // end of the current method, so you should better use a local variable - class function One(var localVariable; obj: TObject): IAutoFree; - /// protect several local TObject variable instances life time - // - specified as localVariable/objectInstance pairs - // - you may write: - // !var var1,var2: TMyClass; - // !begin - // ! TAutoFree.Several([ - // ! @var1,TMyClass.Create, - // ! @var2,TMyClass.Create]); - // ! ... use var1 and var2 - // !end; // here var1 and var2 will be released - // - warning: under FPC, you should assign the result of this method to a local - // IAutoFree variable - see bug http://bugs.freepascal.org/view.php?id=26602 - // - Delphi 10.4 also did change it and release the IAutoFree before the - // end of the current method, so you should better use a local variable - class function Several(const varObjPairs: array of pointer): IAutoFree; - /// protect another TObject variable to an existing IAutoFree instance life time - // - you may write: - // !var var1,var2: TMyClass; - // ! auto: IAutoFree; - // !begin - // ! auto := TAutoFree.One(var1,TMyClass.Create);, - // ! .... do something - // ! auto.Another(var2,TMyClass.Create); - // ! ... use var1 and var2 - // !end; // here var1 and var2 will be released - procedure Another(var localVariable; obj: TObject); - /// will finalize the associated TObject instances - // - note that releasing the TObject instances won't be protected, so - // any exception here may induce a memory leak: use only with "safe" - // simple objects, e.g. mORMot's TSQLRecord - destructor Destroy; override; - end; - -{$ifdef DELPHI5OROLDER} // IAutoLocker -> internal error C3517 under Delphi 5 :( - TAutoLocker = class - protected - fSafe: TSynLocker; - public - constructor Create; - destructor Destroy; override; - procedure Enter; virtual; - procedure Leave; virtual; - function ProtectMethod: IUnknown; - /// gives an access to the internal low-level TSynLocker instance used - function Safe: PSynLocker; - property Locker: TSynLocker read fSafe; - end; - IAutoLocker = TAutoLocker; -{$else DELPHI5OROLDER} - /// an interface used by TAutoLocker to protect multi-thread execution - IAutoLocker = interface - ['{97559643-6474-4AD3-AF72-B9BB84B4955D}'] - /// enter the mutex - // - any call to Enter should be ended with a call to Leave, and - // protected by a try..finally block, as such: - // !begin - // ! ... // unsafe code - // ! fSharedAutoLocker.Enter; - // ! try - // ! ... // thread-safe code - // ! finally - // ! fSharedAutoLocker.Leave; - // ! end; - // !end; - procedure Enter; - /// leave the mutex - // - any call to Leave should be preceded with a call to Enter - procedure Leave; - /// will enter the mutex until the IUnknown reference is released - // - using an IUnknown interface to let the compiler auto-generate a - // try..finally block statement to release the lock for the code block - // - could be used as such under Delphi: - // !begin - // ! ... // unsafe code - // ! fSharedAutoLocker.ProtectMethod; - // ! ... // thread-safe code - // !end; // local hidden IUnknown will release the lock for the method - // - warning: under FPC, you should assign its result to a local variable - - // see bug http://bugs.freepascal.org/view.php?id=26602 - // !var LockFPC: IUnknown; - // !begin - // ! ... // unsafe code - // ! LockFPC := fSharedAutoLocker.ProtectMethod; - // ! ... // thread-safe code - // !end; // LockFPC will release the lock for the method - // or - // !begin - // ! ... // unsafe code - // ! with fSharedAutoLocker.ProtectMethod do begin - // ! ... // thread-safe code - // ! end; // local hidden IUnknown will release the lock for the method - // !end; - function ProtectMethod: IUnknown; - /// gives an access to the internal low-level TSynLocker instance used - function Safe: PSynLocker; - end; - - /// reference-counted block code critical section - // - you can use one instance of this to protect multi-threaded execution - // - the main class may initialize a IAutoLocker property in Create, then call - // IAutoLocker.ProtectMethod in any method to make its execution thread safe - // - this class inherits from TInterfacedObjectWithCustomCreate so you - // could define one published property of a mORMot.pas' TInjectableObject - // as IAutoLocker so that this class may be automatically injected - // - you may use the inherited TAutoLockerDebug class, as defined in SynLog.pas, - // to debug unexpected race conditions due to such critical sections - // - consider inherit from high-level TSynPersistentLock or call low-level - // fSafe := NewSynLocker / fSafe^.DoneAndFreemem instead - TAutoLocker = class(TInterfacedObjectWithCustomCreate,IAutoLocker) - protected - fSafe: TSynLocker; - public - /// initialize the mutex - constructor Create; override; - /// finalize the mutex - destructor Destroy; override; - /// will enter the mutex until the IUnknown reference is released - // - as expected by IAutoLocker interface - // - could be used as such under Delphi: - // !begin - // ! ... // unsafe code - // ! fSharedAutoLocker.ProtectMethod; - // ! ... // thread-safe code - // !end; // local hidden IUnknown will release the lock for the method - // - warning: under FPC, you should assign its result to a local variable - - // see bug http://bugs.freepascal.org/view.php?id=26602 - // !var LockFPC: IUnknown; - // !begin - // ! ... // unsafe code - // ! LockFPC := fSharedAutoLocker.ProtectMethod; - // ! ... // thread-safe code - // !end; // LockFPC will release the lock for the method - // or - // !begin - // ! ... // unsafe code - // ! with fSharedAutoLocker.ProtectMethod do begin - // ! ... // thread-safe code - // ! end; // local hidden IUnknown will release the lock for the method - // !end; - function ProtectMethod: IUnknown; - /// enter the mutex - // - as expected by IAutoLocker interface - // - any call to Enter should be ended with a call to Leave, and - // protected by a try..finally block, as such: - // !begin - // ! ... // unsafe code - // ! fSharedAutoLocker.Enter; - // ! try - // ! ... // thread-safe code - // ! finally - // ! fSharedAutoLocker.Leave; - // ! end; - // !end; - procedure Enter; virtual; - /// leave the mutex - // - as expected by IAutoLocker interface - procedure Leave; virtual; - /// access to the locking methods of this instance - // - as expected by IAutoLocker interface - function Safe: PSynLocker; - /// direct access to the locking methods of this instance - // - faster than IAutoLocker.Safe function - property Locker: TSynLocker read fSafe; - end; -{$endif DELPHI5OROLDER} - - -{$ifndef DELPHI5OROLDER} // internal error C3517 under Delphi 5 :( -{$ifndef NOVARIANTS} - /// ref-counted interface for thread-safe access to a TDocVariant document - // - is implemented e.g. by TLockedDocVariant, for IoC/DI resolution - // - fast and safe storage of any JSON-like object, as property/value pairs, - // or a JSON-like array, as values - ILockedDocVariant = interface - ['{CADC2C20-3F5D-4539-9D23-275E833A86F3}'] - function GetValue(const Name: RawUTF8): Variant; - procedure SetValue(const Name: RawUTF8; const Value: Variant); - /// check and return a given property by name - // - returns TRUE and fill Value with the value associated with the supplied - // Name, using an internal lock for thread-safety - // - returns FALSE if the Name was not found, releasing the internal lock: - // use ExistsOrLock() if you want to add the missing value - function Exists(const Name: RawUTF8; out Value: Variant): boolean; - /// check and return a given property by name - // - returns TRUE and fill Value with the value associated with the supplied - // Name, using an internal lock for thread-safety - // - returns FALSE and set the internal lock if Name does not exist: - // caller should then release the lock via ReplaceAndUnlock() - function ExistsOrLock(const Name: RawUTF8; out Value: Variant): boolean; - /// set a value by property name, and set a local copy - // - could be used as such, for implementing a thread-safe cache: - // ! if not cache.ExistsOrLock('prop',local) then - // ! cache.ReplaceAndUnlock('prop',newValue,local); - // - call of this method should have been precedeed by ExistsOrLock() - // returning false, i.e. be executed on a locked instance - procedure ReplaceAndUnlock(const Name: RawUTF8; const Value: Variant; out LocalValue: Variant); - /// add an existing property value to the given TDocVariant document object - // - returns TRUE and add the Name/Value pair to Obj if Name is existing, - // using an internal lock for thread-safety - // - returns FALSE if Name is not existing in the stored document, and - // lock the internal storage: caller should eventually release the lock - // via AddNewPropAndUnlock() - // - could be used as such, for implementing a thread-safe cache: - // ! if not cache.AddExistingPropOrLock('Articles',Scope) then - // ! cache.AddNewPropAndUnlock('Articles',GetArticlesFromDB,Scope); - // here GetArticlesFromDB would occur inside the main lock - function AddExistingPropOrLock(const Name: RawUTF8; var Obj: variant): boolean; - /// add a property value to the given TDocVariant document object and - // to the internal stored document, then release a previous lock - // - call of this method should have been precedeed by AddExistingPropOrLock() - // returning false, i.e. be executed on a locked instance - procedure AddNewPropAndUnlock(const Name: RawUTF8; const Value: variant; var Obj: variant); - /// add an existing property value to the given TDocVariant document object - // - returns TRUE and add the Name/Value pair to Obj if Name is existing - // - returns FALSE if Name is not existing in the stored document - // - this method would use a lock during the Name lookup, but would always - // release the lock, even if returning FALSE (see AddExistingPropOrLock) - function AddExistingProp(const Name: RawUTF8; var Obj: variant): boolean; - /// add a property value to the given TDocVariant document object - // - this method would not expect the resource to be locked when called, - // as with AddNewPropAndUnlock - // - will use the internal lock for thread-safety - // - if the Name is already existing, would update/change the existing value - // - could be used as such, for implementing a thread-safe cache: - // ! if not cache.AddExistingProp('Articles',Scope) then - // ! cache.AddNewProp('Articles',GetArticlesFromDB,Scope); - // here GetArticlesFromDB would occur outside the main lock - procedure AddNewProp(const Name: RawUTF8; const Value: variant; var Obj: variant); - /// append a value to the internal TDocVariant document array - // - you should not use this method in conjunction with other document-based - // alternatives, like Exists/AddExistingPropOrLock or AddExistingProp - procedure AddItem(const Value: variant); - /// makes a thread-safe copy of the internal TDocVariant document object or array - function Copy: variant; - /// delete all stored properties - procedure Clear; - /// save the stored values as UTF-8 encoded JSON Object - function ToJSON(HumanReadable: boolean=false): RawUTF8; - /// low-level access to the associated thread-safe mutex - function Lock: TAutoLocker; - /// the document fields would be safely accessed via this property - // - this is the main entry point of this storage - // - will raise an EDocVariant exception if Name does not exist at reading - // - implementation class would make a thread-safe copy of the variant value - property Value[const Name: RawUTF8]: Variant read GetValue write SetValue; default; - end; - - /// allows thread-safe access to a TDocVariant document - // - this class inherits from TInterfacedObjectWithCustomCreate so you - // could define one published property of a mORMot.pas' TInjectableObject - // as ILockedDocVariant so that this class may be automatically injected - TLockedDocVariant = class(TInterfacedObjectWithCustomCreate,ILockedDocVariant) - protected - fValue: TDocVariantData; - fLock: TAutoLocker; - function GetValue(const Name: RawUTF8): Variant; - procedure SetValue(const Name: RawUTF8; const Value: Variant); - public - /// initialize the thread-safe document with a fast TDocVariant - // - i.e. call Create(true) aka Create(JSON_OPTIONS[true]) - // - will be the TInterfacedObjectWithCustomCreate default constructor, - // called e.g. during IoC/DI resolution - constructor Create; overload; override; - /// initialize the thread-safe document storage - constructor Create(FastStorage: boolean); reintroduce; overload; - /// initialize the thread-safe document storage with the corresponding options - constructor Create(options: TDocVariantOptions); reintroduce; overload; - /// finalize the storage - destructor Destroy; override; - /// check and return a given property by name - function Exists(const Name: RawUTF8; out Value: Variant): boolean; - /// check and return a given property by name - // - this version - function ExistsOrLock(const Name: RawUTF8; out Value: Variant): boolean; - /// set a value by property name, and set a local copy - procedure ReplaceAndUnlock(const Name: RawUTF8; const Value: Variant; out LocalValue: Variant); - /// add an existing property value to the given TDocVariant document object - // - returns TRUE and add the Name/Value pair to Obj if Name is existing - // - returns FALSE if Name is not existing in the stored document - function AddExistingPropOrLock(const Name: RawUTF8; var Obj: variant): boolean; - /// add a property value to the given TDocVariant document object and - // to the internal stored document - procedure AddNewPropAndUnlock(const Name: RawUTF8; const Value: variant; var Obj: variant); - /// add an existing property value to the given TDocVariant document object - // - returns TRUE and add the Name/Value pair to Obj if Name is existing - // - returns FALSE if Name is not existing in the stored document - // - this method would use a lock during the Name lookup, but would always - // release the lock, even if returning FALSE (see AddExistingPropOrLock) - function AddExistingProp(const Name: RawUTF8; var Obj: variant): boolean; - /// add a property value to the given TDocVariant document object - // - this method would not expect the resource to be locked when called, - // as with AddNewPropAndUnlock - // - will use the internal lock for thread-safety - // - if the Name is already existing, would update/change the existing value - procedure AddNewProp(const Name: RawUTF8; const Value: variant; var Obj: variant); - /// append a value to the internal TDocVariant document array - procedure AddItem(const Value: variant); - /// makes a thread-safe copy of the internal TDocVariant document object or array - function Copy: variant; - /// delete all stored properties - procedure Clear; - /// save the stored value as UTF-8 encoded JSON Object - // - implemented as just a wrapper around VariantSaveJSON() - function ToJSON(HumanReadable: boolean=false): RawUTF8; - /// low-level access to the associated thread-safe mutex - function Lock: TAutoLocker; - /// the document fields would be safely accessed via this property - // - will raise an EDocVariant exception if Name does not exist - // - result variant is returned as a copy, not as varByRef, since a copy - // will definitively be more thread safe - property Value[const Name: RawUTF8]: Variant read GetValue write SetValue; default; - end; -{$endif} -{$endif} - -type - /// class-reference type (metaclass) of an TSynPersistentLock class - TSynPersistentLockClass = class of TSynPersistentLock; - - /// abstract dynamic array of TSynPersistentLock instance - // - note defined as T*ObjArray, since it won't - TSynPersistentLockDynArray = array of TSynPersistentLock; - -/// convert a size to a human readable value power-of-two metric value -// - append EB, PB, TB, GB, MB, KB or B symbol with or without preceding space -// - for EB, PB, TB, GB, MB and KB, add one fractional digit -procedure KB(bytes: Int64; out result: TShort16; nospace: boolean); overload; - -/// convert a size to a human readable value -// - append EB, PB, TB, GB, MB, KB or B symbol with preceding space -// - for EB, PB, TB, GB, MB and KB, add one fractional digit -function KB(bytes: Int64): TShort16; overload; - {$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell - -/// convert a size to a human readable value -// - append EB, PB, TB, GB, MB, KB or B symbol without preceding space -// - for EB, PB, TB, GB, MB and KB, add one fractional digit -function KBNoSpace(bytes: Int64): TShort16; - {$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell - -/// convert a size to a human readable value -// - append EB, PB, TB, GB, MB, KB or B symbol with or without preceding space -// - for EB, PB, TB, GB, MB and KB, add one fractional digit -function KB(bytes: Int64; nospace: boolean): TShort16; overload; - {$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell - -/// convert a string size to a human readable value -// - append EB, PB, TB, GB, MB, KB or B symbol -// - for EB, PB, TB, GB, MB and KB, add one fractional digit -function KB(const buffer: RawByteString): TShort16; overload; - {$ifdef FPC_OR_UNICODE}inline;{$endif} - -/// convert a size to a human readable value -// - append EB, PB, TB, GB, MB, KB or B symbol -// - for EB, PB, TB, GB, MB and KB, add one fractional digit -procedure KBU(bytes: Int64; var result: RawUTF8); - -/// convert a micro seconds elapsed time into a human readable value -// - append 'us', 'ms', 's', 'm', 'h' and 'd' symbol for the given value range, -// with two fractional digits -function MicroSecToString(Micro: QWord): TShort16; overload; - {$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell - -/// convert a micro seconds elapsed time into a human readable value -// - append 'us', 'ms', 's', 'm', 'h' and 'd' symbol for the given value range, -// with two fractional digits -procedure MicroSecToString(Micro: QWord; out result: TShort16); overload; - -/// convert an integer value into its textual representation with thousands marked -// - ThousandSep is the character used to separate thousands in numbers with -// more than three digits to the left of the decimal separator -function IntToThousandString(Value: integer; const ThousandSep: TShort4=','): shortstring; - -/// return the Delphi/FPC Compiler Version -// - returns 'Delphi 2007', 'Delphi 2010' or 'Free Pascal 3.3.1' e.g. -function GetDelphiCompilerVersion: RawUTF8; - -/// returns TRUE if the supplied mutex has been initialized -// - will check if the supplied mutex is void (i.e. all filled with 0 bytes) -function IsInitializedCriticalSection(const CS: TRTLCriticalSection): Boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// on need initialization of a mutex, then enter the lock -// - if the supplied mutex has been initialized, do nothing -// - if the supplied mutex is void (i.e. all filled with 0), initialize it -procedure InitializeCriticalSectionIfNeededAndEnter(var CS: TRTLCriticalSection); - {$ifdef HASINLINE}inline;{$endif} - -/// on need finalization of a mutex -// - if the supplied mutex has been initialized, delete it -// - if the supplied mutex is void (i.e. all filled with 0), do nothing -procedure DeleteCriticalSectionIfNeeded(var CS: TRTLCriticalSection); - -/// compress a data content using the SynLZ algorithm -// - as expected by THttpSocket.RegisterCompress -// - will return 'synlz' as ACCEPT-ENCODING: header parameter -// - will store a hash of both compressed and uncompressed stream: if the -// data is corrupted during transmission, will instantly return '' -function CompressSynLZ(var DataRawByteString; Compress: boolean): AnsiString; - -/// compress a data content using the SynLZ algorithm from one stream into another -// - returns the number of bytes written to Dest -// - you should specify a Magic number to be used to identify the block -function StreamSynLZ(Source: TCustomMemoryStream; Dest: TStream; - Magic: cardinal): integer; overload; - -/// compress a data content using the SynLZ algorithm from one stream into a file -// - returns the number of bytes written to the destination file -// - you should specify a Magic number to be used to identify the block -function StreamSynLZ(Source: TCustomMemoryStream; const DestFile: TFileName; - Magic: cardinal): integer; overload; - -/// uncompress using the SynLZ algorithm from one stream into another -// - returns a newly create memory stream containing the uncompressed data -// - returns nil if source data is invalid -// - you should specify a Magic number to be used to identify the block -// - this function will also recognize the block at the end of the source stream -// (if was appended to an existing data - e.g. a .mab at the end of a .exe) -// - on success, Source will point after all read data (so that you can e.g. -// append several data blocks to the same stream) -function StreamUnSynLZ(Source: TStream; Magic: cardinal): TMemoryStream; overload; - -/// compute the real length of a given StreamSynLZ-compressed buffer -// - allows to replace an existing appended content, for instance -function StreamSynLZComputeLen(P: PAnsiChar; Len, aMagic: cardinal): integer; - -/// uncompress using the SynLZ algorithm from one file into another -// - returns a newly create memory stream containing the uncompressed data -// - returns nil if source file is invalid (e.g. invalid name or invalid content) -// - you should specify a Magic number to be used to identify the block -// - this function will also recognize the block at the end of the source file -// (if was appended to an existing data - e.g. a .mab at the end of a .exe) -function StreamUnSynLZ(const Source: TFileName; Magic: cardinal): TMemoryStream; overload; - -/// compress a file content using the SynLZ algorithm -// - source file is split into 128 MB blocks for fast in-memory compression of -// any file size, then SynLZ compressed and including a Hash32 checksum -// - it is not compatible with StreamSynLZ format, which has no 128 MB chunking -// - you should specify a Magic number to be used to identify the compressed -// file format -function FileSynLZ(const Source, Dest: TFileName; Magic: Cardinal): boolean; - -/// uncompress a file previoulsy compressed via FileSynLZ( -// - you should specify a Magic number to be used to identify the compressed -// file format -function FileUnSynLZ(const Source, Dest: TFileName; Magic: Cardinal): boolean; - -/// returns TRUE if the supplied file name is a SynLZ compressed file, -// matching the Magic number as supplied to FileSynLZ() function -function FileIsSynLZ(const Name: TFileName; Magic: Cardinal): boolean; - -var - /// acccess to our fast SynLZ compression as a TAlgoCompress class - // - please use this global variable methods instead of the deprecated - // SynLZCompress/SynLZDecompress wrapper functions - AlgoSynLZ: TAlgoCompress; - -const - /// CompressionSizeTrigger parameter SYNLZTRIG[true] will disable then - // SynLZCompress() compression - SYNLZTRIG: array[boolean] of integer = (100, maxInt); - /// used e.g. as when ALGO_SAFE[SafeDecompression] for TAlgoCompress.Decompress - ALGO_SAFE: array[boolean] of TAlgoCompressLoad = (aclNormal, aclSafeSlow); - - -/// deprecated function - please call AlgoSynLZ.Compress() method -function SynLZCompress(const Data: RawByteString; CompressionSizeTrigger: integer=100; - CheckMagicForCompressed: boolean=false): RawByteString; overload; - -/// deprecated function - please call AlgoSynLZ.Compress() method -procedure SynLZCompress(P: PAnsiChar; PLen: integer; out Result: RawByteString; - CompressionSizeTrigger: integer=100; CheckMagicForCompressed: boolean=false); overload; - -/// deprecated function - please call AlgoSynLZ.Compress() method -function SynLZCompress(P, Dest: PAnsiChar; PLen, DestLen: integer; - CompressionSizeTrigger: integer=100; CheckMagicForCompressed: boolean=false): integer; overload; - -/// deprecated function - please call AlgoSynLZ.Decompress() method -function SynLZDecompress(const Data: RawByteString): RawByteString; overload; - -/// deprecated function - please call AlgoSynLZ.Decompress() method -procedure SynLZDecompress(P: PAnsiChar; PLen: integer; out Result: RawByteString; - SafeDecompression: boolean=false); overload; - -/// deprecated function - please call AlgoSynLZ.DecompressToBytes() method -function SynLZCompressToBytes(const Data: RawByteString; - CompressionSizeTrigger: integer=100): TByteDynArray; overload; - -/// deprecated function - please call AlgoSynLZ.CompressToBytes() method -function SynLZCompressToBytes(P: PAnsiChar; PLen: integer; - CompressionSizeTrigger: integer=100): TByteDynArray; overload; - -/// deprecated function - please call AlgoSynLZ.Decompress() method -function SynLZDecompress(const Data: TByteDynArray): RawByteString; overload; - -/// deprecated function - please call AlgoSynLZ.Decompress() method -function SynLZDecompress(const Data: RawByteString; out Len: integer; - var tmp: RawByteString): pointer; overload; - -/// deprecated function - please call AlgoSynLZ.Decompress() method -function SynLZDecompress(P: PAnsiChar; PLen: integer; out Len: integer; - var tmp: RawByteString): pointer; overload; - -/// deprecated function - please call AlgoSynLZ.DecompressHeader() method -function SynLZDecompressHeader(P: PAnsiChar; PLen: integer): integer; - -/// deprecated function - please call AlgoSynLZ.DecompressBody() method -function SynLZDecompressBody(P,Body: PAnsiChar; PLen,BodyLen: integer; - SafeDecompression: boolean=false): boolean; - -/// deprecated function - please call AlgoSynLZ.DecompressPartial() method -function SynLZDecompressPartial(P,Partial: PAnsiChar; PLen,PartialLen: integer): integer; - - - -implementation - -{$ifdef FPC} -uses - {$ifdef FPC_X64MM} - {$ifdef CPUX64} - SynFPCx64MM, - {$else} - {$undef FPC_X64MM} - {$endif CPUX64} - {$endif FPC_X64MM} - {$ifdef LINUX} - Unix, - dynlibs, - {$ifdef BSD} - sysctl, - {$else} - Linux, - {$endif BSD} - {$ifdef FPCUSEVERSIONINFO} // to be enabled in Synopse.inc - fileinfo, // FPC 3.0 and up - {$ifdef DARWIN} - machoreader, // MACH-O executables - {$else} - elfreader, // ELF executables - {$endif DARWIN} - {$endif FPCUSEVERSIONINFO} - {$ifdef ISFPC271} - unixcp, // for GetSystemCodePage - {$endif} - SynFPCLinux, - {$endif LINUX} - SynFPCTypInfo; // small wrapper unit around FPC's TypInfo.pp -{$endif FPC} - - -{ ************ some fast UTF-8 / Unicode / Ansi conversion routines } - -var - // internal list of TSynAnsiConvert instances - SynAnsiConvertList: TSynObjectList = nil; - -{$ifdef HASINLINE} -{$ifdef USE_VTYPE_STATIC} // circumvent weird bug on BSD + ARM (Alfred) -procedure VarClear(var v: variant); // defined here for proper inlining -const VTYPE_STATIC = $BFE8; // bitmask to avoid remote VarClearProc call -var p: PInteger; // more efficient generated asm with an explicit temp variable -begin - p := @v; - if p^ and VTYPE_STATIC=0 then - p^ := 0 else - VarClearProc(PVarData(p)^); -end; -{$else} -procedure VarClear(var v: variant); // defined here for proper inlining -begin - VarClearProc(PVarData(@v)^); -end; -{$endif USE_VTYPE_STATIC} -{$endif HASINLINE} - -procedure MoveSmall(Source, Dest: Pointer; Count: PtrUInt); -var c: AnsiChar; // better FPC inlining -begin - inc(PtrUInt(Source),Count); - inc(PtrUInt(Dest),Count); - PtrInt(Count) := -PtrInt(Count); - repeat - c := PAnsiChar(Source)[Count]; - PAnsiChar(Dest)[Count] := c; - inc(Count); - until Count=0; -end; - - -{ TSynTempBuffer } - -procedure TSynTempBuffer.Init(Source: pointer; SourceLen: PtrInt); -begin - len := SourceLen; - if len<=0 then - buf := nil else begin - if len<=SizeOf(tmp)-16 then - buf := @tmp else - GetMem(buf,len+16); // +16 for trailing #0 and for PInteger() parsing - if Source<>nil then begin - MoveFast(Source^,buf^,len); - PPtrInt(PAnsiChar(buf)+len)^ := 0; // init last 4/8 bytes (makes valgrid happy) - end; - end; -end; - -function TSynTempBuffer.InitOnStack: pointer; -begin - buf := @tmp; - len := SizeOf(tmp); - result := @tmp; -end; - -procedure TSynTempBuffer.Init(const Source: RawByteString); -begin - Init(pointer(Source),length(Source)); -end; - -function TSynTempBuffer.Init(Source: PUTF8Char): PUTF8Char; -begin - Init(Source,StrLen(Source)); - result := buf; -end; - -function TSynTempBuffer.Init(SourceLen: PtrInt): pointer; -begin - len := SourceLen; - if len<=0 then - buf := nil else begin - if len<=SizeOf(tmp)-16 then - buf := @tmp else - GetMem(buf,len+16); // +16 for trailing #0 and for PInteger() parsing - end; - result := buf; -end; - -function TSynTempBuffer.Init: integer; -begin - buf := @tmp; - result := SizeOf(tmp)-16; - len := result; -end; - -function TSynTempBuffer.InitRandom(RandomLen: integer; forcegsl: boolean): pointer; -begin - Init(RandomLen); - if RandomLen>0 then - FillRandom(buf,(RandomLen shr 2)+1,forcegsl); - result := buf; -end; - -function TSynTempBuffer.InitIncreasing(Count, Start: PtrInt): PIntegerArray; -begin - Init((Count-Start)*4); - FillIncreasing(buf,Start,Count); - result := buf; -end; - -function TSynTempBuffer.InitZero(ZeroLen: PtrInt): pointer; -begin - Init(ZeroLen-16); - FillCharFast(buf^,ZeroLen,0); - result := buf; -end; - -procedure TSynTempBuffer.Done; -begin - if (buf<>@tmp) and (buf<>nil) then - FreeMem(buf); -end; - -procedure TSynTempBuffer.Done(EndBuf: pointer; var Dest: RawUTF8); -begin - if EndBuf=nil then - Dest := '' else - FastSetString(Dest,buf,PAnsiChar(EndBuf)-PAnsiChar(buf)); - if (buf<>@tmp) and (buf<>nil) then - FreeMem(buf); -end; - - -{ TSynAnsiConvert } - -{$ifdef MSWINDOWS} -const - DefaultCharVar: AnsiChar = '?'; -{$endif} - -function TSynAnsiConvert.AnsiBufferToUnicode(Dest: PWideChar; - Source: PAnsiChar; SourceChars: Cardinal; NoTrailingZero: boolean): PWideChar; -var c: cardinal; -{$ifndef MSWINDOWS} -{$ifdef KYLIX3} - ic: iconv_t; - DestBegin: PAnsiChar; - SourceCharsBegin: integer; -{$endif} -{$endif} -begin - {$ifdef KYLIX3} - SourceCharsBegin := SourceChars; - DestBegin := pointer(Dest); - {$endif} - // first handle trailing 7 bit ASCII chars, by quad (Sha optimization) - if SourceChars>=4 then - repeat - c := PCardinal(Source)^; - if c and $80808080<>0 then - break; // break on first non ASCII quad - dec(SourceChars,4); - inc(Source,4); - PCardinal(Dest)^ := (c shl 8 or (c and $FF)) and $00ff00ff; - c := c shr 16; - PCardinal(Dest+2)^ := (c shl 8 or c) and $00ff00ff; - inc(Dest,4); - until SourceChars<4; - if (SourceChars>0) and (ord(Source^)<=127) then - repeat - dec(SourceChars); - PWord(Dest)^ := ord(Source^); // much faster than dest^ := WideChar(c) for FPC - inc(Source); - inc(Dest); - until (SourceChars=0) or (ord(Source^)>=128); - // rely on the Operating System for all remaining ASCII characters - if SourceChars=0 then - result := Dest else begin - {$ifdef MSWINDOWS} - result := Dest+MultiByteToWideChar( - fCodePage,MB_PRECOMPOSED,Source,SourceChars,Dest,SourceChars); - {$else} - {$ifdef ISDELPHIXE} // use cross-platform wrapper for MultiByteToWideChar() - result := Dest+UnicodeFromLocaleChars( - fCodePage,MB_PRECOMPOSED,Source,SourceChars,Dest,SourceChars); - {$else} - {$ifdef FPC} - // uses our SynFPCLinux ICU API helper - result := Dest+AnsiToWideICU(fCodePage,Source,Dest,SourceChars); - {$else} - {$ifdef KYLIX3} - result := Dest; // makes compiler happy - ic := LibC.iconv_open('UTF-16LE',Pointer(fIConvCodeName)); - if PtrInt(ic)>=0 then - try - result := IconvBufConvert(ic,Source,SourceChars,1, - Dest,SourceCharsBegin*2-(PAnsiChar(Dest)-DestBegin),2); - finally - LibC.iconv_close(ic); - end else - {$else} - raise ESynException.CreateUTF8('%.AnsiBufferToUnicode() not supported yet for CP=%', - [self,CodePage]); - {$endif KYLIX3} - {$endif FPC} - {$endif ISDELPHIXE} - {$endif MSWINDOWS} - end; - if not NoTrailingZero then - result^ := #0; -end; - -function TSynAnsiConvert.AnsiBufferToUTF8(Dest: PUTF8Char; - Source: PAnsiChar; SourceChars: Cardinal; NoTrailingZero: boolean): PUTF8Char; -var tmp: TSynTempBuffer; - c: cardinal; - U: PWideChar; -begin - // first handle trailing 7 bit ASCII chars, by quad (Sha optimization) - if SourceChars>=4 then - repeat - c := PCardinal(Source)^; - if c and $80808080<>0 then - break; // break on first non ASCII quad - PCardinal(Dest)^ := c; - dec(SourceChars,4); - inc(Source,4); - inc(Dest,4); - until SourceChars<4; - if (SourceChars>0) and (ord(Source^)<=127) then - repeat - Dest^ := Source^; - dec(SourceChars); - inc(Source); - inc(Dest); - until (SourceChars=0) or (ord(Source^)>=128); - // rely on the Operating System for all remaining ASCII characters - if SourceChars=0 then - result := Dest else begin - U := AnsiBufferToUnicode(tmp.Init(SourceChars*3),Source,SourceChars); - result := Dest+RawUnicodeToUtf8(Dest,SourceChars*3,tmp.buf, - (PtrUInt(U)-PtrUInt(tmp.buf))shr 1,[ccfNoTrailingZero]); - tmp.Done; - end; - if not NoTrailingZero then - result^ := #0; -end; - -// UTF-8 is AT MOST 50% bigger than UTF-16 in bytes in range U+0800..U+FFFF -// see http://stackoverflow.com/a/7008095 -> bytes=WideCharCount*3 below - -procedure TSynAnsiConvert.InternalAppendUTF8(Source: PAnsiChar; SourceChars: Cardinal; - DestTextWriter: TObject; Escape: TTextWriterKind); -var W: TTextWriter absolute DestTextWriter; - tmp: TSynTempBuffer; -begin // rely on explicit conversion - SourceChars := AnsiBufferToUTF8(tmp.Init(SourceChars*3),Source,SourceChars)-PUTF8Char(tmp.buf); - W.Add(tmp.buf,SourceChars,Escape); - tmp.Done; -end; - -function TSynAnsiConvert.AnsiToRawUnicode(const AnsiText: RawByteString): RawUnicode; -begin - result := AnsiToRawUnicode(pointer(AnsiText),length(AnsiText)); -end; - -function TSynAnsiConvert.AnsiToRawUnicode(Source: PAnsiChar; SourceChars: Cardinal): RawUnicode; -var U: PWideChar; - tmp: TSynTempBuffer; -begin - if SourceChars=0 then - result := '' else begin - U := AnsiBufferToUnicode(tmp.Init(SourceChars*2),Source,SourceChars); - U^ := #0; - SetString(result,PAnsiChar(tmp.buf),PtrUInt(U)-PtrUInt(tmp.buf)+1); - tmp.Done; - end; -end; - -function TSynAnsiConvert.AnsiToUnicodeString(Source: PAnsiChar; SourceChars: Cardinal): SynUnicode; -var tmp: TSynTempBuffer; - U: PWideChar; -begin - if SourceChars=0 then - result := '' else begin - U := AnsiBufferToUnicode(tmp.Init(SourceChars*2),Source,SourceChars); - SetString(result,PWideChar(tmp.buf),(PtrUInt(U)-PtrUInt(tmp.buf))shr 1); - tmp.Done; - end; -end; - -function TSynAnsiConvert.AnsiToUnicodeString(const Source: RawByteString): SynUnicode; -var tmp: TSynTempBuffer; - U: PWideChar; -begin - if Source='' then - result := '' else begin - tmp.Init(length(Source)*2); // max dest size in bytes - U := AnsiBufferToUnicode(tmp.buf,pointer(Source),length(Source)); - SetString(result,PWideChar(tmp.buf),(PtrUInt(U)-PtrUInt(tmp.buf))shr 1); - tmp.Done; - end; -end; - -function TSynAnsiConvert.AnsiToUTF8(const AnsiText: RawByteString): RawUTF8; -begin - result := AnsiBufferToRawUTF8(pointer(AnsiText),length(AnsiText)); -end; - -function TSynAnsiConvert.AnsiBufferToRawUTF8(Source: PAnsiChar; SourceChars: Cardinal): RawUTF8; -var tmp: TSynTempBuffer; - endchar: pointer; // try circumvent Delphi 10.4 optimization issue -begin - if (Source=nil) or (SourceChars=0) then - result := '' else begin - endchar := AnsiBufferToUTF8(tmp.Init(SourceChars*3),Source,SourceChars,true); - tmp.Done(endchar,result); - end; -end; - -constructor TSynAnsiConvert.Create(aCodePage: cardinal); -begin - fCodePage := aCodePage; - fAnsiCharShift := 1; // default is safe - {$ifdef KYLIX3} - fIConvCodeName := 'CP'+UInt32ToUTF8(aCodePage); - {$endif} -end; - -function IsFixedWidthCodePage(aCodePage: cardinal): boolean; -begin - result := ((aCodePage>=1250) and (aCodePage<=1258)) or - (aCodePage=CODEPAGE_LATIN1) or (aCodePage=CP_RAWBYTESTRING); -end; - -class function TSynAnsiConvert.Engine(aCodePage: cardinal): TSynAnsiConvert; -var i: PtrInt; -begin - if SynAnsiConvertList=nil then begin - GarbageCollectorFreeAndNil(SynAnsiConvertList,TSynObjectList.Create); - CurrentAnsiConvert := TSynAnsiConvert.Engine(GetACP); - WinAnsiConvert := TSynAnsiConvert.Engine(CODEPAGE_US) as TSynAnsiFixedWidth; - UTF8AnsiConvert := TSynAnsiConvert.Engine(CP_UTF8) as TSynAnsiUTF8; - end; - if aCodePage<=0 then begin - result := CurrentAnsiConvert; - exit; - end; - with SynAnsiConvertList do - for i := 0 to Count-1 do begin - result := List[i]; - if result.CodePage=aCodePage then - exit; - end; - if aCodePage=CP_UTF8 then - result := TSynAnsiUTF8.Create(CP_UTF8) else - if aCodePage=CP_UTF16 then - result := TSynAnsiUTF16.Create(CP_UTF16) else - if IsFixedWidthCodePage(aCodePage) then - result := TSynAnsiFixedWidth.Create(aCodePage) else - result := TSynAnsiConvert.Create(aCodePage); - SynAnsiConvertList.Add(result); -end; - -function TSynAnsiConvert.UnicodeBufferToAnsi(Dest: PAnsiChar; - Source: PWideChar; SourceChars: Cardinal): PAnsiChar; -var c: cardinal; -{$ifndef MSWINDOWS} -{$ifdef KYLIX3} - ic: iconv_t; - DestBegin: PAnsiChar; - SourceCharsBegin: integer; -{$endif} -{$endif MSWINDOWS} -begin - {$ifdef KYLIX3} - SourceCharsBegin := SourceChars; - DestBegin := Dest; - {$endif} - // first handle trailing 7 bit ASCII chars, by pairs (Sha optimization) - if SourceChars>=2 then - repeat - c := PCardinal(Source)^; - if c and $ff80ff80<>0 then - break; // break on first non ASCII pair - dec(SourceChars,2); - inc(Source,2); - c := c shr 8 or c; - PWord(Dest)^ := c; - inc(Dest,2); - until SourceChars<2; - if (SourceChars>0) and (ord(Source^)<=127) then - repeat - Dest^ := AnsiChar(ord(Source^)); - dec(SourceChars); - inc(Source); - inc(Dest); - until (SourceChars=0) or (ord(Source^)>=128); - // rely on the Operating System for all remaining ASCII characters - if SourceChars=0 then - result := Dest else begin - {$ifdef MSWINDOWS} - result := Dest+WideCharToMultiByte( - fCodePage,0,Source,SourceChars,Dest,SourceChars*3,@DefaultCharVar,nil); - {$else} - {$ifdef ISDELPHIXE} // use cross-platform wrapper for WideCharToMultiByte() - result := Dest+System.LocaleCharsFromUnicode( - fCodePage,0,Source,SourceChars,Dest,SourceChars*3,@DefaultCharVar,nil); - {$else} - {$ifdef FPC} - // uses our SynFPCLinux ICU API helper - result := Dest+WideToAnsiICU(fCodePage,Source,Dest,SourceChars); - {$else} - {$ifdef KYLIX3} - result := Dest; // makes compiler happy - ic := LibC.iconv_open(Pointer(fIConvCodeName),'UTF-16LE'); - if PtrInt(ic)>=0 then - try - result := IconvBufConvert(ic,Source,SourceChars,2, - Dest,SourceCharsBegin*3-(PAnsiChar(Dest)-DestBegin),1); - finally - LibC.iconv_close(ic); - end else - {$else} - raise ESynException.CreateUTF8('%.UnicodeBufferToAnsi() not supported yet for CP=%', - [self,CodePage]); {$endif KYLIX3} - {$endif FPC} - {$endif ISDELPHIXE} - {$endif MSWINDOWS} - end; -end; - -function TSynAnsiConvert.UTF8BufferToAnsi(Dest: PAnsiChar; - Source: PUTF8Char; SourceChars: Cardinal): PAnsiChar; -var tmp: TSynTempBuffer; -begin - if (Source=nil) or (SourceChars=0) then - result := Dest else begin - tmp.Init((SourceChars+1) shl fAnsiCharShift); - result := UnicodeBufferToAnsi(Dest,tmp.buf,UTF8ToWideChar(tmp.buf,Source,SourceChars) shr 1); - tmp.Done; - end; -end; - -function TSynAnsiConvert.UTF8BufferToAnsi(Source: PUTF8Char; - SourceChars: Cardinal): RawByteString; -begin - UTF8BufferToAnsi(Source,SourceChars,result); -end; - -procedure TSynAnsiConvert.UTF8BufferToAnsi(Source: PUTF8Char; SourceChars: Cardinal; - var result: RawByteString); -var tmp: TSynTempBuffer; -begin - if (Source=nil) or (SourceChars=0) then - result := '' else begin - tmp.Init((SourceChars+1) shl fAnsiCharShift); - FastSetStringCP(result,tmp.buf, - Utf8BufferToAnsi(tmp.buf,Source,SourceChars)-PAnsiChar(tmp.buf),fCodePage); - tmp.Done; - end; -end; - -function TSynAnsiConvert.UTF8ToAnsi(const UTF8: RawUTF8): RawByteString; -begin - UTF8BufferToAnsi(pointer(UTF8),length(UTF8),result); -end; - -function TSynAnsiConvert.Utf8ToAnsiBuffer(const S: RawUTF8; - Dest: PAnsiChar; DestSize: integer): integer; -var tmp: array[0..2047] of AnsiChar; // truncated to 2KB as documented -begin - if (DestSize<=0) or (Dest=nil) then begin - result := 0; - exit; - end; - result := length(s); - if result>0 then begin - if result>SizeOf(tmp) then - result := SizeOf(tmp); - result := UTF8BufferToAnsi(tmp,pointer(s),result)-tmp; - if result>=DestSize then - result := DestSize-1; - MoveFast(tmp,Dest^,result); - end; - Dest[result] := #0; -end; - -function TSynAnsiConvert.UnicodeBufferToAnsi(Source: PWideChar; SourceChars: Cardinal): RawByteString; -var tmp: TSynTempBuffer; -begin - if (Source=nil) or (SourceChars=0) then - result := '' else begin - tmp.Init((SourceChars+1) shl fAnsiCharShift); - FastSetStringCP(result,tmp.buf, - UnicodeBufferToAnsi(tmp.buf,Source,SourceChars)-PAnsiChar(tmp.buf),fCodePage); - tmp.Done; - end; -end; - -function TSynAnsiConvert.RawUnicodeToAnsi(const Source: RawUnicode): RawByteString; -begin - result := UnicodeBufferToAnsi(pointer(Source),length(Source) shr 1); -end; - -function TSynAnsiConvert.AnsiToAnsi(From: TSynAnsiConvert; const Source: RawByteString): RawByteString; -begin - if From=self then - result := Source else - result := AnsiToAnsi(From,pointer(Source),length(Source)); -end; - -function TSynAnsiConvert.AnsiToAnsi(From: TSynAnsiConvert; Source: PAnsiChar; SourceChars: cardinal): RawByteString; -var tmpU: array[byte] of WideChar; - U: PWideChar; -begin - if From=self then - FastSetStringCP(result,Source,SourceChars,fCodePage) else - if (Source=nil) or (SourceChars=0) then - result := '' else - if SourceCharsnil) and (SourceChars>0) then begin - // handle 7 bit ASCII WideChars, by quads (Sha optimization) - EndSource := Source+SourceChars; - EndSourceBy4 := EndSource-4; - if (PtrUInt(Source) and 3=0) and (Source<=EndSourceBy4) then - repeat -By4: c := PCardinal(Source)^; - if c and $80808080<>0 then - goto By1; // break on first non ASCII quad - inc(Source,4); - PCardinal(Dest)^ := c; - inc(Dest,4); - until Source>EndSourceBy4; - // generic loop, handling one WideChar per iteration - if Source$7ff then begin - Dest[0] := AnsiChar($E0 or (c shr 12)); - Dest[1] := AnsiChar($80 or ((c shr 6) and $3F)); - Dest[2] := AnsiChar($80 or (c and $3F)); - Inc(Dest,3); - if (PtrUInt(Source) and 3=0) and (Source<=EndSourceBy4) then goto By4; - if Source 255 - // - values taken from MultiByteToWideChar(1252,0,@Tmp,256,@WinAnsiTable,256) - // so these values are available outside the Windows platforms (e.g. Linux/BSD) - // and even if registry has been tweaked as such: - // http://www.fas.harvard.edu/~chgis/data/chgis/downloads/v4/howto/cyrillic.html - WinAnsiUnicodeChars: packed array[128..159] of word = - (8364, 129, 8218, 402, 8222, 8230, 8224, 8225, 710, 8240, 352, 8249, 338, - 141, 381, 143, 144, 8216, 8217, 8220, 8221, 8226, 8211, 8212, 732, 8482, - 353, 8250, 339, 157, 382, 376); - -constructor TSynAnsiFixedWidth.Create(aCodePage: cardinal); -var i: PtrInt; - A256: array[0..256] of AnsiChar; - U256: array[0..256] of WideChar; // AnsiBufferToUnicode() write a last #0 -begin - inherited; - if not IsFixedWidthCodePage(aCodePage) then - // ESynException.CreateUTF8() uses UTF8ToString() -> use CreateFmt() here - raise ESynException.CreateFmt('%s.Create - Invalid code page %d', - [ClassName,fCodePage]); - // create internal look-up tables - SetLength(fAnsiToWide,256); - if (aCodePage=CODEPAGE_US) or (aCodePage=CODEPAGE_LATIN1) or - (aCodePage=CP_RAWBYTESTRING) then begin - for i := 0 to 255 do - fAnsiToWide[i] := i; - if aCodePage=CODEPAGE_US then // do not trust the Windows API :( - for i := low(WinAnsiUnicodeChars) to high(WinAnsiUnicodeChars) do - fAnsiToWide[i] := WinAnsiUnicodeChars[i]; - end else begin // from Operating System returned values - for i := 0 to 255 do - A256[i] := AnsiChar(i); - FillcharFast(U256,SizeOf(U256),0); - if PtrUInt(inherited AnsiBufferToUnicode(U256,A256,256))-PtrUInt(@U256)>512 then - // warning: CreateUTF8() uses UTF8ToString() -> use CreateFmt() now - raise ESynException.CreateFmt('OS error for %s.Create(%d)',[ClassName,aCodePage]); - MoveFast(U256[0],fAnsiToWide[0],512); - end; - SetLength(fWideToAnsi,65536); - for i := 1 to 126 do - fWideToAnsi[i] := i; - FillcharFast(fWideToAnsi[127],65536-127,ord('?')); // '?' for unknown char - for i := 127 to 255 do - if (fAnsiToWide[i]<>0) and (fAnsiToWide[i]<>ord('?')) then - fWideToAnsi[fAnsiToWide[i]] := i; - // fixed width Ansi will never be bigger than UTF-8 - fAnsiCharShift := 0; -end; - -function TSynAnsiFixedWidth.IsValidAnsi(WideText: PWideChar; Length: PtrInt): boolean; -var i: PtrInt; - wc: PtrUInt; -begin - result := false; - if WideText<>nil then - for i := 0 to Length-1 do begin - wc := PtrUInt(WideText[i]); - if wc=0 then - break else - if wc<256 then - if fAnsiToWide[wc]<256 then - continue else - exit else - if fWideToAnsi[wc]=ord('?') then - exit else - continue; - end; - result := true; -end; - -function TSynAnsiFixedWidth.IsValidAnsi(WideText: PWideChar): boolean; -var wc: PtrUInt; -begin - result := false; - if WideText<>nil then - repeat - wc := PtrUInt(WideText^); - inc(WideText); - if wc=0 then - break else - if wc<256 then - if fAnsiToWide[wc]<256 then - continue else - exit else - if fWideToAnsi[wc]=ord('?') then - exit else - continue; - until false; - result := true; -end; - -function TSynAnsiFixedWidth.IsValidAnsiU(UTF8Text: PUTF8Char): boolean; -var c: PtrUInt; - i, extra: PtrInt; -begin - result := false; - if UTF8Text<>nil then - repeat - c := byte(UTF8Text^); - inc(UTF8Text); - if c=0 then break else - if c<=127 then - continue else begin - extra := UTF8_EXTRABYTES[c]; - if UTF8_EXTRA[extra].minimum>$ffff then - exit; - for i := 1 to extra do begin - if byte(UTF8Text^) and $c0<>$80 then exit; // invalid UTF-8 content - c := c shl 6+byte(UTF8Text^); - inc(UTF8Text); - end; - dec(c,UTF8_EXTRA[extra].offset); - if (c>$ffff) or (fWideToAnsi[c]=ord('?')) then - exit; // invalid char in the WinAnsi code page - end; - until false; - result := true; -end; - -function TSynAnsiFixedWidth.IsValidAnsiU8Bit(UTF8Text: PUTF8Char): boolean; -var c: PtrUInt; - i, extra: PtrInt; -begin - result := false; - if UTF8Text<>nil then - repeat - c := byte(UTF8Text^); - inc(UTF8Text); - if c=0 then break else - if c<=127 then - continue else begin - extra := UTF8_EXTRABYTES[c]; - if UTF8_EXTRA[extra].minimum>$ffff then - exit; - for i := 1 to extra do begin - if byte(UTF8Text^) and $c0<>$80 then exit; // invalid UTF-8 content - c := c shl 6+byte(UTF8Text^); - inc(UTF8Text); - end; - dec(c,UTF8_EXTRA[extra].offset); - if (c>255) or (fAnsiToWide[c]>255) then - exit; // not 8 bit char (like "tm" or such) is marked invalid - end; - until false; - result := true; -end; - -function TSynAnsiFixedWidth.UnicodeBufferToAnsi(Dest: PAnsiChar; - Source: PWideChar; SourceChars: Cardinal): PAnsiChar; -var c: cardinal; - tab: PAnsiChar; -begin - // first handle trailing 7 bit ASCII chars, by pairs (Sha optimization) - if SourceChars>=2 then - repeat - c := PCardinal(Source)^; - if c and $ff80ff80<>0 then - break; // break on first non ASCII pair - dec(SourceChars,2); - inc(Source,2); - c := c shr 8 or c; - PWord(Dest)^ := c; - inc(Dest,2); - until SourceChars<2; - // use internal lookup tables for fast process of remaining chars - tab := pointer(fWideToAnsi); - for c := 1 to SourceChars shr 2 do begin - Dest[0] := tab[Ord(Source[0])]; - Dest[1] := tab[Ord(Source[1])]; - Dest[2] := tab[Ord(Source[2])]; - Dest[3] := tab[Ord(Source[3])]; - inc(Source,4); - inc(Dest,4); - end; - for c := 1 to SourceChars and 3 do begin - Dest^ := tab[Ord(Source^)]; - inc(Dest); - inc(Source); - end; - result := Dest; -end; - -function TSynAnsiFixedWidth.UTF8BufferToAnsi(Dest: PAnsiChar; - Source: PUTF8Char; SourceChars: Cardinal): PAnsiChar; -var c: cardinal; - endSource, endSourceBy4: PUTF8Char; - i,extra: integer; -label By1, By4, Quit; // ugly but faster -begin - // first handle trailing 7 bit ASCII chars, by quad (Sha optimization) - endSource := Source+SourceChars; - endSourceBy4 := endSource-4; - if (PtrUInt(Source) and 3=0) and (Source<=endSourceBy4) then - repeat -By4: c := PCardinal(Source)^; - if c and $80808080<>0 then - goto By1; // break on first non ASCII quad - PCardinal(Dest)^ := c; - inc(Source,4); - inc(Dest,4); - until Source>endSourceBy4; - // generic loop, handling one UTF-8 code per iteration - if SourceendSource) then break; - for i := 1 to extra do begin - if byte(Source^) and $c0<>$80 then - goto Quit; // invalid UTF-8 content - c := c shl 6+byte(Source^); - inc(Source); - end; - dec(c,UTF8_EXTRA[extra].offset); - if c>$ffff then - Dest^ := '?' else // '?' as in unknown fWideToAnsi[] items - Dest^ := AnsiChar(fWideToAnsi[c]); - inc(Dest); - if (PtrUInt(Source) and 3=0) and (Source<=endSourceBy4) then goto By4; - if SourceCP_UTF8 then - raise ESynException.CreateUTF8('%.Create(%)',[self,aCodePage]); - inherited Create(aCodePage); -end; - -function TSynAnsiUTF8.UnicodeBufferToUTF8(Dest: PAnsiChar; DestChars: Cardinal; - Source: PWideChar; SourceChars: Cardinal): PAnsiChar; -begin - result := Dest+RawUnicodeToUTF8(PUTF8Char(Dest),DestChars,Source,SourceChars, - [ccfNoTrailingZero]); -end; - -function TSynAnsiUTF8.UnicodeBufferToAnsi(Dest: PAnsiChar; - Source: PWideChar; SourceChars: Cardinal): PAnsiChar; -begin - result := UnicodeBufferToUTF8(Dest,SourceChars,Source,SourceChars); -end; - -function TSynAnsiUTF8.UnicodeBufferToAnsi(Source: PWideChar; - SourceChars: Cardinal): RawByteString; -var tmp: TSynTempBuffer; -begin - if (Source=nil) or (SourceChars=0) then - result := '' else begin - tmp.Init(SourceChars*3); - FastSetStringCP(result,tmp.buf,UnicodeBufferToUTF8(tmp.buf, - SourceChars*3,Source,SourceChars)-PAnsiChar(tmp.buf),fCodePage); - tmp.Done; - end; -end; - -function TSynAnsiUTF8.UTF8BufferToAnsi(Dest: PAnsiChar; Source: PUTF8Char; - SourceChars: Cardinal): PAnsiChar; -begin - MoveFast(Source^,Dest^,SourceChars); - result := Dest+SourceChars; -end; - -procedure TSynAnsiUTF8.UTF8BufferToAnsi(Source: PUTF8Char; SourceChars: Cardinal; - var result: RawByteString); -begin - FastSetString(RawUTF8(result),Source,SourceChars); -end; - -function TSynAnsiUTF8.UTF8ToAnsi(const UTF8: RawUTF8): RawByteString; -begin - result := UTF8; - {$ifdef HASCODEPAGE} - SetCodePage(result,CP_UTF8,false); - {$endif} -end; - -function TSynAnsiUTF8.AnsiToUTF8(const AnsiText: RawByteString): RawUTF8; -begin - result := AnsiText; - {$ifdef HASCODEPAGE} - SetCodePage(RawByteString(result),CP_UTF8,false); - {$endif} -end; - -function TSynAnsiUTF8.AnsiBufferToRawUTF8(Source: PAnsiChar; SourceChars: Cardinal): RawUTF8; -begin - FastSetString(Result,Source,SourceChars); -end; - - -{ TSynAnsiUTF16 } - -function TSynAnsiUTF16.AnsiBufferToUnicode(Dest: PWideChar; - Source: PAnsiChar; SourceChars: Cardinal; NoTrailingZero: boolean): PWideChar; -begin - MoveFast(Source^,Dest^,SourceChars); - result := Pointer(PtrUInt(Dest)+SourceChars); - if not NoTrailingZero then - result^ := #0; -end; - -const - NOTRAILING: array[boolean] of TCharConversionFlags = - ([],[ccfNoTrailingZero]); - -function TSynAnsiUTF16.AnsiBufferToUTF8(Dest: PUTF8Char; Source: PAnsiChar; - SourceChars: Cardinal; NoTrailingZero: boolean): PUTF8Char; -begin - SourceChars := SourceChars shr 1; // from byte count to WideChar count - result := Dest+RawUnicodeToUtf8(Dest,SourceChars*3, - PWideChar(Source),SourceChars,NOTRAILING[NoTrailingZero]); -end; - -function TSynAnsiUTF16.AnsiToRawUnicode(Source: PAnsiChar; SourceChars: Cardinal): RawUnicode; -begin - SetString(result,Source,SourceChars); // byte count -end; - -constructor TSynAnsiUTF16.Create(aCodePage: cardinal); -begin - if aCodePage<>CP_UTF16 then - raise ESynException.CreateUTF8('%.Create(%)',[self,aCodePage]); - inherited Create(aCodePage); -end; - -function TSynAnsiUTF16.UnicodeBufferToAnsi(Dest: PAnsiChar; - Source: PWideChar; SourceChars: Cardinal): PAnsiChar; -begin - SourceChars := SourceChars shl 1; // from WideChar count to byte count - MoveFast(Source^,Dest^,SourceChars); - result := Dest+SourceChars; -end; - -function TSynAnsiUTF16.UTF8BufferToAnsi(Dest: PAnsiChar; Source: PUTF8Char; - SourceChars: Cardinal): PAnsiChar; -begin - result := Dest+UTF8ToWideChar(PWideChar(Dest),Source,SourceChars,true); -end; - - -function WideCharToUtf8(Dest: PUTF8Char; aWideChar: PtrUInt): integer; -begin - if aWideChar<=$7F then begin - Dest^ := AnsiChar(aWideChar); - result := 1; - end else - if aWideChar>$7ff then begin - Dest[0] := AnsiChar($E0 or (aWideChar shr 12)); - Dest[1] := AnsiChar($80 or ((aWideChar shr 6) and $3F)); - Dest[2] := AnsiChar($80 or (aWideChar and $3F)); - result := 3; - end else begin - Dest[0] := AnsiChar($C0 or (aWideChar shr 6)); - Dest[1] := AnsiChar($80 or (aWideChar and $3F)); - result := 2; - end; -end; - -function UTF16CharToUtf8(Dest: PUTF8Char; var Source: PWord): integer; -var c: cardinal; - j: integer; -begin - c := Source^; - inc(Source); - case c of - 0..$7f: begin - Dest^ := AnsiChar(c); - result := 1; - exit; - end; - UTF16_HISURROGATE_MIN..UTF16_HISURROGATE_MAX: begin - c := ((c-$D7C0)shl 10)+(Source^ xor UTF16_LOSURROGATE_MIN); - inc(Source); - end; - UTF16_LOSURROGATE_MIN..UTF16_LOSURROGATE_MAX: begin - c := ((cardinal(Source^)-$D7C0)shl 10)+(c xor UTF16_LOSURROGATE_MIN); - inc(Source); - end; - end; // now c is the UTF-32/UCS4 code point - case c of - 0..$7ff: result := 2; - $800..$ffff: result := 3; - $10000..$1FFFFF: result := 4; - $200000..$3FFFFFF: result := 5; - else result := 6; - end; - for j := result-1 downto 1 do begin - Dest[j] := AnsiChar((c and $3f)+$80); - c := c shr 6; - end; - Dest^ := AnsiChar(Byte(c) or UTF8_FIRSTBYTE[result]); -end; - -function UCS4ToUTF8(ucs4: cardinal; Dest: PUTF8Char): integer; -var j: integer; -begin - case ucs4 of - 0..$7f: begin - Dest^ := AnsiChar(ucs4); - result := 1; - exit; - end; - $80..$7ff: result := 2; - $800..$ffff: result := 3; - $10000..$1FFFFF: result := 4; - $200000..$3FFFFFF: result := 5; - else result := 6; - end; - for j := result-1 downto 1 do begin - Dest[j] := AnsiChar((ucs4 and $3f)+$80); - ucs4 := ucs4 shr 6; - end; - Dest^ := AnsiChar(Byte(ucs4) or UTF8_FIRSTBYTE[result]); -end; - -procedure AnyAnsiToUTF8(const s: RawByteString; var result: RawUTF8); -{$ifdef HASCODEPAGE}var CodePage: Cardinal;{$endif} -begin - if s='' then - result := '' else begin - {$ifdef HASCODEPAGE} - CodePage := StringCodePage(s); - if (CodePage=CP_UTF8) or (CodePage=CP_RAWBYTESTRING) then - result := s else - result := TSynAnsiConvert.Engine(CodePage). - {$else} - result := CurrentAnsiConvert. - {$endif} - AnsiBufferToRawUTF8(pointer(s),length(s)); - end; -end; - -function AnyAnsiToUTF8(const s: RawByteString): RawUTF8; -begin - AnyAnsiToUTF8(s,result); -end; - -function WinAnsiBufferToUtf8(Dest: PUTF8Char; Source: PAnsiChar; SourceChars: Cardinal): PUTF8Char; -begin - result := WinAnsiConvert.AnsiBufferToUTF8(Dest,Source,SourceChars); -end; - -function ShortStringToUTF8(const source: ShortString): RawUTF8; -begin - result := WinAnsiConvert.AnsiBufferToRawUTF8(@source[1],ord(source[0])); -end; - -procedure WinAnsiToUnicodeBuffer(const S: WinAnsiString; Dest: PWordArray; DestLen: PtrInt); -var L: PtrInt; -begin - L := length(S); - if L<>0 then begin - if L>=DestLen then - L := DestLen-1; // truncate to avoid buffer overflow - WinAnsiConvert.AnsiBufferToUnicode(PWideChar(Dest),pointer(S),L); // include last #0 - end else - Dest^[0] := 0; -end; - -function WinAnsiToRawUnicode(const S: WinAnsiString): RawUnicode; -begin - result := WinAnsiConvert.AnsiToRawUnicode(S); -end; - -function WinAnsiToUtf8(const S: WinAnsiString): RawUTF8; -begin - result := WinAnsiConvert.AnsiBufferToRawUTF8(pointer(S),length(s)); -end; - -function WinAnsiToUtf8(WinAnsi: PAnsiChar; WinAnsiLen: PtrInt): RawUTF8; -begin - result := WinAnsiConvert.AnsiBufferToRawUTF8(WinAnsi,WinAnsiLen); -end; - -function WideCharToWinAnsiChar(wc: cardinal): AnsiChar; -begin - wc := WinAnsiConvert.WideCharToAnsiChar(wc); - if integer(wc)=-1 then - result := '?' else - result := AnsiChar(wc); -end; - -function WideCharToWinAnsi(wc: cardinal): integer; -begin - result := WinAnsiConvert.WideCharToAnsiChar(wc); -end; - -function IsWinAnsi(WideText: PWideChar; Length: integer): boolean; -begin - result := WinAnsiConvert.IsValidAnsi(WideText,Length); -end; - -function IsAnsiCompatible(PC: PAnsiChar): boolean; -begin - result := false; - if PC<>nil then - while true do - if PC^=#0 then - break else - if PC^<=#127 then - inc(PC) else // 7 bits chars are always OK, whatever codepage/charset is used - exit; - result := true; -end; - -function IsAnsiCompatible(PC: PAnsiChar; Len: PtrUInt): boolean; -begin - if PC<>nil then begin - result := false; - Len := PtrUInt(@PC[Len-4]); - if Len>=PtrUInt(PC) then - repeat - if PCardinal(PC)^ and $80808080<>0 then - exit; - inc(PC,4); - until LenPtrUInt(PC) then - repeat - if PC^>=#127 then - exit; - inc(PC); - until Len<=PtrUInt(PC); - end; - result := true; -end; - -function IsAnsiCompatible(const Text: RawByteString): boolean; -begin - result := IsAnsiCompatible(PAnsiChar(pointer(Text)),length(Text)); -end; - -function IsAnsiCompatibleW(PW: PWideChar): boolean; -begin - result := false; - if PW<>nil then - while true do - if ord(PW^)=0 then - break else - if ord(PW^)<=127 then - inc(PW) else // 7 bits chars are always OK, whatever codepage/charset is used - exit; - result := true; -end; - -function IsAnsiCompatibleW(PW: PWideChar; Len: PtrInt): boolean; -var i: PtrInt; -begin - result := false; - if PW<>nil then - for i := 0 to Len-1 do - if ord(PW[i])>127 then - exit; - result := true; -end; - -function IsWinAnsi(WideText: PWideChar): boolean; -begin - result := WinAnsiConvert.IsValidAnsi(WideText); -end; - -function IsWinAnsiU(UTF8Text: PUTF8Char): boolean; -begin - result := WinAnsiConvert.IsValidAnsiU(UTF8Text); -end; - -function IsWinAnsiU8Bit(UTF8Text: PUTF8Char): boolean; -begin - result := WinAnsiConvert.IsValidAnsiU8Bit(UTF8Text); -end; - -function UTF8ToWinPChar(dest: PAnsiChar; source: PUTF8Char; count: integer): integer; -begin - result := WinAnsiConvert.UTF8BufferToAnsi(dest,source,count)-dest; -end; - -function ShortStringToAnsi7String(const source: shortstring): RawByteString; -begin - FastSetString(RawUTF8(result),@source[1],ord(source[0])); -end; - -procedure ShortStringToAnsi7String(const source: shortstring; var result: RawUTF8); -begin - FastSetString(result,@source[1],ord(source[0])); -end; - -procedure UTF8ToShortString(var dest: shortstring; source: PUTF8Char); -var c: cardinal; - len,extra,i: integer; -begin - len := 0; - if source<>nil then - repeat - c := byte(source^); inc(source); - if c=0 then break else - if c<=127 then begin - inc(len); dest[len] := AnsiChar(c); - if len<253 then continue else break; - end else begin - extra := UTF8_EXTRABYTES[c]; - if extra=0 then break; // invalid leading byte - for i := 1 to extra do begin - if byte(source^) and $c0<>$80 then begin - dest[0] := AnsiChar(len); - exit; // invalid UTF-8 content - end; - c := c shl 6+byte(source^); - inc(Source); - end; - dec(c,UTF8_EXTRA[extra].offset); - // #256.. -> slower but accurate conversion - inc(len); - if c>$ffff then - dest[len] := '?' else - dest[len] := AnsiChar(WinAnsiConvert.fWideToAnsi[c]); - if len<253 then continue else break; - end; - until false; - dest[0] := AnsiChar(len); -end; - -function Utf8ToWinAnsi(const S: RawUTF8): WinAnsiString; -begin - result := WinAnsiConvert.UTF8ToAnsi(S); -end; - -function Utf8ToWinAnsi(P: PUTF8Char): WinAnsiString; -begin - result := WinAnsiConvert.UTF8ToAnsi(P); -end; - -procedure Utf8ToRawUTF8(P: PUTF8Char; var result: RawUTF8); -begin // fast and Delphi 2009+ ready - FastSetString(result,P,StrLen(P)); -end; - -function UTF8ToWideChar(dest: PWideChar; source: PUTF8Char; - MaxDestChars, sourceBytes: PtrInt; NoTrailingZero: boolean): PtrInt; -// faster than System.Utf8ToUnicode() -var c: cardinal; - begd: PWideChar; - endSource: PUTF8Char; - endDest: PWideChar; - i,extra: integer; -label Quit, NoSource; -begin - result := 0; - if dest=nil then - exit; - if source=nil then - goto NoSource; - if sourceBytes=0 then begin - if source^=#0 then - goto NoSource; - sourceBytes := StrLen(source); - end; - endSource := source+sourceBytes; - endDest := dest+MaxDestChars; - begd := dest; - repeat - c := byte(source^); - inc(source); - if c<=127 then begin - PWord(dest)^ := c; // much faster than dest^ := WideChar(c) for FPC - inc(dest); - if (sourceendSource) then break; - for i := 1 to extra do begin - if byte(Source^) and $c0<>$80 then - goto Quit; // invalid input content - c := c shl 6+byte(Source^); - inc(Source); - end; - with UTF8_EXTRA[extra] do begin - dec(c,offset); - if c=endsource) or (dest>=endDest) then - break; - until false; -Quit: - result := PtrUInt(dest)-PtrUInt(begd); // dest-begd return byte length -NoSource: - if not NoTrailingZero then - dest^ := #0; // always append a WideChar(0) to the end of the buffer -end; - -function UTF8ToWideChar(dest: PWideChar; source: PUTF8Char; sourceBytes: PtrInt; - NoTrailingZero: boolean): PtrInt; -// faster than System.UTF8Decode() -var c: cardinal; - begd: PWideChar; - endSource, endSourceBy4: PUTF8Char; - i,extra: PtrInt; -label Quit, NoSource, By1, By4; -begin - result := 0; - if dest=nil then - exit; - if source=nil then - goto NoSource; - if sourceBytes=0 then begin - if source^=#0 then - goto NoSource; - sourceBytes := StrLen(source); - end; - begd := dest; - endSource := Source+SourceBytes; - endSourceBy4 := endSource-4; - if (PtrUInt(Source) and 3=0) and (Source<=EndSourceBy4) then - repeat // handle 7 bit ASCII chars, by quad (Sha optimization) -By4: c := PCardinal(Source)^; - if c and $80808080<>0 then - goto By1; // break on first non ASCII quad - inc(Source,4); - PCardinal(dest)^ := (c shl 8 or (c and $FF)) and $00ff00ff; - c := c shr 16; - PCardinal(dest+2)^ := (c shl 8 or c) and $00ff00ff; - inc(dest,4); - until Source>EndSourceBy4; - if SourceendSource) then break; - for i := 1 to extra do begin - if byte(Source^) and $c0<>$80 then - goto Quit; // invalid input content - c := c shl 6+byte(Source^); - inc(Source); - end; - with UTF8_EXTRA[extra] do begin - dec(c,offset); - if c=endSource then break; - until false; -Quit: - result := PtrUInt(dest)-PtrUInt(begd); // dest-begd returns bytes length -NoSource: - if not NoTrailingZero then - dest^ := #0; // always append a WideChar(0) to the end of the buffer -end; - -function IsValidUTF8WithoutControlChars(source: PUTF8Char): Boolean; -var extra, i: integer; - c: cardinal; -begin - result := false; - if source<>nil then - repeat - c := byte(source^); - inc(source); - if c=0 then break else - if c<32 then exit else // disallow #1..#31 control char - if c and $80<>0 then begin - extra := UTF8_EXTRABYTES[c]; - if extra=0 then exit else // invalid leading byte - for i := 1 to extra do - if byte(source^) and $c0<>$80 then // invalid UTF-8 encoding - exit else - inc(source); - end; - until false; - result := true; -end; - -function IsValidUTF8WithoutControlChars(const source: RawUTF8): Boolean; -var s, extra, i, len: integer; - c: cardinal; -begin - result := false; - s := 1; - len := length(source); - while s<=len do begin - c := byte(source[s]); - inc(s); - if c<32 then exit else // disallow #0..#31 control char - if c and $80<>0 then begin - extra := UTF8_EXTRABYTES[c]; - if extra=0 then exit else // invalid leading byte - for i := 1 to extra do - if byte(source[s]) and $c0<>$80 then // reached #0 or invalid UTF-8 - exit else - inc(s); - end; - end; - result := true; -end; - - -function Utf8ToUnicodeLength(source: PUTF8Char): PtrUInt; -var c: PtrUInt; - extra,i: integer; -begin - result := 0; - if source<>nil then - repeat - c := byte(source^); - inc(source); - if c=0 then break else - if c<=127 then - inc(result) else begin - extra := UTF8_EXTRABYTES[c]; - if extra=0 then exit else // invalid leading byte - if extra>=UTF8_EXTRA_SURROGATE then - inc(result,2) else - inc(result); - for i := 1 to extra do // inc(source,extra) is faster but not safe - if byte(source^) and $c0<>$80 then - exit else - inc(source); // check valid UTF-8 content - end; - until false; -end; - -function Utf8TruncateToUnicodeLength(var text: RawUTF8; maxUTF16: integer): boolean; -var c: PtrUInt; - extra,i: integer; - source: PUTF8Char; -begin - source := pointer(text); - if (source<>nil) and (cardinal(maxUtf16)=UTF8_EXTRA_SURROGATE then - dec(maxUTF16,2) else - dec(maxUTF16); - for i := 1 to extra do // inc(source,extra) is faster but not safe - if byte(source^) and $c0<>$80 then - break else - inc(source); // check valid UTF-8 content - end; - until false; - result := false; -end; - -function Utf8TruncateToLength(var text: RawUTF8; maxBytes: PtrUInt): boolean; -begin - if PtrUInt(length(text))0) and (ord(text[maxBytes]) and $c0=$80) do dec(maxBytes); - if (maxBytes>0) and (ord(text[maxBytes]) and $80<>0) then dec(maxBytes); - SetLength(text,maxBytes); - result := true; -end; - -function Utf8TruncatedLength(const text: RawUTF8; maxBytes: PtrUInt): PtrInt; -begin - result := length(text); - if PtrUInt(result)0) and (ord(text[result]) and $c0=$80) do dec(result); - if (result>0) and (ord(text[result]) and $80<>0) then dec(result); -end; - -function Utf8TruncatedLength(text: PAnsiChar; textlen,maxBytes: PtrUInt): PtrInt; -begin - if textlen0) and (ord(text[result]) and $c0=$80) do dec(result); - if (result>0) and (ord(text[result]) and $80<>0) then dec(result); -end; - -function Utf8FirstLineToUnicodeLength(source: PUTF8Char): PtrInt; -var c,extra: PtrUInt; -begin - result := 0; - if source<>nil then - repeat - c := byte(source^); - inc(source); - if c in [0,10,13] then break else // #0, #10 or #13 stop the count - if c<=127 then - inc(result) else begin - extra := UTF8_EXTRABYTES[c]; - if extra=0 then exit else // invalid leading byte - if extra>=UTF8_EXTRA_SURROGATE then - inc(result,2) else - inc(result); - inc(source,extra); // a bit less safe, but faster - end; - until false; -end; - -function Utf8DecodeToRawUnicode(P: PUTF8Char; L: integer): RawUnicode; -var tmp: TSynTempBuffer; -begin - result := ''; // somewhat faster if result is freed before any SetLength() - if L=0 then - L := StrLen(P); - if L=0 then - exit; - // +1 below is for #0 ending -> true WideChar(#0) ending - tmp.Init(L*3); // maximum posible unicode size (if all <#128) - SetString(result,PAnsiChar(tmp.buf),UTF8ToWideChar(tmp.buf,P,L)+1); - tmp.Done; -end; - -function Utf8DecodeToRawUnicode(const S: RawUTF8): RawUnicode; -begin - if S='' then - result := '' else - result := Utf8DecodeToRawUnicode(pointer(S),length(S)); -end; - -function Utf8DecodeToRawUnicodeUI(const S: RawUTF8; DestLen: PInteger): RawUnicode; -var L: integer; -begin - L := Utf8DecodeToRawUnicodeUI(S,result); - if DestLen<>nil then - DestLen^ := L; -end; - -function Utf8DecodeToRawUnicodeUI(const S: RawUTF8; var Dest: RawUnicode): integer; -begin - Dest := ''; // somewhat faster if Dest is freed before any SetLength() - if S='' then begin - result := 0; - exit; - end; - result := length(S); - SetLength(Dest,result*2+2); - result := UTF8ToWideChar(pointer(Dest),Pointer(S),result); -end; - -function RawUnicodeToUtf8(Dest: PUTF8Char; DestLen: PtrInt; Source: PWideChar; - SourceLen: PtrInt; Flags: TCharConversionFlags): PtrInt; -var c: Cardinal; - Tail: PWideChar; - i,j: integer; -label unmatch; -begin - result := PtrInt(Dest); - inc(DestLen,PtrInt(Dest)); - if (Source<>nil) and (Dest<>nil) then begin - // first handle 7 bit ASCII WideChars, by pairs (Sha optimization) - SourceLen := SourceLen*2+PtrInt(PtrUInt(Source)); - Tail := PWideChar(SourceLen)-2; - if (PtrInt(PtrUInt(Dest))0 then - break; // break on first non ASCII pair - inc(Source,2); - c := c shr 8 or c; - PWord(Dest)^ := c; - inc(Dest,2); - until (Source>Tail) or (PtrInt(PtrUInt(Dest))>=DestLen); - // generic loop, handling one UCS4 char per iteration - if (PtrInt(PtrUInt(Dest))=SourceLen) or - ((cardinal(Source^)UTF16_LOSURROGATE_MAX)) then begin -unmatch: if (PtrInt(PtrUInt(@Dest[3]))>DestLen) or - not (ccfReplacementCharacterForUnmatchedSurrogate in Flags) then - break; - PWord(Dest)^ := $BFEF; - Dest[2] := AnsiChar($BD); - inc(Dest,3); - if (PtrInt(PtrUInt(Dest))=SourceLen) or - ((cardinal(Source^)UTF16_HISURROGATE_MAX)) then - goto unmatch else begin - c := ((cardinal(Source^)-$D7C0)shl 10)+(c xor UTF16_LOSURROGATE_MIN); - inc(Source); - end; - end; // now c is the UTF-32/UCS4 code point - case c of - 0..$7ff: i := 2; - $800..$ffff: i := 3; - $10000..$1FFFFF: i := 4; - $200000..$3FFFFFF: i := 5; - else i := 6; - end; - if PtrInt(PtrUInt(Dest))+i>DestLen then - break; - for j := i-1 downto 1 do begin - Dest[j] := AnsiChar((c and $3f)+$80); - c := c shr 6; - end; - Dest^ := AnsiChar(Byte(c) or UTF8_FIRSTBYTE[i]); - inc(Dest,i); - if (PtrInt(PtrUInt(Dest)) direct assign -end; -{$endif} - -function Ansi7ToString(Text: PWinAnsiChar; Len: PtrInt): string; -begin - {$ifdef UNICODE} - Ansi7ToString(Text,Len,result); - {$else} - SetString(result,PAnsiChar(Text),Len); - {$endif} -end; - -procedure Ansi7ToString(Text: PWinAnsiChar; Len: PtrInt; var result: string); -{$ifdef UNICODE} -var i: PtrInt; -begin - SetString(result,nil,Len); - for i := 0 to Len-1 do - PWordArray(result)[i] := PByteArray(Text)[i]; // no conversion for 7 bit Ansi -end; -{$else} -begin - SetString(result,PAnsiChar(Text),Len); -end; -{$endif} - -function StringToAnsi7(const Text: string): RawByteString; -{$ifdef UNICODE} -var i: PtrInt; -begin - SetString(result,nil,length(Text)); - for i := 0 to length(Text)-1 do - PByteArray(result)[i] := PWordArray(Text)[i]; // no conversion for 7 bit Ansi -end; -{$else} -begin - result := Text; // if we are SURE this text is 7 bit Ansi -> direct assign -end; -{$endif} - -function StringToWinAnsi(const Text: string): WinAnsiString; -begin - {$ifdef UNICODE} - result := RawUnicodeToWinAnsi(Pointer(Text),length(Text)); - {$else} - result := WinAnsiConvert.AnsiToAnsi(CurrentAnsiConvert,Text); - {$endif} -end; - -function StringBufferToUtf8(Dest: PUTF8Char; Source: PChar; SourceChars: PtrInt): PUTF8Char; -begin - {$ifdef UNICODE} - result := Dest+RawUnicodeToUtf8(Dest,SourceChars*3,PWideChar(Source),SourceChars,[]); - {$else} - result := CurrentAnsiConvert.AnsiBufferToUTF8(Dest,Source,SourceChars); - {$endif} -end; - -procedure StringBufferToUtf8(Source: PChar; out result: RawUTF8); overload; -begin - {$ifdef UNICODE} - RawUnicodeToUtf8(Source,StrLenW(Source),result); - {$else} - result := CurrentAnsiConvert.AnsiBufferToRawUTF8(Source,StrLen(Source)); - {$endif} -end; - -function StringToUTF8(const Text: string): RawUTF8; -begin - {$ifdef UNICODE} - RawUnicodeToUtf8(pointer(Text),length(Text),result); - {$else} - result := CurrentAnsiConvert.AnsiToUTF8(Text); - {$endif} -end; - -procedure StringToUTF8(Text: PChar; TextLen: PtrInt; var result: RawUTF8); -begin - {$ifdef UNICODE} - RawUnicodeToUtf8(Text,TextLen,result); - {$else} - result := CurrentAnsiConvert.AnsiBufferToRawUTF8(Text, TextLen); - {$endif} -end; - -procedure StringToUTF8(const Text: string; var result: RawUTF8); -begin - {$ifdef UNICODE} - RawUnicodeToUtf8(pointer(Text),length(Text),result); - {$else} - result := CurrentAnsiConvert.AnsiToUTF8(Text); - {$endif} -end; - -function ToUTF8(const Text: string): RawUTF8; -begin - {$ifdef UNICODE} - RawUnicodeToUtf8(pointer(Text),length(Text),result); - {$else} - result := CurrentAnsiConvert.AnsiToUTF8(Text); - {$endif} -end; - -function ToUTF8(const Ansi7Text: ShortString): RawUTF8; -begin - FastSetString(result,@Ansi7Text[1],ord(Ansi7Text[0])); -end; - -function ToUTF8({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID): RawUTF8; -begin - FastSetString(result,nil,36); - GUIDToText(pointer(result),@guid); -end; - - -{$ifdef HASVARUSTRING} // some UnicodeString dedicated functions -function UnicodeStringToUtf8(const S: UnicodeString): RawUTF8; -begin - RawUnicodeToUtf8(pointer(S),length(S),result); -end; - -function UTF8DecodeToUnicodeString(const S: RawUTF8): UnicodeString; -begin - UTF8DecodeToUnicodeString(pointer(S),length(S),result); -end; - -procedure UTF8DecodeToUnicodeString(P: PUTF8Char; L: integer; var result: UnicodeString); -var tmp: TSynTempBuffer; -begin - if (P=nil) or (L=0) then - result := '' else begin - tmp.Init(L*3); // maximum posible unicode size (if all <#128) - SetString(result,PWideChar(tmp.buf),UTF8ToWideChar(tmp.buf,P,L) shr 1); - tmp.Done; - end; -end; - -function UnicodeStringToWinAnsi(const S: UnicodeString): WinAnsiString; -begin - result := WinAnsiConvert.UnicodeBufferToAnsi(pointer(S),length(S)); -end; - -function UTF8DecodeToUnicodeString(P: PUTF8Char; L: integer): UnicodeString; -begin - UTF8DecodeToUnicodeString(P,L,result); -end; - -function WinAnsiToUnicodeString(WinAnsi: PAnsiChar; WinAnsiLen: PtrInt): UnicodeString; -begin - SetString(result,nil,WinAnsiLen); - WinAnsiConvert.AnsiBufferToUnicode(pointer(result),WinAnsi,WinAnsiLen); -end; - -function WinAnsiToUnicodeString(const WinAnsi: WinAnsiString): UnicodeString; -begin - result := WinAnsiToUnicodeString(pointer(WinAnsi),length(WinAnsi)); -end; -{$endif HASVARUSTRING} - - -function StrInt32(P: PAnsiChar; val: PtrInt): PAnsiChar; -{$ifdef ABSOLUTEPASCALORNOTINTEL} -begin // fallback to pure pascal version for ARM or PIC - if val<0 then begin - result := StrUInt32(P,PtrUInt(-val))-1; - result^ := '-'; - end else - result := StrUInt32(P,val); -end; -{$else} -{$ifdef CPUX64} {$ifdef FPC}nostackframe; assembler; asm {$else} -asm .noframe // rcx=P, rdx=val (Linux: rdi,rsi) - val is QWord on CPUX64 -{$endif FPC} - {$ifndef win64} - mov rcx, rdi - mov rdx, rsi - {$endif win64} - mov r10, rdx - sar r10, 63 // r10=0 if val>=0 or -1 if val<0 - xor rdx, r10 - sub rdx, r10 // rdx=abs(val) - cmp rdx, 10 - jb @3 // direct process of common val<10 - mov rax, rdx - lea r8, [rip + TwoDigitLookup] -@s: lea rcx, [rcx - 2] - cmp rax, 100 - jb @2 - lea r9, [rax * 2] - shr rax, 2 - mov rdx, 2951479051793528259 // use power of two reciprocal to avoid division - mul rdx - shr rdx, 2 - mov rax, rdx - imul rdx, -200 - lea rdx, [rdx + r8] - movzx rdx, word ptr[rdx + r9] - mov [rcx], dx - cmp rax, 10 - jae @s -@1: or al, '0' - mov byte ptr[rcx - 2], '-' - mov [rcx - 1], al - lea rax, [rcx + r10 - 1] // includes '-' if val<0 - ret -@2: movzx eax, word ptr[r8 + rax * 2] - mov byte ptr[rcx - 1], '-' - mov [rcx], ax - lea rax, [rcx + r10] // includes '-' if val<0 - ret -@3: or dl, '0' - mov byte ptr[rcx - 2], '-' - mov [rcx - 1], dl - lea rax, [rcx + r10 - 1] // includes '-' if val<0 -end; -{$else} {$ifdef FPC} nostackframe; assembler; {$endif} -asm // eax=P, edx=val - mov ecx, edx - sar ecx, 31 // 0 if val>=0 or -1 if val<0 - push ecx - xor edx, ecx - sub edx, ecx // edx=abs(val) - cmp edx, 10 - jb @3 // direct process of common val<10 - push edi - mov edi, eax - mov eax, edx -@s: sub edi, 2 - cmp eax, 100 - jb @2 - mov ecx, eax - mov edx, 1374389535 // use power of two reciprocal to avoid division - mul edx - shr edx, 5 // now edx=eax div 100 - mov eax, edx - imul edx, -200 - movzx edx, word ptr[TwoDigitLookup + ecx * 2 + edx] - mov [edi], dx - cmp eax, 10 - jae @s -@1: dec edi - or al, '0' - mov byte ptr[edi - 1], '-' - mov [edi], al - mov eax, edi - pop edi - pop ecx - add eax, ecx // includes '-' if val<0 - ret -@2: movzx eax, word ptr[TwoDigitLookup + eax * 2] - mov byte ptr[edi - 1], '-' - mov [edi], ax - mov eax, edi - pop edi - pop ecx - add eax, ecx // includes '-' if val<0 - ret -@3: dec eax - pop ecx - or dl, '0' - mov byte ptr[eax - 1], '-' - mov [eax], dl - add eax, ecx // includes '-' if val<0 -end; -{$endif CPUX64} -{$endif ABSOLUTEPASCALORNOTINTEL} - -function StrUInt32(P: PAnsiChar; val: PtrUInt): PAnsiChar; -{$ifdef ABSOLUTEPASCALORNOTINTEL} // fallback to pure pascal version for ARM or PIC -var c100: PtrUInt; // val/c100 are QWord on 64-bit CPU - tab: PWordArray; -begin // this code is faster than Borland's original str() or IntToStr() - tab := @TwoDigitLookupW; - repeat - if val<10 then begin - dec(P); - P^ := AnsiChar(val+ord('0')); - break; - end else - if val<100 then begin - dec(P,2); - PWord(P)^ := tab[val]; - break; - end; - dec(P,2); - c100 := val div 100; - dec(val,c100*100); - PWord(P)^ := tab[val]; - val := c100; - if c100=0 then - break; - until false; - result := P; -end; -{$else} -{$ifdef CPUX64} {$ifdef FPC}nostackframe; assembler; asm {$else} -asm .noframe // rcx=P, rdx=val (Linux: rdi,rsi) - val is QWord on CPUX64 -{$endif FPC} - {$ifndef win64} - mov rcx, rdi - mov rdx, rsi - {$endif win64} - cmp rdx, 10 - jb @3 // direct process of common val<10 - mov rax, rdx - lea r8, [rip + TwoDigitLookup] -@s: lea rcx, [rcx - 2] - cmp rax, 100 - jb @2 - lea r9, [rax * 2] - shr rax, 2 - mov rdx, 2951479051793528259 // use power of two reciprocal to avoid division - mul rdx - shr rdx, 2 - mov rax, rdx - imul rdx, -200 - add rdx, r8 - movzx rdx, word ptr[rdx + r9] - mov [rcx], dx - cmp rax, 10 - jae @s -@1: dec rcx - or al, '0' - mov [rcx], al -@0: mov rax, rcx - ret -@2: movzx eax, word ptr[r8 + rax * 2] - mov [rcx], ax - mov rax, rcx - ret -@3: lea rax, [rcx - 1] - or dl, '0' - mov [rax], dl -end; -{$else} {$ifdef FPC} nostackframe; assembler; {$endif} -asm // eax=P, edx=val - cmp edx, 10 - jb @3 // direct process of common val=0 (or val<10) - push edi - mov edi, eax - mov eax, edx - nop - nop // @s loop alignment -@s: sub edi, 2 - cmp eax, 100 - jb @2 - mov ecx, eax - mov edx, 1374389535 // use power of two reciprocal to avoid division - mul edx - shr edx, 5 // now edx=eax div 100 - mov eax, edx - imul edx, -200 - movzx edx, word ptr[TwoDigitLookup + ecx * 2 + edx] - mov [edi], dx - cmp eax, 10 - jae @s -@1: dec edi - or al, '0' - mov [edi], al - mov eax, edi - pop edi - ret -@2: movzx eax, word ptr[TwoDigitLookup + eax * 2] - mov [edi], ax - mov eax, edi - pop edi - ret -@3: dec eax - or dl, '0' - mov [eax], dl -end; -{$endif CPU64} -{$endif ABSOLUTEPASCALORNOTINTEL} - -function StrUInt64(P: PAnsiChar; const val: QWord): PAnsiChar; -{$ifdef CPU64} -begin - result := StrUInt32(P,val); // StrUInt32 converts PtrUInt=QWord on 64-bit CPU -end; -{$else} -var c,c100: QWord; - tab: {$ifdef CPUX86NOTPIC}TWordArray absolute TwoDigitLookupW{$else}PWordArray{$endif}; -begin - if PInt64Rec(@val)^.Hi=0 then - P := StrUInt32(P,PCardinal(@val)^) else begin - {$ifndef CPUX86NOTPIC}tab := @TwoDigitLookupW;{$endif} - c := val; - repeat - {$ifdef PUREPASCAL} - c100 := c div 100; // one div by two digits - dec(c,c100*100); // fast c := c mod 100 - {$else} - asm // by-passing the RTL is a good idea here - push ebx - mov edx, dword ptr[c + 4] - mov eax, dword ptr[c] - mov ebx, 100 - mov ecx, eax - mov eax, edx - xor edx, edx - div ebx - mov dword ptr[c100 + 4], eax - xchg eax, ecx - div ebx - mov dword ptr[c100], eax - imul ebx, ecx - mov ecx, 100 - mul ecx - add edx, ebx - pop ebx - sub dword ptr[c + 4], edx - sbb dword ptr[c], eax - end; - {$endif} - dec(P,2); - PWord(P)^ := tab[c]; - c := c100; - if PInt64Rec(@c)^.Hi=0 then begin - if PCardinal(@c)^<>0 then - P := StrUInt32(P,PCardinal(@c)^); - break; - end; - until false; - end; - result := P; -end; -{$endif} - -function StrInt64(P: PAnsiChar; const val: Int64): PAnsiChar; -begin - {$ifdef CPU64} - result := StrInt32(P,val); // StrInt32 converts PtrInt=Int64 on 64-bit CPU - {$else} - if val<0 then begin - P := StrUInt64(P,-val)-1; - P^ := '-'; - end else - P := StrUInt64(P,val); - result := P; - {$endif CPU64} -end; - -procedure Int32ToUTF8(Value: PtrInt; var result: RawUTF8); -var tmp: array[0..23] of AnsiChar; - P: PAnsiChar; -begin - if PtrUInt(Value)<=high(SmallUInt32UTF8) then - result := SmallUInt32UTF8[Value] else begin - P := StrInt32(@tmp[23],Value); - FastSetString(result,P,@tmp[23]-P); - end; -end; - -procedure Int64ToUtf8(Value: Int64; var result: RawUTF8); -var tmp: array[0..23] of AnsiChar; - P: PAnsiChar; -begin - {$ifdef CPU64} - if PtrUInt(Value)<=high(SmallUInt32UTF8) then - {$else} // Int64Rec gives compiler internal error C4963 - if (PCardinalArray(@Value)^[0]<=high(SmallUInt32UTF8)) and - (PCardinalArray(@Value)^[1]=0) then - {$endif CPU64} - result := SmallUInt32UTF8[Value] else begin - P := {$ifdef CPU64}StrInt32{$else}StrInt64{$endif}(@tmp[23],Value); - FastSetString(result,P,@tmp[23]-P); - end; -end; - -procedure UInt64ToUtf8(Value: QWord; var result: RawUTF8); -var tmp: array[0..23] of AnsiChar; - P: PAnsiChar; -begin - {$ifdef CPU64} - if Value<=high(SmallUInt32UTF8) then - {$else} // Int64Rec gives compiler internal error C4963 - if (PCardinalArray(@Value)^[0]<=high(SmallUInt32UTF8)) and - (PCardinalArray(@Value)^[1]=0) then - {$endif CPU64} - result := SmallUInt32UTF8[Value] else begin - P := {$ifdef CPU64}StrUInt32{$else}StrUInt64{$endif}(@tmp[23],Value); - FastSetString(result,P,@tmp[23]-P); - end; -end; - -function ClassNameShort(C: TClass): PShortString; -// new TObject.ClassName is UnicodeString (since Delphi 2009) -> inline code -// with vmtClassName = UTF-8 encoded text stored in a shortstring = -44 -begin - result := PPointer(PtrInt(PtrUInt(C))+vmtClassName)^; -end; - -function ClassNameShort(Instance: TObject): PShortString; -begin - result := PPointer(PPtrInt(Instance)^+vmtClassName)^; -end; - -function ToText(C: TClass): RawUTF8; -var P: PShortString; -begin - if C=nil then - result := '' else begin - P := PPointer(PtrInt(PtrUInt(C))+vmtClassName)^; - FastSetString(result,@P^[1],ord(P^[0])); - end; -end; - -procedure ToText(C: TClass; var result: RawUTF8); -var P: PShortString; -begin - if C=nil then - result := '' else begin - P := PPointer(PtrInt(PtrUInt(C))+vmtClassName)^; - FastSetString(result,@P^[1],ord(P^[0])); - end; -end; - -function GetClassParent(C: TClass): TClass; -begin - result := PPointer(PtrInt(PtrUInt(C))+vmtParent)^; - {$ifndef HASDIRECTTYPEINFO} // e.g. for Delphi and newer FPC - if result<>nil then - result := PPointer(result)^; - {$endif HASDIRECTTYPEINFO} -end; - -function VarRecAsChar(const V: TVarRec): integer; -begin - case V.VType of - vtChar: result := ord(V.VChar); - vtWideChar: result := ord(V.VWideChar); - else result := 0; - end; -end; - -function VarRecToInt64(const V: TVarRec; out value: Int64): boolean; -begin - case V.VType of - vtInteger: value := V.VInteger; - vtInt64 {$ifdef FPC}, vtQWord{$endif}: value := V.VInt64^; - vtBoolean: if V.VBoolean then value := 1 else value := 0; // normalize - {$ifndef NOVARIANTS} - vtVariant: value := V.VVariant^; - {$endif} - else begin - result := false; - exit; - end; - end; - result := true; -end; - -function VarRecToDouble(const V: TVarRec; out value: double): boolean; -begin - case V.VType of - vtInteger: value := V.VInteger; - vtInt64: value := V.VInt64^; - {$ifdef FPC} - vtQWord: value := V.VQWord^; - {$endif} - vtBoolean: if V.VBoolean then value := 1 else value := 0; // normalize - vtExtended: value := V.VExtended^; - vtCurrency: value := V.VCurrency^; - {$ifndef NOVARIANTS} - vtVariant: value := V.VVariant^; - {$endif} - else begin - result := false; - exit; - end; - end; - result := true; -end; - -function VarRecToTempUTF8(const V: TVarRec; var Res: TTempUTF8): integer; -{$ifndef NOVARIANTS} -var v64: Int64; - isString: boolean; -{$endif} -label smlu32; -begin - Res.TempRawUTF8 := nil; // avoid GPF - case V.VType of - vtString: begin - Res.Text := @V.VString^[1]; - Res.Len := ord(V.VString^[0]); - result := Res.Len; - exit; - end; - vtAnsiString: begin // expect UTF-8 content - Res.Text := pointer(V.VAnsiString); - Res.Len := length(RawUTF8(V.VAnsiString)); - result := Res.Len; - exit; - end; - {$ifdef HASVARUSTRING} - vtUnicodeString: - RawUnicodeToUtf8(V.VPWideChar,length(UnicodeString(V.VUnicodeString)),RawUTF8(Res.TempRawUTF8)); - {$endif} - vtWideString: - RawUnicodeToUtf8(V.VPWideChar,length(WideString(V.VWideString)),RawUTF8(Res.TempRawUTF8)); - vtPChar: begin // expect UTF-8 content - Res.Text := V.VPointer; - Res.Len := StrLen(V.VPointer); - result := Res.Len; - exit; - end; - vtChar: begin - Res.Temp[0] := V.VChar; // V may be on transient stack (alf: FPC) - Res.Text := @Res.Temp; - Res.Len := 1; - result := 1; - exit; - end; - vtPWideChar: - RawUnicodeToUtf8(V.VPWideChar,StrLenW(V.VPWideChar),RawUTF8(Res.TempRawUTF8)); - vtWideChar: - RawUnicodeToUtf8(@V.VWideChar,1,RawUTF8(Res.TempRawUTF8)); - vtBoolean: begin - if V.VBoolean then // normalize - Res.Text := pointer(SmallUInt32UTF8[1]) else - Res.Text := pointer(SmallUInt32UTF8[0]); - Res.Len := 1; - result := 1; - exit; - end; - vtInteger: begin - result := V.VInteger; - if cardinal(result)<=high(SmallUInt32UTF8) then begin -smlu32: Res.Text := pointer(SmallUInt32UTF8[result]); - Res.Len := PStrLen(Res.Text-_STRLEN)^; - end else begin - Res.Text := PUTF8Char(StrInt32(@Res.Temp[23],result)); - Res.Len := @Res.Temp[23]-Res.Text; - end; - result := Res.Len; - exit; - end; - vtInt64: - if (PCardinalArray(V.VInt64)^[0]<=high(SmallUInt32UTF8)) and - (PCardinalArray(V.VInt64)^[1]=0) then begin - result := V.VInt64^; - goto smlu32; - end else begin - Res.Text := PUTF8Char(StrInt64(@Res.Temp[23],V.VInt64^)); - Res.Len := @Res.Temp[23]-Res.Text; - result := Res.Len; - exit; - end; - {$ifdef FPC} - vtQWord: - if V.VQWord^<=high(SmallUInt32UTF8) then begin - result := V.VQWord^; - goto smlu32; - end else begin - Res.Text := PUTF8Char(StrUInt64(@Res.Temp[23],V.VQWord^)); - Res.Len := @Res.Temp[23]-Res.Text; - result := Res.Len; - exit; - end; - {$endif} - vtCurrency: begin - Res.Text := @Res.Temp; - Res.Len := Curr64ToPChar(V.VInt64^,Res.Temp); - result := Res.Len; - exit; - end; - vtExtended: - DoubleToStr(V.VExtended^,RawUTF8(Res.TempRawUTF8)); - vtPointer,vtInterface: begin - Res.Text := @Res.Temp; - Res.Len := SizeOf(pointer)*2; - BinToHexDisplayLower(@V.VPointer,@Res.Temp,SizeOf(Pointer)); - result := SizeOf(pointer)*2; - exit; - end; - vtClass: begin - if V.VClass<>nil then begin - Res.Text := PPUTF8Char(PtrInt(PtrUInt(V.VClass))+vmtClassName)^+1; - Res.Len := ord(Res.Text[-1]); - end else - Res.Len := 0; - result := Res.Len; - exit; - end; - vtObject: begin - if V.VObject<>nil then begin - Res.Text := PPUTF8Char(PPtrInt(V.VObject)^+vmtClassName)^+1; - Res.Len := ord(Res.Text[-1]); - end else - Res.Len := 0; - result := Res.Len; - exit; - end; - {$ifndef NOVARIANTS} - vtVariant: - if VariantToInt64(V.VVariant^,v64) then - if (PCardinalArray(@v64)^[0]<=high(SmallUInt32UTF8)) and - (PCardinalArray(@v64)^[1]=0) then begin - result := v64; - goto smlu32; - end else begin - Res.Text := PUTF8Char(StrInt64(@Res.Temp[23],v64)); - Res.Len := @Res.Temp[23]-Res.Text; - result := Res.Len; - exit; - end else - VariantToUTF8(V.VVariant^,RawUTF8(Res.TempRawUTF8),isString); - {$endif} - else begin - Res.Len := 0; - result := 0; - exit; - end; - end; - Res.Text := Res.TempRawUTF8; - Res.Len := length(RawUTF8(Res.TempRawUTF8)); - result := Res.Len; -end; - -procedure VarRecToUTF8(const V: TVarRec; var result: RawUTF8; wasString: PBoolean); -var isString: boolean; -begin - isString := not (V.VType in [ - vtBoolean,vtInteger,vtInt64{$ifdef FPC},vtQWord{$endif},vtCurrency,vtExtended]); - with V do - case V.VType of - vtString: - FastSetString(result,@VString^[1],ord(VString^[0])); - vtAnsiString: - result := RawUTF8(VAnsiString); // expect UTF-8 content - {$ifdef HASVARUSTRING} - vtUnicodeString: - RawUnicodeToUtf8(VUnicodeString,length(UnicodeString(VUnicodeString)),result); - {$endif} - vtWideString: - RawUnicodeToUtf8(VWideString,length(WideString(VWideString)),result); - vtPChar: - FastSetString(result,VPChar,StrLen(VPChar)); - vtChar: - FastSetString(result,PAnsiChar(@VChar),1); - vtPWideChar: - RawUnicodeToUtf8(VPWideChar,StrLenW(VPWideChar),result); - vtWideChar: - RawUnicodeToUtf8(@VWideChar,1,result); - vtBoolean: - if VBoolean then // normalize - result := SmallUInt32UTF8[1] else - result := SmallUInt32UTF8[0]; - vtInteger: - Int32ToUtf8(VInteger,result); - vtInt64: - Int64ToUtf8(VInt64^,result); - {$ifdef FPC} - vtQWord: - UInt64ToUtf8(VQWord^,result); - {$endif} - vtCurrency: - Curr64ToStr(VInt64^,result); - vtExtended: - DoubleToStr(VExtended^,result); - vtPointer: - PointerToHex(VPointer,result); - vtClass: - if VClass<>nil then - ToText(VClass,result) else - result := ''; - vtObject: - if VObject<>nil then - ToText(PClass(VObject)^,result) else - result := ''; - vtInterface: - {$ifdef HASINTERFACEASTOBJECT} - if VInterface<>nil then - ToText((IInterface(VInterface) as TObject).ClassType,result) else - result := ''; - {$else} - PointerToHex(VInterface,result); - {$endif} - {$ifndef NOVARIANTS} - vtVariant: - VariantToUTF8(VVariant^,result,isString); - {$endif} - else begin - isString := false; - result := ''; - end; - end; - if wasString<>nil then - wasString^ := isString; -end; - -function VarRecToUTF8IsString(const V: TVarRec; var value: RawUTF8): boolean; -begin - VarRecToUTF8(V,value,@result); -end; - -procedure VarRecToInlineValue(const V: TVarRec; var result: RawUTF8); -var wasString: boolean; - tmp: RawUTF8; -begin - VarRecToUTF8(V,tmp,@wasString); - if wasString then - QuotedStr(tmp,'"',result) else - result := tmp; -end; - -{$ifdef UNICODE} -function StringToRawUnicode(const S: string): RawUnicode; -begin - SetString(result,PAnsiChar(pointer(S)),length(S)*2+1); // +1 for last wide #0 -end; -function StringToSynUnicode(const S: string): SynUnicode; -begin - result := S; -end; -procedure StringToSynUnicode(const S: string; var result: SynUnicode); overload; -begin - result := S; -end; -function StringToRawUnicode(P: PChar; L: integer): RawUnicode; -begin - SetString(result,PAnsiChar(P),L*2+1); // +1 for last wide #0 -end; -function RawUnicodeToString(P: PWideChar; L: integer): string; -begin - SetString(result,P,L); -end; -procedure RawUnicodeToString(P: PWideChar; L: integer; var result: string); -begin - SetString(result,P,L); -end; -function RawUnicodeToString(const U: RawUnicode): string; -begin // uses StrLenW() and not length(U) to handle case when was used as buffer - SetString(result,PWideChar(pointer(U)),StrLenW(Pointer(U))); -end; -function SynUnicodeToString(const U: SynUnicode): string; -begin - result := U; -end; -function UTF8DecodeToString(P: PUTF8Char; L: integer): string; -begin - UTF8DecodeToUnicodeString(P,L,result); -end; -procedure UTF8DecodeToString(P: PUTF8Char; L: integer; var result: string); -begin - UTF8DecodeToUnicodeString(P,L,result); -end; -function UTF8ToString(const Text: RawUTF8): string; -begin - UTF8DecodeToUnicodeString(pointer(Text),length(Text),result); -end; -{$else} -function StringToRawUnicode(const S: string): RawUnicode; -begin - result := CurrentAnsiConvert.AnsiToRawUnicode(S); -end; -function StringToSynUnicode(const S: string): SynUnicode; -begin - result := CurrentAnsiConvert.AnsiToUnicodeString(pointer(S),length(S)); -end; -procedure StringToSynUnicode(const S: string; var result: SynUnicode); overload; -begin - result := CurrentAnsiConvert.AnsiToUnicodeString(pointer(S),length(S)); -end; -function StringToRawUnicode(P: PChar; L: integer): RawUnicode; -begin - result := CurrentAnsiConvert.AnsiToRawUnicode(P,L); -end; -function RawUnicodeToString(P: PWideChar; L: integer): string; -begin - result := CurrentAnsiConvert.UnicodeBufferToAnsi(P,L); -end; -procedure RawUnicodeToString(P: PWideChar; L: integer; var result: string); -begin - result := CurrentAnsiConvert.UnicodeBufferToAnsi(P,L); -end; -function RawUnicodeToString(const U: RawUnicode): string; -begin // uses StrLenW() and not length(U) to handle case when was used as buffer - result := CurrentAnsiConvert.UnicodeBufferToAnsi(Pointer(U),StrLenW(Pointer(U))); -end; -function SynUnicodeToString(const U: SynUnicode): string; -begin - result := CurrentAnsiConvert.UnicodeBufferToAnsi(Pointer(U),length(U)); -end; -function UTF8DecodeToString(P: PUTF8Char; L: integer): string; -begin - CurrentAnsiConvert.UTF8BufferToAnsi(P,L,RawByteString(result)); -end; -procedure UTF8DecodeToString(P: PUTF8Char; L: integer; var result: string); -begin - CurrentAnsiConvert.UTF8BufferToAnsi(P,L,RawByteString(result)); -end; -function UTF8ToString(const Text: RawUTF8): string; -begin - CurrentAnsiConvert.UTF8BufferToAnsi(pointer(Text),length(Text),RawByteString(result)); -end; -{$endif UNICODE} - -procedure UTF8ToWideString(const Text: RawUTF8; var result: WideString); -begin - UTF8ToWideString(pointer(Text),Length(Text),result); -end; - -function UTF8ToWideString(const Text: RawUTF8): WideString; -begin - {$ifdef FPC} - Finalize(result); - {$endif FPC} - UTF8ToWideString(pointer(Text),Length(Text),result); -end; - -procedure UTF8ToWideString(Text: PUTF8Char; Len: PtrInt; var result: WideString); -var tmp: TSynTempBuffer; -begin - if (Text=nil) or (Len=0) then - result := '' else begin - tmp.Init(Len*3); // maximum posible unicode size (if all <#128) - SetString(result,PWideChar(tmp.buf),UTF8ToWideChar(tmp.buf,Text,Len) shr 1); - tmp.Done; - end; -end; - -function WideStringToUTF8(const aText: WideString): RawUTF8; -begin - RawUnicodeToUtf8(pointer(aText),length(aText),result); -end; - -function UTF8ToSynUnicode(const Text: RawUTF8): SynUnicode; -begin - UTF8ToSynUnicode(pointer(Text),length(Text),result); -end; - -procedure UTF8ToSynUnicode(const Text: RawUTF8; var result: SynUnicode); -begin - UTF8ToSynUnicode(pointer(Text),length(Text),result); -end; - -procedure UTF8ToSynUnicode(Text: PUTF8Char; Len: PtrInt; var result: SynUnicode); -var tmp: TSynTempBuffer; -begin - if (Text=nil) or (Len=0) then - result := '' else begin - tmp.Init(Len*3); // maximum posible unicode size (if all <#128) - SetString(result,PWideChar(tmp.buf),UTF8ToWideChar(tmp.buf,Text,Len) shr 1); - tmp.Done; - end; -end; - - - -{ TRawUTF8InterningSlot } - -procedure TRawUTF8InterningSlot.Init; -begin - Safe.Init; - {$ifndef NOVARIANTS} - Safe.LockedInt64[0] := 0; - {$endif} - Values.Init(TypeInfo(TRawUTF8DynArray),Value,HashAnsiString, - SortDynArrayAnsiString,InterningHasher,@Safe.Padding[0].VInteger,false); -end; - -procedure TRawUTF8InterningSlot.Done; -begin - Safe.Done; -end; - -function TRawUTF8InterningSlot.Count: integer; -begin - {$ifdef NOVARIANTS} - result := Safe.Padding[0].VInteger; - {$else} - result := Safe.LockedInt64[0]; - {$endif} -end; - -procedure TRawUTF8InterningSlot.Unique(var aResult: RawUTF8; - const aText: RawUTF8; aTextHash: cardinal); -var i: PtrInt; - added: boolean; -begin - EnterCriticalSection(Safe.fSection); - try - i := Values.FindHashedForAdding(aText,added,aTextHash); - if added then begin - Value[i] := aText; // copy new value to the pool - aResult := aText; - end else - aResult := Value[i]; // return unified string instance - finally - LeaveCriticalSection(Safe.fSection); - end; -end; - -procedure TRawUTF8InterningSlot.UniqueText(var aText: RawUTF8; aTextHash: cardinal); -var i: PtrInt; - added: boolean; -begin - EnterCriticalSection(Safe.fSection); - try - i := Values.FindHashedForAdding(aText,added,aTextHash); - if added then - Value[i] := aText else // copy new value to the pool - aText := Value[i]; // return unified string instance - finally - LeaveCriticalSection(Safe.fSection); - end; -end; - -procedure TRawUTF8InterningSlot.Clear; -begin - EnterCriticalSection(Safe.fSection); - try - Values.SetCount(0); // Values.Clear - Values.Hasher.Clear; - finally - LeaveCriticalSection(Safe.fSection); - end; -end; - -function TRawUTF8InterningSlot.Clean(aMaxRefCount: integer): integer; -var i: integer; - s,d: PPtrUInt; // points to RawUTF8 values (bypass COW assignments) -begin - result := 0; - EnterCriticalSection(Safe.fSection); - try - if Safe.Padding[0].VInteger=0 then - exit; - s := pointer(Value); - d := s; - for i := 1 to Safe.Padding[0].VInteger do begin - if PStrCnt(PAnsiChar(s^)-_STRREFCNT)^<=aMaxRefCount then begin - {$ifdef FPC} - Finalize(PRawUTF8(s)^); - {$else} - PRawUTF8(s)^ := ''; - {$endif FPC} - inc(result); - end else begin - if s<>d then begin - d^ := s^; - s^ := 0; // avoid GPF - end; - inc(d); - end; - inc(s); - end; - if result>0 then begin - Values.SetCount((PtrUInt(d)-PtrUInt(Value))div SizeOf(d^)); - Values.ReHash; - end; - finally - LeaveCriticalSection(Safe.fSection); - end; -end; - - -{ TRawUTF8Interning } - -constructor TRawUTF8Interning.Create(aHashTables: integer); -var p: integer; - i: PtrInt; -begin - for p := 0 to 9 do - if aHashTables=1 shl p then begin - SetLength(fPool,aHashTables); - fPoolLast := aHashTables-1; - for i := 0 to fPoolLast do - fPool[i].Init; - exit; - end; - raise ESynException.CreateUTF8('%.Create(%) not allowed: should be a power of 2', - [self,aHashTables]); -end; - -destructor TRawUTF8Interning.Destroy; -var i: PtrInt; -begin - for i := 0 to fPoolLast do - fPool[i].Done; - inherited Destroy; -end; - -procedure TRawUTF8Interning.Clear; -var i: PtrInt; -begin - if self<>nil then - for i := 0 to fPoolLast do - fPool[i].Clear; -end; - -function TRawUTF8Interning.Clean(aMaxRefCount: integer): integer; -var i: PtrInt; -begin - result := 0; - if self<>nil then - for i := 0 to fPoolLast do - inc(result,fPool[i].Clean(aMaxRefCount)); -end; - -function TRawUTF8Interning.Count: integer; -var i: PtrInt; -begin - result := 0; - if self<>nil then - for i := 0 to fPoolLast do - inc(result,fPool[i].Count); -end; - -procedure TRawUTF8Interning.Unique(var aResult: RawUTF8; const aText: RawUTF8); -var hash: cardinal; -begin - if aText='' then - aResult := '' else - if self=nil then - aResult := aText else begin - hash := InterningHasher(0,pointer(aText),length(aText)); // = fPool[].Values.HashElement - fPool[hash and fPoolLast].Unique(aResult,aText,hash); - end; -end; - -procedure TRawUTF8Interning.UniqueText(var aText: RawUTF8); -var hash: cardinal; -begin - if (self<>nil) and (aText<>'') then begin - hash := InterningHasher(0,pointer(aText),length(aText)); // = fPool[].Values.HashElement - fPool[hash and fPoolLast].UniqueText(aText,hash); - end; -end; - -function TRawUTF8Interning.Unique(const aText: RawUTF8): RawUTF8; -var hash: cardinal; -begin - if aText='' then - result := '' else - if self=nil then - result := aText else begin - hash := InterningHasher(0,pointer(aText),length(aText)); // = fPool[].Values.HashElement - fPool[hash and fPoolLast].Unique(result,aText,hash); - end; -end; - -function TRawUTF8Interning.Unique(aText: PUTF8Char; aTextLen: PtrInt): RawUTF8; -begin - FastSetString(result,aText,aTextLen); - UniqueText(result); -end; - -procedure TRawUTF8Interning.Unique(var aResult: RawUTF8; aText: PUTF8Char; - aTextLen: PtrInt); -begin - FastSetString(aResult,aText,aTextLen); - UniqueText(aResult); -end; - -procedure ClearVariantForString(var Value: variant); {$ifdef HASINLINE} inline; {$endif} -var v: TVarData absolute Value; -begin - if cardinal(v.VType) = varString then - Finalize(RawByteString(v.VString)) - else - begin - VarClear(Value); - PInteger(@v.VType)^ := varString; - v.VString := nil; // to avoid GPF when assign a RawByteString - end; -end; - -{$ifndef NOVARIANTS} - -procedure TRawUTF8Interning.UniqueVariant(var aResult: variant; const aText: RawUTF8); -begin - ClearVariantForString(aResult); - Unique(RawUTF8(TVarData(aResult).VAny),aText); -end; - -procedure TRawUTF8Interning.UniqueVariantString(var aResult: variant; const aText: string); -var tmp: RawUTF8; -begin - StringToUTF8(aText,tmp); - UniqueVariant(aResult,tmp); -end; - -procedure TRawUTF8Interning.UniqueVariant(var aResult: variant; - aText: PUTF8Char; aTextLen: PtrInt; aAllowVarDouble: boolean); -var tmp: RawUTF8; -begin - if not GetNumericVariantFromJSON(aText,TVarData(aResult),aAllowVarDouble) then begin - FastSetString(tmp,aText,aTextLen); - UniqueVariant(aResult,tmp); - end; -end; - -procedure TRawUTF8Interning.UniqueVariant(var aResult: variant); -var vt: cardinal; -begin - vt := TVarData(aResult).VType; - with TVarData(aResult) do - if vt=varString then - UniqueText(RawUTF8(VString)) else - if vt=varVariant or varByRef then - UniqueVariant(PVariant(VPointer)^) else - if vt=varString or varByRef then - UniqueText(PRawUTF8(VPointer)^); -end; - -{$endif NOVARIANTS} - -const - // see https://en.wikipedia.org/wiki/Baudot_code - Baudot2Char: array[0..63] of AnsiChar = - #0'e'#10'a siu'#13'drjnfcktzlwhypqobg'#254'mxv'#255+ - #0'3'#10'- ''87'#13#0'4'#0',!:(5+)2$6019?@'#254'./;'#255; -var - Char2Baudot: array[AnsiChar] of byte; - -function AsciiToBaudot(const Text: RawUTF8): RawByteString; -begin - result := AsciiToBaudot(pointer(Text),length(Text)); -end; - -function AsciiToBaudot(P: PAnsiChar; len: PtrInt): RawByteString; -var i: PtrInt; - c,d,bits: integer; - shift: boolean; - dest: PByte; - tmp: TSynTempBuffer; -begin - result := ''; - if (P=nil) or (len=0) then - exit; - shift := false; - dest := tmp.Init((len*10)shr 3); - d := 0; - bits := 0; - for i := 0 to len-1 do begin - c := Char2Baudot[P[i]]; - if c>32 then begin - if not shift then begin - d := (d shl 5) or 27; - inc(bits,5); - shift := true; - end; - d := (d shl 5) or (c-32); - inc(bits,5); - end else - if c>0 then begin - if shift and (P[i]>=' ') then begin - d := (d shl 5) or 31; - inc(bits,5); - shift := false; - end; - d := (d shl 5) or c; - inc(bits,5); - end; - while bits>=8 do begin - dec(bits,8); - dest^ := d shr bits; - inc(dest); - end; - end; - if bits>0 then begin - dest^ := d shl (8-bits); - inc(dest); - end; - SetString(result,PAnsiChar(tmp.buf),PAnsiChar(dest)-PAnsiChar(tmp.buf)); - tmp.Done; -end; - -function BaudotToAscii(const Baudot: RawByteString): RawUTF8; -begin - result := BaudotToAscii(pointer(Baudot),length(Baudot)); -end; - -function BaudotToAscii(Baudot: PByteArray; len: PtrInt): RawUTF8; -var i: PtrInt; - c,b,bits,shift: integer; - tmp: TSynTempBuffer; - dest: PAnsiChar; -begin - result := ''; - if (Baudot=nil) or (len<=0) then - exit; - dest := tmp.Init((len shl 3)div 5); - try - shift := 0; - b := 0; - bits := 0; - for i := 0 to len-1 do begin - b := (b shl 8) or Baudot[i]; - inc(bits,8); - while bits>=5 do begin - dec(bits,5); - c := (b shr bits) and 31; - case c of - 27: if shift<>0 then - exit else - shift := 32; - 31: if shift<>0 then - shift := 0 else - exit; - else begin - c := ord(Baudot2Char[c+shift]); - if c=0 then - if Baudot[i+1]=0 then // allow triming of last 5 bits - break else - exit; - dest^ := AnsiChar(c); - inc(dest); - end; - end; - end; - end; - finally - tmp.Done(dest,result); - end; -end; - -function IsVoid(const text: RawUTF8): boolean; -var i: PtrInt; -begin - result := false; - for i := 1 to length(text) do - if text[i]>' ' then - exit; - result := true; -end; - -function TrimControlChars(const text: RawUTF8; const controls: TSynAnsicharSet): RawUTF8; -var len,i,j,n: PtrInt; - P: PAnsiChar; -begin - len := length(text); - for i := 1 to len do - if text[i] in controls then begin - n := i-1; - FastSetString(result,nil,len); - P := pointer(result); - if n>0 then - MoveFast(pointer(text)^,P^,n); - for j := i+1 to len do - if not(text[j] in controls) then begin - P[n] := text[j]; - inc(n); - end; - SetLength(result,n); // truncate - exit; - end; - result := text; // no control char found -end; - -procedure ExchgPointer(n1,n2: PPointer); {$ifdef HASINLINE}inline;{$endif} -var n: pointer; -begin - n := n2^; - n2^ := n1^; - n1^ := n; -end; - -procedure ExchgVariant(v1,v2: PPtrIntArray); {$ifdef CPU64}inline;{$endif} -var c: PtrInt; // 32-bit:16bytes=4ptr 64-bit:24bytes=3ptr -begin - c := v2[0]; - v2[0] := v1[0]; - v1[0] := c; - c := v2[1]; - v2[1] := v1[1]; - v1[1] := c; - c := v2[2]; - v2[2] := v1[2]; - v1[2] := c; - {$ifdef CPU32} - c := v2[3]; - v2[3] := v1[3]; - v1[3] := c; - {$endif} -end; - -{$ifdef CPU64} -procedure Exchg16(P1,P2: PPtrIntArray); inline; -var c: PtrInt; -begin - c := P1[0]; - P1[0] := P2[0]; - P2[0] := c; - c := P1[1]; - P1[1] := P2[1]; - P2[1] := c; -end; -{$endif} - -procedure Exchg(P1,P2: PAnsiChar; count: PtrInt); - {$ifdef PUREPASCAL} {$ifdef HASINLINE}inline;{$endif} -var i, c: PtrInt; - u: AnsiChar; -begin - for i := 1 to count shr POINTERSHR do begin - c := PPtrInt(P1)^; - PPtrInt(P1)^ := PPtrInt(P2)^; - PPtrInt(P2)^ := c; - inc(P1,SizeOf(c)); - inc(P2,SizeOf(c)); - end; - for i := 0 to (count and POINTERAND)-1 do begin - u := P1[i]; - P1[i] := P2[i]; - P2[i] := u; - end; -end; -{$else} {$ifdef FPC} nostackframe; assembler; {$endif} -asm // eax=P1, edx=P2, ecx=count - push ebx - push esi - push ecx - shr ecx, 2 - jz @2 -@4: mov ebx, [eax] - mov esi, [edx] - mov [eax], esi - mov [edx], ebx - add eax, 4 - add edx, 4 - dec ecx - jnz @4 -@2: pop ecx - and ecx, 3 - jz @0 -@1: mov bl, [eax] - mov bh, [edx] - mov [eax], bh - mov [edx], bl - inc eax - inc edx - dec ecx - jnz @1 -@0: pop esi - pop ebx -end; -{$endif} - -function GetAllBits(Bits, BitCount: Cardinal): boolean; -begin - if BitCount in [low(ALLBITS_CARDINAL)..high(ALLBITS_CARDINAL)] then begin - BitCount := ALLBITS_CARDINAL[BitCount]; - result := (Bits and BitCount)=BitCount; - end else - result := false; -end; - -// naive code gives the best performance - bts [Bits] has an overhead -function GetBit(const Bits; aIndex: PtrInt): boolean; -begin - result := PByteArray(@Bits)[aIndex shr 3] and (1 shl (aIndex and 7)) <> 0; -end; - -procedure SetBit(var Bits; aIndex: PtrInt); -begin - TByteArray(Bits)[aIndex shr 3] := TByteArray(Bits)[aIndex shr 3] - or (1 shl (aIndex and 7)); -end; - -procedure UnSetBit(var Bits; aIndex: PtrInt); -begin - PByteArray(@Bits)[aIndex shr 3] := PByteArray(@Bits)[aIndex shr 3] - and not (1 shl (aIndex and 7)); -end; - -function GetBitPtr(Bits: pointer; aIndex: PtrInt): boolean; -begin - result := PByteArray(Bits)[aIndex shr 3] and (1 shl (aIndex and 7)) <> 0; -end; - -procedure SetBitPtr(Bits: pointer; aIndex: PtrInt); -begin - PByteArray(Bits)[aIndex shr 3] := PByteArray(Bits)[aIndex shr 3] - or (1 shl (aIndex and 7)); -end; - -procedure UnSetBitPtr(Bits: pointer; aIndex: PtrInt); -begin - PByteArray(Bits)[aIndex shr 3] := PByteArray(Bits)[aIndex shr 3] - and not (1 shl (aIndex and 7)); -end; - -function GetBit64(const Bits: Int64; aIndex: PtrInt): boolean; -begin - result := aIndex in TBits64(Bits); -end; - -procedure SetBit64(var Bits: Int64; aIndex: PtrInt); -begin - include(PBits64(@Bits)^,aIndex); -end; - -procedure UnSetBit64(var Bits: Int64; aIndex: PtrInt); -begin - exclude(PBits64(@Bits)^,aIndex); -end; - -function GetBitsCount(const Bits; Count: PtrInt): PtrInt; -var P: PPtrInt; - popcnt: function(value: PtrInt): PtrInt; // fast redirection within loop -begin - P := @Bits; - result := 0; - popcnt := @GetBitsCountPtrInt; - if Count>=POINTERBITS then - repeat - dec(Count,POINTERBITS); - inc(result,popcnt(P^)); // use SSE4.2 if available - inc(P); - until Count0 then - inc(result,popcnt(P^ and ((PtrInt(1) shl Count)-1))); -end; - -{ FPC x86_64 Linux: - 1000000 pas in 4.67ms i.e. 213,949,507/s, aver. 0us, 1.5 GB/s - 1000000 asm in 4.14ms i.e. 241,196,333/s, aver. 0us, 1.8 GB/s - 1000000 sse4.2 in 2.36ms i.e. 423,011,844/s, aver. 0us, 3.1 GB/s - 1000000 FPC in 21.32ms i.e. 46,886,721/s, aver. 0us, 357.7 MB/s - FPC i386 Windows: - 1000000 pas in 3.40ms i.e. 293,944,738/s, aver. 0us, 1 GB/s - 1000000 asm in 3.18ms i.e. 313,971,742/s, aver. 0us, 1.1 GB/s - 1000000 sse4.2 in 2.74ms i.e. 364,166,059/s, aver. 0us, 1.3 GB/s - 1000000 FPC in 8.18ms i.e. 122,204,570/s, aver. 0us, 466.1 MB/s - notes: - 1. AVX2 faster than popcnt on big buffers - https://arxiv.org/pdf/1611.07612.pdf - 2. our pascal/asm versions below use the efficient Wilkes-Wheeler-Gill algorithm - whereas FPC RTL's popcnt() is much slower } - -{$ifdef CPUX86} -function GetBitsCountSSE42(value: PtrInt): PtrInt; {$ifdef FPC} nostackframe; assembler; {$endif} -asm - {$ifdef FPC_X86ASM} - popcnt eax, eax - {$else} // oldest Delphi don't support this opcode - db $f3,$0f,$B8,$c0 - {$endif} -end; -function GetBitsCountPas(value: PtrInt): PtrInt; {$ifdef FPC} nostackframe; assembler; {$endif} -asm // branchless Wilkes-Wheeler-Gill i386 asm implementation - mov edx, eax - shr eax, 1 - and eax, $55555555 - sub edx, eax - mov eax, edx - shr edx, 2 - and eax, $33333333 - and edx, $33333333 - add eax, edx - mov edx, eax - shr eax, 4 - add eax, edx - and eax, $0f0f0f0f - mov edx, eax - shr edx, 8 - add eax, edx - mov edx, eax - shr edx, 16 - add eax, edx - and eax, $3f -end; -{$else} -{$ifdef CPUX64} -function GetBitsCountSSE42(value: PtrInt): PtrInt; -{$ifdef FPC} assembler; nostackframe; -asm - popcnt rax, value -{$else} // oldest Delphi don't support this opcode -asm .noframe - {$ifdef win64} db $f3,$48,$0f,$B8,$c1 - {$else} db $f3,$48,$0f,$B8,$c7 {$endif} -{$endif FPC} -end; -function GetBitsCountPas(value: PtrInt): PtrInt; -{$ifdef FPC} assembler; nostackframe; asm {$else} asm .noframe {$endif} - mov rax, value - mov rdx, value - shr rax, 1 - mov rcx, $5555555555555555 - mov r8, $3333333333333333 - mov r10, $0f0f0f0f0f0f0f0f - mov r11, $0101010101010101 - and rax, rcx - sub rdx, rax - mov rax, rdx - shr rdx, 2 - and rax, r8 - and rdx, r8 - add rax, rdx - mov rdx, rax - shr rax, 4 - add rax, rdx - and rax, r10 - imul rax, r11 - shr rax, 56 -end; -{$else} -function GetBitsCountPas(value: PtrInt): PtrInt; -begin // generic branchless Wilkes-Wheeler-Gill pure pascal version - result := value; - {$ifdef CPU64} - result := result-((result shr 1) and $5555555555555555); - result := (result and $3333333333333333)+((result shr 2) and $3333333333333333); - result := (result+(result shr 4)) and $0f0f0f0f0f0f0f0f; - inc(result,result shr 8); // avoid slow multiplication on ARM - inc(result,result shr 16); - inc(result,result shr 32); - result := result and $7f; - {$else} - result := result-((result shr 1) and $55555555); - result := (result and $33333333)+((result shr 2) and $33333333); - result := (result+(result shr 4)) and $0f0f0f0f; - inc(result,result shr 8); - inc(result,result shr 16); - result := result and $3f; - {$endif CPU64} -end; -{$endif CPUX64} -{$endif CPUX86} - -type -{$ifdef FPC} - {$packrecords c} // as expected by FPC's RTTI record definitions - TStrRec = record // see TAnsiRec/TUnicodeRec in astrings/ustrings.inc - {$ifdef ISFPC27} - codePage: TSystemCodePage; // =Word - elemSize: Word; - {$ifndef STRCNT32} - {$ifdef CPU64} - _PaddingToQWord: DWord; - {$endif} {$endif} {$endif} - refCnt: TStrCnt; // =SizeInt on older FPC, =longint since FPC 3.4 - length: SizeInt; - end; -{$else FPC} - /// map the Delphi/FPC dynamic array header (stored before each instance) - TDynArrayRec = packed record - {$ifdef CPUX64} - /// padding bytes for 16 byte alignment of the header - _Padding: LongInt; - {$endif} - /// dynamic array reference count (basic garbage memory mechanism) - refCnt: TDACnt; - /// length in element count - // - size in bytes = length*ElemSize - length: PtrInt; - end; - PDynArrayRec = ^TDynArrayRec; - - /// map the Delphi/FPC string header (stored before each instance) - TStrRec = packed record - {$ifdef UNICODE} - {$ifdef CPU64} - /// padding bytes for 16 bytes alignment of the header - _Padding: LongInt; - {$endif} - /// the associated code page used for this string - // - exist only since Delphi/FPC 2009 - // - 0 or 65535 for RawByteString - // - 1200=CP_UTF16 for UnicodeString - // - 65001=CP_UTF8 for RawUTF8 - // - the current code page for AnsiString - codePage: Word; - /// either 1 (for AnsiString) or 2 (for UnicodeString) - // - exist only since Delphi/FPC 2009 - elemSize: Word; - {$endif UNICODE} - /// COW string reference count (basic garbage memory mechanism) - refCnt: TStrCnt; - /// length in characters - // - size in bytes = length*elemSize - length: Longint; - end; -{$endif FPC} - PStrRec = ^TStrRec; - - PTypeInfo = ^TTypeInfo; - {$ifdef HASDIRECTTYPEINFO} // for old FPC (<=3.0) - PTypeInfoStored = PTypeInfo; - {$else} // e.g. for Delphi and newer FPC - PTypeInfoStored = ^PTypeInfo; // = TypeInfoPtr macro in FPC typinfo.pp - {$endif} - - // note: FPC TRecInitData is taken from typinfo.pp via SynFPCTypInfo - // since this information is evolving/breaking a lot in the current FPC trunk - - /// map the Delphi/FPC record field RTTI - TFieldInfo = - {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} - packed - {$endif FPC_REQUIRES_PROPER_ALIGNMENT} - record - TypeInfo: PTypeInfoStored; - {$ifdef FPC} - Offset: sizeint; - {$else} - Offset: PtrUInt; - {$endif FPC} - end; - PFieldInfo = ^TFieldInfo; - {$ifdef ISDELPHI2010_OR_FPC_NEWRTTI} - /// map the Delphi record field enhanced RTTI (available since Delphi 2010) - TEnhancedFieldInfo = - {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} - packed - {$endif FPC_REQUIRES_PROPER_ALIGNMENT} - record - TypeInfo: PTypeInfoStored; - {$ifdef FPC} - Offset: sizeint; // match TInitManagedField/TManagedField in FPC typinfo.pp - {$else} - Offset: PtrUInt; - {$endif FPC} - {$ifdef ISDELPHI2010} - Flags: Byte; - NameLen: byte; // = Name[0] = length(Name) - {$ENDIF} - end; - PEnhancedFieldInfo = ^TEnhancedFieldInfo; - {$endif} - - TTypeInfo = - {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} - packed - {$endif FPC_REQUIRES_PROPER_ALIGNMENT} - record - kind: TTypeKind; - NameLen: byte; - case TTypeKind of - tkUnknown: ( - NameFirst: AnsiChar; - ); - tkDynArray: ( - {$ifdef FPC} - elSize: SizeUInt; // and $7FFFFFFF = item/record size - elType2: PTypeInfoStored; - varType: LongInt; - elType: PTypeInfoStored; - //DynUnitName: ShortStringBase; - {$else} - // storage byte count for this field - elSize: Longint; - // nil for unmanaged field - elType: PTypeInfoStored; - // OleAuto compatible type - varType: Integer; - // also unmanaged field - elType2: PTypeInfoStored; - {$endif FPC} - ); - tkArray: ( - {$ifdef FPC} - // warning: in VER2_6, this is the element size, not full array size - arraySize: SizeInt; - // product of lengths of all dimensions - elCount: SizeInt; - {$else} - arraySize: Integer; - // product of lengths of all dimensions - elCount: Integer; - {$endif FPC} - arrayType: PTypeInfoStored; - dimCount: Byte; - dims: array[0..255 {DimCount-1}] of PTypeInfoStored; - ); - {$ifdef FPC} - tkRecord, tkObject:( - {$ifdef FPC_NEWRTTI} - RecInitInfo: Pointer; // call GetManagedFields() to use FPC's TypInfo.pp - recSize: longint; - {$else} - ManagedCount: longint; - ManagedFields: array[0..0] of TFieldInfo; - // note: FPC for 3.0.x and previous generates RTTI for unmanaged fields (as in TEnhancedFieldInfo) - {$endif FPC_NEWRTTI} - {$else} - tkRecord: ( - recSize: cardinal; - ManagedCount: integer; - ManagedFields: array[0..0] of TFieldInfo; - {$ifdef ISDELPHI2010} // enhanced RTTI containing info about all fields - NumOps: Byte; - //RecOps: array[0..0] of Pointer; - AllCount: Integer; // !!!! may need $RTTI EXPLICIT FIELDS([vcPublic]) - AllFields: array[0..0] of TEnhancedFieldInfo; - {$endif ISDELPHI2010} - {$endif FPC} - ); - tkEnumeration: ( - EnumType: TOrdType; - {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} - EnumDummy: DWORD; // needed on ARM for correct alignment - {$endif} - {$ifdef FPC_ENUMHASINNER} inner: - {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} packed {$endif} record - {$endif FPC_ENUMHASINNER} - MinValue: longint; - MaxValue: longint; - EnumBaseType: PTypeInfoStored; // BaseTypeRef in FPC TypInfo.pp - {$ifdef FPC_ENUMHASINNER} end; {$endif FPC_ENUMHASINNER} - NameList: string[255]; - ); - tkInteger: ( - IntegerType: TOrdType; - ); - tkInt64: ( - MinInt64Value, MaxInt64Value: Int64; - ); - tkSet: ( - SetType: TOrdType; - {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} - SetDummy: DWORD; // needed on ARM for correct alignment - {$endif} - {$ifdef FPC} - {$ifndef VER3_0} - SetSize: SizeInt; - {$endif VER3_0} - {$endif FPC} - SetBaseType: PTypeInfoStored; // CompTypeRef in FPC TypInfo.pp - ); - tkFloat: ( - FloatType: TFloatType; - ); - tkClass: ( - ClassType: TClass; - ParentInfo: PTypeInfoStored; // ParentInfoRef in FPC TypInfo.pp - PropCount: SmallInt; - UnitNameLen: byte; - ); - end; - - {$ifdef FPC} - {$push} - {$PACKRECORDS 1} - {$endif} - TPropInfo = packed record - PropType: PTypeInfoStored; - GetProc: PtrInt; - SetProc: PtrInt; - StoredProc: PtrInt; - Index: Integer; - Default: Longint; - NameIndex: SmallInt; - {$ifdef FPC} - PropProcs : Byte; - {$ifdef FPC_PROVIDE_ATTR_TABLE} - /// property attributes, introduced since FPC SVN 42356-42411 (2019/07) - AttributeTable: Pointer; - {$endif FPC_PROVIDE_ATTR_TABLE} - {$endif} - NameLen: byte; - end; - PPropInfo = ^TPropInfo; - {$ifdef FPC} - {$pop} - {$endif} - -{$ifdef HASDIRECTTYPEINFO} -type - Deref = PTypeInfo; -{$else} -function Deref(Info: PTypeInfoStored): PTypeInfo; // for Delphi and newer FPC -{$ifdef HASINLINE} inline; -begin - result := pointer(Info); - if Info<>nil then - result := Info^; -end; -{$else} -asm // Delphi is so bad at compiling above code... - or eax, eax - jz @z - mov eax, [eax] - ret -@z: db $f3 // rep ret -end; -{$endif HASINLINE} -{$endif HASDIRECTTYPEINFO} - -const - /// codePage offset = string header size - // - used to calc the beginning of memory allocation of a string - STRRECSIZE = SizeOf(TStrRec); - -{$ifdef HASCODEPAGE} -function FastNewString(len: PtrInt; cp: cardinal): PAnsiChar; inline; -begin - if len>0 then begin - {$ifdef FPC_X64MM}result := _Getmem({$else}GetMem(result,{$endif}len+(STRRECSIZE+4)); - PStrRec(result)^.codePage := cp; - PStrRec(result)^.elemSize := 1; - PStrRec(result)^.refCnt := 1; - PStrRec(result)^.length := len; - PCardinal(result+len+STRRECSIZE)^ := 0; // ensure ends with four #0 - inc(PStrRec(result)); - end else - result := nil; -end; -{$endif HASCODEPAGE} - -{$ifdef FPC_X64} -procedure fpc_ansistr_decr_ref; external name 'FPC_ANSISTR_DECR_REF'; -procedure fpc_ansistr_incr_ref; external name 'FPC_ANSISTR_INCR_REF'; -procedure fpc_ansistr_assign; external name 'FPC_ANSISTR_ASSIGN'; -procedure fpc_ansistr_setlength; external name 'FPC_ANSISTR_SETLENGTH'; -procedure fpc_ansistr_compare; external name 'FPC_ANSISTR_COMPARE'; -procedure fpc_ansistr_compare_equal; external name 'FPC_ANSISTR_COMPARE_EQUAL'; -procedure fpc_unicodestr_decr_ref; external name 'FPC_UNICODESTR_DECR_REF'; -procedure fpc_unicodestr_incr_ref; external name 'FPC_UNICODESTR_INCR_REF'; -procedure fpc_unicodestr_assign; external name 'FPC_UNICODESTR_ASSIGN'; -procedure fpc_dynarray_incr_ref; external name 'FPC_DYNARRAY_INCR_REF'; -procedure fpc_dynarray_decr_ref; external name 'FPC_DYNARRAY_DECR_REF'; -procedure fpc_dynarray_clear; external name 'FPC_DYNARRAY_CLEAR'; -{$ifdef FPC_X64MM} -procedure fpc_getmem; external name 'FPC_GETMEM'; -procedure fpc_freemem; external name 'FPC_FREEMEM'; -{$else} -procedure _Getmem; external name 'FPC_GETMEM'; -procedure _Freemem; external name 'FPC_FREEMEM'; -{$endif FPC_X64MM} - -procedure PatchJmp(old, new: PByteArray; size: PtrInt; jmp: PtrUInt=0); -var - rel: PCardinal; -begin - PatchCode(old, new, size, nil, {unprotected=}true); - if jmp = 0 then - jmp := PtrUInt(@_Freemem); - repeat // search and fix "jmp rel fpc_freemem/_dynarray_decr_ref_free" - dec(size); - if size = 0 then - exit; - rel := @old[size + 1]; - until (old[size] = $e9) and - (rel^ = cardinal(jmp - PtrUInt(@new[size]) - 5)); - rel^ := jmp - PtrUInt(rel) - 4; -end; - -procedure _ansistr_decr_ref(var p: Pointer); nostackframe; assembler; -asm - mov rax, qword ptr[p] - xor edx, edx - test rax, rax - jz @z - mov qword ptr[p], rdx - mov p, rax - {$ifdef STRCNT32} - cmp dword ptr[rax - _STRREFCNT], rdx - jl @z -lock dec dword ptr[rax - _STRREFCNT] - {$else} - cmp qword ptr[rax - _STRREFCNT], rdx - jl @z -lock dec qword ptr[rax - _STRREFCNT] - {$endif STRCNT32} - jbe @free -@z: ret -@free: sub p, STRRECSIZE - jmp _Freemem -end; - -procedure _ansistr_incr_ref(p: pointer); nostackframe; assembler; -asm - test p, p - jz @z - {$ifdef STRCNT32} - cmp dword ptr[p - _STRREFCNT], 0 - jl @z -lock inc dword ptr[p - _STRREFCNT] - {$else} - cmp qword ptr[p - _STRREFCNT], 0 - jl @z -lock inc qword ptr[p - _STRREFCNT] - {$endif STRCNT32} -@z: -end; - -procedure _ansistr_assign(var d: pointer; s: pointer); nostackframe; assembler; -asm - mov rax, qword ptr[d] - cmp rax, s - jz @eq - test s, s - jz @ns - {$ifdef STRCNT32} - cmp dword ptr[s - _STRREFCNT], 0 - jl @ns -lock inc dword ptr[s - _STRREFCNT] -@ns: mov qword ptr[d], s - test rax, rax - jnz @z -@eq: ret -@z: mov d, rax - cmp dword ptr[rax - _STRREFCNT], 0 - jl @n - lock dec dword ptr[rax - _STRREFCNT] - {$else} - cmp qword ptr[s - _STRREFCNT], 0 - jl @ns -lock inc qword ptr[s - _STRREFCNT] -@ns: mov qword ptr[d], s - test rax, rax - jnz @z -@eq: ret -@z: mov d, rax - cmp qword ptr[rax - _STRREFCNT], 0 - jl @n - lock dec qword ptr[rax - _STRREFCNT] - {$endif STRCNT32} - ja @n -@free: sub d, STRRECSIZE - jmp _Freemem -@n: -end; - -{ note: fpc_ansistr_compare/_equal do check the codepage and make a UTF-8 - conversion if necessary, whereas Delphi _LStrCmp/_LStrEqual don't; - involving codepage is safer, but paranoid, and 1. is (much) slower, and - 2. is not Delphi compatible -> we rather follow the Delphi/Lazy's way } - -function _ansistr_compare(s1, s2: pointer): SizeInt; nostackframe; assembler; -asm - xor eax, eax - cmp s1, s2 - je @0 - test s1, s2 - jz @maybe0 -@first: mov al, byte ptr[s1] // we can check the first char (for quicksort) - sub al, byte ptr[s2] - jne @ne - mov r8, qword ptr[s1 - _STRLEN] - mov r11, r8 - sub r8, qword ptr[s2 - _STRLEN] // r8 = length(s1)-length(s2) - adc rax, -1 - and rax, r8 // rax = -min(length(s1),length(s2)) - sub rax, r11 - sub s1, rax - sub s2, rax - align 8 -@s: mov r10, qword ptr[s1 + rax] // compare by 8 bytes (may include len) - xor r10, qword ptr[s2 + rax] - jnz @d - add rax, 8 - js @s -@e: mov rax, r8 // all equal -> return difflen -@0: ret -@ne: movsx rax, al - ret -@d: bsf r10, r10 // compute s1^-s2^ - shr r10, 3 - add rax, r10 - jns @e - movzx edx, byte ptr[s2 + rax] - movzx eax, byte ptr[s1 + rax] - sub rax, rdx - ret -@maybe0:test s2, s2 - jz @1 - test s1, s1 - jnz @first - dec rax - ret -@1: inc eax -end; - -function _ansistr_compare_equal(s1, s2: pointer): SizeInt; nostackframe; assembler; -asm - xor eax, eax - cmp s1, s2 - je @q - test s1, s2 - jz @maybe0 -@ok: mov rax, qword ptr[s1 - _STRLEN] // len must match - cmp rax, qword ptr[s2 - _STRLEN] - jne @q - lea s1, qword ptr[s1 + rax - 8] - lea s2, qword ptr[s2 + rax - 8] - neg rax - mov r8, qword ptr[s1] // compare last 8 bytes (may include len) - cmp r8, qword ptr[s2] - jne @q - align 16 -@s: add rax, 8 // compare remaining 8 bytes per iteration - jns @0 - mov r8, qword ptr[s1 + rax] - cmp r8, qword ptr[s2 + rax] - je @s - mov eax, 1 - ret -@0: xor eax, eax -@q: ret -@maybe0:test s2, s2 - jz @1 - test s1, s1 - jnz @ok -@1: inc eax // not zero is enough -end; - -procedure _dynarray_incr_ref(p: pointer); nostackframe; assembler; -asm - test p, p - jz @z - cmp qword ptr[p - _DAREFCNT], 0 - jle @z -lock inc qword ptr[p - _DAREFCNT] -@z: -end; - -procedure _dynarray_decr_ref_free(p: PDynArrayRec; info: pointer); forward; - -procedure _dynarray_decr_ref(var p: Pointer; info: pointer); nostackframe; assembler; -asm - mov rax, qword ptr[p] - test rax, rax - jz @z - mov qword ptr[p], 0 - mov p, rax - sub p, SizeOf(TDynArrayRec) - cmp qword ptr[rax - _DAREFCNT], 0 - jle @z -lock dec qword ptr[p] - jbe @free -@z: ret -@free: jmp _dynarray_decr_ref_free -end; - -procedure FastAssignNew(var d; s: pointer); nostackframe; assembler; -asm - mov rax, qword ptr[d] - mov qword ptr[d], s - test rax, rax - jz @z - mov d, rax - {$ifdef STRCNT32} - cmp dword ptr[rax - _STRREFCNT], 0 - jl @z -lock dec dword ptr[rax - _STRREFCNT] - {$else} - cmp qword ptr[rax - _STRREFCNT], 0 - jl @z -lock dec qword ptr[rax - _STRREFCNT] - {$endif STRCNT32} - jbe @free -@z: ret -@free: sub d, STRRECSIZE - jmp _Freemem -end; - -{$ifdef FPC_HAS_CPSTRING} - -{$ifdef FPC_X64MM} -procedure _ansistr_setlength_new(var s: RawByteString; len: PtrInt; cp: cardinal); -var p, new: PAnsiChar; - l: PtrInt; -begin - if cp<=CP_OEMCP then begin // TranslatePlaceholderCP logic - cp := DefaultSystemCodePage; - if cp=0 then - cp := CP_NONE; - end; - new := FastNewString(len,cp); - p := pointer(s); - if p<>nil then begin - l := PStrLen(p-_STRLEN)^+1; - if l>len then - l := len; - MoveFast(p^,new^,l); - end; - FastAssignNew(s,new); -end; - -procedure _ansistr_setlength(var s: RawByteString; len: PtrInt; cp: cardinal); - nostackframe; assembler; -asm - mov rax, qword ptr[s] - test len, len - jle _ansistr_decr_ref - test rax, rax - jz _ansistr_setlength_new - {$ifdef STRCNT32} - cmp dword ptr[rax - _STRREFCNT], 1 - {$else} - cmp qword ptr[rax - _STRREFCNT], 1 - {$endif STRCNT32} - jne _ansistr_setlength_new - push len - push s - sub qword ptr[s], STRRECSIZE - add len, STRRECSIZE + 1 - call _reallocmem // rely on MM in-place detection - pop s - pop len - add qword ptr[s], STRRECSIZE - mov qword ptr[rax].TStrRec.length, len - mov byte ptr[rax + len + STRRECSIZE], 0 -end; -{$endif FPC_X64MM} - -// _ansistr_concat_convert* optimized for systemcodepage=CP_UTF8 - -function ToTempUTF8(var temp: TSynTempBuffer; p: pointer; len, cp: cardinal): pointer; -begin - if (len=0) or (cp=CP_UTF8) or (cp>=CP_SQLRAWBLOB) or IsAnsiCompatible(p,len) then begin - temp.buf := nil; - temp.len := len; - result := p; - end else begin - temp.Init(len*3); - p := TSynAnsiConvert.Engine(cp).AnsiBufferToUTF8(temp.buf,p,len); - temp.len := PAnsiChar(p)-PAnsiChar(temp.buf); - result := temp.buf; - end; -end; - -procedure _ansistr_concat_convert(var dest: RawByteString; const s1,s2: RawByteString; - cp,cp1,cp2: cardinal); -var t1, t2, t: TSynTempBuffer; // avoid most memory allocation - p1, p2, p: PAnsiChar; - eng: TSynAnsiConvert; -begin - p1 := ToTempUTF8(t1,pointer(s1),length(s1),cp1); - p2 := ToTempUTF8(t2,pointer(s2),length(s2),cp2); - if (cp=CP_UTF8) or (cp>=CP_SQLRAWBLOB) or ((t1.buf=nil) and (t2.buf=nil)) then begin - p := FastNewString(t1.len+t2.len,cp); - MoveFast(p1^,p[0],t1.len); - MoveFast(p2^,p[t1.len],t2.len); - FastAssignNew(dest,p); - end else begin - eng := TSynAnsiConvert.Engine(cp); - t.Init((t1.len+t2.len) shl eng.fAnsiCharShift); - p := eng.UTF8BufferToAnsi(eng.UTF8BufferToAnsi(t.buf,p1,t1.len),p2,t2.len); - FastSetStringCP(dest,t.buf,p-t.buf,cp); - t.Done; - end; - t2.Done; - t1.Done; -end; - -function _lstrlen(const s: RawByteString): TStrLen; inline; -begin - result := PStrLen(PtrUInt(s)-_STRLEN)^; -end; - -function _lstrcp(const s: RawByteString; cp: integer): integer; inline; -begin - result := cp; - if s<>'' then begin - result := PStrRec(PtrUInt(s)-STRRECSIZE)^.codePage; - if result<=CP_OEMCP then - result := CP_UTF8; - end; -end; - -procedure _ansistr_concat_utf8(var dest: RawByteString; - const s1,s2: RawByteString; cp: cardinal); -var cp1, cp2: cardinal; - new: PAnsiChar; - l1: PtrInt; -begin - if cp<=CP_OEMCP then // TranslatePlaceholderCP logic - cp := CP_UTF8; - cp1 := _lstrcp(s1,cp); - cp2 := _lstrcp(s2,cp1); - if (cp1=cp2) and ((cp>=CP_SQLRAWBLOB) or (cp=cp1)) then - cp := cp1 else - if ((cp1<>cp) and (cp1cp) and (cp2 self-resize dest - SetLength(dest,l1+_lstrlen(s2)); - PStrRec(PtrUInt(dest)-STRRECSIZE)^.codepage := cp; - MoveFast(pointer(s2)^,PByteArray(dest)[l1],_lstrlen(s2)); - end else begin - new := FastNewString(l1+_lstrlen(s2),cp); - MoveFast(pointer(s1)^,new[0],l1); - MoveFast(pointer(s2)^,new[l1],_lstrlen(s2)); - FastAssignNew(dest,new); - end; - end; -end; - -procedure _ansistr_concat_multi_convert(var dest: RawByteString; - s: PRawByteString; scount, cp: cardinal); -var t: TTextWriter; - u: RawUTF8; - tmp: TTextWriterStackBuffer; -begin - t := TTextWriter.CreateOwnedStream(tmp); - try - repeat - if s^<>'' then - t.AddAnyAnsiBuffer(pointer(s^),_lstrlen(s^),twNone,_lstrcp(s^,cp)); - inc(s); - dec(scount); - until scount=0; - t.SetText(u); - finally - t.Free; - end; - if (cp=CP_UTF8) or (cp>=CP_SQLRAWBLOB) then - dest := u else - TSynAnsiConvert.Engine(cp).UTF8BufferToAnsi(pointer(u),length(u),dest); -end; - -procedure _ansistr_concat_multi_utf8(var dest: RawByteString; - const s: array of RawByteString; cp: cardinal); -var first,len,i,l: integer; // should NOT be PtrInt/SizeInt to avoid FPC bug with high(s) :( - cpf,cpi: cardinal; - p: pointer; - new: PAnsiChar; -begin - if cp<=CP_OEMCP then - cp := CP_UTF8; - first := 0; - repeat - if first>high(s) then begin - _ansistr_decr_ref(pointer(dest)); - exit; - end; - p := pointer(s[first]); - if p<>nil then - break; - inc(first); - until false; - len := _lstrlen(RawByteString(p)); - cpf := _lstrcp(RawByteString(p),cp); - if (cpf<>cp) and (cpfnil then begin - inc(len,_lstrlen(RawByteString(p))); - cpi := PStrRec(PtrUInt(p)-STRRECSIZE)^.codePage; - if cpi<=CP_OEMCP then - cpi := CP_UTF8; - if (cpi<>cpf) and (cpi self-resize - SetLength(dest,len); - new := pointer(dest); - PStrRec(PtrUInt(dest)-STRRECSIZE)^.codepage := cp; - cp := 0; - end else begin - new := FastNewString(len,cp); - MoveFast(p^,new[0],l); - end; - for i := first+1 to high(s) do begin - p := pointer(s[i]); - if p<>nil then begin - MoveFast(p^,new[l],_lstrlen(RawByteString(p))); - inc(l,_lstrlen(RawByteString(p))); - end; - end; - if cp<>0 then - FastAssignNew(dest,new); - end; -end; - -procedure _fpc_ansistr_concat(var a: RawUTF8); -begin - a := a+a; // to generate "call fpc_ansistr_concat" opcode -end; - -procedure _fpc_ansistr_concat_multi(var a: RawUTF8); -begin - a := a+a+a; // to generate "call fpc_ansistr_concat_multi" opcode -end; - -procedure RedirectRtl(dummy, dest: PByteArray); -begin - repeat - if (dummy[0]=$b9) and (PCardinal(@dummy[1])^=CP_UTF8) then - case dummy[5] of - $e8: begin - // found "mov ecx,65001; call fpc_ansistr_concat" opcodes - RedirectCode(@dummy[PInteger(@dummy[6])^+10],dest); - exit; - end; - $ba: if (PCardinal(@dummy[6])^=2) and (dummy[10]=$e8) then - begin - // found "mov ecx,65001; mov edx,2; call fpc_ansistr_concat_multi" - RedirectCode(@dummy[PInteger(@dummy[11])^+15],dest); - exit; - end; - end; - inc(PByte(dummy)); - until PInt64(dummy)^=0; -end; - -{$endif FPC_HAS_CPSTRING} - -{$else} - -procedure FastAssignNew(var d; s: pointer); {$ifdef HASINLINE} inline; {$endif} -var - sr: PStrRec; // local copy to use register -begin - sr := Pointer(d); - Pointer(d) := s; - if sr = nil then - exit; - dec(sr); - if (sr^.refcnt >= 0) and StrCntDecFree(sr^.refcnt) then - FreeMem(sr); -end; -{$endif FPC_X64} - -{$ifdef HASCODEPAGE} -procedure FastSetStringCP(var s; p: pointer; len, codepage: PtrInt); -var r: pointer; -begin - r := FastNewString(len,codepage); - if p<>nil then - MoveFast(p^,r^,len); - FastAssignNew(s,r); -end; - -procedure FastSetString(var s: RawUTF8; p: pointer; len: PtrInt); -var r: pointer; -begin - r := FastNewString(len,CP_UTF8); - if p<>nil then - MoveFast(p^,r^,len); - FastAssignNew(s,r); -end; -{$else not HASCODEPAGE} -procedure FastSetStringCP(var s; p: pointer; len, codepage: PtrInt); -begin - SetString(RawByteString(s),PAnsiChar(p),len); -end; -procedure FastSetString(var s: RawUTF8; p: pointer; len: PtrInt); -begin - SetString(RawByteString(s),PAnsiChar(p),len); -end; -{$endif HASCODEPAGE} - -procedure GetMemAligned(var s: RawByteString; p: pointer; len: PtrInt; - out aligned: pointer); -begin - SetString(s,nil,len+16); - aligned := pointer(s); - inc(PByte(aligned),PtrUInt(aligned) and 15); - if p<>nil then - MoveFast(p^,aligned^,len); -end; - -function ToText(k: TTypeKind): PShortString; -begin - result := GetEnumName(TypeInfo(TTypeKind),ord(k)); -end; - -function ToText(k: TDynArrayKind): PShortString; -begin - result := GetEnumName(TypeInfo(TDynArrayKind),ord(k)); -end; - -function UniqueRawUTF8(var UTF8: RawUTF8): pointer; -begin - {$ifdef FPC} - UniqueString(UTF8); // @UTF8[1] won't call UniqueString() under FPC :( - {$endif} - result := @UTF8[1]; -end; - -procedure UniqueRawUTF8ZeroToTilde(var UTF8: RawUTF8; MaxSize: integer); -var i: integer; -begin - i := length(UTF8); - if i>MaxSize then - PByteArray(UTF8)[MaxSize] := 0 else - MaxSize := i; - for i := 0 to MaxSize-1 do - if PByteArray(UTF8)[i]=0 then - PByteArray(UTF8)[i] := ord('~'); -end; - -{$ifdef FPC} -function TDynArrayRec.GetLength: sizeint; -begin - result := high+1; -end; - -procedure TDynArrayRec.SetLength(len: sizeint); -begin - high := len-1; -end; -{$endif FPC} - -function DynArrayLength(Value: Pointer): PtrInt; - {$ifdef HASINLINE}inline;{$endif} -begin - result := PtrInt(Value); - if result<>0 then - result := PDALen(result-_DALEN)^{$ifdef FPC}+1{$endif}; -end; - -{$ifdef HASALIGNTYPEDATA} -function FPCTypeInfoOverName(P: pointer): pointer; inline; -{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} {$ifdef CPUARM3264} -const diff=SizeOf(QWord);// always on these two CPU's -{$else} var diff: PtrUInt; {$endif} {$endif} -begin - {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} - {$ifndef CPUARM3264} - diff := PtrUInt(@PTypeInfo(P)^.NameFirst)-PtrUInt(@PTypeInfo(P)^.Kind); - {$endif} - result := AlignTypeData(P+2+PByte(P+1)^); - dec(PByte(result),diff); - {$else} - result := AlignTypeData(P+PByte(P+1)^); - {$endif} -end; -{$endif HASALIGNTYPEDATA} - -function GetTypeInfo(aTypeInfo: pointer; aExpectedKind: TTypeKind): PTypeInfo; overload; -{$ifdef HASINLINE} inline; -begin - result := aTypeInfo; - if result<>nil then - if result^.Kind=aExpectedKind then - {$ifdef HASALIGNTYPEDATA} - result := FPCTypeInfoOverName(result) - {$else} - inc(PByte(result),result^.NameLen) - {$endif} - else - result := nil; -end; -{$else} -asm - test eax, eax - jz @n - movzx ecx, byte ptr[eax + TTypeInfo.NameLen] - cmp dl, [eax] - jne @n - add eax, ecx - ret -@n: xor eax, eax -end; -{$endif HASINLINE} - -function GetTypeInfo(aTypeInfo: pointer; const aExpectedKind: TTypeKinds): PTypeInfo; overload; -{$ifdef HASINLINE} inline; -begin - result := aTypeInfo; - if result<>nil then - if result^.Kind in aExpectedKind then - {$ifdef HASALIGNTYPEDATA} - result := FPCTypeInfoOverName(result) - {$else} - inc(PByte(result),result^.NameLen) - {$endif} - else - result := nil; -end; -{$else} -asm // eax=aTypeInfo edx=aExpectedKind - test eax, eax - jz @n - movzx ecx, byte ptr[eax] - bt edx, ecx - movzx ecx, byte ptr[eax + TTypeInfo.NameLen] - jnb @n - add eax, ecx - ret -@n: xor eax, eax -end; -{$endif HASINLINE} - -function GetTypeInfo(aTypeInfo: pointer): PTypeInfo; overload; -{$ifdef HASINLINE} inline; -begin - {$ifdef HASALIGNTYPEDATA} - result := FPCTypeInfoOverName(aTypeInfo); - {$else} - result := @PAnsiChar(aTypeInfo)[PTypeInfo(aTypeInfo)^.NameLen]; - {$endif} -end; -{$else} -asm - movzx ecx, byte ptr[eax + TTypeInfo.NameLen] - add eax, ecx -end; -{$endif HASINLINE} - -function DynArrayTypeInfoToRecordInfo(aDynArrayTypeInfo: pointer; - aDataSize: PInteger): pointer; -var info: PTypeInfo; -begin - result := nil; - info := GetTypeInfo(aDynArrayTypeInfo,tkDynArray); - if info=nil then - exit; - if info^.elType<>nil then - result := Deref(info^.elType); - if aDataSize<>nil then - aDataSize^ := info^.elSize {$ifdef FPC}and $7FFFFFFF{$endif}; -end; - -procedure TypeInfoToName(aTypeInfo: pointer; var result: RawUTF8; - const default: RawUTF8); -begin - if aTypeInfo<>nil then - FastSetString(result,PAnsiChar(@PTypeInfo(aTypeInfo)^.NameLen)+1, - PTypeInfo(aTypeInfo)^.NameLen) else - result := default; -end; - -function TypeInfoToShortString(aTypeInfo: pointer): PShortString; -begin - if aTypeInfo<>nil then - result := @PTypeInfo(aTypeInfo)^.NameLen else - result := nil; -end; - -procedure TypeInfoToQualifiedName(aTypeInfo: pointer; var result: RawUTF8; - const default: RawUTF8); -var unitname: RawUTF8; -begin - if aTypeInfo<>nil then begin - FastSetString(result,PAnsiChar(@PTypeInfo(aTypeInfo)^.NameLen)+1, - PTypeInfo(aTypeInfo)^.NameLen); - if PTypeInfo(aTypeInfo)^.Kind=tkClass then begin - with GetTypeInfo(aTypeInfo)^ do - FastSetString(unitname,PAnsiChar(@UnitNameLen)+1,UnitNameLen); - result := unitname+'.'+result; - end; - end else result := default; -end; - -function TypeInfoToName(aTypeInfo: pointer): RawUTF8; -begin - TypeInfoToName(aTypeInfo,Result,''); -end; - -function RecordTypeInfoSize(aRecordTypeInfo: pointer): integer; -var info: PTypeInfo; -begin - info := GetTypeInfo(aRecordTypeInfo,tkRecordKinds); - if info=nil then - result := 0 else - result := info^.recSize; -end; - -function GetEnumInfo(aTypeInfo: pointer; out MaxValue: Integer): PShortString; -{$ifdef HASINLINE} inline; -var info: PTypeInfo; - base: PTypeInfoStored; -begin - if (aTypeInfo<>nil) and (PTypeKind(aTypeInfo)^=tkEnumeration) then begin - info := GetTypeInfo(aTypeInfo); - base := info^.{$ifdef FPC_ENUMHASINNER}inner.{$endif}EnumBaseType; - {$ifdef FPC} // no redirection if aTypeInfo is already the base type - if (base<>nil) and (base{$ifndef HASDIRECTTYPEINFO}^{$endif}<>aTypeInfo) then - {$endif} - info := GetTypeInfo(base{$ifndef HASDIRECTTYPEINFO}^{$endif}); - MaxValue := info^.{$ifdef FPC_ENUMHASINNER}inner.{$endif}MaxValue; - result := @info^.NameList; - end else - result := nil; -end; -{$else} -asm // eax=aTypeInfo edx=@MaxValue - test eax, eax - jz @n - cmp byte ptr[eax], tkEnumeration - jnz @n - movzx ecx, byte ptr[eax + TTypeInfo.NameLen] - mov eax, [eax + ecx + TTypeInfo.EnumBaseType] - mov eax, [eax] - movzx ecx, byte ptr[eax + TTypeInfo.NameLen] - add eax, ecx - mov ecx, [eax + TTypeInfo.MaxValue] - mov [edx], ecx - lea eax, [eax + TTypeInfo.NameList] - ret -@n: xor eax, eax -end; -{$endif HASINLINE} - -function GetSetBaseEnum(aTypeInfo: pointer): pointer; -begin - result := GetTypeInfo(aTypeInfo,tkSet); - if result<>nil then - result := Deref(PTypeInfo(result)^.SetBaseType); -end; - -function GetSetInfo(aTypeInfo: pointer; out MaxValue: Integer; - out Names: PShortString): boolean; {$ifdef HASINLINE}inline;{$endif} -var info: PTypeInfo; -begin - info := GetTypeInfo(aTypeInfo,tkSet); - if info<>nil then begin - Names := GetEnumInfo(Deref(info^.SetBaseType),MaxValue); - result := Names<>nil; - end else - result := false; -end; - -const - NULL_LOW = ord('n')+ord('u')shl 8+ord('l')shl 16+ord('l')shl 24; - FALSE_LOW = ord('f')+ord('a')shl 8+ord('l')shl 16+ord('s')shl 24; - FALSE_LOW2 = ord('a')+ord('l')shl 8+ord('s')shl 16+ord('e')shl 24; - TRUE_LOW = ord('t')+ord('r')shl 8+ord('u')shl 16+ord('e')shl 24; - - NULL_SHORTSTRING: string[1] = ''; - -procedure GetEnumNames(aTypeInfo: pointer; aDest: PPShortString); -var MaxValue, i: integer; - res: PShortString; -begin - res := GetEnumInfo(aTypeInfo,MaxValue); - if res<>nil then - for i := 0 to MaxValue do begin - aDest^ := res; - inc(PByte(res),PByte(res)^+1); // next - inc(aDest); - end; -end; - -procedure GetEnumTrimmedNames(aTypeInfo: pointer; aDest: PRawUTF8); -var MaxValue, i: integer; - res: PShortString; -begin - res := GetEnumInfo(aTypeInfo,MaxValue); - if res<>nil then - for i := 0 to MaxValue do begin - aDest^ := TrimLeftLowerCaseShort(res); - inc(PByte(res),PByte(res)^+1); // next - inc(aDest); - end; -end; - -function GetEnumTrimmedNames(aTypeInfo: pointer): TRawUTF8DynArray; -var MaxValue, i: integer; - res: PShortString; -begin - Finalize(result); - res := GetEnumInfo(aTypeInfo,MaxValue); - if res=nil then - exit; - SetLength(result,MaxValue+1); - for i := 0 to MaxValue do begin - result[i] := TrimLeftLowerCaseShort(res); - inc(PByte(res),PByte(res)^+1); // next - end; -end; - -procedure GetCaptionFromTrimmed(PS: PShortString; var result: string); -var tmp: array[byte] of AnsiChar; - L: integer; -begin - L := ord(PS^[0]); - inc(PByte(PS)); - while (L>0) and (PS^[0] in ['a'..'z']) do begin inc(PByte(PS)); dec(L); end; - tmp[L] := #0; // as expected by GetCaptionFromPCharLen/UnCamelCase - if L>0 then - MoveSmall(PS,@tmp,L); - GetCaptionFromPCharLen(tmp,result); -end; - -procedure GetEnumCaptions(aTypeInfo: pointer; aDest: PString); -var MaxValue, i: integer; - res: PShortString; -begin - res := GetEnumInfo(aTypeInfo,MaxValue); - if res<>nil then - for i := 0 to MaxValue do begin - GetCaptionFromTrimmed(res,aDest^); - inc(PByte(res),PByte(res)^+1); // next - inc(aDest); - end; -end; - -function GetEnumName(aTypeInfo: pointer; aIndex: integer): PShortString; -{$ifdef HASINLINENOTX86} -var MaxValue: integer; -begin - result := GetEnumInfo(aTypeInfo,MaxValue); - if (result<>nil) and (cardinal(aIndex)<=cardinal(MaxValue)) then begin - if aIndex>0 then - repeat - inc(PByte(result),PByte(result)^+1); // next - dec(aIndex); - if aIndex=0 then - break; - inc(PByte(result),PByte(result)^+1); // loop unrolled twice - dec(aIndex); - until aIndex=0; - end else - result := @NULL_SHORTSTRING; -end; -{$else} -asm // eax=aTypeInfo edx=aIndex - test eax, eax - jz @0 - cmp byte ptr[eax], tkEnumeration - jnz @0 - movzx ecx, byte ptr[eax + TTypeInfo.NameLen] - mov eax, [eax + ecx + TTypeInfo.EnumBaseType] - mov eax, [eax] - movzx ecx, byte ptr[eax + TTypeInfo.NameLen] - cmp edx, [eax + ecx + TTypeInfo.MaxValue] - ja @0 - lea eax, [eax + ecx + TTypeInfo.NameList] - test edx, edx - jz @z - push edx - shr edx, 2 // fast by-four scanning - jz @1 -@4: dec edx - movzx ecx, byte ptr[eax] - lea eax, [eax + ecx + 1] - movzx ecx, byte ptr[eax] - lea eax, [eax + ecx + 1] - movzx ecx, byte ptr[eax] - lea eax, [eax + ecx + 1] - movzx ecx, byte ptr[eax] - lea eax, [eax + ecx + 1] - jnz @4 - pop edx - and edx, 3 - jnz @s - ret -@1: pop edx -@s: movzx ecx, byte ptr[eax] - dec edx - lea eax, [eax + ecx + 1] // next - jnz @s - ret -@z: rep ret -@0: lea eax, NULL_SHORTSTRING -end; -{$endif HASINLINENOTX86} - -{$ifdef PUREPASCAL} // for proper inlining -function IdemPropNameUSameLen(P1,P2: PUTF8Char; P1P2Len: PtrInt): boolean; -label zero; -begin - P1P2Len := PtrInt(@PAnsiChar(P1)[P1P2Len-SizeOf(cardinal)]); - if P1P2Len>=PtrInt(PtrUInt(P1)) then - repeat // case-insensitive compare 4 bytes per loop - if (PCardinal(P1)^ xor PCardinal(P2)^) and $dfdfdfdf<>0 then - goto zero; - inc(P1,SizeOf(cardinal)); - inc(P2,SizeOf(cardinal)); - until P1P2Len0 then - goto zero; - inc(P1); - until PtrInt(PtrUInt(P1))>=P1P2Len; - result := true; - exit; -zero: - result := false; -end; -{$endif PUREPASCAL} - -function IdemPropNameUSmallNotVoid(P1,P2,P1P2Len: PtrInt): boolean; - {$ifdef HASINLINE}inline;{$endif} -label zero; -begin - inc(P1P2Len,P1); - dec(P2,P1); - repeat - if (PByte(P1)^ xor ord(PAnsiChar(P1)[P2])) and $df<>0 then - goto zero; - inc(P1); - until P1>=P1P2Len; - result := true; - exit; -zero: - result := false; -end; - -function FindShortStringListExact(List: PShortString; MaxValue: integer; - aValue: PUTF8Char; aValueLen: PtrInt): integer; -var PLen: PtrInt; -begin - if aValueLen<>0 then - for result := 0 to MaxValue do begin - PLen := PByte(List)^; - if (PLen=aValuelen) and - IdemPropNameUSmallNotVoid(PtrInt(@List^[1]),PtrInt(aValue),PLen) then - exit; - List := pointer(@PAnsiChar(PLen)[PtrUInt(List)+1]); // next - end; - result := -1; -end; - -function FindShortStringListTrimLowerCase(List: PShortString; MaxValue: integer; - aValue: PUTF8Char; aValueLen: PtrInt): integer; -var PLen: PtrInt; -begin - if aValueLen<>0 then - for result := 0 to MaxValue do begin - PLen := ord(List^[0]); - inc(PUTF8Char(List)); - repeat // trim lower case - if not(PUTF8Char(List)^ in ['a'..'z']) then - break; - inc(PUTF8Char(List)); - dec(PLen); - until PLen=0; - if (PLen=aValueLen) and IdemPropNameUSmallNotVoid(PtrInt(aValue),PtrInt(List),PLen) then - exit; - inc(PUTF8Char(List),PLen); // next - end; - result := -1; -end; - -{$ifdef HASINLINE} -function CompareMemFixed(P1, P2: Pointer; Length: PtrInt): Boolean; -label zero; -begin // cut-down version of our pure pascal CompareMem() function - {$ifndef CPUX86} result := false; {$endif} - Length := PtrInt(@PAnsiChar(P1)[Length-SizeOf(PtrInt)]); - if Length>=PtrInt(PtrUInt(P1)) then - repeat // compare one PtrInt per loop - if PPtrInt(P1)^<>PPtrInt(P2)^ then - goto zero; - inc(PPtrInt(P1)); - inc(PPtrInt(P2)); - until LengthPByteArray(P2)[PtrUInt(P1)] then - goto zero; - inc(PByte(P1)); - until PtrInt(PtrUInt(P1))>=Length; - result := true; - exit; -zero: - {$ifdef CPUX86} result := false; {$endif} -end; -{$endif HASINLINE} - -function FindShortStringListTrimLowerCaseExact(List: PShortString; MaxValue: integer; - aValue: PUTF8Char; aValueLen: PtrInt): integer; -var PLen: PtrInt; -begin - if aValueLen<>0 then - for result := 0 to MaxValue do begin - PLen := ord(List^[0]); - inc(PUTF8Char(List)); - repeat - if not(PUTF8Char(List)^ in ['a'..'z']) then - break; - inc(PUTF8Char(List)); - dec(PLen); - until PLen=0; - if (PLen=aValueLen) and CompareMemFixed(aValue,List,PLen) then - exit; - inc(PUTF8Char(List),PLen); - end; - result := -1; -end; - -function GetEnumNameValue(aTypeInfo: pointer; aValue: PUTF8Char; aValueLen: PtrInt; - AlsoTrimLowerCase: boolean): Integer; -var List: PShortString; - MaxValue: integer; -begin - List := GetEnumInfo(aTypeInfo,MaxValue); - if (aValueLen<>0) and (List<>nil) then begin - result := FindShortStringListExact(List,MaxValue,aValue,aValueLen); - if (result<0) and AlsoTrimLowerCase then - result := FindShortStringListTrimLowerCase(List,MaxValue,aValue,aValueLen); - end else - result := -1; -end; - -function GetEnumNameValueTrimmed(aTypeInfo: pointer; aValue: PUTF8Char; aValueLen: PtrInt): integer; -var List: PShortString; - MaxValue: integer; -begin - List := GetEnumInfo(aTypeInfo,MaxValue); - if (aValueLen<>0) and (List<>nil) then - result := FindShortStringListTrimLowerCase(List,MaxValue,aValue,aValueLen) else - result := -1; -end; - -function GetEnumNameValueTrimmedExact(aTypeInfo: pointer; aValue: PUTF8Char; aValueLen: PtrInt): integer; -var List: PShortString; - MaxValue: integer; -begin - List := GetEnumInfo(aTypeInfo,MaxValue); - if (aValueLen<>0) and (List<>nil) then - result := FindShortStringListTrimLowerCaseExact(List,MaxValue,aValue,aValueLen) else - result := -1; -end; - -function GetEnumNameValue(aTypeInfo: pointer; const aValue: RawUTF8; - AlsoTrimLowerCase: boolean): Integer; -begin - result := GetEnumNameValue(aTypeInfo, pointer(aValue), length(aValue), - AlsoTrimLowerCase); -end; - -function GetSetName(aTypeInfo: pointer; const value): RawUTF8; -var PS: PShortString; - i,max: integer; -begin - result := ''; - if GetSetInfo(aTypeInfo,max,PS) then begin - for i := 0 to max do begin - if GetBitPtr(@value,i) then - result := FormatUTF8('%%,',[result,PS^]); - inc(PByte(PS),PByte(PS)^+1); // next - end; - end; - if result<>'' then - SetLength(result,length(result)-1); // trim last comma -end; - -procedure AppendShortComma(text: PAnsiChar; len: PtrInt; var result: shortstring; - trimlowercase: boolean); -begin - if trimlowercase then - while text^ in ['a'..'z'] do - if len=1 then - exit else begin - inc(text); - dec(len); - end; - if integer(ord(result[0]))+len>=255 then - exit; - if len>0 then - MoveSmall(text,@result[ord(result[0])+1],len); - inc(result[0],len+1); - result[ord(result[0])] := ','; -end; - -procedure GetSetNameShort(aTypeInfo: pointer; const value; out result: ShortString; - trimlowercase: boolean); -var PS: PShortString; - i,max: integer; -begin - result := ''; - if GetSetInfo(aTypeInfo,max,PS) then begin - for i := 0 to max do begin - if GetBitPtr(@value,i) then - AppendShortComma(@PS^[1],ord(PS^[0]),result,trimlowercase); - inc(PByte(PS),PByte(PS)^+1); // next - end; - end; - if result[ord(result[0])]=',' then - dec(result[0]); -end; - -function GetSetNameValue(aTypeInfo: pointer; var P: PUTF8Char; - out EndOfObject: AnsiChar): cardinal; -var names: PShortString; - Text: PUTF8Char; - wasString: boolean; - MaxValue, TextLen, i: integer; -begin - result := 0; - if (P<>nil) and GetSetInfo(aTypeInfo,MaxValue,names) then begin - while (P^<=' ') and (P^<>#0) do inc(P); - if P^='[' then begin - repeat inc(P) until (P^>' ') or (P^=#0); - if P^=']' then - inc(P) else begin - repeat - Text := GetJSONField(P,P,@wasString,@EndOfObject,@TextLen); - if (Text=nil) or not wasString then begin - P := nil; // invalid input (expects a JSON array of strings) - exit; - end; - if Text^='*' then begin - if MaxValue<32 then - result := ALLBITS_CARDINAL[MaxValue+1] else - result := cardinal(-1); - break; - end; - if Text^ in ['a'..'z'] then - i := FindShortStringListExact(names,MaxValue,Text,TextLen) else - i := -1; - if i<0 then - i := FindShortStringListTrimLowerCase(names,MaxValue,Text,TextLen); - if i>=0 then - SetBitPtr(@result,i); - // unknown enum names (i=-1) would just be ignored - until EndOfObject=']'; - if P=nil then - exit; // avoid GPF below if already reached the input end - end; - while not (jcEndOfJSONField in JSON_CHARS[P^]) do begin // mimics GetJSONField() - if P^=#0 then begin - P := nil; - exit; // unexpected end - end; - inc(P); - end; - EndOfObject := P^; - repeat inc(P) until (P^>' ') or (P^=#0); - end else - result := GetCardinal(GetJSONField(P,P,nil,@EndOfObject)); - end; -end; - - -{ note: those low-level VariantTo*() functions are expected to be there - even if NOVARIANTS conditional is defined (used e.g. by SynDB.TQuery) } - -function SetVariantUnRefSimpleValue(const Source: variant; var Dest: TVarData): boolean; -var typ: cardinal; -begin - result := false; - typ := TVarData(Source).VType; - if typ and varByRef=0 then - exit; - typ := typ and not varByRef; - case typ of - varVariant: - if integer(PVarData(TVarData(Source).VPointer)^.VType) in - [varEmpty..varDate,varBoolean,varShortInt..varWord64] then begin - Dest := PVarData(TVarData(Source).VPointer)^; - result := true; - end; - varEmpty..varDate,varBoolean,varShortInt..varWord64: begin - Dest.VType := typ; - Dest.VInt64 := PInt64(TVarData(Source).VAny)^; - result := true; - end; - end; -end; - -function VariantToInteger(const V: Variant; var Value: integer): boolean; -var tmp: TVarData; - vt: cardinal; -begin - result := false; - vt := TVarData(V).VType; - case vt of - varNull, - varEmpty: Value := 0; - varBoolean: if TVarData(V).VBoolean then Value := 1 else Value := 0; // normalize - varSmallint: Value := TVarData(V).VSmallInt; - {$ifndef DELPHI5OROLDER} - varShortInt: Value := TVarData(V).VShortInt; - varWord: Value := TVarData(V).VWord; - varLongWord: - if TVarData(V).VLongWord<=cardinal(High(integer)) then - Value := TVarData(V).VLongWord else - exit; - {$endif} - varByte: Value := TVarData(V).VByte; - varInteger: Value := TVarData(V).VInteger; - varWord64: - if (TVarData(V).VInt64>=0) and (TVarData(V).VInt64<=High(integer)) then - Value := TVarData(V).VInt64 else - exit; - varInt64: - if (TVarData(V).VInt64>=Low(integer)) and (TVarData(V).VInt64<=High(integer)) then - Value := TVarData(V).VInt64 else - exit; - else - if SetVariantUnRefSimpleValue(V,tmp) then begin - result := VariantToInteger(variant(tmp),Value); - exit; - end else - exit; - end; - result := true; -end; - -function VariantToDouble(const V: Variant; var Value: double): boolean; -var tmp: TVarData; - vt: cardinal; -begin - vt := TVarData(V).VType; - if vt=varVariant or varByRef then - result := VariantToDouble(PVariant(TVarData(V).VPointer)^,Value) else begin - result := true; - if VariantToInt64(V,tmp.VInt64) then // also handle varEmpty,varNull - Value := tmp.VInt64 else - case vt of - varDouble,varDate: - Value := TVarData(V).VDouble; - varSingle: - Value := TVarData(V).VSingle; - varCurrency: - Value := TVarData(V).VCurrency; - else begin - if SetVariantUnRefSimpleValue(V,tmp) then - result := VariantToDouble(variant(tmp),Value) else - result := false; - end; - end; - end; -end; - -function VariantToDoubleDef(const V: Variant; const default: double=0): double; -begin - if not VariantToDouble(V,result) then - result := default; -end; - -function VariantToCurrency(const V: Variant; var Value: currency): boolean; -var tmp: TVarData; - vt: cardinal; -begin - vt := TVarData(V).VType; - if vt=varVariant or varByRef then - result := VariantToCurrency(PVariant(TVarData(V).VPointer)^,Value) else begin - result := true; - if VariantToInt64(V,tmp.VInt64) then - Value := tmp.VInt64 else - case vt of - varDouble,varDate: - Value := TVarData(V).VDouble; - varSingle: - Value := TVarData(V).VSingle; - varCurrency: - Value := TVarData(V).VCurrency; - else - if SetVariantUnRefSimpleValue(V,tmp) then - result := VariantToCurrency(variant(tmp),Value) else - result := false; - end; - end; -end; - -function VariantToBoolean(const V: Variant; var Value: Boolean): boolean; -var tmp: TVarData; - vt: cardinal; -begin - vt := TVarData(V).VType; - case vt of - varEmpty, varNull: begin - result := false; - exit; - end; - varBoolean: - Value := TVarData(V).VBoolean; - varInteger: // coming e.g. from GetJsonField() - Value := TVarData(V).VInteger=1; - varString: - Value := IdemPropNameU(RawUTF8(TVarData(V).VAny),BOOL_UTF8[true]); - {$ifndef DELPHI5OROLDER} // WideCompareText() not defined on this old RTL - varOleStr: - Value := WideCompareText(WideString(TVarData(V).VAny),'true')=0; - {$endif DELPHI5OROLDER} - {$ifdef HASVARUSTRING} - varUString: Value := {$ifdef FPC}UnicodeCompareText{$else}CompareText{$endif}( - UnicodeString(TVarData(V).VAny),'true')=0; - {$endif HASVARUSTRING} - else - if SetVariantUnRefSimpleValue(V,tmp) then - if tmp.VType=varBoolean then - Value := tmp.VBoolean else begin - result := false; - exit; - end else begin - result := false; - exit; - end; - end; - result := true; -end; - -function VariantToInt64(const V: Variant; var Value: Int64): boolean; -var tmp: TVarData; - vt: cardinal; -begin - vt := TVarData(V).VType; - case vt of - varNull, - varEmpty: Value := 0; - varBoolean: if TVarData(V).VBoolean then Value := 1 else Value := 0; // normalize - varSmallint: Value := TVarData(V).VSmallInt; - {$ifndef DELPHI5OROLDER} - varShortInt: Value := TVarData(V).VShortInt; - varWord: Value := TVarData(V).VWord; - varLongWord: Value := TVarData(V).VLongWord; - {$endif} - varByte: Value := TVarData(V).VByte; - varInteger: Value := TVarData(V).VInteger; - varWord64: if TVarData(V).VInt64>=0 then - Value := TVarData(V).VInt64 else begin - result := false; - exit; - end; - varInt64: Value := TVarData(V).VInt64; - else - if SetVariantUnRefSimpleValue(V,tmp) then begin - result := VariantToInt64(variant(tmp),Value); - exit; - end else begin - result := false; - exit; - end; - end; - result := true; -end; - -function VariantToInt64Def(const V: Variant; DefaultValue: Int64): Int64; -begin - if not VariantToInt64(V,result) then - result := DefaultValue; -end; - -function VariantToIntegerDef(const V: Variant; DefaultValue: integer): integer; -begin - if not VariantToInteger(V,result) then - result := DefaultValue; -end; - -{$ifndef NOVARIANTS} - -function BinToHexDisplayLowerVariant(Bin: pointer; BinBytes: integer): variant; -begin - RawUTF8ToVariant(BinToHexDisplayLower(Bin,BinBytes),result); -end; - -function VariantHexDisplayToBin(const Hex: variant; Bin: PByte; BinBytes: integer): boolean; -var tmp: RawUTF8; - wasString: boolean; -begin - VariantToUTF8(hex,tmp,wasString); - result := wasstring and HexDisplayToBin(pointer(tmp),Bin,BinBytes); -end; - -function VariantToDateTime(const V: Variant; var Value: TDateTime): boolean; -var tmp: RawUTF8; - vd: TVarData; - vt: cardinal; -begin - vt := TVarData(V).VType; - if vt=varVariant or varByRef then - result := VariantToDateTime(PVariant(TVarData(V).VPointer)^,Value) else begin - result := true; - case vt of - varDouble,varDate: - Value := TVarData(V).VDouble; - varSingle: - Value := TVarData(V).VSingle; - varCurrency: - Value := TVarData(V).VCurrency; - else - if SetVariantUnRefSimpleValue(V,vd) then - result := VariantToDateTime(variant(vd),Value) else begin - VariantToUTF8(V,tmp); - Iso8601ToDateTimePUTF8CharVar(pointer(tmp),length(tmp),Value); - result := Value<>0; - end; - end; - end; -end; - -procedure VariantToInlineValue(const V: Variant; var result: RawUTF8); -var tmp: RawUTF8; - wasString: boolean; -begin - VariantToUTF8(V,tmp,wasString); - if wasString then - QuotedStr(tmp,'"',result) else - result := tmp; -end; - -function VariantToVariantUTF8(const V: Variant): variant; -var tmp: RawUTF8; - wasString: boolean; -begin - VariantToUTF8(V,tmp,wasString); - if wasString then - result := V else - RawUTF8ToVariant(tmp,result); -end; - -procedure VariantToUTF8(const V: Variant; var result: RawUTF8; - var wasString: boolean); -var tmp: TVarData; - vt: cardinal; -begin - wasString := false; - vt := TVarData(V).VType; - with TVarData(V) do - case vt of - varEmpty, - varNull: - result := NULL_STR_VAR; - varSmallint: - Int32ToUTF8(VSmallInt,result); - {$ifndef DELPHI5OROLDER} - varShortInt: - Int32ToUTF8(VShortInt,result); - varWord: - UInt32ToUTF8(VWord,result); - varLongWord: - UInt32ToUTF8(VLongWord,result); - {$endif} - varByte: - result := SmallUInt32UTF8[VByte]; - varBoolean: - if VBoolean then - result := SmallUInt32UTF8[1] else - result := SmallUInt32UTF8[0]; - varInteger: - Int32ToUTF8(VInteger,result); - varInt64: - Int64ToUTF8(VInt64,result); - varWord64: - UInt64ToUTF8(VInt64,result); - varSingle: - ExtendedToStr(VSingle,SINGLE_PRECISION,result); - varDouble: - DoubleToStr(VDouble,result); - varCurrency: - Curr64ToStr(VInt64,result); - varDate: begin - wasString := true; - DateTimeToIso8601TextVar(VDate,'T',result); - end; - varString: begin - wasString := true; - {$ifdef HASCODEPAGE} - AnyAnsiToUTF8(RawByteString(VString),result); - {$else} - result := RawUTF8(VString); - {$endif} - end; - {$ifdef HASVARUSTRING} - varUString: begin - wasString := true; - RawUnicodeToUtf8(VAny,length(UnicodeString(VAny)),result); - end; - {$endif} - varOleStr: begin - wasString := true; - RawUnicodeToUtf8(VAny,length(WideString(VAny)),result); - end; - else - if SetVariantUnRefSimpleValue(V,tmp) then - VariantToUTF8(Variant(tmp),result,wasString) else - if vt=varVariant or varByRef then // complex varByRef - VariantToUTF8(PVariant(VPointer)^,result,wasString) else - if vt=varByRef or varString then begin - wasString := true; - {$ifdef HASCODEPAGE} - AnyAnsiToUTF8(PRawByteString(VString)^,result); - {$else} - result := PRawUTF8(VString)^; - {$endif} - end else - if vt=varByRef or varOleStr then begin - wasString := true; - RawUnicodeToUtf8(pointer(PWideString(VAny)^),length(PWideString(VAny)^),result); - end else - {$ifdef HASVARUSTRING} - if vt=varByRef or varUString then begin - wasString := true; - RawUnicodeToUtf8(pointer(PUnicodeString(VAny)^),length(PUnicodeString(VAny)^),result); - end else - {$endif} - VariantSaveJSON(V,twJSONEscape,result); // will handle also custom types - end; -end; - -function VariantToUTF8(const V: Variant): RawUTF8; -var wasString: boolean; -begin - VariantToUTF8(V,result,wasString); -end; - -function ToUTF8(const V: Variant): RawUTF8; -var wasString: boolean; -begin - VariantToUTF8(V,result,wasString); -end; - -function VariantToUTF8(const V: Variant; var Text: RawUTF8): boolean; -begin - VariantToUTF8(V,Text,result); -end; - -function VariantEquals(const V: Variant; const Str: RawUTF8; - CaseSensitive: boolean): boolean; - function Complex: boolean; - var wasString: boolean; - tmp: RawUTF8; - begin - VariantToUTF8(V,tmp,wasString); - if CaseSensitive then - result := (tmp=Str) else - result := IdemPropNameU(tmp,Str); - end; -var v1,v2: Int64; - vt: cardinal; -begin - vt := TVarData(V).VType; - with TVarData(V) do - case vt of - varEmpty,varNull: - result := Str=''; - varBoolean: - result := VBoolean=(Str<>''); - varString: - if CaseSensitive then - result := RawUTF8(VString)=Str else - result := IdemPropNameU(RawUTF8(VString),Str); - else if VariantToInt64(V,v1) then begin - SetInt64(pointer(Str),v2); - result := v1=v2; - end else - result := Complex; - end; -end; - -function VariantToString(const V: Variant): string; -var wasString: boolean; - tmp: RawUTF8; - vt: cardinal; -begin - vt := TVarData(V).VType; - with TVarData(V) do - case vt of - varEmpty,varNull: - result := ''; // default VariantToUTF8(null)='null' - {$ifdef UNICODE} // not HASVARUSTRING: here we handle string=UnicodeString - varUString: - result := UnicodeString(VAny); - else - if vt=varByRef or varUString then - result := PUnicodeString(VAny)^ - {$endif} - else begin - VariantToUTF8(V,tmp,wasString); - if tmp='' then - result := '' else - UTF8DecodeToString(pointer(tmp),length(tmp),result); - end; - end; -end; - -procedure RawVariantDynArrayClear(V: PVarData; n: integer); -var vt,docv: integer; - handler: TCustomVariantType; -begin - handler := nil; - docv := DocVariantVType; - repeat - vt := V^.VType; - case vt of - varEmpty..varDate,varError,varBoolean,varShortInt..varWord64: ; - varString: {$ifdef FPC}Finalize(RawUTF8(V^.VAny)){$else}RawUTF8(V^.VAny) := ''{$endif}; - varOleStr: WideString(V^.VAny) := ''; - {$ifdef HASVARUSTRING} - varUString: UnicodeString(V^.VAny) := ''; - {$endif} - else - if vt=docv then - DocVariantType.Clear(V^) else - if vt=varVariant or varByRef then - VarClear(PVariant(V^.VPointer)^) else - if handler=nil then - if (vt and varByRef=0) and FindCustomVariantType(vt,handler) then - handler.Clear(V^) else - VarClear(variant(V^)) else - if vt=handler.VarType then - handler.Clear(V^) else - VarClear(variant(V^)); - end; - inc(V); - dec(n); - until n=0; -end; - -procedure VariantDynArrayClear(var Value: TVariantDynArray); -begin - FastDynArrayClear(@Value,TypeInfo(variant)); -end; - -{$endif NOVARIANTS} - -{$ifdef UNICODE} -// this Pos() is seldom used, it was decided to only define it under -// Delphi 2009+ (which expect such a RawUTF8 specific overloaded version) - -function Pos(const substr, str: RawUTF8): Integer; overload; -begin - Result := PosEx(substr,str,1); -end; - -function IntToString(Value: integer): string; -var tmp: array[0..23] of AnsiChar; - P: PAnsiChar; -begin - P := StrInt32(@tmp[23],Value); - Ansi7ToString(PWinAnsiChar(P),@tmp[23]-P,result); -end; - -function IntToString(Value: cardinal): string; -var tmp: array[0..23] of AnsiChar; - P: PAnsiChar; -begin - P := StrUInt32(@tmp[23],Value); - Ansi7ToString(PWinAnsiChar(P),@tmp[23]-P,result); -end; - -function IntToString(Value: Int64): string; -var tmp: array[0..31] of AnsiChar; - P: PAnsiChar; -begin - P := StrInt64(@tmp[31],Value); - Ansi7ToString(PWinAnsiChar(P),@tmp[31]-P,result); -end; - -function DoubleToString(Value: Double): string; -var tmp: ShortString; -begin - if Value=0 then - result := '0' else - Ansi7ToString(PWinAnsiChar(@tmp[1]),DoubleToShort(tmp,Value),result); -end; - -function Curr64ToString(Value: Int64): string; -var tmp: array[0..31] of AnsiChar; -begin - Ansi7ToString(tmp,Curr64ToPChar(Value,tmp),result); -end; - -{$else UNICODE} - -{$ifdef PUREPASCAL} -function IntToString(Value: integer): string; -var tmp: array[0..23] of AnsiChar; - P: PAnsiChar; -begin - if cardinal(Value)<=high(SmallUInt32UTF8) then - result := SmallUInt32UTF8[Value] else begin - P := StrInt32(@tmp[23],Value); - SetString(result,P,@tmp[23]-P); - end; -end; -{$else} -function IntToString(Value: integer): string; {$ifdef FPC} nostackframe; assembler; {$endif} -asm - jmp Int32ToUTF8 -end; -{$endif PUREPASCAL} - -function IntToString(Value: cardinal): string; -var tmp: array[0..23] of AnsiChar; - P: PAnsiChar; -begin - if Value<=high(SmallUInt32UTF8) then - result := SmallUInt32UTF8[Value] else begin - P := StrUInt32(@tmp[23],Value); - SetString(result,P,@tmp[23]-P); - end; -end; - -function IntToString(Value: Int64): string; -var tmp: array[0..31] of AnsiChar; - P: PAnsiChar; -begin - if (Value>=0) and (Value<=high(SmallUInt32UTF8)) then - result := SmallUInt32UTF8[Value] else begin - P := StrInt64(@tmp[31],Value); - SetString(result,P,@tmp[31]-P); - end; -end; - -function DoubleToString(Value: Double): string; -var tmp: ShortString; -begin - if Value=0 then - result := '0' else - SetString(result,PAnsiChar(@tmp[1]),DoubleToShort(tmp,Value)); -end; - -function Curr64ToString(Value: Int64): string; -begin - result := Curr64ToStr(Value); -end; - -{$endif UNICODE} - -procedure bswap64array(a,b: PQWordArray; n: PtrInt); -{$ifdef CPUX86} {$ifdef FPC}nostackframe; assembler;{$endif} -asm - push ebx - push esi -@1: mov ebx, dword ptr[eax] - mov esi, dword ptr[eax + 4] - bswap ebx - bswap esi - mov dword ptr[edx + 4], ebx - mov dword ptr[edx], esi - add eax, 8 - add edx, 8 - dec ecx - jnz @1 - pop esi - pop ebx -end; -{$else} -{$ifdef CPUX64} -{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC} -@1: mov rax, qword ptr[a] - bswap rax - mov qword ptr[b], rax - add a, 8 - add b, 8 - dec n - jnz @1 -end; -{$else} -var i: PtrInt; -begin - for i := 0 to n-1 do - b^[i] := {$ifdef FPC}SwapEndian{$else}bswap64{$endif}(a^[i]); -end; -{$endif CPUX64} -{$endif CPUX86} - -{$ifdef CPUX64} -function bswap32(a: cardinal): cardinal; -{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC} - mov eax, a - bswap eax -end; - -function bswap64(const a: QWord): QWord; {$ifdef FPC}nostackframe; assembler; asm {$else} -asm .noframe // rcx=a (Linux: rdi) -{$endif FPC} - mov rax, a - bswap rax -end; -{$else} -{$ifdef CPUX86} -function bswap32(a: cardinal): cardinal; {$ifdef FPC} nostackframe; assembler; {$endif} -asm - bswap eax -end; - -function bswap64({$ifdef FPC_X86}constref{$else}const{$endif} a: QWord): QWord; -{$ifdef FPC} nostackframe; assembler; {$endif} asm - {$ifdef FPC_X86} - mov edx, dword ptr[eax] - mov eax, dword ptr[eax + 4] - {$else} - mov edx, a.TQWordRec.L - mov eax, a.TQWordRec.H - {$endif FPC_X86} - bswap edx - bswap eax -end; -{$else} -{$ifdef FPC} -function bswap32(a: cardinal): cardinal; -begin - result := SwapEndian(a); // use fast platform-specific function -end; - -function bswap64(const a: QWord): QWord; -begin - result := SwapEndian(a); // use fast platform-specific function -end; -{$else} -function bswap32(a: cardinal): cardinal; -begin - result := ((a and $ff)shl 24)or((a and $ff00)shl 8)or - ((a and $ff0000)shr 8)or((a and $ff000000)shr 24); -end; - -function bswap64(const a: QWord): QWord; -begin - TQWordRec(result).L := bswap32(TQWordRec(a).H); - TQWordRec(result).H := bswap32(TQWordRec(a).L); -end; -{$endif FPC} -{$endif CPUX86} -{$endif CPUX64} - -{$ifndef PUREPASCAL} { these functions are implemented in asm } -{$ifndef LVCL} { don't define these functions twice } -{$ifndef FPC} { some asm functions use some low-level system.pas calls } - -{$define DEFINED_INT32TOUTF8} - -function Int32ToUTF8(Value : PtrInt): RawUtf8; // 3x faster than SysUtils.IntToStr -// from IntToStr32_JOH_IA32_6_a, adapted for Delphi 2009+ -asm // eax=Value, edx=@result - push ebx - push edi - push esi - mov ebx, eax // value - sar ebx, 31 // 0 for +ve value or -1 for -ve value - xor eax, ebx - sub eax, ebx // abs(value) - mov esi, 10 // max dig in result - mov edi, edx // @result - cmp eax, 10 - sbb esi, 0 - cmp eax, 100 - sbb esi, 0 - cmp eax, 1000 - sbb esi, 0 - cmp eax, 10000 - sbb esi, 0 - cmp eax, 100000 - sbb esi, 0 - cmp eax, 1000000 - sbb esi, 0 - cmp eax, 10000000 - sbb esi, 0 - cmp eax, 100000000 - sbb esi, 0 - cmp eax, 1000000000 - sbb esi, ebx // esi=dig (including sign character) - mov ecx, [edx] // result - test ecx, ecx - je @newstr // create new string for result - cmp dword ptr[ecx - 8], 1 - jne @chgstr // reference count <> 1 - cmp esi, [ecx - 4] - je @lenok // existing length = required length - sub ecx, STRRECSIZE // allocation address - push eax // abs(value) - push ecx - mov eax, esp - lea edx, [esi + STRRECSIZE + 1] // new allocation size - call System.@ReallocMem // reallocate result string - pop ecx - pop eax // abs(value) - add ecx, STRRECSIZE // result - mov [ecx - 4], esi // set new length - mov byte ptr[ecx + esi], 0 // add null terminator - mov [edi], ecx // set result address - jmp @lenok -@chgstr:mov edx, dword ptr[ecx - 8] // reference count - add edx, 1 - jz @newstr // refcount = -1 (string constant) -lock dec dword ptr[ecx - 8] // decrement existing reference count -@newstr:push eax // abs(value) - mov eax, esi // length - {$ifdef UNICODE} - mov edx, CP_UTF8 // utf-8 code page for delphi 2009+ - {$endif} - call System.@NewAnsiString - mov [edi], eax // set result address - mov ecx, eax // result - pop eax // abs(value) -@lenok: mov byte ptr[ecx], '-' // store '-' character (may be overwritten) - add esi, ebx // dig (excluding sign character) - sub ecx, ebx // destination of 1st dig - sub esi, 2 // dig (excluding sign character) - 2 - jle @findig // 1 or 2 dig value - cmp esi, 8 // 10 dig value? - jne @setres // not a 10 dig value - sub eax, 2000000000 // dig 10 must be either '1' or '2' - mov dl, '2' - jnc @set10 // dig 10 = '2' - mov dl, '1' // dig 10 = '1' - add eax, 1000000000 -@set10: mov [ecx], dl // save dig 10 - mov esi, 7 // 9 dig remaining - add ecx, 1 // destination of 2nd dig -@setres:mov edi, $28f5c29 // ((2^32)+100-1)/100 -@loop: mov ebx, eax // dividend - mul edi // edx = dividend div 100 - mov eax, edx // set next dividend - imul edx, -200 // -2 * (100 * dividend div 100) - movzx edx, word ptr[TwoDigitLookup + ebx * 2 + edx] // dividend mod 100 in ascii - mov [ecx + esi], dx - sub esi, 2 - jg @loop // loop until 1 or 2 dig remaining -@findig:pop esi - pop edi - pop ebx - jnz @last - movzx eax, word ptr[TwoDigitLookup + eax * 2] - mov [ecx], ax // save final 2 dig - ret -@last: or al, '0' // ascii adjustment - mov [ecx], al // save final dig -end; - -function Int64ToUTF8(Value: Int64): RawUtf8; -asm // from IntToStr64_JOH_IA32_6_b, adapted for Delphi 2009+ - push ebx - mov ecx, [ebp + 8] // low integer of val - mov edx, [ebp + 12] // high integer of val - xor ebp, ebp // clear sign flag (ebp already pushed) - mov ebx, ecx // low integer of val - test edx, edx - jnl @absval - mov ebp, 1 // ebp = 1 for -ve val or 0 for +ve val - neg ecx - adc edx, 0 - neg edx -@absval:jnz @large // edx:ecx = abs(val) - test ecx, ecx - js @large - mov edx, eax // @result - mov eax, ebx // low integer of val - call Int32ToUtf8 // call fastest integer inttostr function - pop ebx -@exit: pop ebp // restore stack and exit - ret 8 -@large: push edi - push esi - mov edi, eax - xor ebx, ebx - xor eax, eax -@t15: cmp edx, $00005af3 // test for 15 or more dig - jne @chk15 // 100000000000000 div $100000000 - cmp ecx, $107a4000 // 100000000000000 mod $100000000 -@chk15: jb @t13 -@t17: cmp edx, $002386f2 // test for 17 or more dig - jne @chk17 // 10000000000000000 div $100000000 - cmp ecx, $6fc10000 // 10000000000000000 mod $100000000 -@chk17: jb @t1516 -@t19: cmp edx, $0de0b6b3 // test for 19 dig - jne @chk19 // 1000000000000000000 div $100000000 - cmp ecx, $a7640000 // 1000000000000000000 mod $100000000 -@chk19: jb @t1718 - mov al, 19 - jmp @setl2 -@t1718: mov bl, 18 // 17 or 18 dig - cmp edx, $01634578 // 100000000000000000 div $100000000 - jne @setlen - cmp ecx, $5d8a0000 // 100000000000000000 mod $100000000 - jmp @setlen -@t1516: mov bl, 16 // 15 or 16 dig - cmp edx, $00038d7e // 1000000000000000 div $100000000 - jne @setlen - cmp ecx, $a4c68000 // 1000000000000000 mod $100000000 - jmp @setlen -@t13: cmp edx, $000000e8 // test for 13 or more dig - jne @chk13 // 1000000000000 div $100000000 - cmp ecx, $d4a51000 // 1000000000000 mod $100000000 -@chk13: jb @t11 -@t1314: mov bl, 14 // 13 or 14 dig - cmp edx, $00000918 // 10000000000000 div $100000000 - jne @setlen - cmp ecx, $4e72a000 // 10000000000000 mod $100000000 - jmp @setlen -@t11: cmp edx, $02 // 10, 11 or 12 dig - jne @chk11 // 10000000000 div $100000000 - cmp ecx, $540be400 // 10000000000 mod $100000000 -@chk11: mov bl, 11 - jb @setlen // 10 dig -@t1112: mov bl, 12 // 11 or 12 dig - cmp edx, $17 // 100000000000 div $100000000 - jne @setlen - cmp ecx, $4876e800 // 100000000000 mod $100000000 -@setlen:sbb eax, 0 // adjust for odd/evem digit count - add eax, ebx -@setl2: push ecx // abs(val) in edx:ecx, dig in eax - push edx // save abs(val) - lea edx, [eax + ebp] // digit needed (including sign character) - mov ecx, [edi] // @result - mov esi, edx // digit needed (including sign character) - test ecx, ecx - je @newstr // create new ansistring for result - cmp dword ptr[ecx - 8], 1 - jne @chgstr // reference count <> 1 - cmp esi, [ecx - 4] - je @lenok // existing length = required length - sub ecx, STRRECSIZE // allocation address - push eax // abs(val) - push ecx - mov eax, esp - lea edx, [esi + STRRECSIZE + 1] // new allocation size - call System.@ReallocMem // reallocate result ansistring - pop ecx - pop eax // abs(val) - add ecx, STRRECSIZE // @result - mov [ecx - 4], esi // set new length - mov byte ptr[ecx + esi], 0 // add null terminator - mov [edi], ecx // set result address - jmp @lenok -@chgstr:mov edx, dword ptr[ecx - 8] // reference count - add edx, 1 - jz @newstr // refcount = -1 (ansistring constant) -lock dec dword ptr[ecx - 8] // decrement existing reference count -@newstr:push eax // abs(val) - mov eax, esi // length - {$ifdef UNICODE} - mov edx, CP_UTF8 // utf-8 code page for delphi 2009+ - {$endif} - call System.@NewAnsiString - mov [edi], eax // set result address - mov ecx, eax // @result - pop eax // abs(val) -@lenok: mov edi, [edi] // @result - sub esi, ebp // digit needed (excluding sign character) - mov byte ptr[edi], '-' // store '-' character (may be overwritten) - add edi, ebp // destination of 1st digit - pop edx // restore abs(val) - pop eax - cmp esi, 17 - jl @less17 // dig < 17 - je @set17 // dig = 17 - cmp esi, 18 - je @set18 // dig = 18 - mov cl, '0' - 1 - mov ebx, $a7640000 // 1000000000000000000 mod $100000000 - mov ebp, $0de0b6b3 // 1000000000000000000 div $100000000 -@dig19: add ecx, 1 - sub eax, ebx - sbb edx, ebp - jnc @dig19 - add eax, ebx - adc edx, ebp - mov [edi], cl - add edi, 1 -@set18: mov cl, '0' - 1 - mov ebx, $5d8a0000 // 100000000000000000 mod $100000000 - mov ebp, $01634578 // 100000000000000000 div $100000000 -@dig18: add ecx, 1 - sub eax, ebx - sbb edx, ebp - jnc @dig18 - add eax, ebx - adc edx, ebp - mov [edi], cl - add edi, 1 -@set17: mov cl, '0' - 1 - mov ebx, $6fc10000 // 10000000000000000 mod $100000000 - mov ebp, $002386f2 // 10000000000000000 div $100000000 -@dig17: add ecx, 1 - sub eax, ebx - sbb edx, ebp - jnc @dig17 - add eax, ebx - adc edx, ebp - mov [edi], cl - add edi, 1 // update destination - mov esi, 16 // set 16 dig left -@less17:mov ecx, 100000000 // process next 8 dig - div ecx // edx:eax = abs(val) = dividend - mov ebp, eax // dividend div 100000000 - mov ebx, edx - mov eax, edx // dividend mod 100000000 - mov edx, $51eb851f - mul edx - shr edx, 5 // dividend div 100 - mov eax, edx // set next dividend - lea edx, [edx * 4 + edx] - lea edx, [edx * 4 + edx] - shl edx, 2 // dividend div 100 * 100 - sub ebx, edx // remainder (0..99) - movzx ebx, word ptr[TwoDigitLookup + ebx * 2] - shl ebx, 16 - mov edx, $51eb851f - mov ecx, eax // dividend - mul edx - shr edx, 5 // dividend div 100 - mov eax, edx - lea edx, [edx * 4 + edx] - lea edx, [edx * 4 + edx] - shl edx, 2 // dividend div 100 * 100 - sub ecx, edx // remainder (0..99) - or bx, word ptr[TwoDigitLookup + ecx * 2] - mov [edi + esi - 4], ebx // store 4 dig - mov ebx, eax - mov edx, $51eb851f - mul edx - shr edx, 5 // edx = dividend div 100 - lea eax, [edx * 4 + edx] - lea eax, [eax * 4 + eax] - shl eax, 2 // eax = dividend div 100 * 100 - sub ebx, eax // remainder (0..99) - movzx ebx, word ptr[TwoDigitLookup + ebx * 2] - movzx ecx, word ptr[TwoDigitLookup + edx * 2] - shl ebx, 16 - or ebx, ecx - mov [edi + esi - 8], ebx // store 4 dig - mov eax, ebp // remainder - sub esi, 10 // dig left - 2 - jz @last2 -@small: mov edx, $28f5c29 // ((2^32)+100-1)/100 - mov ebx, eax // dividend - mul edx - mov eax, edx // set next dividend - imul edx, -200 - movzx edx, word ptr[TwoDigitLookup + ebx * 2 + edx] // dividend mod 100 in ascii - mov [edi + esi], dx - sub esi, 2 - jg @small // repeat until less than 2 dig remaining - jz @last2 - or al, '0' // ascii adjustment - mov [edi], al // save final digit - jmp @done -@last2: movzx eax, word ptr[TwoDigitLookup + eax * 2] - mov [edi], ax // save final 2 dig -@done: pop esi - pop edi - pop ebx -end; - -function Trim(const S: RawUTF8): RawUTF8; -asm // fast implementation by John O'Harrow, modified for Delphi 2009+ - test eax, eax // S = nil? - xchg eax, edx - jz System.@LStrClr // Yes, Return Empty String - mov ecx, [edx - 4] // Length(S) - cmp byte ptr[edx], ' ' // S[1] <= ' '? - jbe @left // Yes, Trim Leading Spaces - cmp byte ptr[edx + ecx - 1], ' ' // S[Length(S)] <= ' '? - jbe @right // Yes, Trim Trailing Spaces - jmp System.@LStrLAsg // No, Result := S (which occurs most time) -@left: dec ecx // Strip Leading Whitespace - jle System.@LStrClr // All Whitespace - inc edx - cmp byte ptr[edx], ' ' - jbe @left -@done: cmp byte ptr[edx + ecx - 1], ' ' -{$ifdef UNICODE} - jbe @right - push CP_UTF8 // UTF-8 code page for Delphi 2009+ - call System.@LStrFromPCharLen // we need a call, not a jmp here - rep ret -{$else} ja System.@LStrFromPCharLen -{$endif} -@right: dec ecx // Strip Trailing Whitespace - jmp @done -end; - -{$endif FPC} { above asm function had some low-level system.pas calls } - -{$endif LVCL} -{$endif PUREPASCAL} - -function CompareMemSmall(P1, P2: Pointer; Length: PtrUInt): Boolean; -label zero; -var c: AnsiChar; // explicit temp variable for better FPC code generation -begin - {$ifndef CPUX86} result := false; {$endif} - inc(PtrUInt(P1),PtrUInt(Length)); - inc(PtrUInt(P2),PtrUInt(Length)); - Length := -Length; - if Length<>0 then - repeat - c := PAnsiChar(P1)[Length]; - if c<>PAnsiChar(P2)[Length] then - goto zero; - inc(Length); - until Length=0; - result := true; - {$ifdef CPUX86} exit; {$endif} -zero: - {$ifdef CPUX86} result := false; {$endif} -end; - -{$ifdef HASINLINE} -procedure FillZero(var dest; count: PtrInt); -begin - FillCharFast(dest,count,0); -end; -{$else} -procedure FillZero(var dest; count: PtrInt); -asm - xor ecx, ecx - jmp dword ptr [FillCharFast] -end; -{$endif} - -function IsEqual(const A,B; count: PtrInt): boolean; -var perbyte: boolean; // ensure no optimization takes place -begin - result := true; - while count>0 do begin - dec(count); - perbyte := PByteArray(@A)[count]=PByteArray(@B)[count]; - result := result and perbyte; - end; -end; - -function PosCharAny(Str: PUTF8Char; Characters: PAnsiChar): PUTF8Char; -var s: PAnsiChar; - c: AnsiChar; -begin - if (Str<>nil) and (Characters<>nil) and (Characters^<>#0) then - repeat - c := Str^; - if c=#0 then - break; - s := Characters; - repeat - if s^=c then begin - result := Str; - exit; - end; - inc(s); - until s^=#0; - inc(Str); - until false; - result := nil; -end; - -function StringReplaceChars(const Source: RawUTF8; OldChar, NewChar: AnsiChar): RawUTF8; -var i,j,n: PtrInt; -begin - if (OldChar<>NewChar) and (Source<>'') then begin - n := length(Source); - for i := 0 to n-1 do - if PAnsiChar(pointer(Source))[i]=OldChar then begin - FastSetString(result,PAnsiChar(pointer(Source)),n); - for j := i to n-1 do - if PAnsiChar(pointer(result))[j]=OldChar then - PAnsiChar(pointer(result))[j] := NewChar; - exit; - end; - end; - result := Source; -end; - -function IdemPChar2(table: PNormTable; p: PUTF8Char; up: PAnsiChar): boolean; - {$ifdef HASINLINE}inline;{$endif} -var u: AnsiChar; -begin // here p and up are expected to be <> nil - result := false; - dec(PtrUInt(p),PtrUInt(up)); - repeat - u := up^; - if u=#0 then - break; - if table^[up[PtrUInt(p)]]<>u then - exit; - inc(up); - until false; - result := true; -end; - -function PosI(uppersubstr: PUTF8Char; const str: RawUTF8): PtrInt; -var u: AnsiChar; - table: {$ifdef CPUX86NOTPIC}TNormTable absolute NormToUpperAnsi7{$else}PNormTable{$endif}; -begin - if uppersubstr<>nil then begin - {$ifndef CPUX86NOTPIC}table := @NormToUpperAnsi7;{$endif} - u := uppersubstr^; - for result := 1 to Length(str) do - if table[str[result]]=u then - if {$ifdef CPUX86NOTPIC}IdemPChar({$else}IdemPChar2(table,{$endif} - @PUTF8Char(pointer(str))[result],PAnsiChar(uppersubstr)+1) then - exit; - end; - result := 0; -end; - -function StrPosI(uppersubstr,str: PUTF8Char): PUTF8Char; -var u: AnsiChar; - table: {$ifdef CPUX86NOTPIC}TNormTable absolute NormToUpperAnsi7{$else}PNormTable{$endif}; -begin - if (uppersubstr<>nil) and (str<>nil) then begin - {$ifndef CPUX86NOTPIC}table := @NormToUpperAnsi7;{$endif} - u := uppersubstr^; - inc(uppersubstr); - result := str; - while result^<>#0 do begin - if table[result^]=u then - if {$ifdef CPUX86NOTPIC}IdemPChar({$else}IdemPChar2(table,{$endif} - result+1,PAnsiChar(uppersubstr)) then - exit; - inc(result); - end; - end; - result := nil; -end; - -function PosIU(substr: PUTF8Char; const str: RawUTF8): Integer; -var p: PUTF8Char; -begin - if (substr<>nil) and (str<>'') then begin - p := pointer(str); - repeat - if GetNextUTF8Upper(p)=ord(substr^) then - if IdemPCharU(p,substr+1) then begin - result := p-pointer(str); - exit; - end; - until p^=#0; - end; - result := 0; -end; - -// same as PosExPas() but using char/PChar for (unicode)string process -function PosExStringPas(pSub, p: PChar; Offset: PtrUInt): PtrInt; -var len, lenSub: PtrInt; - ch: char; - pStart, pStop: PChar; -label Loop2, Loop6, TestT, Test0, Test1, Test2, Test3, Test4, - AfterTestT, AfterTest0, Ret, Exit; -begin - result := 0; - if (p=nil) or (pSub=nil) or (PtrInt(Offset)<=0) then - goto Exit; - len := PStrLen(PtrUInt(p)-_STRLEN)^; - lenSub := PStrLen(PtrUInt(pSub)-_STRLEN)^-1; - if (len=pStop then goto Exit; - goto Loop2; -Test4: dec(p,2); -Test2: dec(p,2); - goto Test0; -Test3: dec(p,2); -Test1: dec(p,2); -TestT: len := lenSub; - if lenSub<>0 then - repeat - if (psub[len]<>p[len+1]) or (psub[len+1]<>p[len+2]) then - goto AfterTestT; - inc(len,2); - until len>=0; - inc(p,2); - if p<=pStop then goto Ret; - goto Exit; -Test0: len := lenSub; - if lenSub<>0 then - repeat - if (psub[len]<>p[len]) or (psub[len+1]<>p[len+1]) then - goto AfterTest0; - inc(len,2); - until len>=0; - inc(p); -Ret: - result := p-pStart; -Exit: -end; - -procedure AppendCharToRawUTF8(var Text: RawUTF8; Ch: AnsiChar); -var L: PtrInt; -begin - L := length(Text); - SetLength(Text,L+1); // reallocate - PByteArray(Text)[L] := ord(Ch); -end; - -procedure AppendBufferToRawUTF8(var Text: RawUTF8; Buffer: pointer; BufferLen: PtrInt); -var L: PtrInt; -begin - if BufferLen<=0 then - exit; - L := length(Text); - SetLength(Text,L+BufferLen); - MoveFast(Buffer^,pointer(PtrInt(Text)+L)^,BufferLen); -end; - -procedure AppendBuffersToRawUTF8(var Text: RawUTF8; const Buffers: array of PUTF8Char); -var i,len,TextLen: PtrInt; - lens: array[0..63] of integer; - P: PUTF8Char; -begin - if high(Buffers)>high(lens) then - raise ESynException.Create('Too many params in AppendBuffersToRawUTF8()'); - len := 0; - for i := 0 to high(Buffers) do begin - lens[i] := StrLen(Buffers[i]); - inc(len,lens[i]); - end; - TextLen := Length(Text); - SetLength(Text,TextLen+len); - P := pointer(Text); - inc(P,TextLen); - for i := 0 to high(Buffers) do - if Buffers[i]<>nil then begin - MoveFast(Buffers[i]^,P^,lens[i]); - inc(P,lens[i]); - end; -end; - -function AppendRawUTF8ToBuffer(Buffer: PUTF8Char; const Text: RawUTF8): PUTF8Char; -var L: PtrInt; -begin - L := length(Text); - if L<>0 then begin - MoveFast(Pointer(Text)^,Buffer^,L); - inc(Buffer,L); - end; - result := Buffer; -end; - -function AppendUInt32ToBuffer(Buffer: PUTF8Char; Value: PtrUInt): PUTF8Char; -var L: PtrInt; - P: PAnsiChar; - tmp: array[0..23] of AnsiChar; -begin - if Value<=high(SmallUInt32UTF8) then begin - P := pointer(SmallUInt32UTF8[Value]); - L := PStrLen(P-_STRLEN)^; - end else begin - P := StrUInt32(@tmp[23],Value); - L := @tmp[23]-P; - end; - result := Buffer; - repeat - result^ := P^; - inc(result); - inc(P); - dec(L); - until L=0; -end; - -function Append999ToBuffer(Buffer: PUTF8Char; Value: PtrUInt): PUTF8Char; -var L: PtrInt; - P: PAnsiChar; - c: cardinal; -begin - P := pointer(SmallUInt32UTF8[Value]); - L := PStrLen(P-_STRLEN)^; - c := PCardinal(P)^; - Buffer[0] := AnsiChar(c); // PCardinal() write = FastMM4 FullDebugMode errors - inc(Buffer); - if L>1 then begin - Buffer^ := AnsiChar(c shr 8); - inc(Buffer); - if L>2 then begin - Buffer^ := AnsiChar(c shr 16); - inc(Buffer); - end; - end; - result := pointer(Buffer); -end; - -function QuotedStr(const S: RawUTF8; Quote: AnsiChar): RawUTF8; -begin - QuotedStr(S,Quote,result); -end; - -procedure QuotedStr(const S: RawUTF8; Quote: AnsiChar; var result: RawUTF8); -var i,L,quote1,nquote: PtrInt; - P,R: PUTF8Char; - tmp: pointer; // will hold a RawUTF8 with no try..finally exception block - c: AnsiChar; -begin - tmp := nil; - L := length(S); - P := pointer(S); - if (P<>nil) and (P=pointer(result)) then begin - RawUTF8(tmp) := S; // make private ref-counted copy for QuotedStr(U,'"',U) - P := pointer(tmp); - end; - nquote := 0; - {$ifdef FPC} // will use fast FPC SSE version - quote1 := IndexByte(P^,L,byte(Quote)); - if quote1>=0 then - for i := quote1 to L-1 do - if P[i]=Quote then - inc(nquote); - {$else} - quote1 := 0; - for i := 0 to L-1 do - if P[i]=Quote then begin - if nquote=0 then - quote1 := i; - inc(nquote); - end; - {$endif} - FastSetString(result,nil,L+nquote+2); - R := pointer(result); - R^ := Quote; - inc(R); - if nquote=0 then begin - MoveFast(P^,R^,L); - R[L] := Quote; - end else begin - MoveFast(P^,R^,quote1); - inc(R,quote1); - inc(quote1,PtrInt(P)); // trick for reusing a register on FPC - repeat - c := PAnsiChar(quote1)^; - if c=#0 then - break; - inc(quote1); - R^ := c; - inc(R); - if c<>Quote then - continue; - R^ := c; - inc(R); - until false; - R^ := Quote; - end; - if tmp<>nil then - {$ifdef FPC}Finalize(RawUTF8(tmp)){$else}RawUTF8(tmp) := ''{$endif}; -end; - -function GotoEndOfQuotedString(P: PUTF8Char): PUTF8Char; -var quote: AnsiChar; -begin // P^=" or P^=' at function call - quote := P^; - inc(P); - repeat - if P^=#0 then - break else - if P^<>quote then - inc(P) else - if P[1]=quote then // allow double quotes inside string - inc(P,2) else - break; // end quote - until false; - result := P; -end; // P^='"' at function return - -procedure QuotedStrJSON(P: PUTF8Char; PLen: PtrInt; var result: RawUTF8; - const aPrefix, aSuffix: RawUTF8); -var temp: TTextWriterStackBuffer; - Lp,Ls: PtrInt; - D: PUTF8Char; -begin - if (P=nil) or (PLen<=0) then - result := '""' else - if (pointer(result)=pointer(P)) or NeedsJsonEscape(P,PLen) then - with TTextWriter.CreateOwnedStream(temp) do - try - AddString(aPrefix); - Add('"'); - AddJSONEscape(P,PLen); - Add('"'); - AddString(aSuffix); - SetText(result); - exit; - finally - Free; - end else begin - Lp := length(aPrefix); - Ls := length(aSuffix); - FastSetString(result,nil,PLen+Lp+Ls+2); - D := pointer(result); // we checked dest result <> source P above - if Lp>0 then begin - MoveFast(pointer(aPrefix)^,D^,Lp); - inc(D,Lp); - end; - D^ := '"'; - MoveFast(P^,D[1],PLen); - inc(D,PLen); - D[1] := '"'; - if Ls>0 then - MoveFast(pointer(aSuffix)^,D[2],Ls); - end; -end; - -procedure QuotedStrJSON(const aText: RawUTF8; var result: RawUTF8; - const aPrefix, aSuffix: RawUTF8); -begin - QuotedStrJSON(pointer(aText),Length(aText),result,aPrefix,aSuffix); -end; - -function QuotedStrJSON(const aText: RawUTF8): RawUTF8; -begin - QuotedStrJSON(pointer(aText),Length(aText),result,'',''); -end; - -function GotoEndOfJSONString(P: PUTF8Char): PUTF8Char; -var c: AnsiChar; -begin // P^='"' at function call - inc(P); - repeat - c := P^; - if c=#0 then - break else - if c<>'\' then - if c<>'"' then // ignore \" - inc(P) else - break else // found ending " - if P[1]=#0 then // avoid potential buffer overflow issue for \#0 - break else - inc(P,2); // ignore \? - until false; - result := P; -end; // P^='"' at function return - -function GotoNextNotSpace(P: PUTF8Char): PUTF8Char; -begin - {$ifdef FPC} - while (P^<=' ') and (P^<>#0) do inc(P); - {$else} - if P^ in [#1..' '] then - repeat - inc(P) - until not(P^ in [#1..' ']); - {$endif} - result := P; -end; - -function GotoNextNotSpaceSameLine(P: PUTF8Char): PUTF8Char; -begin - while P^ in [#9,' '] do inc(P); - result := P; -end; - -function GotoNextSpace(P: PUTF8Char): PUTF8Char; -begin - if P^>' ' then - repeat - inc(P) - until P^<=' '; - result := P; -end; - -function NextNotSpaceCharIs(var P: PUTF8Char; ch: AnsiChar): boolean; -begin - while (P^<=' ') and (P^<>#0) do inc(P); - if P^=ch then begin - inc(P); - result := true; - end else - result := false; -end; - -function UnQuoteSQLStringVar(P: PUTF8Char; out Value: RawUTF8): PUTF8Char; -var quote: AnsiChar; - PBeg, PS: PUTF8Char; - internalquote: PtrInt; -begin - if P=nil then begin - result := nil; - exit; - end; - quote := P^; // " or ' - inc(P); - // compute unquoted string length - PBeg := P; - internalquote := 0; - repeat - if P^=#0 then - break; - if P^<>quote then - inc(P) else - if P[1]=quote then begin - inc(P,2); // allow double quotes inside string - inc(internalquote); - end else - break; // end quote - until false; - if P^=#0 then begin - result := nil; // end of string before end quote -> incorrect - exit; - end; - // create unquoted string - if internalquote=0 then - // no quote within - FastSetString(Value,PBeg,P-PBeg) else begin - // unescape internal quotes - SetLength(Value,P-PBeg-internalquote); - P := PBeg; - PS := Pointer(Value); - repeat - if P^=quote then - if P[1]=quote then - inc(P) else // allow double quotes inside string - break; // end quote - PS^ := P^; - inc(PByte(PS)); - inc(P); - until false; - end; - result := P+1; -end; - -function UnQuoteSQLString(const Value: RawUTF8): RawUTF8; -begin - UnQuoteSQLStringVar(pointer(Value),result); -end; - -function UnQuotedSQLSymbolName(const ExternalDBSymbol: RawUTF8): RawUTF8; -begin - if (ExternalDBSymbol<>'') and - (ExternalDBSymbol[1] in ['[','"','''','(']) then // e.g. for ZDBC's GetFields() - result := copy(ExternalDBSymbol,2,length(ExternalDBSymbol)-2) else - result := ExternalDBSymbol; -end; - -function isSelect(P: PUTF8Char; SelectClause: PRawUTF8): boolean; -var from: PUTF8Char; -begin - if P<>nil then begin - P := SQLBegin(P); - case IdemPCharArray(P, ['SELECT','EXPLAIN ','VACUUM','PRAGMA','WITH','EXECUTE']) of - 0: if P[6]<=' ' then begin - if SelectClause<>nil then begin - inc(P,7); - from := StrPosI(' FROM ',P); - if from=nil then - SelectClause^ := '' else - FastSetString(SelectClause^,P,from-P); - end; - result := true; - end else - result := false; - 1: result := true; - 2,3: result := P[6] in [#0..' ',';']; - 4: result := (P[4]<=' ') and not (StrPosI('INSERT',P+5)<>nil) or - (StrPosI('UPDATE',P+5)<>nil) or (StrPosI('DELETE',P+5)<>nil); - 5: begin // FireBird specific - P := GotoNextNotSpace(P+7); - result := IdemPChar(P,'BLOCK') and IdemPChar(GotoNextNotSpace(P+5),'RETURNS'); - end - else result := false; - end; - end else - result := true; // assume '' statement is SELECT command -end; - -function SQLBegin(P: PUTF8Char): PUTF8Char; -begin - if P<>nil then - repeat - if P^<=' ' then // ignore blanks - repeat - if P^=#0 then - break else - inc(P) - until P^>' '; - if PWord(P)^=ord('-')+ord('-')shl 8 then // SQL comments - repeat - inc(P) - until P^ in [#0,#10] - else - if PWord(P)^=ord('/')+ord('*')shl 8 then begin // C comments - inc(P); - repeat - inc(P); - if PWord(P)^=ord('*')+ord('/')shl 8 then begin - inc(P,2); - break; - end; - until P^=#0; - end - else break; - until false; - result := P; -end; - -procedure SQLAddWhereAnd(var where: RawUTF8; const condition: RawUTF8); -begin - if where='' then - where := condition else - where := where+' and '+condition; -end; - -procedure Base64MagicDecode(var ParamValue: RawUTF8); -var - tmp: RawUTF8; -begin // '\uFFF0base64encodedbinary' decode into binary (input shall have been checked) - tmp := ParamValue; - if not Base64ToBinSafe(PAnsiChar(pointer(tmp))+3,length(tmp)-3,RawByteString(ParamValue)) then - ParamValue := ''; -end; - -function Base64MagicCheckAndDecode(Value: PUTF8Char; var Blob: RawByteString): boolean; -var ValueLen: integer; -begin // '\uFFF0base64encodedbinary' checked and decode into binary - if (Value=nil) or (Value[0]=#0) or (Value[1]=#0) or (Value[2]=#0) or - (PCardinal(Value)^ and $ffffff<>JSON_BASE64_MAGIC) then - result := false else begin - ValueLen := StrLen(Value)-3; - if ValueLen>0 then - result := Base64ToBinSafe(PAnsiChar(Value)+3,ValueLen,Blob) else - result := false; - end; -end; - -function Base64MagicCheckAndDecode(Value: PUTF8Char; var Blob: TSynTempBuffer): boolean; -var ValueLen: integer; -begin // '\uFFF0base64encodedbinary' checked and decode into binary - if (Value=nil) or (Value[0]=#0) or (Value[1]=#0) or (Value[2]=#0) or - (PCardinal(Value)^ and $ffffff<>JSON_BASE64_MAGIC) then - result := false else begin - ValueLen := StrLen(Value)-3; - if ValueLen>0 then - result := Base64ToBin(PAnsiChar(Value)+3,ValueLen,Blob) else - result := false; - end; -end; - -function Base64MagicCheckAndDecode(Value: PUTF8Char; ValueLen: integer; - var Blob: RawByteString): boolean; -begin // '\uFFF0base64encodedbinary' checked and decode into binary - if (ValueLen<4) or (PCardinal(Value)^ and $ffffff<>JSON_BASE64_MAGIC) then - result := false else - result := Base64ToBinSafe(PAnsiChar(Value)+3,ValueLen-3,Blob); -end; - -{$ifndef DEFINED_INT32TOUTF8} - -function Int32ToUtf8(Value: PtrInt): RawUTF8; // faster than SysUtils.IntToStr -var tmp: array[0..23] of AnsiChar; - P: PAnsiChar; -begin - if PtrUInt(Value)<=high(SmallUInt32UTF8) then - result := SmallUInt32UTF8[Value] else begin - P := StrInt32(@tmp[23],Value); - FastSetString(result,P,@tmp[23]-P); - end; -end; - -function Int64ToUtf8(Value: Int64): RawUTF8; // faster than SysUtils.IntToStr -begin - Int64ToUtf8(Value,result); -end; - -function Trim(const S: RawUTF8): RawUTF8; -var I,L: PtrInt; -begin - L := Length(S); - I := 1; - while (I<=L) and (S[I]<=' ') do inc(I); - if I>L then // void string - result := '' else - if (I=1) and (S[L]>' ') then // nothing to trim - result := S else begin - while S[L]<=' ' do dec(L); // allocated trimmed - result := Copy(S,I,L-I+1); - end; -end; - -{$endif DEFINED_INT32TOUTF8} - -{$ifndef CPU64} // already implemented by ToUTF8(Value: PtrInt) below -function ToUTF8(Value: Int64): RawUTF8; -begin - Int64ToUTF8(Value,result); -end; -{$endif CPU64} - -function ToUTF8(Value: PtrInt): RawUTF8; -begin - Int32ToUTF8(Value,result); -end; - -procedure UInt32ToUtf8(Value: PtrUInt; var result: RawUTF8); -var tmp: array[0..23] of AnsiChar; - P: PAnsiChar; -begin - if Value<=high(SmallUInt32UTF8) then - result := SmallUInt32UTF8[Value] else begin - P := StrUInt32(@tmp[23],Value); - FastSetString(result,P,@tmp[23]-P); - end; -end; - -function UInt32ToUtf8(Value: PtrUInt): RawUTF8; -begin - UInt32ToUTF8(Value,result); -end; - -{$ifndef EXTENDEDTOSHORT_USESTR} -var // standard FormatSettings: force US decimal display (with '.' for floats) - SettingsUS: TFormatSettings; -{$endif EXTENDEDTOSHORT_USESTR} - -function FloatStringNoExp(S: PAnsiChar; Precision: PtrInt): PtrInt; -var i, prec: PtrInt; - c: AnsiChar; -begin - result := ord(S[0]); - prec := result; // if no decimal - if S[1]='-' then - dec(prec); - for i := 2 to result do begin // test if scientific format -> return as this - c := S[i]; - if c='E' then // should not appear - exit else - if c='.' then - if i>=precision then begin // return huge decimal number as is - result := i-1; - exit; - end else - dec(prec); - end; - if (prec>=Precision) and (prec<>result) then begin - dec(result,prec-Precision); - if S[result+1]>'5' then begin // manual rounding - prec := result; - repeat - c := S[prec]; - if c<>'.' then - if c='9' then begin - S[prec] := '0'; - if ((prec=2) and (S[1]='-')) or (prec=1) then begin - i := result; - inc(S,prec); - repeat // inlined Move(S[prec],S[prec+1],result); - S[i] := S[i-1]; - dec(i); - until i=0; - S^ := '1'; - dec(S,prec); - break; - end; - end else - if (c>='0') and (c<='8') then begin - inc(S[prec]); - break; - end else - break; - dec(prec); - until prec=0; - end; // note: this fixes http://stackoverflow.com/questions/2335162 - end; - if S[result]='0' then - repeat - dec(result); // trunc any trimming 0 - c := S[result]; - if c<>'.' then - if c<>'0' then - break else - continue else begin - dec(result); - if (result=2) and (S[1]='-') and (S[2]='0') then begin - result := 1; - S[1] := '0'; // '-0.000' -> '0' - end; - break; // if decimal are all '0' -> return only integer part - end; - until false; -end; - -function ExtendedToShortNoExp(var S: ShortString; Value: TSynExtended; - Precision: integer): integer; -begin - {$ifdef DOUBLETOSHORT_USEGRISU} - if Precision=DOUBLE_PRECISION then - DoubleToAscii(0,Precision,Value,@S) else - {$endif DOUBLETOSHORT_USEGRISU} - str(Value:0:Precision,S); // not str(Value:0,S) -> ' 0.0E+0000' - result := FloatStringNoExp(@S,Precision); - S[0] := AnsiChar(result); -end; - -const // range when to switch into scientific notation - minimal 6 digits - SINGLE_HI: TSynExtended = 1E3; // for proper Delphi 5 compilation - SINGLE_LO: TSynExtended = 1E-3; - DOUBLE_HI: TSynExtended = 1E9; - DOUBLE_LO: TSynExtended = 1E-9; - EXT_HI: TSynExtended = 1E12; - EXT_LO: TSynExtended = 1E-12; - -function ExtendedToShort(var S: ShortString; Value: TSynExtended; - Precision: integer): integer; -{$ifdef EXTENDEDTOSHORT_USESTR} -var scientificneeded: boolean; - valueabs: TSynExtended; -begin - {$ifdef DOUBLETOSHORT_USEGRISU} - if Precision=DOUBLE_PRECISION then begin - result := DoubleToShort(S,Value); - exit; - end; - {$endif DOUBLETOSHORT_USEGRISU} - if Value=0 then begin - PWord(@s)^ := 1 + ord('0') shl 8; - result := 1; - exit; - end; - scientificneeded := false; - valueabs := abs(Value); - if Precision<=SINGLE_PRECISION then begin - if (valueabs>SINGLE_HI) or (valueabsDOUBLE_PRECISION then begin - if (valueabs>EXT_HI) or (valueabsDOUBLE_HI) or (valueabs ' 0.0E+0000' - result := FloatStringNoExp(@S,Precision); - S[0] := AnsiChar(result); - end; -end; -{$else} -{$ifdef UNICODE} -var i: PtrInt; -{$endif} -begin - // use ffGeneral: see https://synopse.info/forum/viewtopic.php?pid=442#p442 - result := FloatToText(PChar(@S[1]), Value, fvExtended, ffGeneral, - Precision, 0, SettingsUS); - {$ifdef UNICODE} // FloatToText(PWideChar) is faster than FloatToText(PAnsiChar) - for i := 1 to result do - PByteArray(@S)[i] := PWordArray(PtrInt(@S)-1)[i]; - {$endif} - S[0] := AnsiChar(result); -end; -{$endif EXTENDEDTOSHORT_USESTR} - -function FloatToShortNan(const s: shortstring): TFloatNan; -begin - case PInteger(@s)^ and $ffdfdfdf of - 3+ord('N')shl 8+ord('A')shl 16+ord('N')shl 24: - result := fnNan; - 3+ord('I')shl 8+ord('N')shl 16+ord('F')shl 24, - 4+ord('+')shl 8+ord('I')shl 16+ord('N')shl 24: - result := fnInf; - 4+ord('-')shl 8+ord('I')shl 16+ord('N')shl 24: - result := fnNegInf; - else - result := fnNumber; - end; -end; - -function FloatToStrNan(const s: RawUTF8): TFloatNan; -begin - case length(s) of - 3: case PInteger(s)^ and $dfdfdf of - ord('N')+ord('A')shl 8+ord('N')shl 16: result := fnNan; - ord('I')+ord('N')shl 8+ord('F')shl 16: result := fnInf; - else result := fnNumber; - end; - 4: case PInteger(s)^ and $dfdfdfdf of - ord('+')+ord('I')shl 8+ord('N')shl 16+ord('F')shl 24: result := fnInf; - ord('-')+ord('I')shl 8+ord('N')shl 16+ord('F')shl 24: result := fnNegInf; - else result := fnNumber; - end; - else result := fnNumber; - end; -end; - -function ExtendedToStr(Value: TSynExtended; Precision: integer): RawUTF8; -begin - ExtendedToStr(Value,Precision,result); -end; - -procedure ExtendedToStr(Value: TSynExtended; Precision: integer; - var result: RawUTF8); -var tmp: ShortString; -begin - if Value=0 then - result := SmallUInt32UTF8[0] else - FastSetString(result,@tmp[1],ExtendedToShort(tmp,Value,Precision)); -end; - -function FloatToJSONNan(const s: ShortString): PShortString; -begin - case PInteger(@s)^ and $ffdfdfdf of - 3+ord('N')shl 8+ord('A')shl 16+ord('N')shl 24: - result := @JSON_NAN[fnNan]; - 3+ord('I')shl 8+ord('N')shl 16+ord('F')shl 24, - 4+ord('+')shl 8+ord('I')shl 16+ord('N')shl 24: - result := @JSON_NAN[fnInf]; - 4+ord('-')shl 8+ord('I')shl 16+ord('N')shl 24: - result := @JSON_NAN[fnNegInf]; - else - result := @s; - end; -end; - -function ExtendedToJSON(var tmp: ShortString; Value: TSynExtended; - Precision: integer; NoExp: boolean): PShortString; -begin - if Value=0 then - result := @JSON_NAN[fnNumber] else begin - if noexp then - ExtendedToShortNoExp(tmp,Value,precision) else - ExtendedToShort(tmp,Value,precision); - result := FloatToJSONNan(tmp); - end; -end; - -procedure Div100(Y: cardinal; var res: TDiv100Rec); -{$ifdef FPC} -var Y100: cardinal; -begin - Y100 := Y div 100; // FPC will use fast reciprocal - res.D := Y100; - res.M := Y-Y100*100; // avoid div twice -end; -{$else} -{$ifdef CPUX64} -asm - .noframe - mov r8, res - mov edx, Y - mov dword ptr [r8].TDiv100Rec.M,edx - mov eax, 1374389535 - mul edx - shr edx, 5 - mov dword ptr [r8].TDiv100Rec.D, edx - imul eax, edx, 100 - sub dword ptr [r8].TDiv100Rec.M, eax -end; -{$else} -asm - mov dword ptr [edx].TDiv100Rec.M, eax - mov ecx, edx - mov edx, eax - mov eax, 1374389535 - mul edx - shr edx, 5 - mov dword ptr [ecx].TDiv100Rec.D, edx - imul eax, edx, 100 - sub dword ptr [ecx].TDiv100Rec.M, eax -end; -{$endif CPUX64} -{$endif FPC} - -{$ifdef DOUBLETOSHORT_USEGRISU} - -// includes Fabian Loitsch's Grisu algorithm especially compiled for double -{$I SynDoubleToText.inc} // implements DoubleToAscii() - -function DoubleToShort(var S: ShortString; const Value: double): integer; -var valueabs: double; -begin - valueabs := abs(Value); - if (valueabs>DOUBLE_HI) or (valueabs=high(blocks) then - raise ESynException.Create('FormatUTF8: too many args (max=32)!'); - L := 0; - argN := 0; - b := @blocks; - F := pointer(Format); - repeat - if F^=#0 then - break; - if F^<>'%' then begin - FDeb := F; - repeat - inc(F); - until (F^='%') or (F^=#0); - b^.Text := FDeb; - b^.Len := F-FDeb; - b^.TempRawUTF8 := nil; - inc(L,b^.Len); - inc(b); - if F^=#0 then - break; - end; - inc(F); // jump '%' - if argN<=high(Args) then begin - inc(L,VarRecToTempUTF8(Args[argN],b^)); - if b.Len>0 then - inc(b); - inc(argN); - if F^=#0 then - break; - end else // no more available Args -> add all remaining text - if F^=#0 then - break else begin - b^.Len := length(Format)-(F-pointer(Format)); - b^.Text := F; - b^.TempRawUTF8 := nil; - inc(L,b^.Len); - inc(b); - break; - end; - until false; -end; - -procedure TFormatUTF8.Write(Dest: PUTF8Char); -var d: PTempUTF8; -begin - d := @blocks; - repeat - {$ifdef HASINLINE}MoveSmall(d^.Text,Dest{$else}MoveFast(d^.Text^,Dest^{$endif},d^.Len); - inc(Dest,d^.Len); - if d^.TempRawUTF8<>nil then - {$ifdef FPC}Finalize(RawUTF8(d^.TempRawUTF8)){$else}RawUTF8(d^.TempRawUTF8) := ''{$endif}; - inc(d); - until d=b; -end; - -function TFormatUTF8.WriteMax(Dest: PUTF8Char; Max: PtrUInt): PUTF8Char; -var d: PTempUTF8; -begin - if Max>0 then begin - inc(Max,PtrUInt(Dest)); - d := @blocks; - if Dest<>nil then - repeat - if PtrUInt(Dest)+PtrUInt(d^.Len)>Max then begin // avoid buffer overflow - {$ifdef HASINLINE}MoveSmall(d^.Text,Dest{$else}MoveFast(d^.Text^,Dest^{$endif},Max-PtrUInt(Dest)); - repeat - if d^.TempRawUTF8<>nil then - {$ifdef FPC}Finalize(RawUTF8(d^.TempRawUTF8)){$else}RawUTF8(d^.TempRawUTF8) := ''{$endif}; - inc(d); - until d=b; // avoid memory leak - result := PUTF8Char(Max); - exit; - end; - {$ifdef HASINLINE}MoveSmall(d^.Text,Dest{$else}MoveFast(d^.Text^,Dest^{$endif},d^.Len); - inc(Dest,d^.Len); - if d^.TempRawUTF8<>nil then - {$ifdef FPC}Finalize(RawUTF8(d^.TempRawUTF8)){$else}RawUTF8(d^.TempRawUTF8) := ''{$endif}; - inc(d); - until d=b; - end; - result := Dest; -end; - -procedure FormatUTF8(const Format: RawUTF8; const Args: array of const; - out result: RawUTF8); -var process: TFormatUTF8; -begin - if (Format='') or (high(Args)<0) then // no formatting needed - result := Format else - if PWord(Format)^=ord('%') then // optimize raw conversion - VarRecToUTF8(Args[0],result) else begin - process.Parse(Format,Args); - if process.L<>0 then begin - FastSetString(result,nil,process.L); - process.Write(pointer(result)); - end; - end; -end; - -procedure FormatShort(const Format: RawUTF8; const Args: array of const; - var result: shortstring); -var process: TFormatUTF8; -begin - if (Format='') or (high(Args)<0) then // no formatting needed - SetString(result,PAnsiChar(pointer(Format)),length(Format)) else begin - process.Parse(Format,Args); - result[0] := AnsiChar(process.WriteMax(@result[1],255)-@result[1]); - end; -end; - -function FormatBuffer(const Format: RawUTF8; const Args: array of const; - Dest: pointer; DestLen: PtrInt): PtrInt; -var process: TFormatUTF8; -begin - if (Dest=nil) or (DestLen<=0) then begin - result := 0; - exit; // avoid buffer overflow - end; - process.Parse(Format,Args); - result := PtrInt(process.WriteMax(Dest,DestLen))-PtrInt(Dest); -end; - -function FormatToShort(const Format: RawUTF8; const Args: array of const): shortstring; -var process: TFormatUTF8; -begin // Delphi 5 has troubles compiling overloaded FormatShort() - process.Parse(Format,Args); - result[0] := AnsiChar(process.WriteMax(@result[1],255)-@result[1]); -end; - -procedure FormatShort16(const Format: RawUTF8; const Args: array of const; - var result: TShort16); -var process: TFormatUTF8; -begin - if (Format='') or (high(Args)<0) then // no formatting needed - SetString(result,PAnsiChar(pointer(Format)),length(Format)) else begin - process.Parse(Format,Args); - result[0] := AnsiChar(process.WriteMax(@result[1],16)-@result[1]); - end; -end; - -procedure FormatString(const Format: RawUTF8; const Args: array of const; - out result: string); -var process: TFormatUTF8; - temp: TSynTempBuffer; // will avoid most memory allocations -begin - if (Format='') or (high(Args)<0) then begin // no formatting needed - UTF8DecodeToString(pointer(Format),length(Format),result); - exit; - end; - process.Parse(Format,Args); - temp.Init(process.L); - process.Write(temp.buf); - UTF8DecodeToString(temp.buf,process.L,result); - temp.Done; -end; - -function FormatString(const Format: RawUTF8; const Args: array of const): string; -begin - FormatString(Format,Args,result); -end; - -function FormatUTF8(const Format: RawUTF8; const Args, Params: array of const; JSONFormat: boolean): RawUTF8; -var i, tmpN, L, A, P, len: PtrInt; - isParam: AnsiChar; - tmp: TRawUTF8DynArray; - inlin: set of 0..255; - F,FDeb: PUTF8Char; - wasString: Boolean; -const NOTTOQUOTE: array[boolean] of set of 0..31 = ( - [vtBoolean,vtInteger,vtInt64{$ifdef FPC},vtQWord{$endif},vtCurrency,vtExtended], - [vtBoolean,vtInteger,vtInt64{$ifdef FPC},vtQWord{$endif},vtCurrency,vtExtended,vtVariant]); -label Txt; -begin - if Format='' then begin - result := ''; - exit; - end; - if (high(Args)<0) and (high(Params)<0) then begin - // no formatting to process, but may be a const -> make unique - FastSetString(result,pointer(Format),length(Format)); - exit; // e.g. _JsonFmt() will parse it in-place - end; - if high(Params)<0 then begin - FormatUTF8(Format,Args,result); // slightly faster overloaded function - exit; - end; - if Format='%' then begin - VarRecToUTF8(Args[0],result); // optimize raw conversion - exit; - end; - result := ''; - tmpN := 0; - FillCharFast(inlin,SizeOf(inlin),0); - L := 0; - A := 0; - P := 0; - F := pointer(Format); - while F^<>#0 do begin - if F^<>'%' then begin - FDeb := F; - while not (F^ in [#0,'%','?']) do inc(F); -Txt: len := F-FDeb; - if len>0 then begin - inc(L,len); - if tmpN=length(tmp) then - SetLength(tmp,tmpN+8); - FastSetString(tmp[tmpN],FDeb,len); // add inbetween text - inc(tmpN); - end; - end; - if F^=#0 then - break; - isParam := F^; - inc(F); // jump '%' or '?' - if (isParam='%') and (A<=high(Args)) then begin // handle % substitution - if tmpN=length(tmp) then - SetLength(tmp,tmpN+8); - VarRecToUTF8(Args[A],tmp[tmpN]); - inc(A); - if tmp[tmpN]<>'' then begin - inc(L,length(tmp[tmpN])); - inc(tmpN); - end; - end else - if (isParam='?') and (P<=high(Params)) then begin // handle ? substitution - if tmpN=length(tmp) then - SetLength(tmp,tmpN+8); - {$ifndef NOVARIANTS} - if JSONFormat and (Params[P].VType=vtVariant) then - VariantSaveJSON(Params[P].VVariant^,twJSONEscape,tmp[tmpN]) else - {$endif} - begin - VarRecToUTF8(Params[P],tmp[tmpN]); - wasString := not (Params[P].VType in NOTTOQUOTE[JSONFormat]); - if wasString then - if JSONFormat then - QuotedStrJSON(tmp[tmpN],tmp[tmpN]) else - tmp[tmpN] := QuotedStr(tmp[tmpN],''''); - if not JSONFormat then begin - inc(L,4); // space for :(): - include(inlin,tmpN); - end; - end; - inc(P); - inc(L,length(tmp[tmpN])); - inc(tmpN); - end else - if F^<>#0 then begin // no more available Args -> add all remaining text - FDeb := F; - repeat inc(F) until (F^=#0); - goto Txt; - end; - end; - if L=0 then - exit; - if not JSONFormat and (tmpN>SizeOf(inlin)shl 3) then - raise ESynException.CreateUTF8( - 'Too many parameters for FormatUTF8(): %>%',[tmpN,SizeOf(inlin)shl 3]); - FastSetString(result,nil,L); - F := pointer(result); - for i := 0 to tmpN-1 do - if tmp[i]<>'' then begin - if byte(i) in inlin then begin - PWord(F)^ := ord(':')+ord('(')shl 8; - inc(F,2); - end; - L := PStrLen(PtrUInt(tmp[i])-_STRLEN)^; - MoveFast(pointer(tmp[i])^,F^,L); - inc(F,L); - if byte(i) in inlin then begin - PWord(F)^ := ord(')')+ord(':')shl 8; - inc(F,2); - end; - end; -end; - -function ScanUTF8(P: PUTF8Char; PLen: PtrInt; const fmt: RawUTF8; - const values: array of pointer; ident: PRawUTF8DynArray): integer; -var - v,w: PtrInt; - F,FEnd,PEnd: PUTF8Char; - tab: PTextCharSet; -label next; -begin - result := 0; - if (fmt='') or (P=nil) or (PLen<=0) or (high(values)<0) then - exit; - if ident<>nil then - SetLength(ident^,length(values)); - F := pointer(fmt); - FEnd := F+length(fmt); - PEnd := P+PLen; - for v := 0 to high(values) do - repeat - if (P^<=' ') and (P^<>#0) then // ignore any whitespace char in text - repeat - inc(P); - if P=PEnd then - exit; - until (P^>' ') or (P^=#0); - while (F^<=' ') and (F^<>#0) do begin // ignore any whitespace char in fmt - inc(F); - if F=FEnd then - exit; - end; - if F^='%' then begin // format specifier - inc(F); - if F=FEnd then - exit; - case F^ of - 'd': PInteger(values[v])^ := GetNextItemInteger(P,#0); - 'D': PInt64(values[v])^ := GetNextItemInt64(P,#0); - 'u': PCardinal(values[v])^ := GetNextItemCardinal(P,#0); - 'U': PQword(values[v])^ := GetNextItemQword(P,#0); - 'f': unaligned(PDouble(values[v])^) := GetNextItemDouble(P,#0); - 'F': GetNextItemCurrency(P,PCurrency(values[v])^,#0); - 'x': if not GetNextItemHexDisplayToBin(P,values[v],4,#0) then - exit; - 'X': if not GetNextItemHexDisplayToBin(P,values[v],8,#0) then - exit; - 's','S': begin - w := 0; - while (P[w]>' ') and (P+w<=PEnd) do inc(w); - if F^='s' then - SetString(PShortString(values[v])^,PAnsiChar(P),w) else - FastSetString(PRawUTF8(values[v])^,P,w); - inc(P,w); - while (P^<=' ') and (P^<>#0) and (P<=PEnd) do inc(P); - end; - 'L': begin - w := 0; - tab := @TEXT_CHARS; - while (tcNot01013 in tab[P[w]]) and (P+w<=PEnd) do inc(w); - FastSetString(PRawUTF8(values[v])^,P,w); - inc(P,w); - end; - '%': goto next; - else raise ESynException.CreateUTF8('ScanUTF8: unknown ''%'' specifier [%]',[F^,fmt]); - end; - inc(result); - tab := @TEXT_CHARS; - if (tcIdentifier in tab[F[1]]) or (ident<>nil) then begin - w := 0; - repeat inc(w) until not(tcIdentifier in tab[F[w]]) or (F+w=FEnd); - if ident<>nil then - FastSetString(ident^[v],F,w); - inc(F,w); - end else - inc(F); - if (F>=FEnd) or (P>=PEnd) then - exit; - break; - end else begin -next: while (P^<>F^) and (P<=PEnd) do inc(P); - inc(F); - inc(P); - if (F>=FEnd) or (P>=PEnd) then - exit; - end; - until false; -end; - -function ScanUTF8(const text, fmt: RawUTF8; const values: array of pointer; - ident: PRawUTF8DynArray): integer; -begin - result := ScanUTF8(pointer(text),length(text),fmt,values,ident); -end; - -function RawByteStringArrayConcat(const Values: array of RawByteString): RawByteString; -var i, L: PtrInt; - P: PAnsiChar; -begin - L := 0; - for i := 0 to high(Values) do - inc(L,length(Values[i])); - SetString(Result,nil,L); - P := pointer(Result); - for i := 0 to high(Values) do begin - L := length(Values[i]); - MoveFast(pointer(Values[i])^,P^,L); - inc(P,L); - end; -end; - -procedure RawByteStringToBytes(const buf: RawByteString; out bytes: TBytes); -var L: Integer; -begin - L := Length(buf); - if L<>0 then begin - SetLength(bytes,L); - MoveFast(pointer(buf)^,pointer(bytes)^,L); - end; -end; - -procedure BytesToRawByteString(const bytes: TBytes; out buf: RawByteString); -begin - SetString(buf,PAnsiChar(pointer(bytes)),Length(bytes)); -end; - -procedure ResourceToRawByteString(const ResName: string; ResType: PChar; - out buf: RawByteString; Instance: THandle); -var HResInfo: THandle; - HGlobal: THandle; -begin - if Instance=0 then - Instance := HInstance; - HResInfo := FindResource(Instance,PChar(ResName),ResType); - if HResInfo=0 then - exit; - HGlobal := LoadResource(Instance,HResInfo); - if HGlobal<>0 then begin - SetString(buf,PAnsiChar(LockResource(HGlobal)),SizeofResource(Instance,HResInfo)); - UnlockResource(HGlobal); // only needed outside of Windows - FreeResource(HGlobal); - end; -end; - -procedure ResourceSynLZToRawByteString(const ResName: string; - out buf: RawByteString; Instance: THandle); -var HResInfo: THandle; - HGlobal: THandle; -begin - if Instance=0 then - Instance := HInstance; - HResInfo := FindResource(Instance,PChar(ResName),PChar(10)); - if HResInfo=0 then - exit; - HGlobal := LoadResource(Instance,HResInfo); - if HGlobal<>0 then // direct decompression from memory mapped .exe content - try - AlgoSynLZ.Decompress(LockResource(HGlobal),SizeofResource(Instance,HResInfo),buf); - finally - UnlockResource(HGlobal); // only needed outside of Windows - FreeResource(HGlobal); - end; -end; - -function StrLenW(S: PWideChar): PtrInt; -begin - result := 0; - if S<>nil then - while true do - if S[result+0]<>#0 then - if S[result+1]<>#0 then - if S[result+2]<>#0 then - if S[result+3]<>#0 then - inc(result,4) else begin - inc(result,3); - exit; - end else begin - inc(result,2); - exit; - end else begin - inc(result); - exit; - end else - exit; -end; - -function StrCompW(Str1, Str2: PWideChar): PtrInt; -begin - if Str1<>Str2 then - if Str1<>nil then - if Str2<>nil then begin - if Str1^=Str2^ then - repeat - if (Str1^=#0) or (Str2^=#0) then break; - inc(Str1); - inc(Str2); - until Str1^<>Str2^; - result := PWord(Str1)^-PWord(Str2)^; - exit; - end else - result := 1 else // Str2='' - result := -1 else // Str1='' - result := 0; // Str1=Str2 -end; - -{$ifdef PUREPASCAL} - -function IdemPChar(p: PUTF8Char; up: PAnsiChar): boolean; -// if the beginning of p^ is same as up^ (ignore case - up^ must be already Upper) -var table: PNormTable; - u: AnsiChar; -begin - result := false; - if p=nil then - exit; - if up<>nil then begin - dec(PtrUInt(p),PtrUInt(up)); - table := @NormToUpperAnsi7; - repeat - u := up^; - if u=#0 then - break; - if u<>table^[up[PtrUInt(p)]] then - exit; - inc(up); - until false; - end; - result := true; -end; - -function IntegerScanIndex(P: PCardinalArray; Count: PtrInt; Value: cardinal): PtrInt; -begin - result := 0; - dec(Count,4); - if P<>nil then begin - repeat - if result>Count then - break; - if P^[result]<>Value then - if P^[result+1]<>Value then - if P^[result+2]<>Value then - if P^[result+3]<>Value then begin - inc(result,4); - continue; - end else - inc(result,3) else - inc(result,2) else - inc(result); - exit; - until false; - inc(Count,4); - repeat - if result>=Count then - break; - if P^[result]=Value then - exit else - inc(result); - until false; - end; - result := -1; -end; - -function IntegerScan(P: PCardinalArray; Count: PtrInt; Value: cardinal): PCardinal; -begin - result := nil; - if P=nil then - exit; - Count := PtrInt(@P[Count-4]); - repeat - if PtrUInt(P)>PtrUInt(Count) then - break; - if P^[0]<>Value then - if P^[1]<>Value then - if P^[2]<>Value then - if P^[3]<>Value then begin - P := @P[4]; - continue; - end else - result := @P[3] else - result := @P[2] else - result := @P[1] else - result := pointer(P); - exit; - until false; - inc(Count,4*SizeOf(Value)); - result := pointer(P); - repeat - if PtrUInt(result)>=PtrUInt(Count) then - break; - if result^=Value then - exit else - inc(result); - until false; - result := nil; -end; - -function IntegerScanExists(P: PCardinalArray; Count: PtrInt; Value: cardinal): boolean; -begin - if P<>nil then begin - result := true; - Count := PtrInt(@P[Count-4]); - repeat - if PtrUInt(P)>PtrUInt(Count) then - break; - if (P^[0]=Value) or (P^[1]=Value) or (P^[2]=Value) or (P^[3]=Value) then - exit; - P := @P[4]; - until false; - inc(Count,4*SizeOf(Value)); - repeat - if PtrUInt(P)>=PtrUInt(Count) then - break; - if P^[0]=Value then - exit else - P := @P[1]; - until false; - end; - result := false; -end; - -function PosChar(Str: PUTF8Char; Chr: AnsiChar): PUTF8Char; -var c: cardinal; -begin // FPC is efficient at compiling this code - result := nil; - if Str<>nil then begin - repeat - c := PCardinal(str)^; - if ToByte(c)=0 then - exit else - if ToByte(c)=byte(Chr) then - break; - c := c shr 8; - inc(Str); - if ToByte(c)=0 then - exit else - if ToByte(c)=byte(Chr) then - break; - c := c shr 8; - inc(Str); - if ToByte(c)=0 then - exit else - if ToByte(c)=byte(Chr) then - break; - c := c shr 8; - inc(Str); - if ToByte(c)=0 then - exit else - if ToByte(c)=byte(Chr) then - break; - inc(Str); - until false; - result := Str; - end; -end; - -function CompareMem(P1, P2: Pointer; Length: PtrInt): Boolean; -label zero; -begin // this code compiles well under FPC and Delphi on both 32-bit and 64-bit - Length := PtrInt(@PAnsiChar(P1)[Length-SizeOf(PtrInt)*2]); // = 2*PtrInt end - if Length>=PtrInt(PtrUInt(P1)) then begin - if PPtrInt(PtrUInt(P1))^<>PPtrInt(P2)^ then // compare first PtrInt bytes - goto zero; - inc(PPtrInt(P1)); - inc(PPtrInt(P2)); - dec(PtrInt(P2),PtrInt(PtrUInt(P1))); - PtrInt(PtrUInt(P1)) := PtrInt(PtrUInt(P1)) and -SizeOf(PtrInt); // align - inc(PtrInt(P2),PtrInt(PtrUInt(P1))); - if Length>=PtrInt(PtrUInt(P1)) then - repeat // compare 4 aligned PtrInt per loop - if (PPtrInt(PtrUInt(P1))^<>PPtrInt(P2)^) or (PPtrIntArray(P1)[1]<>PPtrIntArray(P2)[1]) then - goto zero; - inc(PByte(P1),SizeOf(PtrInt)*2); - inc(PByte(P2),SizeOf(PtrInt)*2); - if LengthPPtrInt(P2)^) or (PPtrIntArray(P1)[1]<>PPtrIntArray(P2)[1]) then - goto zero; - inc(PByte(P1),SizeOf(PtrInt)*2); - inc(PByte(P2),SizeOf(PtrInt)*2); - until Length=SizeOf(PtrInt) then begin - if PPtrInt(PtrUInt(P1))^<>PPtrInt(P2)^ then - goto zero; - inc(PPtrInt(P1)); - inc(PPtrInt(P2)); - dec(Length,SizeOf(PtrInt)); - end; - {$ifdef CPU64} - if Length>=4 then begin - if PCardinal(P1)^<>PCardinal(P2)^ then - goto zero; - inc(PCardinal(P1)); - inc(PCardinal(P2)); - dec(Length,4); - end; - {$endif} - if Length>=2 then begin - if PWord(P1)^<>PWord(P2)^ then - goto zero; - inc(PWord(P1)); - inc(PWord(P2)); - dec(Length,2); - end; - if Length>=1 then - if PByte(P1)^<>PByte(P2)^ then - goto zero; - result := true; - exit; -zero: - result := false; -end; - -{$ifdef HASINLINE} // to use directly the SubStr/S arguments registers -function PosEx(const SubStr, S: RawUTF8; Offset: PtrUInt): PtrInt; -begin - result := PosExPas(pointer(SubStr),pointer(S),Offset); -end; -{$endif HASINLINE} - -// from Aleksandr Sharahov's PosEx_Sha_Pas_2() - refactored for cross-platform -function PosExPas(pSub, p: PUTF8Char; Offset: PtrUInt): PtrInt; -var len, lenSub: PtrInt; - ch: AnsiChar; - pStart, pStop: PUTF8Char; -label Loop2, Loop6, TestT, Test0, Test1, Test2, Test3, Test4, - AfterTestT, AfterTest0, Ret, Exit; -begin - result := 0; - if (p=nil) or (pSub=nil) or (PtrInt(Offset)<=0) then - goto Exit; - len := PStrLen(p-_STRLEN)^; - lenSub := PStrLen(pSub-_STRLEN)^-1; - if (len=pStop then goto Exit; - goto Loop2; -Test4: dec(p,2); -Test2: dec(p,2); - goto Test0; -Test3: dec(p,2); -Test1: dec(p,2); -TestT: len := lenSub; - if lenSub<>0 then - repeat - if (psub[len]<>p[len+1]) or (psub[len+1]<>p[len+2]) then - goto AfterTestT; - inc(len,2); - until len>=0; - inc(p,2); - if p<=pStop then goto Ret; - goto Exit; -Test0: len := lenSub; - if lenSub<>0 then - repeat - if (psub[len]<>p[len]) or (psub[len+1]<>p[len+1]) then - goto AfterTest0; - inc(len,2); - until len>=0; - inc(p); -Ret: - result := p-pStart; -Exit: -end; - -function IdemPropNameU(const P1,P2: RawUTF8): boolean; -var L: PtrInt; -begin - L := length(P1); - if length(P2)=L then - result := IdemPropNameUSameLen(pointer(P1),pointer(P2),L) else - result := false; -end; - -function StrIComp(Str1, Str2: pointer): PtrInt; -var C1,C2: byte; // integer/PtrInt are actually slower on FPC - lookupper: PByteArray; // better x86-64 / PIC asm generation -begin - result := PtrInt(PtrUInt(Str2))-PtrInt(PtrUInt(Str1)); - if result<>0 then - if Str1<>nil then - if Str2<>nil then begin - lookupper := @NormToUpperAnsi7Byte; - repeat - C1 := lookupper[PByteArray(Str1)[0]]; - C2 := lookupper[PByteArray(Str1)[result]]; - inc(PByte(Str1)); - until (C1=0) or (C1<>C2); - result := C1-C2; - end else - result := 1 else // Str2='' - result := -1; // Str1='' -end; - -function StrLenPas(S: pointer): PtrInt; -label - _0, _1, _2, _3; // ugly but faster -begin - result := PtrUInt(S); - if S<>nil then begin - while true do - if PAnsiChar(result)[0]=#0 then - goto _0 - else if PAnsiChar(result)[1]=#0 then - goto _1 - else if PAnsiChar(result)[2]=#0 then - goto _2 - else if PAnsiChar(result)[3]=#0 then - goto _3 - else - inc(result, 4); -_3: inc(result); -_2: inc(result); -_1: inc(result); -_0: dec(result,PtrUInt(S)); // return length - end; -end; - -function StrCompFast(Str1, Str2: pointer): PtrInt; -var c: byte; -begin - if Str1<>Str2 then - if Str1<>nil then - if Str2<>nil then begin - c := PByte(Str1)^; - if c=PByte(Str2)^ then - repeat - if c=0 then break; - inc(PByte(Str1)); - inc(PByte(Str2)); - c := PByte(Str1)^; - until c<>PByte(Str2)^; - result := c-PByte(Str2)^; - exit; - end else - result := 1 else // Str2='' - result := -1 else // Str1='' - result := 0; // Str1=Str2 -end; - -procedure YearToPChar(Y: PtrUInt; P: PUTF8Char); -var d100: PtrUInt; - tab: PWordArray; -begin - tab := @TwoDigitLookupW; - d100 := Y div 100; - PWordArray(P)[0] := tab[d100]; - PWordArray(P)[1] := tab[Y-(d100*100)]; -end; - -procedure YearToPChar2(tab: PWordArray; Y: PtrUInt; P: PUTF8Char); {$ifdef HASINLINE}inline;{$endif} -var d100: PtrUInt; -begin - d100 := Y div 100; - PWordArray(P)[0] := tab[d100]; - PWordArray(P)[1] := tab[Y-(d100*100)]; -end; - -function Iso8601ToTimeLog(const S: RawByteString): TTimeLog; -begin - result := Iso8601ToTimeLogPUTF8Char(pointer(S),length(S)); -end; - -function UpperCopy(dest: PAnsiChar; const source: RawUTF8): PAnsiChar; -var s: PAnsiChar; - c: byte; - lookupper: PByteArray; // better x86-64 / PIC asm generation -begin - s := pointer(source); - if s<>nil then begin - lookupper := @NormToUpperAnsi7Byte; - repeat - c := lookupper[ord(s^)]; - if c=0 then - break; - dest^ := AnsiChar(c); - inc(s); - inc(dest); - until false; - end; - result := dest; -end; - -function UpperCopyShort(dest: PAnsiChar; const source: shortstring): PAnsiChar; -var s: PByteArray; - i: PtrInt; - lookupper: PByteArray; // better x86-64 / PIC asm generation -begin - s := @source; - lookupper := @NormToUpperAnsi7Byte; - for i := 1 to s[0] do begin - dest^ := AnsiChar(lookupper[s[i]]); - inc(dest); - end; - result := dest; -end; - -function IdemPCharAndGetNextLine(var source: PUTF8Char; searchUp: PAnsiChar): boolean; -begin - if source=nil then - result := false else begin - result := IdemPChar(source,searchUp); - source := GotoNextLine(source); - end; -end; - -function fnv32(crc: cardinal; buf: PAnsiChar; len: PtrInt): cardinal; -var i: PtrInt; -begin - if buf<>nil then - for i := 0 to len-1 do - crc := (crc xor ord(buf[i]))*16777619; - result := crc; -end; - -function kr32(crc: cardinal; buf: PAnsiChar; len: PtrInt): cardinal; -var i: PtrInt; -begin - if buf<>nil then - for i := 0 to len-1 do begin - crc := crc*31; - inc(crc,ord(buf[i])); - end; - result := crc; -end; - -procedure crcblockNoSSE42(crc128, data128: PBlock128); -var c: cardinal; - tab: PCrc32tab; -begin - tab := @crc32ctab; - c := crc128^[0] xor data128^[0]; - crc128^[0] := tab[3,ToByte(c)] xor tab[2,ToByte(c shr 8)] - xor tab[1,ToByte(c shr 16)] xor tab[0,ToByte(c shr 24)]; - c := crc128^[1] xor data128^[1]; - crc128^[1] := tab[3,ToByte(c)] xor tab[2,ToByte(c shr 8)] - xor tab[1,ToByte(c shr 16)] xor tab[0,ToByte(c shr 24)]; - c := crc128^[2] xor data128^[2]; - crc128^[2] := tab[3,ToByte(c)] xor tab[2,ToByte(c shr 8)] - xor tab[1,ToByte(c shr 16)] xor tab[0,ToByte(c shr 24)]; - c := crc128^[3] xor data128^[3]; - crc128^[3] := tab[3,ToByte(c)] xor tab[2,ToByte(c shr 8)] - xor tab[1,ToByte(c shr 16)] xor tab[0,ToByte(c shr 24)]; -end; - -function crc32cfast(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal; -{$ifdef ABSOLUTEPASCALORNOTINTEL} -var tab: PCrc32tab; -begin // on ARM, we use slicing-by-4 to avoid polluting smaller L1 cache - tab := @crc32ctab; - result := not crc; - if (buf<>nil) and (len>0) then begin - repeat - if PtrUInt(buf) and 3=0 then // align to 4 bytes boundary - break; - result := tab[0,ToByte(result xor ord(buf^))] xor (result shr 8); - dec(len); - inc(buf); - until len=0; - if len>=4 then - repeat - result := result xor PCardinal(buf)^; - inc(buf,4); - dec(len,4); - result := tab[3,ToByte(result)] xor - tab[2,ToByte(result shr 8)] xor - tab[1,ToByte(result shr 16)] xor - tab[0,ToByte(result shr 24)]; - until len<4; - while len>0 do begin - result := tab[0,ToByte(result xor ord(buf^))] xor (result shr 8); - dec(len); - inc(buf); - end; - end; - result := not result; -end; -{$else} -{$ifdef FPC} nostackframe; assembler; asm {$else} asm .noframe {$endif FPC} - {$ifndef win64} - mov r8d, len - {$endif} - mov eax, crc - xor ecx, ecx - test buf, buf // buf=rdx/rsi len=r8 - jz @z - neg r8 - jz @z - not eax - lea r9, [rip + crc32ctab] - cmp r8, -8 - jb @head -@sml: mov cl, byte ptr[buf] - inc buf - xor cl, al - shr eax, 8 - xor eax, dword ptr[rcx * 4 + r9] - inc r8 - jnz @sml -@0: not eax -@z: ret -@head: test buf, 7 - jz @align - mov cl, byte ptr[buf] - inc buf - xor cl, al - shr eax, 8 - xor eax, dword ptr[rcx * 4 + r9] - inc r8 - jnz @head - not eax - ret -@align: sub buf, r8 - add r8, 8 - jg @done - xor r11, r11 -@by8: mov r10d, eax - mov rcx, qword ptr[buf + r8 - 8] - xor r10d, ecx - shr rcx, 32 - mov r11b, cl - shr ecx, 8 - mov eax, dword ptr[r11 * 4 + r9 + 1024 * 3] - mov r11b, cl - shr ecx, 8 - xor eax, dword ptr[r11 * 4 + r9 + 1024 * 2] - mov r11b, cl - shr ecx, 8 - xor eax, dword ptr[r11 * 4 + r9 + 1024 * 1] - mov r11b, cl - xor eax, dword ptr[r11 * 4 + r9 + 1024 * 0] - mov ecx, r10d - mov r11b, cl - shr ecx, 8 - xor eax, dword ptr[r11 * 4 + r9 + 1024 * 7] - mov r11b, cl - shr ecx, 8 - xor eax, dword ptr[r11 * 4 + r9 + 1024 * 6] - mov r11b, cl - shr ecx, 8 - xor eax, dword ptr[r11 * 4 + r9 + 1024 * 5] - mov r11b, cl - xor eax, dword ptr[r11 * 4 + r9 + 1024 * 4] - add r8, 8 - jle @by8 -@done: sub r8, 8 - jge @e -@tail: mov cl, byte ptr[buf + r8] - xor cl, al - shr eax, 8 - xor eax, dword ptr[rcx * 4 + r9] - inc r8 - jnz @tail -@e: not eax -end; -{$endif ABSOLUTEPASCALORNOTINTEL} - -function ToVarInt32(Value: PtrInt; Dest: PByte): PByte; -begin // 0=0,1=1,2=-1,3=2,4=-2... - if Value<0 then - // -1->2, -2->4.. - Value := (-Value) shl 1 else - if Value>0 then - // 1->1, 2->3.. - Value := (Value shl 1)-1; - // 0->0 - result := ToVarUInt32(Value,Dest); -end; - -function ToVarUInt32(Value: cardinal; Dest: PByte): PByte; -label _1,_2,_3; // ugly but fast -begin - if Value>$7f then begin - if Value<$80 shl 7 then goto _1 else - if Value<$80 shl 14 then goto _2 else - if Value<$80 shl 21 then goto _3; - Dest^ := (Value and $7F) or $80; - Value := Value shr 7; - inc(Dest); -_3: Dest^ := (Value and $7F) or $80; - Value := Value shr 7; - inc(Dest); -_2: Dest^ := (Value and $7F) or $80; - Value := Value shr 7; - inc(Dest); -_1: Dest^ := (Value and $7F) or $80; - Value := Value shr 7; - inc(Dest); - end; - Dest^ := Value; - inc(Dest); - result := Dest; -end; - -{$ifdef CPUX64} // very efficient branchless asm - rcx/rdi=A rdx/rsi=B -function SortDynArrayInteger(const A,B): integer; -{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC} - mov r8d, dword ptr[A] - mov edx, dword ptr[B] - xor eax, eax - xor ecx, ecx - cmp r8d, edx - setl cl - setg al - sub eax, ecx -end; -function SortDynArrayCardinal(const A,B): integer; -{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC} - mov ecx, dword ptr[A] - mov edx, dword ptr[B] - xor eax, eax - cmp ecx, edx - seta al - sbb eax, 0 -end; -function SortDynArrayInt64(const A,B): integer; -{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC} - mov r8, qword ptr[A] - mov rdx, qword ptr[B] - xor eax, eax - xor ecx, ecx - cmp r8, rdx - setl cl - setg al - sub eax, ecx -end; -function SortDynArrayQWord(const A,B): integer; -{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC} - mov rcx, qword ptr[A] - mov rdx, qword ptr[B] - xor eax, eax - cmp rcx, rdx - seta al - sbb eax, 0 -end; -function SortDynArrayPointer(const A,B): integer; -{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC} - mov rcx, qword ptr[A] - mov rdx, qword ptr[B] - xor eax, eax - cmp rcx, rdx - seta al - sbb eax, 0 -end; -function SortDynArrayDouble(const A,B): integer; -{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC} - movsd xmm0, qword ptr[A] - movsd xmm1, qword ptr[B] - xor eax, eax - xor edx, edx - comisd xmm0, xmm1 - seta al - setb dl - sub eax, edx -end; -function SortDynArraySingle(const A,B): integer; -{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC} - movss xmm0, dword ptr[A] - movss xmm1, dword ptr[B] - xor eax, eax - xor edx, edx - comiss xmm0, xmm1 - seta al - setb dl - sub eax, edx -end; -function SortDynArrayAnsiString(const A,B): integer; -{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC} - mov rcx, qword ptr[A] - mov rdx, qword ptr[B] - cmp rcx, rdx // A=B (happens with string refcounting) - je @0 - test rcx, rdx // A^ or B^ may be nil i.e. '' - jz @n1 -@s: mov al, byte ptr[rcx] // by char comparison - cmp al, byte ptr[rdx] - jne @ne - inc rcx - inc rdx - test al, al - jnz @s -@0: xor eax, eax - ret -@n1: test rcx, rcx - jz @less // A='' -> -1 - test rdx, rdx - jnz @s // B='' -> 1 -@1: mov eax, 1 - ret -@ne: jnc @1 -@less: mov eax, -1 -end; // note: SSE4.2 read up to 16 bytes after buffer, this version won't -{$else} -function SortDynArrayInteger(const A,B): integer; -begin - result := ord(integer(A)>integer(B))-ord(integer(A)cardinal(B))-ord(cardinal(A)Int64(B))-ord(Int64(A)QWord(B))-ord(QWord(A)PtrUInt(B))-ord(PtrUInt(A)double(B))-ord(double(A)single(B))-ord(single(A)B)-ord(Ap2 then - if p1<>nil then - if p2<>nil then begin - l1 := PStrLen(PtrUInt(p1)-_STRLEN)^; - l2 := PStrLen(PtrUInt(p2)-_STRLEN)^; - l := l1; - if l20 then - exit; - inc(i); - until i>=l; - result := l1-l2; - end else - result := 1 else // p2='' - result := -1 else // p1='' - result := 0; // p1=p2 -end; - -function SortDynArrayPUTF8Char(const A,B): integer; -begin - result := StrCompFast(pointer(A),pointer(B)); -end; - -{$else PUREPASCAL} - -function IdemPChar(p: PUTF8Char; up: PAnsiChar): boolean; -{$ifdef FPC}nostackframe; assembler;{$endif} -asm - test eax, eax - jz @e // P=nil -> false - test edx, edx - push ebx - jz @t // up=nil -> true - xor ebx, ebx -@1: mov ecx, [edx] // optimized for DWORD aligned read up^ - test cl, cl - mov bl, [eax] - jz @t // up^[0]=#0 -> OK - cmp cl, byte ptr[ebx + NormToUpperAnsi7] // NormToUpperAnsi7[p^[0]] - jne @f - mov bl, [eax + 1] - test ch, ch - jz @t // up^[1]=#0 -> OK - cmp ch, byte ptr[ebx + NormToUpperAnsi7] // NormToUpperAnsi7[p^[1]] - jne @f - shr ecx, 16 // cl=up^[2] ch=up^[3] - mov bl, [eax + 2] - test cl, cl - jz @t // up^[2]=#0 -> OK - cmp cl, byte ptr[ebx + NormToUpperAnsi7] // NormToUpperAnsi7[p^[2]] - jne @f - mov bl, [eax + 3] - add eax, 4 - add edx, 4 - test ch, ch - jz @t // up^[3]=#0 -> OK - cmp ch, byte ptr[ebx + NormToUpperAnsi7] // NormToUpperAnsi7[p^[3]] - je @1 -@f: pop ebx // NormToUpperAnsi7[p^]<>up^ -> FALSE -@e: xor eax, eax - ret -@t: pop ebx // up^=#0 -> TRUE - mov al, 1 -end; - -function IntegerScanIndex(P: PCardinalArray; Count: PtrInt; Value: cardinal): PtrInt; -{$ifdef FPC}nostackframe; assembler;{$endif} -asm - push eax - call IntegerScan - pop edx - test eax, eax - jnz @e - dec eax // returns -1 - ret -@e: sub eax, edx - shr eax, 2 -end; - -function IntegerScan(P: PCardinalArray; Count: PtrInt; Value: cardinal): PCardinal; -{$ifdef FPC}nostackframe; assembler;{$endif} -asm // eax=P, edx=Count, Value=ecx - test eax, eax - jz @ok0 // avoid GPF - cmp edx, 8 - jb @s2 - nop - nop - nop // @s1 loop align -@s1: sub edx, 8 - cmp [eax], ecx - je @ok0 - cmp [eax + 4], ecx - je @ok4 - cmp [eax + 8], ecx - je @ok8 - cmp [eax + 12], ecx - je @ok12 - cmp [eax + 16], ecx - je @ok16 - cmp [eax + 20], ecx - je @ok20 - cmp [eax + 24], ecx - je @ok24 - cmp [eax + 28], ecx - je @ok28 - add eax, 32 - cmp edx, 8 - jae @s1 -@s2: test edx, edx - jz @z - cmp [eax], ecx - je @ok0 - dec edx - jz @z - cmp [eax + 4], ecx - je @ok4 - dec edx - jz @z - cmp [eax + 8], ecx - je @ok8 - dec edx - jz @z - cmp [eax + 12], ecx - je @ok12 - dec edx - jz @z - cmp [eax + 16], ecx - je @ok16 - dec edx - jz @z - cmp [eax + 20], ecx - je @ok20 - dec edx - jz @z - cmp [eax + 24], ecx - je @ok24 -@z: xor eax, eax // return nil if not found - ret -@ok0: rep ret -@ok28: add eax, 28 - ret -@ok24: add eax, 24 - ret -@ok20: add eax, 20 - ret -@ok16: add eax, 16 - ret -@ok12: add eax, 12 - ret -@ok8: add eax, 8 - ret -@ok4: add eax, 4 -end; - -function IntegerScanExists(P: PCardinalArray; Count: PtrInt; Value: cardinal): boolean; -{$ifdef FPC}nostackframe; assembler;{$endif} -asm // eax=P, edx=Count, Value=ecx - test eax, eax - jz @z // avoid GPF - cmp edx, 8 - jae @s1 - jmp dword ptr[edx * 4 + @Table] -@Table: dd @z, @1, @2, @3, @4, @5, @6, @7 -@s1: // fast search by 8 integers (pipelined instructions) - sub edx, 8 - cmp [eax], ecx - je @ok - cmp [eax + 4], ecx - je @ok - cmp [eax + 8], ecx - je @ok - cmp [eax + 12], ecx - je @ok - cmp [eax + 16], ecx - je @ok - cmp [eax + 20], ecx - je @ok - cmp [eax + 24], ecx - je @ok - cmp [eax + 28], ecx - je @ok - add eax, 32 - cmp edx, 8 - jae @s1 - jmp dword ptr[edx * 4 + @Table] -@7: cmp [eax + 24], ecx - je @ok -@6: cmp [eax + 20], ecx - je @ok -@5: cmp [eax + 16], ecx - je @ok -@4: cmp [eax + 12], ecx - je @ok -@3: cmp [eax + 8], ecx - je @ok -@2: cmp [eax + 4], ecx - je @ok -@1: cmp [eax], ecx - je @ok -@z: xor eax, eax - ret -@ok: mov al, 1 -end; - -function PosChar(Str: PUTF8Char; Chr: AnsiChar): PUTF8Char; -{$ifdef FPC}nostackframe; assembler;{$endif} -asm // faster version by AB - eax=Str dl=Chr - test eax, eax - jz @z -@1: mov ecx, dword ptr [eax] - cmp cl, dl - je @z - inc eax - test cl, cl - jz @e - cmp ch, dl - je @z - inc eax - test ch, ch - jz @e - shr ecx, 16 - cmp cl, dl - je @z - inc eax - test cl, cl - jz @e - cmp ch, dl - je @z - inc eax - test ch, ch - jnz @1 -@e: xor eax, eax - ret -@z: db $f3 // rep ret -end; - -function CompareMem(P1, P2: Pointer; Length: PtrInt): Boolean; -{$ifdef FPC}nostackframe; assembler;{$endif} -asm // eax=P1 edx=P2 ecx=Length - cmp eax, edx - je @0 // P1=P2 - sub ecx, 8 - jl @small - push ebx - mov ebx, [eax] // Compare First 4 Bytes - cmp ebx, [edx] - jne @setbig - lea ebx, [eax + ecx] // Compare Last 8 Bytes - add edx, ecx - mov eax, [ebx] - cmp eax, [edx] - jne @setbig - mov eax, [ebx + 4] - cmp eax, [edx + 4] - jne @setbig - sub ecx, 4 - jle @true // All Bytes already Compared - neg ecx // ecx=-(Length-12) - add ecx, ebx // DWORD Align Reads - and ecx, -4 - sub ecx, ebx -@loop: mov eax, [ebx + ecx] // Compare 8 Bytes per Loop - cmp eax, [edx + ecx] - jne @setbig - mov eax, [ebx + ecx + 4] - cmp eax, [edx + ecx + 4] - jne @setbig - add ecx, 8 - jl @loop -@true: pop ebx -@0: mov al, 1 - ret -@setbig:pop ebx - setz al - ret -@small: add ecx, 8 // ecx=0..7 - jle @0 // Length <= 0 - neg ecx // ecx=-1..-7 - lea ecx, [@1 + ecx * 8 + 8] // each @#: block below = 8 bytes - jmp ecx -@7: mov cl, [eax + 6] - cmp cl, [edx + 6] - jne @setsml -@6: mov ch, [eax + 5] - cmp ch, [edx + 5] - jne @setsml -@5: mov cl, [eax + 4] - cmp cl, [edx + 4] - jne @setsml -@4: mov ch, [eax + 3] - cmp ch, [edx + 3] - jne @setsml -@3: mov cl, [eax + 2] - cmp cl, [edx + 2] - jne @setsml -@2: mov ch, [eax + 1] - cmp ch, [edx + 1] - jne @setsml -@1: mov al, [eax] - cmp al, [edx] -@setsml:setz al -end; - -function PosEx(const SubStr, S: RawUTF8; Offset: PtrUInt): integer; -{$ifdef FPC}nostackframe; assembler;{$endif} -asm // eax=SubStr, edx=S, ecx=Offset - push ebx - push esi - push edx - test eax, eax - jz @notfnd // exit if SubStr='' - test edx, edx - jz @notfnd // exit if S='' - mov esi, ecx - mov ecx, [edx - 4] // length(S) - mov ebx, [eax - 4] // length(SubStr) - add ecx, edx - sub ecx, ebx // ecx = max start pos for full match - lea edx, [edx + esi - 1] // edx = start position - cmp edx, ecx - jg @notfnd // startpos > max start pos - cmp ebx, 1 - jle @onec // optimized loop for length(SubStr)<=1 - push edi - push ebp - lea edi, [ebx - 2] // edi = length(SubStr)-2 - mov esi, eax // esi = SubStr - movzx ebx, byte ptr[eax] // bl = search character - nop; nop -@l: cmp bl, [edx] // compare 2 characters per @l - je @c1fnd -@notc1: cmp bl, [edx + 1] - je @c2fnd -@notc2: add edx, 2 - cmp edx, ecx // next start position <= max start position - jle @l - pop ebp - pop edi -@notfnd:xor eax, eax // returns 0 if not fnd - pop edx - pop esi - pop ebx - ret -@c1fnd: mov ebp, edi // ebp = length(SubStr)-2 -@c1l: movzx eax, word ptr[esi + ebp] - cmp ax, [edx + ebp] // compare 2 chars per @c1l (may include #0) - jne @notc1 - sub ebp, 2 - jnc @c1l - pop ebp - pop edi - jmp @setres -@c2fnd: mov ebp, edi // ebp = length(SubStr)-2 -@c2l: movzx eax, word ptr[esi + ebp] - cmp ax, [edx + ebp + 1] // compare 2 chars per @c2l (may include #0) - jne @notc2 - sub ebp, 2 - jnc @c2l - pop ebp - pop edi - jmp @chkres -@onec: jl @notfnd // needed for zero-length non-nil strings - movzx eax, byte ptr[eax] // search character -@charl: cmp al, [edx] - je @setres - cmp al, [edx + 1] - je @chkres - add edx, 2 - cmp edx, ecx - jle @charl - jmp @notfnd -@chkres:cmp edx, ecx // check within ansistring - jge @notfnd - add edx, 1 -@setres:pop ecx // ecx = S - pop esi - pop ebx - neg ecx - lea eax, [edx + ecx + 1] -end; - -function IdemPropNameU(const P1,P2: RawUTF8): boolean; -{$ifdef FPC}nostackframe; assembler;{$endif} -asm // eax=p1, edx=p2 - cmp eax, edx - je @out1 - test eax, edx - jz @maybenil -@notnil:mov ecx, [eax - 4] // compare lengths - cmp ecx, [edx - 4] - jne @out1 - push ebx - lea edx, [edx + ecx - 4] // may include the length for shortest strings - lea ebx, [eax + ecx - 4] - neg ecx - mov eax, [ebx] // compare last 4 chars - xor eax, [edx] - and eax, $dfdfdfdf // case insensitive - jne @out2 -@by4: add ecx, 4 - jns @match - mov eax, [ebx + ecx] - xor eax, [edx + ecx] - and eax, $dfdfdfdf // case insensitive - je @by4 -@out2: pop ebx -@out1: setz al - ret -@match: mov al, 1 - pop ebx - ret -@maybenil: // here we know that eax<>edx - test eax, eax - jz @nil0 // eax=nil and eax<>edx -> edx<>nil -> false - test edx, edx - jnz @notnil - mov al, dl // eax<>nil and edx=nil -> false -@nil0: -end; - -function IdemPropNameUSameLen(P1,P2: PUTF8Char; P1P2Len: PtrInt): boolean; -{$ifdef FPC}nostackframe; assembler;{$endif} -asm // eax=p1, edx=p2, ecx=P1P2Len - cmp eax, edx - je @out2 - cmp ecx, 4 - jbe @sml - push ebx - lea edx, [edx + ecx - 4] - lea ebx, [eax + ecx - 4] - neg ecx - mov eax, [ebx] // compare last 4 chars - xor eax, [edx] - and eax, $dfdfdfdf // case insensitive - jne @out1 -@by4: add ecx, 4 - jns @match - mov eax, [ebx + ecx] - xor eax, [edx + ecx] - and eax, $dfdfdfdf // case insensitive - je @by4 -@out1: pop ebx -@out2: setz al - ret - nop - nop -@match: pop ebx - mov al, 1 - ret -@mask: dd 0, $df, $dfdf, $dfdfdf, $dfdfdfdf // compare 1..4 chars -@sml: test ecx, ecx - jz @smlo // p1p2len=0 - mov eax, [eax] - xor eax, [edx] - and eax, dword ptr[@mask + ecx * 4] -@smlo: setz al -end; - -function StrIComp(Str1, Str2: pointer): PtrInt; -{$ifdef FPC}nostackframe; assembler;{$endif} -asm // faster version by AB, from Agner Fog's original - mov ecx, eax - test eax, edx - jz @n -@ok: sub edx, eax - jz @0 -@10: mov al, [ecx] - cmp al, [ecx + edx] - jne @20 - inc ecx - test al, al - jnz @10 // continue with next byte - // terminating zero found. Strings are equal -@0: xor eax, eax - ret -@20: // bytes are different. check case - xor al, 20H // toggle case - cmp al, [ecx + edx] - jne @30 - // possibly differing only by case. Check if a-z - or al, 20H // upper case - sub al, 'a' - cmp al, 'z' - 'a' - ja @30 // not a-z - // a-z and differing only by case - inc ecx - jmp @10 // continue with next byte -@30: // bytes are different,even after changing case - movzx eax, byte[ecx] // get original value again - sub eax, 'A' - cmp eax, 'Z' - 'A' - ja @40 - add eax, 20H -@40: movzx edx, byte[ecx + edx] - sub edx, 'A' - cmp edx, 'Z' - 'A' - ja @50 - add edx, 20H -@50: sub eax, edx // subtract to get result - ret -@n: cmp eax, edx - je @0 - test eax, eax // Str1='' ? - jz @max - test edx, edx // Str2='' ? - jnz @ok - mov eax, 1 - ret -@max: dec eax -end; - -function StrLenPas(S: pointer): PtrInt; -{$ifdef FPC}nostackframe; assembler;{$endif} -asm // slower than x86/SSE* StrLen(), but won't read any byte beyond the string - mov edx, eax - test eax, eax - jz @0 - xor eax, eax -@s: cmp byte ptr[eax + edx + 0], 0 - je @0 - cmp byte ptr[eax + edx + 1], 0 - je @1 - cmp byte ptr[eax + edx + 2], 0 - je @2 - cmp byte ptr[eax + edx + 3], 0 - je @3 - add eax, 4 - jmp @s -@1: inc eax - ret -@0: rep ret -@2: add eax, 2 - ret -@3: add eax, 3 -end; - -function StrCompFast(Str1, Str2: pointer): PtrInt; -{$ifdef FPC}nostackframe; assembler;{$endif} -asm // no branch taken in case of not equal first char - cmp eax, edx - je @zero // same string or both nil - test eax, edx - jz @maynil -@1: mov cl, [eax] - mov ch, [edx] - inc eax - inc edx - test cl, cl - jz @exit - cmp cl, ch - je @1 -@exit: movzx eax, cl - movzx edx, ch - sub eax, edx - ret -@maynil:test eax, eax // Str1='' ? - jz @max - test edx, edx // Str2='' ? - jnz @1 - mov eax, 1 - ret -@max: dec eax - ret -@zero: xor eax, eax -end; - -const - EQUAL_EACH = 8; // see https://msdn.microsoft.com/en-us/library/bb531463 - NEGATIVE_POLARITY = 16; - -function StrCompSSE42(Str1, Str2: pointer): PtrInt; -{$ifdef FPC}nostackframe; assembler;{$endif} -asm // warning: may read up to 15 bytes beyond the string itself - test eax, edx - jz @n -@ok: sub eax, edx - {$ifdef HASAESNI} - movups xmm0, dqword [edx] - pcmpistri xmm0, dqword [edx + eax], EQUAL_EACH + NEGATIVE_POLARITY // result in ecx - {$else} - db $F3,$0F,$6F,$02 - db $66,$0F,$3A,$63,$04,$10,EQUAL_EACH+NEGATIVE_POLARITY - {$endif} - ja @1 - jc @2 - xor eax, eax - ret -@1: add edx, 16 - {$ifdef HASAESNI} - movups xmm0, dqword [edx] - pcmpistri xmm0, dqword [edx + eax], EQUAL_EACH + NEGATIVE_POLARITY // result in ecx - {$else} - db $F3,$0F,$6F,$02 - db $66,$0F,$3A,$63,$04,$10,EQUAL_EACH+NEGATIVE_POLARITY - {$endif} - ja @1 - jc @2 -@0: xor eax, eax // Str1=Str2 - ret -@n: cmp eax, edx - je @0 - test eax, eax // Str1='' ? - jz @max - test edx, edx // Str2='' ? - jnz @ok - mov eax, 1 - ret -@max: dec eax - ret -@2: add eax, edx - movzx eax, byte ptr [eax+ecx] - movzx edx, byte ptr [edx+ecx] - sub eax, edx -end; - -function SortDynArrayAnsiStringSSE42(const A,B): integer; -{$ifdef FPC}nostackframe; assembler;{$endif} -asm // warning: may read up to 15 bytes beyond the string itself - mov eax, [eax] - mov edx, [edx] - test eax, edx - jz @n -@ok: sub eax, edx - jz @0 - {$ifdef HASAESNI} - movups xmm0, dqword [edx] // result in ecx - pcmpistri xmm0, dqword [edx+eax], EQUAL_EACH + NEGATIVE_POLARITY - {$else} - db $F3,$0F,$6F,$02 - db $66,$0F,$3A,$63,$04,$10,EQUAL_EACH+NEGATIVE_POLARITY - {$endif} - ja @1 - jc @2 - xor eax, eax - ret -@1: add edx, 16 - {$ifdef HASAESNI} - movups xmm0, dqword [edx] // result in ecx - pcmpistri xmm0, dqword [edx+eax], EQUAL_EACH + NEGATIVE_POLARITY - {$else} - db $F3,$0F,$6F,$02 - db $66,$0F,$3A,$63,$04,$10,EQUAL_EACH+NEGATIVE_POLARITY - {$endif} - ja @1 - jc @2 -@0: xor eax, eax // Str1=Str2 - ret -@n: cmp eax, edx - je @0 - test eax, eax // Str1='' ? - jz @max - test edx, edx // Str2='' ? - jnz @ok - mov eax, -1 - ret -@max: inc eax - ret -@2: add eax, edx - movzx eax, byte ptr [eax+ecx] - movzx edx, byte ptr [edx+ecx] - sub eax, edx -end; - -function StrLenSSE42(S: pointer): PtrInt; -{$ifdef FPC}nostackframe; assembler;{$endif} -asm // warning: may read up to 15 bytes beyond the string itself - mov edx, eax // copy pointer - test eax, eax - jz @null // returns 0 if S=nil - xor eax, eax - {$ifdef HASAESNI} - pxor xmm0, xmm0 - pcmpistri xmm0, dqword[edx], EQUAL_EACH // comparison result in ecx - {$else} - db $66, $0F, $EF, $C0 - db $66, $0F, $3A, $63, $02, EQUAL_EACH - {$endif} - jnz @loop - mov eax, ecx - ret - nop // for @loop alignment -@loop: add eax, 16 - {$ifdef HASAESNI} - pcmpistri xmm0, dqword[edx + eax], EQUAL_EACH // comparison result in ecx - {$else} - db $66, $0F, $3A, $63, $04, $10, EQUAL_EACH - {$endif} - jnz @loop -@ok: add eax, ecx - ret -@null: db $f3 // rep ret -end; - -procedure YearToPChar(Y: PtrUInt; P: PUTF8Char); -{$ifdef FPC}nostackframe; assembler;{$endif} -asm // eax=Y, edx=P - push edx - mov ecx, eax - mov edx, 1374389535 // use power of two reciprocal to avoid division - mul edx - shr edx, 5 // now edx=Y div 100 - movzx eax, word ptr[TwoDigitLookup + edx * 2] - imul edx, -200 - movzx edx, word ptr[TwoDigitLookup + ecx * 2 + edx] - pop ecx - shl edx, 16 - or eax, edx - mov [ecx], eax -end; - -function Iso8601ToTimeLog(const S: RawByteString): TTimeLog; -{$ifdef FPC} nostackframe; assembler; {$endif} asm - xor ecx,ecx // ContainsNoTime=nil - test eax,eax // if s='' -> p=nil -> will return 0, whatever L value is - jz Iso8601ToTimeLogPUTF8Char - mov edx,[eax-4] // edx=L -@1: jmp Iso8601ToTimeLogPUTF8Char -end; - -function UpperCopy(dest: PAnsiChar; const source: RawUTF8): PAnsiChar; -{$ifdef FPC} nostackframe; assembler; {$endif} -asm // eax=dest source=edx - test edx, edx - jz @z - push esi - mov esi, offset NormToUpperAnsi7 - xor ecx, ecx -@1: mov cl, [edx] - inc edx - test cl, cl - mov cl, [esi + ecx] - jz @2 - mov [eax], cl - inc eax - jmp @1 -@2: pop esi -@z: -end; - -function UpperCopyShort(dest: PAnsiChar; const source: shortstring): PAnsiChar; -{$ifdef FPC} nostackframe; assembler; {$endif} -asm // eax=dest source=edx - push esi - push ebx - movzx ebx, byte ptr[edx] // ebx = length(source) - xor ecx, ecx - test ebx, ebx - mov esi, offset NormToUpperAnsi7 - jz @2 // source='' - inc edx -@1: mov cl, [edx] - inc edx - dec ebx - mov cl, [esi + ecx] - mov [eax], cl - lea eax, [eax + 1] - jnz @1 -@2: pop ebx - pop esi -@z: -end; - -function IdemPCharAndGetNextLine(var source: PUTF8Char; searchUp: PAnsiChar): boolean; -{$ifdef FPC} nostackframe; assembler; {$endif} -asm // eax=source edx=searchUp - push eax // save source var - mov eax, [eax] // eax=source - test eax, eax - jz @z - push eax - call IdemPChar - pop ecx // ecx=source - push eax // save result -@1: mov dl, [ecx] // while not (source^ in [#0,#10,#13]) do inc(source) - inc ecx - cmp dl, 13 - ja @1 - je @e - or dl, dl - jz @0 - cmp dl, 10 - jne @1 - jmp @4 -@e: cmp byte ptr[ecx], 10 // jump #13#10 - jne @4 -@3: inc ecx -@4: pop eax // restore result - pop edx // restore source var - mov [edx], ecx // update source var - ret -@0: xor ecx, ecx // set source=nil - jmp @4 -@z: pop edx // ignore source var, result := false -end; - -procedure crcblockNoSSE42(crc128, data128: PBlock128); -{$ifdef FPC} nostackframe; assembler; {$endif} -asm // Delphi is not efficient about compiling above pascal code - push ebp - push edi - push esi - mov ebp, eax // ebp=crc128 edi=data128 - mov edi, edx - mov edx, dword ptr[eax] - mov ecx, dword ptr[eax + 4] - xor edx, dword ptr[edi] - xor ecx, dword ptr[edi + 4] - movzx esi, dl - mov eax, dword ptr[esi * 4 + crc32ctab + 1024 * 3] - movzx esi, dh - shr edx, 16 - xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 2] - movzx esi, dl - xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 1] - movzx esi, dh - xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 0] - mov edx, dword ptr[ebp + 8] - xor edx, dword ptr[edi + 8] - mov dword ptr[ebp], eax - movzx esi, cl - mov eax, dword ptr[esi * 4 + crc32ctab + 1024 * 3] - movzx esi, ch - shr ecx, 16 - xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 2] - movzx esi, cl - xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 1] - movzx esi, ch - xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 0] - mov dword ptr[ebp + 4], eax - mov ecx, dword ptr[ebp + 12] - xor ecx, dword ptr[edi + 12] - movzx esi, dl - mov eax, dword ptr[esi * 4 + crc32ctab + 1024 * 3] - movzx esi, dh - shr edx, 16 - xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 2] - movzx esi, dl - xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 1] - movzx esi, dh - xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 0] - mov dword ptr[ebp + 8], eax - movzx esi, cl - mov eax, dword ptr[esi * 4 + crc32ctab + 1024 * 3] - movzx esi, ch - shr ecx, 16 - xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 2] - movzx esi, cl - xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 1] - movzx esi, ch - xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 0] - mov dword ptr[ebp + 12], eax - pop esi - pop edi - pop ebp -end; - -function crc32cfast(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal; -{$ifdef FPC} nostackframe; assembler; {$endif} -asm // adapted from Aleksandr Sharahov code and Maxim Masiutin remarks - test edx, edx - jz @z - neg ecx - jz @z - not eax - push ebx - push ebp - lea ebp, [crc32ctab] -@head: test dl, 3 - jz @align - movzx ebx, byte ptr[edx] - inc edx - xor bl, al - shr eax, 8 - xor eax, dword ptr[ebx * 4 + ebp] - inc ecx - jnz @head - pop ebp - pop ebx - not eax -@z: ret -@align: sub edx, ecx - add ecx, 8 - jg @done - push esi - push edi - mov edi, edx -@by8: mov edx, eax - mov ebx, [edi + ecx - 4] - xor edx, [edi + ecx - 8] - movzx esi, bl - mov eax, dword ptr[esi * 4 + ebp + 1024 * 3] - movzx esi, bh - xor eax, dword ptr[esi * 4 + ebp + 1024 * 2] - shr ebx, 16 - movzx esi, bl - xor eax, dword ptr[esi * 4 + ebp + 1024 * 1] - movzx esi, bh - xor eax, dword ptr[esi * 4 + ebp + 1024 * 0] - movzx esi, dl - xor eax, dword ptr[esi * 4 + ebp + 1024 * 7] - movzx esi, dh - xor eax, dword ptr[esi * 4 + ebp + 1024 * 6] - shr edx, 16 - movzx esi, dl - xor eax, dword ptr[esi * 4 + ebp + 1024 * 5] - movzx esi, dh - xor eax, dword ptr[esi * 4 + ebp + 1024 * 4] - add ecx, 8 - jle @by8 - mov edx, edi - pop edi - pop esi -@done: sub ecx, 8 - jl @tail - pop ebp - pop ebx - not eax - ret -@tail: movzx ebx, byte[edx + ecx] - xor bl, al - shr eax, 8 - xor eax, dword ptr[ebx * 4 + ebp] - inc ecx - jnz @tail -@e: pop ebp - pop ebx - not eax -end; - -{$ifndef DELPHI5OROLDER} -const - CMP_RANGES = $44; // see https://msdn.microsoft.com/en-us/library/bb531425 - -function UpperCopy255BufSSE42(dest: PAnsiChar; source: PUTF8Char; sourceLen: PtrInt): PAnsiChar; -{$ifdef FPC} nostackframe; assembler; {$endif} -asm // eax=dest edx=source ecx=sourceLen - test ecx,ecx - jz @z - movups xmm1, dqword ptr [@az] - movups xmm3, dqword ptr [@bits] - cmp ecx, 16 - ja @big - // optimize the common case of sourceLen<=16 - movups xmm2, [edx] - {$ifdef HASAESNI} - pcmpistrm xmm1, xmm2, CMP_RANGES // find in range a-z, return mask in xmm0 - {$else} - db $66, $0F, $3A, $62, $CA, CMP_RANGES - {$endif} - pand xmm0, xmm3 - pxor xmm2, xmm0 - movups [eax], xmm2 - add eax, ecx -@z: ret -@big: push eax - cmp ecx, 240 - jb @ok - mov ecx, 239 -@ok: add [esp], ecx // save to return end position with the exact size - shr ecx, 4 - sub edx, eax - inc ecx -@s: movups xmm2, [edx+eax] - {$ifdef HASAESNI} - pcmpistrm xmm1, xmm2, CMP_RANGES - {$else} - db $66, $0F, $3A, $62, $CA, CMP_RANGES - {$endif} - pand xmm0, xmm3 - pxor xmm2, xmm0 - movups [eax], xmm2 - add eax, 16 - dec ecx - jnz @s - pop eax - ret -@az: db 'azazazazazazazaz' // define range for upper case conversion -@bits: db ' ' // $20 = bit to change when changing case -end; -{$endif DELPHI5OROLDER} - -function fnv32(crc: cardinal; buf: PAnsiChar; len: PtrInt): cardinal; -{$ifdef FPC} nostackframe; assembler; {$endif} -asm // eax=crc, edx=buf, ecx=len - push ebx - test edx, edx - jz @0 - neg ecx - jz @0 - sub edx, ecx -@1: movzx ebx, byte ptr[edx + ecx] - xor eax, ebx - imul eax, eax, 16777619 - inc ecx - jnz @1 -@0: pop ebx -end; // we tried an unrolled version, but it was slower on our Core i7! - -function kr32(crc: cardinal; buf: PAnsiChar; len: PtrInt): cardinal; -{$ifdef FPC} nostackframe; assembler; {$endif} -asm // eax=crc, edx=buf, ecx=len - test ecx, ecx - push edi - push esi - push ebx - push ebp - jz @z - cmp ecx, 4 - jb @s -@8: mov ebx, [edx] // unrolled version reading per dword - add edx, 4 - mov esi, eax - movzx edi, bl - movzx ebp, bh - shr ebx, 16 - shl eax, 5 - sub eax, esi - add eax, edi - mov esi, eax - shl eax, 5 - sub eax, esi - lea esi, [eax + ebp] - add eax, ebp - movzx edi, bl - movzx ebx, bh - shl eax, 5 - sub eax, esi - lea ebp, [eax + edi] - add eax, edi - shl eax, 5 - sub eax, ebp - add eax, ebx - cmp ecx, 8 - lea ecx, [ecx - 4] - jae @8 - test ecx, ecx - jz @z -@s: mov esi, eax -@1: shl eax, 5 - movzx ebx, byte ptr[edx] - inc edx - sub eax, esi - lea esi, [eax + ebx] - add eax, ebx - dec ecx - jnz @1 -@z: pop ebp - pop ebx - pop esi - pop edi -end; - -function ToVarInt32(Value: PtrInt; Dest: PByte): PByte; -{$ifdef FPC} nostackframe; assembler; {$endif} -asm - test eax, eax - jnl @pos - neg eax - add eax, eax - jmp ToVarUInt32 -@pos: jz @zer - lea eax, [eax * 2 - 1] - jmp ToVarUInt32 -@zer: mov [edx], al - lea eax, [edx + 1] -end; - -function ToVarUInt32(Value: PtrUInt; Dest: PByte): PByte; -{$ifdef FPC} nostackframe; assembler; {$endif} -asm - cmp eax, $7f - jbe @0 - cmp eax, $00004000 - jb @1 - cmp eax, $00200000 - jb @2 - cmp eax, $10000000 - jb @3 - mov ecx, eax - shr eax, 7 - and cl, $7f - or cl, $80 - mov [edx], cl - inc edx -@3: mov ecx, eax - shr eax, 7 - and cl, $7f - or cl, $80 - mov [edx], cl - inc edx -@2: mov ecx, eax - shr eax, 7 - and cl, $7f - or cl, $80 - mov [edx], cl - inc edx -@1: mov ecx, eax - shr eax, 7 - and cl, $7f - or cl, $80 - mov [edx], cl - inc edx -@0: mov [edx], al - lea eax, [edx + 1] -end; - -function CompareQWord(A, B: QWord): integer; -begin - {$ifdef FPC_OR_UNICODE} // recent compilers are able to generate correct code - result := ord(A>B)-ord(A returns length(a)-length(b) - pop ebx - ret -@d: bsf ebx, ebx // char differs -> returns pbyte(a)^-pbyte(b)^ - shr ebx, 3 - add ecx, ebx - jns @l - movzx eax, byte ptr[eax + ecx] - movzx edx, byte ptr[edx + ecx] - pop ebx - pop ebx - sub eax, edx - ret -@n1: test eax, eax // a or b may be '' - jz @n0 - test edx, edx - jnz @n2 - cmp [eax - 4], edx - je @0 -@no: jnc @1 - mov eax, -1 - ret -@n0: cmp eax, [edx - 4] - je @0 - jnc @1 - mov eax, -1 - ret -@0: xor eax, eax - ret -@1: mov eax, 1 -end; -function SortDynArrayAnsiStringI(const A,B): integer; -{$ifdef FPC} nostackframe; assembler; {$endif} -asm // avoid a call on the stack on x86 platform - mov eax, [eax] - mov edx, [edx] - jmp StrIComp -end; -function SortDynArrayPUTF8Char(const A,B): integer; -{$ifdef FPC} nostackframe; assembler; {$endif} -asm // avoid a call on the stack on x86 platform - mov eax, [eax] - mov edx, [edx] - jmp dword ptr[StrComp] -end; -function SortDynArrayDouble(const A,B): integer; -{$ifdef FPC} nostackframe; assembler; {$endif} asm - fld qword ptr[eax] - fcomp qword ptr[edx] - fstsw ax - sahf - jz @0 -@nz: jnb @p - mov eax, -1 - ret -@0: xor eax, eax - ret -@p: mov eax, 1 -end; -function SortDynArraySingle(const A,B): integer; -{$ifdef FPC} nostackframe; assembler; {$endif} asm - fld dword ptr[eax] - fcomp dword ptr[edx] - fstsw ax - sahf - jz @0 -@nz: jnb @p - mov eax, -1 - ret -@0: xor eax, eax - ret -@p: mov eax, 1 -end; -{$endif PUREPASCAL} - -function PosExChar(Chr: AnsiChar; const Str: RawUTF8): PtrInt; -begin - if Str<>'' then - {$ifdef FPC} // will use fast FPC SSE version - result := IndexByte(pointer(Str)^,PStrLen(PtrUInt(Str)-_STRLEN)^,byte(chr))+1 else - {$else} - for result := 1 to PInteger(PtrInt(Str)-sizeof(Integer))^ do - if Str[result]=Chr then - exit; - {$endif FPC} - result := 0; -end; - -function SplitRight(const Str: RawUTF8; SepChar: AnsiChar; LeftStr: PRawUTF8): RawUTF8; -var i: PtrInt; -begin - for i := length(Str) downto 1 do - if Str[i]=SepChar then begin - result := copy(Str,i+1,maxInt); - if LeftStr<>nil then - LeftStr^ := copy(Str,1,i-1); - exit; - end; - result := Str; - if LeftStr<>nil then - LeftStr^ := ''; -end; - -function SplitRights(const Str, SepChar: RawUTF8): RawUTF8; -var i, j, sep: PtrInt; - c: AnsiChar; -begin - sep := length(SepChar); - if sep > 0 then - if sep = 1 then - result := SplitRight(Str,SepChar[1]) else begin - for i := length(Str) downto 1 do begin - c := Str[i]; - for j := 1 to sep do - if c=SepChar[j] then begin - result := copy(Str,i+1,maxInt); - exit; - end; - end; - end; - result := Str; -end; - -function Split(const Str, SepStr: RawUTF8; StartPos: integer): RawUTF8; -var i: integer; -begin -{$ifdef FPC} // to use fast FPC SSE version - if (StartPos=1) and (length(SepStr)=1) then - i := PosExChar(SepStr[1],Str) else -{$endif FPC} - i := PosEx(SepStr,Str,StartPos); - if i>0 then - result := Copy(Str,StartPos,i-StartPos) else - if StartPos=1 then - result := Str else - result := Copy(Str,StartPos,maxInt); -end; - -procedure Split(const Str, SepStr: RawUTF8; var LeftStr, RightStr: RawUTF8; ToUpperCase: boolean); -var i: integer; - tmp: RawUTF8; // may be called as Split(Str,SepStr,Str,RightStr) -begin - {$ifdef FPC} // to use fast FPC SSE version - if length(SepStr)=1 then - i := PosExChar(SepStr[1],Str) else - {$endif FPC} - i := PosEx(SepStr,Str); - if i=0 then begin - LeftStr := Str; - RightStr := ''; - end else begin - tmp := copy(Str,1,i-1); - RightStr := copy(Str,i+length(SepStr),maxInt); - LeftStr := tmp; - end; - if ToUpperCase then begin - UpperCaseSelf(LeftStr); - UpperCaseSelf(RightStr); - end; -end; - -function Split(const Str, SepStr: RawUTF8; var LeftStr: RawUTF8; ToUpperCase: boolean): RawUTF8; -begin - Split(Str,SepStr,LeftStr,result,ToUpperCase); -end; - -function Split(const Str: RawUTF8; const SepStr: array of RawUTF8; - const DestPtr: array of PRawUTF8): PtrInt; -var s,i,j: PtrInt; -begin - j := 1; - result := 0; - s := 0; - if high(SepStr)>=0 then - while result<=high(DestPtr) do begin - i := PosEx(SepStr[s],Str,j); - if i=0 then begin - if DestPtr[result]<>nil then - DestPtr[result]^ := copy(Str,j,MaxInt); - inc(result); - break; - end; - if DestPtr[result]<>nil then - DestPtr[result]^ := copy(Str,j,i-j); - inc(result); - if snil then - DestPtr[i]^ := ''; -end; - -function StringReplaceAllProcess(const S, OldPattern, NewPattern: RawUTF8; - found: integer): RawUTF8; -var oldlen,newlen,i,last,posCount,sharedlen: integer; - pos: TIntegerDynArray; - src,dst: PAnsiChar; -begin - oldlen := length(OldPattern); - newlen := length(NewPattern); - SetLength(pos,64); - pos[0] := found; - posCount := 1; - repeat - found := PosEx(OldPattern,S,found+oldlen); - if found=0 then - break; - AddInteger(pos,posCount,found); - until false; - FastSetString(result,nil,Length(S)+(newlen-oldlen)*posCount); - last := 1; - src := pointer(s); - dst := pointer(result); - for i := 0 to posCount-1 do begin - sharedlen := pos[i]-last; - MoveFast(src^,dst^,sharedlen); - inc(src,sharedlen+oldlen); - inc(dst,sharedlen); - if newlen>0 then begin - MoveSmall(pointer(NewPattern),dst,newlen); - inc(dst,newlen); - end; - last := pos[i]+oldlen; - end; - MoveFast(src^,dst^,length(S)-last+1); -end; - -function StringReplaceAll(const S, OldPattern, NewPattern: RawUTF8): RawUTF8; -var found: integer; -begin - if (S='') or (OldPattern='') or (OldPattern=NewPattern) then - result := S else begin - found := PosEx(OldPattern,S,1); // our PosEx() is faster than Pos() - if found=0 then - result := S else - result := StringReplaceAllProcess(S,OldPattern,NewPattern,found); - end; -end; - -function StringReplaceAll(const S: RawUTF8; const OldNewPatternPairs: array of RawUTF8): RawUTF8; -var n,i: integer; -begin - result := S; - n := high(OldNewPatternPairs); - if (n>0) and (n and 1=1) then - for i := 0 to n shr 1 do - result := StringReplaceAll(result,OldNewPatternPairs[i*2],OldNewPatternPairs[i*2+1]); -end; - -function StringReplaceTabs(const Source,TabText: RawUTF8): RawUTF8; - - procedure Process(S,D,T: PAnsiChar; TLen: integer); - begin - repeat - if S^=#0 then - break else - if S^<>#9 then begin - D^ := S^; - inc(D); - inc(S); - end else begin - if TLen>0 then begin - MoveSmall(T,D,TLen); - inc(D,TLen); - end; - inc(S); - end; - until false; - end; - -var L,i,n,ttl: PtrInt; -begin - ttl := length(TabText); - L := Length(Source); - n := 0; - if ttl<>0 then - for i := 1 to L do - if Source[i]=#9 then - inc(n); - if n=0 then begin - result := Source; - exit; - end; - FastSetString(result,nil,L+n*pred(ttl)); - Process(pointer(Source),pointer(result),pointer(TabText),ttl); -end; - -function strspnpas(s,accept: pointer): integer; -var p: PCardinal; - c: AnsiChar; - d: cardinal; -begin // returns size of initial segment of s which are in accept - result := 0; - repeat - c := PAnsiChar(s)[result]; - if c=#0 then - break; - p := accept; - repeat // stop as soon as we find any character not from accept - d := p^; - inc(p); - if AnsiChar(d)=c then - break else - if AnsiChar(d)=#0 then - exit; - d := d shr 8; - if AnsiChar(d)=c then - break else - if AnsiChar(d)=#0 then - exit; - d := d shr 8; - if AnsiChar(d)=c then - break else - if AnsiChar(d)=#0 then - exit; - d := d shr 8; - if AnsiChar(d)=c then - break else - if AnsiChar(d)=#0 then - exit; - until false; - inc(result); - until false; -end; - -function strcspnpas(s,reject: pointer): integer; -var p: PCardinal; - c: AnsiChar; - d: cardinal; -begin // returns size of initial segment of s which are not in reject - result := 0; - repeat - c := PAnsiChar(s)[result]; - if c=#0 then - break; - p := reject; - repeat // stop as soon as we find any character from reject - d := p^; - inc(p); - if AnsiChar(d)=c then - exit else - if AnsiChar(d)=#0 then - break; - d := d shr 8; - if AnsiChar(d)=c then - exit else - if AnsiChar(d)=#0 then - break; - d := d shr 8; - if AnsiChar(d)=c then - exit else - if AnsiChar(d)=#0 then - break; - d := d shr 8; - if AnsiChar(d)=c then - exit else - if AnsiChar(d)=#0 then - break; - until false; - inc(result); - until false; -end; - -{$ifndef ABSOLUTEPASCAL} -{$ifdef CPUINTEL} -{$ifdef CPUX64} // inspired by Agner Fog's strspn64.asm -function strcspnsse42(s,reject: pointer): integer; -{$ifdef FPC}nostackframe; assembler; asm {$else} -asm .noframe // rcx=s, rdx=reject (Linux: rdi,rsi) -{$endif FPC} -{$ifdef win64} - push rdi - push rsi - mov rdi, rcx - mov rsi, rdx -{$endif}mov r8, rsi - xor ecx, ecx -@1: movups xmm2, [rdi] - movups xmm1, [rsi] - {$ifdef HASAESNI} - pcmpistrm xmm1, xmm2, $30 // find in set, invert valid bits, return bit mask in xmm0 - {$else} - db $66,$0F,$3A,$62,$CA,$30 - {$endif} - movd eax, xmm0 - jns @5 -@2: cmp eax, 65535 - jne @3 - add rdi, 16 // first 16 chars matched, continue with next 16 chars - add rcx, 16 - jmp @1 -@3: not eax - bsf eax, eax - add rax, rcx -{$ifdef win64} - pop rsi - pop rdi -{$endif}ret -@4: and eax, edx // accumulate matches -@5: add rsi, 16 // the set is more than 16 bytes - movups xmm1, [rsi] - {$ifdef HASAESNI} - pcmpistrm xmm1, xmm2, $30 - {$else} - db $66,$0F,$3A,$62,$CA,$30 - {$endif} - movd edx, xmm0 - jns @4 - mov rsi, r8 // restore set pointer - and eax, edx // accumulate matches - cmp eax, 65535 - jne @3 - add rdi, 16 - add rcx, 16 - jmp @1 -end; -function strspnsse42(s,accept: pointer): integer; -{$ifdef FPC}nostackframe; assembler; asm {$else} -asm .noframe // rcx=s, rdx=accept (Linux: rdi,rsi) -{$endif FPC} -{$ifdef win64} - push rdi - push rsi - mov rdi, rcx - mov rsi, rdx -{$endif}mov r8, rsi - xor ecx, ecx -@1: movups xmm2, [rdi] - movups xmm1, [rsi] - {$ifdef HASAESNI} - pcmpistrm xmm1, xmm2, $00 // find in set, return bit mask in xmm0 - {$else} - db $66,$0F,$3A,$62,$CA,$00 - {$endif} - movd eax, xmm0 - jns @5 -@2: cmp eax, 65535 - jne @3 - add rdi, 16 // first 16 chars matched, continue with next 16 chars - add rcx, 16 - jmp @1 -@3: not eax - bsf eax, eax - add rax, rcx -{$ifdef win64} - pop rsi - pop rdi -{$endif}ret -@4: or eax, edx // accumulate matches -@5: add rsi, 16 // the set is more than 16 bytes - movups xmm1, [rsi] - {$ifdef HASAESNI} - pcmpistrm xmm1, xmm2, $00 - {$else} - db $66,$0F,$3A,$62,$CA,$00 - {$endif} - movd edx, xmm0 - jns @4 - mov rsi, r8 // restore set pointer - or eax, edx // accumulate matches - cmp eax, 65535 - jne @3 - add rdi, 16 // first 16 chars matched, continue with next 16 chars - add rcx, 16 - jmp @1 -end; -{$endif CPUX64} -{$ifdef CPUX86} -function strcspnsse42(s,reject: pointer): integer; {$ifdef FPC} nostackframe; assembler; {$endif} -asm // eax=s, edx=reject - push edi - push esi - push ebx - mov edi, eax - mov esi, edx - mov ebx, esi - xor ecx, ecx -@1: {$ifdef HASAESNI} - movups xmm2, dqword [edi] - movups xmm1, dqword [esi] - pcmpistrm xmm1, xmm2, $30 // find in set, invert valid bits, return bit mask in xmm0 - movd eax, xmm0 - {$else} - db $F3,$0F,$6F,$17 - db $F3,$0F,$6F,$0E - db $66,$0F,$3A,$62,$CA,$30 - db $66,$0F,$7E,$C0 - {$endif} - jns @5 -@2: cmp eax, 65535 - jne @3 - add edi, 16 // first 16 chars matched, continue with next 16 chars - add ecx, 16 - jmp @1 -@3: not eax - bsf eax, eax - add eax, ecx - pop ebx - pop esi - pop edi - ret -@4: and eax, edx // accumulate matches -@5: add esi, 16 // the set is more than 16 bytes - {$ifdef HASAESNI} - movups xmm1, [esi] - pcmpistrm xmm1, xmm2, $30 - movd edx, xmm0 - {$else} - db $F3,$0F,$6F,$0E - db $66,$0F,$3A,$62,$CA,$30 - db $66,$0F,$7E,$C2 - {$endif} - jns @4 - mov esi, ebx // restore set pointer - and eax, edx // accumulate matches - cmp eax, 65535 - jne @3 - add edi, 16 // first 16 chars matched, continue with next 16 chars - add ecx, 16 - jmp @1 -end; -function strspnsse42(s,accept: pointer): integer; {$ifdef FPC} nostackframe; assembler; {$endif} -asm // eax=s, edx=accept - push edi - push esi - push ebx - mov edi, eax - mov esi, edx - mov ebx, esi - xor ecx, ecx -@1: {$ifdef HASAESNI} - movups xmm2, dqword [edi] - movups xmm1, dqword [esi] - pcmpistrm xmm1, xmm2, $00 // find in set, return bit mask in xmm0 - movd eax, xmm0 - {$else} - db $F3,$0F,$6F,$17 - db $F3,$0F,$6F,$0E - db $66,$0F,$3A,$62,$CA,$00 - db $66,$0F,$7E,$C0 - {$endif} - jns @5 -@2: cmp eax, 65535 - jne @3 - add edi, 16 // first 16 chars matched, continue with next 16 chars - add ecx, 16 - jmp @1 -@3: not eax - bsf eax, eax - add eax, ecx - pop ebx - pop esi - pop edi - ret -@4: or eax, edx // accumulate matches -@5: add esi, 16 // the set is more than 16 bytes - {$ifdef HASAESNI} - movups xmm1, [esi] - pcmpistrm xmm1, xmm2, $00 - movd edx, xmm0 - {$else} - db $F3,$0F,$6F,$0E - db $66,$0F,$3A,$62,$CA,$00 - db $66,$0F,$7E,$C2 - {$endif} - jns @4 - mov esi, ebx // restore set pointer - or eax, edx // accumulate matches - cmp eax, 65535 - jne @3 - add edi, 16 // first 16 chars matched, continue with next 16 chars - add ecx, 16 - jmp @1 -end; -{$ifndef DELPHI5OROLDER} -function StrLenSSE2(S: pointer): PtrInt; {$ifdef FPC} nostackframe; assembler; {$endif} -asm // from GPL strlen32.asm by Agner Fog - www.agner.org/optimize - mov ecx, eax // copy pointer - test eax, eax - jz @null // returns 0 if S=nil - push eax // save start address - pxor xmm0, xmm0 // set to zero - and ecx, 15 // lower 4 bits indicate misalignment - and eax, -16 // align pointer by 16 - // will never read outside a memory page boundary, so won't trigger GPF - movaps xmm1, [eax] // read from nearest preceding boundary - pcmpeqb xmm1, xmm0 // compare 16 bytes with zero - pmovmskb edx, xmm1 // get one bit for each byte result - shr edx, cl // shift out false bits - shl edx, cl // shift back again - bsf edx, edx // find first 1-bit - jnz @A200 // found - // Main loop, search 16 bytes at a time -@A100: add eax, 10H // increment pointer by 16 - movaps xmm1, [eax] // read 16 bytes aligned - pcmpeqb xmm1, xmm0 // compare 16 bytes with zero - pmovmskb edx, xmm1 // get one bit for each byte result - bsf edx, edx // find first 1-bit - // (moving the bsf out of the loop and using test here would be faster - // for long strings on old processors, but we are assuming that most - // strings are short, and newer processors have higher priority) - jz @A100 // loop if not found -@A200: // Zero-byte found. Compute string length - pop ecx // restore start address - sub eax, ecx // subtract start address - add eax, edx // add byte index -@null: -end; -{$endif DELPHI5OROLDER} -{$endif CPUX86} -{$endif CPUINTEL} -{$endif ABSOLUTEPASCAL} - -function IdemPropName(const P1,P2: shortstring): boolean; -begin - if P1[0]=P2[0] then - result := IdemPropNameUSameLen(@P1[1],@P2[1],ord(P2[0])) else - result := false; -end; - -function IdemPropName(const P1: shortstring; P2: PUTF8Char; P2Len: PtrInt): boolean; -begin - if ord(P1[0])=P2Len then - result := IdemPropNameUSameLen(@P1[1],P2,P2Len) else - result := false; -end; - -function IdemPropName(P1,P2: PUTF8Char; P1Len,P2Len: PtrInt): boolean; -begin - if P1Len=P2Len then - result := IdemPropNameUSameLen(P1,P2,P2Len) else - result := false; -end; - -function IdemPropNameU(const P1: RawUTF8; P2: PUTF8Char; P2Len: PtrInt): boolean; -begin - if length(P1)=P2Len then - result := IdemPropNameUSameLen(pointer(P1),P2,P2Len) else - result := false; -end; - -function ToText(os: TOperatingSystem): PShortString; -begin - result := GetEnumName(TypeInfo(TOperatingSystem),ord(os)); -end; - -function ToText(const osv: TOperatingSystemVersion): ShortString; -begin - if osv.os=osWindows then - FormatShort('Windows %', [WINDOWS_NAME[osv.win]], result) else - TrimLeftLowerCaseToShort(ToText(osv.os),result); -end; - -function ToTextOS(osint32: integer): RawUTF8; -var osv: TOperatingSystemVersion absolute osint32; - ost: ShortString; -begin - ost := ToText(osv); - if (osv.os>=osLinux) and (osv.utsrelease[2]<>0) then - result := FormatUTF8('% %.%.%',[ost,osv.utsrelease[2],osv.utsrelease[1],osv.utsrelease[0]]) else - result := ShortStringToUTF8(ost); -end; - -{$ifdef MSWINDOWS} -procedure FileTimeToInt64(const FT: TFileTime; out I64: Int64); -begin - {$ifdef CPU64} - PInt64Rec(@I64)^.Lo := FT.dwLowDateTime; - PInt64Rec(@I64)^.Hi := FT.dwHighDateTime; - {$else} - I64 := PInt64(@FT)^; - {$endif} -end; - -const - // lpMinimumApplicationAddress retrieved from Windows is very low $10000 - // - i.e. maximum number of ID per table would be 65536 in TSQLRecord.GetID - // - so we'll force an higher and almost "safe" value as 1,048,576 - // (real value from runnning Windows is greater than $400000) - MIN_PTR_VALUE = $100000; - - // see http://msdn.microsoft.com/en-us/library/ms724833(v=vs.85).aspx - VER_NT_WORKSTATION = 1; - VER_NT_DOMAIN_CONTROLLER = 2; - VER_NT_SERVER = 3; - SM_SERVERR2 = 89; - PROCESSOR_ARCHITECTURE_AMD64 = 9; - -{$ifndef UNICODE} -function GetVersionEx(var lpVersionInformation: TOSVersionInfoEx): BOOL; stdcall; - external kernel32 name 'GetVersionExA'; -{$endif} - -threadvar // mandatory: GetTickCount seems per-thread on XP :( - LastTickXP: TQWordRec; - -function GetTickCount64ForXP: Int64; stdcall; -var t32: cardinal; - p: PQWordRec; -begin // warning: GetSystemTimeAsFileTime() is fast, but not monotonic! - t32 := Windows.GetTickCount; - p := @LastTickXP; - if t320) or not SwitchToThread then - Windows.Sleep(ms); -end; - -{ TWinRegistry } - -function TWinRegistry.ReadOpen(root: HKEY; const keyname: RawUTF8; - closefirst: boolean): boolean; -var tmp: TSynTempBuffer; -begin - if closefirst then - Close; - tmp.Init(length(keyname)*2); - UTF8ToWideChar(tmp.buf,pointer(keyname)); - key := 0; - result := RegOpenKeyExW(root,tmp.buf,0,KEY_READ,key)=0; - tmp.Done; -end; - -procedure TWinRegistry.Close; -begin - if key<>0 then - RegCloseKey(key); -end; - -function TWinRegistry.ReadString(const entry: SynUnicode; andtrim: boolean): RawUTF8; -var rtype, rsize: DWORD; - tmp: TSynTempBuffer; -begin - result := ''; - if RegQueryValueExW(key,pointer(entry),nil,@rtype,nil,@rsize)<>0 then - exit; - tmp.Init(rsize); - if RegQueryValueExW(key,pointer(entry),nil,nil,tmp.buf,@rsize)=0 then begin - case rtype of - REG_SZ, REG_EXPAND_SZ, REG_MULTI_SZ: - RawUnicodeToUtf8(tmp.buf,StrLenW(tmp.buf),result); - end; - if andtrim then - result := Trim(result); - end; - tmp.Done; -end; - -function TWinRegistry.ReadData(const entry: SynUnicode): RawByteString; -var rtype, rsize: DWORD; -begin - result := ''; - if RegQueryValueExW(key,pointer(entry),nil,@rtype,nil,@rsize)<>0 then - exit; - SetLength(result,rsize); - if RegQueryValueExW(key,pointer(entry),nil,nil,pointer(result),@rsize)<>0 then - result := ''; -end; - -function TWinRegistry.ReadDword(const entry: SynUnicode): cardinal; -var rsize: DWORD; -begin - rsize := 4; - if RegQueryValueExW(key,pointer(entry),nil,nil,@result,@rsize)<>0 then - result := 0; -end; - -function TWinRegistry.ReadQword(const entry: SynUnicode): QWord; -var rsize: DWORD; -begin - rsize := 8; - if RegQueryValueExW(key,pointer(entry),nil,nil,@result,@rsize)<>0 then - result := 0; -end; - -function TWinRegistry.ReadEnumEntries: TRawUTF8DynArray; -var count,maxlen,i,len: DWORD; - tmp: TSynTempBuffer; -begin - result := nil; - if (RegQueryInfoKeyW(key,nil,nil,nil,@count,@maxlen,nil,nil,nil,nil,nil,nil)<>0) or - (count=0) then - exit; - SetLength(result,count); - inc(maxlen); - tmp.Init(maxlen*3); - for i := 0 to count-1 do begin - len := maxlen; - if RegEnumKeyExW(key,i,tmp.buf,len,nil,nil,nil,nil)=0 then - RawUnicodeToUtf8(tmp.buf,len,result[i]); - end; - tmp.Done; -end; - - -procedure RetrieveSystemInfo; -var - IsWow64Process: function(Handle: THandle; var Res: BOOL): BOOL; stdcall; - GetNativeSystemInfo: procedure(var SystemInfo: TSystemInfo); stdcall; - wine_get_version: function: PAnsiChar; stdcall; - Res: BOOL; - h: THandle; - P: pointer; - Vers: TWindowsVersion; - cpu, manuf, prod, prodver: RawUTF8; - reg: TWinRegistry; -begin - h := GetModuleHandle(kernel32); - GetTickCount64 := GetProcAddress(h,'GetTickCount64'); - if not Assigned(GetTickCount64) then // WinXP+ - GetTickCount64 := @GetTickCount64ForXP; - GetSystemTimePreciseAsFileTime := GetProcAddress(h,'GetSystemTimePreciseAsFileTime'); - if not Assigned(GetSystemTimePreciseAsFileTime) then // Win8+ - GetSystemTimePreciseAsFileTime := @GetSystemTimeAsFileTime; - IsWow64Process := GetProcAddress(h,'IsWow64Process'); - Res := false; - IsWow64 := Assigned(IsWow64Process) and - IsWow64Process(GetCurrentProcess,Res) and Res; - FillcharFast(SystemInfo,SizeOf(SystemInfo),0); - if IsWow64 then // see http://msdn.microsoft.com/en-us/library/ms724381(v=VS.85).aspx - GetNativeSystemInfo := GetProcAddress(h,'GetNativeSystemInfo') else - @GetNativeSystemInfo := nil; - if Assigned(GetNativeSystemInfo) then - GetNativeSystemInfo(SystemInfo) else - Windows.GetSystemInfo(SystemInfo); - GetMem(P,10); // ensure that using MIN_PTR_VALUE won't break anything - if (PtrUInt(P)>MIN_PTR_VALUE) and - (PtrUInt(SystemInfo.lpMinimumApplicationAddress)<=MIN_PTR_VALUE) then - PtrUInt(SystemInfo.lpMinimumApplicationAddress) := MIN_PTR_VALUE; - Freemem(P); - OSVersionInfo.dwOSVersionInfoSize := SizeOf(OSVersionInfo); - GetVersionEx(OSVersionInfo); - Vers := wUnknown; - with OSVersionInfo do - // see https://msdn.microsoft.com/en-us/library/windows/desktop/ms724833 - case dwMajorVersion of - 5: case dwMinorVersion of - 0: Vers := w2000; - 1: Vers := wXP; - 2: if (wProductType=VER_NT_WORKSTATION) and - (SystemInfo.wProcessorArchitecture=PROCESSOR_ARCHITECTURE_AMD64) then - Vers := wXP_64 else - if GetSystemMetrics(SM_SERVERR2)=0 then - Vers := wServer2003 else - Vers := wServer2003_R2; - end; - 6: case dwMinorVersion of - 0: Vers := wVista; - 1: Vers := wSeven; - 2: Vers := wEight; - 3: Vers := wEightOne; - 4: Vers := wTen; - end; - 10: Vers := wTen; - end; - if Vers>=wVista then begin - if OSVersionInfo.wProductType<>VER_NT_WORKSTATION then begin // Server edition - inc(Vers,2); // e.g. wEight -> wServer2012 - if (Vers=wServer2016) and (OSVersionInfo.dwBuildNumber>=17763) then - Vers := wServer2019_64; // https://stackoverflow.com/q/53393150 - end else if (Vers=wTen) and (OSVersionInfo.dwBuildNumber>=22000) then - Vers := wEleven; // waiting for an official mean of Windows 11 identification - if (SystemInfo.wProcessorArchitecture=PROCESSOR_ARCHITECTURE_AMD64) and - (Vers wEight64 - end; - OSVersion := Vers; - with OSVersionInfo do - if wServicePackMajor=0 then - FormatUTF8('Windows % (%.%.%)',[WINDOWS_NAME[Vers], - dwMajorVersion,dwMinorVersion,dwBuildNumber],OSVersionText) else - FormatUTF8('Windows % SP% (%.%.%)',[WINDOWS_NAME[Vers],wServicePackMajor, - dwMajorVersion,dwMinorVersion,dwBuildNumber],OSVersionText); - OSVersionInt32 := (integer(Vers) shl 8)+ord(osWindows); - if reg.ReadOpen(HKEY_LOCAL_MACHINE,'Hardware\Description\System\CentralProcessor\0') then begin - cpu := reg.ReadString('ProcessorNameString'); - if cpu='' then - cpu := reg.ReadString('Identifier'); - end; - if reg.ReadOpen(HKEY_LOCAL_MACHINE,'Hardware\Description\System\BIOS',true) then begin - manuf := reg.ReadString('SystemManufacturer'); - if manuf<>'' then - manuf := manuf+' '; - prod := reg.ReadString('SystemProductName'); - prodver := reg.ReadString('SystemVersion'); - if prodver='' then - prodver := reg.ReadString('BIOSVersion'); - end; - if (prod='') or (prodver='') then begin - if reg.ReadOpen(HKEY_LOCAL_MACHINE,'Hardware\Description\System',true) then begin - if prod='' then - prod := reg.ReadString('SystemBiosVersion'); - if prodver='' then - prodver := reg.ReadString('VideoBiosVersion'); - end; - end; - reg.Close; - if prodver<>'' then - FormatUTF8('%% %',[manuf,prod,prodver],BiosInfoText) else - FormatUTF8('%%',[manuf,prod],BiosInfoText); - if cpu='' then - cpu := StringToUTF8(GetEnvironmentVariable('PROCESSOR_IDENTIFIER')); - cpu := Trim(cpu); - FormatUTF8('% x % ('+CPU_ARCH_TEXT+')',[SystemInfo.dwNumberOfProcessors,cpu],CpuInfoText); - h := LoadLibrary('ntdll.dll'); - if h>0 then begin - wine_get_version := GetProcAddress(h,'wine_get_version'); - if Assigned(wine_get_version) then - OSVersionInfoEx := trim('Wine '+trim(wine_get_version)); - FreeLibrary(h); - end; - if OSVersionInfoEx<>'' then - OSVersionText := FormatUTF8('% - %', [OSVersionText,OSVersionInfoEx]); -end; - -{$else} - -{$ifndef BSD} -procedure SetLinuxDistrib(const release: RawUTF8); -var - distrib: TOperatingSystem; - dist: RawUTF8; -begin - for distrib := osArch to high(distrib) do begin - dist := UpperCase(TrimLeftLowerCaseShort(ToText(distrib))); - if PosI(pointer(dist),release)>0 then begin - OS_KIND := distrib; - break; - end; - end; -end; -{$endif BSD} - -procedure RetrieveSystemInfo; -var modname, beg: PUTF8Char; - {$ifdef BSD} - temp: shortstring; - {$else} - cpuinfo: PUTF8Char; - proccpuinfo,prod,prodver,release,dist: RawUTF8; - SR: TSearchRec; - {$endif BSD} -begin - modname := nil; - {$ifdef BSD} - fpuname(SystemInfo.uts); - SystemInfo.dwNumberOfProcessors := fpsysctlhwint(HW_NCPU); - Utf8ToRawUTF8(fpsysctlhwstr(HW_MACHINE,temp),BiosInfoText); - modname := fpsysctlhwstr(HW_MODEL,temp); - with SystemInfo.uts do - FormatUTF8('%-% %',[sysname,release,version],OSVersionText); - {$else} - {$ifdef KYLIX3} - uname(SystemInfo.uts); - {$else} - fpuname(SystemInfo.uts); - {$endif KYLIX3} - prod := Trim(StringFromFile('/sys/class/dmi/id/product_name',true)); - if prod<>'' then begin - prodver := Trim(StringFromFile('/sys/class/dmi/id/product_version',true)); - if prodver<>'' then - FormatUTF8('% %',[prod,prodver],BiosInfoText) else - BiosInfoText := prod; - end; - SystemInfo.dwNumberOfProcessors := 0; - proccpuinfo := StringFromFile('/proc/cpuinfo',true); - cpuinfo := pointer(proccpuinfo); - while cpuinfo<>nil do begin - beg := cpuinfo; - cpuinfo := GotoNextLine(cpuinfo); - if IdemPChar(beg,'PROCESSOR') then - if beg^='P' then - modname := beg else // Processor : ARMv7 - inc(SystemInfo.dwNumberOfProcessors) else // processor : 0 - if IdemPChar(beg,'MODEL NAME') then - modname := beg; - end; - modname := PosChar(modname,':'); - if modname<>nil then - modname := GotoNextNotSpace(modname+1); - FindNameValue(StringFromFile('/etc/os-release'),'PRETTY_NAME=',release); - if (release<>'') and (release[1]='"') then - release := copy(release,2,length(release)-2); - release := trim(release); - if release='' then - if FindNameValue(StringFromFile('/etc/lsb-release'),'DISTRIB_DESCRIPTION=',release) and - (release<>'') and (release[1]='"') then - release := copy(release,2,length(release)-2); - if (release='') and (FindFirst('/etc/*-release',faAnyFile,SR)=0) then begin - release := StringToUTF8(SR.Name); // 'redhat-release' 'SuSE-release' - if IdemPChar(pointer(release),'LSB-') and (FindNext(SR)=0) then - release := StringToUTF8(SR.Name); - release := split(release,'-'); - dist := split(trim(StringFromFile('/etc/'+SR.Name)),#10); - if (dist<>'') and (PosExChar('=',dist)=0) and (PosExChar(' ',dist)>0) then - SetLinuxDistrib(dist) // e.g. 'Red Hat Enterprise Linux Server release 6.7 (Santiago)' - else - dist := ''; - FindClose(SR); - end; - if (release<>'') and (OS_KIND=osLinux) then begin - SetLinuxDistrib(release); - if (OS_KIND=osLinux) and (dist<>'') then begin - SetLinuxDistrib(dist); - release := dist; - end; - if (OS_KIND=osLinux) and ((PosEx('RH',release)>0) or (PosEx('Red Hat',release)>0)) then - OS_KIND := osRedHat; - end; - SystemInfo.release := release; - {$endif BSD} - OSVersionInt32 := {$ifdef FPC}integer(KernelRevision shl 8)+{$endif}ord(OS_KIND); - with SystemInfo.uts do - FormatUTF8('% %',[sysname,release],OSVersionText); - if SystemInfo.release<>'' then - OSVersionText := FormatUTF8('% - %',[SystemInfo.release,OSVersionText]); - {$ifdef Android} - OSVersionText := 'Android ('+OSVersionText+')'; - {$endif} - if (SystemInfo.dwNumberOfProcessors>0) and (modname<>nil) then begin - beg := modname; - while not (ord(modname^) in [0,10,13]) do begin - if modname^<' ' then - modname^ := ' '; - inc(modname); - end; - modname^ := #0; - FormatUTF8('% x % ('+CPU_ARCH_TEXT+')',[SystemInfo.dwNumberOfProcessors,beg],CpuInfoText); - end; - if CpuInfoText='' then - CpuInfoText := CPU_ARCH_TEXT; -end; - -{$ifdef KYLIX3} -function FileOpen(const FileName: string; Mode: LongWord): Integer; -const - SHAREMODE: array[0..fmShareDenyNone shr 4] of Byte = ( - 0, // No share mode specified - F_WRLCK, // fmShareExclusive - F_RDLCK, // fmShareDenyWrite - 0); // fmShareDenyNone -var FileHandle, Tvar: Integer; - LockVar: TFlock; - smode: Byte; -begin - result := -1; - if FileExists(FileName) and - ((Mode and 3)<=fmOpenReadWrite) and ((Mode and $F0)<=fmShareDenyNone) then begin - FileHandle := open64(pointer(FileName),(Mode and 3),FileAccessRights); - if FileHandle=-1 then - exit; - smode := Mode and $F0 shr 4; - if SHAREMODE[smode]<>0 then begin - with LockVar do begin - l_whence := SEEK_SET; - l_start := 0; - l_len := 0; - l_type := SHAREMODE[smode]; - end; - Tvar := fcntl(FileHandle,F_SETLK,LockVar); - if Tvar=-1 then begin - __close(FileHandle); - exit; - end; - end; - result := FileHandle; - end; -end; - -function GetTickCount64: Int64; -begin - result := SynKylix.GetTickCount64; -end; -{$endif KYLIX3} - -{$ifdef FPC} -function GetTickCount64: Int64; -begin - result := SynFPCLinux.GetTickCount64; -end; -{$endif FPC} - -{$endif MSWINDOWS} - -function FileOpenSequentialRead(const FileName: string): Integer; -begin - {$ifdef MSWINDOWS} - if OSVersion>=wVista then // don't use the flag on XP - result := CreateFile(pointer(FileName),GENERIC_READ, - FILE_SHARE_READ or FILE_SHARE_WRITE,nil, // same as fmShareDenyNone - OPEN_EXISTING,FILE_FLAG_SEQUENTIAL_SCAN,0) else - result := FileOpen(FileName,fmOpenRead or fmShareDenyNone); - {$else} - // SysUtils.FileOpen = fpOpen + fpFlock - assuming FileName is UTF-8 - result := fpOpen(pointer(FileName), O_RDONLY); - {$endif MSWINDOWS} -end; - -type -{$ifdef DELPHI5ORFPC} // TFileStream doesn't have per-handle constructor like Delphi - TFileStreamFromHandle = class(THandleStream) - public - destructor Destroy; override; - end; - -destructor TFileStreamFromHandle.Destroy; -begin - FileClose(Handle); // otherwise file is still opened -end; -{$else} - TFileStreamFromHandle = TFileStream; -{$endif DELPHI5ORFPC} - -function FileStreamSequentialRead(const FileName: string): THandleStream; -begin - result := TFileStreamFromHandle.Create(FileOpenSequentialRead(FileName)); -end; - -function Elapsed(var PreviousTix: Int64; Interval: Integer): Boolean; -var now: Int64; -begin - if Interval<=0 then - result := false else begin - now := {$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64; - if now-PreviousTix>Interval then begin - PreviousTix := now; - result := true; - end else - result := false; - end; -end; - -function StrCntDecFree(var refcnt: TStrCnt): boolean; -{$ifdef CPUINTEL} {$ifdef FPC}nostackframe; assembler; {$endif} -asm {$ifdef CPU64DELPHI} .noframe {$endif} - {$ifdef STRCNT32} - lock dec dword ptr[refcnt] - {$else} - lock dec qword ptr[refcnt] - {$endif STRCNT32} - setbe al -end; // we don't check for ismultithread global since lock is cheap on new CPUs -{$else} -begin // fallback to RTL asm e.g. for ARM - {$ifdef STRCNT32} - result := InterLockedDecrement(refcnt)<=0; - {$else} - result := InterLockedDecrement64(refcnt)<=0; - {$endif STRCNT32} -end; -{$endif CPUINTEL} - -function DACntDecFree(var refcnt: TDACnt): boolean; -{$ifdef CPUINTEL} {$ifdef FPC}nostackframe; assembler; {$endif} -asm {$ifdef CPU64DELPHI} .noframe {$endif} - {$ifdef DACNT32} - lock dec dword ptr[refcnt] - {$else} - lock dec qword ptr[refcnt] - {$endif DACNT32} - setbe al -end; // we don't check for ismultithread global since lock is cheap on new CPUs -{$else} -begin // fallback to RTL asm e.g. for ARM - {$ifdef DACNT32} - result := InterLockedDecrement(refcnt)<=0; - {$else} - result := InterLockedDecrement64(refcnt)<=0; - {$endif DACNT32} -end; -{$endif CPUINTEL} - -{$ifndef FPC} // FPC has its built-in InterlockedIncrement/InterlockedDecrement -{$ifdef PUREPASCAL} -function InterlockedIncrement(var I: Integer): Integer; -begin - {$ifdef MSWINDOWS} // AtomicIncrement() may not be available e.g. on Delphi XE2 - result := Windows.InterlockedIncrement(I); - {$else} - result := AtomicIncrement(I); - {$endif} -end; - -function InterlockedDecrement(var I: Integer): Integer; -begin - {$ifdef MSWINDOWS} // AtomicDecrement() may not be available e.g. on Delphi XE2 - result := Windows.InterlockedDecrement(I); - {$else} - result := AtomicDecrement(I); - {$endif} -end; -{$else} -function InterlockedIncrement(var I: Integer): Integer; -asm - mov edx, 1 - xchg eax, edx - lock xadd [edx], eax - inc eax -end; -function InterlockedDecrement(var I: Integer): Integer; -asm - mov edx, -1 - xchg eax, edx - lock xadd [edx], eax - dec eax -end; -{$endif} -{$endif FPC} - -function GetHighUTF8UCS4(var U: PUTF8Char): PtrUInt; -var extra,i: PtrInt; - c: PtrUInt; -begin - result := 0; - c := byte(U^); // here U^>=#80 - inc(U); - extra := UTF8_EXTRABYTES[c]; - if extra=0 then exit else // invalid leading byte - for i := 1 to extra do begin - if byte(U^) and $c0<>$80 then - exit; // invalid input content - c := c shl 6+byte(U^); - inc(U); - end; - with UTF8_EXTRA[extra] do begin - dec(c,offset); - if c=#80 - inc(U); - extra := UTF8_EXTRABYTES[c]; - if extra=0 then exit else // invalid leading byte - for i := 1 to extra do begin - if byte(U^) and $c0<>$80 then - exit; // invalid input content - c := c shl 6+byte(U^); - inc(U); - end; - with UTF8_EXTRA[extra] do begin - dec(c,offset); - if c=127) or not(tcWord in TEXT_BYTES[c]); - repeat - V := U; - c := GetNextUTF8Upper(U); - if c=0 then - exit; - until (c<127) and (tcWord in TEXT_BYTES[c]); - result := V; -end; - -{$ifdef USENORMTOUPPER} - -function AnsiICompW(u1, u2: PWideChar): PtrInt; {$ifdef HASINLINE}inline;{$endif} -var C1,C2: PtrInt; - table: {$ifdef CPUX86NOTPIC}TNormTableByte absolute NormToUpperAnsi7Byte{$else}PNormTableByte{$endif}; -begin - if u1<>u2 then - if u1<>nil then - if u2<>nil then begin - {$ifndef CPUX86NOTPIC}table := @NormToUpperAnsi7Byte;{$endif} - repeat - C1 := PtrInt(u1^); - C2 := PtrInt(u2^); - result := C1-C2; - if result<>0 then begin - if (C1>255) or (C2>255) then exit; - result := table[C1]-table[C2]; - if result<>0 then exit; - end; - if (C1=0) or (C2=0) then break; - inc(u1); - inc(u2); - until false; - end else - result := 1 else // u2='' - result := -1 else // u1='' - result := 0; // u1=u2 -end; - - -{$ifdef PUREPASCAL} -function AnsiIComp(Str1, Str2: pointer): PtrInt; -var C1,C2: byte; // integer/PtrInt are actually slower on FPC - lookupper: PByteArray; // better x86-64 / PIC asm generation -begin - result := PtrInt(PtrUInt(Str2))-PtrInt(PtrUInt(Str1)); - if result<>0 then - if Str1<>nil then - if Str2<>nil then begin - lookupper := @NormToUpperByte; - repeat - C1 := lookupper[PByteArray(Str1)[0]]; - C2 := lookupper[PByteArray(Str1)[result]]; - inc(PByte(Str1)); - until (C1=0) or (C1<>C2); - result := C1-C2; - end else - result := 1 else // Str2='' - result := -1; // Str1='' -end; -{$else} -function AnsiIComp(Str1, Str2: pointer): PtrInt; {$ifdef FPC} nostackframe; assembler; {$endif} -asm // fast 8 bits WinAnsi comparison using the NormToUpper[] array - cmp eax, edx - je @2 - test eax, edx // is either of the strings perhaps nil? - jz @3 -@0: push ebx // compare the first character (faster quicksort) - movzx ebx, byte ptr[eax] // ebx=S1[1] - movzx ecx, byte ptr[edx] // ecx=S2[1] - test ebx, ebx - jz @z - cmp ebx, ecx - je @s - mov bl, byte ptr[NormToUpper + ebx] - mov cl, byte ptr[NormToUpper + ecx] - cmp ebx, ecx - je @s - mov eax, ebx - pop ebx - sub eax, ecx // return S1[1]-S2[1] - ret -@2b: pop ebx -@2: xor eax, eax - ret -@3: test eax, eax // S1='' - jz @4 - test edx, edx // S2='' ? - jnz @0 - mov eax, 1 // return 1 (S1>S2) - ret -@s: inc eax - inc edx - mov bl, [eax] // ebx=S1[i] - mov cl, [edx] // ecx=S2[i] - test ebx, ebx - je @z // end of S1 - cmp ebx, ecx - je @s - mov bl, byte ptr[NormToUpper + ebx] - mov cl, byte ptr[NormToUpper + ecx] - cmp ebx, ecx - je @s - mov eax, ebx - pop ebx - sub eax, ecx // return S1[i]-S2[i] - ret -@z: cmp ebx, ecx // S1=S2? - jz @2b - pop ebx -@4: mov eax, -1 // return -1 (S1$80 then - exit else // invalid input content - c := c shl 6+byte(P[i]); - with UTF8_EXTRA[extra] do begin - dec(c,offset); - if cLD then - SetLength(result,LD); -end; - -function LowerCaseU(const S: RawUTF8): RawUTF8; -var LS,LD: integer; -begin - LS := length(S); - FastSetString(result,pointer(S),LS); - LD := ConvertCaseUTF8(pointer(result),NormToLowerByte); - if LS<>LD then - SetLength(result,LD); -end; - -function UTF8IComp(u1, u2: PUTF8Char): PtrInt; -var c2: PtrInt; - table: {$ifdef CPUX86NOTPIC}TNormTableByte absolute NormToUpperByte{$else}PNormTableByte{$endif}; -begin // fast UTF-8 comparison using the NormToUpper[] array for all 8 bits values - {$ifndef CPUX86NOTPIC}table := @NormToUpperByte;{$endif} - if u1<>u2 then - if u1<>nil then - if u2<>nil then - repeat - result := ord(u1^); - c2 := ord(u2^); - if result<=127 then - if result<>0 then begin - inc(u1); - result := table[result]; - if c2<=127 then begin - if c2=0 then exit; // u1>u2 -> return u1^ - inc(u2); - dec(result,table[c2]); - if result<>0 then exit; - continue; - end; - end else begin // u1^=#0 -> end of u1 reached - if c2<>0 then // end of u2 reached -> u1=u2 -> return 0 - result := -1; // u1u2 -> return u1^ - inc(u2); - dec(result,table[c2]); - if result<>0 then exit; - continue; - end else begin - c2 := GetHighUTF8UCS4Inlined(u2); - if c2<=255 then - dec(result,table[c2]) else // 8 bits to upper - dec(result,c2); // 32-bit widechar returns diff - if result<>0 then exit; - end; - until false else - result := 1 else // u2='' - result := -1 else // u1='' - result := 0; // u1=u2 -end; - -function UTF8ILComp(u1, u2: PUTF8Char; L1,L2: cardinal): PtrInt; -var c2: PtrInt; - extra,i: integer; - table: {$ifdef CPUX86NOTPIC}TNormTableByte absolute NormToUpperByte{$else}PNormTableByte{$endif}; -label neg,pos; -begin // fast UTF-8 comparison using the NormToUpper[] array for all 8 bits values - {$ifndef CPUX86NOTPIC}table := @NormToUpperByte;{$endif} - if u1<>u2 then - if (u1<>nil) and (L1<>0) then - if (u2<>nil) and (L2<>0) then - repeat - result := ord(u1^); - c2 := ord(u2^); - inc(u1); - dec(L1); - if result<=127 then begin - result := table[result]; - if c2<=127 then begin - dec(result,table[c2]); - dec(L2); - inc(u2); - if result<>0 then - exit else - if L1<>0 then - if L2<>0 then - continue else // L1>0 and L2>0 -> next char - goto pos else // L1>0 and L2=0 -> u1>u2 - if L2<>0 then - goto neg else // L1=0 and L2>0 -> u1 u1=u2 - end; - end else begin - extra := UTF8_EXTRABYTES[result]; - if extra=0 then goto neg; // invalid leading byte - dec(L1,extra); - if Integer(L1)<0 then goto neg; - for i := 0 to extra-1 do - result := result shl 6+PByteArray(u1)[i]; - dec(result,UTF8_EXTRA[extra].offset); - inc(u1,extra); - if result and $ffffff00=0 then - result := table[result]; // 8 bits to upper, 32-bit as is - end; - // here result=NormToUpper[u1^] - inc(u2); - dec(L2); - if c2<=127 then begin - dec(result,table[c2]); - if result<>0 then exit; - end else begin - extra := UTF8_EXTRABYTES[c2]; - if extra=0 then goto pos; - dec(L2,extra); - if integer(L2)<0 then goto pos; - for i := 0 to extra-1 do - c2 := c2 shl 6+PByteArray(u2)[i]; - dec(c2,UTF8_EXTRA[extra].offset); - inc(u2,extra); - if c2 and $ffffff00=0 then - dec(result,table[c2]) else // 8 bits to upper - dec(result,c2); // returns 32-bit diff - if result<>0 then exit; - end; - // here we have result=NormToUpper[u2^]-NormToUpper[u1^]=0 - if L1=0 then // test if we reached end of u1 or end of u2 - if L2=0 then exit // u1=u2 - else goto neg else // u1u2 - until false else -pos: result := 1 else // u2='' or u1>u2 -neg: result := -1 else // u1='' or u1UpperValue^ then break; {$else} - if NormToUpperAnsi7[A^]<>UpperValue^ then break; -{$endif} - inc(UpperValue); - if UpperValue^=#0 then begin - result := true; // UpperValue found! - exit; - end; - inc(A); - if A^=#0 then exit; - until false; - // find beginning of next word - repeat - if A^=#0 then exit else -{$ifdef USENORMTOUPPER} - if not (tcWord in TEXT_CHARS[NormToUpper[A^]]) then break else inc(A); -{$else} if not (tcWord in TEXT_CHARS[A^]) then break else inc(A); {$endif} - until false; - until false; -end; - -function FindUnicode(PW, Upper: PWideChar; UpperLen: PtrInt): boolean; -var Start: PWideChar; - w: PtrUInt; -begin - result := false; - if (PW=nil) or (Upper=nil) then exit; - repeat - // go to beginning of next word - repeat - w := ord(PW^); - if w=0 then exit else - if (w>126) or (tcWord in TEXT_BYTES[w]) then - Break; - inc(PW); - until false; - Start := PW; - // search end of word matching UpperLen characters - repeat - inc(PW); - w := ord(PW^); - until (PW-Start>=UpperLen) or - (w=0) or ((w<126) and (not(tcWord in TEXT_BYTES[w]))); - if PW-Start>=UpperLen then - if CompareStringW(LOCALE_USER_DEFAULT,NORM_IGNORECASE,Start,UpperLen,Upper,UpperLen)=2 then begin - result := true; // match found - exit; - end; - // not found: go to end of current word - repeat - w := ord(PW^); - if w=0 then exit else - if ((w<126) and (not(tcWord in TEXT_BYTES[w]))) then Break; - inc(PW); - until false; - until false; -end; - -function FindUTF8(U: PUTF8Char; UpperValue: PAnsiChar): boolean; -var ValueStart: PAnsiChar; -{$ifdef USENORMTOUPPER} - c: PtrUInt; - FirstChar: AnsiChar; -label Next; -{$else} - ch: AnsiChar; -{$endif} -begin - result := false; - if (U=nil) or (UpperValue=nil) then exit; -{$ifdef USENORMTOUPPER} - // handles 8-bits WinAnsi chars inside UTF-8 encoded data - FirstChar := UpperValue^; - ValueStart := UpperValue+1; - repeat - // test beginning of word - repeat - c := byte(U^); - inc(U); - if c=0 then exit else - if c<=127 then begin - if tcWord in TEXT_BYTES[c] then - if PAnsiChar(@NormToUpper)[c]<>FirstChar then - goto Next else - break; - end else - if c and $20=0 then begin // fast direct process $0..$7ff - c := c shl 6+byte(U^)-$3080; - inc(U); - if c<=255 then begin - c := NormToUpperByte[c]; - if tcWord in TEXT_BYTES[c] then - if AnsiChar(c)<>FirstChar then - goto Next else - break; - end; - end else - if UTF8_EXTRABYTES[c]=0 then - exit else // invalid leading byte - inc(U,UTF8_EXTRABYTES[c]); // just ignore surrogates for soundex - until false; - // here we had the first char match -> check if this word match UpperValue - UpperValue := ValueStart; - repeat - if UpperValue^=#0 then begin - result := true; // UpperValue found! - exit; - end; - c := byte(U^); inc(U); // next chars - if c=0 then exit else - if c<=127 then begin - if PAnsiChar(@NormToUpper)[c]<>UpperValue^ then break; - end else - if c and $20=0 then begin - c := c shl 6+byte(U^)-$3080; - inc(U); - if (c>255) or (PAnsiChar(@NormToUpper)[c]<>UpperValue^) then break; - end else begin - if UTF8_EXTRABYTES[c]=0 then - exit else // invalid leading byte - inc(U,UTF8_EXTRABYTES[c]); - break; - end; - inc(UpperValue); - until false; -Next: // find beginning of next word - U := FindNextUTF8WordBegin(U); - until U=nil; -{$else} - // this tiny version only handles 7-bits ansi chars and ignore all UTF-8 chars - ValueStart := UpperValue; - repeat - // find beginning of word - repeat - if byte(U^)=0 then exit else - if byte(U^)<=127 then - if byte(U^) in IsWord then - break else - inc(U) else - if byte(U^) and $20=0 then - inc(U,2) else - inc(U,3); - until false; - // check if this word is the UpperValue - UpperValue := ValueStart; - repeat - ch := NormToUpperAnsi7[U^]; - if ch<>UpperValue^ then break; - inc(UpperValue); - if UpperValue^=#0 then begin - result := true; // UpperValue found! - exit; - end; - inc(U); - if byte(U^)=0 then exit else - if byte(U^) and $80<>0 then break; // 7 bits char check only - until false; - // find beginning of next word - U := FindNextUTF8WordBegin(U); - until U=nil; -{$endif} -end; - -function HexDisplayToBin(Hex: PAnsiChar; Bin: PByte; BinBytes: integer): boolean; -var b,c: byte; - tab: {$ifdef CPUX86NOTPIC}TNormTableByte absolute ConvertHexToBin{$else}PNormTableByte{$endif}; -begin - result := false; // return false if any invalid char - if (Hex=nil) or (Bin=nil) then - exit; - {$ifndef CPUX86NOTPIC}tab := @ConvertHexToBin;{$endif} // faster on PIC and x86_64 - if BinBytes>0 then begin - inc(Bin,BinBytes-1); - repeat - b := tab[Ord(Hex[0])]; - c := tab[Ord(Hex[1])]; - if (b>15) or (c>15) then - exit; - b := b shl 4; // better FPC generation code in small explicit steps - b := b or c; - Bin^ := b; - dec(Bin); - inc(Hex,2); - dec(BinBytes); - until BinBytes=0; - end; - result := true; // correct content in Hex -end; - -function HexDisplayToCardinal(Hex: PAnsiChar; out aValue: cardinal): boolean; -begin - result := HexDisplayToBin(Hex,@aValue,SizeOf(aValue)); - if not result then - aValue := 0; -end; - -function HexDisplayToInt64(Hex: PAnsiChar; out aValue: Int64): boolean; -begin - result := HexDisplayToBin(Hex,@aValue,SizeOf(aValue)); - if not result then - aValue := 0; -end; - -function HexDisplayToInt64(const Hex: RawByteString): Int64; -begin - if not HexDisplayToBin(pointer(Hex),@result,SizeOf(result)) then - result := 0; -end; - -function HexToBin(Hex: PAnsiChar; Bin: PByte; BinBytes: Integer): boolean; -var b,c: byte; - tab: {$ifdef CPUX86NOTPIC}TNormTableByte absolute ConvertHexToBin{$else}PNormTableByte{$endif}; -begin - result := false; // return false if any invalid char - if Hex=nil then - exit; - {$ifndef CPUX86NOTPIC}tab := @ConvertHexToBin;{$endif} // faster on PIC and x86_64 - if BinBytes>0 then - if Bin<>nil then - repeat - b := tab[Ord(Hex[0])]; - c := tab[Ord(Hex[1])]; - if (b>15) or (c>15) then - exit; - inc(Hex,2); - b := b shl 4; - b := b or c; - Bin^ := b; - inc(Bin); - dec(BinBytes); - until BinBytes=0 else - repeat // Bin=nil -> validate Hex^ input - if (tab[Ord(Hex[0])]>15) or (tab[Ord(Hex[1])]>15) then - exit; - inc(Hex,2); - dec(BinBytes); - until BinBytes=0; - result := true; // conversion OK -end; - -procedure HexToBinFast(Hex: PAnsiChar; Bin: PByte; BinBytes: Integer); -var tab: {$ifdef CPUX86NOTPIC}TNormTableByte absolute ConvertHexToBin{$else}PNormTableByte{$endif}; - c: byte; -begin - {$ifndef CPUX86NOTPIC}tab := @ConvertHexToBin;{$endif} // faster on PIC and x86_64 - if BinBytes>0 then - repeat - c := tab[ord(Hex[0])]; - c := c shl 4; - c := tab[ord(Hex[1])] or c; - Bin^ := c; - inc(Hex,2); - inc(Bin); - dec(BinBytes); - until BinBytes=0; -end; - -function OctToBin(Oct: PAnsiChar; Bin: PByte): PtrInt; -var c, v: byte; -label _nxt; -begin - result := PtrInt(Bin); - if Oct <> nil then - repeat - c := ord(Oct^); - inc(Oct); - if c <> ord('\') then begin - if c = 0 then - break; -_nxt: Bin^ := c; - inc(Bin); - continue; - end; - c := ord(Oct^); - inc(Oct); - if c = ord('\') then - goto _nxt; - dec(c, ord('0')); - if c > 3 then - break; // stop at malformated input (includes #0) - c := c shl 6; - v := c; - c := ord(Oct[0]); - dec(c, ord('0')); - if c > 7 then - break; - c := c shl 3; - v := v or c; - c := ord(Oct[1]); - dec(c, ord('0')); - if c > 7 then - break; - c := c or v; - Bin^ := c; - inc(Bin); - inc(Oct, 2); - until false; - result := PtrInt(Bin)-result; -end; - -function OctToBin(const Oct: RawUTF8): RawByteString; -var tmp: TSynTempBuffer; - L: integer; -begin - tmp.Init(length(Oct)); - try - L := OctToBin(pointer(Oct), tmp.buf); - SetString(result, PAnsiChar(tmp.buf), L); - finally - tmp.Done; - end; -end; - -function IsHex(const Hex: RawByteString; BinBytes: integer): boolean; -begin - result := (length(Hex)=BinBytes*2) and SynCommons.HexToBin(pointer(Hex),nil,BinBytes); -end; - -function HexToCharValid(Hex: PAnsiChar): boolean; -begin - result := (ConvertHexToBin[Ord(Hex[0])]<=15) and - (ConvertHexToBin[Ord(Hex[1])]<=15); -end; - -function HexToChar(Hex: PAnsiChar; Bin: PUTF8Char): boolean; -var B,C: PtrUInt; - tab: {$ifdef CPUX86NOTPIC}TNormTableByte absolute ConvertHexToBin{$else}PNormTableByte{$endif}; -begin - if Hex<>nil then begin - {$ifndef CPUX86NOTPIC}tab := @ConvertHexToBin;{$endif} // faster on PIC and x86_64 - B := tab[Ord(Hex[0])]; - C := tab[Ord(Hex[1])]; - if (B<=15) and (C<=15) then begin - if Bin<>nil then - Bin^ := AnsiChar(B shl 4+C); - result := true; - exit; - end; - end; - result := false; // return false if any invalid char -end; - -function HexToWideChar(Hex: PAnsiChar): cardinal; -var B: PtrUInt; -begin - result := ConvertHexToBin[Ord(Hex[0])]; - if result<=15 then begin - B := ConvertHexToBin[Ord(Hex[1])]; - if B<=15 then begin - result := result shl 4+B; - B := ConvertHexToBin[Ord(Hex[2])]; - if B<=15 then begin - result := result shl 4+B; - B := ConvertHexToBin[Ord(Hex[3])]; - if B<=15 then begin - result := result shl 4+B; - exit; - end; - end; - end; - end; - result := 0; -end; - -{ --------- Base64 encoding/decoding } - -type - TBase64Enc = array[0..63] of AnsiChar; - PBase64Enc = ^TBase64Enc; - TBase64Dec = array[AnsiChar] of shortint; - PBase64Dec = ^TBase64Dec; -const - b64enc: TBase64Enc = - 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/'; - b64URIenc: TBase64Enc = - 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_'; -var - /// a conversion table from Base64 text into binary data - // - used by Base64ToBin/IsBase64 functions - // - contains -1 for invalid char, -2 for '=', 0..63 for b64enc[] chars - ConvertBase64ToBin, ConvertBase64URIToBin: TBase64Dec; - -function Base64AnyDecode(const decode: TBase64Dec; sp,rp: PAnsiChar; len: PtrInt): boolean; -var c, ch: PtrInt; -begin - result := false; - while len>=4 do begin - c := decode[sp[0]]; - if c<0 then - exit; - c := c shl 6; - ch := decode[sp[1]]; - if ch<0 then - exit; - c := (c or ch) shl 6; - ch := decode[sp[2]]; - if ch<0 then - exit; - c := (c or ch) shl 6; - ch := decode[sp[3]]; - if ch<0 then - exit; - c := c or ch; - rp[2] := AnsiChar(c); - c := c shr 8; - rp[1] := AnsiChar(c); - c := c shr 8; - rp[0] := AnsiChar(c); - dec(len,4); - inc(rp,3); - inc(sp,4); - end; - if len>=2 then begin - c := decode[sp[0]]; - if c<0 then - exit; - c := c shl 6; - ch := decode[sp[1]]; - if ch<0 then - exit; - if len=2 then - rp[0] := AnsiChar((c or ch) shr 4) else begin - c := (c or ch) shl 6; - ch := decode[sp[2]]; - if ch<0 then - exit; - c := (c or ch) shr 2; - rp[1] := AnsiChar(c); - rp[0] := AnsiChar(c shr 8); - end; - end; - result := true; -end; - -function Base64Decode(sp,rp: PAnsiChar; len: PtrInt): boolean; {$ifdef FPC}inline;{$endif} -var tab: PBase64Dec; // use local register -begin - tab := @ConvertBase64ToBin; - len := len shl 2; // len was the number of 4 chars chunks in sp - if (len>0) and (tab[sp[len-2]]>=0) then - if tab[sp[len-1]]>=0 then else - dec(len) else - dec(len,2); // Base64AnyDecode() algorithm ignores the trailing '=' - result := Base64AnyDecode(tab^,sp,rp,len); -end; - -{$ifdef PUREPASCAL} -function Base64EncodeMain(rp, sp: PAnsiChar; len: cardinal): integer; -var c: cardinal; - enc: PBase64Enc; // use local register -begin - enc := @b64enc; - len := len div 3; - result := len; - if len<>0 then - repeat - c := (ord(sp[0]) shl 16) or (ord(sp[1]) shl 8) or ord(sp[2]); - rp[0] := enc[(c shr 18) and $3f]; - rp[1] := enc[(c shr 12) and $3f]; - rp[2] := enc[(c shr 6) and $3f]; - rp[3] := enc[c and $3f]; - inc(rp,4); - inc(sp,3); - dec(len); - until len=0; -end; -{$else PUREPASCAL} -function Base64EncodeMain(rp, sp: PAnsiChar; len: cardinal): integer; -{$ifdef FPC} nostackframe; assembler; {$endif} -asm // eax=rp edx=sp ecx=len - pipeline optimized version by AB - push ebx - push esi - push edi - push ebp - mov ebx, edx - mov esi, eax - mov eax, ecx - mov edx, 1431655766 // faster eax=len div 3 using reciprocal - sar ecx, 31 - imul edx - mov eax, edx - sub eax, ecx - mov edi, offset b64enc - mov ebp, eax - push eax - jz @z - // edi=b64enc[] ebx=sp esi=rp ebp=len div 3 - xor eax, eax -@1: // read 3 bytes from sp - movzx edx, byte ptr[ebx] - shl edx, 16 - mov al, [ebx + 2] - mov ah, [ebx + 1] - add ebx, 3 - or eax, edx - // encode as Base64 - mov ecx, eax - mov edx, eax - shr ecx, 6 - and edx, $3f - and ecx, $3f - mov dh, [edi + edx] - mov dl, [edi + ecx] - mov ecx, eax - shr eax, 12 - shr ecx, 18 - shl edx, 16 - and ecx, $3f - and eax, $3f - mov cl, [edi + ecx] - mov ch, [edi + eax] - or ecx, edx - // write the 4 encoded bytes into rp - mov [esi], ecx - add esi, 4 - dec ebp - jnz @1 -@z: pop eax // result := len div 3 - pop ebp - pop edi - pop esi - pop ebx -end; -{$endif PUREPASCAL} - -procedure Base64EncodeTrailing(rp, sp: PAnsiChar; len: cardinal); - {$ifdef HASINLINE}inline;{$endif} -var c: cardinal; - enc: PBase64Enc; // use local register -begin - enc := @b64enc; - case len of - 1: begin - c := ord(sp[0]) shl 4; - rp[0] := enc[(c shr 6) and $3f]; - rp[1] := enc[c and $3f]; - PWord(rp+2)^ := ord('=')+ord('=') shl 8; - end; - 2: begin - c := (ord(sp[0]) shl 10) or (ord(sp[1]) shl 2); - rp[0] := enc[(c shr 12) and $3f]; - rp[1] := enc[(c shr 6) and $3f]; - rp[2] := enc[c and $3f]; - rp[3] := '='; - end; - end; -end; - -procedure Base64Encode(rp, sp: PAnsiChar; len: cardinal); -var main: cardinal; -begin - main := Base64EncodeMain(rp,sp,len); - Base64EncodeTrailing(rp+main*4,sp+main*3,len-main*3); -end; - -function BinToBase64Length(len: PtrUInt): PtrUInt; -begin - result := ((len+2)div 3)*4; -end; - -function BinToBase64(const s: RawByteString): RawUTF8; -var len: integer; -begin - result := ''; - len := length(s); - if len=0 then - exit; - FastSetString(result,nil,BinToBase64Length(len)); - Base64Encode(pointer(result),pointer(s),len); -end; - -function BinToBase64Short(Bin: PAnsiChar; BinBytes: integer): shortstring; -var destlen: integer; -begin - result := ''; - if BinBytes=0 then - exit; - destlen := BinToBase64Length(BinBytes); - if destlen>255 then - exit; // avoid buffer overflow - result[0] := AnsiChar(destlen); - Base64Encode(@result[1],Bin,BinBytes); -end; - -function BinToBase64Short(const s: RawByteString): shortstring; -begin - result := BinToBase64Short(pointer(s),length(s)); -end; - -function BinToBase64(Bin: PAnsiChar; BinBytes: integer): RawUTF8; -begin - result := ''; - if BinBytes=0 then - exit; - FastSetString(result,nil,BinToBase64Length(BinBytes)); - Base64Encode(pointer(result),Bin,BinBytes); -end; - -function BinToBase64(const data, Prefix, Suffix: RawByteString; WithMagic: boolean): RawUTF8; -var lendata,lenprefix,lensuffix,len: integer; - res: PByteArray absolute result; -begin - result := ''; - lendata := length(data); - lenprefix := length(Prefix); - lensuffix := length(Suffix); - if lendata+lenprefix+lensuffix=0 then - exit; - len := ((lendata+2) div 3)*4+lenprefix+lensuffix; - if WithMagic then - inc(len,3); - FastSetString(result,nil,len); - if lenprefix>0 then - MoveSmall(pointer(Prefix),res,lenprefix); - if WithMagic then begin - PInteger(@res[lenprefix])^ := JSON_BASE64_MAGIC; - inc(lenprefix,3); - end; - Base64Encode(@res[lenprefix],pointer(data),lendata); - if lensuffix>0 then - MoveSmall(pointer(Suffix),@res[len-lensuffix],lensuffix); -end; - -function BinToBase64WithMagic(const data: RawByteString): RawUTF8; -var len: integer; -begin - result := ''; - len := length(data); - if len=0 then - exit; - FastSetString(result,nil,((len+2) div 3)*4+3); - PInteger(pointer(result))^ := JSON_BASE64_MAGIC; - Base64Encode(PAnsiChar(pointer(result))+3,pointer(data),len); -end; - -function BinToBase64WithMagic(Data: pointer; DataLen: integer): RawUTF8; -begin - result := ''; - if DataLen<=0 then - exit; - FastSetString(result,nil,((DataLen+2) div 3)*4+3); - PInteger(pointer(result))^ := JSON_BASE64_MAGIC; - Base64Encode(PAnsiChar(pointer(result))+3,Data,DataLen); -end; - -function IsBase64Internal(sp: PAnsiChar; len: PtrInt; dec: PBase64Dec): boolean; -var i: PtrInt; -begin - result := false; - if (len=0) or (len and 3<>0) then - exit; - for i := 0 to len-5 do - if dec[sp[i]]<0 then - exit; - inc(sp,len-4); - if (dec[sp[0]]=-1) or (dec[sp[1]]=-1) or - (dec[sp[2]]=-1) or (dec[sp[3]]=-1) then - exit; - result := true; // layout seems correct -end; - -function IsBase64(sp: PAnsiChar; len: PtrInt): boolean; -begin - result := IsBase64Internal(sp,len,@ConvertBase64ToBin); -end; - -function IsBase64(const s: RawByteString): boolean; -begin - result := IsBase64Internal(pointer(s),length(s),@ConvertBase64ToBin); -end; - -function Base64ToBinLengthSafe(sp: PAnsiChar; len: PtrInt): PtrInt; -var dec: PBase64Dec; -begin - dec := @ConvertBase64ToBin; - if IsBase64Internal(sp,len,dec) then begin - if dec[sp[len-2]]>=0 then - if dec[sp[len-1]]>=0 then - result := 0 else - result := 1 else - result := 2; - result := (len shr 2)*3-result; - end else - result := 0; -end; - -function Base64ToBinLength(sp: PAnsiChar; len: PtrInt): PtrInt; -var dec: PBase64Dec; -begin - result := 0; - if (len=0) or (len and 3<>0) then - exit; - dec := @ConvertBase64ToBin; - if dec[sp[len-2]]>=0 then - if dec[sp[len-1]]>=0 then - result := 0 else - result := 1 else - result := 2; - result := (len shr 2)*3-result; -end; - -function Base64ToBin(const s: RawByteString): RawByteString; -begin - Base64ToBinSafe(pointer(s),length(s),result); -end; - -function Base64ToBin(sp: PAnsiChar; len: PtrInt): RawByteString; -begin - Base64ToBinSafe(sp,len,result); -end; - -function Base64ToBin(sp: PAnsiChar; len: PtrInt; var data: RawByteString): boolean; -begin - result := Base64ToBinSafe(sp,len,data); -end; - -function Base64ToBinSafe(const s: RawByteString): RawByteString; -begin - Base64ToBinSafe(pointer(s),length(s),result); -end; - -function Base64ToBinSafe(sp: PAnsiChar; len: PtrInt): RawByteString; -begin - Base64ToBinSafe(sp,len,result); -end; - -function Base64ToBinSafe(sp: PAnsiChar; len: PtrInt; var data: RawByteString): boolean; -var resultLen: PtrInt; -begin - resultLen := Base64ToBinLength(sp,len); - if resultLen<>0 then begin - SetString(data,nil,resultLen); - if ConvertBase64ToBin[sp[len-2]]>=0 then - if ConvertBase64ToBin[sp[len-1]]>=0 then else - dec(len) else - dec(len,2); // adjust for Base64AnyDecode() algorithm - result := Base64AnyDecode(ConvertBase64ToBin,sp,pointer(data),len); - if not result then - data := ''; - end else begin - result := false; - data := ''; - end; -end; - -function Base64ToBin(sp: PAnsiChar; len: PtrInt; var blob: TSynTempBuffer): boolean; -begin - blob.Init(Base64ToBinLength(sp,len)); - result := (blob.len>0) and Base64Decode(sp,blob.buf,len shr 2); -end; - -function Base64ToBin(base64, bin: PAnsiChar; base64len, binlen: PtrInt; - nofullcheck: boolean): boolean; -begin // nofullcheck is just ignored and deprecated - result := (bin<>nil) and (Base64ToBinLength(base64,base64len)=binlen) and - Base64Decode(base64,bin,base64len shr 2); -end; - -function Base64ToBin(const base64: RawByteString; bin: PAnsiChar; binlen: PtrInt; - nofullcheck: boolean): boolean; -begin - result := Base64ToBin(pointer(base64),bin,length(base64),binlen,nofullcheck); -end; - -{ --------- Base64 URI encoding/decoding } - -{$ifdef PUREPASCAL} -procedure Base64uriEncode(rp, sp: PAnsiChar; len: cardinal); -var main, c: cardinal; - enc: PBase64Enc; // faster especially on x86_64 and PIC -begin - enc := @b64URIenc; - main := len div 3; - if main<>0 then begin - dec(len,main*3); // fast modulo - repeat - c := (ord(sp[0]) shl 16) or (ord(sp[1]) shl 8) or ord(sp[2]); - rp[0] := enc[(c shr 18) and $3f]; - rp[1] := enc[(c shr 12) and $3f]; - rp[2] := enc[(c shr 6) and $3f]; - rp[3] := enc[c and $3f]; - inc(rp,4); - inc(sp,3); - dec(main) - until main=0; - end; - case len of - 1: begin - c := ord(sp[0]) shl 4; - rp[0] := enc[(c shr 6) and $3f]; - rp[1] := enc[c and $3f]; - end; - 2: begin - c := (ord(sp[0]) shl 10) or (ord(sp[1]) shl 2); - rp[0] := enc[(c shr 12) and $3f]; - rp[1] := enc[(c shr 6) and $3f]; - rp[2] := enc[c and $3f]; - end; - end; -end; -{$else PUREPASCAL} -function Base64uriEncodeMain(rp, sp: PAnsiChar; len: cardinal): integer; -{$ifdef FPC} nostackframe; assembler; {$endif} -asm // eax=rp edx=sp ecx=len - pipeline optimized version by AB - push ebx - push esi - push edi - push ebp - mov ebx, edx - mov esi, eax - mov eax, ecx - mov edx, 1431655766 // faster eax=len div 3 using reciprocal - sar ecx, 31 - imul edx - mov eax, edx - sub eax, ecx - mov edi, offset b64urienc - mov ebp, eax - push eax - jz @z - // edi=b64urienc[] ebx=sp esi=rp ebp=len div 3 - xor eax, eax -@1: // read 3 bytes from sp - movzx edx, byte ptr[ebx] - shl edx, 16 - mov al, [ebx + 2] - mov ah, [ebx + 1] - add ebx, 3 - or eax, edx - // encode as Base64uri - mov ecx, eax - mov edx, eax - shr ecx, 6 - and edx, $3f - and ecx, $3f - mov dh, [edi + edx] - mov dl, [edi + ecx] - mov ecx, eax - shr eax, 12 - shr ecx, 18 - shl edx, 16 - and ecx, $3f - and eax, $3f - mov cl, [edi + ecx] - mov ch, [edi + eax] - or ecx, edx - // write the 4 encoded bytes into rp - mov [esi], ecx - add esi, 4 - dec ebp - jnz @1 -@z: pop eax // result := len div 3 - pop ebp - pop edi - pop esi - pop ebx -end; - -procedure Base64uriEncodeTrailing(rp, sp: PAnsiChar; len: cardinal); - {$ifdef HASINLINE}inline;{$endif} -var c: cardinal; -begin - case len of - 1: begin - c := ord(sp[0]) shl 4; - rp[0] := b64urienc[(c shr 6) and $3f]; - rp[1] := b64urienc[c and $3f]; - end; - 2: begin - c := ord(sp[0]) shl 10 + ord(sp[1]) shl 2; - rp[0] := b64urienc[(c shr 12) and $3f]; - rp[1] := b64urienc[(c shr 6) and $3f]; - rp[2] := b64urienc[c and $3f]; - end; - end; -end; - -procedure Base64uriEncode(rp, sp: PAnsiChar; len: cardinal); -var main: cardinal; -begin - main := Base64uriEncodeMain(rp,sp,len); - Base64uriEncodeTrailing(rp+main*4,sp+main*3,len-main*3); -end; -{$endif PUREPASCAL} - -function BinToBase64uriLength(len: PtrUInt): PtrUInt; -begin - result := (len div 3)*4; - case len-(result shr 2)*3 of // fast len mod 3 - 1: inc(result,2); - 2: inc(result,3); - end; -end; - -function BinToBase64uri(const s: RawByteString): RawUTF8; -var len: integer; -begin - result := ''; - len := length(s); - if len=0 then - exit; - FastSetString(result,nil,BinToBase64uriLength(len)); - Base64uriEncode(pointer(result),pointer(s),len); -end; - -function BinToBase64uri(Bin: PAnsiChar; BinBytes: integer): RawUTF8; -begin - result := ''; - if BinBytes<=0 then - exit; - FastSetString(result,nil,BinToBase64uriLength(BinBytes)); - Base64uriEncode(pointer(result),Bin,BinBytes); -end; - -function BinToBase64uriShort(Bin: PAnsiChar; BinBytes: integer): shortstring; -var len: integer; -begin - result := ''; - if BinBytes<=0 then - exit; - len := BinToBase64uriLength(BinBytes); - if len>255 then - exit; - byte(result[0]) := len; - Base64uriEncode(@result[1],Bin,BinBytes); -end; - -function Base64uriToBinLength(len: PtrInt): PtrInt; -begin - if len=0 then - result := 0 else begin - result := (len shr 2)*3; - case len and 3 of - 1: result := 0; - 2: inc(result,1); - 3: inc(result,2); - end; - end; -end; - -function Base64uriDecode(sp,rp: PAnsiChar; len: PtrInt): boolean; -begin - result := Base64AnyDecode(ConvertBase64URIToBin,sp,rp,len); -end; - -function Base64uriToBin(sp: PAnsiChar; len: PtrInt): RawByteString; -begin - Base64uriToBin(sp,len,result); -end; - -function Base64uriToBin(const s: RawByteString): RawByteString; -begin - Base64uriToBin(pointer(s),length(s),result); -end; - -procedure Base64uriToBin(sp: PAnsiChar; len: PtrInt; var result: RawByteString); -var resultLen: PtrInt; -begin - resultLen := Base64uriToBinLength(len); - if resultLen<>0 then begin - SetString(result,nil,resultLen); - if Base64AnyDecode(ConvertBase64URIToBin,sp,pointer(result),len) then - exit; - end; - result := ''; -end; - -function Base64uriToBin(sp: PAnsiChar; len: PtrInt; var temp: TSynTempBuffer): boolean; -begin - temp.Init(Base64uriToBinLength(len)); - result := (temp.len>0) and Base64AnyDecode(ConvertBase64URIToBin,sp,temp.buf,len); -end; - -function Base64uriToBin(const base64: RawByteString; bin: PAnsiChar; binlen: PtrInt): boolean; -begin - result := Base64uriToBin(pointer(base64),bin,length(base64),binlen); -end; - -function Base64uriToBin(base64, bin: PAnsiChar; base64len, binlen: PtrInt): boolean; -var resultLen: PtrInt; -begin - resultLen := Base64uriToBinLength(base64len); - result := (resultLen=binlen) and - Base64AnyDecode(ConvertBase64URIToBin,base64,bin,base64len); -end; - -procedure Base64ToURI(var base64: RawUTF8); -var P: PUTF8Char; -begin - P := UniqueRawUTF8(base64); - if P<>nil then - repeat - case P^ of - #0: break; - '+': P^ := '-'; - '/': P^ := '_'; - '=': begin // trim unsignificant trailing '=' characters - SetLength(base64,P-pointer(base64)); - break; - end; - end; - inc(P); - until false; -end; - - -function BinToSource(const ConstName, Comment: RawUTF8; - Data: pointer; Len, PerLine: integer; const Suffix: RawUTF8): RawUTF8; -var W: TTextWriter; - temp: TTextWriterStackBuffer; -begin - if (Data=nil) or (Len<=0) or (PerLine<=0) then - result := '' else begin - W := TTextWriter.CreateOwnedStream(temp,Len*5+50+length(Comment)+length(Suffix)); - try - BinToSource(W,ConstName,Comment,Data,Len,PerLine); - if Suffix<>'' then begin - W.AddString(Suffix); - W.AddCR; - end; - W.SetText(result); - finally - W.Free; - end; - end; -end; - -procedure BinToSource(Dest: TTextWriter; const ConstName, Comment: RawUTF8; - Data: pointer; Len, PerLine: integer); -var line,i: integer; - P: PByte; -begin - if (Dest=nil) or (Data=nil) or (Len<=0) or (PerLine<=0) then - exit; - Dest.AddShort('const'); - if Comment<>'' then - Dest.Add(#13#10' // %',[Comment]); - Dest.Add(#13#10' %: array[0..%] of byte = (',[ConstName,Len-1]); - P := pointer(Data); - repeat - if len>PerLine then - line := PerLine else - line := Len; - Dest.AddShort(#13#10' '); - for i := 0 to line-1 do begin - Dest.Add('$'); - Dest.AddByteToHex(P^); - inc(P); - Dest.Add(','); - end; - dec(Len,line); - until Len=0; - Dest.CancelLastComma; - Dest.Add(');'#13#10' %_LEN = SizeOf(%);'#13#10,[ConstName,ConstName]); -end; - -{$ifdef KYLIX3} -function UpperCaseUnicode(const S: RawUTF8): RawUTF8; -begin - result := WideStringToUTF8(WideUpperCase(UTF8ToWideString(S))); -end; - -function LowerCaseUnicode(const S: RawUTF8): RawUTF8; -begin - result := WideStringToUTF8(WideLowerCase(UTF8ToWideString(S))); -end; -{$else} -function UpperCaseUnicode(const S: RawUTF8): RawUTF8; -var tmp: TSynTempBuffer; - len: integer; -begin - if S='' then begin - result := ''; - exit; - end; - tmp.Init(length(s)*2); - len := UTF8ToWideChar(tmp.buf,pointer(S),length(S)) shr 1; - RawUnicodeToUtf8(tmp.buf,CharUpperBuffW(tmp.buf,len),result); - tmp.Done; -end; - -function LowerCaseUnicode(const S: RawUTF8): RawUTF8; -var tmp: TSynTempBuffer; - len: integer; -begin - if S='' then begin - result := ''; - exit; - end; - tmp.Init(length(s)*2); - len := UTF8ToWideChar(tmp.buf,pointer(S),length(S)) shr 1; - RawUnicodeToUtf8(tmp.buf,CharLowerBuffW(tmp.buf,len),result); - tmp.Done; -end; -{$endif KYLIX3} - -function IsCaseSensitive(const S: RawUTF8): boolean; -begin - result := IsCaseSensitive(pointer(S),length(S)); -end; - -function IsCaseSensitive(P: PUTF8Char; PLen: PtrInt): boolean; -begin - result := true; - if (P<>nil) and (PLen>0) then - repeat - if ord(P^) in [ord('a')..ord('z'), ord('A')..ord('Z')] then - exit; - inc(P); - dec(PLen); - until PLen=0; - result := false; -end; - -function UpperCase(const S: RawUTF8): RawUTF8; -var L, i: PtrInt; -begin - L := length(S); - FastSetString(Result,pointer(S),L); - for i := 0 to L-1 do - if PByteArray(result)[i] in [ord('a')..ord('z')] then - dec(PByteArray(result)[i],32); -end; - -procedure UpperCaseCopy(Text: PUTF8Char; Len: PtrInt; var result: RawUTF8); -var i: PtrInt; -begin - FastSetString(result,Text,Len); - for i := 0 to Len-1 do - if PByteArray(result)[i] in [ord('a')..ord('z')] then - dec(PByteArray(result)[i],32); -end; - -procedure UpperCaseCopy(const Source: RawUTF8; var Dest: RawUTF8); -var L, i: PtrInt; -begin - L := length(Source); - FastSetString(Dest,pointer(Source),L); - for i := 0 to L-1 do - if PByteArray(Dest)[i] in [ord('a')..ord('z')] then - dec(PByteArray(Dest)[i],32); -end; - -procedure UpperCaseSelf(var S: RawUTF8); -var i: PtrInt; - P: PByteArray; -begin - P := UniqueRawUTF8(S); - for i := 0 to length(S)-1 do - if P[i] in [ord('a')..ord('z')] then - dec(P[i],32); -end; - -function LowerCase(const S: RawUTF8): RawUTF8; -var L, i: PtrInt; -begin - L := length(S); - FastSetString(result,pointer(S),L); - for i := 0 to L-1 do - if PByteArray(result)[i] in [ord('A')..ord('Z')] then - inc(PByteArray(result)[i],32); -end; - -procedure LowerCaseCopy(Text: PUTF8Char; Len: PtrInt; var result: RawUTF8); -var i: PtrInt; -begin - FastSetString(result,Text,Len); - for i := 0 to Len-1 do - if PByteArray(result)[i] in [ord('A')..ord('Z')] then - inc(PByteArray(result)[i],32); -end; - -procedure LowerCaseSelf(var S: RawUTF8); -var i: PtrInt; - P: PByteArray; -begin - P := UniqueRawUTF8(S); - for i := 0 to length(S)-1 do - if P[i] in [ord('A')..ord('Z')] then - inc(P[i],32); -end; - -function TrimLeft(const S: RawUTF8): RawUTF8; -var i, l: PtrInt; -begin - l := Length(S); - i := 1; - while (i <= l) and (S[i] <= ' ') do - Inc(i); - Result := Copy(S, i, Maxint); -end; - -function TrimRight(const S: RawUTF8): RawUTF8; -var i: PtrInt; -begin - i := Length(S); - while (i > 0) and (S[i] <= ' ') do - Dec(i); - FastSetString(result,pointer(S),i); -end; - -procedure TrimCopy(const S: RawUTF8; start, count: PtrInt; - var result: RawUTF8); -var L: PtrInt; -begin - if count>0 then begin - if start<=0 then - start := 1; - L := Length(S); - while (start<=L) and (S[start]<=' ') do begin - inc(start); dec(count); end; - dec(start); - dec(L,start); - if count0 do - if S[start+L]<=' ' then - dec(L) else - break; - if L>0 then begin - FastSetString(result,@PByteArray(S)[start],L); - exit; - end; - end; - result := ''; -end; - -type - TAnsiCharToWord = array[AnsiChar] of word; - TByteToWord = array[byte] of word; -var - /// fast lookup table for converting hexadecimal numbers from 0 to 15 - // into their ASCII equivalence - // - is local for better code generation - TwoDigitsHex: array[byte] of array[1..2] of AnsiChar; - TwoDigitsHexW: TAnsiCharToWord absolute TwoDigitsHex; - TwoDigitsHexWB: array[byte] of word absolute TwoDigitsHex; - /// lowercase hexadecimal lookup table - TwoDigitsHexLower: array[byte] of array[1..2] of AnsiChar; - TwoDigitsHexWLower: TAnsiCharToWord absolute TwoDigitsHexLower; - TwoDigitsHexWBLower: array[byte] of word absolute TwoDigitsHexLower; - -procedure BinToHex(Bin, Hex: PAnsiChar; BinBytes: integer); -{$ifdef PUREPASCAL}var tab: ^TAnsiCharToWord;{$endif} -begin - {$ifdef PUREPASCAL}tab := @TwoDigitsHexW;{$endif} - if BinBytes>0 then - repeat - PWord(Hex)^ := {$ifndef PUREPASCAL}TwoDigitsHexW{$else}tab{$endif}[Bin^]; - inc(Bin); - inc(Hex,2); - dec(BinBytes); - until BinBytes=0; -end; - -function BinToHex(const Bin: RawByteString): RawUTF8; -var L: integer; -begin - L := length(Bin); - FastSetString(result,nil,L*2); - SynCommons.BinToHex(pointer(Bin),pointer(Result),L); -end; - -function BinToHex(Bin: PAnsiChar; BinBytes: integer): RawUTF8; -begin - FastSetString(result,nil,BinBytes*2); - SynCommons.BinToHex(Bin,pointer(Result),BinBytes); -end; - -function HexToBin(const Hex: RawUTF8): RawByteString; -var L: integer; -begin - result := ''; - L := length(Hex); - if L and 1<>0 then - L := 0 else // hexadecimal should be in char pairs - L := L shr 1; - SetLength(result,L); - if not SynCommons.HexToBin(pointer(Hex),pointer(result),L) then - result := ''; -end; - -function ByteToHex(P: PAnsiChar; Value: byte): PAnsiChar; -begin - PWord(P)^ := TwoDigitsHexWB[Value]; - result := P+2; -end; - -function EscapeBuffer(s,d: PAnsiChar; len,max: integer): PAnsiChar; -var i: integer; -begin - if len>max then - len := max; - for i := 1 to len do begin - if s^ in [' '..#126] then begin - d^ := s^; - inc(d); - end else begin - d^ := '$'; - inc(d); - PWord(d)^ := TwoDigitsHexWB[ord(s^)]; - inc(d,2); - end; - inc(s); - end; - if len=max then begin - PCardinal(d)^ := ord('.')+ord('.')shl 8+ord('.')shl 16; - inc(d,3); - end else - d^ := #0; - result := d; -end; - -function LogEscape(source: PAnsiChar; sourcelen: integer; var temp: TLogEscape; - enabled: boolean): PAnsiChar; -begin - if enabled then begin - temp[0] := ' '; - EscapeBuffer(source,@temp[1],sourcelen,LOGESCAPELEN); - end else - temp[0] := #0; - result := @temp; -end; - -function LogEscapeFull(const source: RawByteString): RawUTF8; -begin - result := LogEscapeFull(pointer(source),length(source)); -end; - -function LogEscapeFull(source: PAnsiChar; sourcelen: integer): RawUTF8; -begin - FastSetString(result,nil,sourcelen*3); // worse case - if sourcelen=0 then - exit; - sourcelen := EscapeBuffer(source,pointer(result),sourcelen,length(result))-pointer(result); - SetLength(result,sourcelen); -end; - -function EscapeToShort(source: PAnsiChar; sourcelen: integer): shortstring; -begin - result[0] := AnsiChar(EscapeBuffer(source,@result[1],sourcelen,80)-@result[1]); -end; - -function EscapeToShort(const source: RawByteString): shortstring; overload; -begin - result[0] := AnsiChar(EscapeBuffer(pointer(source),@result[1],length(source),80)-@result[1]); -end; - -procedure BinToHexDisplay(Bin, Hex: PAnsiChar; BinBytes: integer); -{$ifdef PUREPASCAL}var tab: ^TAnsiCharToWord;{$endif} -begin - {$ifdef PUREPASCAL}tab := @TwoDigitsHexW;{$endif} - inc(Hex,BinBytes*2); - if BinBytes>0 then - repeat - dec(Hex,2); - PWord(Hex)^ := {$ifndef PUREPASCAL}TwoDigitsHexW{$else}tab{$endif}[Bin^]; - inc(Bin); - dec(BinBytes); - until BinBytes=0; -end; - -function BinToHexDisplay(Bin: PAnsiChar; BinBytes: integer): RawUTF8; -begin - FastSetString(result,nil,BinBytes*2); - BinToHexDisplay(Bin,pointer(result),BinBytes); -end; - -procedure BinToHexLower(Bin, Hex: PAnsiChar; BinBytes: integer); -{$ifdef PUREPASCAL}var tab: ^TAnsiCharToWord;{$endif} -begin - {$ifdef PUREPASCAL}tab := @TwoDigitsHexWLower;{$endif} - if BinBytes>0 then - repeat - PWord(Hex)^ := {$ifndef PUREPASCAL}TwoDigitsHexWLower{$else}tab{$endif}[Bin^]; - inc(Bin); - inc(Hex,2); - dec(BinBytes); - until BinBytes=0; -end; - -function BinToHexLower(const Bin: RawByteString): RawUTF8; -begin - BinToHexLower(pointer(Bin),length(Bin),result); -end; - -procedure BinToHexLower(Bin: PAnsiChar; BinBytes: integer; var result: RawUTF8); -begin - FastSetString(result,nil,BinBytes*2); - BinToHexLower(Bin,pointer(result),BinBytes); -end; - -function BinToHexLower(Bin: PAnsiChar; BinBytes: integer): RawUTF8; -begin - BinToHexLower(Bin,BinBytes,result); -end; - -procedure BinToHexDisplayLower(Bin, Hex: PAnsiChar; BinBytes: PtrInt); -{$ifdef PUREPASCAL}var tab: ^TAnsiCharToWord;{$endif} -begin - if (Bin=nil) or (Hex=nil) or (BinBytes<=0) then - exit; - {$ifdef PUREPASCAL}tab := @TwoDigitsHexWLower;{$endif} - inc(Hex,BinBytes*2); - repeat - dec(Hex,2); - PWord(Hex)^ := {$ifdef PUREPASCAL}tab{$else}TwoDigitsHexWLower{$endif}[Bin^]; - inc(Bin); - dec(BinBytes); - until BinBytes=0; -end; - -function BinToHexDisplayLower(Bin: PAnsiChar; BinBytes: integer): RawUTF8; -begin - FastSetString(result,nil,BinBytes*2); - BinToHexDisplayLower(Bin,pointer(result),BinBytes); -end; - -function BinToHexDisplayLowerShort(Bin: PAnsiChar; BinBytes: integer): shortstring; -begin - if BinBytes>127 then - BinBytes := 127; - result[0] := AnsiChar(BinBytes * 2); - BinToHexDisplayLower(Bin,@result[1],BinBytes); -end; - -function BinToHexDisplayLowerShort16(Bin: Int64; BinBytes: integer): TShort16; -begin - if BinBytes>8 then - BinBytes := 8; - result[0] := AnsiChar(BinBytes * 2); - BinToHexDisplayLower(@Bin,@result[1],BinBytes); -end; - -function BinToHexDisplayFile(Bin: PAnsiChar; BinBytes: integer): TFileName; -{$ifdef UNICODE} -var temp: TSynTempBuffer; -begin - temp.Init(BinBytes*2); - BinToHexDisplayLower(Bin,temp.Buf,BinBytes); - Ansi7ToString(PWinAnsiChar(temp.buf),BinBytes*2,string(result)); - temp.Done; -end; -{$else} -begin - SetString(result,nil,BinBytes*2); - BinToHexDisplayLower(Bin,pointer(result),BinBytes); -end; -{$endif UNICODE} - -procedure PointerToHex(aPointer: Pointer; var result: RawUTF8); -begin - FastSetString(result,nil,SizeOf(Pointer)*2); - BinToHexDisplay(@aPointer,pointer(result),SizeOf(Pointer)); -end; - -function PointerToHex(aPointer: Pointer): RawUTF8; -begin - FastSetString(result,nil,SizeOf(aPointer)*2); - BinToHexDisplay(@aPointer,pointer(result),SizeOf(aPointer)); -end; - -function CardinalToHex(aCardinal: Cardinal): RawUTF8; -begin - FastSetString(result,nil,SizeOf(aCardinal)*2); - BinToHexDisplay(@aCardinal,pointer(result),SizeOf(aCardinal)); -end; - -function CardinalToHexLower(aCardinal: Cardinal): RawUTF8; -begin - FastSetString(result,nil,SizeOf(aCardinal)*2); - BinToHexDisplayLower(@aCardinal,pointer(result),SizeOf(aCardinal)); -end; - -function Int64ToHex(aInt64: Int64): RawUTF8; -begin - FastSetString(result,nil,SizeOf(Int64)*2); - BinToHexDisplay(@aInt64,pointer(result),SizeOf(Int64)); -end; - -procedure Int64ToHex(aInt64: Int64; var result: RawUTF8); -begin - FastSetString(result,nil,SizeOf(Int64)*2); - BinToHexDisplay(@aInt64,pointer(result),SizeOf(Int64)); -end; - -function PointerToHexShort(aPointer: Pointer): TShort16; -begin - result[0] := AnsiChar(SizeOf(aPointer)*2); - BinToHexDisplay(@aPointer,@result[1],SizeOf(aPointer)); -end; - -function CardinalToHexShort(aCardinal: Cardinal): TShort16; -begin - result[0] := AnsiChar(SizeOf(aCardinal)*2); - BinToHexDisplay(@aCardinal,@result[1],SizeOf(aCardinal)); -end; - -function Int64ToHexShort(aInt64: Int64): TShort16; -begin - result[0] := AnsiChar(SizeOf(aInt64)*2); - BinToHexDisplay(@aInt64,@result[1],SizeOf(aInt64)); -end; - -procedure Int64ToHexShort(aInt64: Int64; out result: TShort16); -begin - result[0] := AnsiChar(SizeOf(aInt64)*2); - BinToHexDisplay(@aInt64,@result[1],SizeOf(aInt64)); -end; - -function Int64ToHexString(aInt64: Int64): string; -var temp: TShort16; -begin - Int64ToHexShort(aInt64,temp); - Ansi7ToString(@temp[1],ord(temp[0]),result); -end; - -function UInt3DigitsToUTF8(Value: Cardinal): RawUTF8; -begin - FastSetString(result,nil,3); - PWordArray(result)[0] := TwoDigitLookupW[Value div 10]; - PByteArray(result)[2] := (Value mod 10)+48; -end; - -function UInt4DigitsToUTF8(Value: Cardinal): RawUTF8; -begin - FastSetString(result,nil,4); - if Value>9999 then - Value := 9999; - YearToPChar(Value,pointer(result)); -end; - -function UInt4DigitsToShort(Value: Cardinal): TShort4; -begin - result[0] := #4; - if Value>9999 then - Value := 9999; - YearToPChar(Value,@result[1]); -end; - -function UInt3DigitsToShort(Value: Cardinal): TShort4; -begin - if Value>999 then - Value := 999; - YearToPChar(Value,@result[0]); - result[0] := #3; // override first digit -end; - -function UInt2DigitsToShort(Value: byte): TShort4; -begin - result[0] := #2; - if Value>99 then - Value := 99; - PWord(@result[1])^ := TwoDigitLookupW[Value]; -end; - -function UInt2DigitsToShortFast(Value: byte): TShort4; -begin - result[0] := #2; - PWord(@result[1])^ := TwoDigitLookupW[Value]; -end; - -function SameValue(const A, B: Double; DoublePrec: double): Boolean; -var AbsA,AbsB,Res: double; -begin - if PInt64(@DoublePrec)^=0 then begin // Max(Min(Abs(A),Abs(B))*1E-12,1E-12) - AbsA := Abs(A); - AbsB := Abs(B); - Res := 1E-12; - if AbsAB)-ord(AB)-ord(AB)-ord(AB)-ord(A0) and - (PStrLen(PtrUInt(Values^)-_STRLEN)^=ValueLen) and - CompareMemFixed(pointer(PtrInt(Values^)),pointer(Value),ValueLen) then - exit else - inc(Values) else - for result := 0 to ValuesCount do - if (PtrUInt(Values^)<>0) and // StrIComp() won't change length - (PStrLen(PtrUInt(Values^)-_STRLEN)^=ValueLen) and - (StrIComp(pointer(Values^),pointer(Value))=0) then - exit else - inc(Values); - result := -1; -end; - -function FindPropName(Values: PRawUTF8; const Value: RawUTF8; - ValuesCount: integer): integer; -var ValueLen: TStrLen; -begin - dec(ValuesCount); - ValueLen := length(Value); - if ValueLen=0 then - for result := 0 to ValuesCount do - if Values^='' then - exit else - inc(Values) else - for result := 0 to ValuesCount do - if (PtrUInt(Values^)<>0) and - (PStrLen(PtrUInt(Values^)-_STRLEN)^=ValueLen) and - IdemPropNameUSameLen(pointer(Values^),pointer(Value),ValueLen) then - exit else - inc(Values); - result := -1; -end; - -function FindRawUTF8(const Values: TRawUTF8DynArray; const Value: RawUTF8; - CaseSensitive: boolean): integer; -begin - result := FindRawUTF8(pointer(Values),Value,length(Values),CaseSensitive); -end; - -function FindRawUTF8(const Values: array of RawUTF8; const Value: RawUTF8; - CaseSensitive: boolean): integer; -begin - result := high(Values); - if result>=0 then - result := FindRawUTF8(@Values[0],Value,result+1,CaseSensitive); -end; - -function FindPropName(const Names: array of RawUTF8; const Name: RawUTF8): integer; -begin - result := high(Names); - if result>=0 then - result := FindPropName(@Names[0],Name,result+1); -end; - -function AddRawUTF8(var Values: TRawUTF8DynArray; const Value: RawUTF8; - NoDuplicates, CaseSensitive: boolean): boolean; -var i: integer; -begin - if NoDuplicates then begin - i := FindRawUTF8(Values,Value,CaseSensitive); - if i>=0 then begin - result := false; - exit; - end; - end; - i := length(Values); - SetLength(Values,i+1); - Values[i] := Value; - result := true; -end; - -function NextGrow(capacity: integer): integer; -begin // algorithm similar to TFPList.Expand for the increasing ranges - result := capacity; - if result<128 shl 20 then - if result<8 shl 20 then - if result<=128 then - if result>8 then - inc(result,16) else - inc(result,4) else - inc(result,result shr 2) else - inc(result,result shr 3) else - inc(result,16 shl 20); -end; - -procedure AddRawUTF8(var Values: TRawUTF8DynArray; var ValuesCount: integer; - const Value: RawUTF8); -var capacity: integer; -begin - capacity := Length(Values); - if ValuesCount=capacity then - SetLength(Values,NextGrow(capacity)); - Values[ValuesCount] := Value; - inc(ValuesCount); -end; - -function RawUTF8DynArrayEquals(const A,B: TRawUTF8DynArray): boolean; -var n,i: integer; -begin - result := false; - n := length(A); - if n<>length(B) then - exit; - for i := 0 to n-1 do - if A[i]<>B[i] then - exit; - result := true; -end; - -function RawUTF8DynArrayEquals(const A,B: TRawUTF8DynArray; Count: integer): boolean; -var i: integer; -begin - result := false; - for i := 0 to Count - 1 do - if A[i]<>B[i] then - exit; - result := true; -end; - -procedure StringDynArrayToRawUTF8DynArray(const Source: TStringDynArray; - var Result: TRawUTF8DynArray); -var i: Integer; -begin - Finalize(result); - SetLength(Result,length(Source)); - for i := 0 to length(Source)-1 do - StringToUTF8(Source[i],Result[i]); -end; - -procedure StringListToRawUTF8DynArray(Source: TStringList; var Result: TRawUTF8DynArray); -var i: Integer; -begin - Finalize(result); - SetLength(Result,Source.Count); - for i := 0 to Source.Count-1 do - StringToUTF8(Source[i],Result[i]); -end; - -function FindSectionFirstLine(var source: PUTF8Char; search: PAnsiChar): boolean; -{$ifdef PUREPASCAL} -var tab: PTextCharSet; -begin - result := false; - if source=nil then - exit; - repeat - if source^='[' then begin - inc(source); - result := IdemPChar(source,search); - end; - tab := @TEXT_CHARS; - while tcNot01013 in tab[source^] do inc(source); - while tc1013 in tab[source^] do inc(source); - if result then - exit; // found - until source^=#0; - source := nil; -end; -{$else} {$ifdef FPC} nostackframe; assembler; {$endif} -asm // eax=source edx=search - push eax // save source var - mov eax, [eax] // eax=source - test eax, eax - jz @z - push ebx - mov ebx, edx // save search - cmp byte ptr[eax], '[' - lea eax, [eax + 1] - jne @s -@i: push eax - mov edx, ebx // edx=search - call IdemPChar - pop ecx // ecx=source - jmp @1 -@s: mov ecx, eax - xor eax, eax // result := false -@1: mov dl, [ecx] // while not (source^ in [#0,#10,#13]) do inc(source); - inc ecx - cmp dl, 13 - ja @1 - je @e - or dl, dl - jz @0 - cmp dl, 10 - jne @1 - cmp byte[ecx], 13 - jbe @1 - jmp @4 -@e: cmp byte ptr[ecx], 10 // jump #13#10 - jne @4 - inc ecx -@4: test al, al - jnz @x // exit if IdemPChar returned true - cmp byte ptr[ecx], '[' - lea ecx, [ecx + 1] - jne @1 - mov eax, ecx - jmp @i -@0: xor ecx, ecx // set source=nil -@x: pop ebx - pop edx // restore source var - mov [edx], ecx // update source var - ret -@z: pop edx // ignore source var, result := false -end; -{$endif PUREPASCAL} - -{$ifdef USENORMTOUPPER} -{$ifdef PUREPASCAL} -function IdemPCharW(p: PWideChar; up: PUTF8Char): boolean; -begin - result := false; - if (p=nil) or (up=nil) then - exit; - while up^<>#0 do begin - if (p^>#255) or (up^<>AnsiChar(NormToUpperByte[ord(p^)])) then - exit; - inc(up); - inc(p); - end; - result := true; -end; -{$else} -function IdemPCharW(p: PWideChar; up: PUTF8Char): boolean; {$ifdef FPC} nostackframe; assembler; {$endif} -asm // eax=p edx=up - test eax, eax - jz @e // P=nil -> false - test edx, edx - push ebx - push esi - jz @z // up=nil -> true - mov esi, offset NormToUpper - xor ebx, ebx - xor ecx, ecx -@1: mov bx, [eax] // bl=p^ - mov cl, [edx] // cl=up^ - test bh, bh // p^ > #255 -> FALSE - jnz @n - test cl, cl - mov bl, [ebx + esi] // bl=NormToUpper[p^] - jz @z // up^=#0 -> OK - inc edx - add eax, 2 - cmp bl, cl - je @1 -@n: pop esi - pop ebx -@e: xor eax, eax - ret -@z: mov al, 1 // up^=#0 -> OK - pop esi - pop ebx -end; -{$endif PUREPASCAL} -{$else} -function IdemPCharW(p: PWideChar; up: PUTF8Char): boolean; -// if the beginning of p^ is same as up^ (ignore case - up^ must be already Upper) -begin - result := false; - if (p=nil) or (up=nil) then - exit; - while up^<>#0 do begin - if (p^>#255) or (up^<>AnsiChar(NormToUpperByteAnsi7[ord(p^)])) then - exit; - inc(up); - inc(p); - end; - result := true; -end; -{$endif USENORMTOUPPER} - -function FindNameValue(P: PUTF8Char; UpperName: PAnsiChar): PUTF8Char; -var - {$ifdef CPUX86NOTPIC} - table: TNormTable absolute NormToUpperAnsi7; - {$else} - table: PNormTable; - {$endif} - c: AnsiChar; - u: PAnsiChar; -label - _0; -begin - if (P = nil) or (UpperName = nil) then - goto _0; - {$ifndef CPUX86NOTPIC} table := @NormToUpperAnsi7; {$endif} - repeat - c := UpperName^; - if table[P^] = c then - begin - inc(P); - u := UpperName + 1; - repeat - c := u^; - inc(u); - if c <> #0 then - begin - if table[P^] <> c then - break; - inc(P); - continue; - end; - result := P; // if found, points just after UpperName - exit; - until false; - end; - repeat - repeat - c := P^; - inc(P); - until c <= #13; - if c = #13 then // most common case is text ending with #13#10 - repeat - c := P^; - if (c <> #10) and (c <> #13) then - break; - inc(P); - until false - else if c <> #10 then - if c <> #0 then - continue // e.g. #9 - else - goto _0 - else - repeat - c := P^; - if c <> #10 then - break; - inc(P); - until false; - if c <> #0 then - break; // check if UpperName is at the begining of the new line -_0: result := nil; // reached P^=#0 -> not found - exit; - until false; - until false; -end; - -function FindNameValue(const NameValuePairs: RawUTF8; UpperName: PAnsiChar; - var Value: RawUTF8): boolean; -var - P: PUTF8Char; - L: PtrInt; -begin - P := FindNameValue(pointer(NameValuePairs), UpperName); - if P <> nil then - begin - while P^ in [#9, ' '] do // trim left - inc(P); - L := 0; - while P[L] > #13 do // end of line/value - inc(L); - while P[L - 1] = ' ' do // trim right - dec(L); - FastSetString(Value, P, L); - result := true; - end - else - begin - {$ifdef FPC} Finalize(Value); {$else} Value := ''; {$endif} - result := false; - end; -end; - -function FindSectionFirstLineW(var source: PWideChar; search: PUTF8Char): boolean; -{$ifdef PUREPASCAL} -begin - result := false; - if source=nil then - exit; - repeat - if source^='[' then begin - inc(source); - result := IdemPCharW(source,search); - end; - while not (cardinal(source^) in [0,10,13]) do inc(source); - while cardinal(source^) in [10,13] do inc(source); - if result then - exit; // found - until source^=#0; - source := nil; -end; -{$else} {$ifdef FPC} nostackframe; assembler; {$endif} -asm // eax=source edx=search - push eax // save source var - mov eax, [eax] // eax=source - test eax, eax - jz @z - push ebx - mov ebx, edx // save search - cmp word ptr[eax], '[' - lea eax, [eax + 2] - jne @s -@i: push eax - mov edx, ebx // edx=search - call IdemPCharW - pop ecx // ecx=source - jmp @1 -@s: mov ecx, eax - xor eax, eax // result := false -@1: mov dx, [ecx] // while not (source^ in [#0,#10,#13]) do inc(source) - add ecx, 2 - cmp dx, 13 - ja @1 - je @e - or dx, dx - jz @0 - cmp dx, 10 - jne @1 - jmp @4 -@e: cmp word ptr[ecx], 10 // jump #13#10 - jne @4 - add ecx, 2 -@4: test al, al - jnz @x // exit if IdemPChar returned true - cmp word ptr[ecx], '[' - lea ecx, [ecx + 2] - jne @1 - mov eax, ecx - jmp @i -@0: xor ecx, ecx // set source=nil -@x: pop ebx - pop edx // restore source var - mov [edx], ecx // update source var - ret -@z: pop edx // ignore source var, result := false -end; -{$endif PUREPASCAL} - -function FindIniNameValue(P: PUTF8Char; UpperName: PAnsiChar): RawUTF8; -var u, PBeg: PUTF8Char; - by4: cardinal; - table: {$ifdef CPUX86NOTPIC}TNormTable absolute NormToUpperAnsi7{$else}PNormTable{$endif}; -begin // expect UpperName as 'NAME=' - if (P<>nil) and (P^<>'[') and (UpperName<>nil) then begin - {$ifndef CPUX86NOTPIC}table := @NormToUpperAnsi7;{$endif} - PBeg := nil; - u := P; - repeat - while u^=' ' do inc(u); // trim left ' ' - if u^=#0 then - break; - if table[u^]=UpperName[0] then - PBeg := u; - repeat - by4 := PCardinal(u)^; - if ToByte(by4)>13 then - if ToByte(by4 shr 8)>13 then - if ToByte(by4 shr 16)>13 then - if ToByte(by4 shr 24)>13 then begin - inc(u,4); - continue; - end else - inc(u,3) else - inc(u,2) else - inc(u); - if u^ in [#0,#10,#13] then - break else - inc(u); - until false; - if PBeg<>nil then begin - inc(PBeg); - P := u; - u := pointer(UpperName+1); - repeat - if u^<>#0 then - if table[PBeg^]<>u^ then - break else begin - inc(u); - inc(PBeg); - end else begin - FastSetString(result,PBeg,P-PBeg); - exit; - end; - until false; - PBeg := nil; - u := P; - end; - if u^=#13 then inc(u); - if u^=#10 then inc(u); - until u^ in [#0,'[']; - end; - result := ''; -end; - -function ExistsIniName(P: PUTF8Char; UpperName: PAnsiChar): boolean; -var table: PNormTable; -begin - result := false; - table := @NormToUpperAnsi7; - if (P<>nil) and (P^<>'[') then - repeat - if P^=' ' then begin - repeat inc(P) until P^<>' '; // trim left ' ' - if P^=#0 then - break; - end; - if IdemPChar2(table,P,UpperName) then begin - result := true; - exit; - end; - repeat - if P[0]>#13 then - if P[1]>#13 then - if P[2]>#13 then - if P[3]>#13 then begin - inc(P,4); - continue; - end else - inc(P,3) else - inc(P,2) else - inc(P); - case P^ of - #0: exit; - #10: begin inc(P); break; end; - #13: begin if P[1]=#10 then inc(P,2) else inc(P); break; end; - else inc(P); - end; - until false; - until P^='['; -end; - -function ExistsIniNameValue(P: PUTF8Char; const UpperName: RawUTF8; - const UpperValues: array of PAnsiChar): boolean; -var PBeg: PUTF8Char; -begin - result := true; - if high(UpperValues)>=0 then - while (P<>nil) and (P^<>'[') do begin - if P^=' ' then repeat inc(P) until P^<>' '; // trim left ' ' - PBeg := P; - if IdemPChar(PBeg,pointer(UpperName)) then begin - inc(PBeg,length(UpperName)); - if IdemPCharArray(PBeg,UpperValues)>=0 then - exit; // found one value - break; - end; - P := GotoNextLine(P); - end; - result := false; -end; - -function GetSectionContent(SectionFirstLine: PUTF8Char): RawUTF8; -var PBeg: PUTF8Char; -begin - PBeg := SectionFirstLine; - while (SectionFirstLine<>nil) and (SectionFirstLine^<>'[') do - SectionFirstLine := GotoNextLine(SectionFirstLine); - if SectionFirstLine=nil then - result := PBeg else - FastSetString(result,PBeg,SectionFirstLine-PBeg); -end; - -function GetSectionContent(const Content, SectionName: RawUTF8): RawUTF8; -var P: PUTF8Char; - UpperSection: array[byte] of AnsiChar; -begin - P := pointer(Content); - PWord(UpperCopy255(UpperSection,SectionName))^ := ord(']'); - if FindSectionFirstLine(P,UpperSection) then - result := GetSectionContent(P) else - result := ''; -end; - -function DeleteSection(var Content: RawUTF8; const SectionName: RawUTF8; - EraseSectionHeader: boolean): boolean; -var P: PUTF8Char; - UpperSection: array[byte] of AnsiChar; -begin - result := false; // no modification - P := pointer(Content); - PWord(UpperCopy255(UpperSection,SectionName))^ := ord(']'); - if FindSectionFirstLine(P,UpperSection) then - result := DeleteSection(P,Content,EraseSectionHeader); -end; - -function DeleteSection(SectionFirstLine: PUTF8Char; var Content: RawUTF8; - EraseSectionHeader: boolean): boolean; -var PEnd: PUTF8Char; - IndexBegin: PtrInt; -begin - result := false; - PEnd := SectionFirstLine; - if EraseSectionHeader then // erase [Section] header line - while (PtrUInt(SectionFirstLine)>PtrUInt(Content)) and (SectionFirstLine^<>'[') do dec(SectionFirstLine); - while (PEnd<>nil) and (PEnd^<>'[') do - PEnd := GotoNextLine(PEnd); - IndexBegin := SectionFirstLine-pointer(Content); - if IndexBegin=0 then - exit; // no modification - if PEnd=nil then - SetLength(Content,IndexBegin) else - delete(Content,IndexBegin+1,PEnd-SectionFirstLine); - result := true; // Content was modified -end; - -procedure ReplaceSection(SectionFirstLine: PUTF8Char; - var Content: RawUTF8; const NewSectionContent: RawUTF8); -var PEnd: PUTF8Char; - IndexBegin: PtrInt; -begin - if SectionFirstLine=nil then - exit; - // delete existing [Section] content - PEnd := SectionFirstLine; - while (PEnd<>nil) and (PEnd^<>'[') do - PEnd := GotoNextLine(PEnd); - IndexBegin := SectionFirstLine-pointer(Content); - if PEnd=nil then - SetLength(Content,IndexBegin) else - delete(Content,IndexBegin+1,PEnd-SectionFirstLine); - // insert section content - insert(NewSectionContent,Content,IndexBegin+1); -end; - -procedure ReplaceSection(var Content: RawUTF8; const SectionName, - NewSectionContent: RawUTF8); -var UpperSection: array[byte] of AnsiChar; - P: PUTF8Char; -begin - P := pointer(Content); - PWord(UpperCopy255(UpperSection,SectionName))^ := ord(']'); - if FindSectionFirstLine(P,UpperSection) then - ReplaceSection(P,Content,NewSectionContent) else - Content := Content+'['+SectionName+']'#13#10+NewSectionContent; -end; - -function FindIniNameValueInteger(P: PUTF8Char; UpperName: PAnsiChar): PtrInt; -begin - result := GetInteger(pointer(FindIniNameValue(P,UpperName))); -end; - -function FindIniEntry(const Content, Section, Name: RawUTF8): RawUTF8; -var P: PUTF8Char; - UpperSection, UpperName: array[byte] of AnsiChar; - // possible GPF if length(Section/Name)>255, but should const in code -begin - result := ''; - P := pointer(Content); - if P=nil then exit; - // UpperName := UpperCase(Name)+'='; - PWord(UpperCopy255(UpperName,Name))^ := ord('='); - if Section='' then - // find the Name= entry before any [Section] - result := FindIniNameValue(P,UpperName) else begin - // find the Name= entry in the specified [Section] - PWord(UpperCopy255(UpperSection,Section))^ := ord(']'); - if FindSectionFirstLine(P,UpperSection) then - result := FindIniNameValue(P,UpperName); - end; -end; - -function FindWinAnsiIniEntry(const Content, Section,Name: RawUTF8): RawUTF8; -begin - result := WinAnsiToUtf8(WinAnsiString(FindIniEntry(Content,Section,Name))); -end; - -function FindIniEntryInteger(const Content,Section,Name: RawUTF8): integer; -begin - result := GetInteger(pointer(FindIniEntry(Content,Section,Name))); -end; - -function FindIniEntryFile(const FileName: TFileName; const Section,Name: RawUTF8): RawUTF8; -var Content: RawUTF8; -begin - Content := StringFromFile(FileName); - if Content='' then - result := '' else - result := FindIniEntry(Content,Section,Name); -end; - -function UpdateIniNameValueInternal(var Content: RawUTF8; - const NewValue, NewValueCRLF: RawUTF8; var P: PUTF8Char; - UpperName: PAnsiChar; UpperNameLength: integer): boolean; -var PBeg: PUTF8Char; - i: integer; -begin - while (P<>nil) and (P^<>'[') do begin - while P^=' ' do inc(P); // trim left ' ' - PBeg := P; - P := GotoNextLine(P); - if IdemPChar(PBeg,UpperName) then begin - // update Name=Value entry - result := true; - inc(PBeg,UpperNameLength); - i := (PBeg-pointer(Content))+1; - if (i=length(NewValue)) and CompareMem(PBeg,pointer(NewValue),i) then - exit; // new Value is identical to the old one -> no change - if P=nil then // avoid last line (P-PBeg) calculation error - SetLength(Content,i-1) else - delete(Content,i,P-PBeg); // delete old Value - insert(NewValueCRLF,Content,i); // set new value - exit; - end; - end; - result := false; -end; - -function UpdateIniNameValue(var Content: RawUTF8; const Name, UpperName, NewValue: RawUTF8): boolean; -var P: PUTF8Char; -begin - if UpperName='' then - result := false else begin - P := pointer(Content); - result := UpdateIniNameValueInternal(Content,NewValue,NewValue+#13#10,P, - pointer(UpperName),length(UpperName)); - if result or (Name='') then - exit; - if Content<>'' then - Content := Content+#13#10; - Content := Content+Name+NewValue; - result := true; - end; -end; - -procedure UpdateIniEntry(var Content: RawUTF8; const Section,Name,Value: RawUTF8); -const CRLF = #13#10; -var P: PUTF8Char; - SectionFound: boolean; - i, UpperNameLength: PtrInt; - V: RawUTF8; - UpperSection, UpperName: array[byte] of AnsiChar; -label Sec; -begin - UpperNameLength := length(Name); - PWord(UpperCopy255Buf(UpperName,pointer(Name),UpperNameLength))^ := ord('='); - inc(UpperNameLength); - V := Value+CRLF; - P := pointer(Content); - // 1. find Section, and try update within it - if Section='' then - goto Sec; // find the Name= entry before any [Section] - SectionFound := false; - PWord(UpperCopy255(UpperSection,Section))^ := ord(']'); - if FindSectionFirstLine(P,UpperSection) then begin -Sec:SectionFound := true; - if UpdateIniNameValueInternal(Content,Value,V,P,@UpperName,UpperNameLength) then - exit; - // we reached next [Section] without having found Name= - end; - // 2. section or Name= entry not found: add Name=Value - V := Name+'='+V; - if not SectionFound then - // create not existing [Section] - V := '['+Section+(']'+CRLF)+V; - // insert Name=Value at P^ (end of file or end of [Section]) - if P=nil then - // insert at end of file - Content := Content+V else begin - // insert at end of [Section] - i := (P-pointer(Content))+1; - insert(V,Content,i); - end; -end; - -procedure UpdateIniEntryFile(const FileName: TFileName; const Section,Name,Value: RawUTF8); -var Content: RawUTF8; -begin - Content := StringFromFile(FileName); - UpdateIniEntry(Content,Section,Name,Value); - FileFromString(Content,FileName); -end; - -function StringFromFile(const FileName: TFileName; HasNoSize: boolean): RawByteString; -var F: THandle; - Read, Size, Chunk: integer; - P: PUTF8Char; - tmp: array[0..$7fff] of AnsiChar; -begin - result := ''; - if FileName='' then - exit; - F := FileOpenSequentialRead(FileName); - if PtrInt(F)>=0 then begin - if HasNoSize then begin - Size := 0; - repeat - Read := FileRead(F,tmp,SizeOf(tmp)); - if Read<=0 then - break; - SetLength(result,Size+Read); // in-place resize - MoveFast(tmp,PByteArray(result)^[Size],Read); - inc(Size,Read); - until false; - end else begin - Size := GetFileSize(F,nil); - if Size>0 then begin - SetLength(result,Size); - P := pointer(result); - repeat - Chunk := Size; - {$ifdef MSWINDOWS} // FILE_FLAG_SEQUENTIAL_SCAN has limits on XP - if Chunk>32 shl 20 then - Chunk := 32 shl 20; // avoid e.g. ERROR_NO_SYSTEM_RESOURCES - {$endif} - Read := FileRead(F,P^,Chunk); - if Read<=0 then begin - result := ''; - break; - end; - inc(P,Read); - dec(Size,Read); - until Size=0; - end; - end; - FileClose(F); - end; -end; - -function FileFromString(const Content: RawByteString; const FileName: TFileName; - FlushOnDisk: boolean; FileDate: TDateTime): boolean; -var F: THandle; - P: PByte; - L,written: integer; -begin - result := false; - if FileName='' then - exit; - F := FileCreate(FileName); - if PtrInt(F)<0 then - exit; - L := length(Content); - P := pointer(Content); - while L>0 do begin - written := FileWrite(F,P^,L); - if written<0 then begin - FileClose(F); - exit; - end; - dec(L,written); - inc(P,written); - end; - if FlushOnDisk then - FlushFileBuffers(F); - {$ifdef MSWINDOWS} - if FileDate<>0 then - FileSetDate(F,DateTimeToFileDate(FileDate)); - FileClose(F); - {$else} - FileClose(F); - if FileDate<>0 then - FileSetDate(FileName,DateTimeToFileDate(FileDate)); - {$endif MSWINDOWS} - result := true; -end; - -type - TTextFileKind = (isUnicode, isUTF8, isAnsi); - -function TextFileKind(const Map: TMemoryMap): TTextFileKind; -begin - result := isAnsi; - if (Map.Buffer<>nil) and (Map.Size>3) then - if PWord(Map.Buffer)^=$FEFF then - result := isUnicode else - if (PWord(Map.Buffer)^=$BBEF) and (PByteArray(Map.Buffer)[2]=$BF) then - result := isUTF8; -end; - -function AnyTextFileToSynUnicode(const FileName: TFileName; ForceUTF8: boolean): SynUnicode; -var Map: TMemoryMap; -begin - result := ''; - if Map.Map(FileName) then - try - if ForceUTF8 then - UTF8ToSynUnicode(PUTF8Char(Map.Buffer),Map.Size,Result) else - case TextFileKind(Map) of - isUnicode: - SetString(result,PWideChar(PtrUInt(Map.Buffer)+2),(Map.Size-2) shr 1); - isUTF8: - UTF8ToSynUnicode(PUTF8Char(pointer(PtrUInt(Map.Buffer)+3)),Map.Size-3,Result); - isAnsi: - result := CurrentAnsiConvert.AnsiToUnicodeString(Map.Buffer, Map.Size); - end; - finally - Map.UnMap; - end; -end; - -function AnyTextFileToRawUTF8(const FileName: TFileName; AssumeUTF8IfNoBOM: boolean): RawUTF8; -var Map: TMemoryMap; -begin - result := ''; - if Map.Map(FileName) then - try - case TextFileKind(Map) of - isUnicode: - RawUnicodeToUtf8(PWideChar(PtrUInt(Map.Buffer)+2),(Map.Size-2) shr 1,Result); - isUTF8: - FastSetString(result,pointer(PtrUInt(Map.Buffer)+3),Map.Size-3); - isAnsi: - if AssumeUTF8IfNoBOM then - FastSetString(result,Map.Buffer,Map.Size) else - result := CurrentAnsiConvert.AnsiBufferToRawUTF8(Map.Buffer, Map.Size); - end; - finally - Map.UnMap; - end; -end; - -function AnyTextFileToString(const FileName: TFileName; ForceUTF8: boolean): string; -var Map: TMemoryMap; -begin - result := ''; - if Map.Map(FileName) then - try - if ForceUTF8 then -{$ifdef UNICODE} - UTF8DecodeToString(PUTF8Char(Map.Buffer),Map.Size,result) {$else} - result := CurrentAnsiConvert.UTF8BufferToAnsi(PUTF8Char(Map.Buffer),Map.Size) -{$endif} else - case TextFileKind(Map) of -{$ifdef UNICODE} - isUnicode: - SetString(result,PWideChar(PtrUInt(Map.Buffer)+2),(Map.Size-2) shr 1); - isUTF8: - UTF8DecodeToString(pointer(PtrUInt(Map.Buffer)+3),Map.Size-3,result); - isAnsi: - result := CurrentAnsiConvert.AnsiToUnicodeString(Map.Buffer,Map.Size); -{$else} - isUnicode: - result := CurrentAnsiConvert.UnicodeBufferToAnsi(PWideChar(PtrUInt(Map.Buffer)+2),(Map.Size-2) shr 1); - isUTF8: - result := CurrentAnsiConvert.UTF8BufferToAnsi(pointer(PtrUInt(Map.Buffer)+3),Map.Size-3); - isAnsi: - SetString(result,PAnsiChar(Map.Buffer),Map.Size); -{$endif UNICODE} - end; - finally - Map.UnMap; - end; -end; - -function StreamToRawByteString(aStream: TStream): RawByteString; -var current, size: Int64; -begin - result := ''; - if aStream=nil then - exit; - current := aStream.Position; - if (current=0) and aStream.InheritsFrom(TRawByteStringStream) then begin - result := TRawByteStringStream(aStream).DataString; // fast COW - exit; - end; - size := aStream.Size-current; - if (size=0) or (size>maxInt) then - exit; - SetLength(result,size); - aStream.Read(pointer(result)^,size); - aStream.Position := current; -end; - -function RawByteStringToStream(const aString: RawByteString): TStream; -begin - result := TRawByteStringStream.Create(aString); -end; - -function ReadStringFromStream(S: TStream; MaxAllowedSize: integer): RawUTF8; -var L: integer; -begin - result := ''; - L := 0; - if (S.Read(L,4)<>4) or (L<=0) or (L>MaxAllowedSize) then - exit; - FastSetString(result,nil,L); - if S.Read(pointer(result)^,L)<>L then - result := ''; -end; - -function WriteStringToStream(S: TStream; const Text: RawUTF8): boolean; -var L: integer; -begin - L := length(Text); - if L=0 then - result := S.Write(L,4)=4 else - {$ifdef FPC} - result := (S.Write(L,4)=4) and (S.Write(pointer(Text)^,L)=L); - {$else} - result := S.Write(pointer(PtrInt(Text)-SizeOf(integer))^,L+4)=L+4; - {$endif FPC} -end; - -function GetFileNameWithoutExt(const FileName: TFileName; - Extension: PFileName): TFileName; -var i, max: PtrInt; -begin - i := length(FileName); - max := i-16; - while (i>0) and not(cardinal(FileName[i]) in [ord('\'),ord('/'),ord('.')]) - and (i>=max) do dec(i); - if (i=0) or (FileName[i]<>'.') then begin - result := FileName; - if Extension<>nil then - Extension^ := ''; - end else begin - result := copy(FileName,1,i-1); - if Extension<>nil then - Extension^ := copy(FileName,i,20); - end; -end; - -function GetFileNameExtIndex(const FileName, CSVExt: TFileName): integer; -var Ext: TFileName; - P: PChar; -begin - result := -1; - P := pointer(CSVExt); - Ext := ExtractFileExt(FileName); - if (P=nil) or (Ext='') or (Ext[1]<>'.') then - exit; - delete(Ext,1,1); - repeat - inc(result); - if SameText(GetNextItemString(P),Ext) then - exit; - until P=nil; - result := -1; -end; - -function FileSize(const FileName: TFileName): Int64; -{$ifdef MSWINDOWS} -var FA: WIN32_FILE_ATTRIBUTE_DATA; -begin // 5 times faster than CreateFile, GetFileSizeEx, CloseHandle - if GetFileAttributesEx(pointer(FileName),GetFileExInfoStandard,@FA) then begin - PInt64Rec(@result)^.Lo := FA.nFileSizeLow; - PInt64Rec(@result)^.Hi := FA.nFileSizeHigh; - end else - result := 0; -end; -{$else} -var f: THandle; - res: Int64Rec absolute result; -begin - result := 0; - f := FileOpen(FileName,fmOpenRead or fmShareDenyNone); - if PtrInt(f)>0 then begin - res.Lo := GetFileSize(f,@res.Hi); // from SynKylix/SynFPCLinux - FileClose(f); - end; -end; -{$endif MSWINDOWS} - -function FileSize(F: THandle): Int64; -var res: Int64Rec absolute result; -begin - result := 0; - if PtrInt(F)>0 then - res.Lo := GetFileSize(F,@res.Hi); // from WinAPI or SynKylix/SynFPCLinux -end; - -function FileInfoByHandle(aFileHandle: THandle; out FileId, FileSize, - LastWriteAccess, FileCreateDateTime: Int64): Boolean; -var - lastreadaccess: TUnixMSTime; - {$ifdef MSWINDOWS} - lp: TByHandleFileInformation; - {$else} - lp: {$ifdef FPC}stat{$else}TStatBuf64{$endif}; - r: integer; - {$endif MSWINDOWS} -begin -{$ifdef MSWINDOWS} - result := GetFileInformationByHandle(aFileHandle,lp); - if not result then - exit; - LastWriteAccess := FileTimeToUnixMSTime(lp.ftLastWriteTime); - FileCreateDateTime := FileTimeToUnixMSTime(lp.ftCreationTime); - lastreadaccess := FileTimeToUnixMSTime(lp.ftLastAccessTime); - PInt64Rec(@FileSize).lo := lp.nFileSizeLow; - PInt64Rec(@FileSize).hi := lp.nFileSizeHigh; - PInt64Rec(@FileId).lo := lp.nFileIndexLow; - PInt64Rec(@FileId).hi := lp.nFileIndexHigh; -{$else} - r := {$ifdef FPC}FpFStat{$else}fstat64{$endif}(aFileHandle, lp); - result := r >= 0; - if not result then - exit; - FileId := lp.st_ino; - FileSize := lp.st_size; - lastreadaccess := lp.st_atime * MSecsPerSec; - LastWriteAccess := lp.st_mtime * MSecsPerSec; - {$ifdef OPENBSD} - if (lp.st_birthtime <> 0) and (lp.st_birthtime < lp.st_ctime) then - lp.st_ctime:= lp.st_birthtime; - {$endif} - FileCreateDateTime := lp.st_ctime * MSecsPerSec; -{$endif MSWINDOWS} - if LastWriteAccess <> 0 then - if (FileCreateDateTime = 0) or (FileCreateDateTime > LastWriteAccess) then - FileCreateDateTime:= LastWriteAccess; - if lastreadaccess <> 0 then - if (FileCreateDateTime = 0) or (FileCreateDateTime > lastreadaccess) then - FileCreateDateTime:= lastreadaccess; -end; - -function FileAgeToDateTime(const FileName: TFileName): TDateTime; -{$ifdef MSWINDOWS} -var FA: WIN32_FILE_ATTRIBUTE_DATA; - ST,LT: TSystemTime; -begin // 5 times faster than CreateFile, GetFileSizeEx, CloseHandle - if GetFileAttributesEx(pointer(FileName),GetFileExInfoStandard,@FA) and - FileTimeToSystemTime(FA.ftLastWriteTime,ST) and - SystemTimeToTzSpecificLocalTime(nil,ST,LT) then - result := SystemTimeToDateTime(LT) else - result := 0; -end; -{$else} -{$ifdef HASNEWFILEAGE} -begin - if not FileAge(FileName,result) then -{$else} -var Age: integer; -begin - Age := FileAge(FileName); - if Age<>-1 then - result := FileDateToDateTime(Age) else -{$endif HASNEWFILEAGE} - result := 0; -end; -{$endif MSWINDOWS} - -function CopyFile(const Source, Target: TFileName; FailIfExists: boolean): boolean; -{$ifdef MSWINDOWS} -begin - result := Windows.CopyFile(pointer(Source),pointer(Target),FailIfExists); -end; -{$else} -var SourceF, DestF: TFileStream; -begin - result := false; - if FailIfExists then - if FileExists(Target) then - exit else - DeleteFile(Target); - try - SourceF := TFileStream.Create(Source,fmOpenRead); - try - DestF := TFileStream.Create(Target,fmCreate); - try - DestF.CopyFrom(SourceF, SourceF.Size); - finally - DestF.Free; - end; - FileSetDateFrom(Target,SourceF.Handle); - finally - SourceF.Free; - end; - result := true; - except - result := false; - end; -end; -{$endif} - -function SearchRecToDateTime(const F: TSearchRec): TDateTime; -begin - {$ifdef ISDELPHIXE} - result := F.Timestamp; - {$else} - result := FileDateToDateTime(F.Time); - {$endif} -end; - -function SearchRecValidFile(const F: TSearchRec): boolean; -begin - {$ifndef DELPHI5OROLDER} - {$WARN SYMBOL_DEPRECATED OFF} // for faVolumeID - {$endif} - result := (F.Name<>'') and (F.Attr and (faDirectory - {$ifdef MSWINDOWS}+faVolumeID+faSysFile+faHidden)=0) and (F.Name[1]<>'.') - {$else})=0){$endif}; - {$ifndef DELPHI5OROLDER} - {$WARN SYMBOL_DEPRECATED ON} - {$endif} -end; - -function SearchRecValidFolder(const F: TSearchRec): boolean; -begin - result := (F.Attr and (faDirectory {$ifdef MSWINDOWS}+faHidden{$endif})=faDirectory) and - (F.Name<>'') and (F.Name<>'.') and (F.Name<>'..'); -end; - -function DirectoryDelete(const Directory: TFileName; const Mask: TFileName; - DeleteOnlyFilesNotDirectory: Boolean; DeletedCount: PInteger): Boolean; -var F: TSearchRec; - Dir: TFileName; - n: integer; -begin - n := 0; - result := true; - if DirectoryExists(Directory) then begin - Dir := IncludeTrailingPathDelimiter(Directory); - if FindFirst(Dir+Mask,faAnyFile-faDirectory,F)=0 then begin - repeat - if SearchRecValidFile(F) then - if DeleteFile(Dir+F.Name) then - inc(n) else - result := false; - until FindNext(F)<>0; - FindClose(F); - end; - if not DeleteOnlyFilesNotDirectory and not RemoveDir(Dir) then - result := false; - end; - if DeletedCount<>nil then - DeletedCount^ := n; -end; - -function DirectoryDeleteOlderFiles(const Directory: TFileName; TimePeriod: TDateTime; - const Mask: TFileName; Recursive: Boolean; TotalSize: PInt64): Boolean; -var F: TSearchRec; - Dir: TFileName; - old: TDateTime; -begin - if not Recursive and (TotalSize<>nil) then - TotalSize^ := 0; - result := true; - if (Directory='') or not DirectoryExists(Directory) then - exit; - Dir := IncludeTrailingPathDelimiter(Directory); - if FindFirst(Dir+Mask,faAnyFile,F)=0 then begin - old := Now - TimePeriod; - repeat - if F.Name[1]<>'.' then - if Recursive and (F.Attr and faDirectory<>0) then - DirectoryDeleteOlderFiles(Dir+F.Name,TimePeriod,Mask,true,TotalSize) else - if SearchRecValidFile(F) and (SearchRecToDateTime(F) < old) then - if not DeleteFile(Dir+F.Name) then - result := false else - if TotalSize<>nil then - inc(TotalSize^,F.Size); - until FindNext(F)<>0; - FindClose(F); - end; -end; - -procedure TFindFiles.FromSearchRec(const Directory: TFileName; const F: TSearchRec); -begin - Name := Directory+F.Name; - {$ifdef MSWINDOWS} - {$ifdef HASINLINE} // FPC or Delphi 2006+ - Size := F.Size; - {$else} // F.Size was limited to 32-bit on older Delphi - PInt64Rec(@Size)^.Lo := F.FindData.nFileSizeLow; - PInt64Rec(@Size)^.Hi := F.FindData.nFileSizeHigh; - {$endif} - {$else} - Size := F.Size; - {$endif} - Attr := F.Attr; - Timestamp := SearchRecToDateTime(F); -end; - -function TFindFiles.ToText: shortstring; -begin - FormatShort('% % %',[Name,KB(Size),DateTimeToFileShort(Timestamp)],result); -end; - -function FindFiles(const Directory,Mask,IgnoreFileName: TFileName; - SortByName,IncludesDir,SubFolder: boolean): TFindFilesDynArray; -var m,count: integer; - dir: TFileName; - da: TDynArray; - masks: TRawUTF8DynArray; - masked: TFindFilesDynArray; - procedure SearchFolder(const folder : TFileName); - var - F: TSearchRec; - ff: TFindFiles; - begin - if FindFirst(dir+folder+Mask,faAnyfile-faDirectory,F)=0 then begin - repeat - if SearchRecValidFile(F) and ((IgnoreFileName='') or - (AnsiCompareFileName(F.Name,IgnoreFileName)<>0)) then begin - if IncludesDir then - ff.FromSearchRec(dir+folder,F) else - ff.FromSearchRec(folder,F); - da.Add(ff); - end; - until FindNext(F)<>0; - FindClose(F); - end; - if SubFolder and (FindFirst(dir+folder+'*',faDirectory,F)=0) then begin - repeat - if SearchRecValidFolder(F) and ((IgnoreFileName='') or - (AnsiCompareFileName(F.Name,IgnoreFileName)<>0)) then - SearchFolder(IncludeTrailingPathDelimiter(folder+F.Name)); - until FindNext(F)<>0; - FindClose(F); - end; - end; -begin - result := nil; - da.Init(TypeInfo(TFindFilesDynArray),result,@count); - if Pos(';',Mask)>0 then - CSVToRawUTF8DynArray(pointer(StringToUTF8(Mask)),masks,';'); - if masks<>nil then begin - if SortByName then - QuickSortRawUTF8(masks,length(masks),nil,{$ifdef MSWINDOWS}@StrIComp{$else}@StrComp{$endif}); - for m := 0 to length(masks)-1 do begin // masks[] recursion - masked := FindFiles(Directory,UTF8ToString(masks[m]), - IgnoreFileName,SortByName,IncludesDir,SubFolder); - da.AddArray(masked); - end; - end else begin - if Directory<>'' then - dir := IncludeTrailingPathDelimiter(Directory); - SearchFolder(''); - if SortByName and (da.Count>0) then - da.Sort(SortDynArrayFileName); - end; - da.Capacity := count; // trim result[] -end; - -function FindFilesDynArrayToFileNames(const Files: TFindFilesDynArray): TFileNameDynArray; -var i,n: PtrInt; -begin - Finalize(result); - n := length(Files); - SetLength(result,n); - for i := 0 to n-1 do - result[i] := Files[i].Name; -end; - -function SynchFolders(const Reference, Dest: TFileName; - SubFolder,ByContent,WriteFileNameToConsole: boolean): integer; -var ref,dst: TFileName; - fref,fdst: TSearchRec; - reftime: TDateTime; - s: RawByteString; -begin - result := 0; - ref := IncludeTrailingPathDelimiter(Reference); - dst := IncludeTrailingPathDelimiter(Dest); - if DirectoryExists(ref) and (FindFirst(dst+FILES_ALL,faAnyFile,fdst)=0) then begin - repeat - if SearchRecValidFile(fdst) then begin - if ByContent then - reftime := FileAgeToDateTime(ref+fdst.Name) else - if FindFirst(ref+fdst.Name,faAnyFile,fref)=0 then begin - reftime := SearchRecToDateTime(fref); - if (fdst.Size=fref.Size) and (SearchRecToDateTime(fdst)=reftime) then - reftime := 0; - FindClose(fref); - end else - reftime := 0; // "continue" trigger unexpected warning on Delphi - if reftime=0 then - continue; // skip if no reference file to copy from - s := StringFromFile(ref+fdst.Name); - if (s='') or (ByContent and (length(s)=fdst.Size) and - (DefaultHasher(0,pointer(s),fdst.Size)=HashFile(dst+fdst.Name))) then - continue; - FileFromString(s,dst+fdst.Name,false,reftime); - inc(result); - if WriteFileNameToConsole then - {$I-} writeln('synched ',dst,fdst.name); {$I+} - end else if SubFolder and SearchRecValidFolder(fdst) then - inc(result,SynchFolders(ref+fdst.Name,dst+fdst.Name,SubFolder,ByContent,WriteFileNameToConsole)); - until FindNext(fdst)<>0; - FindClose(fdst); - end; -end; - -function EnsureDirectoryExists(const Directory: TFileName; - RaiseExceptionOnCreationFailure: boolean): TFileName; -begin - result := IncludeTrailingPathDelimiter(ExpandFileName(Directory)); - if not DirectoryExists(result) then - if not CreateDir(result) then - if not RaiseExceptionOnCreationFailure then - result := '' else - raise ESynException.CreateUTF8('Impossible to create folder %',[result]); -end; - -var - TemporaryFileNameRandom: integer; - -function TemporaryFileName: TFileName; -var folder: TFileName; -begin // fast cross-platform implementation - folder := GetSystemPath(spTempFolder); - if TemporaryFileNameRandom=0 then - TemporaryFileNameRandom := Random32gsl; - repeat // thread-safe unique file name generation - FormatString('%%_%.tmp',[folder,ExeVersion.ProgramName, - CardinalToHexShort(InterlockedIncrement(TemporaryFileNameRandom))],string(result)); - until not FileExists(result); -end; - -function IsDirectoryWritable(const Directory: TFileName): boolean; -var fn: TFileName; -begin - fn := ExcludeTrailingPathDelimiter(Directory); - result := {$ifndef DELPHI5OROLDER}not FileIsReadOnly{$else}DirectoryExists{$endif}(fn); - if not result then - exit; - fn := FormatString('%%.%%',[fn,PathDelim,CardinalToHexShort(integer(GetCurrentThreadID)), - BinToBase64uriShort(@ExeVersion.Hash,SizeOf(ExeVersion.Hash))]); - result := FileFromString('tobedeleted',fn); // actually try to write something - DeleteFile(fn); -end; - -{$ifdef DELPHI5OROLDER} - -function DirectoryExists(const Directory: string): boolean; -var Code: Integer; -begin - Code := GetFileAttributes(pointer(Directory)); - result := (Code<>-1) and (FILE_ATTRIBUTE_DIRECTORY and Code<>0); -end; - -function SameFileName(const S1, S2: TFileName): Boolean; -begin - result := AnsiCompareFileName(S1,S2)=0; -end; - -function GetEnvironmentVariable(const Name: string): string; -var Len: Integer; - Buffer: array[0..1023] of Char; -begin - Result := ''; - Len := Windows.GetEnvironmentVariable(pointer(Name),@Buffer,SizeOf(Buffer)); - if Len 0 then - Error := EOSError.CreateFmt('System Error. Code: %d.'#13#10'%s', - [LastError,SysErrorMessage(LastError)]) else - Error := EOSError.Create('A call to an OS function failed'); - Error.ErrorCode := LastError; - raise Error; -end; - -{$endif DELPHI5OROLDER} - -{$ifdef DELPHI6OROLDER} -procedure VarCastError; -begin - raise EVariantError.Create('Variant Type Cast Error'); -end; -{$endif} - -{$ifdef MSWINDOWS} -function FileSetDateFrom(const Dest: TFileName; SourceHandle: integer): boolean; -var FileTime: TFileTime; - D: THandle; -begin - D := FileOpen(Dest,fmOpenWrite); - if D<>THandle(-1) then begin - result := GetFileTime(SourceHandle,nil,nil,@FileTime) and - SetFileTime(D,nil,nil,@FileTime); - FileClose(D); - end else - result := false; -end; -{$else} -function FileSetDateFrom(const Dest: TFileName; SourceHandle: integer): boolean; -begin - result := FileSetDate(Dest,FileGetDate(SourceHandle))=0; -end; -{$endif} - -{$IFDEF PUREPASCAL} -{$IFNDEF HASCODEPAGE} -function Pos(const substr, str: RawUTF8): Integer; overload; -begin // the RawByteString version is fast enough - Result := PosEx(substr,str,1); -end; -{$ENDIF} -{$ENDIF} - -function FindObjectEntry(const Content, Name: RawUTF8): RawUTF8; -var L: integer; -begin - result := Trim(FindIniEntry(Content,'',Name+' ')); // 'Name = Value' format - if (result<>'') and (result[1]='''') then begin - L := length(result); - if result[L]='''' then - result := copy(result,2,L-2); // 'testDI6322.IAS' -> testDI6322.IAS - end; -end; - -function FindObjectEntryWithoutExt(const Content, Name: RawUTF8): RawUTF8; -begin - result := RawUTF8(GetFileNameWithoutExt( - ExtractFileName(TFileName(FindObjectEntry(Content,Name))))); -end; - - -function Int64ScanExists(P: PInt64Array; Count: PtrInt; const Value: Int64): boolean; -begin - if P<>nil then begin - result := true; - Count := PtrInt(@P[Count-4]); - repeat - if PtrUInt(P)>PtrUInt(Count) then - break; - if (P^[0]=Value) or (P^[1]=Value) or (P^[2]=Value) or (P^[3]=Value) then - exit; - P := @P[4]; - until false; - inc(Count,4*SizeOf(Value)); - repeat - if PtrUInt(P)>=PtrUInt(Count) then - break; - if P^[0]=Value then - exit else - P := @P[1]; - until false; - end; - result := false; -end; - -function Int64Scan(P: PInt64Array; Count: PtrInt; const Value: Int64): PInt64; -begin - result := nil; - if P=nil then - exit; - Count := PtrInt(@P[Count-4]); - repeat - if PtrUInt(P)>PtrUInt(Count) then - break; - if P^[0]<>Value then - if P^[1]<>Value then - if P^[2]<>Value then - if P^[3]<>Value then begin - P := @P[4]; - continue; - end else - result := @P[3] else - result := @P[2] else - result := @P[1] else - result := pointer(P); - exit; - until false; - inc(Count,4*SizeOf(Value)); - result := pointer(P); - repeat - if PtrUInt(result)>=PtrUInt(Count) then - break; - if result^=Value then - exit else - inc(result); - until false; - result := nil; -end; - -function AddInteger(var Values: TIntegerDynArray; Value: integer; - NoDuplicates: boolean): boolean; -var n: PtrInt; -begin - n := Length(Values); - if NoDuplicates and IntegerScanExists(pointer(Values),n,Value) then begin - result := false; - exit; - end; - SetLength(Values,n+1); - Values[n] := Value; - result := true -end; - -procedure AddInteger(var Values: TIntegerDynArray; var ValuesCount: integer; - Value: integer); -begin - if ValuesCount=length(Values) then - SetLength(Values,NextGrow(ValuesCount)); - Values[ValuesCount] := Value; - inc(ValuesCount); -end; - -function AddInteger(var Values: TIntegerDynArray; var ValuesCount: integer; - Value: integer; NoDuplicates: boolean): boolean; -begin - if NoDuplicates and IntegerScanExists(pointer(Values),ValuesCount,Value) then begin - result := false; - exit; - end; - if ValuesCount=length(Values) then - SetLength(Values,NextGrow(ValuesCount)); - Values[ValuesCount] := Value; - inc(ValuesCount); - result := true; -end; - -function AddInteger(var Values: TIntegerDynArray; const Another: TIntegerDynArray): PtrInt; -var v,a: PtrInt; -begin - v := length(Values); - a := length(Another); - if a>0 then begin - SetLength(Values,v+a); - MoveFast(Another[0],Values[v],a*SizeOf(Integer)); - end; - result := v+a; -end; - -function AddWord(var Values: TWordDynArray; var ValuesCount: integer; Value: Word): PtrInt; -begin - result := ValuesCount; - if result=length(Values) then - SetLength(Values,NextGrow(result)); - Values[result] := Value; - inc(ValuesCount); -end; - -function AddInt64(var Values: TInt64DynArray; var ValuesCount: integer; Value: Int64): PtrInt; -begin - result := ValuesCount; - if result=length(Values) then - SetLength(Values,NextGrow(result)); - Values[result] := Value; - inc(ValuesCount); -end; - -function AddInt64(var Values: TInt64DynArray; Value: Int64): PtrInt; -begin - result := length(Values); - SetLength(Values,result+1); - Values[result] := Value; -end; - -function AddInt64(var Values: TInt64DynArray; const Another: TInt64DynArray): PtrInt; -var v,a: PtrInt; -begin - v := length(Values); - a := length(Another); - if a>0 then begin - SetLength(Values,v+a); - MoveFast(Another[0],Values[v],a*SizeOf(Int64)); - end; - result := v+a; -end; - -procedure AddInt64Sorted(var Values: TInt64DynArray; Value: Int64); -var last: integer; -begin - last := high(Values); - if FastFindInt64Sorted(pointer(Values),last,Value)<0 then begin - inc(last); - SetLength(Values,last+1); - Values[last] := Value; - QuickSortInt64(pointer(Values),0,last); - end; -end; - -function AddInt64Once(var Values: TInt64DynArray; Value: Int64): PtrInt; -begin - result := Int64ScanIndex(pointer(Values),length(Values),Value); - if result<0 then - result := AddInt64(Values,Value); -end; - -procedure DynArrayMakeUnique(Values: PPointer; TypeInfo: pointer); -var da: TDynArray; - n: PtrInt; -begin // caller ensured that Values<>nil, Values^<>nil and RefCnt>1 - da.Init(TypeInfo,Values^); - n := PDALen(PPtrUInt(Values)^-_DALEN)^{$ifdef FPC}+1{$endif}; - da.InternalSetLength(n,n); // make copy -end; - -procedure DeleteWord(var Values: TWordDynArray; Index: PtrInt); -var n: PtrInt; -begin - n := Length(Values); - if PtrUInt(Index)>=PtrUInt(n) then - exit; // wrong Index - dec(n); - if n>Index then begin - if PDACnt(PtrUInt(Values)-_DAREFCNT)^>1 then - DynArrayMakeUnique(@Values,TypeInfo(TWordDynArray)); - MoveFast(Values[Index+1],Values[Index],(n-Index)*SizeOf(Word)); - end; - SetLength(Values,n); -end; - -procedure DeleteInteger(var Values: TIntegerDynArray; Index: PtrInt); -var n: PtrInt; -begin - n := Length(Values); - if PtrUInt(Index)>=PtrUInt(n) then - exit; // wrong Index - dec(n); - if n>Index then begin - if PDACnt(PtrUInt(Values)-_DAREFCNT)^>1 then - DynArrayMakeUnique(@Values,TypeInfo(TIntegerDynArray)); - MoveFast(Values[Index+1],Values[Index],(n-Index)*SizeOf(Integer)); - end; - SetLength(Values,n); -end; - -procedure DeleteInteger(var Values: TIntegerDynArray; var ValuesCount: Integer; Index: PtrInt); -var n: PtrInt; -begin - n := ValuesCount; - if PtrUInt(Index)>=PtrUInt(n) then - exit; // wrong Index - dec(n,Index+1); - if n>0 then begin - if PDACnt(PtrUInt(Values)-_DAREFCNT)^>1 then - DynArrayMakeUnique(@Values,TypeInfo(TIntegerDynArray)); - MoveFast(Values[Index+1],Values[Index],n*SizeOf(Integer)); - end; - dec(ValuesCount); -end; - -procedure DeleteInt64(var Values: TInt64DynArray; Index: PtrInt); -var n: PtrInt; -begin - n := Length(Values); - if PtrUInt(Index)>=PtrUInt(n) then - exit; // wrong Index - dec(n); - if n>Index then begin - if PDACnt(PtrUInt(Values)-_DAREFCNT)^>1 then - DynArrayMakeUnique(@Values,TypeInfo(TInt64DynArray)); - MoveFast(Values[Index+1],Values[Index],(n-Index)*SizeOf(Int64)); - end; - SetLength(Values,n); -end; - -procedure DeleteInt64(var Values: TInt64DynArray; var ValuesCount: Integer; Index: PtrInt); -var n: PtrInt; -begin - n := ValuesCount; - if PtrUInt(Index)>=PtrUInt(n) then - exit; // wrong Index - dec(n,Index+1); - if n>0 then begin - if PDACnt(PtrUInt(Values)-_DAREFCNT)^>1 then - DynArrayMakeUnique(@Values,TypeInfo(TInt64DynArray)); - MoveFast(Values[Index+1],Values[Index],n*SizeOf(Int64)); - end; - dec(ValuesCount); -end; - -procedure ExcludeInteger(var Values, Excluded: TIntegerDynArray; ExcludedSortSize: integer); -var i,v,x,n: PtrInt; -begin - if (Values=nil) or (Excluded=nil) then - exit; // nothing to exclude - if PDACnt(PtrUInt(Values)-_DAREFCNT)^>1 then - DynArrayMakeUnique(@Values,TypeInfo(TIntegerDynArray)); - if PDACnt(PtrUInt(Excluded)-_DAREFCNT)^>1 then - DynArrayMakeUnique(@Excluded,TypeInfo(TIntegerDynArray)); - v := length(Values); - n := 0; - x := Length(Excluded); - if (x>ExcludedSortSize) or (v>ExcludedSortSize) then begin // sort if worth it - dec(x); - QuickSortInteger(pointer(Excluded),0,x); - for i := 0 to v-1 do - if FastFindIntegerSorted(pointer(Excluded),x,Values[i])<0 then begin - if n<>i then - Values[n] := Values[i]; - inc(n); - end; - end else - for i := 0 to v-1 do - if not IntegerScanExists(pointer(Excluded),x,Values[i]) then begin - if n<>i then - Values[n] := Values[i]; - inc(n); - end; - if n<>v then - SetLength(Values,n); -end; - -procedure IncludeInteger(var Values, Included: TIntegerDynArray; - IncludedSortSize: Integer); -var i,v,x,n: PtrInt; -begin - if (Values=nil) or (Included=nil) then begin - Values := nil; - exit; - end; - if PDACnt(PtrUInt(Values)-_DAREFCNT)^>1 then - DynArrayMakeUnique(@Values,TypeInfo(TIntegerDynArray)); - if PDACnt(PtrUInt(Included)-_DAREFCNT)^>1 then - DynArrayMakeUnique(@Included,TypeInfo(TIntegerDynArray)); - v := length(Values); - n := 0; - x := Length(Included); - if (x>IncludedSortSize) or (v>IncludedSortSize) then begin // sort if worth it - dec(x); - QuickSortInteger(pointer(Included),0,x); - for i := 0 to v-1 do - if FastFindIntegerSorted(pointer(Included),x,Values[i])>=0 then begin - if n<>i then - Values[n] := Values[i]; - inc(n); - end; - end else - for i := 0 to v-1 do - if IntegerScanExists(pointer(Included),x,Values[i]) then begin - if n<>i then - Values[n] := Values[i]; - inc(n); - end; - if n<>v then - SetLength(Values,n); -end; - -procedure ExcludeInt64(var Values, Excluded: TInt64DynArray; ExcludedSortSize: Integer); -var i,v,x,n: PtrInt; -begin - if (Values=nil) or (Excluded=nil) then - exit; // nothing to exclude - v := length(Values); - n := 0; - x := Length(Excluded); - if (x>ExcludedSortSize) or (v>ExcludedSortSize) then begin // sort if worth it - dec(x); - QuickSortInt64(pointer(Excluded),0,x); - for i := 0 to v-1 do - if FastFindInt64Sorted(pointer(Excluded),x,Values[i])<0 then begin - if n<>i then - Values[n] := Values[i]; - inc(n); - end; - end else - for i := 0 to v-1 do - if not Int64ScanExists(pointer(Excluded),x,Values[i]) then begin - if n<>i then - Values[n] := Values[i]; - inc(n); - end; - if n<>v then - SetLength(Values,n); -end; - -procedure IncludeInt64(var Values, Included: TInt64DynArray; - IncludedSortSize: integer); -var i,v,x,n: PtrInt; -begin - if (Values=nil) or (Included=nil) then begin - Values := nil; - exit; - end; - v := length(Values); - n := 0; - x := Length(Included); - if (x>IncludedSortSize) or (v>IncludedSortSize) then begin // sort if worth it - dec(x); - QuickSortInt64(pointer(Included),0,x); - for i := 0 to v-1 do - if FastFindInt64Sorted(pointer(Included),x,Values[i])>=0 then begin - if n<>i then - Values[n] := Values[i]; - inc(n); - end; - end else - for i := 0 to v-1 do - if Int64ScanExists(pointer(Included),x,Values[i]) then begin - if n<>i then - Values[n] := Values[i]; - inc(n); - end; - if n<>v then - SetLength(Values,n); -end; - -procedure DeduplicateInteger(var Values: TIntegerDynArray); -begin - DeduplicateInteger(Values, length(Values)); -end; - -function DeduplicateIntegerSorted(val: PIntegerArray; last: PtrInt): PtrInt; -var i: PtrInt; -begin // sub-function for better code generation - i := 0; - repeat // here last>0 so ilast then - continue; - result := i; - exit; - until false; - result := i; - inc(i); - if i<>last then begin - repeat - if val[i]<>val[i+1] then begin - val[result] := val[i]; - inc(result); - end; - inc(i); - until i=last; - val[result] := val[i]; - end; -end; - -function DeduplicateInteger(var Values: TIntegerDynArray; Count: integer): integer; -begin - result := Count; - dec(Count); - if Count>0 then begin - QuickSortInteger(pointer(Values),0,Count); - result := DeduplicateIntegerSorted(pointer(Values),Count)+1; - end; - if result<>length(Values) then - SetLength(Values,result); -end; - -procedure DeduplicateInt64(var Values: TInt64DynArray); -begin - DeduplicateInt64(Values, length(Values)); -end; - -function DeduplicateInt64Sorted(val: PInt64Array; last: PtrInt): PtrInt; -var i: PtrInt; -begin // sub-function for better code generation - i := 0; - repeat // here last>0 so ilast then - continue; - result := i; - exit; - until false; - result := i; - inc(i); - if i<>last then begin - repeat - if val[i]<>val[i+1] then begin - val[result] := val[i]; - inc(result); - end; - inc(i); - until i=last; - val[result] := val[i]; - end; -end; - -function DeduplicateInt64(var Values: TInt64DynArray; Count: integer): integer; -begin - result := Count; - dec(Count); - if Count>0 then begin - QuickSortInt64(pointer(Values),0,Count); - result := DeduplicateInt64Sorted(pointer(Values),Count)+1; - end; - if result<>length(Values) then - SetLength(Values,result); -end; - -procedure CopyInteger(const Source: TIntegerDynArray; out Dest: TIntegerDynArray); -var n: integer; -begin - n := length(Source); - SetLength(Dest,n); - MoveFast(Source[0],Dest[0],n*SizeOf(Integer)); -end; - -procedure CopyInt64(const Source: TInt64DynArray; out Dest: TInt64DynArray); -var n: integer; -begin - n := length(Source); - SetLength(Dest,n); - MoveFast(Source[0],Dest[0],n*SizeOf(Int64)); -end; - -function MaxInteger(const Values: TIntegerDynArray; ValuesCount: PtrInt; MaxStart: integer): Integer; -var i: PtrInt; - v: integer; -begin - result := MaxStart; - for i := 0 to ValuesCount-1 do begin - v := Values[i]; - if v>result then - result := v; // branchless opcode on FPC - end; -end; - -function SumInteger(const Values: TIntegerDynArray; ValuesCount: PtrInt): Integer; -var i: PtrInt; -begin - result := 0; - for i := 0 to ValuesCount-1 do - inc(result,Values[i]); -end; - -procedure Reverse(const Values: TIntegerDynArray; ValuesCount: PtrInt; - Reversed: PIntegerArray); -var i: PtrInt; -begin - i := 0; - if ValuesCount>=4 then begin - dec(ValuesCount,4); - while i0 then - if StartValue=0 then - for i := 0 to Count-1 do - Values[i] := i else - for i := 0 to Count-1 do begin - Values[i] := StartValue; - inc(StartValue); - end; -end; - -procedure Int64ToUInt32(Values64: PInt64Array; Values32: PCardinalArray; Count: PtrInt); -var i: PtrInt; -begin - for i := 0 to Count-1 do - Values32[i] := Values64[i]; -end; - -procedure CSVToIntegerDynArray(CSV: PUTF8Char; var Result: TIntegerDynArray; Sep: AnsiChar); -begin - while CSV<>nil do begin - SetLength(Result,length(Result)+1); - Result[high(Result)] := GetNextItemInteger(CSV,Sep); - end; -end; - -procedure CSVToInt64DynArray(CSV: PUTF8Char; var Result: TInt64DynArray; Sep: AnsiChar); -begin - while CSV<>nil do begin - SetLength(Result,length(Result)+1); - Result[high(Result)] := GetNextItemInt64(CSV,Sep); - end; -end; - -function CSVToInt64DynArray(CSV: PUTF8Char; Sep: AnsiChar): TInt64DynArray; -begin - Finalize(result); - while CSV<>nil do begin - SetLength(Result,length(Result)+1); - Result[high(Result)] := GetNextItemInt64(CSV,Sep); - end; -end; - -function IntegerDynArrayToCSV(Values: PIntegerArray; ValuesCount: integer; - const Prefix, Suffix: RawUTF8; InlinedValue: boolean): RawUTF8; -type - TInts16 = packed array[word] of string[15]; // shortstring are faster (no heap allocation) -var i, L, Len: PtrInt; - tmp: array[0..15] of AnsiChar; - ints: ^TInts16; - P: PAnsiChar; - tmpbuf: TSynTempBuffer; -begin - result := ''; - if ValuesCount=0 then - exit; - if InlinedValue then - Len := 4*ValuesCount else - Len := 0; - tmpbuf.Init(ValuesCount*SizeOf(ints[0])+Len); // faster than a dynamic array - try - ints := tmpbuf.buf; - // compute whole result length at once - dec(ValuesCount); - inc(Len,length(Prefix)+length(Suffix)); - tmp[15] := ','; - for i := 0 to ValuesCount do begin - P := StrInt32(@tmp[15],Values[i]); - L := @tmp[15]-P; - if i'' then begin - L := length(Prefix); - MoveSmall(pointer(Prefix),P,L); - inc(P,L); - end; - for i := 0 to ValuesCount do begin - if InlinedValue then begin - PWord(P)^ := ord(':')+ord('(')shl 8; - inc(P,2); - end; - L := ord(ints[i][0]); - MoveSmall(@ints[i][1],P,L); - inc(P,L); - if InlinedValue then begin - PWord(P)^ := ord(')')+ord(':')shl 8; - inc(P,2); - end; - end; - if Suffix<>'' then - MoveSmall(pointer(Suffix),P,length(Suffix)); - finally - tmpbuf.Done; - end; -end; - -function Int64DynArrayToCSV(Values: PInt64Array; ValuesCount: integer; - const Prefix, Suffix: RawUTF8; InlinedValue: boolean): RawUTF8; -type - TInt = packed record - Len: byte; - Val: array[0..19] of AnsiChar; // Int64: 19 digits, then - sign - end; -var i, L, Len: PtrInt; - int: ^TInt; - P: PAnsiChar; - tmp: TSynTempBuffer; -begin - result := ''; - if ValuesCount=0 then - exit; - if InlinedValue then - Len := 4*ValuesCount else - Len := 0; - int := tmp.Init(ValuesCount*SizeOf(TInt)+Len); // faster than a dynamic array - try - // compute whole result length at once - dec(ValuesCount); - inc(Len,length(Prefix)+length(Suffix)); - for i := 0 to ValuesCount do begin - P := StrInt64(PAnsiChar(int)+21,Values[i]); - L := PAnsiChar(int)+21-P; - int^.Len := L; - if i'' then begin - L := length(Prefix); - MoveSmall(pointer(Prefix),P,L); - inc(P,L); - end; - int := tmp.buf; - repeat - if InlinedValue then begin - PWord(P)^ := ord(':')+ord('(')shl 8; - inc(P,2); - end; - L := int^.Len; - MoveSmall(PAnsiChar(int)+21-L,P,L); - inc(P,L); - if InlinedValue then begin - PWord(P)^ := ord(')')+ord(':')shl 8; - inc(P,2); - end; - if ValuesCount=0 then - break; - inc(int); - P^ := ','; - inc(P); - dec(ValuesCount); - until false; - if Suffix<>'' then - MoveSmall(pointer(Suffix),P,length(Suffix)); - finally - tmp.Done; - end; -end; - -function IntegerDynArrayToCSV(const Values: TIntegerDynArray; - const Prefix, Suffix: RawUTF8; InlinedValue: boolean): RawUTF8; -begin - result := IntegerDynArrayToCSV(pointer(Values),length(Values),Prefix,Suffix,InlinedValue); -end; - -function Int64DynArrayToCSV(const Values: TInt64DynArray; - const Prefix: RawUTF8; const Suffix: RawUTF8; InlinedValue: boolean): RawUTF8; -begin - result := Int64DynArrayToCSV(pointer(Values),length(Values),Prefix,Suffix,InlinedValue); -end; - -function Int64ScanIndex(P: PInt64Array; Count: PtrInt; const Value: Int64): PtrInt; -begin - result := 0; - dec(Count,8); - if P<>nil then begin - repeat - if result>Count then - break; - if P^[result]<>Value then - if P^[result+1]<>Value then - if P^[result+2]<>Value then - if P^[result+3]<>Value then - if P^[result+4]<>Value then - if P^[result+5]<>Value then - if P^[result+6]<>Value then - if P^[result+7]<>Value then begin - inc(result,8); - continue; - end else - inc(result,7) else - inc(result,6) else - inc(result,5) else - inc(result,4) else - inc(result,3) else - inc(result,2) else - inc(result); - exit; - until false; - inc(Count,8); - repeat - if result>=Count then - break; - if P^[result]=Value then - exit else - inc(result); - until false; - end; - result := -1; -end; - -function QWordScanIndex(P: PQWordArray; Count: PtrInt; const Value: QWord): PtrInt; -begin - result := Int64ScanIndex(pointer(P),Count,Value); // this is the very same code -end; - -function PtrUIntScan(P: PPtrUIntArray; Count: PtrInt; Value: PtrUInt): pointer; -{$ifdef HASINLINE} -begin - result := {$ifdef CPU64}Int64Scan{$else}IntegerScan{$endif}(pointer(P),Count,Value); -end; -{$else} -asm - jmp IntegerScan -end; -{$endif HASINLINE} - -function PtrUIntScanExists(P: PPtrUIntArray; Count: PtrInt; Value: PtrUInt): boolean; -{$ifdef HASINLINE} -begin - result := {$ifdef CPU64}Int64ScanExists{$else}IntegerScanExists{$endif}(pointer(P),Count,Value); -end; -{$else} -asm - jmp IntegerScanExists; -end; -{$endif HASINLINE} - -function PtrUIntScanIndex(P: PPtrUIntArray; Count: PtrInt; Value: PtrUInt): PtrInt; -{$ifdef HASINLINE} -begin - result := {$ifdef CPU64}Int64ScanIndex{$else}IntegerScanIndex{$endif}(pointer(P),Count,Value); -end; -{$else} -asm // identical to IntegerScanIndex() asm stub - push eax - call IntegerScan - pop edx - test eax, eax - jnz @e - dec eax // returns -1 - ret -@e: sub eax, edx - shr eax, 2 -end; -{$endif HASINLINE} - -function ByteScanIndex(P: PByteArray; Count: PtrInt; Value: Byte): PtrInt; -begin -{$ifdef FPC} - result := IndexByte(P^,Count,Value); // will use fast FPC SSE version -{$else} - result := 0; - if P<>nil then - repeat - if result>=Count then - break; - if P^[result]=Value then - exit else - inc(result); - until false; - result := -1; -{$endif FPC} -end; - -function WordScanIndex(P: PWordArray; Count: PtrInt; Value: word): PtrInt; -begin -{$ifdef FPC} - result := IndexWord(P^,Count,Value); // will use fast FPC SSE version -{$else} - result := 0; - if P<>nil then - repeat - if result>=Count then - break; - if P^[result]=Value then - exit else - inc(result); - until false; - result := -1; -{$endif FPC} -end; - -function AnyScanIndex(P,Elem: pointer; Count,ElemSize: PtrInt): PtrInt; -begin - case ElemSize of - // optimized versions for arrays of byte,word,integer,Int64,Currency,Double - 1: result := ByteScanIndex(P,Count,PByte(Elem)^); - 2: result := WordScanIndex(P,Count,PWord(Elem)^); - 4: result := IntegerScanIndex(P,Count,PInteger(Elem)^); - 8: result := Int64ScanIndex(P,Count,PInt64(Elem)^); - // small ElemSize version (=0; - 2: result := WordScanIndex(P,Count,PInteger(Elem)^)>=0; - 4: result := IntegerScanExists(P,Count,PInteger(Elem)^); - 8: result := Int64ScanExists(P,Count,PInt64(Elem)^); - // small ElemSize version (0 then - repeat - if CompareMemSmall(P,Elem,ElemSize) then - exit; - inc(PByte(P),ElemSize); - dec(Count); - until Count=0; - result := false; - end; - else begin // generic binary comparison (fast with leading 64-bit comparison) - result := true; - if Count>0 then - repeat - if (PInt64(P)^=PInt64(Elem)^) and - CompareMemSmall(PAnsiChar(P)+8,PAnsiChar(Elem)+8,ElemSize-8) then - exit; - inc(PByte(P),ElemSize); - dec(Count); - until Count=0; - result := false; - end; - end; -end; - - -procedure QuickSortInteger(ID: PIntegerArray; L,R: PtrInt); -var I, J, P: PtrInt; - tmp: integer; -begin - if L=tmp; - if ID[J]>tmp then repeat dec(J) until ID[J]<=tmp; - if I <= J then begin - tmp := ID[J]; ID[J] := ID[I]; ID[I] := tmp; - if P = I then P := J else if P = J then P := I; - inc(I); dec(J); - end; - until I > J; - if J - L < R - I then begin // use recursion only for smaller range - if L < J then - QuickSortInteger(ID, L, J); - L := I; - end else begin - if I < R then - QuickSortInteger(ID, I, R); - R := J; - end; - until L >= R; -end; - -procedure QuickSortInteger(var ID: TIntegerDynArray); -begin - QuickSortInteger(pointer(ID),0,high(ID)); -end; - -procedure QuickSortInteger(ID,CoValues: PIntegerArray; L,R: PtrInt); -var I, J, P: PtrInt; - tmp: integer; -begin - if L=tmp; - if ID[J]>tmp then repeat dec(J) until ID[J]<=tmp; - if I <= J then begin - tmp := ID[J]; ID[J] := ID[I]; ID[I] := tmp; - tmp := CoValues[J]; CoValues[J] := CoValues[I]; CoValues[I] := tmp; - if P = I then P := J else if P = J then P := I; - inc(I); dec(J); - end; - until I > J; - if J - L < R - I then begin // use recursion only for smaller range - if L < J then - QuickSortInteger(ID, CoValues, L, J); - L := I; - end else begin - if I < R then - QuickSortInteger(ID, CoValues, I, R); - R := J; - end; - until L >= R; -end; - -procedure QuickSortWord(ID: PWordArray; L, R: PtrInt); -var I, J, P: PtrInt; - tmp: word; -begin - if L=tmp; - if ID[J]>tmp then repeat dec(J) until ID[J]<=tmp; - if I <= J then begin - tmp := ID[J]; ID[J] := ID[I]; ID[I] := tmp; - if P = I then P := J else if P = J then P := I; - inc(I); dec(J); - end; - until I > J; - if J - L < R - I then begin // use recursion only for smaller range - if L < J then - QuickSortWord(ID, L, J); - L := I; - end else begin - if I < R then - QuickSortWord(ID, I, R); - R := J; - end; - until L >= R; -end; - -procedure QuickSortInt64(ID: PInt64Array; L, R: PtrInt); -var I, J, P: PtrInt; - tmp: Int64; -begin - if L=tmp; - if ID[J]>tmp then repeat dec(J) until ID[J]<=tmp; - {$else} - while ID[I]ID[P] do dec(J); - {$endif} - if I <= J then begin - tmp := ID[J]; ID[J] := ID[I]; ID[I] := tmp; - if P = I then P := J else if P = J then P := I; - inc(I); dec(J); - end; - until I > J; - if J - L < R - I then begin // use recursion only for smaller range - if L < J then - QuickSortInt64(ID, L, J); - L := I; - end else begin - if I < R then - QuickSortInt64(ID, I, R); - R := J; - end; - until L >= R; -end; - -procedure QuickSortQWord(ID: PQWordArray; L, R: PtrInt); -var I, J, P: PtrInt; - tmp: QWord; -begin - if L0 do dec(J); - {$else} - tmp := ID[P]; - if ID[I]=tmp; - if ID[J]>tmp then repeat dec(J) until ID[J]<=tmp; - {$endif} - if I <= J then begin - tmp := ID[J]; ID[J] := ID[I]; ID[I] := tmp; - if P = I then P := J else if P = J then P := I; - inc(I); dec(J); - end; - until I > J; - if J - L < R - I then begin // use recursion only for smaller range - if L < J then - QuickSortQWord(ID, L, J); - L := I; - end else begin - if I < R then - QuickSortQWord(ID, I, R); - R := J; - end; - until L >= R; -end; - -procedure QuickSortInt64(ID,CoValues: PInt64Array; L, R: PtrInt); -var I, J, P: PtrInt; - tmp: Int64; -begin - if L=tmp; - if ID[J]>tmp then repeat dec(J) until ID[J]<=tmp; - {$else} - while ID[I]ID[P] do dec(J); - {$endif} - if I <= J then begin - tmp := ID[J]; ID[J] := ID[I]; ID[I] := tmp; - tmp := CoValues[J]; CoValues[J] := CoValues[I]; CoValues[I] := tmp; - if P = I then P := J else if P = J then P := I; - inc(I); dec(J); - end; - until I > J; - if J - L < R - I then begin // use recursion only for smaller range - if L < J then - QuickSortInt64(ID, CoValues, L, J); - L := I; - end else begin - if I < R then - QuickSortInt64(ID, CoValues, I, R); - R := J; - end; - until L >= R; -end; - -procedure QuickSortPtrInt(P: PPtrIntArray; L, R: PtrInt); -begin - {$ifdef CPU64} - QuickSortInt64(PInt64Array(P),L,R); - {$else} - QuickSortInteger(PIntegerArray(P),L,R); - {$endif} -end; - -function FastFindPtrIntSorted(P: PPtrIntArray; R: PtrInt; Value: PtrInt): PtrInt; -begin - {$ifdef CPU64} - result := FastFindInt64Sorted(PInt64Array(P),R,Value); - {$else} - result := FastFindIntegerSorted(PIntegerArray(P),R,Value); - {$endif} -end; - -procedure QuickSortPointer(P: PPointerArray; L, R: PtrInt); -begin - {$ifdef CPU64} - QuickSortInt64(PInt64Array(P),L,R); - {$else} - QuickSortInteger(PIntegerArray(P),L,R); - {$endif} -end; - -function FastFindPointerSorted(P: PPointerArray; R: PtrInt; Value: pointer): PtrInt; -begin - {$ifdef CPU64} - result := FastFindInt64Sorted(PInt64Array(P),R,Int64(Value)); - {$else} - result := FastFindIntegerSorted(PIntegerArray(P),R,integer(Value)); - {$endif} -end; - -procedure NotifySortedIntegerChanges(old, new: PIntegerArray; oldn, newn: PtrInt; - const added, deleted: TOnNotifySortedIntegerChange; const sender); -var o, n: PtrInt; -begin - o := 0; - n := 0; - repeat - while (n=newn) or (old[o]=oldn) or (new[n]=oldn) and (n>=newn); -end; - -procedure CopyAndSortInteger(Values: PIntegerArray; ValuesCount: integer; - var Dest: TIntegerDynArray); -begin - if ValuesCount>length(Dest) then - SetLength(Dest,ValuesCount); - MoveFast(Values^[0],Dest[0],ValuesCount*SizeOf(Integer)); - QuickSortInteger(pointer(Dest),0,ValuesCount-1); -end; - -procedure CopyAndSortInt64(Values: PInt64Array; ValuesCount: integer; - var Dest: TInt64DynArray); -begin - if ValuesCount>length(Dest) then - SetLength(Dest,ValuesCount); - MoveFast(Values^[0],Dest[0],ValuesCount*SizeOf(Int64)); - QuickSortInt64(pointer(Dest),0,ValuesCount-1); -end; - -function FastFindIntegerSorted(P: PIntegerArray; R: PtrInt; Value: integer): PtrInt; -{$ifdef CPUX64} // P=rcx/rdi R=rdx/rsi Value=r8d/edx -{$ifdef FPC} assembler; nostackframe; asm {$else} asm .noframe {$endif} - xor r9, r9 // r9=L rax=result - test R, R - jl @ko - lea rax, [r9 + R] -{$ifdef FPC} align 8 {$else} .align 8 {$endif} -@s: shr rax, 1 - lea r10, qword ptr[rax - 1] // efficient branchless binary search - lea r11, qword ptr[rax + 1] - cmp Value, dword ptr[P + rax * 4] - je @ok - cmovl R, r10 - cmovg r9, r11 - lea rax, [r9 + R] - cmp r9, R - jle @s -@ko: or rax, -1 -@ok: -end; -{$else} -var L: PtrInt; - cmp: integer; -begin - L := 0; - if 0<=R then - repeat - result := (L + R) shr 1; - cmp := P^[result]-Value; - if cmp=0 then - exit; - if cmp<0 then begin - L := result+1; - if L<=R then - continue; - break; - end; - R := result-1; - if L<=R then - continue; - break; - until false; - result := -1 -end; -{$endif CPUX64} - - -function FastFindIntegerSorted(const Values: TIntegerDynArray; Value: integer): PtrInt; -begin - result := FastFindIntegerSorted(pointer(Values),length(Values)-1,Value); -end; - -function FastFindInt64Sorted(P: PInt64Array; R: PtrInt; const Value: Int64): PtrInt; -{$ifdef CPUX64} // P=rcx/rdi R=rdx/rsi Value=r8d/edx -{$ifdef FPC} assembler; nostackframe; asm {$else} asm .noframe {$endif} - xor r9, r9 // r9=L rax=result - test R, R - jl @ko - lea rax, [r9 + R] -{$ifdef FPC} align 8 {$else} .align 8 {$endif} -@s: shr rax, 1 - lea r10, qword ptr[rax - 1] // efficient branchless binary search - lea r11, qword ptr[rax + 1] - cmp Value, qword ptr[P + rax * 8] - je @ok - cmovl R, r10 - cmovg r9, r11 - lea rax, [r9 + R] - cmp r9, R - jle @s -@ko: or rax, -1 -@ok: -end; -{$else} -var L: PtrInt; - {$ifdef CPUX86} - cmp: Integer; - {$endif} -begin - L := 0; - if 0<=R then - repeat - result := (L + R) shr 1; - {$ifndef CPUX86} - if P^[result]=Value then - exit else - if P^[result] R; - while (i>=0) and (P^[i]>=Value) do dec(i); - result := i+1; // return the index where to insert - end; -end; - -function AddSortedInteger(var Values: TIntegerDynArray; var ValuesCount: integer; - Value: integer; CoValues: PIntegerDynArray): PtrInt; -begin - result := FastLocateIntegerSorted(pointer(Values),ValuesCount-1,Value); - if result>=0 then // if Value exists -> fails - result := InsertInteger(Values,ValuesCount,Value,result,CoValues); -end; - -function AddSortedInteger(var Values: TIntegerDynArray; - Value: integer; CoValues: PIntegerDynArray): PtrInt; -var ValuesCount: integer; -begin - ValuesCount := length(Values); - result := FastLocateIntegerSorted(pointer(Values),ValuesCount-1,Value); - if result>=0 then begin // if Value exists -> fails - SetLength(Values,ValuesCount+1); // manual size increase - result := InsertInteger(Values,ValuesCount,Value,result,CoValues); - end; -end; - -function TSortedIntegerArray.Add(aValue: Integer): PtrInt; -begin - result := Count; // optimistic check of perfectly increasing aValue - if (result>0) and (aValue<=Values[result-1]) then - result := FastLocateIntegerSorted(pointer(Values),result-1,aValue); - if result<0 then // aValue already exists in Values[] -> fails - exit; - if Count=length(Values) then - SetLength(Values,NextGrow(Count)); - if resultnil then - SetLength(CoValues^,n); - end; - n := ValuesCount; - if PtrUInt(result)nil then - MoveFast(CoValues^[result],CoValues^[result+1],n); - end else - result := n; - Values[result] := Value; - inc(ValuesCount); -end; - -function TIntegerDynArrayFrom(const Values: array of integer): TIntegerDynArray; -var i: PtrInt; -begin - Finalize(result); - SetLength(result,length(Values)); - for i := 0 to high(Values) do - result[i] := Values[i]; -end; - -function TIntegerDynArrayFrom64(const Values: TInt64DynArray; - raiseExceptionOnOverflow: boolean): TIntegerDynArray; -var i: PtrInt; -const MinInt = -MaxInt-1; -begin - Finalize(result); - SetLength(result,length(Values)); - for i := 0 to length(Values)-1 do - if Values[i]>MaxInt then - if raiseExceptionOnOverflow then - raise ESynException.CreateUTF8('TIntegerDynArrayFrom64: Values[%]=%>%', - [i,Values[i],MaxInt]) else - result[i] := MaxInt else - if Values[i]ord(' ') then - break; - inc(P); - c := byte(P^); - until false; - if c=ord('-') then begin - minus := true; - repeat inc(P); c := byte(P^); until c<>ord(' '); - end else begin - minus := false; - if c=ord('+') then - repeat inc(P); c := byte(P^); until c<>ord(' '); - end; - dec(c,48); - if c>9 then - exit; - result := c; - repeat - inc(P); - c := byte(P^); - dec(c,48); - if c>9 then - break; - result := result*10+PtrInt(c); - until false; - if minus then - result := -result; -end; - -function GetInteger(P,PEnd: PUTF8Char): PtrInt; -var c: byte; - minus: boolean; -begin - result := 0; - if (P=nil) or (P>=PEnd) then - exit; - c := byte(P^); - repeat - if c=0 then - exit; - if c>ord(' ') then - break; - inc(P); - if P=PEnd then - exit; - c := byte(P^); - until false; - if c=ord('-') then begin - minus := true; - repeat inc(P); if P=PEnd then exit; c := byte(P^); until c<>ord(' '); - end else begin - minus := false; - if c=ord('+') then - repeat inc(P); if P=PEnd then exit; c := byte(P^); until c<>ord(' '); - end; - dec(c,48); - if c>9 then - exit; - result := c; - repeat - inc(P); - if P=PEnd then - break; - c := byte(P^); - dec(c,48); - if c>9 then - break; - result := result*10+PtrInt(c); - until false; - if minus then - result := -result; -end; - -function GetInteger(P: PUTF8Char; var err: integer): PtrInt; -var c: byte; - minus: boolean; -begin - result := 0; - err := 1; // don't return the exact index, just 1 as error flag - if P=nil then - exit; - c := byte(P^); - repeat - if c=0 then - exit; - if c>ord(' ') then - break; - inc(P); - c := byte(P^); - until false; - if c=ord('-') then begin - minus := true; - repeat inc(P); c := byte(P^); until c<>ord(' '); - end else begin - minus := false; - if c=ord('+') then - repeat inc(P); c := byte(P^); until c<>ord(' '); - end; - dec(c,48); - if c>9 then - exit; - result := c; - repeat - inc(P); - c := byte(P^); - dec(c,48); - if c<=9 then - result := result*10+PtrInt(c) else - if c<>256-48 then - exit else - break; - until false; - err := 0; // success - if minus then - result := -result; -end; - -function GetIntegerDef(P: PUTF8Char; Default: PtrInt): PtrInt; -var err: integer; -begin - result := GetInteger(P,err); - if err<>0 then - result := Default; -end; - -function UTF8ToInteger(const value: RawUTF8; Default: PtrInt=0): PtrInt; -var err: integer; -begin - result := GetInteger(pointer(value),err); - if err<>0 then - result := Default; -end; - -function UTF8ToInteger(const value: RawUTF8; Min,max: PtrInt; Default: PtrInt=0): PtrInt; -var err: integer; -begin - result := GetInteger(pointer(value),err); - if (err<>0) or (resultmax) then - result := Default; -end; - -function ToInteger(const text: RawUTF8; out value: integer): boolean; -var err: integer; -begin - value := GetInteger(pointer(text),err); - result := err=0; -end; - -function ToCardinal(const text: RawUTF8; out value: cardinal; minimal: cardinal): boolean; -begin - value := GetCardinalDef(pointer(text),cardinal(-1)); - result := (value<>cardinal(-1)) and (value>=minimal); -end; - -function ToInt64(const text: RawUTF8; out value: Int64): boolean; -var err: integer; -begin - value := GetInt64(pointer(text),err); - result := err=0; -end; - -function ToDouble(const text: RawUTF8; out value: double): boolean; -var err: integer; -begin - value := GetExtended(pointer(text),err); - result := err=0; -end; - -function UTF8ToInt64(const text: RawUTF8; const default: Int64): Int64; -var err: integer; -begin - result := GetInt64(pointer(text),err); - if err<>0 then - result := default; -end; - -function GetBoolean(P: PUTF8Char): boolean; -begin - if P<>nil then - case PInteger(P)^ of - TRUE_LOW: result := true; - FALSE_LOW: result := false; - else result := PWord(P)^<>ord('0'); - end else - result := false; -end; - -function GetCardinalDef(P: PUTF8Char; Default: PtrUInt): PtrUInt; -var c: byte; -begin - result := Default; - if P=nil then - exit; - c := byte(P^); - repeat - if c=0 then - exit; - if c>ord(' ') then - break; - inc(P); - c := byte(P^); - until false; - dec(c,48); - if c>9 then - exit; - result := c; - repeat - inc(P); - c := byte(P^)-48; - if c>9 then - break; - result := result*10+PtrUInt(c); - until false; -end; - -function GetCardinal(P: PUTF8Char): PtrUInt; -var c: byte; -begin - result := 0; - if P=nil then - exit; - c := byte(P^); - repeat - if c=0 then - exit; - if c>ord(' ') then - break; - inc(P); - c := byte(P^); - until false; - dec(c,48); - if c>9 then - exit; - result := c; - repeat - inc(P); - c := byte(P^); - dec(c,48); - if c>9 then - break; - result := result*10+PtrUInt(c); - until false; -end; - -function GetCardinalW(P: PWideChar): PtrUInt; -var c: PtrUInt; -begin - result := 0; - if P=nil then - exit; - c := ord(P^); - repeat - if c=0 then - exit; - if c>ord(' ') then - break; - inc(P); - c := ord(P^); - until false; - dec(c,48); - if c>9 then - exit; - result := c; - repeat - inc(P); - c := ord(P^); - dec(c,48); - if c>9 then - break; - result := result*10+c; - until false; -end; - -{$ifdef CPU64} -procedure SetInt64(P: PUTF8Char; var result: Int64); -begin // PtrInt is already int64 -> call PtrInt version - result := GetInteger(P); -end; -{$else} -procedure SetInt64(P: PUTF8Char; var result: Int64); -var c: cardinal; - minus: boolean; -begin - result := 0; - if P=nil then - exit; - while (P^<=' ') and (P^<>#0) do inc(P); - if P^='-' then begin - minus := true; - repeat inc(P) until P^<>' '; - end else begin - minus := false; - if P^='+' then - repeat inc(P) until P^<>' '; - end; - c := byte(P^)-48; - if c>9 then - exit; - PCardinal(@result)^ := c; - inc(P); - repeat // fast 32-bit loop - c := byte(P^)-48; - if c>9 then - break else - PCardinal(@result)^ := PCardinal(@result)^*10+c; - inc(P); - if PCardinal(@result)^>=high(cardinal)div 10 then begin - repeat // 64-bit loop - c := byte(P^)-48; - if c>9 then - break; - result := result shl 3+result+result; // fast result := result*10 - inc(result,c); - inc(P); - until false; - break; - end; - until false; - if minus then - result := -result; -end; -{$endif} - -{$ifdef CPU64} -procedure SetQWord(P: PUTF8Char; var result: QWord); -begin // PtrUInt is already QWord -> call PtrUInt version - result := GetCardinal(P); -end; -{$else} -procedure SetQWord(P: PUTF8Char; var result: QWord); -var c: cardinal; -begin - result := 0; - if P=nil then - exit; - while (P^<=' ') and (P^<>#0) do inc(P); - if P^='+' then - repeat inc(P) until P^<>' '; - c := byte(P^)-48; - if c>9 then - exit; - PCardinal(@result)^ := c; - inc(P); - repeat // fast 32-bit loop - c := byte(P^)-48; - if c>9 then - break else - PCardinal(@result)^ := PCardinal(@result)^*10+c; - inc(P); - if PCardinal(@result)^>=high(cardinal)div 10 then begin - repeat // 64-bit loop - c := byte(P^)-48; - if c>9 then - break; - result := result shl 3+result+result; // fast result := result*10 - inc(result,c); - inc(P); - until false; - break; - end; - until false; -end; -{$endif} - -{$ifdef CPU64} -function GetInt64(P: PUTF8Char): Int64; -begin // PtrInt is already int64 -> call previous version - result := GetInteger(P); -end; -{$else} -function GetInt64(P: PUTF8Char): Int64; -begin - SetInt64(P,result); -end; -{$endif} - -function GetInt64Def(P: PUTF8Char; const Default: Int64): Int64; -var err: integer; -begin - result := GetInt64(P,err); - if err>0 then - result := Default; -end; - -{$ifdef CPU64} -function GetInt64(P: PUTF8Char; var err: integer): Int64; -begin // PtrInt is already int64 -> call previous version - result := GetInteger(P,err); -end; -{$else} -function GetInt64(P: PUTF8Char; var err: integer): Int64; -var c: cardinal; - minus: boolean; -begin - err := 0; - result := 0; - if P=nil then - exit; - while (P^<=' ') and (P^<>#0) do inc(P); - if P^='-' then begin - minus := true; - repeat inc(P) until P^<>' '; - end else begin - minus := false; - if P^='+' then - repeat inc(P) until P^<>' '; - end; - inc(err); - c := byte(P^)-48; - if c>9 then - exit; - PCardinal(@result)^ := c; - inc(P); - repeat // fast 32-bit loop - c := byte(P^); - if c<>0 then begin - dec(c,48); - inc(err); - if c>9 then - exit; - PCardinal(@result)^ := PCardinal(@result)^*10+c; - inc(P); - if PCardinal(@result)^>=high(cardinal)div 10 then begin - repeat // 64-bit loop - c := byte(P^); - if c=0 then begin - err := 0; // conversion success without error - break; - end; - dec(c,48); - inc(err); - if c>9 then - exit else - {$ifdef CPU32DELPHI} - result := result shl 3+result+result; - {$else} - result := result*10; - {$endif} - inc(result,c); - if result<0 then - exit; // overflow (>$7FFFFFFFFFFFFFFF) - inc(P); - until false; - break; - end; - end else begin - err := 0; // reached P^=#0 -> conversion success without error - break; - end; - until false; - if minus then - result := -result; -end; -{$endif} - -function GetQWord(P: PUTF8Char; var err: integer): QWord; -var c: PtrUInt; -begin - err := 1; // error - result := 0; - if P=nil then - exit; - while (P^<=' ') and (P^<>#0) do inc(P); - c := byte(P^)-48; - if c>9 then - exit; - {$ifdef CPU64} - result := c; - inc(P); - repeat - c := byte(P^); - if c=0 then - break; - dec(c,48); - if c>9 then - exit; - result := result*10+c; - inc(P); - until false; - err := 0; // success - {$else} - PByte(@result)^ := c; - inc(P); - repeat // fast 32-bit loop - c := byte(P^); - if c<>0 then begin - dec(c,48); - inc(err); - if c>9 then - exit; - PCardinal(@result)^ := PCardinal(@result)^*10+c; - inc(P); - if PCardinal(@result)^>=high(cardinal)div 10 then begin - repeat // 64-bit loop - c := byte(P^); - if c=0 then begin - err := 0; // conversion success without error - break; - end; - dec(c,48); - inc(err); - if c>9 then - exit else - {$ifdef CPU32DELPHI} - result := result shl 3+result+result; - {$else} - result := result*10; - {$endif} - inc(result,c); - inc(P); - until false; - break; - end; - end else begin - err := 0; // reached P^=#0 -> conversion success without error - break; - end; - until false; - {$endif CPU64} -end; - -function GetExtended(P: PUTF8Char): TSynExtended; -var err: integer; -begin - result := GetExtended(P,err); - if err<>0 then - result := 0; -end; - -const POW10: array[-31..33] of TSynExtended = ( - 1E-31,1E-30,1E-29,1E-28,1E-27,1E-26,1E-25,1E-24,1E-23,1E-22,1E-21,1E-20, - 1E-19,1E-18,1E-17,1E-16,1E-15,1E-14,1E-13,1E-12,1E-11,1E-10,1E-9,1E-8,1E-7, - 1E-6,1E-5,1E-4,1E-3,1E-2,1E-1,1E0,1E1,1E2,1E3,1E4,1E5,1E6,1E7,1E8,1E9,1E10, - 1E11,1E12,1E13,1E14,1E15,1E16,1E17,1E18,1E19,1E20,1E21,1E22,1E23,1E24,1E25, - 1E26,1E27,1E28,1E29,1E30,1E31,0,-1); - -function HugePower10(exponent: integer): TSynExtended; {$ifdef HASINLINE}inline;{$endif} -var e: TSynExtended; -begin - result := POW10[0]; - if exponent<0 then begin - e := POW10[-1]; - exponent := -exponent; - end else - e := POW10[1]; - repeat - while exponent and 1=0 do begin - exponent := exponent shr 1; - e := sqr(e); - end; - result := result*e; - dec(exponent); - until exponent=0; -end; - -function GetExtended(P: PUTF8Char; out err: integer): TSynExtended; -{$ifndef CPU32DELPHI} -var digit: byte; - frac, exp: PtrInt; - c: AnsiChar; - flags: set of (fNeg, fNegExp, fValid); - v: Int64; // allows 64-bit resolution for the digits -label e; -begin - byte(flags) := 0; - v := 0; - frac := 0; - if P=nil then - goto e; - c := P^; - if c=' ' then - repeat - inc(P); - c := P^; - until c<>' '; // trailing spaces - if c='+' then begin - inc(P); - c := P^; - end else - if c='-' then begin - inc(P); - c := P^; - include(flags,fNeg); - end; - digit := 18; // max Int64 resolution - repeat - inc(P); - if (c>='0') and (c<='9') then begin - if digit <> 0 then begin - dec(c,ord('0')); - {$ifdef CPU64} - v := v*10; - {$else} - v := v shl 3+v+v; - {$endif} - inc(v,byte(c)); - dec(digit); // over-required digits are just ignored - include(flags,fValid); - if frac<>0 then - dec(frac); - end else - if frac>=0 then - inc(frac); // handle #############00000 - c := P^; - continue; - end; - if c<>'.' then - break; - if frac>0 then - goto e; - dec(frac); - c := P^; - until false; - if frac<0 then - inc(frac); - if (c='E') or (c='e') then begin - exp := 0; - exclude(flags,fValid); - c := P^; - if c='+' then - inc(P) else - if c='-' then begin - inc(P); - include(flags,fNegExp); - end; - repeat - c := P^; - inc(P); - if (c<'0') or (c>'9') then - break; - dec(c,ord('0')); - exp := (exp*10)+byte(c); - include(flags,fValid); - until false; - if fNegExp in flags then - dec(frac,exp) else - inc(frac,exp); - end; - if (fValid in flags) and (c=#0) then - err := 0 else -e: err := 1; // return the (partial) value even if not ended with #0 - if (frac>=-31) and (frac<=31) then - result := POW10[frac] else - result := HugePower10(frac); - if fNeg in flags then - result := result*POW10[33]; // *-1 - result := result*v; -end; -{$else} -const Ten: double = 10.0; -asm // in: eax=text, edx=@err out: st(0)=result - push ebx // save used registers - push esi - push edi - mov esi, eax // string pointer - push eax // save for error condition - xor ebx, ebx - push eax // allocate local storage for loading fpu - test esi, esi - jz @nil // nil string -@trim: movzx ebx, byte ptr[esi] // strip leading spaces - inc esi - cmp bl, ' ' - je @trim - xor ecx, ecx // clear sign flag - fld qword[Ten] // load 10 into fpu - xor eax, eax // zero number of decimal places - fldz // zero result in fpu - cmp bl, '0' - jl @chksig // check for sign character -@dig1: xor edi, edi // zero exponent value -@digl: sub bl, '0' - cmp bl, 9 - ja @frac // non-digit - mov cl, 1 // set digit found flag - mov [esp], ebx // store for fpu use - fmul st(0), st(1) // multply by 10 - fiadd dword ptr[esp] // add next digit - movzx ebx, byte ptr[esi] // get next char - inc esi - test bl, bl // end reached? - jnz @digl // no,get next digit - jmp @finish // yes,finished -@chksig:cmp bl, '-' - je @minus - cmp bl, '+' - je @sigset -@gdig1: test bl, bl - jz @error // no digits found - jmp @dig1 -@minus: mov ch, 1 // set sign flag -@sigset:movzx ebx, byte ptr[esi] // get next char - inc esi - jmp @gdig1 -@frac: cmp bl, '.' - '0' - jne @exp // no decimal point - movzx ebx, byte ptr[esi] // get next char - test bl, bl - jz @dotend // string ends with '.' - inc esi -@fracl: sub bl, '0' - cmp bl, 9 - ja @exp // non-digit - mov [esp], ebx - dec eax // -(number of decimal places) - fmul st(0), st(1) // multply by 10 - fiadd dword ptr[esp] // add next digit - movzx ebx, byte ptr[esi] // get next char - inc esi - test bl, bl // end reached? - jnz @fracl // no, get next digit - jmp @finish // yes, finished (no exponent) -@dotend:test cl, cl // any digits found before '.'? - jnz @finish // yes, valid - jmp @error // no,invalid -@exp: or bl, $20 - cmp bl, 'e' - '0' - jne @error // not 'e' or 'e' - movzx ebx, byte ptr[esi] // get next char - inc esi - mov cl, 0 // clear exponent sign flag - cmp bl, '-' - je @minexp - cmp bl, '+' - je @expset - jmp @expl -@minexp:mov cl, 1 // set exponent sign flag -@expset:movzx ebx, byte ptr[esi] // get next char - inc esi -@expl: sub bl, '0' - cmp bl, 9 - ja @error // non-digit - lea edi, [edi + edi * 4]// multiply by 10 - add edi, edi - add edi, ebx // add next digit - movzx ebx, byte ptr[esi] // get next char - inc esi - test bl, bl // end reached? - jnz @expl // no, get next digit -@endexp:test cl, cl // positive exponent? - jz @finish // yes, keep exponent value - neg edi // no, negate exponent value -@finish:add eax, edi // exponent value - number of decimal places - mov [edx], ebx // result code = 0 - jz @pow // no call to _pow10 needed - mov edi, ecx // save decimal sign flag - call System.@Pow10 // raise to power of 10 - mov ecx, edi // restore decimal sign flag -@pow: test ch, ch // decimal sign flag set? - jnz @negate // yes, negate value -@ok: add esp, 8 // dump local storage and string pointer -@exit: ffree st(1) // remove ten value from fpu - pop edi // restore used registers - pop esi - pop ebx - ret // finished -@negate:fchs // negate result in fpu - jmp @ok -@nil: inc esi // force result code = 1 - fldz // result value = 0 -@error: pop ebx // dump local storage - pop eax // string pointer - sub esi, eax // error offset - mov [edx], esi // set result code - test ch, ch // decimal sign flag set? - jz @exit // no,exit - fchs // yes. negate result in fpu - jmp @exit // exit setting result code -end; -{$endif CPU32DELPHI} - -function FloatStrCopy(s, d: PUTF8Char): PUTF8Char; -var c: AnsiChar; -begin - while s^=' ' do inc(s); - c := s^; - if (c='+') or (c='-') then begin - inc(s); - d^ := c; - inc(d); - c := s^; - end; - if c='.' then begin - PCardinal(d)^ := ord('0')+ord('.')shl 8; // '.5' -> '0.5' - inc(d,2); - inc(s); - c := s^; - end; - if (c>='0') and (c<='9') then - repeat - inc(s); - d^ := c; - inc(d); - c := s^; - if ((c>='0') and (c<='9')) or (c='.') then - continue; - if (c<>'e') and (c<>'E') then - break; - inc(s); - d^ := c; // 1.23e120 or 1.23e-45 - inc(d); - c := s^; - if c='-' then begin - inc(s); - d^ := c; - inc(d); - c := s^; - end; - while (c>='0') and (c<='9') do begin - inc(s); - d^ := c; - inc(d); - c := s^; - end; - break; - until false; - result := d; -end; - -function GetUTF8Char(P: PUTF8Char): cardinal; -begin - if P<>nil then begin - result := ord(P[0]); - if result and $80<>0 then begin - result := GetHighUTF8UCS4(P); - if result>$ffff then - result := ord('?'); // do not handle surrogates now - end; - end else - result := PtrUInt(P); -end; - -function NextUTF8UCS4(var P: PUTF8Char): cardinal; -begin - if P<>nil then begin - result := byte(P[0]); - if result<=127 then - inc(P) else begin - if result and $20=0 then begin - result := result shl 6+byte(P[1])-$3080; // fast direct process $0..$7ff - inc(P,2); - end else - result := GetHighUTF8UCS4(P); // handle even surrogates - end; - end else - result := 0; -end; - -function ContainsUTF8(p, up: PUTF8Char): boolean; -var u: PByte; -begin - if (p<>nil) and (up<>nil) and (up^<>#0) then begin - result := true; - repeat - u := pointer(up); - repeat - if GetNextUTF8Upper(p)<>u^ then - break else - inc(u); - if u^=0 then - exit; // up^ was found inside p^ - until false; - p := FindNextUTF8WordBegin(p); - until p=nil; - end; - result := false; -end; - -function IdemFileExt(p: PUTF8Char; extup: PAnsiChar; sepChar: AnsiChar): Boolean; -var ext: PUTF8Char; -begin - if (p<>nil) and (extup<>nil) then begin - ext := nil; - repeat - if p^=sepChar then - ext := p; // get last '.' position from p into ext - inc(p); - until p^=#0; - result := IdemPChar(ext,extup); - end else - result := false; -end; - -function IdemFileExts(p: PUTF8Char; const extup: array of PAnsiChar; - sepChar: AnsiChar): integer; -var ext: PUTF8Char; -begin - result := -1; - if (p<>nil) and (high(extup)>0) then begin - ext := nil; - repeat - if p^=sepChar then - ext := p; // get last '.' position from p into ext - inc(p); - until p^=#0; - if ext<>nil then - result := IdemPCharArray(ext,extup); - end; -end; - -function IdemPCharWithoutWhiteSpace(p: PUTF8Char; up: PAnsiChar): boolean; -begin - result := False; - if p=nil then - exit; - if up<>nil then - while up^<>#0 do begin - while p^<=' ' do // trim white space - if p^=#0 then - exit else - inc(p); - if up^<>NormToUpperAnsi7[p^] then - exit; - inc(up); - inc(p); - end; - result := true; -end; - -function IdemPCharArray(p: PUTF8Char; const upArray: array of PAnsiChar): integer; -var w: word; - tab: {$ifdef CPUX86NOTPIC}TNormTableByte absolute NormToUpperAnsi7{$else}PNormTableByte{$endif}; - up: ^PAnsiChar; -begin - if p<>nil then begin - {$ifndef CPUX86NOTPIC}tab := @NormToUpperAnsi7;{$endif} // faster on PIC and x86_64 - w := tab[ord(p[0])]+tab[ord(p[1])]shl 8; - up := @upArray[0]; - for result := 0 to high(upArray) do - if (PWord(up^)^=w) and - {$ifdef CPUX86NOTPIC}IdemPChar({$else}IdemPChar2(pointer(tab),{$endif}p+2,up^+2) then - exit else - inc(up); - end; - result := -1; -end; - -function IdemPCharArray(p: PUTF8Char; const upArrayBy2Chars: RawUTF8): integer; -var w: word; -begin - if p<>nil then begin - w := NormToUpperAnsi7Byte[ord(p[0])]+NormToUpperAnsi7Byte[ord(p[1])]shl 8; - for result := 0 to pred(length(upArrayBy2Chars) shr 1) do - if PWordArray(upArrayBy2Chars)[result]=w then - exit; - end; - result := -1; -end; - -function IdemPCharU(p, up: PUTF8Char): boolean; -begin - result := false; - if (p=nil) or (up=nil) then - exit; - while up^<>#0 do begin - if GetNextUTF8Upper(p)<>ord(up^) then - exit; - inc(up); - end; - result := true; -end; - -function EndWith(const text, upText: RawUTF8): boolean; -var o: PtrInt; -begin - o := length(text)-length(upText); - result := (o>=0) and IdemPChar(PUTF8Char(pointer(text))+o,pointer(upText)); -end; - -function EndWithArray(const text: RawUTF8; const upArray: array of RawUTF8): integer; -var t,o: PtrInt; -begin - t := length(text); - if t>0 then - for result := 0 to high(upArray) do begin - o := t-length(UpArray[result]); - if (o>=0) and IdemPChar(PUTF8Char(pointer(text))+o,pointer(upArray[result])) then - exit; - end; - result := -1; -end; - -function UpperCopy255(dest: PAnsiChar; const source: RawUTF8): PAnsiChar; -begin - if source<>'' then - result := UpperCopy255Buf(dest,pointer(source),PStrLen(PtrUInt(source)-_STRLEN)^) else - result := dest; -end; - -function UpperCopy255BufPas(dest: PAnsiChar; source: PUTF8Char; sourceLen: PtrInt): PAnsiChar; -var i,c,d{$ifdef CPU64},_80,_61,_7b{$endif}: PtrUInt; -begin - if sourceLen>0 then begin - if sourceLen>248 then - sourceLen := 248; // avoid buffer overflow - // we allow to copy up to 3/7 more chars in Dest^ since its size is 255 - {$ifdef CPU64} // unbranched uppercase conversion of 8 chars blocks - _80 := PtrUInt($8080808080808080); // use registers for constants - _61 := $6161616161616161; - _7b := $7b7b7b7b7b7b7b7b; - for i := 0 to (sourceLen-1) shr 3 do begin - c := PPtrUIntArray(source)^[i]; - d := c or _80; - PPtrUIntArray(dest)^[i] := c-((d-PtrUInt(_61)) and not(d-_7b)) and - ((not c) and _80)shr 2; - end; - {$else} // unbranched uppercase conversion of 4 chars blocks - for i := 0 to (sourceLen-1) shr 2 do begin - c := PPtrUIntArray(source)^[i]; - d := c or PtrUInt($80808080); - PPtrUIntArray(dest)^[i] := c-((d-PtrUInt($61616161)) and not(d-PtrUInt($7b7b7b7b))) and - ((not c) and PtrUInt($80808080))shr 2; - end; - {$endif} - result := dest+sourceLen; // but we always return the exact size - end else - result := dest; -end; - -function UpperCopyWin255(dest: PWinAnsiChar; const source: RawUTF8): PWinAnsiChar; -var i, L: PtrInt; - tab: {$ifdef CPUX86NOTPIC}TNormTableByte absolute NormToUpperByte{$else}PNormTableByte{$endif}; -begin - if source='' then - result := dest else begin - L := PStrLen(PtrUInt(source)-_STRLEN)^; - if L>250 then - L := 250; // avoid buffer overflow - result := dest+L; - {$ifndef CPUX86NOTPIC}tab := @NormToUpperByte;{$endif} // faster on PIC and x86_64 - for i := 0 to L-1 do - dest[i] := AnsiChar(tab[PByteArray(source)[i]]); - end; -end; - -function UTF8UpperCopy(Dest, Source: PUTF8Char; SourceChars: Cardinal): PUTF8Char; -var c: cardinal; - endSource, endSourceBy4, up: PUTF8Char; - extra,i: PtrInt; -label By1, By4, set1; // ugly but faster -begin - if (Source<>nil) and (Dest<>nil) then begin - // first handle trailing 7 bit ASCII chars, by quad (Sha optimization) - endSource := Source+SourceChars; - endSourceBy4 := endSource-4; - up := @NormToUpper; - if (PtrUInt(Source) and 3=0) and (Source<=endSourceBy4) then - repeat - By4:c := PCardinal(Source)^; - if c and $80808080<>0 then - goto By1; // break on first non ASCII quad - inc(Source,4); - Dest[0] := up[ToByte(c)]; - Dest[1] := up[ToByte(c shr 8)]; - Dest[2] := up[ToByte(c shr 16)]; - Dest[3] := up[ToByte(c shr 24)]; - inc(Dest,4); - until Source>endSourceBy4; - // generic loop, handling one UCS4 char per iteration - if SourceendSource) then break; - for i := 0 to extra-1 do - c := c shl 6+byte(Source[i]); - with UTF8_EXTRA[extra] do begin - dec(c,offset); - if c0 - just copy UTF-8 input untouched - inc(Dest); - Dest^ := Source^; - inc(Source); - dec(extra); - if extra=0 then - goto Set1; - until false; - end; - until false; - end; - result := Dest; -end; - -function UTF8UpperCopy255(dest: PAnsiChar; const source: RawUTF8): PUTF8Char; -var L: integer; -begin - L := length(source); - if L>0 then begin - if L>250 then - L := 250; // avoid buffer overflow - result := UTF8UpperCopy(pointer(dest),pointer(source),L); - end else - result := pointer(dest); -end; - -function UpperCopy255W(dest: PAnsiChar; const source: SynUnicode): PAnsiChar; -var c: cardinal; - i,L: integer; -begin - L := length(source); - if L>0 then begin - if L>250 then - L := 250; // avoid buffer overflow - result := dest+L; - for i := 0 to L-1 do begin - c := PWordArray(source)[i]; - if c<255 then - dest[i] := AnsiChar(NormToUpperAnsi7Byte[c]) else - dest[i] := '?'; - end; - end else - result := dest; -end; - -function UpperCopy255W(dest: PAnsiChar; source: PWideChar; L: integer): PAnsiChar; -var c: cardinal; - i: integer; -begin - if L>0 then begin - if L>250 then - L := 250; // avoid buffer overflow - result := dest+L; - for i := 0 to L-1 do begin - c := PWordArray(source)[i]; - if c<255 then - dest[i] := AnsiChar(NormToUpperAnsi7Byte[c]) else - dest[i] := '?'; - end; - end else - result := dest; -end; - -function GetNextLine(source: PUTF8Char; out next: PUTF8Char; andtrim: boolean): RawUTF8; -var beg: PUTF8Char; -begin - if source=nil then begin - {$ifdef FPC}Finalize(result){$else}result := ''{$endif}; - next := source; - exit; - end; - if andtrim then // optional trim left - while source^ in [#9,' '] do inc(source); - beg := source; - repeat // just here to avoid a goto - if source[0]>#13 then - if source[1]>#13 then - if source[2]>#13 then - if source[3]>#13 then begin - inc(source,4); // fast process 4 chars per loop - continue; - end else - inc(source,3) else - inc(source,2) else - inc(source); - case source^ of - #0: next := nil; - #10: next := source+1; - #13: if source[1]=#10 then next := source+2 else next := source+1; - else begin - inc(source); - continue; - end; - end; - if andtrim then // optional trim right - while (source>beg) and (source[-1] in [#9,' ']) do dec(source); - FastSetString(result,beg,source-beg); - exit; - until false; -end; - -{$ifdef UNICODE} -function GetNextLineW(source: PWideChar; out next: PWideChar): string; -begin - next := source; - if source=nil then begin - result := ''; - exit; - end; - while not (cardinal(source^) in [0,10,13]) do inc(source); - SetString(result,PChar(next),source-next); - if source^=#13 then inc(source); - if source^=#10 then inc(source); - if source^=#0 then - next := nil else - next := source; -end; - -function FindIniNameValueW(P: PWideChar; UpperName: PUTF8Char): string; -var PBeg: PWideChar; - L: PtrInt; -begin - while (P<>nil) and (P^<>'[') do begin - PBeg := P; - while not (cardinal(P^) in [0,10,13]) do inc(P); - while cardinal(P^) in [10,13] do inc(P); - if P^=#0 then P := nil; - if PBeg^=' ' then repeat inc(PBeg) until PBeg^<>' '; // trim left ' ' - if IdemPCharW(PBeg,UpperName) then begin - inc(PBeg,StrLen(UpperName)); - L := 0; while PBeg[L]>=' ' do inc(L); // get line length - SetString(result,PBeg,L); - exit; - end; - end; - result := ''; -end; - -function FindIniEntryW(const Content: string; const Section, Name: RawUTF8): string; -var P: PWideChar; - UpperSection, UpperName: array[byte] of AnsiChar; - // possible GPF if length(Section/Name)>255, but should const in code -begin - result := ''; - P := pointer(Content); - if P=nil then exit; - // UpperName := UpperCase(Name)+'='; - PWord(UpperCopy255(UpperName,Name))^ := ord('='); - if Section='' then - // find the Name= entry before any [Section] - result := FindIniNameValueW(P,UpperName) else begin - // find the Name= entry in the specified [Section] - PWord(UpperCopy255(UpperSection,Section))^ := ord(']'); - if FindSectionFirstLineW(P,UpperSection) then - result := FindIniNameValueW(P,UpperName); - end; -end; -{$endif UNICODE} - -function IdemPCharAndGetNextItem(var source: PUTF8Char; const searchUp: RawUTF8; - var Item: RawUTF8; Sep: AnsiChar): boolean; -begin - if source=nil then - result := false else begin - result := IdemPChar(source,Pointer(searchUp)); - if result then begin - inc(source,Length(searchUp)); - GetNextItem(source,Sep,Item); - end; - end; -end; - -function GotoNextLine(source: PUTF8Char): PUTF8Char; -label - _z, _0, _1, _2, _3; // ugly but faster -var - c: AnsiChar; -begin - if source<>nil then - repeat - if source[0]<#13 then - goto _0 - else if source[1]<#13 then - goto _1 - else if source[2]<#13 then - goto _2 - else if source[3]<#13 then - goto _3 - else begin - inc(source, 4); - continue; - end; -_3: inc(source); -_2: inc(source); -_1: inc(source); -_0: c := source^; - if c=#13 then begin - if source[1]=#10 then begin - result := source+2; // most common case is text ending with #13#10 - exit; - end; - end else - if c=#0 then - goto _z else - if c<>#10 then begin - inc(source); - continue; // e.g. #9 - end; - result := source+1; - exit; - until false; -_z: result := nil; -end; - -function BufferLineLength(Text, TextEnd: PUTF8Char): PtrInt; -{$ifdef CPUX64} -{$ifdef FPC} nostackframe; assembler; asm {$else} asm .noframe {$endif} -{$ifdef MSWINDOWS} // Win64 ABI to System-V ABI - push rsi - push rdi - mov rdi, rcx - mov rsi, rdx -{$endif}mov r8, rsi - sub r8, rdi // rdi=Text, rsi=TextEnd, r8=TextLen - jz @fail - mov ecx, edi - movaps xmm0, [rip + @for10] - movaps xmm1, [rip + @for13] - and rdi, -16 // check first aligned 16 bytes - and ecx, 15 // lower cl 4 bits indicate misalignment - movaps xmm2, [rdi] - movaps xmm3, xmm2 - pcmpeqb xmm2, xmm0 - pcmpeqb xmm3, xmm1 - por xmm3, xmm2 - pmovmskb eax, xmm3 - shr eax, cl // shift out unaligned bytes - test eax, eax - jz @main - bsf eax, eax - add rax, rcx - add rax, rdi - sub rax, rsi - jae @fail // don't exceed TextEnd - add rax, r8 // rax = TextFound - TextEnd + (TextEnd - Text) = offset -{$ifdef MSWINDOWS} - pop rdi - pop rsi -{$endif}ret -@main: add rdi, 16 - sub rdi, rsi - jae @fail - jmp @by16 -{$ifdef FPC} align 16 {$else} .align 16 {$endif} -@for10: dq $0a0a0a0a0a0a0a0a - dq $0a0a0a0a0a0a0a0a -@for13: dq $0d0d0d0d0d0d0d0d - dq $0d0d0d0d0d0d0d0d -@by16: movaps xmm2, [rdi + rsi] // check 16 bytes per loop - movaps xmm3, xmm2 - pcmpeqb xmm2, xmm0 - pcmpeqb xmm3, xmm1 - por xmm3, xmm2 - pmovmskb eax, xmm3 - test eax, eax - jnz @found - add rdi, 16 - jnc @by16 -@fail: mov rax, r8 // returns TextLen if no CR/LF found -{$ifdef MSWINDOWS} - pop rdi - pop rsi -{$endif}ret -@found: bsf eax, eax - add rax, rdi - jc @fail - add rax, r8 -{$ifdef MSWINDOWS} - pop rdi - pop rsi -{$endif} -end; -{$else} -begin - result := PtrUInt(Text)-1; - repeat - inc(result); - if PtrUInt(result)13) or ((PByte(result)^<>10) and (PByte(result)^<>13)) then - continue; - break; - until false; - dec(result,PtrInt(Text)); // returns length -end; -{$endif CPUX64} - -function GetLineSize(P, PEnd: PUTF8Char): PtrUInt; -var c: byte; -begin - {$ifdef CPUX64} - if PEnd <> nil then begin - result := BufferLineLength(P,PEnd); // use branchless SSE2 on x86_64 - exit; - end; - result := PtrUInt(P)-1; - {$else} - result := PtrUInt(P)-1; - if PEnd<>nil then - repeat // inlined BufferLineLength() - inc(result); - if PtrUInt(result)13) or ((c<>10) and (c<>13)) then - continue; - end; - break; - until false else - {$endif CPUX64} - repeat // inlined BufferLineLength() ending at #0 for PEnd=nil - inc(result); - c := PByte(result)^; - if (c>13) or ((c<>0) and (c<>10) and (c<>13)) then - continue; - break; - until false; - dec(result,PtrUInt(P)); // returns length -end; - -function GetNextItem(var P: PUTF8Char; Sep: AnsiChar): RawUTF8; -begin - GetNextItem(P,Sep,result); -end; - -procedure GetNextItem(var P: PUTF8Char; Sep: AnsiChar; var result: RawUTF8); -var S: PUTF8Char; -begin - if P=nil then - result := '' else begin - S := P; - while (S^<>#0) and (S^<>Sep) do - inc(S); - FastSetString(result,P,S-P); - if S^<>#0 then - P := S+1 else - P := nil; - end; -end; - -procedure GetNextItem(var P: PUTF8Char; Sep, Quote: AnsiChar; var result: RawUTF8); -begin - if P=nil then - result := '' - else if P^=Quote then begin - P := UnQuoteSQLStringVar(P,result); - if P=nil then - result := '' - else if P^<>#0 then - inc(P); - end else - GetNextItem(P,Sep,result); -end; - -procedure GetNextItemTrimed(var P: PUTF8Char; Sep: AnsiChar; var result: RawUTF8); -var S,E: PUTF8Char; -begin - if (P=nil) or (Sep<=' ') then - result := '' else begin - while (P^<=' ') and (P^<>#0) do inc(P); // trim left - S := P; - while (S^<>#0) and (S^<>Sep) do - inc(S); - E := S; - while (E>P) and (E[-1] in [#1..' ']) do dec(E); // trim right - FastSetString(result,P,E-P); - if S^<>#0 then - P := S+1 else - P := nil; - end; -end; - -procedure GetNextItemTrimedCRLF(var P: PUTF8Char; var result: RawUTF8); -var S,E: PUTF8Char; -begin - if P=nil then - result := '' else begin - S := P; - while (S^<>#0) and (S^<>#10) do - inc(S); - E := S; - if (E>P) and (E[-1]=#13) then - dec(E); - FastSetString(result,P,E-P); - if S^<>#0 then - P := S+1 else - P := nil; - end; -end; - -function GetNextItemString(var P: PChar; Sep: Char): string; -// this function will compile into AnsiString or UnicodeString, depending -// of the compiler version -var S: PChar; -begin - if P=nil then - result := '' else begin - S := P; - while (S^<>#0) and (S^<>Sep) do - inc(S); - SetString(result,P,S-P); - if S^<>#0 then - P := S+1 else - P := nil; - end; -end; - -function GetNextStringLineToRawUnicode(var P: PChar): RawUnicode; -var S: PChar; -begin - if P=nil then - result := '' else begin - S := P; - while S^>=' ' do - inc(S); - result := StringToRawUnicode(P,S-P); - while (S^<>#0) and (S^<' ') do inc(S); // ignore e.g. #13 or #10 - if S^<>#0 then - P := S else - P := nil; - end; -end; - -procedure AppendCSVValues(const CSV: string; const Values: array of string; - var Result: string; const AppendBefore: string); -var Caption: string; - i, bool: integer; - P: PChar; - first: Boolean; -begin - P := pointer(CSV); - if P=nil then - exit; - first := True; - for i := 0 to high(Values) do begin - Caption := GetNextItemString(P); - if Values[i]<>'' then begin - if first then begin - Result := Result+#13#10; - first := false; - end else - Result := Result+AppendBefore; - bool := FindCSVIndex('0,-1',RawUTF8(Values[i])); - Result := Result+Caption+': '; - if bool<0 then - Result := Result+Values[i] else - Result := Result+GetCSVItemString(pointer(GetNextItemString(P)),bool,'/'); - end; - end; -end; - -procedure GetNextItemShortString(var P: PUTF8Char; out Dest: ShortString; Sep: AnsiChar); -var S: PUTF8Char; - len: PtrInt; -begin - S := P; - if S<>nil then begin - while (S^<=' ') and (S^<>#0) do inc(S); - P := S; - if (S^<>#0) and (S^<>Sep) then - repeat - inc(S); - until (S^=#0) or (S^=Sep); - len := S-P; - repeat - dec(len); - until (len<0) or not(P[len] in [#1..' ']); // trim right spaces - if len>=255 then - len := 255 else - inc(len); - Dest[0] := AnsiChar(len); - MoveSmall(P,@Dest[1],Len); - if S^<>#0 then - P := S+1 else - P := nil; - end else - Dest[0] := #0; -end; - -function GetNextItemHexDisplayToBin(var P: PUTF8Char; Bin: PByte; BinBytes: integer; - Sep: AnsiChar): boolean; -var S: PUTF8Char; - len: integer; -begin - result := false; - FillCharFast(Bin^,BinBytes,0); - if P=nil then - exit; - if P^=' ' then repeat inc(P) until P^<>' '; - S := P; - if Sep=#0 then - while S^>' ' do - inc(S) else - while (S^<>#0) and (S^<>Sep) do - inc(S); - len := S-P; - while (P[len-1] in [#1..' ']) and (len>0) do dec(len); // trim right spaces - if len<>BinBytes*2 then - exit; - if not HexDisplayToBin(PAnsiChar(P),Bin,BinBytes) then - FillCharFast(Bin^,BinBytes,0) else begin - if S^=#0 then - P := nil else - if Sep<>#0 then - P := S+1 else - P := S; - result := true; - end; -end; - -function GetNextItemCardinal(var P: PUTF8Char; Sep: AnsiChar): PtrUInt; -var c: PtrUInt; -begin - if P=nil then begin - result := 0; - exit; - end; - if P^=' ' then repeat inc(P) until P^<>' '; - c := byte(P^)-48; - if c>9 then - result := 0 else begin - result := c; - inc(P); - repeat - c := byte(P^)-48; - if c>9 then - break else - result := result*10+c; - inc(P); - until false; - end; - if Sep<>#0 then - while (P^<>#0) and (P^<>Sep) do // go to end of CSV item (ignore any decimal) - inc(P); - if P^=#0 then - P := nil else - if Sep<>#0 then - inc(P); -end; - -function GetNextItemCardinalStrict(var P: PUTF8Char): PtrUInt; -var c: PtrUInt; -begin - if P=nil then begin - result := 0; - exit; - end; - c := byte(P^)-48; - if c>9 then - result := 0 else begin - result := c; - inc(P); - repeat - c := byte(P^)-48; - if c>9 then - break else - result := result*10+c; - inc(P); - until false; - end; - if P^=#0 then - P := nil; -end; - -function CSVOfValue(const Value: RawUTF8; Count: cardinal; const Sep: RawUTF8): RawUTF8; -var ValueLen, SepLen: cardinal; - i: cardinal; - P: PAnsiChar; -begin // CSVOfValue('?',3)='?,?,?' - result := ''; - if Count=0 then - exit; - ValueLen := length(Value); - SepLen := Length(Sep); - FastSetString(result,nil,ValueLen*Count+SepLen*pred(Count)); - P := pointer(result); - i := 1; - repeat - if ValueLen>0 then begin - MoveSmall(Pointer(Value),P,ValueLen); - inc(P,ValueLen); - end; - if i=Count then - break; - if SepLen>0 then begin - MoveSmall(Pointer(Sep),P,SepLen); - inc(P,SepLen); - end; - inc(i); - until false; -// assert(P-pointer(result)=length(result)); -end; - -procedure SetBitCSV(var Bits; BitsCount: integer; var P: PUTF8Char); -var bit,last: cardinal; -begin - while P<>nil do begin - bit := GetNextItemCardinalStrict(P)-1; // '0' marks end of list - if bit>=cardinal(BitsCount) then - break; // avoid GPF - if (P=nil) or (P^=',') then - SetBitPtr(@Bits,bit) else - if P^='-' then begin - inc(P); - last := GetNextItemCardinalStrict(P)-1; // '0' marks end of list - if last>=Cardinal(BitsCount) then - exit; - while bit<=last do begin - SetBitPtr(@Bits,bit); - inc(bit); - end; - end; - if (P<>nil) and (P^=',') then - inc(P); - end; - if (P<>nil) and (P^=',') then - inc(P); -end; - -function GetBitCSV(const Bits; BitsCount: integer): RawUTF8; -var i,j: integer; -begin - result := ''; - i := 0; - while i9 then - result := 0 else begin - result := c; - inc(P); - repeat - c := word(P^)-48; - if c>9 then - break else - result := result*10+c; - inc(P); - until false; - end; - while (P^<>#0) and (P^<>Sep) do // go to end of CSV item (ignore any decimal) - inc(P); - if P^=#0 then - P := nil else - inc(P); -end; - -function GetNextItemInteger(var P: PUTF8Char; Sep: AnsiChar): PtrInt; -var minus: boolean; -begin - if P=nil then begin - result := 0; - exit; - end; - if P^=' ' then repeat inc(P) until P^<>' '; - if (P^ in ['+','-']) then begin - minus := P^='-'; - inc(P); - end else - minus := false; - result := PtrInt(GetNextItemCardinal(P,Sep)); - if minus then - result := -result; -end; - -function GetNextTChar64(var P: PUTF8Char; Sep: AnsiChar; out Buf: TChar64): PtrInt; -var S: PUTF8Char; - c: AnsiChar; -begin - result := 0; - S := P; - if S=nil then - exit; - if Sep=#0 then - repeat // store up to next whitespace - c := S[result]; - if c<=' ' then break; - Buf[result] := c; - inc(result); - if result>=SizeOf(Buf) then - exit; // avoid buffer overflow - until false else - repeat // store up to Sep or end of string - c := S[result]; - if (c=#0) or (c=Sep) then break; - Buf[result] := c; - inc(result); - if result>=SizeOf(Buf) then - exit; // avoid buffer overflow - until false; - Buf[result] := #0; // make asciiz - inc(S,result); // S[result]=Sep or #0 - if S^=#0 then - P := nil else - if Sep=#0 then - P := S else - P := S+1; -end; - -function GetNextItemInt64(var P: PUTF8Char; Sep: AnsiChar): Int64; -{$ifdef CPU64} -begin - result := GetNextItemInteger(P,Sep); // PtrInt=Int64 -end; -{$else} -var tmp: TChar64; -begin - if GetNextTChar64(P,Sep,tmp)>0 then - SetInt64(tmp,result) else - result := 0; -end; -{$endif} - -function GetNextItemQWord(var P: PUTF8Char; Sep: AnsiChar): QWord; -{$ifdef CPU64} -begin - result := GetNextItemCardinal(P,Sep); // PtrUInt=QWord -end; -{$else} -var tmp: TChar64; -begin - if GetNextTChar64(P,Sep,tmp)>0 then - SetQWord(tmp,result) else - result := 0; -end; -{$endif} - -function GetNextItemHexa(var P: PUTF8Char; Sep: AnsiChar): QWord; -var tmp: TChar64; - L: integer; -begin - result := 0; - L := GetNextTChar64(P,Sep,tmp); - if (L>0) and (L and 1=0) then - if not HexDisplayToBin(@tmp,@result,L shr 1) then - result := 0; -end; - -function GetNextItemDouble(var P: PUTF8Char; Sep: AnsiChar): double; -var tmp: TChar64; - err: integer; -begin - if GetNextTChar64(P,Sep,tmp)>0 then begin - result := GetExtended(tmp,err); - if err<>0 then - result := 0; - end else - result := 0; -end; - -function GetNextItemCurrency(var P: PUTF8Char; Sep: AnsiChar): currency; -begin - GetNextItemCurrency(P,result,Sep); -end; - -procedure GetNextItemCurrency(var P: PUTF8Char; out result: currency; Sep: AnsiChar); -var tmp: TChar64; -begin - if GetNextTChar64(P,Sep,tmp)>0 then - PInt64(@result)^ := StrToCurr64(tmp) else - result := 0; -end; - -function GetCSVItem(P: PUTF8Char; Index: PtrUInt; Sep: AnsiChar): RawUTF8; -var i: PtrUInt; -begin - if P=nil then - result := '' else - for i := 0 to Index do - GetNextItem(P,Sep,result); -end; - -function GetUnQuoteCSVItem(P: PUTF8Char; Index: PtrUInt; Sep, Quote: AnsiChar): RawUTF8; -var i: PtrUInt; -begin - if P=nil then - result := '' else - for i := 0 to Index do - GetNextItem(P,Sep,Quote,result); -end; - -function GetLastCSVItem(const CSV: RawUTF8; Sep: AnsiChar): RawUTF8; -var i: integer; -begin - for i := length(CSV) downto 1 do - if CSV[i]=Sep then begin - result := copy(CSV,i+1,maxInt); - exit; - end; - result := CSV; -end; - -function GetCSVItemString(P: PChar; Index: PtrUInt; Sep: Char): string; -var i: PtrUInt; -begin - if P=nil then - result := '' else - for i := 0 to Index do - result := GetNextItemString(P,Sep); -end; - -function FindCSVIndex(CSV: PUTF8Char; const Value: RawUTF8; Sep: AnsiChar; - CaseSensitive,TrimValue: boolean): integer; -var s: RawUTF8; -begin - result := 0; - while CSV<>nil do begin - GetNextItem(CSV,Sep,s); - if TrimValue then - s := trim(s); - if CaseSensitive then begin - if s=Value then - exit; - end else - if SameTextU(s,Value) then - exit; - inc(result); - end; - result := -1; // not found -end; - -procedure CSVToRawUTF8DynArray(CSV: PUTF8Char; var Result: TRawUTF8DynArray; - Sep: AnsiChar; TrimItems, AddVoidItems: boolean); -var s: RawUTF8; - n: integer; -begin - n := length(Result); - while CSV<>nil do begin - if TrimItems then - GetNextItemTrimed(CSV,Sep,s) else - GetNextItem(CSV,Sep,s); - if (s<>'') or AddVoidItems then - AddRawUTF8(Result,n,s); - end; - if n<>length(Result) then - SetLength(Result,n); -end; - -procedure CSVToRawUTF8DynArray(const CSV,Sep,SepEnd: RawUTF8; var Result: TRawUTF8DynArray); -var offs,i: integer; -begin - offs := 1; - while offs<=length(CSV) do begin - SetLength(Result,length(Result)+1); - i := PosEx(Sep,CSV,offs); - if i=0 then begin - i := PosEx(SepEnd,CSV,offs); - if i=0 then - i := MaxInt else - dec(i,offs); - Result[high(Result)] := Copy(CSV,offs,i); - exit; - end; - Result[high(Result)] := Copy(CSV,offs,i-offs); - offs := i+length(sep); - end; -end; - -function AddPrefixToCSV(CSV: PUTF8Char; const Prefix: RawUTF8; Sep: AnsiChar): RawUTF8; -var s: RawUTF8; -begin - GetNextItem(CSV,Sep,result); - if result='' then - exit; - result := Prefix+result; - while CSV<>nil do begin - GetNextItem(CSV,Sep,s); - if s<>'' then - result := result+','+Prefix+s; - end; -end; - -procedure AddToCSV(const Value: RawUTF8; var CSV: RawUTF8; const Sep: RawUTF8); -begin - if CSV='' then - CSV := Value else - CSV := CSV+Sep+Value; -end; - -function RenameInCSV(const OldValue, NewValue: RawUTF8; var CSV: RawUTF8; - const Sep: RawUTF8): boolean; -var pattern: RawUTF8; - i,j: integer; -begin - result := OldValue=NewValue; - i := length(OldValue); - if result or (length(Sep)<>1) or (length(CSV)0) or (PosEx(Sep,NewValue)>0) then - exit; - if CompareMem(pointer(OldValue),pointer(CSV),i) and // first (or unique) item - ((CSV[i+1]=Sep[1]) or (CSV[i+1]=#0)) then - i := 1 else begin - j := 1; - pattern := Sep+OldValue; - repeat - i := PosEx(pattern,CSV,j); - if i=0 then - exit; - j := i+length(pattern); - until (CSV[j]=Sep[1]) or (CSV[j]=#0); - inc(i); - end; - delete(CSV,i,length(OldValue)); - insert(NewValue,CSV,i); - result := true; -end; - -function RawUTF8ArrayToCSV(const Values: array of RawUTF8; const Sep: RawUTF8): RawUTF8; -var i, len, seplen, L: Integer; - P: PAnsiChar; -begin - result := ''; - if high(Values)<0 then - exit; - seplen := length(Sep); - len := seplen*high(Values); - for i := 0 to high(Values) do - inc(len,length(Values[i])); - FastSetString(result,nil,len); - P := pointer(result); - i := 0; - repeat - L := length(Values[i]); - if L>0 then begin - MoveFast(pointer(Values[i])^,P^,L); - inc(P,L); - end; - if i=high(Values) then - Break; - if seplen>0 then begin - MoveSmall(pointer(Sep),P,seplen); - inc(P,seplen); - end; - inc(i); - until false; -end; - -function RawUTF8ArrayToQuotedCSV(const Values: array of RawUTF8; const Sep: RawUTF8; - Quote: AnsiChar): RawUTF8; -var i: integer; - tmp: TRawUTF8DynArray; -begin - SetLength(tmp,length(Values)); - for i := 0 to High(Values) do - tmp[i] := QuotedStr(Values[i],Quote); - result := RawUTF8ArrayToCSV(tmp,Sep); -end; - -function TRawUTF8DynArrayFrom(const Values: array of RawUTF8): TRawUTF8DynArray; -var i: integer; -begin - Finalize(result); - SetLength(result,length(Values)); - for i := 0 to high(Values) do - result[i] := Values[i]; -end; - -{$ifdef HASCODEPAGE} -function LStringCodePage(info: PTypeInfo): integer; inline; -begin // caller checked that info^.kind=tkLString - result := PWord({$ifdef FPC}AlignTypeData{$endif}(pointer(PtrUInt(info)+info^.NameLen+2)))^; -end; -{$endif HASCODEPAGE} - -function IsRawUTF8DynArray(typeinfo: pointer): boolean; -var nfo: PTypeInfo; -begin - if typeinfo=System.TypeInfo(TRawUTF8DynArray) then - result := true else begin - nfo := GetTypeInfo(typeinfo,tkDynArray); - if (nfo<>nil) and (nfo^.elSize=SizeOf(pointer)) and - (nfo^.elType<>nil) then begin - nfo := DeRef(nfo^.elType); - result := (nfo^.kind=tkLString) - {$ifdef HASCODEPAGE}and (LStringCodePage(nfo)=CP_UTF8){$endif}; - end else - result := false; - end; -end; - -procedure AddArrayOfConst(var Dest: TTVarRecDynArray; const Values: array of const); -var i,n: Integer; -begin - n := length(Dest); - SetLength(Dest,n+length(Values)); - for i := 0 to high(Values) do - Dest[i+n] := Values[i]; -end; - -var - DefaultTextWriterTrimEnum: boolean; - -function ObjectToJSON(Value: TObject; Options: TTextWriterWriteObjectOptions): RawUTF8; -var temp: TTextWriterStackBuffer; -begin - if Value=nil then - result := NULL_STR_VAR else - with DefaultTextWriterSerializer.CreateOwnedStream(temp) do - try - include(fCustomOptions,twoForceJSONStandard); - WriteObject(Value,Options); - SetText(result); - finally - Free; - end; -end; - -function ObjectsToJSON(const Names: array of RawUTF8; const Values: array of TObject; - Options: TTextWriterWriteObjectOptions): RawUTF8; -var i,n: integer; - temp: TTextWriterStackBuffer; -begin - with DefaultTextWriterSerializer.CreateOwnedStream(temp) do - try - n := length(Names); - Add('{'); - for i := 0 to high(Values) do - if Values[i]<>nil then begin - if i0) and (n and 1=1) then begin - for A := 0 to n shr 1 do begin - VarRecToUTF8(NameValuePairs[A*2],name); - if not IsUrlValid(pointer(name)) then - continue; // just skip invalid names - with NameValuePairs[A*2+1] do - if VType=vtObject then - value := ObjectToJSON(VObject,[]) else - VarRecToUTF8(NameValuePairs[A*2+1],value); - result := result+'&'+name+'='+UrlEncode(value); - end; - result[1] := '?'; - end; -end; - -function IsUrlValid(P: PUTF8Char): boolean; -var tab: PTextCharSet; -begin - result := false; - if P=nil then - exit; - tab := @TEXT_CHARS; - repeat // cf. rfc3986 2.3. Unreserved Characters - if tcURIUnreserved in tab[P^] then - inc(P) else - exit; - until P^=#0; - result := true; -end; - -function AreUrlValid(const Url: array of RawUTF8): boolean; -var i: integer; -begin - result := false; - for i := 0 to high(Url) do - if not IsUrlValid(pointer(Url[i])) then - exit; - result := true; -end; - -function IncludeTrailingURIDelimiter(const URI: RawByteString): RawByteString; -begin - if (URI<>'') and (URI[length(URI)]<>'/') then - result := URI+'/' else - result := URI; -end; - -function UrlEncodeJsonObject(const URIName: RawUTF8; ParametersJSON: PUTF8Char; - const PropNamesToIgnore: array of RawUTF8; IncludeQueryDelimiter: Boolean): RawUTF8; -var i,j: integer; - sep: AnsiChar; - Params: TNameValuePUTF8CharDynArray; - temp: TTextWriterStackBuffer; -begin - if ParametersJSON=nil then - result := URIName else - with TTextWriter.CreateOwnedStream(temp) do - try - AddString(URIName); - if (JSONDecode(ParametersJSON,Params,true)<>nil) and (Params<>nil) then begin - sep := '?'; - for i := 0 to length(Params)-1 do - with Params[i] do begin - for j := 0 to high(PropNamesToIgnore) do - if IdemPropNameU(PropNamesToIgnore[j],Name,NameLen) then begin - NameLen := 0; - break; - end; - if NameLen=0 then - continue; - if IncludeQueryDelimiter then - Add(sep); - AddNoJSONEscape(Name,NameLen); - Add('='); - AddString(UrlEncode(Value)); - sep := '&'; - IncludeQueryDelimiter := true; - end; - end; - SetText(result); - finally - Free; - end; -end; - -function UrlEncodeJsonObject(const URIName, ParametersJSON: RawUTF8; - const PropNamesToIgnore: array of RawUTF8; IncludeQueryDelimiter: Boolean): RawUTF8; -var temp: TSynTempBuffer; -begin - temp.Init(ParametersJSON); - try - result := UrlEncodeJsonObject(URIName,temp.buf,PropNamesToIgnore,IncludeQueryDelimiter); - finally - temp.Done; - end; -end; - -function UrlDecode(const s: RawUTF8; i,len: PtrInt): RawUTF8; -var L: PtrInt; - P: PUTF8Char; - tmp: TSynTempBuffer; -begin - result := ''; - L := PtrInt(s); - if L=0 then - exit; - L := PStrLen(L-_STRLEN)^; - if len<0 then - len := L; - if i>L then - exit; - dec(i); - if len=i then - exit; - P := tmp.Init(len-i); // reserve enough space for result - while inil then begin - // compute resulting length of value - Beg := U; - len := 0; - while (U^<>#0) and (U^<>'&') do begin - if (U^='%') and HexToCharValid(PAnsiChar(U+1)) then - inc(U,3) else - inc(U); - inc(len); - end; - // decode value content - if len<>0 then begin - FastSetString(Value,nil,len); - V := pointer(Value); - U := Beg; - repeat - if (U^='%') and HexToChar(PAnsiChar(U+1),V) then begin - inc(V); - inc(U,3); - end else begin - if U^='+' then - V^ := ' ' else - V^ := U^; - inc(V); - inc(U); - end; - dec(len); - until len=0; - end; - end; - result := U; -end; - -function UrlDecodeNextName(U: PUTF8Char; out Name: RawUTF8): PUTF8Char; -var Beg, V: PUTF8Char; - len: PtrInt; -begin - result := nil; - if U=nil then - exit; - // compute resulting length of name - Beg := U; - len := 0; - repeat - case U^ of - #0: exit; - '=': begin - result := U+1; - break; - end; - '%': if (U[1]='3') and (U[2] in ['D','d']) then begin - result := U+3; - break; // %3d means = according to the RFC - end else - if HexToCharValid(PAnsiChar(U+1)) then - inc(U,3) else - inc(U); - else inc(U); - end; - inc(len); - until false; - if len=0 then - exit; - // decode name content - FastSetString(Name,nil,len); - V := pointer(Name); - U := Beg; - repeat - if (U^='%') and HexToChar(PAnsiChar(U+1),V) then begin - inc(V); - inc(U,3); - end else begin - if U^='+' then - V^ := ' ' else - V^ := U^; - inc(V); - inc(U); - end; - dec(len); - until len=0; -end; - -function UrlDecodeNextNameValue(U: PUTF8Char; var Name,Value: RawUTF8): PUTF8Char; -begin - result := nil; - if U=nil then - exit; - U := UrlDecodeNextName(U,Name); - if U=nil then - exit; - U := UrlDecodeNextValue(U,Value); - if U^=#0 then - result := U else - result := U+1; // jump '&' to let decode the next name=value pair -end; - -function UrlDecodeValue(U: PUTF8Char; const Upper: RawUTF8; var Value: RawUTF8; - Next: PPUTF8Char): boolean; -begin - // UrlDecodeValue('select=%2A&where=LastName%3D%27M%C3%B4net%27','SELECT=',V,@U) - // -> U^='where=...' and V='*' - result := false; // mark value not modified by default - if U=nil then begin - if Next<>nil then - Next^ := U; - exit; - end; - if IdemPChar(U,pointer(Upper)) then begin - result := true; - inc(U,length(Upper)); - U := UrlDecodeNextValue(U,Value); - end; - if Next=nil then - exit; - while not(U^ in [#0,'&']) do inc(U); - if U^=#0 then - Next^ := nil else - Next^ := U+1; // jump '&' -end; - -function UrlDecodeInteger(U: PUTF8Char; const Upper: RawUTF8; - var Value: integer; Next: PPUTF8Char): boolean; -var V: PtrInt; - SignNeg: boolean; -begin - // UrlDecodeInteger('offset=20&where=LastName%3D%27M%C3%B4net%27','OFFSET=',O,@Next) - // -> Next^='where=...' and O=20 - result := false; // mark value not modified by default - if U=nil then begin - if Next<>nil then - Next^ := U; - exit; - end; - if IdemPChar(U,pointer(Upper)) then begin - inc(U,length(Upper)); - if U^='-' then begin - SignNeg := True; - Inc(U); - end else - SignNeg := false; - if U^ in ['0'..'9'] then begin - V := 0; - repeat - V := (V*10)+ord(U^)-48; - inc(U); - until not (U^ in ['0'..'9']); - if SignNeg then - Value := -V else - Value := V; - result := true; - end; - end; - if Next=nil then - exit; - while not(U^ in [#0,'&']) do inc(U); - if U^=#0 then - Next^ := nil else - Next^ := U+1; // jump '&' -end; - -function UrlDecodeCardinal(U: PUTF8Char; const Upper: RawUTF8; - var Value: Cardinal; Next: PPUTF8Char): boolean; -var V: PtrInt; -begin - // UrlDecodeInteger('offset=20&where=LastName%3D%27M%C3%B4net%27','OFFSET=',O,@Next) - // -> Next^='where=...' and O=20 - result := false; // mark value not modified by default - if U=nil then begin - if Next<>nil then - Next^ := U; - exit; - end; - if IdemPChar(U,pointer(Upper)) then begin - inc(U,length(Upper)); - if U^ in ['0'..'9'] then begin - V := 0; - repeat - V := (V*10)+ord(U^)-48; - inc(U); - until not (U^ in ['0'..'9']); - Value := V; - result := true; - end; - end; - if Next=nil then - exit; - while not(U^ in [#0,'&']) do inc(U); - if U^=#0 then - Next^ := nil else - Next^ := U+1; // jump '&' -end; - -function UrlDecodeInt64(U: PUTF8Char; const Upper: RawUTF8; - var Value: Int64; Next: PPUTF8Char): boolean; -var tmp: RawUTF8; -begin - result := UrlDecodeValue(U,Upper,tmp,Next); - if result then - SetInt64(pointer(tmp),Value); -end; - -function UrlDecodeExtended(U: PUTF8Char; const Upper: RawUTF8; - var Value: TSynExtended; Next: PPUTF8Char): boolean; -var tmp: RawUTF8; - err: integer; -begin - result := UrlDecodeValue(U,Upper,tmp,Next); - if result then begin - Value := GetExtended(pointer(tmp),err); - if err<>0 then - result := false; - end; -end; - -function UrlDecodeDouble(U: PUTF8Char; const Upper: RawUTF8; var Value: double; - Next: PPUTF8Char): boolean; -var tmp: RawUTF8; - err: integer; -begin - result := UrlDecodeValue(U,Upper,tmp,Next); - if result then begin - Value := GetExtended(pointer(tmp),err); - if err<>0 then - result := false; - end; -end; - -function UrlDecodeNeedParameters(U, CSVNames: PUTF8Char): boolean; -var tmp: array[byte] of AnsiChar; - L: integer; - Beg: PUTF8Char; -// UrlDecodeNeedParameters('price=20.45&where=LastName%3D','price,where') will -// return TRUE -begin - result := (CSVNames=nil); - if result then - exit; // no parameter to check -> success - if U=nil then - exit; // no input data -> error - repeat - L := 0; - while (CSVNames^<>#0) and (CSVNames^<>',') do begin - tmp[L] := NormToUpper[CSVNames^]; - if L=high(tmp) then - exit else // invalid CSV parameter - inc(L); - inc(CSVNames); - end; - if L=0 then - exit; // invalid CSV parameter - PWord(@tmp[L])^ := ord('='); - Beg := U; - repeat - if IdemPChar(U,tmp) then - break; - while not(U^ in [#0,'&']) do inc(U); - if U^=#0 then - exit else // didn't find tmp in U - inc(U); // Jump & - until false; - U := Beg; - if CSVNames^=#0 then - Break else // no more parameter to check - inc(CSVNames); // jump & - until false; - result := true; // all parameters found -end; - -function CSVEncode(const NameValuePairs: array of const; - const KeySeparator, ValueSeparator: RawUTF8): RawUTF8; -var i: integer; - temp: TTextWriterStackBuffer; -begin - if length(NameValuePairs)<2 then - result := '' else - with DefaultTextWriterSerializer.CreateOwnedStream(temp) do - try - for i := 1 to length(NameValuePairs) shr 1 do begin - Add(NameValuePairs[i*2-2],twNone); - AddNoJSONEscape(pointer(KeySeparator),length(KeySeparator)); - Add(NameValuePairs[i*2-1],twNone); - AddNoJSONEscape(pointer(ValueSeparator),length(ValueSeparator)); - end; - SetText(result); - finally - Free; - end; -end; - -function ArrayOfConstValueAsText(const NameValuePairs: array of const; - const aName: RawUTF8): RawUTF8; -var i: integer; - name: RawUTF8; -begin - for i := 1 to length(NameValuePairs) shr 1 do - if VarRecToUTF8IsString(NameValuePairs[i*2-2],name) and - IdemPropNameU(name,aName) then begin - VarRecToUTF8(NameValuePairs[i*2-1],result); - exit; - end; - result := ''; -end; - -function IsZero(P: pointer; Length: integer): boolean; -var i: integer; -begin - result := false; - for i := 1 to Length shr 4 do // 16 bytes (4 DWORD) by loop - aligned read - {$ifdef CPU64} - if (PInt64Array(P)^[0]<>0) or (PInt64Array(P)^[1]<>0) then - {$else} - if (PCardinalArray(P)^[0]<>0) or (PCardinalArray(P)^[1]<>0) or - (PCardinalArray(P)^[2]<>0) or (PCardinalArray(P)^[3]<>0) then - {$endif} - exit else - inc(PByte(P),16); - for i := 1 to (Length shr 2)and 3 do // 4 bytes (1 DWORD) by loop - if PCardinal(P)^<>0 then - exit else - inc(PByte(P),4); - for i := 1 to Length and 3 do // remaining content - if PByte(P)^<>0 then - exit else - inc(PByte(P)); - result := true; -end; - -function IsZeroSmall(P: pointer; Length: PtrInt): boolean; -begin - result := false; - repeat - if PByte(P)^<>0 then - exit; - inc(PByte(P)); - dec(Length); - if Length=0 then - break; - until false; - result := true; -end; - -function IsZero(const Values: TRawUTF8DynArray): boolean; -var i: integer; -begin - result := false; - for i := 0 to length(Values)-1 do - if Values[i]<>'' then - exit; - result := true; -end; - -function IsZero(const Values: TIntegerDynArray): boolean; -var i: integer; -begin - result := false; - for i := 0 to length(Values)-1 do - if Values[i]<>0 then - exit; - result := true; -end; - -function IsZero(const Values: TInt64DynArray): boolean; -var i: integer; -begin - result := false; - for i := 0 to length(Values)-1 do - if Values[i]<>0 then - exit; - result := true; -end; - -procedure FillZero(var Values: TRawUTF8DynArray); -var i: integer; -begin - for i := 0 to length(Values)-1 do - {$ifdef FPC}Finalize(Values[i]){$else}Values[i] := ''{$endif}; -end; - -procedure FillZero(var Values: TIntegerDynArray); -begin - FillCharFast(Values[0],length(Values)*SizeOf(integer),0); -end; - -procedure FillZero(var Values: TInt64DynArray); -begin - FillCharFast(Values[0],length(Values)*SizeOf(Int64),0); -end; - - -function crc16(Data: PAnsiChar; Len: integer): cardinal; -var i, j: Integer; -begin - result := $ffff; - for i := 0 to Len-1 do begin - result := result xor (ord(Data[i]) shl 8); - for j := 1 to 8 do - if result and $8000<>0 then - result := (result shl 1) xor $1021 else - result := result shl 1; - end; - result := result and $ffff; -end; - -function Hash32(const Text: RawByteString): cardinal; -begin - result := Hash32(pointer(Text),length(Text)); -end; - -function Hash32(Data: PCardinalArray; Len: integer): cardinal; -{$ifdef CPUX64} {$ifdef FPC}nostackframe; assembler; -asm {$else} asm .noframe {$endif} // rcx/rdi=Data edx/esi=Len - xor eax, eax - xor r9d, r9d - test Data, Data - jz @z - {$ifdef win64} - mov r8, rdx - shr r8, 4 - {$else} - mov edx, esi - shr esi, 4 - {$endif} - jz @by4 - {$ifdef FPC} align 16 {$else} .align 16 {$endif} -@by16: add eax, dword ptr[Data] - add r9d, eax - add eax, dword ptr[Data+4] - add r9d, eax - add eax, dword ptr[Data+8] - add r9d, eax - add eax, dword ptr[Data+12] - add r9d, eax - add Data, 16 - {$ifdef win64} - dec r8d - {$else} - dec esi - {$endif} - jnz @by16 -@by4: mov dh, dl - and dl, 15 - jz @0 - shr dl, 2 - jz @rem -@4: add eax, dword ptr[Data] - add r9d, eax - add Data, 4 - dec dl - jnz @4 -@rem: and dh, 3 - jz @0 - dec dh - jz @1 - dec dh - jz @2 - mov ecx, dword ptr[Data] - and ecx, $ffffff - jmp @e -@2: movzx ecx, word ptr[Data] - jmp @e -@1: movzx ecx, byte ptr[Data] -@e: add eax, ecx -@0: add r9d, eax - shl r9d, 16 - xor eax, r9d -@z: -end; -{$else} -{$ifdef PUREPASCAL} -var s1,s2: cardinal; - i: integer; -begin - if Data<>nil then begin - s1 := 0; - s2 := 0; - for i := 1 to Len shr 4 do begin // 16 bytes (128-bit) loop - aligned read - inc(s1,Data[0]); - inc(s2,s1); - inc(s1,Data[1]); - inc(s2,s1); - inc(s1,Data[2]); - inc(s2,s1); - inc(s1,Data[3]); - inc(s2,s1); - Data := @Data[4]; - end; - for i := 1 to (Len shr 2)and 3 do begin // 4 bytes (DWORD) by loop - inc(s1,Data[0]); - inc(s2,s1); - Data := @Data[1]; - end; - case Len and 3 of // remaining 0..3 bytes - 1: inc(s1,PByte(Data)^); - 2: inc(s1,PWord(Data)^); - 3: inc(s1,PWord(Data)^ or (PByteArray(Data)^[2] shl 16)); - end; - inc(s2,s1); - result := s1 xor (s2 shl 16); - end else - result := 0; -end; -{$else} {$ifdef FPC} nostackframe; assembler; {$endif} -asm // eax=Data edx=Len - push esi - push edi - mov cl, dl - mov ch, dl - xor esi, esi - xor edi, edi - test eax, eax - jz @z - shr edx, 4 - jz @by4 - nop -@by16: add esi, dword ptr[eax] - add edi, esi - add esi, dword ptr[eax+4] - add edi, esi - add esi, dword ptr[eax+8] - add edi, esi - add esi, dword ptr[eax+12] - add edi, esi - add eax, 16 - dec edx - jnz @by16 -@by4: and cl, 15 - jz @0 - shr cl, 2 - jz @rem -@4: add esi, dword ptr[eax] - add edi, esi - add eax, 4 - dec cl - jnz @4 -@rem: and ch, 3 - jz @0 - dec ch - jz @1 - dec ch - jz @2 - mov eax, dword ptr[eax] - and eax, $ffffff - jmp @e -@2: movzx eax, word ptr[eax] - jmp @e -@1: movzx eax, byte ptr[eax] -@e: add esi, eax -@0: add edi, esi - mov eax, esi - shl edi, 16 - xor eax, edi -@z: pop edi - pop esi -end; -{$endif PUREPASCAL} -{$endif CPUX64} - -procedure OrMemory(Dest,Source: PByteArray; size: PtrInt); -begin - while size>=SizeOf(PtrInt) do begin - dec(size,SizeOf(PtrInt)); - PPtrInt(Dest)^ := PPtrInt(Dest)^ or PPtrInt(Source)^; - inc(PPtrInt(Dest)); - inc(PPtrInt(Source)); - end; - while size>0 do begin - dec(size); - Dest[size] := Dest[size] or Source[size]; - end; -end; - -procedure XorMemory(Dest,Source: PByteArray; size: PtrInt); -begin - while size>=SizeOf(PtrInt) do begin - dec(size,SizeOf(PtrInt)); - PPtrInt(Dest)^ := PPtrInt(Dest)^ xor PPtrInt(Source)^; - inc(PPtrInt(Dest)); - inc(PPtrInt(Source)); - end; - while size>0 do begin - dec(size); - Dest[size] := Dest[size] xor Source[size]; - end; -end; - -procedure XorMemory(Dest,Source1,Source2: PByteArray; size: PtrInt); -begin - while size>=SizeOf(PtrInt) do begin - dec(size,SizeOf(PtrInt)); - PPtrInt(Dest)^ := PPtrInt(Source1)^ xor PPtrInt(Source2)^; - inc(PPtrInt(Dest)); - inc(PPtrInt(Source1)); - inc(PPtrInt(Source2)); - end; - while size>0 do begin - dec(size); - Dest[size] := Source1[size] xor Source2[size]; - end; -end; - -procedure AndMemory(Dest,Source: PByteArray; size: PtrInt); -begin - while size>=SizeOf(PtrInt) do begin - dec(size,SizeOf(PtrInt)); - PPtrInt(Dest)^ := PPtrInt(Dest)^ and PPtrInt(Source)^; - inc(PPtrInt(Dest)); - inc(PPtrInt(Source)); - end; - while size>0 do begin - dec(size); - Dest[size] := Dest[size] and Source[size]; - end; -end; - -{$ifdef CPUINTEL} // use optimized x86/x64 asm versions for xxHash32 - -{$ifdef CPUX86} -function xxHash32(crc: cardinal; P: PAnsiChar; len: integer): cardinal; -{$ifdef FPC}nostackframe; assembler;{$endif} -asm - xchg edx, ecx - push ebp - push edi - lea ebp, [ecx+edx] - push esi - push ebx - sub esp, 8 - mov ebx, eax - mov dword ptr [esp], edx - lea eax, [ebx+165667B1H] - cmp edx, 15 - jbe @2 - lea eax, [ebp-10H] - lea edi, [ebx+24234428H] - lea esi, [ebx-7A143589H] - mov dword ptr [esp+4H], ebp - mov edx, eax - lea eax, [ebx+61C8864FH] - mov ebp, edx -@1: mov edx, dword ptr [ecx] - imul edx, -2048144777 - add edi, edx - rol edi, 13 - imul edi, -1640531535 - mov edx, dword ptr [ecx+4] - imul edx, -2048144777 - add esi, edx - rol esi, 13 - imul esi, -1640531535 - mov edx, dword ptr [ecx+8] - imul edx, -2048144777 - add ebx, edx - rol ebx, 13 - imul ebx, -1640531535 - mov edx, dword ptr [ecx+12] - lea ecx, [ecx+16] - imul edx, -2048144777 - add eax, edx - rol eax, 13 - imul eax, -1640531535 - cmp ebp, ecx - jnc @1 - rol edi, 1 - rol esi, 7 - rol ebx, 12 - add esi, edi - mov ebp, dword ptr [esp+4H] - ror eax, 14 - add ebx, esi - add eax, ebx -@2: lea esi, [ecx+4H] - add eax, dword ptr [esp] - cmp ebp, esi - jc @4 - mov ebx, esi - nop -@3: imul edx, dword ptr [ebx-4H], -1028477379 - add ebx, 4 - add eax, edx - ror eax, 15 - imul eax, 668265263 - cmp ebp, ebx - jnc @3 - lea edx, [ebp-4H] - sub edx, ecx - mov ecx, edx - and ecx, 0FFFFFFFCH - add ecx, esi -@4: cmp ebp, ecx - jbe @6 -@5: movzx edx, byte ptr [ecx] - add ecx, 1 - imul edx, 374761393 - add eax, edx - rol eax, 11 - imul eax, -1640531535 - cmp ebp, ecx - jnz @5 - nop -@6: mov edx, eax - add esp, 8 - shr edx, 15 - xor eax, edx - imul eax, -2048144777 - pop ebx - pop esi - mov edx, eax - shr edx, 13 - xor eax, edx - imul eax, -1028477379 - pop edi - pop ebp - mov edx, eax - shr edx, 16 - xor eax, edx -end; -{$endif CPUX86} - -{$ifdef CPUX64} -function xxHash32(crc: cardinal; P: PAnsiChar; len: integer): cardinal; -{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe{$endif} - {$ifdef LINUX} // crc=rdi P=rsi len=rdx - mov r8, rdi - mov rcx, rsi - {$else} // crc=r8 P=rcx len=rdx - mov r10, r8 - mov r8, rcx - mov rcx, rdx - mov rdx, r10 - push rsi // Win64 expects those registers to be preserved - push rdi - {$endif} - // P=r8 len=rcx crc=rdx - push r12 - push rbx - mov r12d, -1640531535 - lea r10, [rcx+rdx] - lea eax, [r8+165667B1H] - cmp rdx, 15 - jbe @2 - lea rsi, [r10-10H] - lea ebx, [r8+24234428H] - lea edi, [r8-7A143589H] - lea eax, [r8+61C8864FH] -@1: imul r9d, dword ptr [rcx], -2048144777 - add rcx, 16 - imul r11d, dword ptr [rcx-0CH], -2048144777 - add ebx, r9d - lea r9d, [r11+rdi] - rol ebx, 13 - rol r9d, 13 - imul ebx, r12d - imul edi, r9d, -1640531535 - imul r9d, dword ptr [rcx-8H], -2048144777 - add r8d, r9d - imul r9d, dword ptr [rcx-4H], -2048144777 - rol r8d, 13 - imul r8d, r12d - add eax, r9d - rol eax, 13 - imul eax, r12d - cmp rsi, rcx - jnc @1 - rol edi, 7 - rol ebx, 1 - rol r8d, 12 - mov r9d, edi - ror eax, 14 - add r9d, ebx - add r8d, r9d - add eax, r8d -@2: lea r9, [rcx+4H] - add eax, edx - cmp r10, r9 - jc @4 - mov r8, r9 -@3: imul edx, dword ptr [r8-4H], -1028477379 - add r8, 4 - add eax, edx - ror eax, 15 - imul eax, 668265263 - cmp r10, r8 - jnc @3 - lea rdx, [r10-4H] - sub rdx, rcx - mov rcx, rdx - and rcx, 0FFFFFFFFFFFFFFFCH - add rcx, r9 -@4: cmp r10, rcx - jbe @6 -@5: movzx edx, byte ptr [rcx] - add rcx, 1 - imul edx, 374761393 - add eax, edx - rol eax, 11 - imul eax, r12d - cmp r10, rcx - jnz @5 -@6: mov edx, eax - shr edx, 15 - xor eax, edx - imul eax, -2048144777 - mov edx, eax - shr edx, 13 - xor eax, edx - imul eax, -1028477379 - mov edx, eax - shr edx, 16 - xor eax, edx - pop rbx - pop r12 - {$ifndef LINUX} - pop rdi - pop rsi - {$endif} -end; -{$endif CPUX64} - -{$else not CPUINTEL} - -const - PRIME32_1 = 2654435761; - PRIME32_2 = 2246822519; - PRIME32_3 = 3266489917; - PRIME32_4 = 668265263; - PRIME32_5 = 374761393; - -{$ifdef FPC} // RolDWord is an intrinsic function under FPC :) -function Rol13(value: cardinal): cardinal; inline; -begin - result := RolDWord(value, 13); -end; -{$else} -{$ifdef HASINLINENOTX86} -function RolDWord(value: cardinal; count: integer): cardinal; inline; -begin - result := (value shl count) or (value shr (32-count)); -end; - -function Rol13(value: cardinal): cardinal; inline; -begin - result := (value shl 13) or (value shr 19); -end; -{$else} -function RolDWord(value: cardinal; count: integer): cardinal; -asm - mov cl, dl - rol eax, cl -end; - -function Rol13(value: cardinal): cardinal; -asm - rol eax, 13 -end; -{$endif HASINLINENOTX86} -{$endif FPC} - -function xxHash32(crc: cardinal; P: PAnsiChar; len: integer): cardinal; -var c1, c2, c3, c4: cardinal; - PLimit, PEnd: PAnsiChar; -begin - PEnd := P + len; - if len >= 16 then begin - PLimit := PEnd - 16; - c3 := crc; - c2 := c3 + PRIME32_2; - c1 := c2 + PRIME32_1; - c4 := c3 - PRIME32_1; - repeat - c1 := PRIME32_1 * Rol13(c1 + PRIME32_2 * PCardinal(P)^); - c2 := PRIME32_1 * Rol13(c2 + PRIME32_2 * PCardinal(P+4)^); - c3 := PRIME32_1 * Rol13(c3 + PRIME32_2 * PCardinal(P+8)^); - c4 := PRIME32_1 * Rol13(c4 + PRIME32_2 * PCardinal(P+12)^); - inc(P, 16); - until not (P <= PLimit); - result := RolDWord(c1, 1) + RolDWord(c2, 7) + RolDWord(c3, 12) + RolDWord(c4, 18); - end else - result := crc + PRIME32_5; - inc(result, len); - while P + 4 <= PEnd do begin - inc(result, PCardinal(P)^ * PRIME32_3); - result := RolDWord(result, 17) * PRIME32_4; - inc(P, 4); - end; - while P < PEnd do begin - inc(result, PByte(P)^ * PRIME32_5); - result := RolDWord(result, 11) * PRIME32_1; - inc(P); - end; - result := result xor (result shr 15); - result := result * PRIME32_2; - result := result xor (result shr 13); - result := result * PRIME32_3; - result := result xor (result shr 16); -end; - -{$endif CPUINTEL} - -type - TRegisters = record - eax,ebx,ecx,edx: cardinal; - end; - -{$ifdef CPUINTEL} -{$ifdef CPU64} -procedure GetCPUID(Param: Cardinal; var Registers: TRegisters); -{$ifdef FPC}nostackframe; assembler; asm {$else} -asm .noframe // ecx=param, rdx=Registers (Linux: edi,rsi) -{$endif FPC} - mov eax, Param - mov r9, Registers - mov r10, rbx // preserve rbx - xor ebx, ebx - xor ecx, ecx - xor edx, edx - cpuid - mov TRegisters(r9).&eax, eax - mov TRegisters(r9).&ebx, ebx - mov TRegisters(r9).&ecx, ecx - mov TRegisters(r9).&edx, edx - mov rbx, r10 -end; - -{$ifndef ABSOLUTEPASCAL} -const - CMP_RANGES = $44; // see https://msdn.microsoft.com/en-us/library/bb531425 - _UpperCopy255BufSSE42: array[0..31] of AnsiChar = - 'azazazazazazazaz '; - -function UpperCopy255BufSSE42(dest: PAnsiChar; source: PUTF8Char; sourceLen: PtrInt): PAnsiChar; -{$ifdef FPC}nostackframe; assembler; asm {$else} -asm .noframe // rcx=dest, rdx=source, r8=len (Linux: rdi,rsi,rdx) -{$endif FPC} - {$ifdef win64} - mov rax, rcx - mov r9, rdx - mov rdx, r8 - {$else} - mov rax, rdi - mov r9, rsi - {$endif} - lea rcx, [rip + _UpperCopy255BufSSE42] - test rdx, rdx - jz @z - movups xmm1, dqword ptr [rcx] - movups xmm3, dqword ptr [rcx + 16] - cmp rdx, 16 - ja @big - // optimize the common case of sourceLen<=16 - movups xmm2, [r9] - {$ifdef HASAESNI} - pcmpistrm xmm1, xmm2, CMP_RANGES // find in range a-z, return mask in xmm0 - {$else} - db $66, $0F, $3A, $62, $CA, CMP_RANGES - {$endif} - pand xmm0, xmm3 - pxor xmm2, xmm0 - movups [rax], xmm2 - add rax, rdx -@z: ret -@big: mov rcx, rax - cmp rdx, 240 - jb @ok - mov rdx, 239 -@ok: add rax, rdx // return end position with the exact size - shr rdx, 4 - sub r9, rcx - add rdx, 1 -{$ifdef FPC} align 16 {$else} .align 16{$endif} -@s: movups xmm2, [r9 + rcx] - {$ifdef HASAESNI} - pcmpistrm xmm1, xmm2, CMP_RANGES - {$else} - db $66, $0F, $3A, $62, $CA, CMP_RANGES - {$endif} - pand xmm0, xmm3 - pxor xmm2, xmm0 - movups [rcx], xmm2 - add rcx, 16 - dec rdx - jnz @s -end; - -{$ifdef HASAESNI} -const - EQUAL_EACH = 8; // see https://msdn.microsoft.com/en-us/library/bb531463 - NEGATIVE_POLARITY = 16; - -function StrLenSSE42(S: pointer): PtrInt; -{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC} - xor rax, rax - mov rdx, S - test S, S - jz @null - xor rcx, rcx - pxor xmm0, xmm0 - pcmpistri xmm0, [rdx], EQUAL_EACH // result in ecx - jnz @L - mov eax, ecx -@null: ret -{$ifdef FPC} align 16 {$else} .align 16 {$endif} -@L: add rax, 16 // add before comparison flag - pcmpistri xmm0, [rdx + rax], EQUAL_EACH // result in ecx - jnz @L - add rax, rcx -end; - -function StrCompSSE42(Str1, Str2: pointer): PtrInt; -{$ifdef FPC}nostackframe; assembler; asm {$else} -asm .noframe // rcx=Str1, rdx=Str2 (Linux: rdi,rsi) -{$endif FPC} - {$ifdef win64} - mov rax, rcx - test rcx, rdx - {$else} - mov rax, rdi - mov rdx, rsi - test rdi, rsi // is one of Str1/Str2 nil ? - {$endif} - jz @n -@ok: sub rax, rdx - xor rcx, rcx - movups xmm0, dqword [rdx] - pcmpistri xmm0, dqword [rdx + rax], EQUAL_EACH + NEGATIVE_POLARITY // result in rcx - ja @1 - jc @2 - xor rax, rax - ret -{$ifdef FPC} align 16 {$else} .align 16 {$endif} -@1: add rdx, 16 - movups xmm0, dqword [rdx] - pcmpistri xmm0, dqword [rdx + rax], EQUAL_EACH + NEGATIVE_POLARITY - ja @1 - jc @2 -@0: xor rax, rax // Str1=Str2 - ret -@n: cmp rax, rdx - je @0 - test rax, rax // Str1='' ? - jz @max - test rdx, rdx // Str2='' ? - jnz @ok - mov rax, 1 - ret -@max: dec rax // returns -1 - ret -@2: add rax, rdx - movzx rax, byte ptr [rax + rcx] - movzx rdx, byte ptr [rdx + rcx] - sub rax, rdx -end; -{$endif HASAESNI} -{$endif ABSOLUTEPASCAL} - -function crc32csse42(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal; -{$ifdef FPC}nostackframe; assembler; asm {$else} -asm .noframe // ecx=crc, rdx=buf, r8=len (Linux: edi,rsi,edx) -{$endif FPC} - mov eax, crc - not eax - test len, len - jz @0 - test buf, buf - jz @0 - jmp @align -@7: crc32 eax, byte ptr[buf] - inc buf - dec len - jz @0 -@align: test buf, 7 - jnz @7 - mov ecx, len - shr len, 3 - jnz @s -@2: test cl, 4 - jz @3 - crc32 eax, dword ptr[buf] - add buf, 4 -@3: test cl, 2 - jz @1 - crc32 eax, word ptr[buf] - add buf, 2 -@1: test cl, 1 - jz @0 - crc32 eax, byte ptr[buf] -@0: not eax - ret -{$ifdef FPC} align 16 -@s: crc32 rax, qword [buf] // hash 8 bytes per loop -{$else} .align 16 -@s: db $F2,$48,$0F,$38,$F1,$02 // circumvent Delphi inline asm compiler bug -{$endif}add buf, 8 - dec len - jnz @s - jmp @2 -end; - -function StrLenSSE2(S: pointer): PtrInt; -{$ifdef FPC}nostackframe; assembler; asm {$else} -asm .noframe // rcx=S (Linux: rdi) -{$endif FPC} // from GPL strlen64.asm by Agner Fog - www.agner.org/optimize - {$ifdef win64} - mov rax, rcx // get pointer to string from rcx - mov r8, rcx // copy pointer - test rcx, rcx - {$else} - mov rax, rdi - mov ecx, edi - test rdi, rdi - {$endif} - jz @null // returns 0 if S=nil - // rax=s,ecx=32-bit of s - pxor xmm0, xmm0 // set to zero - and ecx, 15 // lower 4 bits indicate misalignment - and rax, -16 // align pointer by 16 - // will never read outside a memory page boundary, so won't trigger GPF - movaps xmm1, [rax] // read from nearest preceding boundary - pcmpeqb xmm1, xmm0 // compare 16 bytes with zero - pmovmskb edx, xmm1 // get one bit for each byte result - shr edx, cl // shift out false bits - shl edx, cl // shift back again - bsf edx, edx // find first 1-bit - jnz @L2 // found - // Main loop, search 16 bytes at a time -{$ifdef FPC} align 16 {$else} .align 16 {$endif} -@L1: add rax, 10H // increment pointer by 16 - movaps xmm1, [rax] // read 16 bytes aligned - pcmpeqb xmm1, xmm0 // compare 16 bytes with zero - pmovmskb edx, xmm1 // get one bit for each byte result - bsf edx, edx // find first 1-bit - // (moving the bsf out of the loop and using test here would be faster - // for long strings on old processors, but we are assuming that most - // strings are short, and newer processors have higher priority) - jz @L1 // loop if not found -@L2: // Zero-byte found. Compute string length - {$ifdef win64} - sub rax, r8 // subtract start address - {$else} - sub rax, rdi - {$endif} - add rax, rdx // add byte index -@null: -end; - -{$endif CPU64} - -procedure crcblockssse42(crc128, data128: PBlock128; count: integer); -{$ifdef CPUX64} {$ifdef FPC}nostackframe; assembler; asm {$else} -asm .noframe {$endif FPC} - test count, count - jle @z - mov rax, data128 - {$ifdef win64} - mov rdx, rcx - mov ecx, r8d - {$else} - mov ecx, edx - mov rdx, rdi - {$endif win64} - mov r8d, dword ptr [rdx] // we can't use qword ptr here - mov r9d, dword ptr [rdx + 4] - mov r10d, dword ptr [rdx + 8] - mov r11d, dword ptr [rdx + 12] -{$ifdef FPC} align 16 {$else} .align 16 {$endif} -@s: crc32 r8d, dword ptr [rax] - crc32 r9d, dword ptr [rax + 4] - crc32 r10d, dword ptr [rax + 8] - crc32 r11d, dword ptr [rax + 12] - add rax, 16 - dec ecx - jnz @s - mov dword ptr [rdx], r8d - mov dword ptr [rdx + 4], r9d - mov dword ptr [rdx + 8], r10d - mov dword ptr [rdx + 12], r11d -@z: -end; -{$else} {$ifdef FPC} nostackframe; assembler; {$endif} -asm // eax=crc128 edx=data128 ecx=count - push ebx - push esi - push edi - push ebp - test count, count - jle @z - mov ebp, count - mov esi, crc128 - mov edi, data128 - mov eax, dword ptr[esi] - mov ebx, dword ptr[esi + 4] - mov ecx, dword ptr[esi + 8] - mov edx, dword ptr[esi + 12] -{$ifdef FPC_X86ASM} align 8 -@s: crc32 eax, dword ptr[edi] - crc32 ebx, dword ptr[edi + 4] - crc32 ecx, dword ptr[edi + 8] - crc32 edx, dword ptr[edi + 12] -{$else}@s:db $F2, $0F, $38, $F1, $07 - db $F2, $0F, $38, $F1, $5F, $04 - db $F2, $0F, $38, $F1, $4F, $08 - db $F2, $0F, $38, $F1, $57, $0C -{$endif} add edi, 16 - dec ebp - jnz @s - mov dword ptr[esi], eax - mov dword ptr[esi + 4], ebx - mov dword ptr[esi + 8], ecx - mov dword ptr[esi + 12], edx -@z: pop ebp - pop edi - pop esi - pop ebx -end; -{$endif CPUX64} -{$endif CPUINTEL} - -procedure crcblocksfast(crc128, data128: PBlock128; count: integer); -{$ifdef PUREPASCAL} // efficient registers use on 64-bit, ARM or PIC -var c: cardinal; - tab: PCrc32tab; -begin - tab := @crc32ctab; - if count>0 then - repeat - c := crc128^[0] xor data128^[0]; - crc128^[0] := tab[3,ToByte(c)] xor tab[2,ToByte(c shr 8)] - xor tab[1,ToByte(c shr 16)] xor tab[0,ToByte(c shr 24)]; - c := crc128^[1] xor data128^[1]; - crc128^[1] := tab[3,ToByte(c)] xor tab[2,ToByte(c shr 8)] - xor tab[1,ToByte(c shr 16)] xor tab[0,ToByte(c shr 24)]; - c := crc128^[2] xor data128^[2]; - crc128^[2] := tab[3,ToByte(c)] xor tab[2,ToByte(c shr 8)] - xor tab[1,ToByte(c shr 16)] xor tab[0,ToByte(c shr 24)]; - c := crc128^[3] xor data128^[3]; - crc128^[3] := tab[3,ToByte(c)] xor tab[2,ToByte(c shr 8)] - xor tab[1,ToByte(c shr 16)] xor tab[0,ToByte(c shr 24)]; - inc(data128); - dec(count); - until count=0; -end; -{$else} // call optimized x86 asm within the loop -begin - while count>0 do begin - crcblockNoSSE42(crc128,data128); - inc(data128); - dec(count); - end; -end; -{$endif PUREPASCAL} - -{$ifdef CPUINTEL} -function crc32cBy4SSE42(crc, value: cardinal): cardinal; -{$ifdef CPU64} {$ifdef FPC}nostackframe; assembler; asm {$else} -asm .noframe {$endif FPC} - mov eax, crc - crc32 eax, value -end; -{$else} {$ifdef FPC}nostackframe; assembler;{$endif} -asm // eax=crc, edx=value - {$ifdef FPC_X86ASM} - crc32 eax, edx - {$else} - db $F2, $0F, $38, $F1, $C2 - {$endif} -end; -{$endif CPU64} - -procedure crcblockSSE42(crc128, data128: PBlock128); -{$ifdef CPU64} {$ifdef FPC}nostackframe; assembler; asm {$else} -asm .noframe // rcx=crc128, rdx=data128 (Linux: rdi,rsi) -{$endif FPC} - mov eax, dword ptr[crc128] // we can't use two qword ptr here - mov r8d, dword ptr[crc128 + 4] - mov r9d, dword ptr[crc128 + 8] - mov r10d, dword ptr[crc128 + 12] - crc32 eax, dword ptr[data128] - crc32 r8d, dword ptr[data128 + 4] - crc32 r9d, dword ptr[data128 + 8] - crc32 r10d, dword ptr[data128 + 12] - mov dword ptr[crc128], eax - mov dword ptr[crc128 + 4], r8d - mov dword ptr[crc128 + 8], r9d - mov dword ptr[crc128 + 12], r10d -end; -{$else} {$ifdef FPC}nostackframe; assembler;{$endif} -asm // eax=crc128, edx=data128 - mov ecx, eax - {$ifdef FPC_X86ASM} - mov eax, dword ptr[ecx] - crc32 eax, dword ptr[edx] - mov dword ptr[ecx], eax - mov eax, dword ptr[ecx + 4] - crc32 eax, dword ptr[edx + 4] - mov dword ptr[ecx + 4], eax - mov eax, dword ptr[ecx + 8] - crc32 eax, dword ptr[edx + 8] - mov dword ptr[ecx + 8], eax - mov eax, dword ptr[ecx + 12] - crc32 eax, dword ptr[edx + 12] - mov dword ptr[ecx + 12], eax - {$else} - mov eax, dword ptr[ecx] - db $F2, $0F, $38, $F1, $02 - mov dword ptr[ecx], eax - mov eax, dword ptr[ecx + 4] - db $F2, $0F, $38, $F1, $42, $04 - mov dword ptr[ecx + 4], eax - mov eax, dword ptr[ecx + 8] - db $F2, $0F, $38, $F1, $42, $08 - mov dword ptr[ecx + 8], eax - mov eax, dword ptr[ecx + 12] - db $F2, $0F, $38, $F1, $42, $0C - mov dword ptr[ecx + 12], eax - {$endif FPC_OR_UNICODE} -end; -{$endif CPU64} -{$endif CPUINTEL} - -function crc32cBy4fast(crc, value: cardinal): cardinal; -var tab: PCrc32tab; -begin - tab := @crc32ctab; - result := crc xor value; - result := tab[3,ToByte(result)] xor - tab[2,ToByte(result shr 8)] xor - tab[1,ToByte(result shr 16)] xor - tab[0,ToByte(result shr 24)]; -end; - -function crc32cinlined(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal; -{$ifdef HASINLINE} -var tab: PCrc32tab; -begin - result := not crc; - if len>0 then begin - tab := @crc32ctab; - repeat - result := tab[0,ToByte(result) xor ord(buf^)] xor (result shr 8); - inc(buf); - dec(len); - until len=0; - end; - result := not result; -end; -{$else} -begin - result := crc32c(crc,buf,len); -end; -{$endif} - -{$ifdef CPUX86} -procedure GetCPUID(Param: Cardinal; var Registers: TRegisters); -{$ifdef FPC}nostackframe; assembler;{$endif} -asm - push esi - push edi - mov esi, edx - mov edi, eax - pushfd - pop eax - mov edx, eax - xor eax, $200000 - push eax - popfd - pushfd - pop eax - xor eax, edx - jz @nocpuid - push ebx - mov eax, edi - xor ecx, ecx - {$ifdef DELPHI5OROLDER} - db $0f, $a2 - {$else} - cpuid - {$endif} - mov TRegisters(esi).&eax, eax - mov TRegisters(esi).&ebx, ebx - mov TRegisters(esi).&ecx, ecx - mov TRegisters(esi).&edx, edx - pop ebx -@nocpuid: - pop edi - pop esi -end; - -function crc32csse42(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal; -{$ifdef FPC}nostackframe; assembler;{$endif} -asm // eax=crc, edx=buf, ecx=len - not eax - test ecx, ecx - jz @0 - test edx, edx - jz @0 - jmp @align - db $8D, $0B4, $26, $00, $00, $00, $00 // manual @by8 align 16 -@a: {$ifdef FPC_X86ASM} - crc32 eax, byte ptr[edx] - {$else} - db $F2, $0F, $38, $F0, $02 - {$endif} - inc edx - dec ecx - jz @0 -@align: test dl, 3 - jnz @a - push ecx - shr ecx, 3 - jnz @by8 -@rem: pop ecx - test cl, 4 - jz @4 - {$ifdef FPC_X86ASM} - crc32 eax, dword ptr[edx] - {$else} - db $F2, $0F, $38, $F1, $02 - {$endif} - add edx, 4 -@4: test cl, 2 - jz @2 - {$ifdef FPC_X86ASM} - crc32 eax, word ptr[edx] - {$else} - db $66, $F2, $0F, $38, $F1, $02 - {$endif} - add edx, 2 -@2: test cl, 1 - jz @0 - {$ifdef FPC_X86ASM} - crc32 eax, byte ptr[edx] - {$else} - db $F2, $0F, $38, $F0, $02 - {$endif} -@0: not eax - ret -@by8: {$ifdef FPC_X86ASM} - crc32 eax, dword ptr[edx] - crc32 eax, dword ptr[edx + 4] - {$else} - db $F2, $0F, $38, $F1, $02 - db $F2, $0F, $38, $F1, $42, $04 - {$endif} - add edx, 8 - dec ecx - jnz @by8 - jmp @rem -end; -{$endif CPUX86} - -function crc32cUTF8ToHex(const str: RawUTF8): RawUTF8; -begin - result := CardinalToHex(crc32c(0,pointer(str),length(str))); -end; - -function crc64c(buf: PAnsiChar; len: cardinal): Int64; -var hilo: Int64Rec absolute result; -begin - hilo.Lo := crc32c(0,buf,len); - hilo.Hi := crc32c(hilo.Lo,buf,len); -end; - -function crc63c(buf: PAnsiChar; len: cardinal): Int64; -var hilo: Int64Rec absolute result; -begin - hilo.Lo := crc32c(0,buf,len); - hilo.Hi := crc32c(hilo.Lo,buf,len) and $7fffffff; -end; - -procedure crc128c(buf: PAnsiChar; len: cardinal; out crc: THash128); -var h: THash128Rec absolute crc; - h1,h2: cardinal; -begin // see https://goo.gl/Pls5wi - h1 := crc32c(0,buf,len); - h2 := crc32c(h1,buf,len); - h.i0 := h1; inc(h1,h2); - h.i1 := h1; inc(h1,h2); - h.i2 := h1; inc(h1,h2); - h.i3 := h1; -end; - -function IsZero(const dig: THash128): boolean; -var a: TPtrIntArray absolute dig; -begin - result := a[0] or a[1] {$ifndef CPU64}or a[2] or a[3]{$endif} = 0; -end; - -function IsEqual(const A,B: THash128): boolean; -var a_: TPtrIntArray absolute A; - b_: TPtrIntArray absolute B; -begin // uses anti-forensic time constant "xor/or" pattern - result := ((a_[0] xor b_[0]) or (a_[1] xor b_[1]) - {$ifndef CPU64} or (a_[2] xor b_[2]) or (a_[3] xor b_[3]){$endif})=0; -end; - -procedure FillZero(out dig: THash128); -var d: TInt64Array absolute dig; -begin - d[0] := 0; - d[1] := 0; -end; - -function Hash128Index(P: PHash128Rec; Count: integer; h: PHash128Rec): integer; -{$ifdef CPU64} -var _0, _1: PtrInt; -begin - if P<>nil then begin - _0 := h^.Lo; - _1 := h^.Hi; - for result := 0 to Count-1 do - if (P^.Lo=_0) and (P^.Hi=_1) then - exit else - inc(P); - end; - result := -1; // not found -end; -{$else} -begin // fast O(n) brute force search - if P<>nil then - for result := 0 to Count-1 do - if (P^.i0=h^.i0) and (P^.i1=h^.i1) and (P^.i2=h^.i2) and (P^.i3=h^.i3) then - exit else - inc(P); - result := -1; // not found -end; -{$endif CPU64} - -function IP4Text(ip4: cardinal): shortstring; -var b: array[0..3] of byte absolute ip4; -begin - if ip4=0 then - result := '' else - FormatShort('%.%.%.%',[b[0],b[1],b[2],b[3]],result); -end; - -procedure IP6Text(ip6: PHash128; result: PShortString); -var i: integer; - p: PByte; - {$ifdef PUREPASCAL}tab: ^TByteToWord;{$endif} -begin - if IsZero(ip6^) then - result^ := '' else begin - result^[0] := AnsiChar(39); - p := @result^[1]; - {$ifdef PUREPASCAL}tab := @TwoDigitsHexWBLower;{$endif} - for i := 0 to 7 do begin - PWord(p)^ := {$ifdef PUREPASCAL}tab{$else}TwoDigitsHexWBLower{$endif}[ip6^[0]]; inc(p,2); - PWord(p)^ := {$ifdef PUREPASCAL}tab{$else}TwoDigitsHexWBLower{$endif}[ip6^[1]]; inc(p,2); - inc(PWord(ip6)); - p^ := ord(':'); inc(p); - end; - end; -end; - -function IP6Text(ip6: PHash128): shortstring; -begin - IP6Text(ip6, @result); -end; - -function IsZero(const dig: THash160): boolean; -var a: TIntegerArray absolute dig; -begin - result := a[0] or a[1] or a[2] or a[3] or a[4] = 0; -end; - -function IsEqual(const A,B: THash160): boolean; -var a_: TIntegerArray absolute A; - b_: TIntegerArray absolute B; -begin // uses anti-forensic time constant "xor/or" pattern - result := ((a_[0] xor b_[0]) or (a_[1] xor b_[1]) or (a_[2] xor b_[2]) or - (a_[3] xor b_[3]) or (a_[4] xor b_[4]))=0; -end; - -procedure FillZero(out dig: THash160); -begin - PInt64Array(@dig)^[0] := 0; - PInt64Array(@dig)^[1] := 0; - PIntegerArray(@dig)^[4] := 0; -end; - -procedure crc256c(buf: PAnsiChar; len: cardinal; out crc: THash256); -var h: THash256Rec absolute crc; - h1,h2: cardinal; -begin // see https://goo.gl/Pls5wi - h1 := crc32c(0,buf,len); - h2 := crc32c(h1,buf,len); - h.i0 := h1; inc(h1,h2); - h.i1 := h1; inc(h1,h2); - h.i2 := h1; inc(h1,h2); - h.i3 := h1; inc(h1,h2); - h.i4 := h1; inc(h1,h2); - h.i5 := h1; inc(h1,h2); - h.i6 := h1; inc(h1,h2); - h.i7 := h1; -end; - -function IsZero(const dig: THash256): boolean; -var a: TPtrIntArray absolute dig; -begin - result := a[0] or a[1] or a[2] or a[3] - {$ifndef CPU64} or a[4] or a[5] or a[6] or a[7]{$endif} = 0; -end; - -function IsEqual(const A,B: THash256): boolean; -var a_: TPtrIntArray absolute A; - b_: TPtrIntArray absolute B; -begin // uses anti-forensic time constant "xor/or" pattern - result := ((a_[0] xor b_[0]) or (a_[1] xor b_[1]) or - (a_[2] xor b_[2]) or (a_[3] xor b_[3]) - {$ifndef CPU64} or (a_[4] xor b_[4]) or (a_[5] xor b_[5]) - or (a_[6] xor b_[6]) or (a_[7] xor b_[7]) {$endif})=0; -end; - -function Hash256Index(P: PHash256Rec; Count: integer; h: PHash256Rec): integer; -{$ifdef CPU64} -var _0, _1: PtrInt; -begin // fast O(n) brute force search - if P<>nil then begin - _0 := h^.d0; - _1 := h^.d1; - for result := 0 to Count-1 do - if (P^.d0=_0) and (P^.d1=_1) and (P^.d2=h^.d2) and (P^.d3=h^.d3) then - exit else - inc(P); - end; - result := -1; // not found -end; -{$else} -begin - if P<>nil then - for result := 0 to Count-1 do - if (P^.i0=h^.i0) and (P^.i1=h^.i1) and (P^.i2=h^.i2) and (P^.i3=h^.i3) and - (P^.i4=h^.i4) and (P^.i5=h^.i5) and (P^.i6=h^.i6) and (P^.i7=h^.i7) then - exit else - inc(P); - result := -1; // not found -end; -{$endif CPU64} - -procedure FillZero(out dig: THash256); -var d: TInt64Array absolute dig; -begin - d[0] := 0; - d[1] := 0; - d[2] := 0; - d[3] := 0; -end; - -function IsZero(const dig: THash384): boolean; -var a: TPtrIntArray absolute dig; -begin - result := a[0] or a[1] or a[2] or a[3] or a[4] or a[5] - {$ifndef CPU64} or a[6] or a[7] or a[8] or a[9] or a[10] or a[11] {$endif} = 0; -end; - -function IsEqual(const A,B: THash384): boolean; -var a_: TPtrIntArray absolute A; - b_: TPtrIntArray absolute B; -begin // uses anti-forensic time constant "xor/or" pattern - result := ((a_[0] xor b_[0]) or (a_[1] xor b_[1]) or - (a_[2] xor b_[2]) or (a_[3] xor b_[3]) or - (a_[4] xor b_[4]) or (a_[5] xor b_[5]) - {$ifndef CPU64} or (a_[6] xor b_[6]) or (a_[7] xor b_[7]) - or (a_[8] xor b_[8]) or (a_[9] xor b_[9]) - or (a_[10] xor b_[10]) or (a_[11] xor b_[11]) {$endif})=0; -end; - -procedure FillZero(out dig: THash384); -var d: TInt64Array absolute dig; -begin - d[0] := 0; - d[1] := 0; - d[2] := 0; - d[3] := 0; - d[4] := 0; - d[5] := 0; -end; - -function IsZero(const dig: THash512): boolean; -var a: TPtrIntArray absolute dig; -begin - result := a[0] or a[1] or a[2] or a[3] or a[4] or a[5] or a[6] or a[7] {$ifndef CPU64} - or a[8] or a[9] or a[10] or a[11] or a[12] or a[13] or a[14] or a[15] {$endif} = 0; -end; - -function IsEqual(const A,B: THash512): boolean; -var a_: TPtrIntArray absolute A; - b_: TPtrIntArray absolute B; -begin // uses anti-forensic time constant "xor/or" pattern - result := ((a_[0] xor b_[0]) or (a_[1] xor b_[1]) or - (a_[2] xor b_[2]) or (a_[3] xor b_[3]) or - (a_[4] xor b_[4]) or (a_[5] xor b_[5]) or - (a_[6] xor b_[6]) or (a_[7] xor b_[7]) - {$ifndef CPU64} or (a_[8] xor b_[8]) or (a_[9] xor b_[9]) - or (a_[10] xor b_[10]) or (a_[11] xor b_[11]) - or (a_[12] xor b_[12]) or (a_[13] xor b_[13]) - or (a_[14] xor b_[14]) or (a_[15] xor b_[15]) {$endif})=0; -end; - -procedure FillZero(out dig: THash512); -var d: TInt64Array absolute dig; -begin - d[0] := 0; - d[1] := 0; - d[2] := 0; - d[3] := 0; - d[4] := 0; - d[5] := 0; - d[6] := 0; - d[7] := 0; -end; - -procedure crc512c(buf: PAnsiChar; len: cardinal; out crc: THash512); -var h: THash512Rec absolute crc; - h1,h2: cardinal; -begin // see https://goo.gl/Pls5wi - h1 := crc32c(0,buf,len); - h2 := crc32c(h1,buf,len); - h.i0 := h1; inc(h1,h2); - h.i1 := h1; inc(h1,h2); - h.i2 := h1; inc(h1,h2); - h.i3 := h1; inc(h1,h2); - h.i4 := h1; inc(h1,h2); - h.i5 := h1; inc(h1,h2); - h.i6 := h1; inc(h1,h2); - h.i7 := h1; inc(h1,h2); - h.i8 := h1; inc(h1,h2); - h.i9 := h1; inc(h1,h2); - h.i10 := h1; inc(h1,h2); - h.i11 := h1; inc(h1,h2); - h.i12 := h1; inc(h1,h2); - h.i13 := h1; inc(h1,h2); - h.i14 := h1; inc(h1,h2); - h.i15 := h1; -end; - -procedure FillZero(var secret: RawByteString); -begin - if secret<>'' then - with PStrRec(Pointer(PtrInt(secret)-STRRECSIZE))^ do - if refCnt=1 then // avoid GPF if const - FillCharFast(pointer(secret)^,length,0); -end; - -procedure FillZero(var secret: RawUTF8); -begin - if secret<>'' then - with PStrRec(Pointer(PtrInt(secret)-STRRECSIZE))^ do - if refCnt=1 then // avoid GPF if const - FillCharFast(pointer(secret)^,length,0); -end; - -procedure mul64x64(const left, right: QWord; out product: THash128Rec); -{$ifdef CPUX64} {$ifdef FPC}nostackframe; assembler; asm {$else} -asm .noframe // rcx/rdi=left, rdx/rsi=right r8/rdx=product -{$endif}{$ifdef WIN64} - mov rax, rcx - mul rdx // uses built-in 64-bit -> 128-bit multiplication -{$else} mov r8, rdx - mov rax, rdi - mul rsi -{$endif}mov qword ptr [r8], rax - mov qword ptr [r8+8], rdx -end; -{$else} -{$ifdef CPUX86} {$ifdef FPC} nostackframe; assembler; {$endif} -asm // adapted from FPC compiler output, which is much better than Delphi's here - {$ifdef FPC} - push ebp - mov ebp, esp - {$endif FPC} - mov ecx, eax - mov eax, dword ptr [ebp+8H] - mul dword ptr [ebp+10H] - mov dword ptr [ecx], eax - mov dword ptr [ebp-4H], edx - mov eax, dword ptr [ebp+8H] - mul dword ptr [ebp+14H] - add eax, dword ptr [ebp-4H] - adc edx, 0 - mov dword ptr [ebp-10H], eax - mov dword ptr [ebp-0CH], edx - mov eax, dword ptr [ebp+0CH] - mul dword ptr [ebp+10H] - add eax, dword ptr [ebp-10H] - adc edx, 0 - mov dword ptr [ecx+4H], eax - mov dword ptr [ebp-14H], edx - mov eax, dword ptr [ebp+0CH] - mul dword ptr [ebp+14H] - add eax, dword ptr [ebp-0CH] - adc edx, 0 - add eax, dword ptr [ebp-14H] - adc edx, 0 - mov dword ptr [ecx+8H], eax - mov dword ptr [ecx+0CH], edx - {$ifdef FPC} - pop ebp - {$endif FPC} -end; -{$else} // CPU-neutral implementation -var l: TQWordRec absolute left; - r: TQWordRec absolute right; - t1,t2,t3: TQWordRec; -begin - t1.V := QWord(l.L)*r.L; - t2.V := QWord(l.H)*r.L+t1.H; - t3.V := QWord(l.L)*r.H+t2.L; - product.H := QWord(l.H)*r.H+t2.H+t3.H; - product.L := t3.V shl 32 or t1.L; -end; -{$endif CPUX86} -{$endif CPUX64} - -{$ifndef ABSOLUTEPASCAL} -{$ifdef CPUX64} -const - // non-temporal writes should bypass the cache when the size is bigger than - // half the size of the largest level cache - we assume low 1MB cache here - CPUCACHEX64 = 512*1024; - -{ - regarding benchmark numbers from TTestLowLevelCommon.CustomRTL - -> FillCharFast/MoveFast are faster, especially for small lengths (strings) - -> Delphi RTL is lower than FPC's, and it doesn't support AVX assembly yet - -> cpuERMS - of little benefit - is disabled, unless WITH_ERMS is defined - http://blog.synopse.info/post/2020/02/17/New-move/fillchar-optimized-sse2/avx-asm-version -} - -// these stand-alone functions will use CPUIDX64 to adjust the algorithm -procedure MoveFast(const src; var dst; cnt: PtrInt); -{$ifdef FPC}nostackframe; assembler; -asm {$else} asm .noframe {$endif} // rcx/rdi=src rdx/rsi=dst r8/rdx=cnt - {$ifdef WIN64} - mov rax, r8 - {$else} - mov rax, rdx // rax=r8=cnt - mov r8, rdx - {$endif} - lea r10, [rip+@jmptab] - cmp src, dst - je @equal - cmp cnt, 32 - ja @lrg // >32 or <0 - sub rax, 8 - jg @sml // 9..32 - jmp qword ptr[r10 + 64 + rax * 8] // 0..8 -@equal: ret -{$ifdef FPC} align 8 {$else} .align 8 {$endif} -@jmptab:dq @exit, @01, @02, @03, @04, @05, @06, @07, @08 -@sml: mov r8, qword ptr[src + rax] // last 8 - mov r9, qword ptr[src] // first 8 - cmp al, 8 - jle @sml16 - mov r10, qword ptr[src + 8] // second 8 - cmp al, 16 - jle @sml24 - mov r11, qword ptr[src + 16] // third 8 - mov qword ptr[dst + 16], r11 // third 8 -@sml24: mov qword ptr[dst + 8], r10 // second 8 -@sml16: mov qword ptr[dst], r9 // first 8 - mov qword ptr[dst + rax], r8 // last 8 (may be overlapping) - ret -@02: movzx eax, word ptr[src] // use small size moves as code alignment - mov word ptr[dst], ax - ret -@04: mov eax, [src] - mov dword ptr[dst], eax - ret -@08: mov rax, [src] - mov [dst], rax -@exit: ret -@lrg: jng @exit // cnt < 0 - cmp src, dst - ja @lrgfwd - sub dst, rax - cmp src, dst - lea dst, [dst + rax] - ja @lrgbwd -@lrgfwd:{$ifdef WITH_ERMS} - test byte ptr[rip+CPUIDX64], 1 shl cpuERMS - jz @nofwe - cmp rax, 2048 - jb @nofwe - cld -@repmov:{$ifdef WIN64} - push rsi - push rdi - mov rsi, src - mov rdi, dst - mov rcx, r8 - rep movsb - pop rdi - pop rsi - {$else} - mov rax, dst // dst=rsi and src=rdi -> rax to swap - mov rsi, src - mov rdi, rax - mov rcx, r8 - rep movsb - {$endif} - ret -@nofwe: {$endif WITH_ERMS} - mov r9, dst - {$ifdef FPC} // no AVX asm on Delphi :( - cmp rax, 256 // vzeroupper penaly for cnt>255 - jb @fsse2 - test byte ptr[rip+CPUIDX64], 1 shl cpuAVX - jnz @fwdavx - {$endif FPC} -@fsse2: movups xmm2, oword ptr[src] // first 16 - lea src, [src + rax - 16] - lea rax, [rax + dst - 16] - movups xmm1, oword ptr[src] // last 16 - mov r10, rax - neg rax - and dst, -16 // 16-byte aligned writes - lea rax, [rax + dst + 16] - cmp r8, CPUCACHEX64 - ja @fwdnv // bypass cache for cnt>512KB -{$ifdef FPC} align 16 {$else} .align 16 {$endif} -@fwd: movups xmm0, oword ptr[src + rax] // regular loop - movaps [r10 + rax], xmm0 - add rax, 16 - jl @fwd -@fwdend:movups [r10], xmm1 // last 16 - movups [r9], xmm2 // first 16 - ret -{$ifdef FPC} align 16 {$else} .align 16 {$endif} -@fwdnv: movups xmm0, oword ptr[src + rax] // non-temporal loop - movntdq [r10 + rax], xmm0 - add rax, 16 - jl @fwdnv - sfence - jmp @fwdend -{$ifdef FPC} -@fwdavx:vmovups ymm2, oword ptr[src] // first 32 - lea src, [src + rax - 32] - lea rax, [rax + dst - 32] - vmovups ymm1, oword ptr[src] // last 32 - mov r10, rax - neg rax - and dst, -32 // 32-byte aligned writes - lea rax, [rax + dst + 32] - cmp r8, CPUCACHEX64 - ja @favxn // bypass cache for cnt>512KB - align 16 -@favxr: vmovups ymm0, oword ptr[src + rax] // regular loop - vmovaps [r10 + rax], ymm0 - add rax, 32 - jl @favxr -@favxe: vmovups [r10], ymm1 // last 32 - vmovups [r9], ymm2 // first 32 -// https://software.intel.com/en-us/articles/avoiding-avx-sse-transition-penalties - vzeroupper - ret - align 16 -@favxn: vmovups ymm0, oword ptr[src + rax] // non-temporal loop - vmovntps [r10 + rax], ymm0 - add rax, 32 - jl @favxn - sfence - jmp @favxe -{$endif FPC} -@lrgbwd:{$ifdef WITH_ERMS} // backward move - test byte ptr[rip+CPUIDX64], 1 shl cpuERMS - jz @nobwe - cmp rax, 2048 - jb @nobwe - std - lea src, [src + rax - 1] - lea dst, [dst + rax - 1] - jmp @repmov -@nobwe: {$endif WITH_ERMS} - {$ifdef FPC} - cmp rax, 256 - jb @bsse2 - test byte ptr[rip+CPUIDX64], 1 shl cpuAVX - jnz @bwdavx - {$endif FPC} -@bsse2: sub rax, 16 - mov r9, rax - movups xmm2, oword ptr[src + rax] // last 16 - movups xmm1, oword ptr[src] // first 16 - add rax, dst - and rax, -16 // 16-byte aligned writes - sub rax, dst - cmp r8, CPUCACHEX64 - ja @bwdnv // bypass cache for cnt>512KB -{$ifdef FPC} align 16 {$else} .align 16 {$endif} -@bwd: movups xmm0, oword ptr[src + rax] // regular loop - movaps oword ptr[dst + rax], xmm0 - sub rax, 16 - jg @bwd -@bwdend:movups oword ptr[dst], xmm1 // first 16 - movups oword ptr[dst + r9], xmm2 // last 16 - ret -@01: mov al, byte ptr[src] - mov byte ptr[dst], al - ret -{$ifdef FPC} align 16 {$else} .align 16 {$endif} -@bwdnv: movups xmm0, oword ptr[src + rax] // non-temporal loop - movntdq oword ptr[dst + rax], xmm0 - sub rax, 16 - jg @bwdnv - sfence - jmp @bwdend -{$ifdef FPC} -@bwdavx:sub rax, 32 - mov r9, rax - vmovups ymm2, oword ptr[src + rax] // last 32 - vmovups ymm1, oword ptr[src] // first 32 - add rax, dst - and rax, -32 // 32-byte aligned writes - sub rax, dst - cmp r8, CPUCACHEX64 - ja @bavxn // bypass cache for cnt>512KB - align 16 -@bavxr: vmovups ymm0, oword ptr[src + rax] // regular loop - vmovaps oword ptr[dst + rax], ymm0 - sub rax, 32 - jg @bavxr -@bavxe: vmovups oword ptr[dst], ymm1 // first 32 - vmovups oword ptr[dst + r9], ymm2 // last 32 - vzeroupper - ret - align 16 -@bavxn: vmovups ymm0, oword ptr[src + rax] // non-temporal loop - vmovntps oword ptr[dst + rax], ymm0 - sub rax, 32 - jg @bavxn - sfence - jmp @bavxe -{$endif FPC} -@03: movzx eax, word ptr[src] - mov cl, byte ptr[src + 2] - mov word ptr[dst], ax - mov byte ptr[dst + 2], cl - ret -@05: mov eax, dword ptr[src] - mov cl, byte ptr[src + 4] - mov dword ptr[dst], eax - mov byte ptr[dst + 4], cl - ret -@06: mov eax, dword ptr[src] - mov cx, word ptr[src + 4] - mov dword ptr[dst], eax - mov word ptr[dst + 4], cx - ret -@07: mov r8d, dword ptr[src] // faster with no overlapping - mov ax, word ptr[src + 4] - mov cl, byte ptr[src + 6] - mov dword ptr[dst], r8d - mov word ptr[dst + 4], ax - mov byte ptr[dst + 6], cl -end; - -procedure FillCharFast(var dst; cnt: PtrInt; value: byte); -{$ifdef FPC}nostackframe; assembler; -asm {$else} asm .noframe {$endif} // rcx/rdi=dst rdx/rsi=cnt r8b/dl=val - mov r9, $0101010101010101 - lea r10, [rip+@jmptab] - {$ifdef WIN64} - movzx eax, r8b - {$else} - movzx eax, dl - mov rdx, rsi // rdx=cnt - {$endif} - imul rax, r9 // broadcast value into all bytes of rax (in 1 cycle) - cmp cnt, 32 - ja @abv32 // >32 or <0 - sub rdx, 8 - jg @sml // small 9..32 - jmp qword ptr[r10 + 64 + rdx*8] // tiny 0..8 bytes -{$ifdef FPC} align 8 {$else} .align 8 {$endif} -@jmptab:dq @00, @01, @02, @03, @04, @05, @06, @07, @08 -@sml: cmp dl, 8 // 9..32 bytes - jle @sml16 - cmp dl, 16 - jle @sml24 - mov qword ptr[dst+16], rax -@sml24: mov qword ptr[dst+8], rax -@sml16: mov qword ptr[dst+rdx], rax // last 8 (may be overlapping) -@08: mov qword ptr[dst], rax -@00: ret -@07: mov dword ptr[dst+3], eax -@03: mov word ptr[dst+1], ax -@01: mov byte ptr[dst], al - ret -@06: mov dword ptr[dst+2], eax -@02: mov word ptr[dst], ax - ret -@05: mov byte ptr[dst+4], al -@04: mov dword ptr[dst], eax - ret -{$ifdef FPC} align 8{$else} .align 8{$endif} -@abv32: jng @00 // < 0 - movd xmm0, eax - lea r8, [dst+cnt] // r8 point to end - pshufd xmm0, xmm0, 0 // broadcast value into all bytes of xmm0 - mov r10, rdx // save rdx=cnt - {$ifdef FPC} // Delphi doesn't support avx, and erms is slower - cmp rdx, 256 - jae @abv256 // try erms or avx if cnt>255 (vzeroupper penalty) - {$endif FPC} -@sse2: movups oword ptr[dst], xmm0 // first unaligned 16 bytes - lea rdx, [dst+rdx-1] - and rdx, -16 - add dst, 16 - and dst, -16 // dst is 16-bytes aligned - sub dst, rdx - jnb @last - cmp r10, CPUCACHEX64 - ja @nv // bypass cache for cnt>512KB -{$ifdef FPC} align 16 {$else} .align 16 {$endif} -@reg: movaps oword ptr[rdx+dst], xmm0 // regular loop - add dst, 16 - jnz @reg -@last: movups oword ptr[r8-16], xmm0 // last unaligned 16 bytes - ret -{$ifdef FPC} align 16 {$else} .align 16 {$endif} -@nv: movntdq [rdx+dst], xmm0 // non-temporal loop - add dst, 16 - jnz @nv - sfence - movups oword ptr[r8-16], xmm0 - ret -{$ifdef FPC} -@abv256:{$ifdef WITH_ERMS} - mov r9b, byte ptr[rip+CPUIDX64] - test r9b, 1 shl cpuERMS - jz @noerms - cmp rdx, 2048 // ERMS is worth it for cnt>2KB - jb @noerms - cmp rdx, CPUCACHEX64 // non-temporal moves are still faster - jae @noerms - cld -{$ifdef WIN64} - mov r8, rdi - mov rdi, dst - mov rcx, cnt - rep stosb - mov rdi, r8 -{$else} mov rcx, cnt - rep stosb -{$endif}ret -@noerms:test r9b, 1 shl cpuAVX -{$else} test byte ptr[rip+CPUIDX64], 1 shl cpuAVX - {$endif WITH_ERMS} - jz @sse2 - movups oword ptr[dst], xmm0 // first unaligned 1..16 bytes - add dst, 16 - and dst, -16 - movaps oword ptr[dst], xmm0 // aligned 17..32 bytes - vinsertf128 ymm0,ymm0,xmm0,1 - add dst, 16 - and dst, -32 // dst is 32-bytes aligned - mov rdx, r8 - and rdx, -32 - sub dst, rdx - cmp r10, CPUCACHEX64 - ja @avxnv - align 16 -@avxreg:vmovaps ymmword ptr[rdx+dst], ymm0 // regular loop - add dst, 32 - jnz @avxreg -@avxok: vmovups oword ptr[r8-32], ymm0 // last unaligned 32 bytes - vzeroupper - ret - align 16 -@avxnv: vmovntps oword ptr [rdx+dst], ymm0 // non-temporal loop - add dst, 32 - jnz @avxnv - sfence - jmp @avxok -{$endif FPC} -end; -{$endif CPUX64} -{$endif ABSOLUTEPASCAL} - -procedure SymmetricEncrypt(key: cardinal; var data: RawByteString); -var i,len: integer; - d: PCardinal; - tab: PCrc32tab; -begin - if data='' then - exit; // nothing to cypher - tab := @crc32ctab; - {$ifdef FPC} - UniqueString(data); // @data[1] won't call UniqueString() under FPC :( - {$endif} - d := @data[1]; - len := length(data); - key := key xor cardinal(len); - for i := 0 to (len shr 2)-1 do begin - key := key xor tab[0,(cardinal(i) xor key)and 1023]; - d^ := d^ xor key; - inc(d); - end; - for i := 0 to (len and 3)-1 do - PByteArray(d)^[i] := PByteArray(d)^[i] xor key xor tab[0,17 shl i]; -end; - -function UnixTimeToDateTime(const UnixTime: TUnixTime): TDateTime; -begin - result := UnixTime / SecsPerDay + UnixDateDelta; -end; - -function DateTimeToUnixTime(const AValue: TDateTime): TUnixTime; -begin - result := Round((AValue - UnixDateDelta) * SecsPerDay); -end; - -const - UnixFileTimeDelta = 116444736000000000; // from year 1601 to 1970 - DateFileTimeDelta = 94353120000000000; // from year 1601 to 1899 - -{$ifdef MSWINDOWS} -function FileTimeToUnixTime(const FT: TFileTime): TUnixTime; -{$ifdef CPU64}var nano100: Int64;{$endif} -begin - {$ifdef CPU64} - FileTimeToInt64(ft,nano100); - result := (nano100-UnixFileTimeDelta) div 10000000; - {$else} // use PInt64 to avoid URW699 with Delphi 6 / Kylix - result := (PInt64(@ft)^-UnixFileTimeDelta) div 10000000; - {$endif} -end; - -function FileTimeToUnixMSTime(const FT: TFileTime): TUnixMSTime; -{$ifdef CPU64}var nano100: Int64;{$endif} -begin - {$ifdef CPU64} - FileTimeToInt64(ft,nano100); - result := (nano100-UnixFileTimeDelta) div 10000; - {$else} // use PInt64 to avoid URW699 with Delphi 6 / Kylix - result := (PInt64(@ft)^-UnixFileTimeDelta) div 10000; - {$endif} -end; - -function UnixTimeUTC: TUnixTime; -var ft: TFileTime; -begin - GetSystemTimeAsFileTime(ft); // very fast, with 100 ns unit - result := FileTimeToUnixTime(ft); -end; - -function UnixMSTimeUTC: TUnixMSTime; -var ft: TFileTime; -begin - GetSystemTimePreciseAsFileTime(ft); // slower, but try to achieve ms resolution - result := FileTimeToUnixMSTime(ft); -end; - -function UnixMSTimeUTCFast: TUnixMSTime; -var ft: TFileTime; -begin - GetSystemTimeAsFileTime(ft); // faster, but with HW interupt resolution - result := FileTimeToUnixMSTime(ft); -end; -{$else MSWINDOWS} -function UnixTimeUTC: TUnixTime; -begin - result := GetUnixUTC; // direct retrieval from UNIX API -end; - -function UnixMSTimeUTC: TUnixMSTime; -begin - result := GetUnixMSUTC; // direct retrieval from UNIX API -end; - -function UnixMSTimeUTCFast: TUnixMSTime; -begin - result := GetUnixMSUTC; // direct retrieval from UNIX API -end; -{$endif MSWINDOWS} - -function DaysToIso8601(Days: cardinal; Expanded: boolean): RawUTF8; -var Y,M: cardinal; -begin - Y := 0; - while Days>365 do begin - dec(Days,366); - inc(Y); - end; - M := 0; - if Days>31 then begin - inc(M); - while Days>MonthDays[false][M] do begin - dec(Days,MonthDays[false][M]); - inc(M); - end; - end; - result := DateToIso8601(Y,M,Days,Expanded); -end; - -function UnixTimeToString(const UnixTime: TUnixTime; Expanded: boolean; - FirstTimeChar: AnsiChar): RawUTF8; -begin // inlined UnixTimeToDateTime - result := DateTimeToIso8601(UnixTime/SecsPerDay+UnixDateDelta,Expanded, - FirstTimeChar,false); -end; - -function DateTimeToFileShort(const DateTime: TDateTime): TShort16; -begin - DateTimeToFileShort(DateTime,result); -end; - -procedure DateTimeToFileShort(const DateTime: TDateTime; out result: TShort16); -var T: TSynSystemTime; - tab: {$ifdef CPUX86NOTPIC}TWordArray absolute TwoDigitLookupW{$else}PWordArray{$endif}; -begin // use 'YYMMDDHHMMSS' format - if DateTime<=0 then begin - PWord(@result[0])^ := 1+ord('0') shl 8; - exit; - end; - T.FromDate(DateTime); - if T.Year > 1999 then - if T.Year < 2100 then - dec(T.Year,2000) else - T.Year := 99 else - T.Year := 0; - T.FromTime(DateTime); - {$ifndef CPUX86NOTPIC}tab := @TwoDigitLookupW;{$endif} - result[0] := #12; - PWord(@result[1])^ := tab[T.Year]; - PWord(@result[3])^ := tab[T.Month]; - PWord(@result[5])^ := tab[T.Day]; - PWord(@result[7])^ := tab[T.Hour]; - PWord(@result[9])^ := tab[T.Minute]; - PWord(@result[11])^ := tab[T.Second]; -end; - -procedure UnixTimeToFileShort(const UnixTime: TUnixTime; out result: TShort16); -begin // use 'YYMMDDHHMMSS' format - if UnixTime<=0 then - PWord(@result[0])^ := 1+ord('0') shl 8 else - DateTimeToFileShort(UnixTime/SecsPerDay+UnixDateDelta, result); -end; - -function UnixTimeToFileShort(const UnixTime: TUnixTime): TShort16; -begin - UnixTimeToFileShort(UnixTime, result); -end; - -function UnixMSTimeToFileShort(const UnixMSTime: TUnixMSTime): TShort16; -begin - UnixTimeToFileShort(UnixMSTime div MSecsPerSec, result); -end; - -function UnixTimePeriodToString(const UnixTime: TUnixTime; FirstTimeChar: AnsiChar): RawUTF8; -begin - if UnixTime0; - end else - result := false; -end; - -function Char2ToByte(P: PUTF8Char; out Value: Cardinal): Boolean; -var B: PtrUInt; -begin - B := ConvertHexToBin[ord(P[0])]; - if B<=9 then begin - Value := B; - B := ConvertHexToBin[ord(P[1])]; - if B<=9 then begin - Value := Value*10+B; - result := false; - exit; - end; - end; - result := true; // error -end; - -function Char3ToWord(P: PUTF8Char; out Value: Cardinal): Boolean; -var B: PtrUInt; -begin - B := ConvertHexToBin[ord(P[0])]; - if B<=9 then begin - Value := B; - B := ConvertHexToBin[ord(P[1])]; - if B<=9 then begin - Value := Value*10+B; - B := ConvertHexToBin[ord(P[2])]; - if B<=9 then begin - Value := Value*10+B; - result := false; - exit; - end; - end; - end; - result := true; // error -end; - -function Char4ToWord(P: PUTF8Char; out Value: Cardinal): Boolean; -var B: PtrUInt; -begin - B := ConvertHexToBin[ord(P[0])]; - if B<=9 then begin - Value := B; - B := ConvertHexToBin[ord(P[1])]; - if B<=9 then begin - Value := Value*10+B; - B := ConvertHexToBin[ord(P[2])]; - if B<=9 then begin - Value := Value*10+B; - B := ConvertHexToBin[ord(P[3])]; - if B<=9 then begin - Value := Value*10+B; - result := false; - exit; - end; - end; - end; - end; - result := true; // error -end; - -procedure Iso8601ToDateTimePUTF8CharVar(P: PUTF8Char; L: integer; var result: TDateTime); -var B: cardinal; - Y,M,D, H,MI,SS,MS: cardinal; - d100: TDiv100Rec; - tab: {$ifdef CPUX86NOTPIC}TNormTableByte absolute ConvertHexToBin{$else}PNormTableByte{$endif}; -// expect 'YYYYMMDDThhmmss[.sss]' format but handle also 'YYYY-MM-DDThh:mm:ss[.sss]' -begin - unaligned(result) := 0; - if P=nil then - exit; - if L=0 then - L := StrLen(P); - if L<4 then - exit; // we need 'YYYY' at least - if (P[0]='''') and (P[L-1]='''') then begin // unquote input - inc(P); - dec(L, 2); - if L<4 then exit; - end; - if P[0]='T' then begin - dec(P,8); - inc(L,8); - end else begin - {$ifndef CPUX86NOTPIC}tab := @ConvertHexToBin;{$endif} // faster on PIC and x86_64 - B := tab[ord(P[0])]; // first digit - if B>9 then exit else Y := B; // fast check '0'..'9' - B := tab[ord(P[1])]; - if B>9 then exit else Y := Y*10+B; - B := tab[ord(P[2])]; - if B>9 then exit else Y := Y*10+B; - B := tab[ord(P[3])]; - if B>9 then exit else Y := Y*10+B; - if P[4] in ['-','/'] then begin inc(P); dec(L); end; // allow YYYY-MM-DD - D := 1; - if L>=6 then begin // YYYYMM - M := ord(P[4])*10+ord(P[5])-(48+480); - if (M=0) or (M>12) then exit; - if P[6] in ['-','/'] then begin inc(P); dec(L); end; // allow YYYY-MM-DD - if L>=8 then begin // YYYYMMDD - if (L>8) and not(P[8] in [#0,' ','T']) then - exit; // invalid date format - D := ord(P[6])*10+ord(P[7])-(48+480); - if (D=0) or (D>MonthDays[true][M]) then exit; // worse is leap year=true - end; - end else - M := 1; - if M>2 then // inlined EncodeDate(Y,M,D) - dec(M,3) else - if M>0 then begin - inc(M,9); - dec(Y); - end; - if Y>9999 then - exit; // avoid integer overflow e.g. if '0000' is an invalid date - Div100(Y,d100); - unaligned(result) := (146097*d100.d) shr 2 + (1461*d100.m) shr 2 + - (153*M+2) div 5+D; - unaligned(result) := unaligned(result)-693900; // as float: avoid sign issue - if L<15 then - exit; // not enough space to retrieve the time - end; - H := ord(P[9])*10+ord(P[10])-(48+480); - if P[11]=':' then begin inc(P); dec(L); end;// allow hh:mm:ss - MI := ord(P[11])*10+ord(P[12])-(48+480); - if P[13]=':' then begin inc(P); dec(L); end; // allow hh:mm:ss - SS := ord(P[13])*10+ord(P[14])-(48+480); - if (L>16) and (P[15]='.') then begin - // one or more digits representing a decimal fraction of a second - MS := ord(P[16])*100-4800; - if L>17 then MS := MS+ord(P[17])*10-480; - if L>18 then MS := MS+ord(P[18])-48; - if MS>1000 then - MS := 0; - end else - MS := 0; - if (H<24) and (MI<60) and (SS<60) then // inlined EncodeTime() - result := result+(H*(MinsPerHour*SecsPerMin*MSecsPerSec)+ - MI*(SecsPerMin*MSecsPerSec)+SS*MSecsPerSec+MS)/MSecsPerDay; -end; - -function Iso8601ToTimePUTF8Char(P: PUTF8Char; L: integer): TDateTime; -begin - Iso8601ToTimePUTF8CharVar(P,L,result); -end; - -procedure Iso8601ToTimePUTF8CharVar(P: PUTF8Char; L: integer; var result: TDateTime); -var H,MI,SS,MS: cardinal; -begin - if Iso8601ToTimePUTF8Char(P,L,H,MI,SS,MS) then - result := (H*(MinsPerHour*SecsPerMin*MSecsPerSec)+ - MI*(SecsPerMin*MSecsPerSec)+SS*MSecsPerSec+MS)/MSecsPerDay else - result := 0; -end; - -function Iso8601ToTimePUTF8Char(P: PUTF8Char; L: integer; var H,M,S,MS: cardinal): boolean; -begin - result := false; // error - if P=nil then - exit; - if L=0 then - L := StrLen(P); - if L<6 then - exit; // we need 'hhmmss' at least - H := ord(P[0])*10+ord(P[1])-(48+480); - if P[2]=':' then begin inc(P); dec(L); end; // allow hh:mm:ss - M := ord(P[2])*10+ord(P[3])-(48+480); - if P[4]=':' then begin inc(P); dec(L); end; // allow hh:mm:ss - S := ord(P[4])*10+ord(P[5])-(48+480); - if (L>6) and (P[6]='.') then begin - // one or more digits representing a decimal fraction of a second - MS := ord(P[7])*100-4800; - if L>7 then MS := MS+ord(P[8])*10-480; - if L>8 then MS := MS+ord(P[9])-48; - end else - MS := 0; - if (H<24) and (M<60) and (S<60) and (MS<1000) then - result := true; -end; - -function Iso8601ToDatePUTF8Char(P: PUTF8Char; L: integer; var Y,M,D: cardinal): boolean; -begin - result := false; // error - if P=nil then - exit; - if L=0 then - L := StrLen(P); - if (L<8) or not (P[0] in ['0'..'9']) or not (P[1] in ['0'..'9']) or - not (P[2] in ['0'..'9']) or not (P[3] in ['0'..'9']) then - exit; // we need 'YYYYMMDD' at least - Y := ord(P[0])*1000+ord(P[1])*100+ord(P[2])*10+ord(P[3])-(48+480+4800+48000); - if (Y<1000) or (Y>2999) then - exit; - if P[4] in ['-','/'] then inc(P); // allow YYYY-MM-DD - M := ord(P[4])*10+ord(P[5])-(48+480); - if (M=0) or (M>12) then - exit; - if P[6] in ['-','/'] then inc(P); - D := ord(P[6])*10+ord(P[7])-(48+480); - if (D<>0) and (D<=MonthDays[true][M]) then - result := true; -end; - -function IntervalTextToDateTime(Text: PUTF8Char): TDateTime; -begin - IntervalTextToDateTimeVar(Text,result); -end; - -procedure IntervalTextToDateTimeVar(Text: PUTF8Char; var result: TDateTime); -var negative: boolean; - Time: TDateTime; -begin // e.g. IntervalTextToDateTime('+0 06:03:20') - result := 0; - if Text=nil then - exit; - if Text^ in ['+','-'] then begin - negative := (Text^='-'); - result := GetNextItemDouble(Text,' '); - end else - negative := false; - Iso8601ToTimePUTF8CharVar(Text,0,Time); - if negative then - result := result-Time else - result := result+Time; -end; - -function Iso8601ToDateTime(const S: RawByteString): TDateTime; -begin - result := Iso8601ToDateTimePUTF8Char(pointer(S),length(S)); -end; - -function TimeLogToDateTime(const Timestamp: TTimeLog): TDateTime; -begin - result := PTimeLogBits(@Timestamp)^.ToDateTime; -end; - -function TimeLogToUnixTime(const Timestamp: TTimeLog): TUnixTime; -begin - result := PTimeLogBits(@Timestamp)^.ToUnixTime; -end; - -function DateToIso8601PChar(P: PUTF8Char; Expanded: boolean; Y,M,D: PtrUInt): PUTF8Char; -// use 'YYYYMMDD' format if not Expanded, 'YYYY-MM-DD' format if Expanded -var tab: {$ifdef CPUX86NOTPIC}TWordArray absolute TwoDigitLookupW{$else}PWordArray{$endif}; -begin - {$ifdef CPUX86NOTPIC} - YearToPChar(Y,P); - {$else} - tab := @TwoDigitLookupW; - YearToPChar2(tab,Y,P); - {$endif} - inc(P,4); - if Expanded then begin - P^ := '-'; - inc(P); - end; - PWord(P)^ := tab[M]; - inc(P,2); - if Expanded then begin - P^ := '-'; - inc(P); - end; - PWord(P)^ := tab[D]; - result := P+2; -end; - -function TimeToIso8601PChar(P: PUTF8Char; Expanded: boolean; H,M,S,MS: PtrUInt; - FirstChar: AnsiChar; WithMS: boolean): PUTF8Char; -var tab: {$ifdef CPUX86NOTPIC}TWordArray absolute TwoDigitLookupW{$else}PWordArray{$endif}; -begin // use Thhmmss[.sss] format - if FirstChar<>#0 then begin - P^ := FirstChar; - inc(P); - end; - {$ifndef CPUX86NOTPIC}tab := @TwoDigitLookupW;{$endif} - PWord(P)^ := tab[H]; - inc(P,2); - if Expanded then begin - P^ := ':'; - inc(P); - end; - PWord(P)^ := tab[M]; - inc(P,2); - if Expanded then begin - P^ := ':'; - inc(P); - end; - PWord(P)^ := tab[S]; - inc(P,2); - if WithMS then begin - {$ifdef CPUX86NOTPIC}YearToPChar(MS{$else}YearToPChar2(tab,MS{$endif},P); - P^ := '.'; // override first '0' digit - inc(P,4); - end; - result := P; -end; - -function DateToIso8601PChar(Date: TDateTime; P: PUTF8Char; Expanded: boolean): PUTF8Char; -var T: TSynSystemTime; -begin // use YYYYMMDD / YYYY-MM-DD date format - T.FromDate(Date); - result := DateToIso8601PChar(P,Expanded,T.Year,T.Month,T.Day); -end; - -function DateToIso8601Text(Date: TDateTime): RawUTF8; -begin // into 'YYYY-MM-DD' date format - if Date=0 then - result := '' else begin - FastSetString(result,nil,10); - DateToIso8601PChar(Date,pointer(result),True); - end; -end; - -function TimeToIso8601PChar(Time: TDateTime; P: PUTF8Char; Expanded: boolean; - FirstChar: AnsiChar; WithMS: boolean): PUTF8Char; -var T: TSynSystemTime; -begin - T.FromTime(Time); - result := TimeToIso8601PChar(P,Expanded,T.Hour,T.Minute,T.Second,T.MilliSecond,FirstChar,WithMS); -end; - -function DateTimeToIso8601(P: PUTF8Char; D: TDateTime; Expanded: boolean; - FirstChar: AnsiChar; WithMS: boolean; QuotedChar: AnsiChar): integer; -var S: PUTF8Char; -begin - S := P; - if QuotedChar<>#0 then begin - P^ := QuotedChar; - inc(P); - end; - P := DateToIso8601PChar(D,P,Expanded); - P := TimeToIso8601PChar(D,P,Expanded,FirstChar,WithMS); - if QuotedChar<>#0 then begin - P^ := QuotedChar; - inc(P); - end; - result := P-S; -end; - -function DateTimeToIso8601(D: TDateTime; Expanded: boolean; - FirstChar: AnsiChar; WithMS: boolean; QuotedChar: AnsiChar): RawUTF8; -var tmp: array[0..31] of AnsiChar; -begin // D=0 is handled in DateTimeToIso8601Text() - FastSetString(result,@tmp,DateTimeToIso8601(@tmp,D,Expanded,FirstChar,WithMS,QuotedChar)); -end; - -function DateToIso8601(Date: TDateTime; Expanded: boolean): RawUTF8; -// use YYYYMMDD / YYYY-MM-DD date format -begin - FastSetString(result,nil,8+2*integer(Expanded)); - DateToIso8601PChar(Date,pointer(result),Expanded); -end; - -function DateToIso8601(Y,M,D: cardinal; Expanded: boolean): RawUTF8; -// use 'YYYYMMDD' format if not Expanded, 'YYYY-MM-DD' format if Expanded -begin - FastSetString(result,nil,8+2*integer(Expanded)); - DateToIso8601PChar(pointer(result),Expanded,Y,M,D); -end; - -function TimeToIso8601(Time: TDateTime; Expanded: boolean; FirstChar: AnsiChar; - WithMS: boolean): RawUTF8; -// use Thhmmss[.sss] / Thh:mm:ss[.sss] format -begin - FastSetString(result,nil,7+2*integer(Expanded)+4*integer(WithMS)); - TimeToIso8601PChar(Time,pointer(result),Expanded,FirstChar,WithMS); -end; - -function DateTimeToIso8601Text(DT: TDateTime; FirstChar: AnsiChar; - WithMS: boolean): RawUTF8; -begin - DateTimeToIso8601TextVar(DT,FirstChar,result,WithMS); -end; - -procedure DateTimeToIso8601TextVar(DT: TDateTime; FirstChar: AnsiChar; - var result: RawUTF8; WithMS: boolean); -begin - if DT=0 then - result := '' else - if frac(DT)=0 then - result := DateToIso8601(DT,true) else - if trunc(DT)=0 then - result := TimeToIso8601(DT,true,FirstChar,WithMS) else - result := DateTimeToIso8601(DT,true,FirstChar,WithMS); -end; - -procedure DateTimeToIso8601StringVar(DT: TDateTime; FirstChar: AnsiChar; - var result: string; WithMS: boolean); -var tmp: RawUTF8; -begin - DateTimeToIso8601TextVar(DT,FirstChar,tmp,WithMS); - Ansi7ToString(Pointer(tmp),length(tmp),result); -end; - -function DateTimeToIso8601ExpandedPChar(const Value: TDateTime; Dest: PUTF8Char; - FirstChar: AnsiChar; WithMS: boolean): PUTF8Char; -begin - if Value<>0 then begin - if trunc(Value)<>0 then - Dest := DateToIso8601PChar(Value,Dest,true); - if frac(Value)<>0 then - Dest := TimeToIso8601PChar(Value,Dest,true,FirstChar,WithMS); - end; - Dest^ := #0; - result := Dest; -end; - -function Iso8601ToTimeLogPUTF8Char(P: PUTF8Char; L: integer; ContainsNoTime: PBoolean): TTimeLog; -// bits: S=0..5 M=6..11 H=12..16 D=17..21 M=22..25 Y=26..40 -// i.e. S<64 M<64 H<32 D<32 M<16 Y<9999: power of 2 -> use fast shl/shr -var V,B: PtrUInt; - tab: {$ifdef CPUX86NOTPIC}TNormTableByte absolute ConvertHexToBin{$else}PNormTableByte{$endif}; -begin - result := 0; - if P=nil then - exit; - if L=0 then - L := StrLen(P); - if L<4 then - exit; // we need 'YYYY' at least - if P[0]='T' then - dec(P,8) else begin // 'YYYY' -> year decode - {$ifndef CPUX86NOTPIC}tab := @ConvertHexToBin;{$endif} // faster on PIC/x86_64 - V := tab[ord(P[0])]; - if V>9 then exit; - B := tab[ord(P[1])]; - if B>9 then exit else V := V*10+B; - B := tab[ord(P[2])]; - if B>9 then exit else V := V*10+B; - B := tab[ord(P[3])]; - if B>9 then exit else V := V*10+B; - result := Int64(V) shl 26; // store YYYY - if P[4] in ['-','/'] then begin inc(P); dec(L); end; // allow YYYY-MM-DD - if L>=6 then begin // YYYYMM - V := ord(P[4])*10+ord(P[5])-(48+480+1); // Month 1..12 -> 0..11 - if V<=11 then - inc(result,V shl 22) else begin - result := 0; - exit; - end; - if P[6] in ['-','/'] then begin inc(P); dec(L); end; // allow YYYY-MM-DD - if L>=8 then begin // YYYYMMDD - V := ord(P[6])*10+ord(P[7])-(48+480+1); // Day 1..31 -> 0..30 - if (V<=30) and ((L=8) or (P[8] in [#0,' ','T'])) then - inc(result,V shl 17) else begin - result := 0; - exit; - end; - end; - end; - if L<15 then begin // not enough place to retrieve a time - if ContainsNoTime<>nil then - ContainsNoTime^ := true; - exit; - end; - end; - if ContainsNoTime<>nil then - ContainsNoTime^ := false; - B := ord(P[9])*10+ord(P[10])-(48+480); - if B<=23 then V := B shl 12 else exit; - if P[11]=':' then inc(P); // allow hh:mm:ss - B := ord(P[11])*10+ord(P[12])-(48+480); - if B<=59 then inc(V,B shl 6) else exit; - if P[13]=':' then inc(P); // allow hh:mm:ss - B := ord(P[13])*10+ord(P[14])-(48+480); - if B<=59 then inc(result,PtrUInt(V+B)); -end; - -function IsIso8601(P: PUTF8Char; L: integer): boolean; -begin - result := Iso8601ToTimeLogPUTF8Char(P,L)<>0; -end; - -function DateTimeToi18n(const DateTime: TDateTime): string; -begin - if Assigned(i18nDateTimeText) then - result := i18nDateTimeText(DateTime) else - result := {$ifdef UNICODE}Ansi7ToString{$endif}(DateTimeToIso8601(DateTime,true,' ',true)); -end; - - -{ TTimeLogBits } - -// bits: S=0..5 M=6..11 H=12..16 D=17..21 M=22..25 Y=26..40 -// size: S=6 M=6 H=5 D=5 M=4 Y=12 -// i.e. S<64 M<64 H<32 D<32 M<16 Y<=9999: power of 2 -> use fast shl/shr - -procedure TTimeLogBits.From(Y, M, D, HH, MM, SS: cardinal); -begin - inc(HH,D shl 5+M shl 10+Y shl 14-(1 shl 5+1 shl 10)); - Value := SS+MM shl 6+Int64(HH) shl 12; -end; - -procedure TTimeLogBits.From(P: PUTF8Char; L: integer); -begin - Value := Iso8601ToTimeLogPUTF8Char(P,L); -end; - -procedure TTimeLogBits.Expand(out Date: TSynSystemTime); -var V: PtrUInt; -begin - V := PPtrUint(@Value)^; - Date.Year := {$ifdef CPU32}Value{$else}V{$endif} shr (6+6+5+5+4); - Date.Month := 1+(V shr (6+6+5+5)) and 15; - Date.DayOfWeek := 0; - Date.Day := 1+(V shr (6+6+5)) and 31; - Date.Hour := (V shr (6+6)) and 31; - Date.Minute := (V shr 6) and 63; - Date.Second := V and 63; -end; - -procedure TTimeLogBits.From(const S: RawUTF8); -begin - Value := Iso8601ToTimeLogPUTF8Char(pointer(S),length(S)); -end; - -procedure TTimeLogBits.From(FileDate: integer); -begin -{$ifdef MSWINDOWS} - From(PInt64Rec(@FileDate)^.Hi shr 9+1980, - PInt64Rec(@FileDate)^.Hi shr 5 and 15, - PInt64Rec(@FileDate)^.Hi and 31, - PInt64Rec(@FileDate)^.Lo shr 11, - PInt64Rec(@FileDate)^.Lo shr 5 and 63, - PInt64Rec(@FileDate)^.Lo and 31 shl 1); -{$else} // FileDate depends on the running OS - From(FileDateToDateTime(FileDate)); -{$endif} -end; - -procedure TTimeLogBits.From(DateTime: TDateTime; DateOnly: Boolean); -var T: TSynSystemTime; - V: PtrInt; -begin - T.FromDate(DateTime); - if DateOnly then - T.Hour := 0 else - T.FromTime(DateTime); - V := T.Day shl 5+T.Month shl 10+T.Year shl 14-(1 shl 5+1 shl 10); - Value := V; // circumvent C1093 error on Delphi 5 - Value := Value shl 12; - if not DateOnly then begin - V := T.Second+T.Minute shl 6+T.Hour shl 12; - Value := Value+V; - end; -end; - -procedure TTimeLogBits.FromUnixTime(const UnixTime: TUnixTime); -begin - From(UnixTimeToDateTime(UnixTime)); -end; - -procedure TTimeLogBits.FromUnixMSTime(const UnixMSTime: TUnixMSTime); -begin - From(UnixMSTimeToDateTime(UnixMSTime)); -end; - -procedure TTimeLogBits.From(Time: PSynSystemTime); -var V: PtrInt; -begin - V := Time^.Hour+Time^.Day shl 5+Time^.Month shl 10+Time^.Year shl 14-(1 shl 5+1 shl 10); - Value := V; // circumvent C1093 error on Delphi 5 - V := Time^.Second+Time^.Minute shl 6; - Value := (Value shl 12)+V; -end; - -var // GlobalTime[LocalTime] cache protected using RCU128() - GlobalTime: array[boolean] of record - time: TSystemTime; - clock: PtrInt; // avoid slower API call with 8-16ms loss of precision - end; - -{$ifndef FPC}{$ifdef CPUINTEL} // intrinsic in FPC -procedure ReadBarrier; -asm - {$ifdef CPUX86} - lock add dword ptr [esp], 0 - {$else} - lfence // lfence requires an SSE CPU, which is OK on x86-64 - {$endif} -end; -{$endif}{$endif} - -procedure RCU32(var src,dst); -begin - repeat - Integer(dst) := Integer(src); - ReadBarrier; - until Integer(dst)=Integer(src); -end; - -procedure RCU64(var src,dst); -begin - repeat - Int64(dst) := Int64(src); - ReadBarrier; - until Int64(dst)=Int64(src); -end; - -procedure RCUPtr(var src,dst); -begin - repeat - PtrInt(dst) := PtrInt(src); - ReadBarrier; - until PtrInt(dst)=PtrInt(src); -end; - -procedure RCU128(var src,dst); -var s: THash128Rec absolute src; - d: THash128Rec absolute dst; -begin - repeat - d := s; - ReadBarrier; - until (d.L=s.L) and (d.H=s.H); -end; - -procedure RCU(var src,dst; len: integer); -begin - if len>0 then - repeat - MoveSmall(@src,@dst,len); // per-byte inlined copy - ReadBarrier; - until CompareMemSmall(@src,@dst,len); -end; - -procedure FromGlobalTime(LocalTime: boolean; out NewTime: TSynSystemTime); -var tix: PtrInt; - newtimesys: TSystemTime absolute NewTime; -begin - with GlobalTime[LocalTime] do begin - tix := {$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64 - {$ifndef MSWINDOWS}shr 3{$endif}; // Linux: 8ms refresh - if clock<>tix then begin // Windows: typically in range of 10-16 ms - clock := tix; - NewTime.Clear; - if LocalTime then - GetLocalTime(newtimesys) else - {$ifdef MSWINDOWS}GetSystemTime{$else}GetNowUTCSystem{$endif}(newtimesys); - RCU128(newtimesys,time); - end else - RCU128(time,NewTime); - end; - {$ifndef MSWINDOWS} // those TSystemTime fields are inverted in datih.inc :( - tix := newtimesys.DayOfWeek; - NewTime.Day := newtimesys.Day; - NewTime.DayOfWeek := tix; - {$endif} -end; - -procedure TTimeLogBits.FromUTCTime; -var now: TSynSystemTime; -begin - FromGlobalTime(false,now); - From(@now); -end; - -procedure TTimeLogBits.FromNow; -var now: TSynSystemTime; -begin - FromGlobalTime(true,now); - From(@now); -end; - -function TTimeLogBits.ToTime: TDateTime; -var lo: PtrUInt; -begin - lo := {$ifdef CPU64}Value{$else}PCardinal(@Value)^{$endif}; - if lo and (1 shl (6+6+5)-1)=0 then - result := 0 else - result := EncodeTime((lo shr(6+6))and 31, (lo shr 6)and 63, lo and 63, 0); -end; - -function IsLeapYear(Year: cardinal): boolean; -var d100: TDiv100Rec; -begin - if Year and 3 = 0 then begin - Div100(Year,d100); - result := ((d100.M <> 0) or // (Year mod 100 > 0) - (Year - ((d100.D shr 2) * 400) = 0)); // (Year mod 400 = 0)) - end else - result := false; -end; - -function TryEncodeDate(Year, Month, Day: cardinal; out Date: TDateTime): Boolean; -var d100: TDiv100Rec; -begin // faster version by AB - result := False; - if (Year>0) and (Year<10000) and (Month>0) and (Month<13) and (Day>0) and - (Day <= MonthDays[IsLeapYear(Year)][Month]) then begin - if Month>2 then - dec(Month,3) else - if (Month>0) then begin - inc(Month,9); - dec(Year); - end - else exit; // Month <= 0 - Div100(Year,d100); - Date := (146097*d100.D) shr 2+(1461*d100.M) shr 2+ - (153*Month+2) div 5+Day; - Date := Date-693900; // should be separated to avoid sign issues - result := true; - end; -end; - -function TTimeLogBits.ToDate: TDateTime; -var Y, lo: PtrUInt; -begin - {$ifdef CPU64} - lo := Value; - Y := lo shr (6+6+5+5+4); - {$else} - Y := Value shr (6+6+5+5+4); - lo := PCardinal(@Value)^; - {$endif} - if (Y=0) or not TryEncodeDate(Y,1+(lo shr(6+6+5+5))and 15,1+(lo shr(6+6+5))and 31,result) then - result := 0; -end; - -function TTimeLogBits.ToDateTime: TDateTime; -var Y, lo: PtrUInt; - Time: TDateTime; -begin - {$ifdef CPU64} - lo := Value; - Y := lo shr (6+6+5+5+4); - {$else} - Y := Value shr (6+6+5+5+4); - lo := PCardinal(@Value)^; - {$endif} - if (Y=0) or not TryEncodeDate(Y,1+(lo shr(6+6+5+5))and 15,1+(lo shr(6+6+5))and 31,result) then - result := 0; - if (lo and (1 shl(6+6+5)-1)<>0) and TryEncodeTime((lo shr(6+6)) and 31, - (lo shr 6)and 63, lo and 63, 0, Time) then - result := result+Time; -end; - -function TTimeLogBits.Year: Integer; -begin - result := Value shr (6+6+5+5+4); -end; - -function TTimeLogBits.Month: Integer; -begin - result := 1+(PCardinal(@Value)^ shr (6+6+5+5)) and 15; -end; - -function TTimeLogBits.Day: Integer; -begin - result := 1+(PCardinal(@Value)^ shr (6+6+5)) and 31; -end; - -function TTimeLogBits.Hour: Integer; -begin - result := (PCardinal(@Value)^ shr (6+6)) and 31; -end; - -function TTimeLogBits.Minute: Integer; -begin - result := (PCardinal(@Value)^ shr 6) and 63; -end; - -function TTimeLogBits.Second: Integer; -begin - result := PCardinal(@Value)^ and 63; -end; - -function TTimeLogBits.ToUnixTime: TUnixTime; -begin - result := DateTimeToUnixTime(ToDateTime); -end; - -function TTimeLogBits.ToUnixMSTime: TUnixMSTime; -begin - result := DateTimeToUnixMSTime(ToDateTime); -end; - -function TTimeLogBits.Text(Dest: PUTF8Char; Expanded: boolean; FirstTimeChar: AnsiChar): integer; -var lo: PtrUInt; - S: PUTF8Char; -begin - if Value=0 then begin - result := 0; - exit; - end; - S := Dest; - lo := {$ifdef CPU64}Value{$else}PCardinal(@Value)^{$endif}; - if lo and (1 shl (6+6+5)-1)=0 then - // no Time: just convert date - result := DateToIso8601PChar(Dest, Expanded, - {$ifdef CPU64}lo{$else}Value{$endif} shr (6+6+5+5+4), - 1+(lo shr (6+6+5+5)) and 15, 1+(lo shr (6+6+5)) and 31)-S else - if {$ifdef CPU64}lo{$else}Value{$endif} shr (6+6+5)=0 then - // no Date: just convert time - result := TimeToIso8601PChar(Dest, Expanded, (lo shr (6+6)) and 31, - (lo shr 6) and 63, lo and 63, 0, FirstTimeChar)-S else begin - // convert time and date - Dest := DateToIso8601PChar(Dest, Expanded, - {$ifdef CPU64}lo{$else}Value{$endif} shr (6+6+5+5+4), - 1+(lo shr (6+6+5+5)) and 15, 1+(lo shr (6+6+5)) and 31); - result := TimeToIso8601PChar(Dest, Expanded, (lo shr (6+6)) and 31, - (lo shr 6) and 63, lo and 63, 0, FirstTimeChar)-S; - end; -end; - -function TTimeLogBits.Text(Expanded: boolean; FirstTimeChar: AnsiChar): RawUTF8; -var tmp: array[0..31] of AnsiChar; -begin - if Value=0 then - result := '' else - FastSetString(result,@tmp,Text(tmp,Expanded,FirstTimeChar)); -end; - -function TTimeLogBits.FullText(Dest: PUTF8Char; Expanded: boolean; - FirstTimeChar,QuotedChar: AnsiChar): PUTF8Char; -var lo: PtrUInt; -begin // convert full time and date - if QuotedChar<>#0 then begin - Dest^ := QuotedChar; - inc(Dest); - end; - lo := {$ifdef CPU64}Value{$else}PCardinal(@Value)^{$endif}; - Dest := DateToIso8601PChar(Dest, Expanded, - {$ifdef CPU64}lo{$else}Value{$endif} shr (6+6+5+5+4), - 1+(lo shr (6+6+5+5)) and 15, 1+(lo shr (6+6+5)) and 31); - Dest := TimeToIso8601PChar(Dest, Expanded, (lo shr (6+6)) and 31, - (lo shr 6) and 63, lo and 63, 0, FirstTimeChar); - if QuotedChar<>#0 then begin - Dest^ := QuotedChar; - inc(Dest); - end; - result := Dest; -end; - -function TTimeLogBits.FullText(Expanded: boolean; FirstTimeChar,QuotedChar: AnsiChar): RawUTF8; -var tmp: array[0..31] of AnsiChar; -begin - FastSetString(result,@tmp,FullText(tmp,Expanded,FirstTimeChar,QuotedChar)-@tmp); -end; - -function TTimeLogBits.i18nText: string; -begin - if Assigned(i18nDateText) then - result := i18nDateText(Value) else - result := {$ifdef UNICODE}Ansi7ToString{$endif}(Text(true,' ')); -end; - -function TimeLogNow: TTimeLog; -begin - PTimeLogBits(@result)^.FromNow; -end; - -function TimeLogNowUTC: TTimeLog; -begin - PTimeLogBits(@result)^.FromUTCTime; -end; - -function NowToString(Expanded: boolean; FirstTimeChar: AnsiChar): RawUTF8; -var I: TTimeLogBits; -begin - I.FromNow; - result := I.Text(Expanded,FirstTimeChar); -end; - -function NowUTCToString(Expanded: boolean; FirstTimeChar: AnsiChar): RawUTF8; -var I: TTimeLogBits; -begin - I.FromUTCTime; - result := I.Text(Expanded,FirstTimeChar); -end; - -const - DTMS_FMT: array[boolean] of RawUTF8 = ('%%%%%%%%%', '%-%-%%%:%:%.%%'); - -function DateTimeMSToString(DateTime: TDateTime; Expanded: boolean; - FirstTimeChar: AnsiChar; const TZD: RawUTF8): RawUTF8; -var T: TSynSystemTime; -begin // 'YYYY-MM-DD hh:mm:ss.sssZ' or 'YYYYMMDD hhmmss.sssZ' format - if DateTime=0 then - result := '' else begin - T.FromDateTime(DateTime); - result := DateTimeMSToString(T.Hour,T.Minute,T.Second,T.MilliSecond, - T.Year,T.Month,T.Day,Expanded,FirstTimeChar,TZD); - end; -end; - -function DateTimeMSToString(HH,MM,SS,MS,Y,M,D: cardinal; Expanded: boolean; - FirstTimeChar: AnsiChar; const TZD: RawUTF8): RawUTF8; -begin // 'YYYY-MM-DD hh:mm:ss.sssZ' or 'YYYYMMDD hhmmss.sssZ' format - FormatUTF8(DTMS_FMT[Expanded], [UInt4DigitsToShort(Y),UInt2DigitsToShortFast(M), - UInt2DigitsToShortFast(D),FirstTimeChar,UInt2DigitsToShortFast(HH), - UInt2DigitsToShortFast(MM),UInt2DigitsToShortFast(SS),UInt3DigitsToShort(MS),TZD], result); -end; - -function DateTimeToHTTPDate(dt: TDateTime; const tz: RawUTF8): RawUTF8; -var T: TSynSystemTime; -begin - if dt=0 then - result := '' else begin - T.FromDateTime(dt); - T.ToHTTPDate(result,tz); - end; -end; - -function TimeToString: RawUTF8; -var I: TTimeLogBits; -begin - I.FromNow; - I.Value := I.Value and (1 shl (6+6+5)-1); // keep only time - result := I.Text(true,' '); -end; - -function TimeLogFromFile(const FileName: TFileName): TTimeLog; -var Date: TDateTime; -begin - Date := FileAgeToDateTime(FileName); - if Date=0 then - result := 0 else - PTimeLogBits(@result)^.From(Date); -end; - -function TimeLogFromDateTime(const DateTime: TDateTime): TTimeLog; -begin - PTimeLogBits(@result)^.From(DateTime); -end; - -function TimeLogFromUnixTime(const UnixTime: TUnixTime): TTimeLog; -begin - PTimeLogBits(@result)^.FromUnixTime(UnixTime); -end; - - -{ TSynDate } - -procedure TSynDate.Clear; -begin - PInt64(@self)^ := 0; -end; - -procedure TSynDate.SetMax; -begin - PInt64(@self)^ := $001F0000000C270F; // 9999 + 12 shl 16 + 31 shl 48 -end; - -function TSynDate.IsZero: boolean; -begin - result := PInt64(@self)^=0; -end; - -function TSynDate.ParseFromText(var P: PUTF8Char): boolean; -var L: PtrInt; - Y,M,D: cardinal; -begin - result := false; - if P=nil then - exit; - while P^ in [#9,' '] do inc(P); - L := 0; - while P[L] in ['0'..'9','-','/'] do inc(L); - if not Iso8601ToDatePUTF8Char(P,L,Y,M,D) then - exit; - Year := Y; - Month := M; - DayOfWeek := 0; - Day := D; - inc(P,L); // move P^ just after the date - result := true; -end; - -procedure TSynDate.FromNow(localtime: boolean); -var dt: TSynSystemTime; -begin - FromGlobalTime(localtime,dt); - self := PSynDate(@dt)^; // 4 first fields of TSynSystemTime do match -end; - -procedure TSynDate.FromDate(date: TDate); -var dt: TSynSystemTime; -begin - dt.FromDate(date); // faster than DecodeDate - self := PSynDate(@dt)^; -end; - -function TSynDate.IsEqual({$ifdef FPC}constref{$else}const{$endif} another{$ifndef DELPHI5OROLDER}: TSynDate{$endif}): boolean; -begin - result := (PCardinal(@Year)^=PCardinal(@TSynDate(another).Year)^) and (Day=TSynDate(another).Day); -end; - -function TSynDate.Compare({$ifdef FPC}constref{$else}const{$endif} another{$ifndef DELPHI5OROLDER}: TSynDate{$endif}): integer; -begin - result := Year-TSynDate(another).Year; - if result=0 then begin - result := Month-TSynDate(another).Month; - if result=0 then - result := Day-TSynDate(another).Day; - end; -end; - -procedure TSynDate.ComputeDayOfWeek; -var d: TDateTime; - i: PtrInt; -begin - if not TryEncodeDate(Year,Month,Day,d) then begin - DayOfWeek := 0; - exit; - end; - i := ((trunc(d)-1) mod 7)+1; // sunday is day 1 - if i<=0 then - DayOfWeek := i+7 else - DayOfWeek := i; -end; - -function TSynDate.ToDate: TDate; -begin - if not TryEncodeDate(Year,Month,Day,PDateTime(@result)^) then - result := 0; -end; - -function TSynDate.ToText(Expanded: boolean): RawUTF8; -begin - if PInt64(@self)^=0 then - result := '' else - result := DateToIso8601(Year,Month,Day,Expanded); -end; - - -{ TSynSystemTime } - -function TryEncodeDayOfWeekInMonth(AYear, AMonth, ANthDayOfWeek, ADayOfWeek: integer; - out AValue: TDateTime): Boolean; -var LStartOfMonth, LDay: integer; -begin // adapted from DateUtils - result := TryEncodeDate(AYear,AMonth,1,aValue); - if not result then - exit; - LStartOfMonth := (DateTimeToTimestamp(aValue).Date-1)mod 7+1; - if LStartOfMonth<=ADayOfWeek then - dec(ANthDayOfWeek); - LDay := (ADayOfWeek-LStartOfMonth+1)+7*ANthDayOfWeek; - result := TryEncodeDate(AYear,AMonth,LDay,AValue); -end; - -function TSynSystemTime.EncodeForTimeChange(const aYear: word): TDateTime; -var dow,d: word; -begin - if DayOfWeek=0 then - dow := 7 else // Delphi Sunday = 7 - dow := DayOfWeek; - // Encoding the day of change - d := Day; - while not TryEncodeDayOfWeekInMonth(aYear,Month,d,dow,Result) do begin - // if Day = 5 then try it and if needed decrement to find the last - // occurence of the day in this month - if d=0 then begin - TryEncodeDayOfWeekInMonth(aYear,Month,1,7,Result); - break; - end; - dec(d); - end; - // finally add the time when change is due - result := result+EncodeTime(Hour,Minute,Second,MilliSecond); -end; - -procedure TSynSystemTime.Clear; -begin - PInt64Array(@self)[0] := 0; - PInt64Array(@self)[1] := 0; -end; - -function TSynSystemTime.IsZero: boolean; -begin - result := (PInt64Array(@self)[0]=0) and (PInt64Array(@self)[1]=0); -end; - -function TSynSystemTime.IsEqual(const another{$ifndef DELPHI5OROLDER}: TSynSystemTime{$endif}): boolean; -begin - result := (PInt64Array(@self)[0]=PInt64Array(@another)[0]) and - (PInt64Array(@self)[1]=PInt64Array(@another)[1]); -end; - -function TSynSystemTime.IsDateEqual(const date{$ifndef DELPHI5OROLDER}: TSynDate{$endif}): boolean; -begin - result := (PCardinal(@Year)^=PCardinal(@TSynDate(date).Year)^) and - (Day=TSynDate(date).Day); -end; - -procedure TSynSystemTime.FromNowUTC; -begin - FromGlobalTime(false,self); -end; - -procedure TSynSystemTime.FromNowLocal; -begin - FromGlobalTime(true,self); -end; - -procedure TSynSystemTime.FromDateTime(const dt: TDateTime); -begin - FromDate(dt); - FromTime(dt); -end; - -procedure TSynSystemTime.FromDate(const dt: TDateTime); -var t,t2,t3: PtrUInt; -begin - t := Trunc(dt); - t := (t+693900)*4-1; - if PtrInt(t)>=0 then begin - t3 := t div 146097; - t2 := (t-t3*146097) and not 3; - t := PtrUInt(t2+3) div 1461; // PtrUInt() needed for FPC i386 - Year := t3*100+t; - t2 := ((t2+7-t*1461)shr 2)*5; - t3 := PtrUInt(t2-3) div 153; - Day := PtrUInt(t2+2-t3*153) div 5; - if t3<10 then - inc(t3,3) else begin - dec(t3,9); - inc(Year); - end; - Month := t3; - DayOfWeek := 0; // not set by default - end else - PInt64(@Year)^ := 0; -end; - -procedure TSynSystemTime.FromTime(const dt: TDateTime); -begin - FromMS(QWord(round(abs(dt)*MSecsPerDay)) mod MSecsPerDay); -end; - -procedure TSynSystemTime.FromMS(ms: PtrUInt); -var t: PtrUInt; -begin - t := ms div 3600000; - Hour := t; - dec(ms,t*3600000); - t := ms div 60000; - Minute := t; - dec(ms,t*60000); - t := ms div 1000; - Second := t; - dec(ms,t*1000); - MilliSecond := ms; -end; - -procedure TSynSystemTime.FromSec(s: PtrUInt); -var t: PtrUInt; -begin - t := s div 3600; - Hour := t; - dec(s,t*3600); - t := s div 60; - Minute := t; - dec(s,t*60); - Second := s; - MilliSecond := 0; -end; - -function TSynSystemTime.FromText(const iso: RawUTF8): boolean; -var t: TTimeLogBits; -begin - t.From(iso); - if t.Value=0 then - result := false else begin - t.Expand(self); // TTimeLogBits is faster than FromDateTime() - result := true; - end; -end; - -function TSynSystemTime.ToText(Expanded: boolean; - FirstTimeChar: AnsiChar; const TZD: RawUTF8): RawUTF8; -begin - result := DateTimeMSToString(Hour,Minute,Second,MilliSecond,Year,Month,Day, - Expanded,FirstTimeChar,TZD); -end; - -procedure TSynSystemTime.AddLogTime(WR: TTextWriter); -var y,d100: PtrUInt; - P: PUTF8Char; - tab: {$ifdef CPUX86NOTPIC}TWordArray absolute TwoDigitLookupW{$else}PWordArray{$endif}; -begin - if WR.BEnd-WR.B<=18 then - WR.FlushToStream; - {$ifndef CPUX86NOTPIC}tab := @TwoDigitLookupW;{$endif} - y := Year; - d100 := y div 100; - P := WR.B+1; - PWord(P)^ := tab[d100]; - PWord(P+2)^ := tab[y-(d100*100)]; - PWord(P+4)^ := tab[Month]; - PWord(P+6)^ := tab[Day]; - P[8] := ' '; - PWord(P+9)^ := tab[Hour]; - PWord(P+11)^ := tab[Minute]; - PWord(P+13)^ := tab[Second]; - y := Millisecond; - PWord(P+15)^ := tab[y shr 4]; - inc(WR.B,17); -end; - -const - HTML_WEEK_DAYS: array[1..7] of string[3] = - ('Sun','Mon','Tue','Wed','Thu','Fri','Sat'); - HTML_MONTH_NAMES: array[1..12] of string[3] = - ('Jan','Feb','Mar','Apr','May','Jun', 'Jul','Aug','Sep','Oct','Nov','Dec'); - -function TSynSystemTime.ToNCSAText(P: PUTF8Char): PtrInt; -var y,d100: PtrUInt; - tab: {$ifdef CPUX86NOTPIC}TWordArray absolute TwoDigitLookupW{$else}PWordArray{$endif}; -begin - {$ifndef CPUX86NOTPIC}tab := @TwoDigitLookupW;{$endif} - PWord(P)^ := tab[Day]; - PCardinal(P+2)^ := PCardinal(@HTML_MONTH_NAMES[Month])^; - P[2] := '/'; // overwrite HTML_MONTH_NAMES[][0] - P[6] := '/'; - y := Year; - d100 := y div 100; - PWord(P+7)^ := tab[d100]; - PWord(P+9)^ := tab[y-(d100*100)]; - P[11] := ':'; - PWord(P+12)^ := tab[Hour]; - P[14] := ':'; - PWord(P+15)^ := tab[Minute]; - P[17] := ':'; - PWord(P+18)^ := tab[Second]; - P[20] := ' '; - result := 21; -end; - -procedure TSynSystemTime.ToHTTPDate(out text: RawUTF8; const tz: RawUTF8); -begin - if DayOfWeek=0 then - PSynDate(@self)^.ComputeDayOfWeek; // first 4 fields do match - FormatUTF8('%, % % % %:%:% %', [HTML_WEEK_DAYS[DayOfWeek], - UInt2DigitsToShortFast(Day),HTML_MONTH_NAMES[Month],UInt4DigitsToShort(Year), - UInt2DigitsToShortFast(Hour),UInt2DigitsToShortFast(Minute), - UInt2DigitsToShortFast(Second),tz],text); -end; - -procedure TSynSystemTime.ToIsoDateTime(out text: RawUTF8; const FirstTimeChar: AnsiChar); -begin - FormatUTF8('%-%-%%%:%:%', [UInt4DigitsToShort(Year),UInt2DigitsToShortFast(Month), - UInt2DigitsToShortFast(Day),FirstTimeChar,UInt2DigitsToShortFast(Hour), - UInt2DigitsToShortFast(Minute),UInt2DigitsToShortFast(Second)],text); -end; - -procedure TSynSystemTime.ToIsoDate(out text: RawUTF8); -begin - FormatUTF8('%-%-%', [UInt4DigitsToShort(Year),UInt2DigitsToShortFast(Month), - UInt2DigitsToShortFast(Day)],text); -end; - -procedure TSynSystemTime.ToIsoTime(out text: RawUTF8; const FirstTimeChar: RawUTF8); -begin - FormatUTF8('%%:%:%', [FirstTimeChar,UInt2DigitsToShortFast(Hour), - UInt2DigitsToShortFast(Minute),UInt2DigitsToShortFast(Second)],text); -end; - -procedure TSynSystemTime.AddNCSAText(WR: TTextWriter); -begin - if WR.BEnd-WR.B<=21 then - WR.FlushToStream; - inc(WR.B,ToNCSAText(WR.B+1)); -end; - -function TSynSystemTime.ToDateTime: TDateTime; -var time: TDateTime; -begin - if TryEncodeDate(Year,Month,Day,result) then - if TryEncodeTime(Hour,Minute,Second,MilliSecond,time) then - result := result+time else - result := 0 else - result := 0; -end; - -procedure TSynSystemTime.ToSynDate(out date: TSynDate); -begin - date := PSynDate(@self)^; // first 4 fields do match -end; - -procedure TSynSystemTime.ComputeDayOfWeek; -begin - PSynDate(@self)^.ComputeDayOfWeek; // first 4 fields do match -end; - -procedure TSynSystemTime.IncrementMS(ms: integer); -begin - inc(MilliSecond, ms); - if MilliSecond >= 1000 then - repeat - dec(MilliSecond, 1000); - if Second < 60 then - inc(Second) - else begin - Second := 0; - if Minute < 60 then - inc(Minute) - else begin - Minute := 0; - if Hour < 24 then - inc(Hour) - else begin - Hour := 0; - if Day < MonthDays[false, Month] then - inc(Day) - else begin - Day := 1; - if Month < 12 then - inc(Month) - else begin - Month := 1; - inc(Year); - end; - end; - end; - end; - end; - until MilliSecond < 1000; -end; - -procedure AppendToTextFile(aLine: RawUTF8; const aFileName: TFileName; - aMaxSize: Int64; aUTCTimeStamp: boolean); -var F: THandle; - Old: TFileName; - Date: array[1..22] of AnsiChar; - size: Int64; - i: integer; - now: TSynSystemTime; -begin - if aFileName='' then - exit; - F := FileOpen(aFileName,fmOpenWrite or fmShareDenyNone); - if PtrInt(F)<0 then begin - F := FileCreate(aFileName); - if PtrInt(F)<0 then - exit; // you may not have write access to this folder - end; - // append to end of file - size := FileSeek64(F,0,soFromEnd); - if (aMaxSize>0) and (size>aMaxSize) then begin - // rotate log file if too big - FileClose(F); - Old := aFileName+'.bak'; // '.log.bak' - DeleteFile(Old); // rotate once - RenameFile(aFileName,Old); - F := FileCreate(aFileName); - if PtrInt(F)<0 then - exit; - end; - PWord(@Date)^ := 13+10 shl 8; // first go to next line - if aUTCTimeStamp then - now.FromNowUTC else - now.FromNowLocal; - DateToIso8601PChar(@Date[3],true,Now.Year,Now.Month,Now.Day); - TimeToIso8601PChar(@Date[13],true,Now.Hour,Now.Minute,Now.Second,0,' '); - Date[22] := ' '; - FileWrite(F,Date,SizeOf(Date)); - for i := 1 to length(aLine) do - if aLine[i]<' ' then - aLine[i] := ' '; // avoid line feed in text log file - FileWrite(F,pointer(aLine)^,length(aLine)); - FileClose(F); -end; - -procedure LogToTextFile(Msg: RawUTF8); -begin - if Msg='' then begin - StringToUTF8(SysErrorMessage(GetLastError),Msg); - if Msg='' then - exit; - end; - AppendToTextFile(Msg,{$ifndef MSWINDOWS}ExtractFileName{$endif} - (ChangeFileExt(ExeVersion.ProgramFileName,'.log'))); -end; - -function IsEqualGUID(const guid1, guid2: TGUID): Boolean; -begin - result := (PHash128Rec(@guid1).L=PHash128Rec(@guid2).L) and - (PHash128Rec(@guid1).H=PHash128Rec(@guid2).H); -end; - -function IsEqualGUID(guid1, guid2: PGUID): Boolean; -begin - result := (PHash128Rec(guid1).L=PHash128Rec(guid2).L) and - (PHash128Rec(guid1).H=PHash128Rec(guid2).H); -end; - -function IsEqualGUIDArray(const guid: TGUID; const guids: array of TGUID): integer; -begin - result := Hash128Index(@guids[0],length(guids),@guid); -end; - -function IsNullGUID({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID): Boolean; -var a: TPtrIntArray absolute guid; -begin - result := (a[0]=0) and (a[1]=0) {$ifndef CPU64} and (a[2]=0) and (a[3]=0){$endif}; -end; - -function AddGUID(var guids: TGUIDDynArray; const guid: TGUID; - NoDuplicates: boolean): integer; -begin - if NoDuplicates then begin - result := Hash128Index(pointer(guids),length(guids),@guid); - if result>=0 then - exit; - end; - result := length(guids); - SetLength(guids,result+1); - guids[result] := guid; -end; - -function GUIDToText(P: PUTF8Char; guid: PByteArray): PUTF8Char; -var i: integer; -begin // encode as '3F2504E0-4F89-11D3-9A0C-0305E82C3301' - for i := 3 downto 0 do begin - PWord(P)^ := TwoDigitsHexWB[guid[i]]; - inc(P,2); - end; - inc(PByte(guid),4); - for i := 1 to 2 do begin - P[0] := '-'; - PWord(P+1)^ := TwoDigitsHexWB[guid[1]]; - PWord(P+3)^ := TwoDigitsHexWB[guid[0]]; - inc(PByte(guid),2); - inc(P,5); - end; - P[0] := '-'; - PWord(P+1)^ := TwoDigitsHexWB[guid[0]]; - PWord(P+3)^ := TwoDigitsHexWB[guid[1]]; - P[5] := '-'; - inc(PByte(guid),2); - inc(P,6); - for i := 0 to 5 do begin - PWord(P)^ := TwoDigitsHexWB[guid[i]]; - inc(P,2); - end; - result := P; -end; - -function HexaToByte(P: PUTF8Char; var Dest: byte): boolean; {$ifdef HASINLINE}inline;{$endif} -var B,C: PtrUInt; -begin - B := ConvertHexToBin[Ord(P[0])]; - if B<=15 then begin - C := ConvertHexToBin[Ord(P[1])]; - if C<=15 then begin - Dest := B shl 4+C; - result := true; - exit; - end; - end; - result := false; // mark error -end; - -function TextToGUID(P: PUTF8Char; guid: PByteArray): PUTF8Char; -var i: integer; -begin // decode from '3F2504E0-4F89-11D3-9A0C-0305E82C3301' - result := nil; - for i := 3 downto 0 do begin - if not HexaToByte(P,guid[i]) then - exit; - inc(P,2); - end; - inc(PByte(guid),4); - for i := 1 to 2 do begin - if (P^<>'-') or not HexaToByte(P+1,guid[1]) or not HexaToByte(P+3,guid[0]) then - exit; - inc(P,5); - inc(PByte(guid),2); - end; - if (P[0]<>'-') or (P[5]<>'-') or - not HexaToByte(P+1,guid[0]) or not HexaToByte(P+3,guid[1]) then - exit; - inc(PByte(guid),2); - inc(P,6); - for i := 0 to 5 do - if HexaToByte(P,guid[i]) then - inc(P,2) else - exit; - result := P; -end; - -function GUIDToRawUTF8({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID): RawUTF8; -var P: PUTF8Char; -begin - FastSetString(result,nil,38); - P := pointer(result); - P^ := '{'; - GUIDToText(P+1,@guid)^ := '}'; -end; - -function GUIDToShort({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID): TGUIDShortString; -begin - GUIDToShort(guid,result); -end; - -procedure GUIDToShort({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID; - out dest: TGUIDShortString); -begin - dest[0] := #38; - dest[1] := '{'; - dest[38] := '}'; - GUIDToText(@dest[2],@guid); -end; - -function GUIDToString({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID): string; -{$ifdef UNICODE} -var tmp: array[0..35] of AnsiChar; - i: integer; -begin - GUIDToText(tmp,@guid); - SetString(result,nil,38); - PWordArray(result)[0] := ord('{'); - for i := 1 to 36 do - PWordArray(result)[i] := ord(tmp[i-1]); // no conversion for 7 bit Ansi - PWordArray(result)[37] := ord('}'); -end; -{$else} -begin - result := GUIDToRawUTF8(guid); -end; -{$endif} - -{$ifdef CPUINTEL} /// NIST SP 800-90A compliant RDRAND Intel x86/x64 opcode -function RdRand32: cardinal; {$ifdef CPU64} -{$ifdef FPC}nostackframe; assembler; asm{$else} asm .noframe {$endif FPC} {$else} -{$ifdef FPC}nostackframe; assembler;{$endif} asm {$endif} - // rdrand eax: same opcodes for x86 and x64 - db $0f, $c7, $f0 - // returns in eax, ignore carry flag (eax=0 won't hurt) -end; -{$endif CPUINTEL} - -threadvar - _Lecuyer: TLecuyer; // uses only 16 bytes per thread - -procedure TLecuyer.Seed(entropy: PByteArray; entropylen: PtrInt); -var time, crc: THash128Rec; - i, j: PtrInt; -begin - repeat - QueryPerformanceCounter(time.Lo); - time.Hi := UnixMSTimeUTCFast xor PtrUInt(GetCurrentThreadID); - crcblock(@crc.b,@time.b); - crcblock(@crc.b,@ExeVersion.Hash.b); - if entropy<>nil then - for i := 0 to entropylen-1 do begin - j := i and 15; - crc.b[j] := crc.b[j] xor entropy^[i]; - end; - rs1 := rs1 xor crc.c0; - rs2 := rs2 xor crc.c1; - rs3 := rs3 xor crc.c2; - {$ifdef CPUINTEL} - if cfRAND in CpuFeatures then begin // won't hurt e.g. from Random32gsl - rs1 := rs1 xor RdRand32; - rs2 := rs2 xor RdRand32; - rs3 := rs3 xor RdRand32; - end; - {$endif CPUINTEL} - until (rs1>1) and (rs2>7) and (rs3>15); - seedcount := 1; - for i := 1 to crc.i3 and 15 do - Next; // warm up -end; - -function TLecuyer.Next: cardinal; -begin - if word(seedcount)=0 then // reseed after 256KB of output - Seed(nil,0) else - inc(seedcount); - result := rs1; - rs1 := ((result and -2)shl 12) xor (((result shl 13)xor result)shr 19); - result := rs2; - rs2 := ((result and -8)shl 4) xor (((result shl 2)xor result)shr 25); - result := rs3; - rs3 := ((result and -16)shl 17) xor (((result shl 3)xor result)shr 11); - result := rs1 xor rs2 xor result; -end; - -function TLecuyer.Next(max: cardinal): cardinal; -begin - result := (QWord(Next)*max)shr 32; -end; - -procedure Random32Seed(entropy: pointer; entropylen: PtrInt); -begin - _Lecuyer.Seed(entropy,entropylen); -end; - -function Random32: cardinal; -begin - {$ifdef CPUINTEL} - if cfRAND in CpuFeatures then begin - result := RdRand32; - if ((integer(result)<>-1) and (result<>0)) or (RdRand32<>result) then - exit; // ensure not affected by old AMD bug after suspend to RAM - exclude(CpuFeatures,cfRAND); // disable if weakness detected - end; - {$endif CPUINTEL} - result := _Lecuyer.Next; -end; - -function Random32(max: cardinal): cardinal; -begin - result := (QWord(Random32)*max)shr 32; -end; - -function Random32gsl: cardinal; -begin - result := _Lecuyer.Next; -end; - -function Random32gsl(max: cardinal): cardinal; -begin - result := (QWord(_Lecuyer.Next)*max)shr 32; -end; - -procedure FillRandom(Dest: PCardinalArray; CardinalCount: integer; forcegsl: boolean); -var i: PtrInt; - c: cardinal; - seed: TQWordRec; - lecuyer: ^TLecuyer; -begin - if CardinalCount<=0 then - exit; - {$ifdef CPUINTEL} - if (cfRAND in CpuFeatures) and not forcegsl then - lecuyer := nil else - {$endif CPUINTEL} - lecuyer := @_Lecuyer; - QueryPerformanceCounter(PInt64(@seed)^); - c := crc32cBy4(seed.L,seed.H); - for i := 0 to CardinalCount-1 do begin - {$ifdef CPUINTEL} - if lecuyer=nil then - c := crc32cBy4(c,RdRand32) else // never trust plain Intel values - {$endif CPUINTEL} - c := c xor lecuyer^.Next; - Dest^[i] := Dest^[i] xor c; - end; -end; - -function RandomGUID: TGUID; -begin - FillRandom(@result,SizeOf(TGUID) shr 2,{forcegsl=}true); -end; - -procedure RandomGUID(out result: TGUID); -begin - FillRandom(@result,SizeOf(TGUID) shr 2,{forcegsl=}true); -end; - -procedure FillZero(var result: TGUID); -begin - FillZero(PHash128(@result)^); -end; - -function RawUTF8ToGUID(const text: RawByteString): TGUID; -begin - if (length(text)<>38) or (text[1]<>'{') or (text[38]<>'}') or - (TextToGUID(@text[2],@result)=nil) then - FillZero(PHash128(@result)^); -end; - -function StringToGUID(const text: string): TGUID; -{$ifdef UNICODE} -var tmp: array[0..35] of byte; - i: integer; -{$endif} -begin - if (length(text)=38) and (text[1]='{') and (text[38]='}') then begin - {$ifdef UNICODE} - for i := 0 to 35 do - tmp[i] := PWordArray(text)[i+1]; - if TextToGUID(@tmp,@result)<>nil then - {$else} - if TextToGUID(@text[2],@result)<>nil then - {$endif} - exit; // conversion OK - end; - FillZero(PHash128(@result)^); -end; - -function StrCurr64(P: PAnsiChar; const Value: Int64): PAnsiChar; -var c: QWord; - d: cardinal; - {$ifndef CPU64}c64: Int64Rec absolute c;{$endif} -begin - if Value=0 then begin - result := P-1; - result^ := '0'; - exit; - end; - if Value<0 then - c := -Value else - c := Value; - if {$ifdef CPU64}c<10000{$else}(c64.Hi=0) and (c64.Lo<10000){$endif} then begin - result := P-6; // only decimals -> append '0.xxxx' - PWord(result)^ := ord('0')+ord('.')shl 8; - YearToPChar(c,PUTF8Char(P)-4); - end else begin - result := StrUInt64(P-1,c); - d := PCardinal(P-5)^; // in two explit steps for CPUARM (alf) - PCardinal(P-4)^ := d; - P[-5] := '.'; // insert '.' just before last 4 decimals - end; - if Value<0 then begin - dec(result); - result^ := '-'; - end; -end; - -procedure Curr64ToStr(const Value: Int64; var result: RawUTF8); -var tmp: array[0..31] of AnsiChar; - P: PAnsiChar; - Decim, L: Cardinal; -begin - if Value=0 then - result := SmallUInt32UTF8[0] else begin - P := StrCurr64(@tmp[31],Value); - L := @tmp[31]-P; - if L>4 then begin - Decim := PCardinal(P+L-SizeOf(cardinal))^; // 4 last digits = 4 decimals - if Decim=ord('0')+ord('0')shl 8+ord('0')shl 16+ord('0')shl 24 then - dec(L,5) else // no decimal - if Decim and $ffff0000=ord('0')shl 16+ord('0')shl 24 then - dec(L,2); // 2 decimals - end; - FastSetString(result,P,L); - end; -end; - -function Curr64ToStr(const Value: Int64): RawUTF8; -begin - Curr64ToStr(Value,result); -end; - -function CurrencyToStr(Value: currency): RawUTF8; -begin - result := Curr64ToStr(PInt64(@Value)^); -end; - -function Curr64ToPChar(const Value: Int64; Dest: PUTF8Char): PtrInt; -var tmp: array[0..31] of AnsiChar; - P: PAnsiChar; - Decim: Cardinal; -begin - P := StrCurr64(@tmp[31],Value); - result := @tmp[31]-P; - if result>4 then begin - Decim := PCardinal(P+result-SizeOf(cardinal))^; // 4 last digits = 4 decimals - if Decim=ord('0')+ord('0')shl 8+ord('0')shl 16+ord('0')shl 24 then - dec(result,5) else // no decimal - if Decim and $ffff0000=ord('0')shl 16+ord('0')shl 24 then - dec(result,2); // 2 decimals - end; - MoveSmall(P,Dest,result); -end; - -function StrToCurr64(P: PUTF8Char; NoDecimal: PBoolean): Int64; -var c: cardinal; - minus: boolean; - Dec: cardinal; -begin - result := 0; - if P=nil then - exit; - while (P^<=' ') and (P^<>#0) do inc(P); - if P^='-' then begin - minus := true; - repeat inc(P) until P^<>' '; - end else begin - minus := false; - if P^='+' then - repeat inc(P) until P^<>' '; - end; - if P^='.' then begin // '.5' -> 500 - Dec := 2; - inc(P); - end else - Dec := 0; - c := byte(P^)-48; - if c>9 then - exit; - PCardinal(@result)^ := c; - inc(P); - repeat - if P^<>'.' then begin - c := byte(P^)-48; - if c>9 then - break; - {$ifdef CPU32DELPHI} - result := result shl 3+result+result; - {$else} - result := result*10; - {$endif} - inc(result,c); - inc(P); - if Dec<>0 then begin - inc(Dec); - if Dec<5 then continue else break; - end; - end else begin - inc(Dec); - inc(P); - end; - until false; - if NoDecimal<>nil then - if Dec=0 then begin - NoDecimal^ := true; - if minus then - result := -result; - exit; - end else - NoDecimal^ := false; - if Dec<>5 then // Dec=5 most of the time - case Dec of - 0,1: result := result*10000; - {$ifdef CPU32DELPHI} - 2: result := result shl 10-result shl 4-result shl 3; - 3: result := result shl 6+result shl 5+result shl 2; - 4: result := result shl 3+result+result; - {$else} - 2: result := result*1000; - 3: result := result*100; - 4: result := result*10; - {$endif} - end; - if minus then - result := -result; -end; - -function StrToCurrency(P: PUTF8Char): currency; -begin - PInt64(@result)^ := StrToCurr64(P,nil); -end; - -function TruncTo2Digits(Value: Currency): Currency; -var V64: Int64 absolute Value; // to avoid any floating-point precision issues -begin - dec(V64,V64 mod 100); - result := Value; -end; - -procedure TruncTo2DigitsCurr64(var Value: Int64); -begin - dec(Value,Value mod 100); -end; - -function TruncTo2Digits64(Value: Int64): Int64; -begin - result := Value-Value mod 100; -end; - -function SimpleRoundTo2Digits(Value: Currency): Currency; -var V64: Int64 absolute Value; // to avoid any floating-point precision issues -begin - SimpleRoundTo2DigitsCurr64(V64); - result := Value; -end; - -procedure SimpleRoundTo2DigitsCurr64(var Value: Int64); -var Spare: PtrInt; -begin - Spare := Value mod 100; - if Spare<>0 then - if Spare>50 then - inc(Value,100-Spare) else - if Spare<-50 then - dec(Value,100+Spare) else - dec(Value,Spare); -end; - -function TrimLeftLowerCase(const V: RawUTF8): PUTF8Char; -begin - result := Pointer(V); - if result<>nil then begin - while result^ in ['a'..'z'] do - inc(result); - if result^=#0 then - result := Pointer(V); - end; -end; - -function TrimLeftLowerCaseToShort(V: PShortString): ShortString; -begin - TrimLeftLowerCaseToShort(V,result); -end; - -procedure TrimLeftLowerCaseToShort(V: PShortString; out result: ShortString); -var P: PAnsiChar; - L: integer; -begin - L := length(V^); - P := @V^[1]; - while (L>0) and (P^ in ['a'..'z']) do begin - inc(P); - dec(L); - end; - if L=0 then - result := V^ else - SetString(result,P,L); -end; - -{$ifdef FPC_OR_PUREPASCAL} -function TrimLeftLowerCaseShort(V: PShortString): RawUTF8; -var P: PAnsiChar; - L: integer; -begin - L := length(V^); - P := @V^[1]; - while (L>0) and (P^ in ['a'..'z']) do begin - inc(P); - dec(L); - end; - if L=0 then - FastSetString(result,@V^[1],length(V^)) else - FastSetString(result,P,L); -end; -{$else} -function TrimLeftLowerCaseShort(V: PShortString): RawUTF8; -asm // eax=V - xor ecx, ecx - push edx // save result RawUTF8 - test eax, eax - jz @2 // avoid GPF - lea edx, [eax + 1] - mov cl, [eax] -@1: mov ch, [edx] // edx=source cl=length - sub ch, 'a' - sub ch, 'z' - 'a' - ja @2 // not a lower char -> create a result string starting at edx - inc edx - dec cl - jnz @1 - mov cl, [eax] - lea edx, [eax + 1] // no UpperCase -> retrieve full text (result := V^) -@2: pop eax - movzx ecx, cl -{$ifdef UNICODE} - push CP_UTF8 // UTF-8 code page for Delphi 2009+ + call below, not jump - call System.@LStrFromPCharLen // eax=Dest edx=Source ecx=Length - rep ret // we need a call just above for right push CP_UTF8 retrieval -{$else} jmp System.@LStrFromPCharLen // eax=dest edx=source ecx=length(source) -{$endif} -end; -{$endif FPC_OR_PUREPASCAL} - -function UnCamelCase(const S: RawUTF8): RawUTF8; -var tmp: TSynTempBuffer; - destlen: PtrInt; -begin - if S='' then - result := '' else begin - destlen := UnCamelCase(tmp.Init(length(S)*2),pointer(S)); - tmp.Done(PAnsiChar(tmp.buf)+destlen,result); - end; -end; - -function UnCamelCase(D, P: PUTF8Char): integer; -var Space, SpaceBeg, DBeg: PUTF8Char; - CapitalCount: integer; - Number: boolean; -label Next; -begin - DBeg := D; - if (D<>nil) and (P<>nil) then begin // avoid GPF - Space := D; - SpaceBeg := D; - repeat - CapitalCount := 0; - Number := P^ in ['0'..'9']; - if Number then - repeat - inc(CapitalCount); - D^ := P^; - inc(P); - inc(D); - until not (P^ in ['0'..'9']) else - repeat - inc(CapitalCount); - D^ := P^; - inc(P); - inc(D); - until not (P^ in ['A'..'Z']); - if P^=#0 then break; // no lowercase conversion of last fully uppercased word - if (CapitalCount > 1) and not Number then begin - dec(P); - dec(D); - end; - while P^ in ['a'..'z'] do begin - D^ := P^; - inc(D); - inc(P); - end; - if P^='_' then - if P[1]='_' then begin - D^ := ':'; - inc(P); - inc(D); - goto Next; - end else begin - PWord(D)^ := ord(' ')+ord('-')shl 8; - inc(D,2); - Next: if Space=SpaceBeg then - SpaceBeg := D+1; - inc(P); - Space := D+1; - end else - Space := D; - if P^=#0 then break; - D^ := ' '; - inc(D); - until false; - if Space>DBeg then - dec(Space); - while Space>SpaceBeg do begin - if Space^ in ['A'..'Z'] then - if not (Space[1] in ['A'..'Z',' ']) then - inc(Space^,32); // lowercase conversion of not last fully uppercased word - dec(Space); - end; - end; - result := D-DBeg; -end; - -procedure CamelCase(P: PAnsiChar; len: PtrInt; var s: RawUTF8; - const isWord: TSynByteSet); -var i: PtrInt; - d: PAnsiChar; - tmp: array[byte] of AnsiChar; -begin - if len > SizeOf(tmp) then - len := SizeOf(tmp); - for i := 0 to len-1 do - if not(ord(P[i]) in isWord) then begin - if i>0 then begin - MoveSmall(P,@tmp,i); - inc(P,i); - dec(len,i); - end; - d := @tmp[i]; - while len > 0 do begin - while (len > 0) and not (ord(P^) in isWord) do begin - inc(P); - dec(len); - end; - if len = 0 then - break; - d^ := NormToUpperAnsi7[P^]; - inc(d); - repeat - inc(P); - dec(len); - if not (ord(P^) in isWord) then - break; - d^ := P^; - inc(d); - until len = 0; - end; - P := @tmp; - len := d-tmp; - break; - end; - FastSetString(s,P,len); -end; - -procedure CamelCase(const text: RawUTF8; var s: RawUTF8; const isWord: TSynByteSet); -begin - CamelCase(pointer(text), length(text), s, isWord); -end; - -procedure GetCaptionFromPCharLen(P: PUTF8Char; out result: string); -var Temp: array[byte] of AnsiChar; -begin // "out result" parameter definition already made result := '' - if P=nil then - exit; -{$ifdef UNICODE} - // property and enumeration names are UTF-8 encoded with Delphi 2009+ - UTF8DecodeToUnicodeString(Temp,UnCamelCase(@Temp,P),result); -{$else} - SetString(result,Temp,UnCamelCase(@Temp,P)); -{$endif} -{$ifndef LVCL} // LVCL system.pas doesn't implement LoadResStringTranslate() - if Assigned(LoadResStringTranslate) then - LoadResStringTranslate(result); -{$endif} -end; - -function GetDisplayNameFromClass(C: TClass): RawUTF8; -var DelphiName: PShortString; - TrimLeft: integer; -begin - if C=nil then begin - result := ''; - exit; - end; - DelphiName := ClassNameShort(C); - TrimLeft := 0; - if DelphiName^[0]>#4 then - case PInteger(@DelphiName^[1])^ and $DFDFDFDF of - // fast case-insensitive compare - ord('T')+ord('S')shl 8+ord('Q')shl 16+ord('L')shl 24: - if (DelphiName^[0]<=#10) or - (PInteger(@DelphiName^[5])^ and $DFDFDFDF<> // fast case-insensitive compare - ord('R')+ord('E')shl 8+ord('C')shl 16+ord('O')shl 24) or - (PWord(@DelphiName^[9])^ and $DFDF<>ord('R')+ord('D')shl 8) then - TrimLeft := 4 else - TrimLeft := 10; - ord('T')+ord('S')shl 8+ord('Y')shl 16+ord('N')shl 24: - TrimLeft := 4; - end; - if (Trimleft=0) and (DelphiName^[1]='T') then - Trimleft := 1; - FastSetString(result,@DelphiName^[TrimLeft+1],ord(DelphiName^[0])-TrimLeft); -end; - -function GetPublishedMethods(Instance: TObject; out Methods: TPublishedMethodInfoDynArray; - aClass: TClass): integer; - procedure AddParentsFirst(C: TClass); - type - TMethodInfo = packed record - {$ifdef FPC} - Name: PShortString; - Addr: Pointer; - {$else} - Len: Word; - Addr: Pointer; - Name: ShortString; - {$endif} - end; - var Table: {$ifdef FPC}PCardinalArray{$else}PWordArray{$endif}; - M: ^TMethodInfo; - i: integer; - begin - if C=nil then - exit; - AddParentsFirst(GetClassParent(C)); // put children published methods afterward - Table := PPointer(PtrUInt(C)+PtrUInt(vmtMethodTable))^; - if Table=nil then - exit; - SetLength(Methods,result+Table^[0]); - M := @Table^[1]; - for i := 1 to Table^[0] do // Table^[0] = methods count - with Methods[result] do begin - ShortStringToAnsi7String(M^.Name{$ifdef FPC}^{$endif},Name); - Method.Data := Instance; - Method.Code := M^.Addr; - {$ifdef FPC} - inc(M); - {$else} - inc(PByte(M),M^.Len); - {$endif} - inc(result); - end; - end; -begin - result := 0; - if aClass <> nil then - AddParentsFirst(aClass) - else if Instance<>nil then - AddParentsFirst(PPointer(Instance)^); // use recursion for adding -end; - -function GetCaptionFromClass(C: TClass): string; -var tmp: RawUTF8; - P: PUTF8Char; -begin - if C=nil then - result := '' else begin - ToText(C,tmp); - P := pointer(tmp); - if IdemPChar(P,'TSQL') or IdemPChar(P,'TSYN') then - inc(P,4) else - if P^='T' then - inc(P); - GetCaptionFromPCharLen(P,result); - end; -end; - -function GetCaptionFromEnum(aTypeInfo: pointer; aIndex: integer): string; -begin - GetCaptionFromTrimmed(GetEnumName(aTypeInfo,aIndex),result); -end; - -function CharSetToCodePage(CharSet: integer): cardinal; -begin - case CharSet of - SHIFTJIS_CHARSET: result := 932; - HANGEUL_CHARSET: result := 949; - GB2312_CHARSET: result := 936; - HEBREW_CHARSET: result := 1255; - ARABIC_CHARSET: result := 1256; - GREEK_CHARSET: result := 1253; - TURKISH_CHARSET: result := 1254; - VIETNAMESE_CHARSET: result := 1258; - THAI_CHARSET: result := 874; - EASTEUROPE_CHARSET: result := 1250; - RUSSIAN_CHARSET: result := 1251; - BALTIC_CHARSET: result := 1257; - else result := CODEPAGE_US; // default is ANSI_CHARSET = iso-8859-1 = windows-1252 - end; -end; - -function CodePageToCharSet(CodePage: Cardinal): Integer; -begin - case CodePage of - 932: result := SHIFTJIS_CHARSET; - 949: result := HANGEUL_CHARSET; - 936: result := GB2312_CHARSET; - 1255: result := HEBREW_CHARSET; - 1256: result := ARABIC_CHARSET; - 1253: result := GREEK_CHARSET; - 1254: result := TURKISH_CHARSET; - 1258: result := VIETNAMESE_CHARSET; - 874: result := THAI_CHARSET; - 1250: result := EASTEUROPE_CHARSET; - 1251: result := RUSSIAN_CHARSET; - 1257: result := BALTIC_CHARSET; - else result := ANSI_CHARSET; // default is iso-8859-1 = windows-1252 - end; -end; - -function GetMimeContentTypeFromBuffer(Content: Pointer; Len: PtrInt; - const DefaultContentType: RawUTF8): RawUTF8; -begin // see http://www.garykessler.net/library/file_sigs.html for magic numbers - result := DefaultContentType; - if (Content<>nil) and (Len>4) then - case PCardinal(Content)^ of - $04034B50: result := 'application/zip'; // 50 4B 03 04 - $46445025: result := 'application/pdf'; // 25 50 44 46 2D 31 2E - $21726152: result := 'application/x-rar-compressed'; // 52 61 72 21 1A 07 00 - $AFBC7A37: result := 'application/x-7z-compressed'; // 37 7A BC AF 27 1C - $694C5153: result := 'application/x-sqlite3'; // SQlite format 3 = 53 51 4C 69 - $75B22630: result := 'audio/x-ms-wma'; // 30 26 B2 75 8E 66 - $9AC6CDD7: result := 'video/x-ms-wmv'; // D7 CD C6 9A 00 00 - $474E5089: result := 'image/png'; // 89 50 4E 47 0D 0A 1A 0A - $38464947: result := 'image/gif'; // 47 49 46 38 - $46464F77: result := 'application/font-woff'; // wOFF in BigEndian - $A3DF451A: result := 'video/webm'; // 1A 45 DF A3 MKV Matroska stream file - $002A4949, $2A004D4D, $2B004D4D: - result := 'image/tiff'; // 49 49 2A 00 or 4D 4D 00 2A or 4D 4D 00 2B - $46464952: if Len>16 then // RIFF - case PCardinalArray(Content)^[2] of - $50424557: result := 'image/webp'; - $20495641: if PCardinalArray(Content)^[3]=$5453494C then - result := 'video/x-msvideo'; // Windows Audio Video Interleave file - end; - $E011CFD0: // Microsoft Office applications D0 CF 11 E0=DOCFILE - if Len>600 then - case PWordArray(Content)^[256] of // at offset 512 - $A5EC: result := 'application/msword'; // EC A5 C1 00 - $FFFD: // FD FF FF - case PByteArray(Content)^[516] of - $0E,$1C,$43: result := 'application/vnd.ms-powerpoint'; - $10,$1F,$20,$22,$23,$28,$29: result := 'application/vnd.ms-excel'; - end; - end; - $5367674F: - if Len>14 then // OggS - if (PCardinalArray(Content)^[1]=$00000200) and - (PCardinalArray(Content)^[2]=$00000000) and - (PWordArray(Content)^[6]=$0000) then - result := 'video/ogg'; - $1C000000: - if Len>12 then - if PCardinalArray(Content)^[1]=$70797466 then // ftyp - case PCardinalArray(Content)^[2] of - $6D6F7369, // isom: ISO Base Media file (MPEG-4) v1 - $3234706D: // mp42: MPEG-4 video/QuickTime file - result := 'video/mp4'; - $35706733: // 3gp5: MPEG-4 video files - result := 'video/3gpp'; - end; - else - case PCardinal(Content)^ and $00ffffff of - $685A42: result := 'application/bzip2'; // 42 5A 68 - $088B1F: result := 'application/gzip'; // 1F 8B 08 - $492049: result := 'image/tiff'; // 49 20 49 - $FFD8FF: result := JPEG_CONTENT_TYPE; // FF D8 FF DB/E0/E1/E2/E3/E8 - else - case PWord(Content)^ of - $4D42: result := 'image/bmp'; // 42 4D - end; - end; - end; -end; - -function GetMimeContentType(Content: Pointer; Len: PtrInt; - const FileName: TFileName): RawUTF8; -begin - if FileName<>'' then begin // file extension is more precise -> check first - result := LowerCase(StringToAnsi7(ExtractFileExt(FileName))); - case PosEx(copy(result,2,4), - 'png,gif,tiff,jpg,jpeg,bmp,doc,htm,html,css,js,ico,wof,txt,svg,'+ - // 1 5 9 14 18 23 27 31 35 40 44 47 51 55 59 - 'atom,rdf,rss,webp,appc,mani,docx,xml,json,woff,ogg,ogv,mp4,m2v,'+ - // 63 68 72 76 81 86 91 96 100 105 110 114 118 122 - 'm2p,mp3,h264,text,log,gz,webm,mkv,rar,7z') of - // 126 130 134 139 144 148 151 156 160 164 - 1: result := 'image/png'; - 5: result := 'image/gif'; - 9: result := 'image/tiff'; - 14,18: result := JPEG_CONTENT_TYPE; - 23: result := 'image/bmp'; - 27,91: result := 'application/msword'; - 31,35: result := HTML_CONTENT_TYPE; - 40: result := 'text/css'; - 44: result := 'application/javascript'; - // text/javascript and application/x-javascript are obsolete (RFC 4329) - 47: result := 'image/x-icon'; - 51,105: result := 'application/font-woff'; - 55,139,144: result := TEXT_CONTENT_TYPE; - 59: result := 'image/svg+xml'; - 63,68,72,96: result := XML_CONTENT_TYPE; - 76: result := 'image/webp'; - 81,86: result := 'text/cache-manifest'; - 100: result := JSON_CONTENT_TYPE_VAR; - 110,114: result := 'video/ogg'; // RFC 5334 - 118: result := 'video/mp4'; // RFC 4337 6381 - 122,126: result := 'video/mp2'; - 130: result := 'audio/mpeg'; // RFC 3003 - 134: result := 'video/H264'; // RFC 6184 - 148: result := 'application/gzip'; - 151,156: result := 'video/webm'; - 160: result := 'application/x-rar-compressed'; - 164: result := 'application/x-7z-compressed'; - else - result := GetMimeContentTypeFromBuffer(Content,Len,'application/'+copy(result,2,20)); - end; - end else - result := GetMimeContentTypeFromBuffer(Content,Len,BINARY_CONTENT_TYPE); -end; - -function GetMimeContentTypeHeader(const Content: RawByteString; - const FileName: TFileName): RawUTF8; -begin - result := HEADER_CONTENT_TYPE+ - GetMimeContentType(Pointer(Content),length(Content),FileName); -end; - -function IsContentCompressed(Content: Pointer; Len: PtrInt): boolean; -begin // see http://www.garykessler.net/library/file_sigs.html - result := false; - if (Content<>nil) and (Len>8) then - case PCardinal(Content)^ of - $002a4949, $2a004d4d, $2b004d4d, // 'image/tiff' - $04034b50, // 'application/zip' = 50 4B 03 04 - $184d2204, // LZ4 stream format = 04 22 4D 18 - $21726152, // 'application/x-rar-compressed' = 52 61 72 21 1A 07 00 - $28635349, // cab = 49 53 63 28 - $38464947, // 'image/gif' = 47 49 46 38 - $43614c66, // FLAC = 66 4C 61 43 00 00 00 22 - $4643534d, // cab = 4D 53 43 46 [MSCF] - $46464952, // avi,webp,wav = 52 49 46 46 [RIFF] - $46464f77, // 'application/font-woff' = wOFF in BigEndian - $474e5089, // 'image/png' = 89 50 4E 47 0D 0A 1A 0A - $4d5a4cff, // LZMA = FF 4C 5A 4D 41 00 - $72613c21, // .ar/.deb files = '!' (assuming compressed) - $75b22630, // 'audio/x-ms-wma' = 30 26 B2 75 8E 66 - $766f6f6d, // mov = 6D 6F 6F 76 [....moov] - $89a8275f, // jar = 5F 27 A8 89 - $9ac6cdd7, // 'video/x-ms-wmv' = D7 CD C6 9A 00 00 - $a5a5a5a5, // .mab file = MAGIC_MAB in SynLog.pas - $a5aba5a5, // .data = TSQLRESTSTORAGEINMEMORY_MAGIC in mORMot.pas - $aba51051, // .log.synlz = LOG_MAGIC in SynLog.pas - $aba5a5ab, // .dbsynlz = SQLITE3_MAGIC in SynSQLite3.pas - $afbc7a37, // 'application/x-7z-compressed' = 37 7A BC AF 27 1C - $b7010000, $ba010000, // mpeg = 00 00 01 Bx - $cececece, // jceks = CE CE CE CE - $dbeeabed, // .rpm package file - $e011cfd0: // msi = D0 CF 11 E0 A1 B1 1A E1 - result := true; - else - case PCardinal(Content)^ and $00ffffff of - $088b1f, // 'application/gzip' = 1F 8B 08 - $334449, // mp3 = 49 44 33 [ID3] - $492049, // 'image/tiff' = 49 20 49 - $535746, // swf = 46 57 53 [FWS] - $535743, // swf = 43 57 53 [zlib] - $53575a, // zws/swf = 5A 57 53 [FWS] - $564c46, // flv = 46 4C 56 [FLV] - $685a42, // 'application/bzip2' = 42 5A 68 - $ffd8ff: // JPEG_CONTENT_TYPE = FF D8 FF DB/E0/E1/E2/E3/E8 - result := true; - else - case PCardinalArray(Content)^[1] of // 4 byte offset - 1{TAlgoSynLZ.AlgoID}: // crc32 01 00 00 00 crc32 = Compress() header - result := PCardinalArray(Content)^[0]<>PCardinalArray(Content)^[2]; - $70797466, // mp4,mov = 66 74 79 70 [33 67 70 35/4D 53 4E 56..] - $766f6f6d: // mov = 6D 6F 6F 76 - result := true; - end; - end; - end; -end; - -function GetJpegSize(jpeg: PAnsiChar; len: PtrInt; out Height, Width: integer): boolean; -var je: PAnsiChar; -begin // see https://en.wikipedia.org/wiki/JPEG#Syntax_and_structure - result := false; - if (jpeg=nil) or (len<100) or (PWord(jpeg)^<>$d8ff) then // SOI - exit; - je := jpeg+len-1; - inc(jpeg,2); - while jpeg#$ff then - exit; - inc(jpeg); - case ord(jpeg^) of - $c0..$c3,$c5..$c7,$c9..$cb,$cd..$cf: begin // SOF - Height := swap(PWord(jpeg+4)^); - Width := swap(PWord(jpeg+6)^); - result := (Height>0) and (Height<20000) and (Width>0) and (Width<20000); - exit; - end; - $d0..$d8,$01: inc(jpeg); // RST, SOI - $d9: break; // EOI - $ff: ; // padding - else inc(jpeg,swap(PWord(jpeg+1)^)+1); - end; - end; -end; - -function GetJpegSize(const jpeg: TFileName; out Height, Width: integer): boolean; -var map: TMemoryMap; -begin - if map.Map(jpeg) then - try - result := GetJpegSize(map.Buffer,map.Size,Height,Width); - finally - map.UnMap; - end else - result := false; -end; - -function IsHTMLContentTypeTextual(Headers: PUTF8Char): Boolean; -begin - result := ExistsIniNameValue(Headers,HEADER_CONTENT_TYPE_UPPER, - [JSON_CONTENT_TYPE_UPPER,'TEXT/','APPLICATION/XML','APPLICATION/JAVASCRIPT', - 'APPLICATION/X-JAVASCRIPT','IMAGE/SVG+XML']); -end; - -function MultiPartFormDataDecode(const MimeType,Body: RawUTF8; - var MultiPart: TMultiPartDynArray): boolean; -var boundary,endBoundary: RawUTF8; - i,j: integer; - P: PUTF8Char; - part: TMultiPart; -begin - result := false; - i := PosEx('boundary=',MimeType); - if i=0 then - exit; - TrimCopy(MimeType,i+9,200,boundary); - if (boundary<>'') and (boundary[1]='"') then - boundary := copy(boundary,2,length(boundary)-2); // "boundary" -> boundary - boundary := '--'+boundary; - endBoundary := boundary+'--'+#13#10; - boundary := boundary+#13#10; - i := PosEx(boundary,Body); - if i<>0 then - repeat - inc(i,length(boundary)); - if i=length(body) then - exit; // reached the end - P := PUTF8Char(Pointer(Body))+i-1; - Finalize(part); - repeat - if IdemPChar(P,'CONTENT-DISPOSITION: ') then begin - inc(P,21); - if IdemPCharAndGetNextItem(P,'FORM-DATA; NAME="',part.Name,'"') then - IdemPCharAndGetNextItem(P,'; FILENAME="',part.FileName,'"') else - IdemPCharAndGetNextItem(P,'FILE; FILENAME="',part.FileName,'"') - end else - if not IdemPCharAndGetNextItem(P,'CONTENT-TYPE: ',part.ContentType) then - IdemPCharAndGetNextItem(P,'CONTENT-TRANSFER-ENCODING: ',part.Encoding); - P := GotoNextLine(P); - if P=nil then - exit; - until PWord(P)^=13+10 shl 8; - i := P-PUTF8Char(Pointer(Body))+3; // i = just after header - j := PosEx(boundary,Body,i); - if j=0 then begin - j := PosEx(endboundary,Body,i); // try last boundary - if j=0 then - exit; - end; - part.Content := copy(Body,i,j-i-2); // -2 to ignore latest #13#10 - if (part.ContentType='') or (PosEx('-8',part.ContentType)>0) then begin - part.ContentType := TEXT_CONTENT_TYPE; - {$ifdef HASCODEPAGE} - SetCodePage(part.Content,CP_UTF8,false); // ensure raw field value is UTF-8 - {$endif} - end; - if IdemPropNameU(part.Encoding,'base64') then - part.Content := Base64ToBin(part.Content); - // note: "quoted-printable" not yet handled here - SetLength(MultiPart,length(MultiPart)+1); - MultiPart[high(MultiPart)] := part; - result := true; - i := j; - until false; -end; - -function MultiPartFormDataEncode(const MultiPart: TMultiPartDynArray; - var MultiPartContentType, MultiPartContent: RawUTF8): boolean; -var len, boundcount, filescount, i: integer; - boundaries: array of RawUTF8; - bound: RawUTF8; - W: TTextWriter; - temp: TTextWriterStackBuffer; - procedure NewBound; - var random: array[1..3] of cardinal; - begin - FillRandom(@random,3,{forcegsl=}true); - bound := BinToBase64(@random,SizeOf(Random)); - SetLength(boundaries,boundcount+1); - boundaries[boundcount] := bound; - inc(boundcount); - end; -begin - result := false; - len := length(MultiPart); - if len=0 then - exit; - boundcount := 0; - filescount := 0; - W := TTextWriter.CreateOwnedStream(temp); - try - // header - see https://www.w3.org/Protocols/rfc1341/7_2_Multipart.html - NewBound; - MultiPartContentType := 'Content-Type: multipart/form-data; boundary='+bound; - for i := 0 to len-1 do - with MultiPart[i] do begin - if FileName='' then - W.Add('--%'#13#10'Content-Disposition: form-data; name="%"'#13#10+ - 'Content-Type: %'#13#10#13#10'%'#13#10'--%'#13#10, - [bound,Name,ContentType,Content,bound]) else begin - // if this is the first file, create the header for files - if filescount=0 then begin - if i>0 then - NewBound; - W.Add('Content-Disposition: form-data; name="files"'#13#10+ - 'Content-Type: multipart/mixed; boundary=%'#13#10#13#10,[bound]); - end; - inc(filescount); - W.Add('--%'#13#10'Content-Disposition: file; filename="%"'#13#10+ - 'Content-Type: %'#13#10,[bound,FileName,ContentType]); - if Encoding<>'' then - W.Add('Content-Transfer-Encoding: %'#13#10,[Encoding]); - W.AddCR; - W.AddString(MultiPart[i].Content); - W.Add(#13#10'--%'#13#10,[bound]); - end; - end; - // footer multipart - for i := boundcount-1 downto 0 do - W.Add('--%--'#13#10, [boundaries[i]]); - W.SetText(MultiPartContent); - result := True; - finally - W.Free; - end; -end; - -function MultiPartFormDataAddFile(const FileName: TFileName; - var MultiPart: TMultiPartDynArray; const Name: RawUTF8): boolean; -var part: TMultiPart; - newlen: integer; - content: RawByteString; -begin - result := false; - content := StringFromFile(FileName); - if content='' then - exit; - newlen := length(MultiPart)+1; - if Name='' then - FormatUTF8('File%',[newlen],part.Name) else - part.Name := Name; - part.FileName := StringToUTF8(ExtractFileName(FileName)); - part.ContentType := GetMimeContentType(pointer(content),length(content),FileName); - part.Encoding := 'base64'; - part.Content := BinToBase64(content); - SetLength(MultiPart,newlen); - MultiPart[newlen-1] := part; - result := true; -end; - -function MultiPartFormDataAddField(const FieldName, FieldValue: RawUTF8; - var MultiPart: TMultiPartDynArray): boolean; -var - part: TMultiPart; - newlen: integer; -begin - result := false; - if FieldName='' then - exit; - newlen := length(MultiPart)+1; - part.Name := FieldName; - part.ContentType := GetMimeContentTypeFromBuffer( - pointer(FieldValue),length(FieldValue),'text/plain'); - part.Content := FieldValue; - SetLength(MultiPart,newlen); - MultiPart[newlen-1] := part; - result := true; -end; - -function FastLocatePUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt; Value: PUTF8Char): PtrInt; -begin - result := FastLocatePUTF8CharSorted(P,R,Value,TUTF8Compare(@StrComp)); -end; - -function FastLocatePUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt; Value: PUTF8Char; - Compare: TUTF8Compare): PtrInt; -var L,i,cmp: PtrInt; -begin // fast O(log(n)) binary search - if not Assigned(Compare) or (R<0) then - result := 0 else - if Compare(P^[R],Value)<0 then // quick return if already sorted - result := R+1 else begin - L := 0; - result := -1; // return -1 if found - repeat - i := (L + R) shr 1; - cmp := Compare(P^[i],Value); - if cmp=0 then - exit; - if cmp<0 then - L := i + 1 else - R := i - 1; - until (L > R); - while (i>=0) and (Compare(P^[i],Value)>=0) do dec(i); - result := i+1; // return the index where to insert - end; -end; - -function FastFindPUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt; Value: PUTF8Char; - Compare: TUTF8Compare): PtrInt; -var L, cmp: PtrInt; -begin // fast O(log(n)) binary search - L := 0; - if Assigned(Compare) and (R>=0) then - repeat - result := (L+R) shr 1; - cmp := Compare(P^[result],Value); - if cmp=0 then - exit; - if cmp<0 then begin - L := result+1; - if L<=R then - continue; - break; - end; - R := result-1; - if L<=R then - continue; - break; - until false; - result := -1; -end; - -function FastFindPUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt; Value: PUTF8Char): PtrInt; -{$ifdef CPUX64} // P=rcx/rdi R=rdx/rsi Value=r8/rdx -{$ifdef FPC} assembler; nostackframe; asm {$else} asm .noframe {$endif} - {$ifdef win64} - push rdi - mov rdi, P // P=rdi - {$endif} - push r12 - push r13 - xor r9, r9 // L=r9 - test R, R - jl @err - test Value, Value - jz @void - mov cl, byte ptr[Value] // to check first char (likely diverse) -@s: lea rax, qword ptr[r9 + R] - shr rax, 1 - lea r12, qword ptr[rax - 1] // branchless main loop - lea r13, qword ptr[rax + 1] - mov r10, qword ptr[rdi + rax * 8] - test r10, r10 - jz @lt - cmp cl, byte ptr[r10] - je @eq - cmovc R, r12 - cmovnc r9, r13 -@nxt: cmp r9, R - jle @s -@err: or rax, -1 -@found: pop r13 - pop r12 - {$ifdef win64} - pop rdi - {$endif} - ret -@lt: mov r9, r13 // very unlikely P[rax]=nil - jmp @nxt -@eq: mov r11, Value -@sub: mov cl, byte ptr[r10] - inc r10 - inc r11 - test cl, cl - jz @found - mov cl, byte ptr[r11] - cmp cl, byte ptr[r10] - je @sub - mov cl, byte ptr[Value] // reset first char - cmovc R, r12 - cmovnc r9, r13 - cmp r9, R - jle @s - jmp @err -@void: or rax, -1 - cmp qword ptr[P], 0 - cmove rax, Value - jmp @found -end; -{$else} -var L: PtrInt; - c: byte; - piv,val: PByte; -begin // fast O(log(n)) binary search using inlined StrCompFast() - if R>=0 then - if Value<>nil then begin - L := 0; - repeat - result := (L+R) shr 1; - piv := pointer(P^[result]); - if piv<>nil then begin - val := pointer(Value); - c := piv^; - if c=val^ then - repeat - if c=0 then - exit; // StrComp(P^[result],Value)=0 - inc(piv); - inc(val); - c := piv^; - until c<>val^; - if c>val^ then begin - R := result-1; // StrComp(P^[result],Value)>0 - if L<=R then - continue; - break; - end; - end; - L := result+1; // StrComp(P^[result],Value)<0 - if L<=R then - continue; - break; - until false; - end else - if P^[0]=nil then begin // '' should be in lowest P[] slot - result := 0; - exit; - end; - result := -1; -end; -{$endif CPUX64} - -function FastFindUpperPUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt; - Value: PUTF8Char; ValueLen: PtrInt): PtrInt; -var tmp: array[byte] of AnsiChar; -begin - UpperCopy255Buf(@tmp,Value,ValueLen)^ := #0; - result := FastFindPUTF8CharSorted(P,R,@tmp); -end; - -function FastFindIndexedPUTF8Char(P: PPUTF8CharArray; R: PtrInt; - var SortedIndexes: TCardinalDynArray; Value: PUTF8Char; - ItemComp: TUTF8Compare): PtrInt; -var L, cmp: PtrInt; -begin // fast O(log(n)) binary search - L := 0; - if 0<=R then - repeat - result := (L + R) shr 1; - cmp := ItemComp(P^[SortedIndexes[result]],Value); - if cmp=0 then begin - result := SortedIndexes[result]; - exit; - end; - if cmp<0 then begin - L := result+1; - if L<=R then - continue; - break; - end; - R := result-1; - if L<=R then - continue; - break; - until false; - result := -1; -end; - -function AddSortedRawUTF8(var Values: TRawUTF8DynArray; var ValuesCount: integer; - const Value: RawUTF8; CoValues: PIntegerDynArray; ForcedIndex: PtrInt; - Compare: TUTF8Compare): PtrInt; -var n: PtrInt; -begin - if ForcedIndex>=0 then - result := ForcedIndex else begin - if not Assigned(Compare) then - Compare := @StrComp; - result := FastLocatePUTF8CharSorted(pointer(Values),ValuesCount-1,pointer(Value),Compare); - if result<0 then - exit; // Value exists -> fails - end; - n := Length(Values); - if ValuesCount=n then begin - n := NextGrow(n); - SetLength(Values,n); - if CoValues<>nil then - SetLength(CoValues^,n); - end; - n := ValuesCount; - if resultnil then begin - {$ifdef CPU64}n := n shr 1;{$endif} // 64-bit pointer size is twice an integer - MoveFast(CoValues^[result],CoValues^[result+1],n); - end; - end else - result := n; - Values[result] := Value; - inc(ValuesCount); -end; - - -type - /// used internaly for faster quick sort - TQuickSortRawUTF8 = object - Values: PPointerArray; - Compare: TUTF8Compare; - CoValues: PIntegerArray; - pivot: pointer; - procedure Sort(L,R: PtrInt); - end; - -procedure TQuickSortRawUTF8.Sort(L, R: PtrInt); -var I, J, P: PtrInt; - Tmp: Pointer; - TmpInt: integer; -begin - if L0 do Dec(J); - if I <= J then begin - Tmp := Values^[J]; - Values^[J] := Values^[I]; - Values^[I] := Tmp; - if CoValues<>nil then begin - TmpInt := CoValues^[J]; - CoValues^[J] := CoValues^[I]; - CoValues^[I] := TmpInt; - end; - if P = I then P := J else if P = J then P := I; - Inc(I); Dec(J); - end; - until I > J; - if J - L < R - I then begin // use recursion only for smaller range - if L < J then - Sort(L, J); - L := I; - end else begin - if I < R then - Sort(I, R); - R := J; - end; - until L >= R; -end; - -procedure QuickSortRawUTF8(var Values: TRawUTF8DynArray; ValuesCount: integer; - CoValues: PIntegerDynArray; Compare: TUTF8Compare); -var QS: TQuickSortRawUTF8; -begin - QS.Values := pointer(Values); - if Assigned(Compare) then - QS.Compare := Compare else - QS.Compare := @StrComp; - if CoValues=nil then - QS.CoValues := nil else - QS.CoValues := pointer(CoValues^); - QS.Sort(0,ValuesCount-1); -end; - -function DeleteRawUTF8(var Values: TRawUTF8DynArray; Index: integer): boolean; -var n: integer; -begin - n := length(Values); - if cardinal(Index)>=cardinal(n) then - result := false else begin - dec(n); - if PDACnt(PtrUInt(Values)-_DAREFCNT)^>1 then - DynArrayMakeUnique(@Values,TypeInfo(TRawUTF8DynArray)); - Values[Index] := ''; // avoid GPF - if n>Index then begin - MoveFast(pointer(Values[Index+1]),pointer(Values[Index]),(n-Index)*SizeOf(pointer)); - PtrUInt(Values[n]) := 0; // avoid GPF - end; - SetLength(Values,n); - result := true; - end; -end; - -function DeleteRawUTF8(var Values: TRawUTF8DynArray; var ValuesCount: integer; - Index: integer; CoValues: PIntegerDynArray): boolean; -var n: integer; -begin - n := ValuesCount; - if cardinal(Index)>=cardinal(n) then - result := false else begin - dec(n); - ValuesCount := n; - if PDACnt(PtrUInt(Values)-_DAREFCNT)^>1 then - DynArrayMakeUnique(@Values,TypeInfo(TRawUTF8DynArray)); - Values[Index] := ''; // avoid GPF - dec(n,Index); - if n>0 then begin - if CoValues<>nil then - MoveFast(CoValues^[Index+1],CoValues^[Index],n*SizeOf(Integer)); - MoveFast(pointer(Values[Index+1]),pointer(Values[Index]),n*SizeOf(pointer)); - PtrUInt(Values[ValuesCount]) := 0; // avoid GPF - end; - result := true; - end; -end; - -function ToText(const aIntelCPUFeatures: TIntelCpuFeatures; const Sep: RawUTF8): RawUTF8; -var f: TIntelCpuFeature; - List: PShortString; - MaxValue: integer; -begin - result := ''; - List := GetEnumInfo(TypeInfo(TIntelCpuFeature),MaxValue); - if List<>nil then - for f := low(f) to high(f) do begin - if (f in aIntelCPUFeatures) and (List^[3]<>'_') then begin - if result<>'' then - result := result+Sep; - result := result+RawUTF8(copy(List^,3,10)); - end; - inc(PByte(List),PByte(List)^+1); // next - end; -end; - -{$ifdef MSWINDOWS} - -// wrapper around some low-level Windows-specific API - -{$ifdef DELPHI6OROLDER} -function GetFileVersion(const FileName: TFileName): cardinal; -var Size, Size2: DWord; - Pt: Pointer; - Info: ^TVSFixedFileInfo; - tmp: TFileName; -begin - result := cardinal(-1); - if FileName='' then - exit; - // GetFileVersionInfo modifies the filename parameter data while parsing - // Copy the string const into a local variable to create a writeable copy - SetString(tmp,PChar(FileName),length(FileName)); - Size := GetFileVersionInfoSize(pointer(tmp), Size2); - if Size>0 then begin - GetMem(Pt, Size); - try - GetFileVersionInfo(pointer(FileName), 0, Size, Pt); - if VerQueryValue(Pt, '\', pointer(Info), Size2) then - result := Info^.dwFileVersionMS; - finally - Freemem(Pt); - end; - end; -end; -{$endif DELPHI6OROLDER} - -function WndProcMethod(Hwnd: HWND; Msg,wParam,lParam: integer): integer; stdcall; -var obj: TObject; - dsp: TMessage; -begin - {$ifdef CPU64} - obj := pointer(GetWindowLongPtr(HWnd,GWLP_USERDATA)); - {$else} - obj := pointer(GetWindowLong(HWnd,GWL_USERDATA)); // faster than GetProp() - {$endif CPU64} - if not Assigned(obj) then - result := DefWindowProc(HWnd,Msg,wParam,lParam) else begin - dsp.msg := Msg; - dsp.wParam := WParam; - dsp.lParam := lParam; - dsp.result := 0; - obj.Dispatch(dsp); - result := dsp.result; - end; -end; - -function CreateInternalWindow(const aWindowName: string; aObject: TObject): HWND; -var TempClass: TWndClass; -begin - result := 0; - if GetClassInfo(HInstance, pointer(aWindowName), TempClass) then - exit; // class name already registered -> fail - FillCharFast(TempClass,SizeOf(TempClass),0); - TempClass.hInstance := HInstance; - TempClass.lpfnWndProc := @DefWindowProc; - TempClass.lpszClassName := pointer(aWindowName); - Windows.RegisterClass(TempClass); - result := CreateWindowEx(WS_EX_TOOLWINDOW, pointer(aWindowName), - '', WS_POPUP {!0}, 0, 0, 0, 0, 0, 0, HInstance, nil); - if result=0 then - exit; // impossible to create window -> fail - {$ifdef CPU64} - SetWindowLongPtr(result,GWLP_USERDATA,PtrInt(aObject)); - SetWindowLongPtr(result,GWLP_WNDPROC,PtrInt(@WndProcMethod)); - {$else} - SetWindowLong(result,GWL_USERDATA,PtrInt(aObject)); // faster than SetProp() - SetWindowLong(result,GWL_WNDPROC,PtrInt(@WndProcMethod)); - {$endif CPU64} -end; - -function ReleaseInternalWindow(var aWindowName: string; var aWindow: HWND): boolean; -begin - if (aWindow<>0) and (aWindowName<>'') then begin - {$ifdef CPU64} - SetWindowLongPtr(aWindow,GWLP_WNDPROC,PtrInt(@DefWindowProc)); - {$else} - SetWindowLong(aWindow,GWL_WNDPROC,PtrInt(@DefWindowProc)); - {$endif CPU64} - DestroyWindow(aWindow); - Windows.UnregisterClass(pointer(aWindowName),HInstance); - aWindow := 0; - aWindowName := ''; - result := true; - end else - result := false; -end; - -var - LastAppUserModelID: string; - -function SetAppUserModelID(const AppUserModelID: string): boolean; -var shell32: THandle; - id: SynUnicode; - SetCurrentProcessExplicitAppUserModelID: function(appID: PWidechar): HResult; stdcall; -begin - if AppUserModelID=LastAppUserModelID then begin - result := true; - exit; // nothing to set - end; - result := false; - shell32 := GetModuleHandle('shell32.dll'); - if shell32=0 then - exit; - SetCurrentProcessExplicitAppUserModelID := GetProcAddress( - shell32,'SetCurrentProcessExplicitAppUserModelID'); - if not Assigned(SetCurrentProcessExplicitAppUserModelID) then - exit; // API available since Windows Seven / Server 2008 R2 - StringToSynUnicode(AppUserModelID,id); - if Pos('.',AppUserModelID)=0 then - id := id+'.'+id; // at least CompanyName.ProductName - if SetCurrentProcessExplicitAppUserModelID(pointer(id))<>S_OK then - exit; - result := true; - LastAppUserModelID := AppUserModelID; -end; - -{$endif MSWINDOWS} - -{ TFileVersion } - -constructor TFileVersion.Create(const aFileName: TFileName; - aMajor,aMinor,aRelease,aBuild: integer); -var M,D: word; -{$ifdef MSWINDOWS} - Size, Size2: DWord; - Pt, StrPt, StrValPt: Pointer; - LanguageInfo: RawUTF8; - Info: ^TVSFixedFileInfo; - FileTime: TFILETIME; - SystemTime: TSYSTEMTIME; - tmp: TFileName; - function ReadResourceByName(const From: RawUTF8): RawUTF8; - var sz: DWord; - begin - VerQueryValueA(Pt,PAnsiChar('\StringFileInfo\'+LanguageInfo+'\'+From),StrValPt,sz); - if sz>0 then - FastSetString(Result,StrValPt,sz) - end; -{$else} -{$ifdef FPCUSEVERSIONINFO} - VI: TVersionInfo; - LanguageInfo: String; - TI, I: Integer; -{$endif} -{$endif MSWINDOWS} -begin - fFileName := aFileName; - {$ifdef MSWINDOWS} - if aFileName<>'' then begin - // GetFileVersionInfo modifies the filename parameter data while parsing. - // Copy the string const into a local variable to create a writeable copy. - SetString(tmp,PChar(aFileName),length(aFileName)); - Size := GetFileVersionInfoSize(pointer(tmp), Size2); - if Size>0 then begin - GetMem(Pt, Size); - try - GetFileVersionInfo(pointer(aFileName), 0, Size, Pt); - VerQueryValue(Pt, '\', pointer(Info), Size2); - with Info^ do begin - if Version32=0 then begin - aMajor := dwFileVersionMS shr 16; - aMinor := word(dwFileVersionMS); - aRelease := dwFileVersionLS shr 16; - end; - aBuild := word(dwFileVersionLS); - if (dwFileDateLS<>0) and (dwFileDateMS<>0) then begin - FileTime.dwLowDateTime:= dwFileDateLS; // built date from version info - FileTime.dwHighDateTime:= dwFileDateMS; - FileTimeToSystemTime(FileTime, SystemTime); - fBuildDateTime := EncodeDate( - SystemTime.wYear,SystemTime.wMonth,SystemTime.wDay); - end; - end; - VerQueryValue(Pt, '\VarFileInfo\Translation', StrPt, Size2); - if Size2 >= 4 then begin - LanguageInfo := BinToHexDisplay(PAnsiChar(StrPt), 2) + BinToHexDisplay(PAnsiChar(StrPt)+2, 2); - CompanyName := ReadResourceByName('CompanyName'); - FileDescription := ReadResourceByName('FileDescription'); - FileVersion := ReadResourceByName('FileVersion'); - InternalName := ReadResourceByName('InternalName'); - LegalCopyright := ReadResourceByName('LegalCopyright'); - OriginalFilename := ReadResourceByName('OriginalFilename'); - ProductName := ReadResourceByName('ProductName'); - ProductVersion := ReadResourceByName('ProductVersion'); - Comments := ReadResourceByName('Comments'); - end - finally - Freemem(Pt); - end; - end; - end; - {$else MSWINDOWS} - {$ifdef FPCUSEVERSIONINFO} // FPC 3.0+ if enabled in Synopse.inc / project options - if aFileName<>'' then - try - VI := TVersionInfo.Create; - try - if (aFileName<>ExeVersion.ProgramFileName) and (aFileName<>ParamStr(0)) then - VI.Load(aFileName) else - VI.Load(HInstance); // load info for currently running program - aMajor := VI.FixedInfo.FileVersion[0]; - aMinor := VI.FixedInfo.FileVersion[1]; - aRelease := VI.FixedInfo.FileVersion[2]; - aBuild := VI.FixedInfo.FileVersion[3]; - //fBuildDateTime := TDateTime(VI.FixedInfo.FileDate); << need to find out how to convert this before uncommenting - // detect translation. - if VI.VarFileInfo.Count>0 then - with VI.VarFileInfo.Items[0] do - LanguageInfo := Format('%.4x%.4x',[language,codepage]); - if LanguageInfo='' then begin - // take first language - Ti := 0; - if VI.StringFileInfo.Count>0 then - LanguageInfo := VI.StringFileInfo.Items[0].Name - end else begin - // look for index of language - TI := VI.StringFileInfo.Count-1; - while (TI>=0) and (CompareText(VI.StringFileInfo.Items[TI].Name,LanguageInfo)<>0) do - dec(TI); - if (TI < 0) then begin - TI := 0; // revert to first translation - LanguageInfo := VI.StringFileInfo.Items[TI].Name; - end; - end; - with VI.StringFileInfo.Items[TI] do begin - CompanyName := Values['CompanyName']; - FileDescription := Values['FileDescription']; - FileVersion := Values['FileVersion']; - InternalName := Values['InternalName']; - LegalCopyright := Values['LegalCopyright']; - OriginalFilename := Values['OriginalFilename']; - ProductName := Values['ProductName']; - ProductVersion := Values['ProductVersion']; - Comments := Values['Comments']; - end; - finally - VI.Free; - end; - except - // just ignore if version information resource is missing - end; - {$endif FPCUSEVERSIONINFO} - {$endif MSWINDOWS} - SetVersion(aMajor,aMinor,aRelease,aBuild); - if fBuildDateTime=0 then // get build date from file age - fBuildDateTime := FileAgeToDateTime(aFileName); - if fBuildDateTime<>0 then - DecodeDate(fBuildDateTime,BuildYear,M,D); -end; - -function TFileVersion.Version32: integer; -begin - result := Major shl 16+Minor shl 8+Release; -end; - -procedure TFileVersion.SetVersion(aMajor,aMinor,aRelease,aBuild: integer); -begin - Major := aMajor; - Minor := aMinor; - Release := aRelease; - Build := aBuild; - Main := IntToString(Major)+'.'+IntToString(Minor); - fDetailed := Main+ '.'+IntToString(Release)+'.'+IntToString(Build); -end; - -function TFileVersion.BuildDateTimeString: string; -begin - DateTimeToIso8601StringVar(fBuildDateTime,' ',result); -end; - -function TFileVersion.DetailedOrVoid: string; -begin - if (self=nil) or (Major or Minor or Release or Build=0) then - result := '' else - result := fDetailed; -end; - -function TFileVersion.VersionInfo: RawUTF8; -begin - FormatUTF8('% % (%)',[ExtractFileName(fFileName),DetailedOrVoid,BuildDateTimeString],result); -end; - -function TFileVersion.UserAgent: RawUTF8; -begin - if self=nil then - result := '' else - FormatUTF8('%/%%',[GetFileNameWithoutExt(ExtractFileName(fFileName)), - DetailedOrVoid,OS_INITIAL[OS_KIND]],result); - {$ifdef MSWINDOWS} - if OSVersion in WINDOWS_32 then - result := result+'32'; - {$endif MSWINDOWS} -end; - -class function TFileVersion.GetVersionInfo(const aFileName: TFileName): RawUTF8; -begin - with Create(aFileName,0,0,0,0) do - try - result := VersionInfo; - finally - Free; - end; -end; - -procedure SetExecutableVersion(const aVersionText: RawUTF8); -var P: PUTF8Char; - i: integer; - ver: array[0..3] of integer; -begin - P := pointer(aVersionText); - for i := 0 to 3 do - ver[i] := GetNextItemCardinal(P,'.'); - SetExecutableVersion(ver[0],ver[1],ver[2],ver[3]); -end; - -procedure SetExecutableVersion(aMajor,aMinor,aRelease,aBuild: integer); -var {$ifdef MSWINDOWS} - tmp: array[byte] of WideChar; - tmpsize: cardinal; - {$else} - tmp: string; - {$endif} -begin - with ExeVersion do begin - if Version=nil then begin - {$ifdef MSWINDOWS} - ProgramFileName := paramstr(0); - {$else} - ProgramFileName := GetModuleName(HInstance); - if ProgramFileName='' then - ProgramFileName := ExpandFileName(paramstr(0)); - {$endif MSWINDOWS} - ProgramFilePath := ExtractFilePath(ProgramFileName); - if IsLibrary then - InstanceFileName := GetModuleName(HInstance) else - InstanceFileName := ProgramFileName; - ProgramName := StringToUTF8(GetFileNameWithoutExt(ExtractFileName(ProgramFileName))); - {$ifdef MSWINDOWS} - tmpsize := SizeOf(tmp); - GetComputerNameW(tmp,tmpsize); - RawUnicodeToUtf8(@tmp,StrLenW(tmp),Host); - tmpsize := SizeOf(tmp); - GetUserNameW(tmp,tmpsize); - RawUnicodeToUtf8(@tmp,StrLenW(tmp),User); - {$else} - StringToUTF8(GetHostName,Host); - if Host='' then - StringToUTF8(GetEnvironmentVariable('HOSTNAME'),Host); - tmp := GetEnvironmentVariable('LOGNAME'); // POSIX - if tmp='' then - tmp := GetEnvironmentVariable('USER'); - {$ifdef KYLIX3} - if tmp='' then - User := LibC.getpwuid(LibC.getuid)^.pw_name else - {$endif} - StringToUTF8(tmp,User); - {$endif MSWINDOWS} - if Host='' then - Host := 'unknown'; - if User='' then - User := 'unknown'; - GarbageCollectorFreeAndNil(Version, - TFileVersion.Create(InstanceFileName,aMajor,aMinor,aRelease,aBuild)); - end else - Version.SetVersion(aMajor,aMinor,aRelease,aBuild); - FormatUTF8('% % (%)',[ProgramFileName,Version.Detailed, - DateTimeToIso8601(Version.BuildDateTime,True,' ')],ProgramFullSpec); - Hash.c0 := Version.Version32; - {$ifdef CPUINTEL} - Hash.c0 := crc32c(Hash.c0,@CpuFeatures,SizeOf(CpuFeatures)); - {$endif} - Hash.c0 := crc32c(Hash.c0,pointer(Host),length(Host)); - Hash.c1 := crc32c(Hash.c0,pointer(User),length(User)); - Hash.c2 := crc32c(Hash.c1,pointer(ProgramFullSpec),length(ProgramFullSpec)); - Hash.c3 := crc32c(Hash.c2,pointer(InstanceFileName),length(InstanceFileName)); - end; -end; - -{$ifdef MSWINDOWS} -// avoid unneeded reference to ShlObj.pas -function SHGetFolderPath(hwnd: HWND; csidl: Integer; hToken: THandle; - dwFlags: DWord; pszPath: PChar): HRESULT; stdcall; external 'SHFolder.dll' - name {$ifdef UNICODE}'SHGetFolderPathW'{$else}'SHGetFolderPathA'{$endif}; - -var - _SystemPath: array[TSystemPath] of TFileName; - -function GetSystemPath(kind: TSystemPath): TFileName; -const - CSIDL_PERSONAL = $0005; - CSIDL_LOCAL_APPDATA = $001C; // local non roaming user folder - CSIDL_COMMON_APPDATA = $0023; - CSIDL_COMMON_DOCUMENTS = $002E; - CSIDL: array[TSystemPath] of integer = ( - // spCommonData, spUserData, spCommonDocuments - CSIDL_COMMON_APPDATA, CSIDL_LOCAL_APPDATA, CSIDL_COMMON_DOCUMENTS, - // spUserDocuments, spTempFolder, spLog - CSIDL_PERSONAL, 0, CSIDL_LOCAL_APPDATA); - ENV: array[TSystemPath] of TFileName = ( - 'ALLUSERSAPPDATA', 'LOCALAPPDATA', '', '', 'TEMP', 'LOCALAPPDATA'); -var tmp: array[0..MAX_PATH] of char; -begin - if _SystemPath[kind]='' then - if (kind=spLog) and IsDirectoryWritable(ExeVersion.ProgramFilePath) then - _SystemPath[kind] := EnsureDirectoryExists(ExeVersion.ProgramFilePath+'log') else - if (CSIDL[kind]<>0) and (SHGetFolderPath(0,CSIDL[kind],0,0,@tmp)=S_OK) then - _SystemPath[kind] := IncludeTrailingPathDelimiter(tmp) else begin - _SystemPath[kind] := GetEnvironmentVariable(ENV[kind]); - if _SystemPath[kind]='' then - _SystemPath[kind] := GetEnvironmentVariable('APPDATA'); - _SystemPath[kind] := IncludeTrailingPathDelimiter(_SystemPath[kind]); - end; - result := _SystemPath[kind]; -end; -{$else MSWINDOWS} -var - _HomePath, _TempPath, _UserPath, _LogPath: TFileName; - -function GetSystemPath(kind: TSystemPath): TFileName; -begin - case kind of - spLog: begin - if _LogPath='' then - if IsDirectoryWritable('/var/log') then - _LogPath := '/var/log/' else // may not be writable by not root on POSIX - if IsDirectoryWritable(ExeVersion.ProgramFilePath) then - _LogPath := ExeVersion.ProgramFilePath else - _LogPath := GetSystemPath(spUserData); - result := _LogPath; - end; - spUserData: begin - if _UserPath='' then begin // ~/.cache/appname - _UserPath := GetEnvironmentVariable('XDG_CACHE_HOME'); - if (_UserPath='') or not IsDirectoryWritable(_UserPath) then - _UserPath := EnsureDirectoryExists(GetSystemPath(spUserDocuments)+'.cache'); - _UserPath := EnsureDirectoryExists(_UserPath+UTF8ToString(ExeVersion.ProgramName)); - end; - result := _UserPath; - end; - spTempFolder: begin - if _TempPath='' then begin - _TempPath := GetEnvironmentVariable('TMPDIR'); // POSIX - if _TempPath='' then - _TempPath := GetEnvironmentVariable('TMP'); - if _TempPath='' then - if DirectoryExists('/tmp') then - _TempPath := '/tmp' else - _TempPath := '/var/tmp'; - _TempPath := IncludeTrailingPathDelimiter(_TempPath); - end; - result := _TempPath; - end else begin - if _HomePath='' then // POSIX requires a value for $HOME - _HomePath := IncludeTrailingPathDelimiter(GetEnvironmentVariable('HOME')); - result := _HomePath; - end; - end; -end; -{$endif MSWINDOWS} - -procedure PatchCode(Old,New: pointer; Size: integer; Backup: pointer; - LeaveUnprotected: boolean); -{$ifdef MSWINDOWS} -var RestoreProtection, Ignore: DWORD; - i: integer; -begin - if VirtualProtect(Old, Size, PAGE_EXECUTE_READWRITE, RestoreProtection) then - begin - if Backup<>nil then - for i := 0 to Size-1 do // do not use Move() here - PByteArray(Backup)^[i] := PByteArray(Old)^[i]; - for i := 0 to Size-1 do // do not use Move() here - PByteArray(Old)^[i] := PByteArray(New)^[i]; - if not LeaveUnprotected then - VirtualProtect(Old, Size, RestoreProtection, Ignore); - FlushInstructionCache(GetCurrentProcess, Old, Size); - if not CompareMemFixed(Old,New,Size) then - raise ESynException.Create('PatchCode?'); - end; -end; -{$else} -var PageSize: PtrUInt; - AlignedAddr: pointer; - i: PtrInt; - ProtectedResult: boolean; - ProtectedMemory: boolean; -begin - if Backup<>nil then - for i := 0 to Size-1 do // do not use Move() here - PByteArray(Backup)^[i] := PByteArray(Old)^[i]; - PageSize := SystemInfo.dwPageSize; - AlignedAddr := Pointer((PtrUInt(Old) DIV SystemInfo.dwPageSize) * SystemInfo.dwPageSize); - while PtrUInt(Old)+PtrUInt(Size)>=PtrUInt(AlignedAddr)+PageSize do - Inc(PageSize,SystemInfo.dwPageSize); - ProtectedResult := SynMProtect(AlignedAddr,PageSize,PROT_READ or PROT_WRITE or PROT_EXEC) = 0; - ProtectedMemory := not ProtectedResult; - if ProtectedMemory then - ProtectedResult := SynMProtect(AlignedAddr,PageSize,PROT_READ or PROT_WRITE) = 0; - if ProtectedResult then - try - for i := 0 to Size-1 do // do not use Move() here - PByteArray(Old)^[i] := PByteArray(New)^[i]; - if not LeaveUnprotected and ProtectedMemory then - SynMProtect(AlignedAddr,PageSize,PROT_READ or PROT_EXEC); - except - end; -end; -{$endif MSWINDOWS} - -procedure PatchCodePtrUInt(Code: PPtrUInt; Value: PtrUInt; - LeaveUnprotected: boolean); -begin - PatchCode(Code,@Value,SizeOf(Code^),nil,LeaveUnprotected); -end; - -{$ifdef CPUINTEL} - -procedure RedirectCode(Func, RedirectFunc: Pointer; Backup: PPatchCode); -var NewJump: packed record - Code: byte; // $e9 = jmp {relative} - Distance: integer; // relative jump is 32-bit even on CPU64 - end; -begin - if (Func=nil) or (RedirectFunc=nil) then - exit; // nothing to redirect to - assert(SizeOf(TPatchCode)=SizeOf(NewJump)); - NewJump.Code := $e9; - NewJump.Distance := integer(PtrUInt(RedirectFunc)-PtrUInt(Func)-SizeOf(NewJump)); - PatchCode(Func,@NewJump,SizeOf(NewJump),Backup); - {$ifndef LVCL} - assert(pByte(Func)^=$e9); - {$endif} -end; - -procedure RedirectCodeRestore(Func: pointer; const Backup: TPatchCode); -begin - PatchCode(Func,@Backup,SizeOf(TPatchCode)); -end; - -{$endif CPUINTEL} - -{$ifndef LVCL} -{$ifndef FPC} -{$ifndef UNICODE} - -const - MemoryDelta = $8000; // 32 KB granularity (must be a power of 2) - -function THeapMemoryStream.Realloc(var NewCapacity: longint): Pointer; -// allocates memory from Delphi heap (FastMM4/SynScaleMM) and not windows.Global*() -// and uses bigger growing size -> a lot faster -var i: PtrInt; -begin - if NewCapacity>0 then begin - i := Seek(0,soFromCurrent); // no direct access to fSize -> use Seek() trick - if NewCapacity=Seek(0,soFromEnd) then begin // avoid ReallocMem() if just truncate - result := Memory; - Seek(i,soBeginning); - exit; - end; - NewCapacity := (NewCapacity + (MemoryDelta - 1)) and not (MemoryDelta - 1); - Seek(i,soBeginning); - end; - Result := Memory; - if NewCapacity <> Capacity then begin - if NewCapacity = 0 then begin - FreeMem(Memory); - Result := nil; - end else begin - if Capacity = 0 then - GetMem(Result, NewCapacity) else - if NewCapacity > Capacity then // only realloc if necessary (grow up) - ReallocMem(Result, NewCapacity) else - NewCapacity := Capacity; // same capacity as before - if Result = nil then - raise EStreamError.Create('THeapMemoryStream'); // memory allocation bug - end; - end; -end; - -{$endif UNICODE} -{$endif FPC} -{$endif LVCL} - - -{ TSortedWordArray } - -function FastLocateWordSorted(P: PWordArray; R: integer; Value: word): PtrInt; -var L,cmp: PtrInt; -begin - if R<0 then - result := 0 else begin - L := 0; - repeat - result := (L + R) shr 1; - cmp := P^[result]-Value; - if cmp=0 then begin - result := -result-1; // return -(foundindex+1) if already exists - exit; - end; - if cmp<0 then - L := result + 1 else - R := result - 1; - until (L > R); - while (result>=0) and (P^[result]>=Value) do dec(result); - result := result+1; // return the index where to insert - end; -end; - -function FastFindWordSorted(P: PWordArray; R: PtrInt; Value: Word): PtrInt; -{$ifdef CPUX64} // P=rcx/rdi R=rdx/rsi Value=r8w/dx -{$ifdef FPC} assembler; nostackframe; asm {$else} asm .noframe {$endif} - {$ifdef win64} - push rdi - mov rdi, P // rdi=P - {$endif} - xor r9, r9 // r9=L rax=result - test R, R - jl @ko -{$ifdef FPC} align 8 {$else} .align 8 {$endif} -@s: lea rax, [r9 + R] - shr rax, 1 - lea r10, qword ptr[rax - 1] // branchless loop - lea r11, qword ptr[rax + 1] - movzx ecx, word ptr[rdi + rax * 2] - {$ifdef win64} - cmp ecx, r8d - {$else} - cmp ecx, edx // 'cmp cx,Value' is silently rejected by Darwin asm - {$endif win64} - je @ok - cmovg R, r10 - cmovl r9, r11 - cmp r9, R - jle @s -@ko: or rax, -1 -@ok: {$ifdef win64} - pop rdi - {$endif} -end; -{$else} -var L: PtrInt; - cmp: integer; -begin - L := 0; - if 0<=R then - repeat - result := (L + R) shr 1; - cmp := P^[result]-Value; - if cmp=0 then - exit; - if cmp<0 then begin - L := result+1; - if L<=R then - continue; - break; - end; - R := result-1; - if L<=R then - continue; - break; - until false; - result := -1 -end; -{$endif CPUX64} - -function TSortedWordArray.Add(aValue: Word): PtrInt; -begin - result := Count; // optimistic check of perfectly increasing aValue - if (result>0) and (aValue<=Values[result-1]) then - result := FastLocateWordSorted(pointer(Values),result-1,aValue); - if result<0 then // aValue already exists in Values[] -> fails - exit; - if Count=length(Values) then - SetLength(Values,NextGrow(Count)); - if result J; - if J - L < R - I then begin // use recursion only for smaller range - if L < J then - QuickSortCompare(OnCompare, Index, L, J); - L := I; - end else begin - if I < R then - QuickSortCompare(OnCompare, Index, I, R); - R := J; - end; - until L >= R; -end; - -procedure Exchg32(var A,B: integer); {$ifdef HASINLINE}inline;{$endif} -var tmp: integer; -begin - tmp := A; - A := B; - B := tmp; -end; - -function MedianQuickSelectInteger(Values: PIntegerArray; n: integer): integer; -var low, high, median, middle, ll, hh: PtrInt; -begin - if n=0 then begin - result := 0; - exit; - end; - if n=1 then begin - result := Values[0]; - exit; - end; - low := 0; - high := n-1; - median := high shr 1; - repeat - if high<=low then begin // one item left - result := Values[median]; - exit; - end; - if high=low+1 then begin // two items -> return the smallest (not average) - if Values[low]>Values[high] then - Exchg32(Values[low],Values[high]); - result := Values[median]; - exit; - end; - // find median of low, middle and high items; swap into position low - middle := (low+high) shr 1; - if Values[middle]>Values[high] then - Exchg32(Values[middle],Values[high]); - if Values[low]>Values[high] then - Exchg32(Values[low],Values[high]); - if Values[middle]>Values[low] then - Exchg32(Values[middle],Values[low]); - // swap low item (now in position middle) into position (low+1) - Exchg32(Values[middle],Values[low+1]); - // nibble from each end towards middle, swapping items when stuck - ll := low+1; - hh := high; - repeat - repeat - inc(ll); - until not (Values[low]>Values[ll]); - repeat - dec(hh); - until not (Values[hh]>Values[low]); - if hh=median then - high := hh-1; - until false; -end; - -function MedianQuickSelect(const OnCompare: TOnValueGreater; n: integer; - var TempBuffer: TSynTempBuffer): integer; -var low, high, middle, median, ll, hh: PtrInt; - tmp: integer; - ndx: PIntegerArray; -begin - if n<=1 then begin - TempBuffer.buf := nil; // avoid GPF in TempBuffer.Done - result := 0; - exit; - end; - low := 0; - high := n-1; - ndx := TempBuffer.InitIncreasing(n*4); // no heap alloacation until n>1024 - median := high shr 1; - repeat - if high<=low then begin // one item left - result := ndx[median]; - TempBuffer.Done; - exit; - end; - if high=low+1 then begin // two items -> return the smallest (not average) - if OnCompare(ndx[low],ndx[high]) then - Exchg32(ndx[low],ndx[high]); - result := ndx[median]; - TempBuffer.Done; - exit; - end; - // find median of low, middle and high items; swap into position low - middle := (low+high) shr 1; - if OnCompare(ndx[middle],ndx[high]) then - Exchg32(ndx[middle],ndx[high]); - if OnCompare(ndx[low],ndx[high]) then - Exchg32(ndx[low],ndx[high]); - if OnCompare(ndx[middle],ndx[low]) then - Exchg32(ndx[middle],ndx[low]); - // swap low item (now in position middle) into position (low+1) - Exchg32(ndx[middle],ndx[low+1]); - // nibble from each end towards middle, swapping items when stuck - ll := low+1; - hh := high; - repeat - tmp := ndx[low]; - repeat - inc(ll); - until not OnCompare(tmp,ndx[ll]); - repeat - dec(hh); - until not OnCompare(ndx[hh],tmp); - if hh=median then - high := hh-1; - until false; -end; - -function gcd(a, b: cardinal): cardinal; -begin - while a <> b do - if a > b then - dec(a, b) else - dec(b, a); - result := a; -end; - -function ToVarUInt32Length(Value: PtrUInt): PtrUInt; -begin - if Value<=$7f then - result := 1 else - if Value<$80 shl 7 then - result := 2 else - if Value<$80 shl 14 then - result := 3 else - if Value <$80 shl 21 then - result := 4 else - result := 5; -end; - -function ToVarUInt32LengthWithData(Value: PtrUInt): PtrUInt; -begin - if Value<=$7f then - result := Value+1 else - if Value<$80 shl 7 then - result := Value+2 else - if Value<$80 shl 14 then - result := Value+3 else - if Value<$80 shl 21 then - result := Value+4 else - result := Value+5; -end; - -{$ifdef HASINLINE} -function FromVarUInt32(var Source: PByte): cardinal; -begin - result := Source^; - inc(Source); - if result>$7f then - result := (result and $7F) or FromVarUInt32Up128(Source); -end; - -function FromVarUInt32Big(var Source: PByte): cardinal; -{$else} -function FromVarUInt32Big(var Source: PByte): cardinal; -asm - jmp FromVarUInt32 -end; - -function FromVarUInt32(var Source: PByte): cardinal; -{$endif} -var c: cardinal; - p: PByte; -begin - p := Source; - result := p^; - inc(p); - if result>$7f then begin // Values between 128 and 16256 - c := p^; - c := c shl 7; - result := result and $7F or c; - inc(p); - if c>$7f shl 7 then begin // Values between 16257 and 2080768 - c := p^; - c := c shl 14; - inc(p); - result := result and $3FFF or c; - if c>$7f shl 14 then begin // Values between 2080769 and 266338304 - c := p^; - c := c shl 21; - inc(p); - result := result and $1FFFFF or c; - if c>$7f shl 21 then begin - c := p^; - c := c shl 28; - inc(p); - result := result and $FFFFFFF or c; - end; - end; - end; - end; - Source := p; -end; - -function FromVarUInt32Up128(var Source: PByte): cardinal; -var c: cardinal; - p: PByte; -begin // Values above 128 - p := Source; - result := p^ shl 7; - inc(p); - if result>$7f shl 7 then begin // Values above 16257 - c := p^; - c := c shl 14; - inc(p); - result := result and $3FFF or c; - if c>$7f shl 14 then begin - c := p^; - c := c shl 21; - inc(p); - result := result and $1FFFFF or c; - if c>$7f shl 21 then begin - c := p^; - c := c shl 28; - inc(p); - result := result and $FFFFFFF or c; - end; - end; - end; - Source := p; -end; - -function FromVarUInt32(var Source: PByte; SourceMax: PByte; out Value: cardinal): boolean; -begin - if SourceMax=nil then begin - Value := FromVarUInt32(Source); - result := true; - end else begin - Source := FromVarUInt32Safe(Source,SourceMax,Value); - result := Source<>nil; - end; -end; - -function FromVarUInt32Safe(Source, SourceMax: PByte; out Value: cardinal): PByte; -var c: cardinal; -begin - result := nil; // error - if PAnsiChar(Source)>=PAnsiChar(SourceMax) then exit; - c := Source^; - inc(Source); - Value := c; - if c>$7f then begin // Values between 128 and 16256 - if PAnsiChar(Source)>=PAnsiChar(SourceMax) then exit; - c := Source^; - c := c shl 7; - Value := Value and $7F or c; - inc(Source); - if c>$7f shl 7 then begin // Values between 16257 and 2080768 - if PAnsiChar(Source)>=PAnsiChar(SourceMax) then exit; - c := Source^; - c := c shl 14; - inc(Source); - Value := Value and $3FFF or c; - if c>$7f shl 14 then begin // Values between 2080769 and 266338304 - if PAnsiChar(Source)>=PAnsiChar(SourceMax) then exit; - c := Source^; - c := c shl 21; - inc(Source); - Value := Value and $1FFFFF or c; - if c>$7f shl 21 then begin - if PAnsiChar(Source)>=PAnsiChar(SourceMax) then exit; - c := Source^; - c := c shl 28; - inc(Source); - Value := Value and $FFFFFFF or c; - end; - end; - end; - end; - result := Source; // safely decoded -end; - -function FromVarInt32(var Source: PByte): integer; -var c: cardinal; - p: PByte; -begin // fast stand-alone function with no FromVarUInt32 call - p := Source; - result := p^; - inc(p); - if result>$7f then begin - c := p^; - c := c shl 7; - result := result and $7F or integer(c); - inc(p); - if c>$7f shl 7 then begin - c := p^; - c := c shl 14; - inc(p); - result := result and $3FFF or integer(c); - if c>$7f shl 14 then begin - c := p^; - c := c shl 21; - inc(p); - result := result and $1FFFFF or integer(c); - if c>$7f shl 21 then begin - c := p^; - c := c shl 28; - inc(p); - result := result and $FFFFFFF or integer(c); - end; - end; - end; - end; - Source := p; - // 0=0,1=1,2=-1,3=2,4=-2... - if result and 1<>0 then - // 1->1, 3->2.. - result := result shr 1+1 else - // 0->0, 2->-1, 4->-2.. - result := -(result shr 1); -end; - -function FromVarUInt32High(var Source: PByte): cardinal; -var c: cardinal; -begin - result := Source^; - inc(Source); - c := Source^ shl 7; - inc(Source); - result := result and $7F or c; - if c<=$7f shl 7 then - exit; - c := Source^ shl 14; - inc(Source); - result := result and $3FFF or c; - if c<=$7f shl 14 then - exit; - c := Source^ shl 21; - inc(Source); - result := result and $1FFFFF or c; - if c<=$7f shl 21 then - exit; - c := Source^ shl 28; - inc(Source); - result := result and $FFFFFFF or c; -end; - -function ToVarInt64(Value: Int64; Dest: PByte): PByte; -begin // 0=0,1=1,2=-1,3=2,4=-2... - {$ifdef CPU32} - if Value<=0 then - // 0->0, -1->2, -2->4.. - result := ToVarUInt64((-Value) shl 1,Dest) else - // 1->1, 2->3.. - result := ToVarUInt64((Value shl 1)-1,Dest); - {$else} - if Value<=0 then - // 0->0, -1->2, -2->4.. - Value := (-Value) shl 1 else - // 1->1, 2->3.. - Value := (Value shl 1)-1; - result := ToVarUInt64(Value,Dest); - {$endif} -end; - -function ToVarUInt64(Value: QWord; Dest: PByte): PByte; -label _1,_2,_4; // ugly but fast -var c: cardinal; -begin - repeat - c := Value; - if {$ifdef CPU32}PInt64Rec(@Value)^.Hi=0{$else}Value shr 32=0{$endif} then begin - if c>$7f then begin // inlined result := ToVarUInt32(Value,Dest); - if c<$80 shl 7 then goto _1 else - if c<$80 shl 14 then goto _2 else - if c>=$80 shl 21 then goto _4; - Dest^ := (c and $7F) or $80; - c := c shr 7; - inc(Dest); - _2: Dest^ := (c and $7F) or $80; - c := c shr 7; - inc(Dest); - _1: Dest^ := (c and $7F) or $80; - c := c shr 7; - inc(Dest); - end; - Dest^ := c; - inc(Dest); - result := Dest; - exit; - end; -_4: PCardinal(Dest)^ := (c and $7F) or (((c shr 7)and $7F)shl 8) or - (((c shr 14)and $7F)shl 16) or (((c shr 21)and $7F)shl 24) or $80808080; - inc(Dest,4); - Value := Value shr 28; - until false; -end; - -function FromVarUInt64(var Source: PByte): QWord; -var c,n: PtrUInt; - p: PByte; -begin - p := Source; - {$ifdef CPU64} - result := p^; - if result>$7f then begin - result := result and $7F; - {$else} - if p^>$7f then begin - result := PtrUInt(p^) and $7F; - {$endif} - n := 0; - inc(p); - repeat - c := p^; - inc(n,7); - if c<=$7f then - break; - result := result or (QWord(c and $7f) shl n); - inc(p); - until false; - result := result or (QWord(c) shl n); - end{$ifndef CPU64} else - result := p^{$endif}; - inc(p); - Source := p; -end; - -function FromVarUInt64Safe(Source, SourceMax: PByte; out Value: QWord): PByte; -var c,n: PtrUInt; -begin - result := nil; // error - if PAnsiChar(Source)>=PAnsiChar(SourceMax) then exit; - c := Source^; - inc(Source); - if c>$7f then begin - Value := c and $7F; - n := 7; - repeat - if PAnsiChar(Source)>=PAnsiChar(SourceMax) then - exit; - c := Source^; - inc(Source); - if c<=$7f then - break; - c := c and $7f; - Value := Value or (QWord(c) shl n); - inc(n,7); - until false; - Value := Value or (QWord(c) shl n); - end else - Value := c; - result := Source; // safely decoded -end; - -function FromVarUInt64(var Source: PByte; SourceMax: PByte; out Value: QWord): boolean; -begin - if SourceMax=nil then begin - Value := FromVarUInt64(Source); - result := true; - end else begin - Source := FromVarUInt64Safe(Source,SourceMax,Value); - result := Source<>nil; - end; -end; - -function FromVarInt64(var Source: PByte): Int64; -var c,n: PtrUInt; -begin // 0=0,1=1,2=-1,3=2,4=-2... - {$ifdef CPU64} - result := Source^; - if result>$7f then begin - result := result and $7F; - n := 0; - inc(Source); - repeat - c := Source^; - inc(n,7); - if c<=$7f then - break; - result := result or (Int64(c and $7f) shl n); - inc(Source); - until false; - result := result or (Int64(c) shl n); - end; - if result and 1<>0 then - // 1->1, 3->2.. - result := result shr 1+1 else - // 0->0, 2->-1, 4->-2.. - result := -(result shr 1); - {$else} - c := Source^; - if c>$7f then begin - result := c and $7F; - n := 0; - inc(Source); - repeat - c := Source^; - inc(n,7); - if c<=$7f then - break; - result := result or (Int64(c and $7f) shl n); - inc(Source); - until false; - result := result or (Int64(c) shl n); - if PCardinal(@result)^ and 1<>0 then - // 1->1, 3->2.. - result := result shr 1+1 else - // 0->0, 2->-1, 4->-2.. - result := -(result shr 1); - end else begin - if c=0 then - result := 0 else - if c and 1=0 then - // 0->0, 2->-1, 4->-2.. - result := -Int64(c shr 1) else - // 1->1, 3->2.. - result := (c shr 1)+1; - end; - {$endif} - inc(Source); -end; - -function FromVarInt64Value(Source: PByte): Int64; -{$ifdef DELPHI5OROLDER} -begin // try to circumvent Internal Error C1093 on Delphi 5 :( - result := FromVarInt64(Source); -end; -{$else} -var c,n: PtrUInt; -begin // 0=0,1=1,2=-1,3=2,4=-2... - c := Source^; - if c>$7f then begin - result := c and $7F; - n := 0; - inc(Source); - repeat - c := Source^; - inc(n,7); - if c<=$7f then - break; - result := result or (Int64(c and $7f) shl n); - inc(Source); - until false; - result := result or (Int64(c) shl n); - if {$ifdef CPU64}result{$else}PCardinal(@result)^{$endif} and 1<>0 then - // 1->1, 3->2.. - result := result shr 1+1 else - // 0->0, 2->-1, 4->-2.. - result := -Int64(result shr 1); - end else - if c=0 then - result := 0 else - if c and 1=0 then - // 0->0, 2->-1, 4->-2.. - result := -Int64(c shr 1) else - // 1->1, 3->2.. - result := (c shr 1)+1; -end; -{$endif DELPHI5OROLDER} - -function GotoNextVarInt(Source: PByte): pointer; -begin - if Source<>nil then begin - if Source^>$7f then - repeat - inc(Source) - until Source^<=$7f; - inc(Source); - end; - result := Source; -end; - -function ToVarString(const Value: RawUTF8; Dest: PByte): PByte; -var Len: integer; -begin - Len := Length(Value); - Dest := ToVarUInt32(Len,Dest); - if Len>0 then begin - MoveFast(pointer(Value)^,Dest^,Len); - result := pointer(PAnsiChar(Dest)+Len); - end else - result := Dest; -end; - -function GotoNextVarString(Source: PByte): pointer; -begin - result := Pointer(PtrUInt(Source)+FromVarUInt32(Source)); -end; - -function FromVarString(var Source: PByte): RawUTF8; -var len: PtrUInt; -begin - len := FromVarUInt32(Source); - FastSetStringCP(Result,Source,len,CP_UTF8); - inc(Source,len); -end; - -function FromVarString(var Source: PByte; SourceMax: PByte): RawUTF8; -var len: cardinal; -begin - Source := FromVarUInt32Safe(Source,SourceMax,len); - if (Source=nil) or (PAnsiChar(Source)+len>PAnsiChar(SourceMax)) then - len := 0; - FastSetStringCP(Result,Source,len,CP_UTF8); - inc(Source,len); -end; - -procedure FromVarString(var Source: PByte; var Value: TSynTempBuffer); -var len: integer; -begin - len := FromVarUInt32(Source); - Value.Init(Source,len); - PByteArray(Value.buf)[len] := 0; // include trailing #0 - inc(Source,len); -end; - -function FromVarString(var Source: PByte; SourceMax: PByte; - var Value: TSynTempBuffer): boolean; -var len: cardinal; -begin - if SourceMax=nil then - len := FromVarUInt32(Source) else begin - Source := FromVarUInt32Safe(Source,SourceMax,len); - if (Source=nil) or (PAnsiChar(Source)+len>PAnsiChar(SourceMax)) then begin - result := false; - exit; - end; - end; - Value.Init(Source,len); - PByteArray(Value.buf)[len] := 0; // include trailing #0 - inc(Source,len); - result := true; -end; - -procedure FromVarString(var Source: PByte; var Value: RawByteString; - CodePage: integer); -var Len: PtrUInt; -begin - Len := FromVarUInt32(Source); - FastSetStringCP(Value,Source,Len,CodePage); - inc(Source,Len); -end; - -function FromVarString(var Source: PByte; SourceMax: PByte; - var Value: RawByteString; CodePage: integer): boolean; -var len: cardinal; -begin - if SourceMax=nil then - len := FromVarUInt32(Source) else begin - Source := FromVarUInt32Safe(Source,SourceMax,len); - if (Source=nil) or (PAnsiChar(Source)+len>PAnsiChar(SourceMax)) then begin - result := false; - exit; - end; - end; - FastSetStringCP(Value,Source,len,CodePage); - inc(Source,len); - result := true; -end; - -function FromVarBlob(Data: PByte): TValueResult; -begin - Result.Len := FromVarUInt32(Data); - Result.Ptr := pointer(Data); -end; - - -{ ************ low-level RTTI types and conversion routines } - -{$ifdef FPC} - -{$ifdef FPC_OLDRTTI} -function OldRTTIFirstManagedField(info: PTypeInfo): PFieldInfo; -var fieldtype: PTypeInfo; - i: integer; -begin - result := @info^.ManagedFields[0]; - for i := 1 to info^.ManagedCount do begin - fieldtype := DeRef(result^.TypeInfo); - if (fieldtype<>nil) and (fieldtype^.Kind in tkManagedTypes) then - exit; - inc(result); - end; - result := nil; -end; - -function OldRTTIManagedSize(typeInfo: Pointer): SizeInt; inline; -begin - case PTypeKind(typeInfo)^ of // match tkManagedTypes - tkLString,tkLStringOld,tkWString,tkUString, tkInterface,tkDynarray: - result := SizeOf(Pointer); - {$ifndef NOVARIANTS} - tkVariant: result := SizeOf(TVarData); - {$endif} - tkArray: with GetTypeInfo(typeInfo)^ do - result := arraySize{$ifdef VER2_6}*elCount{$endif}; - tkObject,tkRecord: result := GetTypeInfo(typeInfo)^.recSize; - else raise ESynException.CreateUTF8('OldRTTIManagedSize unhandled % (%)', - [ToText(PTypeKind(typeInfo)^)^,PByte(typeInfo)^]); - end; -end; - -procedure RecordCopy(var Dest; const Source; TypeInfo: pointer); -begin // external name 'FPC_COPY' does not work as we need - FPCFinalize(@Dest,TypeInfo); - Move(Source,Dest,OldRTTIManagedSize(TypeInfo)); - FPCRecordAddRef(Dest,TypeInfo); -end; -{$else} -procedure RecordCopy(var Dest; const Source; TypeInfo: pointer); -begin - FPCRecordCopy(Source,Dest,TypeInfo); -end; -{$endif FPC_OLDRTTI} - -procedure RecordClear(var Dest; TypeInfo: pointer); -begin - FPCFinalize(@Dest,TypeInfo); -end; - -{$else FPC} - -procedure CopyArray(dest, source, typeInfo: Pointer; cnt: PtrUInt); -asm -{$ifdef CPU64} - .noframe - jmp System.@CopyArray -{$else} push dword ptr[EBP + 8] - call System.@CopyArray // RTL is fast enough for this -{$endif} -end; - -procedure _DynArrayClear(var a: Pointer; typeInfo: Pointer); -asm - {$ifdef CPU64} - .noframe - {$endif} - jmp System.@DynArrayClear -end; - -procedure _FinalizeArray(p: Pointer; typeInfo: Pointer; elemCount: PtrUInt); -asm - {$ifdef CPU64} - .noframe - {$endif} - jmp System.@FinalizeArray -end; - -procedure _Finalize(Data: Pointer; TypeInfo: Pointer); -asm -{$ifdef CPU64} - .noframe - mov r8, 1 // rcx=p rdx=typeInfo r8=ElemCount - jmp System.@FinalizeArray -{$else} // much faster than FinalizeArray(Data,TypeInfo,1) - movzx ecx, byte ptr[edx] // eax=ptr edx=typeinfo ecx=datatype - sub cl, tkLString - {$ifdef UNICODE} - cmp cl, tkUString - tkLString + 1 - {$else} - cmp cl, tkDynArray - tkLString + 1 - {$endif} - jnb @@err - jmp dword ptr[@@Tab + ecx * 4] - nop - nop // for @@Tab alignment -@@Tab: dd System.@LStrClr -{$IFDEF LINUX} // under Linux, WideString are refcounted as AnsiString - dd System.@LStrClr -{$else} dd System.@WStrClr -{$endif LINUX} -{$ifdef LVCL} - dd @@err -{$else} dd System.@VarClr -{$endif LVCL} - dd @@ARRAY - dd RecordClear - dd System.@IntfClear - dd @@err - dd System.@DynArrayClear - {$ifdef UNICODE} - dd System.@UStrClr - {$endif} -@@err: mov al, reInvalidPtr - {$ifdef DELPHI5OROLDER} - jmp System.@RunError - {$else} - jmp System.Error - {$endif} -@@array:movzx ecx, [edx].TTypeInfo.NameLen - add ecx, edx - mov edx, dword ptr[ecx].TTypeInfo.ManagedFields[0] // Fields[0].TypeInfo^ - mov ecx, [ecx].TTypeInfo.ManagedCount - mov edx, [edx] - jmp System.@FinalizeArray -{$endif CPU64} -end; -{$endif FPC} - -procedure RecordZero(var Dest; TypeInfo: pointer); -var info: PTypeInfo; -begin - info := GetTypeInfo(TypeInfo,tkRecordKinds); - if info<>nil then begin // record/object only - RecordClear(Dest,TypeInfo); - FillCharFast(Dest,info^.recSize,0); - end; -end; - -procedure RawUTF8DynArrayClear(var Value: TRawUTF8DynArray); -begin - FastDynArrayClear(@Value,TypeInfo(RawUTF8)); -end; - -function ArrayItemType(var info: PTypeInfo; out len: integer): PTypeInfo; - {$ifdef HASINLINE}inline;{$endif} -begin - {$ifdef HASALIGNTYPEDATA} // inlined info := GetTypeInfo(info) - info := FPCTypeInfoOverName(info); - {$else} - info := @PAnsiChar(info)[info^.NameLen]; - {$endif} - result := nil; - if (info=nil) or (info^.dimCount<>1) then begin - len := 0; - info := nil; // supports single dimension static array only - end else begin - len := info^.arraySize{$ifdef VER2_6}*info^.elCount{$endif}; - {$ifdef HASDIRECTTYPEINFO} // inlined result := DeRef(info^.arrayType) - result := info^.arrayType; - {$else} - if info^.arrayType=nil then - exit; - result := info^.arrayType^; - {$endif} - {$ifdef FPC} - if (result<>nil) and not(result^.Kind in tkManagedTypes) then - result := nil; // as with Delphi - {$endif} - end; -end; - -function ManagedTypeCompare(A,B: PAnsiChar; info: PTypeInfo): integer; -// returns -1 if info was not handled, 0 if A^<>B^, or SizeOf(A^) if A^=B^ -var i,arraysize: integer; - itemtype: PTypeInfo; - {$ifndef DELPHI5OROLDER} // do not know why this compiler does not like it - DynA, DynB: TDynArray; - {$endif} -begin // info is expected to come from a DeRef() if retrieved from RTTI - result := 0; // A^<>B^ - case info^.Kind of // should match tkManagedTypes - tkLString{$ifdef FPC},tkLStringOld{$endif}: - if PRawByteString(A)^=PRawByteString(B)^ then - result := SizeOf(pointer); - tkWString: - if PWideString(A)^=PWideString(B)^ then - result := SizeOf(pointer); - {$ifdef HASVARUSTRING} - tkUString: - if PUnicodeString(A)^=PUnicodeString(B)^ then - result := SizeOf(pointer); - {$endif} - tkRecord{$ifdef FPC},tkObject{$endif}: - if not RecordEquals(A^,B^,info,@result) then - result := 0; // A^<>B^ - {$ifndef NOVARIANTS} - tkVariant: // slightly more optimized than PVariant(A)^=PVariant(B)^ - if SortDynArrayVariantComp(PVarData(A)^,PVarData(B)^,false)=0 then - result := SizeOf(variant); - {$endif} - {$ifndef DELPHI5OROLDER} - tkDynArray: begin - DynA.Init(info,A^); - DynB.Init(info,B^); - if DynA.Equals(DynB) then - result := SizeOf(pointer); - end; - {$endif} - tkInterface: - if PPointer(A)^=PPointer(B)^ then - result := SizeOf(pointer); - tkArray: begin - itemtype := ArrayItemType(info,arraysize); - if info=nil then - result := -1 else - if itemtype=nil then - if CompareMemFixed(A,B,arraysize) then - result := arraysize else - result := 0 else begin - for i := 1 to info^.elCount do begin // only compare managed fields - result := ManagedTypeCompare(A,B,itemtype); - if result<=0 then - exit; // invalid (-1) or not equals (0) - inc(A,result); - inc(B,result); - end; - result := arraysize; - end; - end; - else - result := -1; // Unhandled field - end; -end; - -function ManagedTypeSaveLength(data: PAnsiChar; info: PTypeInfo; - out len: integer): integer; -// returns 0 on error, or saved bytes + len=data^ length -var DynArray: TDynArray; - itemtype: PTypeInfo; - itemsize,size,i: integer; - P: PPtrUInt absolute data; -begin // info is expected to come from a DeRef() if retrieved from RTTI - case info^.Kind of // should match tkManagedTypes - tkLString{$ifdef FPC},tkLStringOld{$endif}: begin - len := SizeOf(pointer); - if P^=0 then - result := 1 else - result := ToVarUInt32LengthWithData(PStrLen(P^-_STRLEN)^); - end; - tkWString: begin // PStrRec doesn't match on Widestring for FPC - len := SizeOf(pointer); - result := ToVarUInt32LengthWithData(length(PWideString(P)^)*2); - end; - {$ifdef HASVARUSTRING} - tkUString: begin - len := SizeOf(pointer); - if P^=0 then - result := 1 else - result := ToVarUInt32LengthWithData(PStrLen(P^-_STRLEN)^*2); - end; - {$endif} - tkRecord{$ifdef FPC},tkObject{$endif}: - result := RecordSaveLength(data^,info,@len); - tkArray: begin - itemtype := ArrayItemType(info,len); - result := 0; - if info<>nil then - if itemtype=nil then - result := len else - for i := 1 to info^.elCount do begin - size := ManagedTypeSaveLength(data,itemtype,itemsize); - if size=0 then begin - result := 0; - exit; - end; - inc(result,size); - inc(data,itemsize); - end; - end; - {$ifndef NOVARIANTS} - tkVariant: begin - len := SizeOf(variant); - result := VariantSaveLength(PVariant(data)^); - end; - {$endif} - tkDynArray: begin - DynArray.Init(info,data^); - len := SizeOf(pointer); - result := DynArray.SaveToLength; - end; - tkInterface: begin - len := SizeOf(Int64); // consume 64-bit even on CPU32 - result := SizeOf(PtrUInt); - end; - else - result := 0; // invalid/unhandled record content - end; -end; - -function ManagedTypeSave(data, dest: PAnsiChar; info: PTypeInfo; - out len: integer): PAnsiChar; -// returns nil on error, or final dest + len=data^ length -var DynArray: TDynArray; - itemtype: PTypeInfo; - itemsize,i: integer; - P: PPtrUInt absolute data; -begin // info is expected to come from a DeRef() if retrieved from RTTI - case info^.Kind of - tkLString {$ifdef HASVARUSTRING},tkUString{$endif} {$ifdef FPC},tkLStringOld{$endif}: begin - if P^=0 then begin - dest^ := #0; - result := dest+1; - end else begin - itemsize := PStrLen(P^-_STRLEN)^; - {$ifdef HASVARUSTRING} // UnicodeString length in WideChars - if info^.Kind=tkUString then - itemsize := itemsize*2; - {$endif} - result := pointer(ToVarUInt32(itemsize,pointer(dest))); - MoveFast(pointer(P^)^,result^,itemsize); - inc(result,itemsize); - end; - len := SizeOf(PtrUInt); // size of tkLString/tkUString in record - end; - tkWString: begin - itemsize := length(PWideString(P)^)*2; // PStrRec doesn't match on FPC - result := pointer(ToVarUInt32(itemsize,pointer(dest))); - MoveFast(pointer(P^)^,result^,itemsize); - inc(result,itemsize); - len := SizeOf(PtrUInt); - end; - tkRecord{$ifdef FPC},tkObject{$endif}: - result := RecordSave(data^,dest,info,len); - tkArray: begin - itemtype := ArrayItemType(info,len); - if info=nil then - result := nil else - if itemtype=nil then begin - MoveSmall(data,dest,len); - result := dest+len; - end else begin - for i := 1 to info^.elCount do begin - dest := ManagedTypeSave(data,dest,itemtype,itemsize); - if dest=nil then - break; // invalid/unhandled content - inc(data,itemsize) - end; - result := dest; - end; - end; - {$ifndef NOVARIANTS} - tkVariant: begin - result := VariantSave(PVariant(data)^,dest); - len := SizeOf(Variant); // size of tkVariant in record - end; - {$endif} - tkDynArray: begin - DynArray.Init(info,data^); - result := DynArray.SaveTo(dest); - len := SizeOf(PtrUInt); // size of tkDynArray in record - end; - {$ifndef DELPHI5OROLDER} - tkInterface: begin - PIInterface(dest)^ := PIInterface(data)^; // with proper refcount - result := dest+SizeOf(Int64); // consume 64-bit even on CPU32 - len := SizeOf(PtrUInt); - end; - {$endif} - else - result := nil; // invalid/unhandled record content - end; -end; - -function ManagedTypeLoad(data: PAnsiChar; var source: PAnsiChar; - info: PTypeInfo; sourceMax: PAnsiChar): integer; -// returns source=nil on error, or final source + result=data^ length -var DynArray: TDynArray; - itemtype: PTypeInfo; - itemsize: cardinal; - i: PtrInt; -begin // info is expected to come from a DeRef() if retrieved from RTTI - result := SizeOf(PtrUInt); // size of most items - if info^.Kind in [tkLString{$ifdef FPC},tkLStringOld{$endif},tkWString - {$ifdef HASVARUSTRING},tkUString{$endif}] then - if sourceMax<>nil then begin - source := pointer(FromVarUInt32Safe(PByte(source),PByte(sourceMax),itemsize)); - if source=nil then - exit; - if source+itemsize>sourceMax then begin - source := nil; - exit; // avoid buffer overflow - end; - end else - itemsize := FromVarUInt32(PByte(source)); // in source buffer bytes - case info^.Kind of - tkLString{$ifdef FPC}, tkLStringOld{$endif}: begin - {$ifdef HASCODEPAGE} - FastSetStringCP(data^,source,itemsize,LStringCodePage(info)); - {$else} - SetString(PRawUTF8(data)^,source,itemsize); - {$endif HASCODEPAGE} - inc(source,itemsize); - end; - tkWString: begin - SetString(PWideString(data)^,PWideChar(source),itemsize shr 1); - inc(source,itemsize); - end; - {$ifdef HASVARUSTRING} - tkUString: begin - SetString(PUnicodeString(data)^,PWideChar(source),itemsize shr 1); - inc(source,itemsize); - end; - {$endif} - tkRecord{$ifdef FPC},tkObject{$endif}: - source := RecordLoad(data^,source,info,@result,sourceMax); - tkArray: begin - itemtype := ArrayItemType(info,result); - if info=nil then - source := nil else - if itemtype=nil then - if (sourceMax<>nil) and (source+result>sourceMax) then - source := nil else begin - MoveSmall(source,data,result); - inc(source,result); - end else - for i := 1 to info^.elCount do begin - inc(data,ManagedTypeLoad(data,source,itemtype,sourceMax)); - if source=nil then - exit; - end; - end; - {$ifndef NOVARIANTS} - tkVariant: begin - source := VariantLoad(PVariant(data)^,source,@JSON_OPTIONS[true]); - result := SizeOf(Variant); // size of tkVariant in record - end; - {$endif NOVARIANTS} - tkDynArray: begin - DynArray.Init(info,data^); - source := DynArray.LoadFrom(source,nil,{nohash=}true,sourceMax); - end; - {$ifndef DELPHI5OROLDER} - tkInterface: begin - if (sourceMax<>nil) and (source+SizeOf(Int64)>sourceMax) then begin - source := nil; - exit; - end; - PIInterface(data)^ := PIInterface(source)^; // with proper refcount - inc(source,SizeOf(Int64)); // consume 64-bit even on CPU32 - end; - {$endif DELPHI5OROLDER} - else - source := nil; // notify error for unexpected input type - end; -end; - -function GetManagedFields(info: PTypeInfo; out firstfield: PFieldInfo): integer; -{$ifdef HASINLINE}inline;{$endif} -{$ifdef FPC_NEWRTTI} -var - recInitData: PFPCRecInitData; // low-level type redirected from SynFPCTypInfo - aPointer:pointer; -begin - if Assigned(info^.RecInitInfo) then - recInitData := PFPCRecInitData(AlignTypeDataClean(PTypeInfo(info^.RecInitInfo+2+PByte(info^.RecInitInfo+1)^))) - else begin - aPointer:=@info^.RecInitInfo; - {$ifdef FPC_PROVIDE_ATTR_TABLE} - dec(PByte(aPointer),SizeOf(Pointer)); - {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} - {$ifdef CPUARM} - dec(PByte(aPointer),SizeOf(Pointer)); - {$endif CPUARM} - {$endif} - {$endif} - recInitData := PFPCRecInitData(aPointer); - end; - firstfield := PFieldInfo(PtrUInt(@recInitData^.ManagedFieldCount)); - inc(PByte(firstfield),SizeOf(recInitData^.ManagedFieldCount)); - firstfield := AlignPTypeInfo(firstfield); - result := recInitData^.ManagedFieldCount; -{$else} -begin - firstfield := @info^.ManagedFields[0]; - result := info^.ManagedCount; -{$endif FPC_NEWRTTI} -end; - -function RecordEquals(const RecA, RecB; TypeInfo: pointer; - PRecSize: PInteger): boolean; -var info,fieldinfo: PTypeInfo; - F, offset: PtrInt; - field: PFieldInfo; - A, B: PAnsiChar; -begin - A := @RecA; - B := @RecB; - result := false; - info := GetTypeInfo(TypeInfo,tkRecordKinds); - if info=nil then - exit; // raise Exception.CreateUTF8('% is not a record',[Typ^.Name]); - if PRecSize<>nil then - PRecSize^ := info^.recSize; - if A=B then begin // both nil or same pointer - result := true; - exit; - end; - offset := 0; - for F := 1 to GetManagedFields(info,field) do begin - fieldinfo := DeRef(field^.TypeInfo); - {$ifdef FPC_OLDRTTI} // old FPC did include RTTI for unmanaged fields - if not (fieldinfo^.Kind in tkManagedTypes) then begin - inc(field); - continue; // as with Delphi - end; - {$endif} - offset := integer(field^.Offset)-offset; - if offset<>0 then begin - if not CompareMemFixed(A,B,offset) then - exit; // binary block not equal - inc(A,offset); - inc(B,offset); - end; - offset := ManagedTypeCompare(A,B,fieldinfo); - if offset<=0 then - if offset=0 then // A^<>B^ - exit else // Diff=-1 for unexpected type - raise ESynException.CreateUTF8('RecordEquals: unexpected %', - [ToText(fieldinfo^.Kind)^]); - inc(A,offset); - inc(B,offset); - inc(offset,field^.Offset); - inc(field); - end; - if CompareMemFixed(A,B,integer(info^.recSize)-offset) then - result := true; -end; - -function RecordSaveLength(const Rec; TypeInfo: pointer; Len: PInteger): integer; -var info,fieldinfo: PTypeInfo; - F, recsize,saved: integer; - field: PFieldInfo; - R: PAnsiChar; -begin - R := @Rec; - info := GetTypeInfo(TypeInfo,tkRecordKinds); - if (R=nil) or (info=nil) then begin - result := 0; // should have been checked before - exit; - end; - result := info^.recSize; - if Len<>nil then - Len^ := result; - for F := 1 to GetManagedFields(info,field) do begin - fieldinfo := DeRef(field^.TypeInfo); - {$ifdef FPC_OLDRTTI} // old FPC did include RTTI for unmanaged fields! :) - if not (fieldinfo^.Kind in tkManagedTypes) then begin - inc(field); - continue; // as with Delphi - end; - {$endif}; - saved := ManagedTypeSaveLength(R+field^.Offset,fieldinfo,recsize); - if saved=0 then begin - result := 0; // invalid type - exit; - end; - inc(result,saved-recsize); // extract recsize from info^.recSize - inc(field); - end; -end; - -function RecordSave(const Rec; Dest: PAnsiChar; TypeInfo: pointer; - out Len: integer): PAnsiChar; -var info,fieldinfo: PTypeInfo; - F, offset: integer; - field: PFieldInfo; - R: PAnsiChar; -begin - R := @Rec; - info := GetTypeInfo(TypeInfo,tkRecordKinds); - if (R=nil) or (info=nil) then begin - result := nil; // should have been checked before - exit; - end; - Len := info^.recSize; - offset := 0; - for F := 1 to GetManagedFields(info,field) do begin - {$ifdef HASDIRECTTYPEINFO} // inlined DeRef() - fieldinfo := field^.TypeInfo; - {$else} - {$ifdef CPUINTEL} - fieldinfo := PPointer(field^.TypeInfo)^; - {$else} - fieldinfo := DeRef(field^.TypeInfo); - {$endif} - {$endif} - {$ifdef FPC_OLDRTTI} // old FPC did include RTTI for unmanaged fields! :) - if not (fieldinfo^.Kind in tkManagedTypes) then begin - inc(field); - continue; // as with Delphi - end; - {$endif}; - offset := integer(field^.Offset)-offset; - if offset>0 then begin - MoveFast(R^,Dest^,offset); - inc(R,offset); - inc(Dest,offset); - end; - Dest := ManagedTypeSave(R,Dest,fieldinfo,offset); - if Dest=nil then begin - result := nil; // invalid/unhandled record content - exit; - end; - inc(R,offset); - inc(offset,field.Offset); - inc(field); - end; - offset := integer(info^.recSize)-offset; - if offset<0 then - raise ESynException.Create('RecordSave offset<0') else - if offset<>0 then begin - MoveFast(R^,Dest^,offset); - result := Dest+offset; - end else - result := Dest; -end; - -function RecordSave(const Rec; Dest: PAnsiChar; TypeInfo: pointer): PAnsiChar; -var dummylen: integer; -begin - result := RecordSave(Rec,Dest,TypeInfo,dummylen); -end; - -function RecordSave(const Rec; TypeInfo: pointer): RawByteString; -var destlen,dummylen: integer; - dest: PAnsiChar; -begin - destlen := RecordSaveLength(Rec,TypeInfo); - SetString(result,nil,destlen); - if destlen<>0 then begin - dest := RecordSave(Rec,pointer(result),TypeInfo,dummylen); - if (dest=nil) or (dest-pointer(result)<>destlen) then // paranoid check - raise ESynException.CreateUTF8('RecordSave % len=%<>%', - [TypeInfoToShortString(TypeInfo)^,dest-pointer(result),destlen]); - end; -end; - -function RecordSaveBytes(const Rec; TypeInfo: pointer): TBytes; -var destlen,dummylen: integer; - dest: PAnsiChar; -begin - destlen := RecordSaveLength(Rec,TypeInfo); - result := nil; // don't reallocate TBytes data from a previous call - SetLength(result,destlen); - if destlen<>0 then begin - dest := RecordSave(Rec,pointer(result),TypeInfo,dummylen); - if (dest=nil) or (dest-pointer(result)<>destlen) then // paranoid check - raise ESynException.CreateUTF8('RecordSave % len=%<>%', - [TypeInfoToShortString(TypeInfo)^,dest-pointer(result),destlen]); - end; -end; - -procedure RecordSave(const Rec; var Dest: TSynTempBuffer; TypeInfo: pointer); -var dummylen: integer; - P: PAnsiChar; -begin - Dest.Init(RecordSaveLength(Rec,TypeInfo)); - P := RecordSave(Rec,Dest.buf,TypeInfo,dummylen); - if (P=nil) or (P-Dest.buf<>Dest.len) then begin // paranoid check - Dest.Done; - raise ESynException.CreateUTF8('RecordSave TSynTempBuffer %',[TypeInfoToShortString(TypeInfo)^]); - end; -end; - -function RecordSaveBase64(const Rec; TypeInfo: pointer; UriCompatible: boolean): RawUTF8; -var len,dummy: integer; - temp: TSynTempBuffer; -begin - result := ''; - len := RecordSaveLength(Rec,TypeInfo); - if len=0 then - exit; - temp.Init(len+4); - RecordSave(Rec,PAnsiChar(temp.buf)+4,TypeInfo,dummy); - PCardinal(temp.buf)^ := crc32c(0,PAnsiChar(temp.buf)+4,len); - if UriCompatible then - result := BinToBase64uri(temp.buf,temp.len) else - result := BinToBase64(temp.buf,temp.len); - temp.Done; -end; - -function RecordLoadBase64(Source: PAnsiChar; Len: PtrInt; var Rec; - TypeInfo: pointer; UriCompatible: boolean): boolean; -var temp: TSynTempBuffer; -begin - result := false; - if Len<=6 then - exit; - if UriCompatible then - result := Base64uriToBin(Source,Len,temp) else - result := Base64ToBin(Source,Len,temp); - result := result and (temp.len>=4) and - (crc32c(0,PAnsiChar(temp.buf)+4,temp.len-4)=PCardinal(temp.buf)^) and - (RecordLoad(Rec,PAnsiChar(temp.buf)+4,TypeInfo,nil,PAnsiChar(temp.buf)+temp.len)<>nil); - temp.Done; -end; - -function RecordLoad(var Rec; Source: PAnsiChar; TypeInfo: pointer; - Len: PInteger; SourceMax: PAnsiChar): PAnsiChar; -var info,fieldinfo: PTypeInfo; - n, F: integer; - offset: PtrInt; - field: PFieldInfo; - R: PAnsiChar; -begin - result := nil; // indicates error - R := @Rec; - info := GetTypeInfo(TypeInfo,tkRecordKinds); - if (R=nil) or (info=nil) then // should have been checked before - exit; - if Len<>nil then - Len^ := info^.recSize; - n := GetManagedFields(info,field); - if Source=nil then begin // inline RecordClear() function - for F := 1 to n do begin - {$ifdef FPC}FPCFinalize{$else}_Finalize{$endif}(R+field^.Offset,Deref(field^.TypeInfo)); - inc(field); - end; - exit; - end; - offset := 0; - for F := 1 to n do begin - {$ifdef HASDIRECTTYPEINFO} // inlined DeRef() - fieldinfo := field^.TypeInfo; - {$else} - {$ifdef CPUINTEL} - fieldinfo := PPointer(field^.TypeInfo)^; - {$else} - fieldinfo := DeRef(field^.TypeInfo); - {$endif} - {$endif} - {$ifdef FPC_OLDRTTI} // old FPC did include RTTI for unmanaged fields! :) - if not (fieldinfo^.Kind in tkManagedTypes) then begin - inc(field); - continue; // as with Delphi - end; - {$endif}; - offset := integer(field^.Offset)-offset; - if offset<>0 then begin - if (SourceMax<>nil) and (Source+offset>SourceMax) then - exit; - MoveFast(Source^,R^,offset); - inc(Source,offset); - inc(R,offset); - end; - offset := ManagedTypeLoad(R,Source,fieldinfo,SourceMax); - if Source=nil then - exit; // error at loading - inc(R,offset); - inc(offset,field^.Offset); - inc(field); - end; - offset := integer(info^.recSize)-offset; - if offset<0 then - raise ESynException.Create('RecordLoad offset<0') else - if offset<>0 then begin - if (SourceMax<>nil) and (Source+offset>SourceMax) then - exit; - MoveFast(Source^,R^,offset); - result := Source+offset; - end else - result := Source; -end; - -function RecordLoad(var Res; const Source: RawByteString; TypeInfo: pointer): boolean; -var P: PAnsiChar; -begin - P := pointer(Source); - P := RecordLoad(Res,P,TypeInfo,nil,P+length(Source)); - result := (P<>nil) and (P-pointer(Source)=length(Source)); -end; - -{$ifndef FPC} - - {$ifdef USEPACKAGES} - {$define EXPECTSDELPHIRTLRECORDCOPYCLEAR} - {$endif} - {$ifdef DELPHI5OROLDER} - {$define EXPECTSDELPHIRTLRECORDCOPYCLEAR} - {$endif} - {$ifdef PUREPASCAL} - {$define EXPECTSDELPHIRTLRECORDCOPYCLEAR} - {$endif} - {$ifndef DOPATCHTRTL} - {$define EXPECTSDELPHIRTLRECORDCOPYCLEAR} - {$endif} - -{$ifdef EXPECTSDELPHIRTLRECORDCOPYCLEAR} -procedure RecordCopy(var Dest; const Source; TypeInfo: pointer); -asm // same params than _CopyRecord{ dest, source, typeInfo: Pointer } - {$ifdef CPU64} - .noframe - {$endif} - jmp System.@CopyRecord -end; - -procedure RecordClear(var Dest; TypeInfo: pointer); -asm - {$ifdef CPU64} - .noframe - {$endif} - jmp System.@FinalizeRecord -end; -{$endif EXPECTSDELPHIRTLRECORDCOPYCLEAR} - - -{$ifdef DOPATCHTRTL} - -function SystemRecordCopyAddress: Pointer; -asm - {$ifdef CPU64} - mov rax,offset System.@CopyRecord - {$else} - mov eax,offset System.@CopyRecord - {$endif} -end; - -function SystemFinalizeRecordAddress: Pointer; -asm - {$ifdef CPU64} - mov rax,offset System.@FinalizeRecord - {$else} - mov eax,offset System.@FinalizeRecord - {$endif} -end; - -function SystemInitializeRecordAddress: Pointer; -asm - {$ifdef CPU64} - mov rax,offset System.@InitializeRecord - {$else} - mov eax,offset System.@InitializeRecord - {$endif} -end; - -{$ifdef CPUX86} -procedure _InitializeRecord(P: Pointer; TypeInfo: Pointer); -asm // faster version by AB - { -> EAX pointer to record to be finalized } - { EDX pointer to type info } -(* // this TObject.Create-like initialization sounds slower - movzx ecx,byte ptr [edx].TTypeInfo.NameLen - mov edx,[edx+ecx].TTypeInfo.Size - xor ecx,ecx - jmp dword ptr [FillCharFast] *) - movzx ecx, byte ptr[edx].TTypeInfo.NameLen - push ebx - mov ebx, eax - push esi - push edi - mov edi, [edx + ecx].TTypeInfo.ManagedCount - lea esi, [edx + ecx].TTypeInfo.ManagedFields - test edi, edi - jz @end -@loop: mov edx, [esi].TFieldInfo.TypeInfo - mov eax, [esi].TFieldInfo.&Offset - mov edx, [edx] - add esi, 8 - movzx ecx, [edx].TTypeInfo.Kind - add eax, ebx // eax=data to be initialized - jmp dword ptr[@tab + ecx * 4 - tkLString * 4] -@tab: dd @ptr, @ptr, @varrec, @array, @array, @ptr, @ptr, @ptr, @ptr -@ptr: mov dword ptr[eax], 0 // pointer initialization - dec edi - jg @loop -@end: pop edi - pop esi - pop ebx - ret -@varrec:xor ecx, ecx - mov dword ptr[eax], ecx - mov dword ptr[eax + 4], ecx - mov dword ptr[eax + 8], ecx - mov dword ptr[eax + 12], ecx - dec edi - jg @loop - pop edi - pop esi - pop ebx - ret -@array: mov ecx, 1 // here eax=data edx=typeinfo - call System.@InitializeArray - dec edi - jg @loop - pop edi - pop esi - pop ebx -end; - -{$ifndef UNICODE} // TMonitor.Destroy is not available ! -> apply to D2007 only -procedure TObjectCleanupInstance; -asm // faster version by AB - push ebx - mov ebx, eax -@loop: mov ebx, [ebx] // handle three VMT levels per iteration - mov edx, [ebx].vmtInitTable - mov ebx, [ebx].vmtParent - test edx, edx - jnz @clr - test ebx, ebx - jz @end - mov ebx, [ebx] - mov edx, [ebx].vmtInitTable - mov ebx, [ebx].vmtParent - test edx, edx - jnz @clr - test ebx, ebx - jz @end - mov ebx, [ebx] - mov edx, [ebx].vmtInitTable - mov ebx, [ebx].vmtParent - test edx, edx - jnz @clr - test ebx, ebx - jnz @loop -@end: pop ebx - ret -@clr: push offset @loop // TObject has no vmtInitTable -> safe - jmp RecordClear // eax=self edx=typeinfo -end; -{$endif} - -procedure RecordClear(var Dest; TypeInfo: pointer); -asm // faster version by AB (direct call to finalization procedures) - { -> EAX pointer to record to be finalized } - { EDX pointer to type info } - { <- EAX pointer to record to be finalized } - movzx ecx, byte ptr[edx].TTypeInfo.NameLen - push ebx - mov ebx, eax - push esi - push edi - mov edi, [edx + ecx].TTypeInfo.ManagedCount - lea esi, [edx + ecx].TTypeInfo.ManagedFields - test edi, edi - jz @end -@loop: mov edx, [esi].TFieldInfo.TypeInfo - mov eax, [esi].TFieldInfo.&Offset - mov edx, [edx] - add esi, 8 - movzx ecx, [edx].TTypeInfo.Kind - add eax, ebx // eax=data to be initialized - sub cl, tkLString -{$ifdef UNICODE} - cmp cl, tkUString - tkLString + 1 -{$else} cmp cl, tkDynArray - tkLString + 1 -{$endif} - jnb @err - call dword ptr[@Tab + ecx * 4] - dec edi - jg @loop -@end: mov eax, ebx // keep eax at return (see e.g. TObject.CleanupInstance) - pop edi - pop esi - pop ebx - ret - nop - nop - nop // align @Tab -@Tab: dd System.@LStrClr -{$IFDEF LINUX} // under Linux, WideString are refcounted as AnsiString - dd System.@LStrClr -{$else} dd System.@WStrClr -{$endif} -{$ifdef LVCL} - dd @err -{$else} dd System.@VarClr -{$endif} - dd @array - dd RecordClear - dd System.@IntfClear - dd @err - dd System.@DynArrayClear - {$ifdef UNICODE} - dd System.@UStrClr - {$endif} -@err: mov al, reInvalidPtr - pop edi - pop esi - pop ebx - jmp System.Error -@array: movzx ecx, [edx].TTypeInfo.NameLen - add ecx, edx - mov edx, dword ptr[ecx].TTypeInfo.ManagedFields[0] // Fields[0].TypeInfo^ - mov ecx, [ecx].TTypeInfo.ManagedCount - mov edx, [edx] - call System.@FinalizeArray - // we made Call @Array -> ret to continue -end; - -procedure RecordCopy(var Dest; const Source; TypeInfo: pointer); -asm // faster version of _CopyRecord{dest, source, typeInfo: Pointer} by AB - { -> EAX pointer to dest } - { EDX pointer to source } - { ECX pointer to typeInfo } - push ebp - push ebx - push esi - push edi - movzx ebx, byte ptr[ecx].TTypeInfo.NameLen - mov esi, edx // esi = source - mov edi, eax // edi = dest - add ebx, ecx // ebx = TFieldTable - xor eax, eax // eax = current offset - mov ebp, [ebx].TTypeInfo.ManagedCount // ebp = TFieldInfo count - mov ecx, [ebx].TTypeInfo.recSize - test ebp, ebp - jz @fullcopy - push ecx // SizeOf(record) on stack - add ebx, offset TTypeInfo.ManagedFields[0] // ebx = first TFieldInfo -@next: mov ecx, [ebx].TFieldInfo.&Offset - mov edx, [ebx].TFieldInfo.TypeInfo - sub ecx, eax - mov edx, [edx] - jle @nomov - add esi, ecx - add edi, ecx - neg ecx -@mov1: mov al, [esi + ecx] // fast copy not destructable data - mov [edi + ecx], al - inc ecx - jnz @mov1 -@nomov: mov eax, edi - movzx ecx, [edx].TTypeInfo.Kind - cmp ecx, tkLString - je @LString - jb @err -{$ifdef UNICODE} - cmp ecx, tkUString - je @UString -{$else} cmp ecx, tkDynArray - je @dynaray -{$endif} ja @err - jmp dword ptr[ecx * 4 + @tab - tkWString * 4] - -@Tab: dd @WString, @variant, @array, @record, @interface, @err -{$ifdef UNICODE} - dd @dynaray -{$endif} -@errv: mov al, reVarInvalidOp - jmp @err2 -@err: mov al, reInvalidPtr -@err2: pop edi - pop esi - pop ebx - pop ebp - jmp System.Error - nop // all functions below have esi=source edi=dest -@array: movzx ecx, byte ptr[edx].TTypeInfo.NameLen - push dword ptr[edx + ecx].TTypeInfo.recSize - push dword ptr[edx + ecx].TTypeInfo.ManagedCount - mov ecx, dword ptr[edx + ecx].TTypeInfo.ManagedFields[0] // Fields[0].TypeInfo^ - mov ecx, [ecx] - mov edx, esi - call System.@CopyArray - pop eax // restore SizeOf(Array) - jmp @finish -@record:movzx ecx, byte ptr[edx].TTypeInfo.NameLen - mov ecx, [edx + ecx].TTypeInfo.recSize - push ecx - mov ecx, edx - mov edx, esi - call RecordCopy - pop eax // restore SizeOf(Record) - jmp @finish - nop - nop - nop -@variant: -{$ifdef NOVARCOPYPROC} - mov edx, esi - call System.@VarCopy -{$else} mov edx, esi - cmp dword ptr[VarCopyProc], 0 - jz @errv - call [VarCopyProc] -{$endif} - mov eax, 16 - jmp @finish -{$ifdef DELPHI6OROLDER} - nop - nop -{$endif} -@interface: - mov edx, [esi] - call System.@IntfCopy - jmp @fin4 - nop - nop - nop -@dynaray: - mov ecx, edx // ecx=TypeInfo - mov edx, [esi] - call System.@DynArrayAsg - jmp @fin4 -@WString: -{$ifndef LINUX} - mov edx, [esi] - call System.@WStrAsg - jmp @fin4 -{$endif} -@LString: - mov edx, [esi] - call System.@LStrAsg -{$ifdef UNICODE} - jmp @fin4 - nop - nop -@UString: - mov edx, [esi] - call System.@UStrAsg -{$endif} -@fin4: mov eax, 4 -@finish: - add esi, eax - add edi, eax - add eax, [ebx].TFieldInfo.&Offset - add ebx, 8 - dec ebp // any other TFieldInfo? - jnz @next - pop ecx // ecx= SizeOf(record) -@fullcopy: - mov edx, edi - sub ecx, eax - mov eax, esi - jle @nomov2 - call dword ptr[MoveFast] -@nomov2: pop edi - pop esi - pop ebx - pop ebp -end; - -{$endif CPUX86} -{$endif DOPATCHTRTL} - -{$ifndef CPUARM} - -function SystemFillCharAddress: Pointer; -asm - {$ifdef CPU64} - mov rax,offset System.@FillChar - {$else} - mov eax,offset System.@FillChar - {$endif} -end; - -{$ifndef CPU64} - -{$ifndef PUREPASCAL} - -procedure FillCharX87; -asm // eax=Dest edx=Count cl=Value - // faster version by John O'Harrow (Code Size = 153 Bytes) - mov ch, cl // copy value into both bytes of cx - cmp edx, 32 - jl @small - mov [eax], cx // fill first 8 bytes - mov [eax + 2], cx - mov [eax + 4], cx - mov [eax + 6], cx - sub edx, 16 - fld qword ptr[eax] - fst qword ptr[eax + edx] // fill last 16 bytes - fst qword ptr[eax + edx + 8] - mov ecx, eax - and ecx, 7 // 8-byte align writes - sub ecx, 8 - sub eax, ecx - add edx, ecx - add eax, edx - neg edx -@loop: fst qword ptr[eax + edx] // fill 16 bytes per loop - fst qword ptr[eax + edx + 8] - add edx, 16 - jl @loop - ffree st(0) - fincstp - ret - nop -@small: test edx, edx - jle @done - mov [eax + edx - 1], cl // fill last byte - and edx, -2 // no. of words to fill - neg edx - lea edx, [@fill + 60 + edx * 2] - jmp edx - nop // align jump destinations - nop -@fill: mov [eax + 28], cx - mov [eax + 26], cx - mov [eax + 24], cx - mov [eax + 22], cx - mov [eax + 20], cx - mov [eax + 18], cx - mov [eax + 16], cx - mov [eax + 14], cx - mov [eax + 12], cx - mov [eax + 10], cx - mov [eax + 8], cx - mov [eax + 6], cx - mov [eax + 4], cx - mov [eax + 2], cx - mov [eax], cx - ret // for 4-bytes @fill alignment -@done: db $f3 // rep ret AMD trick here -end; - -/// faster implementation of Move() for Delphi versions with no FastCode inside -procedure MoveX87; -asm // eax=source edx=dest ecx=count - // original code by John O'Harrow - included since delphi 2007 - cmp eax, edx - jz @exit // exit if source=dest - cmp ecx, 32 - ja @lrg // count > 32 or count < 0 - sub ecx, 8 - jg @sml // 9..32 byte move - jmp dword ptr[@table + 32 + ecx * 4] // 0..8 byte move -@sml: fild qword ptr[eax + ecx] // load last 8 - fild qword ptr[eax] // load first 8 - cmp ecx, 8 - jle @sml16 - fild qword ptr[eax + 8] // load second 8 - cmp ecx, 16 - jle @sml24 - fild qword ptr[eax + 16] // load third 8 - fistp qword ptr[edx + 16] // save third 8 -@sml24: fistp qword ptr[edx + 8] // save second 8 -@sml16: fistp qword ptr[edx] // save first 8 - fistp qword ptr[edx + ecx] // save last 8 - ret -@exit: rep ret -@table: dd @exit, @m01, @m02, @m03, @m04, @m05, @m06, @m07, @m08 -@lrgfwd:push edx - fild qword ptr[eax] // first 8 - lea eax, [eax + ecx - 8] - lea ecx, [ecx + edx - 8] - fild qword ptr[eax] // last 8 - push ecx - neg ecx - and edx, -8 // 8-byte align writes - lea ecx, [ecx + edx + 8] - pop edx -@fwd: fild qword ptr[eax + ecx] - fistp qword ptr[edx + ecx] - add ecx, 8 - jl @fwd - fistp qword ptr[edx] // last 8 - pop edx - fistp qword ptr[edx] // first 8 - ret -@lrg: jng @exit // count < 0 - cmp eax, edx - ja @lrgfwd - sub edx, ecx - cmp eax, edx - lea edx, [edx + ecx] - jna @lrgfwd - sub ecx, 8 // backward move - push ecx - fild qword ptr[eax + ecx] // last 8 - fild qword ptr[eax] // first 8 - add ecx, edx - and ecx, -8 // 8-byte align writes - sub ecx, edx -@bwd: fild qword ptr[eax + ecx] - fistp qword ptr[edx + ecx] - sub ecx, 8 - jg @bwd - pop ecx - fistp qword ptr[edx] // first 8 - fistp qword ptr[edx + ecx] // last 8 - ret -@m01: movzx ecx, byte ptr[eax] - mov [edx], cl - ret -@m02: movzx ecx, word ptr[eax] - mov [edx], cx - ret -@m03: mov cx, [eax] - mov al, [eax + 2] - mov [edx], cx - mov [edx + 2], al - ret -@m04: mov ecx, [eax] - mov [edx], ecx - ret -@m05: mov ecx, [eax] - mov al, [eax + 4] - mov [edx], ecx - mov [edx + 4], al - ret -@m06: mov ecx, [eax] - mov ax, [eax + 4] - mov [edx], ecx - mov [edx + 4], ax - ret -@m07: mov ecx, [eax] - mov eax, [eax + 3] - mov [edx], ecx - mov [edx + 3], eax - ret -@m08: mov ecx, [eax] - mov eax, [eax + 4] - mov [edx], ecx - mov [edx + 4], eax -end; - -{$ifdef WITH_ERMS} -procedure FillCharERMSB; // Ivy Bridge+ Enhanced REP MOVSB/STOSB CPUs -asm // eax=Dest edx=Count cl=Value - test edx, edx - jle @none - cld - push edi - mov edi, eax - mov al, cl - mov ecx, edx - rep stosb - pop edi -@none: -end; - -procedure MoveERMSB; // Ivy Bridge+ Enhanced REP MOVSB/STOSB CPUs -asm // eax=source edx=dest ecx=count - test ecx, ecx - jle @none - push esi - push edi - cmp edx, eax - ja @down - mov esi, eax - mov edi, edx - cld - rep movsb - pop edi - pop esi -@none:ret -@down:lea esi, [eax + ecx - 1] - lea edi, [edx + ecx - 1] - std - rep movsb - pop edi - pop esi - cld -end; -{$endif WITH_ERMS} - -function StrLenX86(S: pointer): PtrInt; -// pure x86 function (if SSE2 not available) - faster than SysUtils' version -asm - test eax, eax - jz @0 - cmp byte ptr[eax + 0], 0 - je @0 - cmp byte ptr[eax + 1], 0 - je @1 - cmp byte ptr[eax + 2], 0 - je @2 - cmp byte ptr[eax + 3], 0 - je @3 - push eax - and eax, -4 { DWORD Align Reads } -@Loop: add eax, 4 - mov edx, [eax] { 4 Chars per Loop } - lea ecx, [edx - $01010101] - not edx - and edx, ecx - and edx, $80808080 { Set Byte to $80 at each #0 Position } - jz @Loop { Loop until any #0 Found } - pop ecx - bsf edx, edx { Find First #0 Position } - shr edx, 3 { Byte Offset of First #0 } - add eax, edx { Address of First #0 } - sub eax, ecx { Returns Length } - ret -@0: xor eax, eax - ret -@1: mov eax, 1 - ret -@2: mov eax, 2 - ret -@3: mov eax, 3 -end; - -{$ifndef DELPHI5OROLDER} // need SSE2 asm instruction set - -procedure FillCharSSE2; -asm // Dest=eax Count=edx Value=cl - mov ch, cl {copy value into both bytes of cx} - cmp edx, 32 - jl @small - sub edx, 16 - movd xmm0, ecx - pshuflw xmm0, xmm0, 0 - pshufd xmm0, xmm0, 0 - movups [eax], xmm0 {fill first 16 bytes} - movups [eax + edx], xmm0 {fill last 16 bytes} - mov ecx, eax {16-byte align writes} - and ecx, 15 - sub ecx, 16 - sub eax, ecx - add edx, ecx - add eax, edx - neg edx - cmp edx, - 512 * 1024 - jb @large -@loop: movaps [eax + edx], xmm0 {fill 16 bytes per loop} - add edx, 16 - jl @loop - ret -@large: movntdq [eax + edx], xmm0 {fill 16 bytes per loop} - add edx, 16 - jl @large - ret -@small: test edx, edx - jle @done - mov [eax + edx - 1], cl {fill last byte} - and edx, -2 {no. of words to fill} - neg edx - lea edx, [@smallfill + 60 + edx * 2] - jmp edx - nop {align jump destinations} - nop -@smallfill: - mov [eax + 28], cx - mov [eax + 26], cx - mov [eax + 24], cx - mov [eax + 22], cx - mov [eax + 20], cx - mov [eax + 18], cx - mov [eax + 16], cx - mov [eax + 14], cx - mov [eax + 12], cx - mov [eax + 10], cx - mov [eax + 8], cx - mov [eax + 6], cx - mov [eax + 4], cx - mov [eax + 2], cx - mov [eax], cx - ret {do not remove - this is for alignment} -@done: -end; - -{$endif DELPHI5OROLDER} - -{$endif PUREPASCAL} -{$endif CPU64} -{$endif CPUARM} - -{$endif FPC} - - -{ ************ Custom record / dynamic array JSON serialization } - -procedure SaveJSON(const Value; TypeInfo: pointer; - Options: TTextWriterOptions; var result: RawUTF8); -var temp: TTextWriterStackBuffer; -begin - with DefaultTextWriterSerializer.CreateOwnedStream(temp) do - try - fCustomOptions := fCustomOptions+Options; - AddTypedJSON(TypeInfo,Value); - SetText(result); - finally - Free; - end; -end; - -function SaveJSON(const Value; TypeInfo: pointer; EnumSetsAsText: boolean): RawUTF8; -var options: TTextWriterOptions; -begin - if EnumSetsAsText then - options := [twoEnumSetsAsTextInRecord,twoFullSetsAsStar] else - options := [twoFullSetsAsStar]; - SaveJSON(Value,TypeInfo,options,result); -end; - -type - /// information about one customized JSON serialization - TJSONCustomParserRegistration = record - RecordTypeName: RawUTF8; - RecordTextDefinition: RawUTF8; - DynArrayTypeInfo: pointer; - RecordTypeInfo: pointer; - Reader: TDynArrayJSONCustomReader; - Writer: TDynArrayJSONCustomWriter; - RecordCustomParser: TJSONRecordAbstract; - end; - PJSONCustomParserRegistration = ^TJSONCustomParserRegistration; - TJSONCustomParserRegistrations = array of TJSONCustomParserRegistration; - - PTJSONCustomParserAbstract = ^TJSONRecordAbstract; - - /// used internally to manage custom record / dynamic array JSON serialization - // - e.g. used by TTextWriter.RegisterCustomJSONSerializer*() - TJSONCustomParsers = class - protected - fLastDynArrayIndex: integer; - fLastRecordIndex: integer; - fParser: TJSONCustomParserRegistrations; - fParsersCount: Integer; - fParsers: TDynArrayHashed; - {$ifndef NOVARIANTS} - fVariants: array of record - TypeClass: TCustomVariantType; - Reader: TDynArrayJSONCustomReader; - Writer: TDynArrayJSONCustomWriter; - end; - function VariantSearch(aClass: TCustomVariantType): PtrInt; - procedure VariantWrite(aClass: TCustomVariantType; - aWriter: TTextWriter; const aValue: variant; Escape: TTextWriterKind); - {$endif} - function TryToGetFromRTTI(aDynArrayTypeInfo, aRecordTypeInfo: pointer): integer; - function Search(aTypeInfo: pointer; var Reg: TJSONCustomParserRegistration; - AddIfNotExisting: boolean): integer; - function DynArraySearch(aDynArrayTypeInfo, aRecordTypeInfo: pointer; - AddIfNotExisting: boolean=true): integer; overload; - function RecordSearch(aRecordTypeInfo: pointer; - AddIfNotExisting: boolean=true): integer; overload; - function RecordSearch(aRecordTypeInfo: pointer; - out Reader: TDynArrayJSONCustomReader): boolean; overload; - function RecordSearch(aRecordTypeInfo: pointer; - out Writer: TDynArrayJSONCustomWriter; PParser: PTJSONCustomParserAbstract): boolean; overload; - function RecordSearch(const aTypeName: RawUTF8): integer; overload; - function RecordRTTITextHash(aRecordTypeInfo: pointer; var crc: cardinal; - out recsize: integer): boolean; - public - constructor Create; - procedure RegisterCallbacks(aTypeInfo: pointer; - aReader: TDynArrayJSONCustomReader; aWriter: TDynArrayJSONCustomWriter); - function RegisterFromText(aTypeInfo: pointer; - const aRTTIDefinition: RawUTF8): TJSONRecordAbstract; - {$ifndef NOVARIANTS} - procedure RegisterCallbacksVariant(aClass: TCustomVariantType; - aReader: TDynArrayJSONCustomReader; aWriter: TDynArrayJSONCustomWriter); - {$endif} - property Parser: TJSONCustomParserRegistrations read fParser; - property ParsersCount: Integer read fParsersCount; - end; - -var - GlobalJSONCustomParsers: TJSONCustomParsers; - -constructor TJSONCustomParsers.Create; -begin - fParsers.InitSpecific(TypeInfo(TJSONCustomParserRegistrations), - fParser,djRawUTF8,@fParsersCount,true); - GarbageCollectorFreeAndNil(GlobalJSONCustomParsers,self); -end; - -function TJSONCustomParsers.TryToGetFromRTTI(aDynArrayTypeInfo, - aRecordTypeInfo: pointer): integer; -var Reg: TJSONCustomParserRegistration; - RegRoot: TJSONCustomParserRTTI; - {$ifdef ISDELPHI2010} - info: PTypeInfo; - {$endif} - added: boolean; - ndx, len: integer; - name: PShortString; -begin - result := -1; - Reg.RecordTypeInfo := aRecordTypeInfo; - Reg.DynArrayTypeInfo := aDynArrayTypeInfo; - TypeInfoToName(Reg.RecordTypeInfo,Reg.RecordTypeName); - if Reg.RecordTypeName='' then begin - name := TypeInfoToShortString(Reg.DynArrayTypeInfo); - if name=nil then - exit; // we need a type name! - len := length(name^); // try to guess from T*DynArray or T*s names - if (len>12) and (IdemPropName('DynArray',@name^[len-7],8)) then - FastSetString(Reg.RecordTypeName,@name^[1],len-8) else - if (len>3) and (name^[len]='s') then - FastSetString(Reg.RecordTypeName,@name^[1],len-1) else - exit; - end; - RegRoot := TJSONCustomParserRTTI.CreateFromTypeName('',Reg.RecordTypeName); - {$ifdef ISDELPHI2010} - if RegRoot=nil then begin - info := GetTypeInfo(aRecordTypeInfo,tkRecordKinds); - if info=nil then - exit; // not enough RTTI - inc(PByte(info),info^.ManagedCount*SizeOf(TFieldInfo)-SizeOf(TFieldInfo)); - inc(PByte(info),info^.NumOps*SizeOf(pointer)); // jump RecOps[] - if info^.AllCount=0 then - exit; // not enough RTTI -> avoid exception in constructor below - end; - {$else} - if RegRoot=nil then - exit; // not enough RTTI for older versions of Delphi - {$endif} - Reg.RecordCustomParser := TJSONRecordRTTI.Create(Reg.RecordTypeInfo,RegRoot); - Reg.Reader := Reg.RecordCustomParser.CustomReader; - Reg.Writer := Reg.RecordCustomParser.CustomWriter; - if self=nil then - if GlobalJSONCustomParsers<>nil then // may have been set just above - self := GlobalJSONCustomParsers else - self := TJSONCustomParsers.Create; - ndx := fParsers.FindHashedForAdding(Reg.RecordTypeName,added); - if not added then - exit; // name should be unique - fParser[ndx] := Reg; - result := ndx; -end; - -function TJSONCustomParsers.DynArraySearch(aDynArrayTypeInfo,aRecordTypeInfo: pointer; - AddIfNotExisting: boolean): Integer; -var threadsafe: integer; - parser: PJSONCustomParserRegistration; -begin // O(n) brute force is fast enough, since n remains small (mostly<64) - if self<>nil then - if (aDynArrayTypeInfo<>nil) and (fParsersCount<>0) then begin - threadsafe := fLastDynArrayIndex; - if (cardinal(threadsafe)=0 then - fLastRecordIndex := result; - end else - result := -1; -end; - -function TJSONCustomParsers.RecordSearch(aRecordTypeInfo: pointer; - AddIfNotExisting: boolean): integer; -begin - if aRecordTypeInfo=nil then begin - result := -1; - exit; - end; - if self<>nil then - if (cardinal(fLastRecordIndex)=0 then - fLastRecordIndex := result; - end else - result := -1; -end; - -function TJSONCustomParsers.RecordSearch(const aTypeName: RawUTF8): integer; -begin - if self=nil then - result := -1 else - if (cardinal(fLastRecordIndex)=0 then - fLastRecordIndex := result; - end; -end; - -function TJSONCustomParsers.RecordSearch(aRecordTypeInfo: pointer; - out Reader: TDynArrayJSONCustomReader): boolean; -var ndx: integer; -begin - ndx := RecordSearch(aRecordTypeInfo); - if (ndx>=0) and Assigned(fParser[ndx].Reader) then begin - Reader := fParser[ndx].Reader; - result := true; - end else - result := false; -end; - -function TJSONCustomParsers.RecordRTTITextHash(aRecordTypeInfo: pointer; - var crc: cardinal; out recsize: integer): boolean; -var ndx: integer; -begin - if (self<>nil) and (aRecordTypeInfo<>nil) then - for ndx := 0 to fParsersCount-1 do - with fParser[ndx] do - if RecordTypeInfo=aRecordTypeInfo then begin - if RecordTextDefinition='' then - break; - crc := crc32c(crc,pointer(RecordTextDefinition),length(RecordTextDefinition)); - recsize := RecordTypeInfoSize(aRecordTypeInfo); - result := true; - exit; - end; - result := false; -end; - -function TJSONCustomParsers.RecordSearch(aRecordTypeInfo: pointer; - out Writer: TDynArrayJSONCustomWriter; PParser: PTJSONCustomParserAbstract): boolean; -var ndx: integer; -begin - result := false; - ndx := RecordSearch(aRecordTypeInfo); - if (ndx>=0) and Assigned(fParser[ndx].Writer) then begin - Writer := fParser[ndx].Writer; - if PParser<>nil then - PParser^ := fParser[ndx].RecordCustomParser; - result := true; - end; -end; - -function TJSONCustomParsers.Search(aTypeInfo: pointer; - var Reg: TJSONCustomParserRegistration; AddIfNotExisting: boolean): integer; -var added: boolean; -begin - if (aTypeInfo=nil) or (self=nil) then - raise ESynException.CreateUTF8('%.Search(%)',[self,aTypeInfo]); - FillCharFast(Reg,SizeOf(Reg),0); - case PTypeKind(aTypeInfo)^ of - tkDynArray: begin - Reg.DynArrayTypeInfo := aTypeInfo; - Reg.RecordTypeInfo := DynArrayTypeInfoToRecordInfo(aTypeInfo); - result := DynArraySearch(Reg.DynArrayTypeInfo,Reg.RecordTypeInfo,false); - end; - tkRecord{$ifdef FPC},tkObject{$endif}: begin - Reg.DynArrayTypeInfo := nil; - Reg.RecordTypeInfo := aTypeInfo; - result := RecordSearch(Reg.RecordTypeInfo,false); - end; - else raise ESynException.CreateUTF8('%.Search: % not a tkDynArray/tkRecord', - [self,ToText(PTypeKind(aTypeInfo)^)^]); - end; - if not AddIfNotExisting then - exit; - TypeInfoToName(Reg.RecordTypeInfo,Reg.RecordTypeName); - if Reg.RecordTypeName='' then - TypeInfoToName(Reg.DynArrayTypeInfo,Reg.RecordTypeName); - if Reg.RecordTypeName='' then - raise ESynException.CreateUTF8('%.Search(%) has no type name',[self,aTypeInfo]); - if result<0 then - result := fParsers.FindHashedForAdding(Reg.RecordTypeName,added); -end; - -{$ifndef NOVARIANTS} -function TJSONCustomParsers.VariantSearch(aClass: TCustomVariantType): PtrInt; -begin - if self<>nil then - for result := 0 to length(fVariants)-1 do - if fVariants[result].TypeClass=aClass then - exit; - result := -1; -end; - -procedure TJSONCustomParsers.VariantWrite(aClass: TCustomVariantType; - aWriter: TTextWriter; const aValue: variant; Escape: TTextWriterKind); -var ndx: PtrInt; - temp: string; -begin - ndx := VariantSearch(aClass); - if (ndx>=0) and Assigned(fVariants[ndx].Writer) then - fVariants[ndx].Writer(aWriter,aValue) else begin - temp := aValue; // fallback to JSON string from variant-to-string conversion - if Escape=twJSONEscape then - aWriter.Add('"'); - {$ifdef UNICODE} - aWriter.AddW(pointer(temp),length(temp),Escape); - {$else} - aWriter.AddAnsiString(temp,Escape); - {$endif} - if Escape=twJSONEscape then - aWriter.Add('"'); - end; -end; - -procedure TJSONCustomParsers.RegisterCallbacksVariant(aClass: TCustomVariantType; - aReader: TDynArrayJSONCustomReader; aWriter: TDynArrayJSONCustomWriter); -var ndx: PtrInt; -begin - if self=nil then - self := TJSONCustomParsers.Create; - ndx := VariantSearch(aClass); - if ndx<0 then begin - ndx := length(fVariants); - SetLength(fVariants,ndx+1); - fVariants[ndx].TypeClass := aClass; - end; - fVariants[ndx].Writer := aWriter; - fVariants[ndx].Reader := aReader; -end; -{$endif} - -procedure TJSONCustomParsers.RegisterCallbacks(aTypeInfo: pointer; - aReader: TDynArrayJSONCustomReader; aWriter: TDynArrayJSONCustomWriter); -var Reg: TJSONCustomParserRegistration; - ForAdding: boolean; - ndx: integer; -begin - if self=nil then - self := TJSONCustomParsers.Create; - ForAdding := Assigned(aReader) or Assigned(aWriter); - ndx := Search(aTypeInfo,Reg,ForAdding); - if ForAdding then begin - Reg.Writer := aWriter; - Reg.Reader := aReader; - fParser[ndx] := Reg; - end else - if ndx>=0 then begin - fParsers.Delete(ndx); - fParsers.ReHash; - end; -end; - -function TJSONCustomParsers.RegisterFromText(aTypeInfo: pointer; - const aRTTIDefinition: RawUTF8): TJSONRecordAbstract; -var Reg: TJSONCustomParserRegistration; - ForAdding: boolean; - ndx: integer; -begin - if self=nil then - self := TJSONCustomParsers.Create; - ForAdding := aRTTIDefinition<>''; - ndx := Search(aTypeInfo,Reg,ForAdding); - if ForAdding then begin - result := TJSONRecordTextDefinition.FromCache(Reg.RecordTypeInfo,aRTTIDefinition); - Reg.RecordTextDefinition := aRTTIDefinition; - Reg.Reader := result.CustomReader; - Reg.Writer := result.CustomWriter; - Reg.RecordCustomParser := result; - fParser[ndx] := Reg; - end else begin - result := nil; - if ndx>=0 then begin - fParsers.Delete(ndx); - fParsers.ReHash; - end; - end; -end; - -function ManagedTypeSaveRTTIHash(info: PTypeInfo; var crc: cardinal): integer; -var itemtype: PTypeInfo; - i, unmanagedsize: integer; - field: PFieldInfo; - dynarray: TDynArray; -begin // info is expected to come from a DeRef() if retrieved from RTTI - result := 0; - if info=nil then - exit; - {$ifdef FPC} // storage binary layout as Delphi's ordinal value - crc := crc32c(crc,@FPCTODELPHI[info^.Kind],1); - {$else} - crc := crc32c(crc,@info^.Kind,1); // hash RTTI kind, but not name - {$endif} - case info^.Kind of // handle nested RTTI - tkLString,{$ifdef FPC}tkLStringOld,{$endif}{$ifdef HASVARUSTRING}tkUString,{$endif} - tkWString,tkInterface: - result := SizeOf(pointer); - {$ifndef NOVARIANTS} - tkVariant: - result := SizeOf(variant); - {$endif} - tkRecord{$ifdef FPC},tkObject{$endif}: // first search from custom RTTI text - if not GlobalJSONCustomParsers.RecordRTTITextHash(info,crc,result) then begin - itemtype := GetTypeInfo(info,tkRecordKinds); - if itemtype<>nil then begin - unmanagedsize := itemtype^.recsize; - for i := 1 to GetManagedFields(itemtype,field) do begin - info := DeRef(field^.TypeInfo); - {$ifdef FPC_OLDRTTI} // old FPC did include RTTI for unmanaged fields - if info^.Kind in tkManagedTypes then // as with Delphi - {$endif} - dec(unmanagedsize,ManagedTypeSaveRTTIHash(info,crc)); - inc(field); - end; - crc := crc32c(crc,@unmanagedsize,4); - result := itemtype^.recSize; - end; - end; - tkArray: begin - itemtype := ArrayItemType(info,result); - if info=nil then - exit; - unmanagedsize := result; - if itemtype<>nil then - for i := 1 to info^.elCount do - dec(unmanagedsize,ManagedTypeSaveRTTIHash(itemtype,crc)); - crc := crc32c(crc,@unmanagedsize,4); - end; - tkDynArray: begin - dynarray.Init(info,field); // fake void array pointer - crc := dynarray.SaveToTypeInfoHash(crc); - result := SizeOf(pointer); - end; - end; -end; - -function TypeInfoToHash(aTypeInfo: pointer): cardinal; -begin - result := 0; - ManagedTypeSaveRTTIHash(aTypeInfo,result); -end; - -function RecordSaveJSON(const Rec; TypeInfo: pointer; EnumSetsAsText: boolean): RawUTF8; -begin - result := SaveJSON(Rec,TypeInfo,EnumSetsAsText); -end; - -const - NULCHAR: AnsiChar = #0; - -function RecordLoadJSON(var Rec; JSON: PUTF8Char; TypeInfo: pointer; EndOfObject: PUTF8Char - {$ifndef NOVARIANTS}; CustomVariantOptions: PDocVariantOptions{$endif}): PUTF8Char; -var wasString, wasValid: boolean; - Reader: TDynArrayJSONCustomReader; - FirstChar,EndOfObj: AnsiChar; - Val: PUTF8Char; - ValLen: integer; -begin // code below must match TTextWriter.AddRecordJSON - result := nil; // indicates error - if JSON=nil then - exit; - if (@Rec=nil) or (TypeInfo=nil) then - raise ESynException.CreateUTF8('Invalid RecordLoadJSON(%) call',[TypeInfo]); - if JSON^=' ' then repeat inc(JSON); if JSON^=#0 then exit; until JSON^<>' '; - if PCardinal(JSON)^=JSON_BASE64_MAGIC_QUOTE then begin - if not (PTypeKind(TypeInfo)^ in tkRecordTypes) then - raise ESynException.CreateUTF8('RecordLoadJSON(%/%)', - [PShortString(@PTypeInfo(TypeInfo).NameLen)^,ToText(PTypeKind(TypeInfo)^)^]); - Val := GetJSONField(JSON,JSON,@wasString,@EndOfObj,@ValLen); - if (Val=nil) or not wasString or (ValLen<3) or - (PInteger(Val)^ and $00ffffff<>JSON_BASE64_MAGIC) or - not RecordLoad(Rec,Base64ToBin(PAnsiChar(Val)+3,ValLen-3),TypeInfo) then - exit; // invalid content - end else begin - if not GlobalJSONCustomParsers.RecordSearch(TypeInfo,Reader) then - exit; - FirstChar := JSON^; - JSON := Reader(JSON,Rec,wasValid{$ifndef NOVARIANTS},CustomVariantOptions{$endif}); - if not wasValid then - exit; - if JSON<>nil then - JSON := GotoNextNotSpace(JSON); - if (JSON<>nil) and (JSON^<>#0) then - if FirstChar='"' then // special case e.g. for TGUID string - EndOfObj := FirstChar else begin - EndOfObj := JSON^; - inc(JSON); - end else - EndOfObj := #0; - end; - if JSON=nil then // end reached, but valid content decoded - result := @NULCHAR else - result := JSON; - if EndOfObject<>nil then - EndOfObject^ := EndOfObj; -end; - -function RecordLoadJSON(var Rec; const JSON: RawUTF8; TypeInfo: pointer{$ifndef NOVARIANTS}; - CustomVariantOptions: PDocVariantOptions{$endif}): boolean; -var tmp: TSynTempBuffer; -begin - tmp.Init(JSON); // make private copy before in-place decoding - try - result := RecordLoadJSON(Rec,tmp.buf,TypeInfo,nil - {$ifndef NOVARIANTS},CustomVariantOptions{$endif})<>nil; - finally - tmp.Done; - end; -end; - - -{ TJSONCustomParserCustom } - -constructor TJSONCustomParserCustom.Create(const aPropertyName, aCustomTypeName: RawUTF8); -begin - inherited Create(aPropertyName,ptCustom); - fCustomTypeName := aCustomTypeName; -end; - -procedure TJSONCustomParserCustom.FinalizeItem(Data: Pointer); -begin // nothing to be done by default -end; - - -{ TJSONCustomParserCustomSimple } - -constructor TJSONCustomParserCustomSimple.Create( - const aPropertyName, aCustomTypeName: RawUTF8; aCustomType: pointer); -var info: PTypeInfo; - kind: TTypeKind; -begin - inherited Create(aPropertyName,aCustomTypeName); - fCustomTypeInfo := aCustomType; - if IdemPropNameU(aCustomTypeName,'TGUID') then begin - fKnownType := ktGUID; - fDataSize := SizeOf(TGUID); - end else - if fCustomTypeInfo<>nil then begin - TypeInfoToName(fCustomTypeInfo,fCustomTypeName,aCustomTypeName); - kind := PTypeKind(fCustomTypeInfo)^; - info := GetTypeInfo(fCustomTypeInfo,[tkEnumeration,tkSet,tkArray,tkDynArray]); - fTypeData := info; - if info<>nil then - case kind of - tkEnumeration, tkSet: begin - fDataSize := ORDTYPE_SIZE[info^.EnumType]; - if kind=tkEnumeration then - fKnownType := ktEnumeration else - fKnownType := ktSet; - exit; // success - end; - tkArray: begin - if info^.dimCount<>1 then - raise ESynException.CreateUTF8('%.Create("%") supports only single '+ - 'dimension static array)',[self,fCustomTypeName]); - fKnownType := ktStaticArray; - {$ifdef VER2_6} - fFixedSize := info^.arraySize; // is elSize in fact - fDataSize := fFixedSize*info^.elCount; - {$else} - fDataSize := info^.arraySize; - fFixedSize := fDataSize div info^.elCount; - {$endif} - fNestedArray := TJSONCustomParserRTTI.CreateFromRTTI( - '',Deref(info^.arrayType),fFixedSize); - exit; // success - end; - tkDynArray: begin - fKnownType := ktDynamicArray; - exit; // success - end; - end; - raise ESynException.CreateUTF8('%.Create("%") unsupported type: % (%)', - [self,fCustomTypeName,ToText(kind)^,ord(kind)]); - end; -end; - -constructor TJSONCustomParserCustomSimple.CreateFixedArray( - const aPropertyName: RawUTF8; aFixedSize: cardinal); -begin - inherited Create(aPropertyName,FormatUTF8('Fixed%Byte',[aFixedSize])); - fKnownType := ktFixedArray; - fFixedSize := aFixedSize; - fDataSize := aFixedSize; -end; - -constructor TJSONCustomParserCustomSimple.CreateBinary( - const aPropertyName: RawUTF8; aDataSize, aFixedSize: cardinal); -begin - inherited Create(aPropertyName,FormatUTF8('BinHex%Byte',[aFixedSize])); - fKnownType := ktBinary; - fFixedSize := aFixedSize; - fDataSize := aDataSize; -end; - -destructor TJSONCustomParserCustomSimple.Destroy; -begin - inherited; - fNestedArray.Free; -end; - -procedure TJSONCustomParserCustomSimple.CustomWriter( - const aWriter: TTextWriter; const aValue); -var i: integer; - V: PByte; -begin - case fKnownType of - ktStaticArray: begin - aWriter.Add('['); - V := @aValue; - for i := 1 to PTypeInfo(fTypeData)^.elCount do begin - fNestedArray.WriteOneLevel(aWriter,V,[]); - aWriter.Add(','); - end; - aWriter.CancelLastComma; - aWriter.Add(']'); - end; - ktEnumeration, ktSet: - aWriter.AddTypedJSON(fCustomTypeInfo,aValue); - ktDynamicArray: - raise ESynException.CreateUTF8('%.CustomWriter("%"): unsupported', - [self,fCustomTypeName]); - ktBinary: - if (fFixedSize<=SizeOf(QWord)) and IsZero(@aValue,fFixedSize) then - aWriter.AddShort('""') else // 0 -> "" - aWriter.AddBinToHexDisplayQuoted(@aValue,fFixedSize); - else begin // encoded as JSON strings - aWriter.Add('"'); - case fKnownType of - ktGUID: - aWriter.Add(TGUID(aValue)); - ktFixedArray: - aWriter.AddBinToHex(@aValue,fFixedSize); - end; - aWriter.Add('"'); - end; - end; -end; - -function TJSONCustomParserCustomSimple.CustomReader(P: PUTF8Char; var aValue; - out EndOfObject: AnsiChar{$ifndef NOVARIANTS}; CustomVariantOptions: PDocVariantOptions{$endif}): PUTF8Char; -var PropValue: PUTF8Char; - i, PropValueLen, i32: integer; - u64: QWord; - wasString: boolean; - Val: PByte; -begin - result := nil; // indicates error - case fKnownType of - ktStaticArray: begin - if P^<>'[' then - exit; // we expect a true array here - P := GotoNextNotSpace(P+1); - if JSONArrayCount(P)<>PTypeInfo(fTypeData)^.elCount then - exit; // invalid number of items - Val := @aValue; - for i := 1 to PTypeInfo(fTypeData)^.elCount do - if not fNestedArray.ReadOneLevel( - P,Val,[]{$ifndef NOVARIANTS},CustomVariantOptions{$endif}) then - exit else - if P=nil then - exit; - P := GotoNextNotSpace(P); - EndOfObject := P^; - if P^ in [',','}'] then - inc(P); - result := P; - end; - ktDynamicArray: - raise ESynException.CreateUTF8('%.CustomReader("%"): unsupported', - [self,fCustomTypeName]); - ktSet: begin - i32 := GetSetNameValue(fCustomTypeInfo,P,EndOfObject); - MoveSmall(@i32,@aValue,fDataSize); - result := P; - end; - else begin // encoded as JSON strings or number - PropValue := GetJSONField(P,P,@wasString,@EndOfObject,@PropValueLen); - if PropValue=nil then - exit; // not a JSON string or number - if P=nil then // result=nil=error + caller may dec(P); P^:=EndOfObject; - P := PropValue+PropValueLen; - case fKnownType of - ktGUID: - if wasString and (TextToGUID(PropValue,@aValue)<>nil) then - result := P; - ktEnumeration: begin - if wasString then - i32 := GetEnumNameValue(fCustomTypeInfo,PropValue,PropValueLen,true) else - i32 := GetCardinal(PropValue); - if i32<0 then - exit; - MoveSmall(@i32,@aValue,fDataSize); - result := P; - end; - ktFixedArray: - if wasString and (PropValueLen=fFixedSize*2) and - SynCommons.HexToBin(PAnsiChar(PropValue),@aValue,fFixedSize) then - result := P; - ktBinary: - if wasString then begin // default hexa serialization - FillCharFast(aValue,fDataSize,0); - if (PropValueLen=0) or ((PropValueLen=fFixedSize*2) and - HexDisplayToBin(PAnsiChar(PropValue),@aValue,fFixedSize)) then - result := P; - end else - if fFixedSize<=SizeOf(u64) then begin // allow integer serialization - SetQWord(PropValue,u64); - MoveSmall(@u64,@aValue,fDataSize); - result := P; - end; - end; - end; - end; -end; - - -{ TJSONCustomParserCustomRecord } - -constructor TJSONCustomParserCustomRecord.Create( - const aPropertyName: RawUTF8; aCustomTypeIndex: integer); -begin - fCustomTypeIndex := aCustomTypeIndex; - with GlobalJSONCustomParsers.fParser[fCustomTypeIndex] do begin - inherited Create(aPropertyName,RecordTypeName); - fCustomTypeInfo := RecordTypeInfo; - fCustomTypeName := RecordTypeName; - end; - fDataSize := RecordTypeInfoSize(fCustomTypeInfo); -end; - -function TJSONCustomParserCustomRecord.GetJSONCustomParserRegistration: pointer; -begin - result := nil; - if GlobalJSONCustomParsers<>nil then begin - if (Cardinal(fCustomTypeIndex)>=Cardinal(GlobalJSONCustomParsers.fParsersCount)) or - not IdemPropNameU(fCustomTypeName, - GlobalJSONCustomParsers.fParser[fCustomTypeIndex].RecordTypeName) then - fCustomTypeIndex := GlobalJSONCustomParsers.RecordSearch(fCustomTypeInfo); - if fCustomTypeIndex>=0 then - result := @GlobalJSONCustomParsers.fParser[fCustomTypeIndex]; - end; - if result=nil then - raise ESynException.CreateUTF8( - '%: [%] type should not have been un-registered',[self,fCustomTypeName]); -end; - -procedure TJSONCustomParserCustomRecord.CustomWriter( - const aWriter: TTextWriter; const aValue); -var parser: PJSONCustomParserRegistration; -begin - parser := GetJSONCustomParserRegistration; - parser^.Writer(aWriter,aValue); -end; - -function TJSONCustomParserCustomRecord.CustomReader(P: PUTF8Char; var aValue; - out EndOfObject: AnsiChar{$ifndef NOVARIANTS}; CustomVariantOptions: PDocVariantOptions{$endif}): PUTF8Char; -var valid: boolean; - callback: PJSONCustomParserRegistration; // D5/D6 Internal error: C3890 -begin - callback := GetJSONCustomParserRegistration; - result := callback^.Reader(P,aValue,valid{$ifndef NOVARIANTS},CustomVariantOptions{$endif}); - if not valid then - result := nil; - if result=nil then - exit; - EndOfObject := result^; - if result^ in [',','}',']'] then - inc(result); -end; - -procedure TJSONCustomParserCustomRecord.FinalizeItem(Data: Pointer); -begin - RecordClear(Data^,fCustomTypeInfo); -end; - - -{ TJSONCustomParserRTTI } - -type - TJSONSerializerFromTextSimple = record - TypeInfo: pointer; - BinaryDataSize, BinaryFieldSize: integer; - end; - TJSONSerializerFromTextSimpleDynArray = array of TJSONSerializerFromTextSimple; -var // RawUTF8/TJSONSerializerFromTextSimpleDynArray - GlobalCustomJSONSerializerFromTextSimpleType: TSynDictionary; - -procedure JSONSerializerFromTextSimpleTypeAdd(aTypeName: RawUTF8; - aTypeInfo: pointer; aDataSize, aFieldSize: integer); -var simple: TJSONSerializerFromTextSimple; -begin - if aTypeName='' then - TypeInfoToName(aTypeInfo,aTypeName); - if aDataSize<>0 then - if aFieldSize>aDataSize then - raise ESynException.CreateUTF8('JSONSerializerFromTextSimpleTypeAdd(%) fieldsize=%>%', - [aTypeName,aFieldSize,aDataSize]) else - if aFieldSize=0 then - aFieldSize := aDataSize; // not truncated - simple.TypeInfo := aTypeInfo; - simple.BinaryDataSize := aDataSize; - simple.BinaryFieldSize := aFieldSize; - UpperCaseSelf(aTypeName); - if GlobalCustomJSONSerializerFromTextSimpleType.Add(aTypeName,simple)<0 then - raise ESynException.CreateUTF8('JSONSerializerFromTextSimpleTypeAdd(%) duplicated', [aTypeName]); -end; - -/// if defined, will try to mimic the default record alignment -// -> is buggy, and compiler revision specific -> we would rather use packed records -{.$define ALIGNCUSTOMREC} - -constructor TJSONCustomParserRTTI.Create(const aPropertyName: RawUTF8; - aPropertyType: TJSONCustomParserRTTIType); -begin - fPropertyName := aPropertyName; - fPropertyType := aPropertyType; -end; - -class function TJSONCustomParserRTTI.TypeNameToSimpleRTTIType(TypeName: PUTF8Char; - TypeNameLen: PtrInt; ItemTypeName: PRawUTF8): TJSONCustomParserRTTIType; -const - SORTEDMAX = {$ifdef NOVARIANTS}32{$else}33{$endif}{$ifdef HASVARUSTRING}+1{$endif}; - SORTEDNAMES: array[0..SORTEDMAX] of PUTF8Char = - ('ARRAY','BOOLEAN','BYTE','CARDINAL','CURRENCY', - 'DOUBLE','EXTENDED','INT64','INTEGER','PTRINT','PTRUINT','QWORD', - 'RAWBYTESTRING','RAWJSON','RAWUTF8','RECORD','SINGLE', - 'STRING','SYNUNICODE','TCREATETIME','TDATETIME','TDATETIMEMS','TGUID', - 'TID','TMODTIME','TRECORDREFERENCE','TRECORDREFERENCETOBEDELETED', - 'TRECORDVERSION','TSQLRAWBLOB','TTIMELOG',{$ifdef HASVARUSTRING}'UNICODESTRING',{$endif} - 'UTF8STRING',{$ifndef NOVARIANTS}'VARIANT',{$endif} - 'WIDESTRING','WORD'); - // warning: recognized types should match at binary storage level! - SORTEDTYPES: array[0..SORTEDMAX] of TJSONCustomParserRTTIType = - (ptArray,ptBoolean,ptByte,ptCardinal,ptCurrency, - ptDouble,ptExtended,ptInt64,ptInteger,ptPtrInt,ptPtrUInt,ptQWord, - ptRawByteString,ptRawJSON,ptRawUTF8,ptRecord,ptSingle, - ptString,ptSynUnicode,ptTimeLog,ptDateTime,ptDateTimeMS,ptGUID, - ptID,ptTimeLog,ptInt64,ptInt64,ptInt64,ptRawByteString,ptTimeLog, - {$ifdef HASVARUSTRING}ptUnicodeString,{$endif}ptRawUTF8, - {$ifndef NOVARIANTS}ptVariant,{$endif} - ptWideString,ptWord); -var ndx: integer; - up: PUTF8Char; - tmp: array[byte] of AnsiChar; // avoid unneeded memory allocation -begin - if ItemTypeName<>nil then begin - UpperCaseCopy(TypeName,TypeNameLen,ItemTypeName^); - up := pointer(ItemTypeName^); - end else begin - UpperCopy255Buf(@tmp,TypeName,TypeNameLen)^ := #0; - up := @tmp; - end; -//for ndx := 1 to SORTEDMAX do assert(StrComp(SORTEDNAMES[ndx],SORTEDNAMES[ndx-1])>0,SORTEDNAMES[ndx]); - ndx := FastFindPUTF8CharSorted(@SORTEDNAMES,SORTEDMAX,up); - if ndx>=0 then - result := SORTEDTYPES[ndx] else - result := ptCustom; -end; - -class function TJSONCustomParserRTTI.TypeNameToSimpleRTTIType( - const TypeName: RawUTF8): TJSONCustomParserRTTIType; -begin - if TypeName='' then - result := ptCustom else - result := TypeNameToSimpleRTTIType(Pointer(TypeName),length(TypeName),nil); -end; - -class function TJSONCustomParserRTTI.TypeNameToSimpleRTTIType( - TypeName: PShortString): TJSONCustomParserRTTIType; -begin - if TypeName=nil then - result := ptCustom else - result := TypeNameToSimpleRTTIType(@TypeName^[1],ord(TypeName^[0]),nil); -end; - -class function TJSONCustomParserRTTI.TypeInfoToSimpleRTTIType(Info: pointer): TJSONCustomParserRTTIType; -begin - result := ptCustom; // e.g. for tkRecord - if Info=nil then - exit; - case PTypeKind(Info)^ of // FPC and Delphi will use a fast jmp table - tkLString{$ifdef FPC},tkLStringOld{$endif}: result := ptRawUTF8; - tkWString: result := ptWideString; - {$ifdef HASVARUSTRING}tkUString: result := ptUnicodeString;{$endif} - {$ifdef FPC_OR_UNICODE} - tkClassRef,tkPointer{$ifdef UNICODE},tkProcedure{$endif}: result := ptPtrInt; - {$endif} - {$ifndef NOVARIANTS} - tkVariant: result := ptVariant; - {$endif} - tkDynArray: result := ptArray; - tkChar: result := ptByte; - tkWChar: result := ptWord; - tkClass, tkMethod, tkInterface: result := ptPtrInt; - tkInteger: - case GetTypeInfo(Info)^.IntegerType of - otSByte,otUByte: result := ptByte; - otSWord,otUWord: result := ptWord; - otSLong: result := ptInteger; - otULong: result := ptCardinal; - {$ifdef FPC_NEWRTTI} - otSQWord: result := ptInt64; - otUQWord: result := ptQWord; - {$endif} - end; - tkInt64: - {$ifndef FPC} if Info=TypeInfo(QWord) then result := ptQWord else - {$ifdef UNICODE}with GetTypeInfo(Info)^ do // detect QWord/UInt64 - if MinInt64Value>MaxInt64Value then result := ptQWord else{$endif}{$endif} - result := ptInt64; - {$ifdef FPC} - tkQWord: result := ptQWord; - tkBool: result := ptBoolean; - {$else} - tkEnumeration: // other enumerates (or tkSet) use TJSONCustomParserCustomSimple - if Info=TypeInfo(boolean) then - result := ptBoolean; - {$endif} - tkFloat: - case GetTypeInfo(Info)^.FloatType of - ftSingle: result := ptSingle; - ftDoub: result := ptDouble; - ftCurr: result := ptCurrency; - ftExtended: result := ptExtended; - // ftComp: not implemented yet - end; - end; -end; - -function TypeInfoToRttiType(aTypeInfo: pointer): TJSONCustomParserRTTIType; -begin // first by known name, then from RTTI - result := TJSONCustomParserRTTI.TypeNameToSimpleRTTIType( - PUTF8Char(@PTypeInfo(aTypeInfo)^.NameLen)+1,PTypeInfo(aTypeInfo)^.NameLen,nil); - if result=ptCustom then - result := TJSONCustomParserRTTI.TypeInfoToSimpleRTTIType(aTypeInfo); -end; - -class function TJSONCustomParserRTTI.TypeNameToSimpleBinary(const aTypeName: RawUTF8; - out aDataSize, aFieldSize: integer): boolean; -var simple: ^TJSONSerializerFromTextSimple; -begin - simple := GlobalCustomJSONSerializerFromTextSimpleType.FindValue(aTypeName); - if (simple<>nil) and (simple^.BinaryFieldSize<>0) then begin - aDataSize := simple^.BinaryDataSize; - aFieldSize := simple^.BinaryFieldSize; - result := true; - end else - result := false; -end; - -class function TJSONCustomParserRTTI.CreateFromRTTI( - const PropertyName: RawUTF8; Info: pointer; ItemSize: integer): TJSONCustomParserRTTI; -var Item: PTypeInfo absolute Info; - ItemType: TJSONCustomParserRTTIType; - ItemTypeName: RawUTF8; - ndx: integer; -begin - if Item=nil then // no RTTI -> stored as hexa string - result := TJSONCustomParserCustomSimple.CreateFixedArray(PropertyName,ItemSize) else begin - ItemType := TypeNameToSimpleRTTIType(PUTF8Char(@Item.NameLen)+1,Item.NameLen,@ItemTypeName); - if ItemType=ptCustom then - ItemType := TypeInfoToSimpleRTTIType(Info); - if ItemType=ptCustom then - if Item^.kind in [tkEnumeration,tkArray,tkDynArray,tkSet] then - result := TJSONCustomParserCustomSimple.Create( - PropertyName,ItemTypeName,Item) else begin - ndx := GlobalJSONCustomParsers.RecordSearch(Item); - if ndx<0 then - ndx := GlobalJSONCustomParsers.RecordSearch(ItemTypeName); - if ndx<0 then - raise ESynException.CreateUTF8('%.CreateFromRTTI("%") unsupported %', - [self,ItemTypeName,ToText(Item^.kind)^]); - result := TJSONCustomParserCustomRecord.Create(PropertyName,ndx); - end else - result := TJSONCustomParserRTTI.Create(PropertyName,ItemType); - end; - if ItemSize<>0 then - result.fDataSize := ItemSize; -end; - -class function TJSONCustomParserRTTI.CreateFromTypeName( - const aPropertyName, aCustomRecordTypeName: RawUTF8): TJSONCustomParserRTTI; -var ndx: integer; - simple: ^TJSONSerializerFromTextSimple; -begin - simple := GlobalCustomJSONSerializerFromTextSimpleType.FindValue(aCustomRecordTypeName); - if simple<>nil then - if simple^.BinaryFieldSize<>0 then - result := TJSONCustomParserCustomSimple.CreateBinary( - aPropertyName,simple^.BinaryDataSize,simple^.BinaryFieldSize) else - result := TJSONCustomParserCustomSimple.Create( - aPropertyName,aCustomRecordTypeName,simple^.TypeInfo) else begin - ndx := GlobalJSONCustomParsers.RecordSearch(aCustomRecordTypeName); - if ndx<0 then - result := nil else - result := TJSONCustomParserCustomRecord.Create(aPropertyName,ndx); - end; -end; - -procedure TJSONCustomParserRTTI.ComputeFullPropertyName; -var i: PtrInt; -begin - for i := 0 to length(NestedProperty)-1 do begin - NestedProperty[i].ComputeFullPropertyName; - if fFullPropertyName<>'' then - NestedProperty[i].fFullPropertyName := - fFullPropertyName+'.'+NestedProperty[i].fPropertyName; - end; -end; - -procedure TJSONCustomParserRTTI.ComputeNestedDataSize; -var i: PtrInt; -begin - assert(fNestedDataSize=0); - fNestedDataSize := 0; - for i := 0 to length(NestedProperty)-1 do begin - NestedProperty[i].ComputeDataSizeAfterAdd; - inc(fNestedDataSize,NestedProperty[i].fDataSize); - if fFullPropertyName<>'' then - NestedProperty[i].fFullPropertyName := - fFullPropertyName+'.'+NestedProperty[i].fPropertyName; - end; -end; - -procedure TJSONCustomParserRTTI.ComputeDataSizeAfterAdd; -const // binary size (in bytes) of each kind of property - 0 for ptRecord/ptCustom - JSONRTTI_SIZE: array[TJSONCustomParserRTTIType] of byte = ( - SizeOf(PtrUInt),SizeOf(Boolean),SizeOf(Byte),SizeOf(Cardinal),SizeOf(Currency), - SizeOf(Double),SizeOf(Extended),SizeOf(Int64),SizeOf(Integer),SizeOf(QWord), - SizeOf(RawByteString),SizeOf(RawJSON),SizeOf(RawUTF8),0,SizeOf(Single), - SizeOf(String),SizeOf(SynUnicode),SizeOf(TDateTime),SizeOf(TDateTimeMS), - SizeOf(TGUID),SizeOf(Int64),SizeOf(TTimeLog), - {$ifdef HASVARUSTRING}SizeOf(UnicodeString),{$endif} - {$ifndef NOVARIANTS}SizeOf(Variant),{$endif} - SizeOf(WideString),SizeOf(Word),0); -var i: PtrInt; -begin - if fFullPropertyName='' then begin - fFullPropertyName := fPropertyName; - ComputeFullPropertyName; - end; - if fDataSize=0 then begin - ComputeNestedDataSize; - case PropertyType of - ptRecord: - for i := 0 to length(NestedProperty)-1 do - inc(fDataSize,NestedProperty[i].fDataSize); - //ptCustom: fDataSize already set in TJSONCustomParserCustom.Create() - else - fDataSize := JSONRTTI_SIZE[PropertyType]; - end; - {$ifdef ALIGNCUSTOMREC} - inc(fDataSize,fDataSize and 7); - {$endif} - end; -end; - -procedure TJSONCustomParserRTTI.FinalizeNestedRecord(var Data: PByte); -var j: PtrInt; -begin - for j := 0 to length(NestedProperty)-1 do begin - case NestedProperty[j].PropertyType of - ptRawByteString, - ptRawJSON, - ptRawUTF8: {$ifdef FPC}Finalize(PRawByteString(Data)^){$else}PRawByteString(Data)^ := ''{$endif}; - ptString: PString(Data)^ := ''; - ptSynUnicode: PSynUnicode(Data)^ := ''; - {$ifdef HASVARUSTRING} - ptUnicodeString: PUnicodeString(Data)^ := ''; - {$endif} - ptWideString: PWideString(Data)^ := ''; - ptArray: NestedProperty[j].FinalizeNestedArray(PPtrUInt(Data)^); - {$ifndef NOVARIANTS} - ptVariant: VarClear(PVariant(Data)^); - {$endif} - ptRecord: begin - NestedProperty[j].FinalizeNestedRecord(Data); - continue; - end; - ptCustom: - TJSONCustomParserCustom(NestedProperty[j]).FinalizeItem(Data); - end; - inc(Data,NestedProperty[j].fDataSize); - end; -end; - -procedure TJSONCustomParserRTTI.FinalizeNestedArray(var Data: PtrUInt); -var i: integer; - p: PDynArrayRec; - ItemData: PByte; -begin - if Data=0 then - exit; - ItemData := pointer(Data); - p := pointer(Data); - dec(p); - Data := 0; - if (p^.refCnt>=0) and DACntDecFree(p^.refCnt) then begin - for i := 1 to p^.length do - FinalizeNestedRecord(ItemData); - FreeMem(p); - end; -end; - -procedure TJSONCustomParserRTTI.AllocateNestedArray(var Data: PtrUInt; - NewLength: integer); -begin - FinalizeNestedArray(Data); - if NewLength<=0 then - exit; - pointer(Data) := AllocMem(SizeOf(TDynArrayRec)+fNestedDataSize*NewLength); - PDynArrayRec(Data)^.refCnt := 1; - PDynArrayRec(Data)^.length := NewLength; - inc(Data,SizeOf(TDynArrayRec)); -end; - -procedure TJSONCustomParserRTTI.ReAllocateNestedArray(var Data: PtrUInt; - NewLength: integer); -var OldLength: integer; - p: PDynArrayRec; -begin - p := pointer(Data); - if p=nil then - raise ESynException.CreateUTF8('%.ReAllocateNestedArray(nil)',[self]); - dec(p); - ReAllocMem(p,SizeOf(p^)+fNestedDataSize*NewLength); - OldLength := p^.length; - if NewLength>OldLength then - FillCharFast(PByteArray(p)[SizeOf(p^)+fNestedDataSize*OldLength], - fNestedDataSize*(NewLength-OldLength),0); - p^.length := NewLength; - inc(p); - Data := PtrUInt(p); -end; - -function TJSONCustomParserRTTI.ReadOneLevel(var P: PUTF8Char; var Data: PByte; - Options: TJSONCustomParserSerializationOptions{$ifndef NOVARIANTS}; - CustomVariantOptions: PDocVariantOptions{$endif}): boolean; -var EndOfObject: AnsiChar; - function ProcessValue(const Prop: TJSONCustomParserRTTI; var P: PUTF8Char; - var Data: PByte): boolean; - var DynArray: PByte; - ArrayLen, ArrayCapacity, n, PropValueLen: integer; - wasString: boolean; - PropValue, ptr: PUTF8Char; - label Error; - begin - result := false; - P := GotoNextNotSpace(P); - case Prop.PropertyType of - ptRecord: begin - if not Prop.ReadOneLevel( - P,Data,Options{$ifndef NOVARIANTS},CustomVariantOptions{$endif}) then - exit; - EndOfObject := P^; - if P^ in [',','}'] then - inc(P); - result := true; - exit; - end; - ptArray: - if (PInteger(P)^=NULL_LOW) and (jcEndOfJSONValueField in JSON_CHARS[P[4]]) then begin - P := GotoNextNotSpace(P+4); - EndOfObject := P^; - if P^<>#0 then //if P^=',' then - inc(P); - Prop.FinalizeNestedArray(PPtrUInt(Data)^); // null -> void array - end else begin - if P^<>'[' then - exit; // we expect a true array here - repeat inc(P) until P^<>' '; - // try to allocate nested array at once (if not too slow) - ArrayLen := JSONArrayCount(P,P+131072); // parse up to 128 KB here - if ArrayLen<0 then // mostly JSONArrayCount()=nil due to PMax - ArrayCapacity := 512 else - ArrayCapacity := ArrayLen; - Prop.AllocateNestedArray(PPtrUInt(Data)^,ArrayCapacity); - // read array content - if ArrayLen=0 then begin - if not NextNotSpaceCharIs(P,']') then - exit; - end else begin - n := 0; - DynArray := PPointer(Data)^; - repeat - inc(n); - if (ArrayLen<0) and (n>ArrayCapacity) then begin - ArrayCapacity := NextGrow(ArrayCapacity); - Prop.ReAllocateNestedArray(PPtrUInt(Data)^,ArrayCapacity); - DynArray := PPointer(Data)^; - inc(DynArray,pred(n)*Prop.fNestedDataSize); - end; - if Prop.NestedProperty[0].PropertyName='' then begin - // array of simple type - ptr := P; - if not ProcessValue(Prop.NestedProperty[0],ptr,DynArray) or (ptr=nil) then - goto Error; - P := ptr; - end else begin - // array of record - ptr := P; - if not Prop.ReadOneLevel(ptr,DynArray,Options{$ifndef NOVARIANTS}, - CustomVariantOptions{$endif}) or (ptr=nil) then - goto Error; - P := GotoNextNotSpace(ptr); - EndOfObject := P^; - if not(P^ in [',',']']) then - goto Error; - inc(P); - end; - case EndOfObject of - ',': continue; - ']': begin - if ArrayLen<0 then - Prop.ReAllocateNestedArray(PPtrUInt(Data)^,n) else - if n<>ArrayLen then - goto Error; - break; // we reached end of array - end; - else begin -Error: Prop.FinalizeNestedArray(PPtrUInt(Data)^); - exit; - end; - end; - until false; - end; - if P=nil then - exit; - P := GotoNextNotSpace(P); - EndOfObject := P^; - if P^<>#0 then //if P^=',' then - inc(P); - end; - ptCustom: begin - ptr := TJSONCustomParserCustom(Prop).CustomReader(P,Data^,EndOfObject - {$ifndef NOVARIANTS},CustomVariantOptions{$endif}); - if ptr=nil then - exit; - P := ptr; - end; - {$ifndef NOVARIANTS} - ptVariant: - P := VariantLoadJSON(PVariant(Data)^,P,@EndOfObject, - @JSON_OPTIONS[soCustomVariantCopiedByReference in Options]); - {$endif} - ptRawByteString: begin - PropValue := GetJSONField(P,ptr,@wasString,@EndOfObject,@PropValueLen); - if PropValue=nil then // null -> Blob='' - PRawByteString(Data)^ := '' else - if not Base64MagicCheckAndDecode(PropValue,PropValueLen,PRawByteString(Data)^) then - exit; - P := ptr; - end; - ptRawJSON: - GetJSONItemAsRawJSON(P,PRawJSON(Data)^,@EndOfObject); - else begin - PropValue := GetJSONField(P,ptr,@wasString,@EndOfObject,@PropValueLen); - if (PropValue<>nil) and // PropValue=nil for null - (wasString<>(Prop.PropertyType in [ptRawUTF8,ptString,ptSynUnicode, - {$ifdef HASVARUSTRING}ptUnicodeString,{$endif} - ptDateTime,ptDateTimeMS,ptGUID,ptWideString])) then - exit; - P := ptr; - case Prop.PropertyType of - ptBoolean: PBoolean(Data)^ := GetBoolean(PropValue); - ptByte: PByte(Data)^ := GetCardinal(PropValue); - ptCardinal: PCardinal(Data)^ := GetCardinal(PropValue); - ptCurrency: PInt64(Data)^ := StrToCurr64(PropValue); - ptDouble: unaligned(PDouble(Data)^) := GetExtended(PropValue); - ptExtended: PExtended(Data)^ := GetExtended(PropValue); - ptInt64,ptID,ptTimeLog: SetInt64(PropValue,PInt64(Data)^); - ptQWord: SetQWord(PropValue,PQWord(Data)^); - ptInteger: PInteger(Data)^ := GetInteger(PropValue); - ptSingle: PSingle(Data)^ := GetExtended(PropValue); - ptRawUTF8: FastSetString(PRawUTF8(Data)^,PropValue,PropValueLen); - ptString: UTF8DecodeToString(PropValue,PropValueLen,PString(Data)^); - ptSynUnicode:UTF8ToSynUnicode(PropValue,PropValueLen,PSynUnicode(Data)^); - {$ifdef HASVARUSTRING} - ptUnicodeString:UTF8DecodeToUnicodeString(PropValue,PropValueLen,PUnicodeString(Data)^); - {$endif} - ptDateTime, ptDateTimeMS: Iso8601ToDateTimePUTF8CharVar( - PropValue,PropValueLen,PDateTime(Data)^); - ptWideString:UTF8ToWideString(PropValue,PropValueLen,PWideString(Data)^); - ptWord: PWord(Data)^ := GetCardinal(PropValue); - ptGUID: TextToGUID(PropValue,pointer(Data)); - end; - end; - end; - inc(Data,Prop.fDataSize); - result := true; - end; -var i,j: integer; - PropName: shortstring; - ptr: PUTF8Char; - Values: array of PUTF8Char; -begin - result := false; - if P=nil then - exit; - P := GotoNextNotSpace(P); - if (PInteger(P)^=NULL_LOW) and (jcEndOfJSONValueField in JSON_CHARS[P[4]]) then begin - P := GotoNextNotSpace(P+4); // a record stored as null - inc(Data,fDataSize); - result := true; - exit; - end; - EndOfObject := #0; - if not (PropertyType in [ptRecord,ptArray]) then begin - ptr := P; - result := ProcessValue(Self,P,Data); - exit; - end; - if P^<>'{' then - exit; // we expect a true object here - repeat inc(P) until (P^>' ') or (P^=#0); - if P^='}' then begin - inc(Data,fDataSize); - EndOfObject := '}'; - inc(P); - end else - for i := 0 to length(NestedProperty)-1 do begin - ptr := P; - GetJSONPropName(ptr,PropName); - if PropName='' then - exit; // invalid JSON content - P := ptr; - if IdemPropNameU(NestedProperty[i].PropertyName,@PropName[1],ord(PropName[0])) then begin - // O(1) optimistic search - if not ProcessValue(NestedProperty[i],P,Data) then - exit; - if EndOfObject='}' then begin // ignore missing properties - for j := i+1 to length(NestedProperty)-1 do - inc(Data,NestedProperty[j].fDataSize); - break; - end; - end else begin - SetLength(Values,length(NestedProperty)); // pessimistic check through all properties - repeat - for j := i to length(NestedProperty)-1 do - if (Values[j]=nil) and - IdemPropNameU(NestedProperty[j].PropertyName,@PropName[1],ord(PropName[0])) then begin - Values[j] := P; - PropName := ''; - break; - end; - if (PropName<>'') and not(soReadIgnoreUnknownFields in Options) then - exit; // unexpected property - ptr := GotoNextJSONItem(P,1,@EndOfObject); - if ptr=nil then - exit; - P := ptr; - if EndOfObject='}' then - break; - GetJSONPropName(ptr,PropName); // next name - if PropName='' then - exit; // invalid JSON content - P := ptr; - until false; - for j := i to length(NestedProperty)-1 do - if Values[j]=nil then // ignore missing properties - inc(Data,NestedProperty[j].fDataSize) else - if not ProcessValue(NestedProperty[j],Values[j],Data) then - exit; - EndOfObject := '}'; // ProcessValue() did update EndOfObject - break; - end; - end; - if (P<>nil) and (EndOfObject=',') and (soReadIgnoreUnknownFields in Options) then begin - ptr := GotoNextJSONObjectOrArray(P,'}'); - if ptr=nil then - exit; - P := ptr; - end else - if EndOfObject<>'}' then - exit; - if P<>nil then - P := GotoNextNotSpace(P); - result := true; -end; - -function Plural(const itemname: shortstring; itemcount: cardinal): shortstring; -var len,L: PtrInt; -begin - len := (AppendUInt32ToBuffer(@result[1],itemcount)-PUTF8Char(@result[1]))+1; - result[len] := ' '; - L := ord(itemname[0]); - if L in [1..240] then begin // avoid buffer overflow - MoveSmall(@itemname[1],@result[len+1],L); - inc(len,L); - if itemcount>1 then begin - inc(len); - result[len] := 's'; - end; - end; - result[0] := AnsiChar(len); -end; - -function TJSONCustomParserRTTI.IfDefaultSkipped(var Value: PByte): boolean; -begin - case PropertyType of - ptBoolean: result := not PBoolean(Value)^; - ptByte: result := PByte(Value)^=0; - ptWord: result := PWord(Value)^=0; - ptInteger,ptCardinal,ptSingle: - result := PInteger(Value)^=0; - ptCurrency,ptDouble,ptInt64,ptQWord,ptID,ptTimeLog,ptDateTime,ptDateTimeMS: - result := PInt64(Value)^=0; - ptExtended: result := PExtended(Value)^=0; - {$ifndef NOVARIANTS} - ptVariant: result := integer(PVarData(Value)^.VType)<=varNull; - {$endif} - ptRawJSON,ptRawByteString,ptRawUTF8,ptString,ptSynUnicode,ptWideString, - {$ifdef HASVARUSTRING}ptUnicodeString,{$endif}ptArray: - result := PPointer(Value)^=nil; - ptGUID: result := IsNullGUID(PGUID(Value)^); - ptRecord: result := IsZero(Value,fDataSize); - else result := false; - end; - if result then - inc(Value,fDataSize); -end; - -procedure TJSONCustomParserRTTI.WriteOneSimpleValue(aWriter: TTextWriter; var Value: PByte; - Options: TJSONCustomParserSerializationOptions); -var DynArray: PByte; - j: integer; -begin - case PropertyType of - ptBoolean: aWriter.Add(PBoolean(Value)^); - ptByte: aWriter.AddU(PByte(Value)^); - ptCardinal: aWriter.AddU(PCardinal(Value)^); - ptCurrency: aWriter.AddCurr64(PInt64(Value)^); - ptDouble: aWriter.AddDouble(unaligned(PDouble(Value)^)); - ptExtended: aWriter.Add(PExtended(Value)^,EXTENDED_PRECISION); - ptInt64,ptID,ptTimeLog: - aWriter.Add(PInt64(Value)^); - ptQWord: aWriter.AddQ(PQWord(Value)^); - ptInteger: aWriter.Add(PInteger(Value)^); - ptSingle: aWriter.AddSingle(PSingle(Value)^); - ptWord: aWriter.AddU(PWord(Value)^); - {$ifndef NOVARIANTS} - ptVariant: aWriter.AddVariant(PVariant(Value)^,twJSONEscape); - {$endif} - ptRawJSON: aWriter.AddRawJSON(PRawJSON(Value)^); - ptRawByteString: - aWriter.WrBase64(PPointer(Value)^,length(PRawByteString(Value)^),{withMagic=}true); - ptRawUTF8, ptString, ptSynUnicode,{$ifdef HASVARUSTRING}ptUnicodeString,{$endif} - ptDateTime, ptDateTimeMS, ptGUID, ptWideString: begin - aWriter.Add('"'); - case PropertyType of - ptRawUTF8: aWriter.AddJSONEscape(PPointer(Value)^); - ptString: aWriter.AddJSONEscapeString(PString(Value)^); - ptSynUnicode,{$ifdef HASVARUSTRING}ptUnicodeString,{$endif} - ptWideString: aWriter.AddJSONEscapeW(PPointer(Value)^); - ptDateTime: aWriter.AddDateTime(unaligned(PDateTime(Value)^),{withms=}false); - ptDateTimeMS: aWriter.AddDateTime(unaligned(PDateTime(Value)^),true); - ptGUID: aWriter.Add(PGUID(Value)^); - end; - aWriter.Add('"'); - end; - ptArray: begin - aWriter.Add('['); - inc(aWriter.fHumanReadableLevel); - DynArray := PPointer(Value)^; - if DynArray<>nil then - for j := 1 to DynArrayLength(DynArray) do begin - if soWriteHumanReadable in Options then - aWriter.AddCRAndIndent; - if NestedProperty[0].PropertyName='' then // array of simple - NestedProperty[0].WriteOneSimpleValue(aWriter,DynArray,Options) else - WriteOneLevel(aWriter,DynArray,Options); // array of record - aWriter.Add(','); - {$ifdef ALIGNCUSTOMREC} - if PtrUInt(DynArray)and 7<>0 then - inc(DynArray,8-(PtrUInt(DynArray)and 7)); - {$endif} - end; - aWriter.CancelLastComma; - aWriter.Add(']'); - dec(aWriter.fHumanReadableLevel); - end; - ptRecord: begin - WriteOneLevel(aWriter,Value,Options); - exit; - end; - ptCustom: - TJSONCustomParserCustom(self).CustomWriter(aWriter,Value^); - end; - inc(Value,fDataSize); -end; - -procedure TJSONCustomParserRTTI.WriteOneLevel(aWriter: TTextWriter; var P: PByte; - Options: TJSONCustomParserSerializationOptions); -var i: integer; - SubProp: TJSONCustomParserRTTI; -begin - if P=nil then begin - aWriter.AddShort('null'); - exit; - end; - if not (PropertyType in [ptRecord,ptArray]) then begin - WriteOneSimpleValue(aWriter,P,Options); - exit; - end; - aWriter.Add('{'); - Inc(aWriter.fHumanReadableLevel); - for i := 0 to length(NestedProperty)-1 do begin - SubProp := NestedProperty[i]; - if soWriteIgnoreDefault in Options then - if SubProp.IfDefaultSkipped(P) then - continue; - if soWriteHumanReadable in Options then - aWriter.AddCRAndIndent; - aWriter.AddFieldName(SubProp.PropertyName); - if soWriteHumanReadable in Options then - aWriter.Add(' '); - SubProp.WriteOneSimpleValue(aWriter,P,Options); - aWriter.Add(','); - end; - aWriter.CancelLastComma; - dec(aWriter.fHumanReadableLevel); - if soWriteHumanReadable in Options then - aWriter.AddCRAndIndent; - aWriter.Add('}'); -end; - - -{ TJSONRecordAbstract } - -constructor TJSONRecordAbstract.Create; -begin - fItems := TSynObjectList.Create; -end; - -function TJSONRecordAbstract.AddItem(const aPropertyName: RawUTF8; - aPropertyType: TJSONCustomParserRTTIType; - const aCustomRecordTypeName: RawUTF8): TJSONCustomParserRTTI; -begin - if aPropertyType=ptCustom then begin - result := TJSONCustomParserRTTI.CreateFromTypeName( - aPropertyName,aCustomRecordTypeName); - if result=nil then - raise ESynException.CreateUTF8('Unregistered ptCustom for %.AddItem(%: %)', - [self,aPropertyName,aCustomRecordTypeName]); - end else - result := TJSONCustomParserRTTI.Create(aPropertyName,aPropertyType); - fItems.Add(result); -end; - -function TJSONRecordAbstract.CustomReader(P: PUTF8Char; var aValue; - out aValid: Boolean{$ifndef NOVARIANTS}; CustomVariantOptions: PDocVariantOptions{$endif}): PUTF8Char; -var Data: PByte; - EndOfObject: AnsiChar; -begin - if Root.PropertyType=ptCustom then begin - result := TJSONCustomParserCustom(Root).CustomReader(P,aValue,EndOfObject - {$ifndef NOVARIANTS},CustomVariantOptions{$endif}); - aValid := result<>nil; - if (EndOfObject<>#0) and aValid then begin - dec(result); - result^ := EndOfObject; // emulates simple read - end; - exit; - end; - Data := @aValue; - aValid := Root.ReadOneLevel(P,Data,Options{$ifndef NOVARIANTS},CustomVariantOptions{$endif}); - result := P; -end; - -procedure TJSONRecordAbstract.CustomWriter(const aWriter: TTextWriter; const aValue); -var P: PByte; - o: TJSONCustomParserSerializationOptions; -begin - P := @aValue; - o := Options; - if twoIgnoreDefaultInRecord in aWriter.CustomOptions then - include(o,soWriteIgnoreDefault); - Root.WriteOneLevel(aWriter,P,o); -end; - -destructor TJSONRecordAbstract.Destroy; -begin - FreeAndNil(fItems); - inherited; -end; - - -{ TJSONRecordTextDefinition } - -var - JSONCustomParserCache: TRawUTF8List; - -class function TJSONRecordTextDefinition.FromCache(aTypeInfo: pointer; - const aDefinition: RawUTF8): TJSONRecordTextDefinition; -begin - if JSONCustomParserCache=nil then - GarbageCollectorFreeAndNil(JSONCustomParserCache, - TRawUTF8List.Create([fObjectsOwned,fNoDuplicate,fCaseSensitive])); - result := JSONCustomParserCache.GetObjectFrom(aDefinition); - if result<>nil then - exit; - result := TJSONRecordTextDefinition.Create(aTypeInfo,aDefinition); - JSONCustomParserCache.AddObjectUnique(aDefinition,@result); -end; - -constructor TJSONRecordTextDefinition.Create(aRecordTypeInfo: pointer; - const aDefinition: RawUTF8); -var P: PUTF8Char; - recordInfoSize: integer; -begin - inherited Create; - fDefinition := aDefinition; - fRoot := TJSONCustomParserRTTI.Create('',ptRecord); - TypeInfoToName(aRecordTypeInfo,fRoot.fCustomTypeName); - fItems.Add(fRoot); - P := pointer(aDefinition); - Parse(fRoot,P,eeNothing); - fRoot.ComputeDataSizeAfterAdd; - recordInfoSize := RecordTypeInfoSize(aRecordTypeInfo); - if (recordInfoSize<>0) and (fRoot.fDataSize<>recordInfoSize) then - raise ESynException.CreateUTF8('%.Create: % text definition is not accurate,'+ - ' or the type has not been defined as PACKED record: RTTI size is %'+ - ' bytes but text definition covers % bytes', - [self,fRoot.fCustomTypeName,recordInfoSize,fRoot.fDataSize]); -end; - -function DynArrayItemTypeLen(const aDynArrayTypeName: RawUTF8): PtrInt; -begin - result := length(aDynArrayTypeName); - if (result>12) and IdemPropName('DynArray',@PByteArray(aDynArrayTypeName)[result-8],8) then - dec(result,8) else - if (result>3) and (aDynArrayTypeName[result] in ['s','S']) then - dec(result) else - result := 0; -end; - -function DynArrayItemTypeIsSimpleBinary(const aDynArrayTypeName: RawUTF8): boolean; -var itemLen,dataSize,fieldSize: integer; -begin - itemLen := DynArrayItemTypeLen(aDynArrayTypeName); - result := (itemLen>0) and TJSONCustomParserRTTI.TypeNameToSimpleBinary( - copy(aDynArrayTypeName,1,itemLen),dataSize,fieldSize); -end; - -procedure TJSONRecordTextDefinition.Parse(Props: TJSONCustomParserRTTI; - var P: PUTF8Char; PEnd: TJSONCustomParserRTTIExpectedEnd); - function GetNextFieldType(var P: PUTF8Char; - var TypIdent: RawUTF8): TJSONCustomParserRTTIType; - begin - if GetNextFieldProp(P,TypIdent) then - result := TJSONCustomParserRTTI.TypeNameToSimpleRTTIType( - pointer(TypIdent),length(TypIdent),@TypIdent) else - raise ESynException.CreateUTF8('%.Parse: missing field type',[self]); - end; -var PropsName: TRawUTF8DynArray; - PropsMax, ndx, len, firstNdx: cardinal; - Typ, ArrayTyp: TJSONCustomParserRTTIType; - TypIdent, ArrayTypIdent: RawUTF8; - Item: TJSONCustomParserRTTI; - ExpectedEnd: TJSONCustomParserRTTIExpectedEnd; -begin - SetLength(PropsName,16); - PropsMax := 0; - while (P<>nil) and (P^<>#0) do begin - // fill Props[] - if P^ in ['''','"'] then begin // parse identifier as SQL string (e.g. "@field0") - P := UnQuoteSQLStringVar(P,PropsName[PropsMax]); - if P=nil then - break; - end else // regular object pascal identifier (i.e. 0..9,a..z,A..Z,_) - if not GetNextFieldProp(P,PropsName[PropsMax]) then - break; - case P^ of - ',': begin - inc(P); - inc(PropsMax); - if PropsMax=cardinal(length(PropsName)) then - SetLength(PropsName,PropsMax+16); - continue; // several properties defined with the same type - end; - ':': P := GotoNextNotSpace(P+1); - end; - // identify type - ArrayTyp := ptRecord; - if P^='{' then begin - Typ := ptRecord; - ExpectedEnd := eeCurly; - repeat inc(P) until (P^>' ') or (P^=#0); - end else - if P^='[' then begin - Typ := ptArray; - ExpectedEnd := eeSquare; - repeat inc(P) until (P^>' ') or (P^=#0); - end else begin - Typ := GetNextFieldType(P,TypIdent); - case Typ of - ptArray: begin - if IdemPChar(P,'OF') then begin - P := GotoNextNotSpace(P+2); - ArrayTyp := GetNextFieldType(P,ArrayTypIdent); - if ArrayTyp=ptArray then - P := nil; - end else - P := nil; - if P=nil then - raise ESynException.CreateUTF8('%.Parse: expected syntax is '+ - '"array of record" or "array of SimpleType"',[self]); - if ArrayTyp=ptRecord then - ExpectedEnd := eeEndKeyWord else - ExpectedEnd := eeNothing; - end; - ptRecord: - ExpectedEnd := eeEndKeyWord; - ptCustom: begin - len := DynArrayItemTypeLen(TypIdent); - if len>0 then begin - ArrayTyp := TJSONCustomParserRTTI.TypeNameToSimpleRTTIType( - @PByteArray(TypIdent)[1],len-1,@ArrayTypIdent); // TByteDynArray -> byte - if ArrayTyp=ptCustom then begin // TMyTypeDynArray/TMyTypes -> TMyType - FastSetString(ArrayTypIdent,pointer(TypIdent),len); - if GlobalCustomJSONSerializerFromTextSimpleType.Find(ArrayTypIdent)>=0 then - Typ := ptArray; - end else - Typ := ptArray; - end; - ExpectedEnd := eeNothing; - end; - else ExpectedEnd := eeNothing; - end; - end; - // add elements - firstNdx := length(Props.fNestedProperty); - SetLength(Props.fNestedProperty,firstNdx+PropsMax+1); - for ndx := 0 to PropsMax do begin - Item := AddItem(PropsName[ndx],Typ,TypIdent); - Props.fNestedProperty[firstNdx+ndx] := Item; - if (Typ=ptArray) and (ArrayTyp<>ptRecord) then begin - SetLength(Item.fNestedProperty,1); - Item.fNestedProperty[0] := AddItem('',ArrayTyp,ArrayTypIdent); - end else - if Typ in [ptArray,ptRecord] then - if ndx=0 then // only parse once multiple fields nested type - Parse(Item,P,ExpectedEnd) else - Item.fNestedProperty := Props.fNestedProperty[firstNdx].fNestedProperty; - Item.ComputeDataSizeAfterAdd; - end; - // validate expected end - while P^ in [#1..' ',';'] do inc(P); - case PEnd of - eeEndKeyWord: - if IdemPChar(P,'END') then begin - inc(P,3); - while P^ in [#1..' ',';'] do inc(P); - break; - end; - eeSquare: - if P^=']' then begin - inc(P); - break; - end; - eeCurly: - if P^='}' then begin - inc(P); - break; - end; - end; - PropsMax := 0; - end; -end; - - -{ TJSONRecordRTTI } - -constructor TJSONRecordRTTI.Create(aRecordTypeInfo: pointer; - aRoot: TJSONCustomParserRTTI); -begin - inherited Create; - fRecordTypeInfo := aRecordTypeInfo; - fRoot := aRoot; - if fRoot=nil then begin - {$ifdef ISDELPHI2010} - fRoot := TJSONCustomParserRTTI.Create('',ptRecord); - FromEnhancedRTTI(fRoot,aRecordTypeInfo); - if fRoot.fNestedDataSize<>RecordTypeInfoSize(aRecordTypeInfo) then - raise ESynException.CreateUTF8( - '%.Create: error when retrieving enhanced RTTI for %', - [self,fRoot.CustomTypeName]); - {$else} - raise ESynException.CreateUTF8('%.Create with no enhanced RTTI for %', - [self,PShortString(@PTypeInfo(aRecordTypeInfo).NameLen)^]); - {$endif} - end; - fItems.Add(fRoot); - GarbageCollector.Add(self); -end; - -function TJSONRecordRTTI.AddItemFromRTTI( - const PropertyName: RawUTF8; Info: pointer; ItemSize: integer): TJSONCustomParserRTTI; -begin - result := TJSONCustomParserRTTI.CreateFromRTTI(PropertyName,Info,ItemSize); - fItems.Add(result); -end; - -{$ifdef ISDELPHI2010} - -procedure TJSONRecordRTTI.FromEnhancedRTTI( - Props: TJSONCustomParserRTTI; Info: pointer); -var FieldTable: PTypeInfo; - i: integer; - FieldSize: cardinal; - RecField: PEnhancedFieldInfo; - ItemFields: array of PEnhancedFieldInfo; - ItemField: PTypeInfo; - ItemFieldName: RawUTF8; - ItemFieldSize: cardinal; - Item, ItemArray: TJSONCustomParserRTTI; -begin // only tkRecord is needed here - FieldTable := GetTypeInfo(Info,tkRecord); - if FieldTable=nil then - raise ESynException.CreateUTF8('%.FromEnhancedRTTI(%=record?)',[self,Info]); - FieldSize := FieldTable^.recSize; - inc(PByte(FieldTable),FieldTable^.ManagedCount*SizeOf(TFieldInfo)-SizeOf(TFieldInfo)); - inc(PByte(FieldTable),FieldTable^.NumOps*SizeOf(pointer)); // jump RecOps[] - if FieldTable^.AllCount=0 then - exit; // not enough RTTI -> will raise an error in Create() - TypeInfoToName(Info,Props.fCustomTypeName); - RecField := @FieldTable^.AllFields[0]; - SetLength(ItemFields,FieldTable^.AllCount); - for i := 0 to FieldTable^.AllCount-1 do begin - ItemFields[i] := RecField; - inc(PByte(RecField),RecField^.NameLen); // Delphi: no AlignPtr() needed - inc(RecField); - inc(PByte(RecField),PWord(RecField)^); - end; - SetLength(Props.fNestedProperty,FieldTable^.AllCount); - for i := 0 to FieldTable^.AllCount-1 do begin - if i=FieldTable^.AllCount-1 then - ItemFieldSize := FieldSize-ItemFields[i].Offset else - ItemFieldSize := ItemFields[i+1].Offset-ItemFields[i].Offset; - ItemField := Deref(ItemFields[i]^.TypeInfo); - FastSetString(ItemFieldName,PAnsiChar(@ItemFields[i]^.NameLen)+1,ItemFields[i]^.NameLen); - Item := AddItemFromRTTI(ItemFieldName,ItemField,ItemFieldSize); - Props.fNestedProperty[i] := Item; - case Item.PropertyType of - ptArray: begin - inc(PByte(ItemField),ItemField^.NameLen); - ItemArray := AddItemFromRTTI('',Deref(ItemField^.elType2), - ItemField^.elSize {$ifdef FPC}and $7FFFFFFF{$endif}); - if (ItemArray.PropertyType=ptCustom) and - (ItemArray.ClassType=TJSONCustomParserRTTI) then - FromEnhancedRTTI(Item,Deref(ItemField^.elType2)) else begin - SetLength(Item.fNestedProperty,1); - Item.fNestedProperty[0] := ItemArray; - Item.ComputeNestedDataSize; - end; - end; - ptCustom: - if (ItemField<>nil) and (Item.ClassType=TJSONCustomParserRTTI) then - FromEnhancedRTTI(Item,ItemField); - end; - end; - Props.ComputeNestedDataSize; -end; - -{$endif ISDELPHI2010} - - -{ ************ variant-based process, including JSON/BSON document content } - -{$ifndef LVCL} - -procedure RawByteStringToVariant(Data: PByte; DataLen: Integer; var Value: variant); -begin - ClearVariantForString(Value); - if (Data=nil) or (DataLen<=0) then - TVarData(Value).VType := varNull else - SetString(RawByteString(TVarData(Value).VAny),PAnsiChar(Data),DataLen); -end; - -procedure RawByteStringToVariant(const Data: RawByteString; var Value: variant); -begin - ClearVariantForString(Value); - if Data='' then - TVarData(Value).VType := varNull else - RawByteString(TVarData(Value).VAny) := Data; -end; - -procedure VariantToRawByteString(const Value: variant; var Dest: RawByteString); -begin - case integer(TVarData(Value).VType) of - varEmpty, varNull: - Dest := ''; - varString: - Dest := RawByteString(TVarData(Value).VAny); - else // not from RawByteStringToVariant() -> conversion to string - Dest := {$ifdef UNICODE}RawByteString{$else}string{$endif}(Value); - end; -end; - -procedure SetVariantNull(var Value: variant); -begin // slightly faster than Value := Null - VarClear(Value); - TVarData(Value).VType := varNull; -end; - -{$endif LVCL} - -function VarDataIsEmptyOrNull(VarData: pointer): Boolean; -var vt: cardinal; -begin - repeat - vt := PVarData(VarData)^.VType; - if vt<>varVariant or varByRef then - break; - VarData := PVarData(VarData)^.VPointer; - if VarData=nil then begin - result := true; - exit; - end; - until false; - result := (vt<=varNull) or (vt=varNull or varByRef); -end; - -function VarIsEmptyOrNull(const V: Variant): Boolean; -begin - result := VarDataIsEmptyOrNull(@V); -end; - -function VarIs(const V: Variant; const VTypes: TVarDataTypes): Boolean; -var VD: PVarData; - vt: cardinal; -begin - VD := @V; - repeat - vt := VD^.VType; - if vt<>varVariant or varByRef then - break; - VD := VD^.VPointer; - if VD=nil then begin - result := false; - exit; - end; - until false; - result := vt in VTypes; -end; - -function VarIsVoid(const V: Variant): boolean; -var vt: cardinal; -begin - vt := TVarData(V).VType; - with TVarData(V) do - case vt of - varEmpty,varNull: - result := true; - varBoolean: - result := not VBoolean; - varString,varOleStr{$ifdef HASVARUSTRING},varUString{$endif}: - result := VAny=nil; - varDate: - result := VInt64=0; - else - if vt=varVariant or varByRef then - result := VarIsVoid(PVariant(VPointer)^) else - if (vt=varByRef or varString) or (vt=varByRef or varOleStr) - {$ifdef HASVARUSTRING} or (vt=varByRef or varUString) {$endif} then - result := PPointer(VAny)^=nil else - {$ifndef NOVARIANTS} - if vt=cardinal(DocVariantVType) then - result := TDocVariantData(V).Count=0 else - {$endif} - result := false; - end; -end; - -function VarStringOrNull(const v: RawUTF8): variant; -begin - if v='' then - SetVariantNull(result) else - {$ifdef NOVARIANTS} result := v {$else} RawUTF8ToVariant(v,result) {$endif}; -end; - -{$ifndef NOVARIANTS} - -/// internal method used by VariantLoadJSON(), GetVariantFromJSON() and -// TDocVariantData.InitJSONInPlace() -procedure GetJSONToAnyVariant(var Value: variant; var JSON: PUTF8Char; - EndOfObject: PUTF8Char; Options: PDocVariantOptions; AllowDouble: boolean); forward; - -procedure SetVariantByRef(const Source: Variant; var Dest: Variant); -var vt: cardinal; -begin - VarClear(Dest); - vt := TVarData(Source).VType; - if ((vt and varByRef)<>0) or (vt in [varEmpty..varDate,varBoolean,varShortInt..varWord64]) then - TVarData(Dest) := TVarData(Source) else - if not SetVariantUnRefSimpleValue(Source,TVarData(Dest)) then begin - TVarData(Dest).VType := varVariant or varByRef; - TVarData(Dest).VPointer := @Source; - end; -end; - -procedure SetVariantByValue(const Source: Variant; var Dest: Variant); -var s: PVarData; - d: TVarData absolute Dest; - vt: cardinal; -begin - s := @Source; - VarClear(Dest); - vt := s^.VType; - if vt=varVariant or varByRef then begin - s := s^.VPointer; - vt := s^.VType; - end; - case vt of - varEmpty..varDate,varBoolean,varShortInt..varWord64: begin - d.VType := vt; - d.VInt64 := s^.VInt64; - end; - varString: begin - d.VType := varString; - d.VAny := nil; - RawByteString(d.VAny) := RawByteString(s^.VAny); - end; - varByRef or varString: begin - d.VType := varString; - d.VAny := nil; - RawByteString(d.VAny) := PRawByteString(s^.VAny)^; - end; - {$ifdef HASVARUSTRING} varUString, varByRef or varUString, {$endif} - varOleStr, varByRef or varOleStr: begin - d.VType := varString; - d.VAny := nil; - VariantToUTF8(PVariant(s)^,RawUTF8(d.VAny)); // store a RawUTF8 instance - end; - else - if not SetVariantUnRefSimpleValue(PVariant(s)^,d) then - if vt=cardinal(DocVariantVType) then - DocVariantType.CopyByValue(d,s^) else - Dest := PVariant(s)^; - end; -end; - -procedure ZeroFill(Value: PVarData); -begin // slightly faster than FillChar(Value,SizeOf(Value),0); - PInt64Array(Value)^[0] := 0; - PInt64Array(Value)^[1] := 0; - {$ifdef CPU64} - //assert(SizeOf(TVarData)=24); - PInt64Array(Value)^[2] := 0; - {$endif} -end; - -procedure FillZero(var value: variant); -begin - with TVarData(Value) do - if cardinal(VType)=varString then - FillZero(RawByteString(VString)); - VarClear(Value); -end; - -procedure RawUTF8ToVariant(Txt: PUTF8Char; TxtLen: integer; var Value: variant); -begin - ClearVariantForString(Value); - FastSetString(RawUTF8(TVarData(Value).VString), Txt, TxtLen); -end; - -procedure RawUTF8ToVariant(const Txt: RawUTF8; var Value: variant); -begin - ClearVariantForString(Value); - if Txt='' then - exit; - RawByteString(TVarData(Value).VString) := Txt; - {$ifdef HASCODEPAGE} // force explicit UTF-8 - SetCodePage(RawByteString(TVarData(Value).VAny),CP_UTF8,false); - {$endif HASCODEPAGE} -end; - -procedure FormatUTF8ToVariant(const Fmt: RawUTF8; const Args: array of const; - var Value: variant); -begin - RawUTF8ToVariant(FormatUTF8(Fmt,Args),Value); -end; - -function RawUTF8ToVariant(const Txt: RawUTF8): variant; -begin - RawUTF8ToVariant(Txt,result); -end; - -procedure RawUTF8ToVariant(const Txt: RawUTF8; var Value: TVarData; - ExpectedValueType: cardinal); -begin - if ExpectedValueType=varString then begin - RawUTF8ToVariant(Txt,variant(Value)); - exit; - end; - VarClear(variant(Value)); - Value.VType := ExpectedValueType; - Value.VAny := nil; // avoid GPF below - if Txt<>'' then - case ExpectedValueType of - varOleStr: - UTF8ToWideString(Txt,WideString(Value.VAny)); - {$ifdef HASVARUSTRING} - varUString: - UTF8DecodeToUnicodeString(pointer(Txt),length(Txt),UnicodeString(Value.VAny)); - {$endif} - else raise ESynException.CreateUTF8('RawUTF8ToVariant(ExpectedValueType=%)', - [ExpectedValueType]); - end; -end; - -function VariantSave(const Value: variant; Dest: PAnsiChar): PAnsiChar; - procedure ComplexType; - begin - try - Dest := pointer(ToVarString(VariantSaveJSON(Value),PByte(Dest))); - except - on Exception do - Dest := nil; // notify invalid/unhandled variant content - end; - end; -var LenBytes: integer; - tmp: TVarData; -begin - with TVarData(Value) do - if VType and varByRef<>0 then - if VType=varVariant or varByRef then begin - result := VariantSave(PVariant(VPointer)^,Dest); - exit; - end else - if SetVariantUnRefSimpleValue(Value,tmp) then begin - result := VariantSave(variant(tmp),Dest-SizeOf(VType)); - exit; - end; - with TVarData(Value) do begin - PWord(Dest)^ := VType; - inc(Dest,SizeOf(VType)); - case VType of - varNull, varEmpty: ; - varShortInt, varByte: begin - Dest^ := AnsiChar(VByte); - inc(Dest); - end; - varSmallint, varWord, varBoolean: begin - PWord(Dest)^ := VWord; - inc(Dest,SizeOf(VWord)); - end; - varSingle, varLongWord, varInteger: begin - PInteger(Dest)^ := VInteger; - inc(Dest,SizeOf(VInteger)); - end; - varInt64, varWord64, varDouble, varDate, varCurrency:begin - PInt64(Dest)^ := VInt64; - inc(Dest,SizeOf(VInt64)); - end; - varString, varOleStr {$ifdef HASVARUSTRING}, varUString{$endif}: begin - if PtrUInt(VAny)=0 then - LenBytes := 0 else begin - LenBytes := PStrLen(PtrUInt(VAny)-_STRLEN)^; - {$ifdef HASVARUSTRING} - if VType=varUString then - LenBytes := LenBytes*2; // stored length is in bytes, not (wide)chars - {$endif} - end; - Dest := pointer(ToVarUInt32(LenBytes,pointer(Dest))); - if LenBytes>0 then begin // direct raw copy - MoveFast(PPtrUInt(VAny)^,Dest^,LenBytes); - inc(Dest,LenBytes); - end; - end; - else ComplexType; // complex types are stored as JSON - end; - end; - result := Dest; -end; - -function VariantSaveLength(const Value: variant): integer; -var tmp: TVarData; - v: TVarData absolute Value; -begin // match VariantSave() storage - if v.VType and varByRef<>0 then - if v.VType=varVariant or varByRef then begin - result := VariantSaveLength(PVariant(v.VPointer)^); - exit; - end else - if SetVariantUnRefSimpleValue(Value,tmp) then begin - result := VariantSaveLength(variant(tmp)); - exit; - end; - case v.VType of - varEmpty, varNull: - result := SizeOf(tmp.VType); - varShortInt, varByte: - result := SizeOf(tmp.VByte)+SizeOf(tmp.VType); - varSmallint, varWord, varBoolean: - result := SizeOf(tmp.VSmallint)+SizeOf(tmp.VType); - varSingle, varLongWord, varInteger: - result := SizeOf(tmp.VInteger)+SizeOf(tmp.VType); - varInt64, varWord64, varDouble, varDate, varCurrency: - result := SizeOf(tmp.VInt64)+SizeOf(tmp.VType); - varString, varOleStr: - if PtrUInt(v.VAny)=0 then - result := 1+SizeOf(tmp.VType) else - result := ToVarUInt32LengthWithData( - PStrLen(PtrUInt(v.VAny)-_STRLEN)^)+SizeOf(tmp.VType); - {$ifdef HASVARUSTRING} - varUString: - if PtrUInt(v.VAny)=0 then // stored length is in bytes, not (wide)chars - result := 1+SizeOf(tmp.VType) else - result := ToVarUInt32LengthWithData( - PStrLen(PtrUInt(v.VAny)-_STRLEN)^*2)+SizeOf(tmp.VType); - {$endif} - else - try // complex types will be stored as JSON - result := ToVarUInt32LengthWithData(VariantSaveJSONLength(Value))+SizeOf(tmp.VType); - except - on Exception do - result := 0; // notify invalid/unhandled variant content - end; - end; -end; - -function VariantSave(const Value: variant): RawByteString; -var P: PAnsiChar; -begin - SetString(result,nil,VariantSaveLength(Value)); - P := VariantSave(Value,pointer(result)); - if P-pointer(result)<>length(result) then - raise ESynException.Create('VariantSave length'); -end; - -function VariantLoad(const Bin: RawByteString; - CustomVariantOptions: PDocVariantOptions): variant; -begin - if VariantLoad(result,Pointer(Bin),CustomVariantOptions, - PAnsiChar(pointer(Bin))+length(Bin))=nil then - VarClear(result); -end; - -function VariantLoad(var Value: variant; Source: PAnsiChar; - CustomVariantOptions: PDocVariantOptions; SourceMax: PAnsiChar): PAnsiChar; -var JSON: PUTF8Char; - n: cardinal; - tmp: TSynTempBuffer; // GetJSON*() does in-place unescape -> private copy -begin - result := nil; // error - VarClear(Value); - if (SourceMax<>nil) and (Source+2>SourceMax) then exit; - TVarData(Value).VType := PWord(Source)^; - inc(Source,SizeOf(TVarData(Value).VType)); - case TVarData(Value).VType of - varNull, varEmpty: ; - varShortInt, varByte: begin - if (SourceMax<>nil) and (Source>=SourceMax) then exit; - TVarData(Value).VByte := byte(Source^); - inc(Source); - end; - varSmallint, varWord, varBoolean: begin - if (SourceMax<>nil) and (Source+2>SourceMax) then exit; - TVarData(Value).VWord := PWord(Source)^; - inc(Source,SizeOf(Word)); - end; - varSingle, varLongWord, varInteger: begin - if (SourceMax<>nil) and (Source+4>SourceMax) then exit; - TVarData(Value).VInteger := PInteger(Source)^; - inc(Source,SizeOf(Integer)); - end; - varInt64, varWord64, varDouble, varDate, varCurrency: begin - if (SourceMax<>nil) and (Source+8>SourceMax) then exit; - TVarData(Value).VInt64 := PInt64(Source)^; - inc(Source,SizeOf(Int64)); - end; - varString, varOleStr {$ifdef HASVARUSTRING}, varUString{$endif}: begin - TVarData(Value).VAny := nil; // avoid GPF below when assigning a string variable to VAny - if not FromVarUInt32(PByte(Source),PByte(SourceMax),n) or - ((SourceMax<>nil) and (Source+n>SourceMax)) then - exit; - case TVarData(Value).VType of - varString: - FastSetString(RawUTF8(TVarData(Value).VString),Source,n); // explicit RawUTF8 - varOleStr: - SetString(WideString(TVarData(Value).VAny),PWideChar(Source),n shr 1); - {$ifdef HASVARUSTRING} - varUString: - SetString(UnicodeString(TVarData(Value).VAny),PWideChar(Source),n shr 1); - {$endif} - end; - inc(Source,n); - end; - else - if CustomVariantOptions<>nil then begin - try // expected format for complex type is JSON (VType may differ) - if FromVarString(PByte(Source),PByte(SourceMax),tmp) then - try - JSON := tmp.buf; - TVarData(Value).VType := varEmpty; // avoid GPF below - GetJSONToAnyVariant(Value,JSON,nil,CustomVariantOptions,false); - finally - tmp.Done; - end else - exit; - except - on Exception do - exit; // notify invalid/unhandled variant content - end; - end else - exit; - end; - result := Source; -end; - -procedure FromVarVariant(var Source: PByte; var Value: variant; - CustomVariantOptions: PDocVariantOptions); -begin - Source := PByte(VariantLoad(Value,PAnsiChar(Source),CustomVariantOptions)); -end; - -function VariantLoadJSON(var Value: variant; JSON: PUTF8Char; EndOfObject: PUTF8Char; - TryCustomVariants: PDocVariantOptions; AllowDouble: boolean): PUTF8Char; -var wasString: boolean; - Val: PUTF8Char; -begin - result := JSON; - if JSON=nil then - exit; - if TryCustomVariants<>nil then begin - if dvoJSONObjectParseWithinString in TryCustomVariants^ then begin - JSON := GotoNextNotSpace(JSON); - if JSON^='"' then begin - Val := GetJSONField(result,result,@wasString,EndOfObject); - GetJSONToAnyVariant(Value,Val,EndOfObject,TryCustomVariants,AllowDouble); - end else - GetJSONToAnyVariant(Value,result,EndOfObject,TryCustomVariants,AllowDouble); - end else - GetJSONToAnyVariant(Value,result,EndOfObject,TryCustomVariants,AllowDouble); - end else begin - Val := GetJSONField(result,result,@wasString,EndOfObject); - GetVariantFromJSON(Val,wasString,Value,nil,AllowDouble); - end; - if result=nil then - result := @NULCHAR; // reached end, but not invalid input -end; - -procedure VariantLoadJSON(var Value: Variant; const JSON: RawUTF8; - TryCustomVariants: PDocVariantOptions; AllowDouble: boolean); -var tmp: TSynTempBuffer; -begin - tmp.Init(JSON); // temp copy before in-place decoding - try - VariantLoadJSON(Value,tmp.buf,nil,TryCustomVariants,AllowDouble); - finally - tmp.Done; - end; -end; - -function VariantLoadJSON(const JSON: RawUTF8; TryCustomVariants: PDocVariantOptions; - AllowDouble: boolean): variant; -var tmp: TSynTempBuffer; -begin - tmp.Init(JSON); - try - VariantLoadJSON(result,tmp.buf,nil,TryCustomVariants,AllowDouble); - finally - tmp.Done; - end; -end; - -function VariantSaveJSON(const Value: variant; Escape: TTextWriterKind): RawUTF8; -begin - VariantSaveJSON(Value,Escape,result); -end; - -procedure VariantSaveJSON(const Value: variant; Escape: TTextWriterKind; - var result: RawUTF8); -var temp: TTextWriterStackBuffer; -begin // not very optimized, but fast enough in practice, and creates valid JSON - with DefaultTextWriterSerializer.CreateOwnedStream(temp) do - try - AddVariant(Value,Escape); // may encounter TObjectVariant -> WriteObject - SetText(result); - finally - Free; - end; -end; - -function VariantSaveJSONLength(const Value: variant; Escape: TTextWriterKind): integer; -var Fake: TFakeWriterStream; - temp: TTextWriterStackBuffer; -begin // will avoid most memory allocations - Fake := TFakeWriterStream.Create; - try - with DefaultTextWriterSerializer.Create(Fake,@temp,SizeOf(temp)) do - try - AddVariant(Value,Escape); - FlushFinal; - result := fTotalFileSize; - finally - Free; - end; - finally - Fake.Free; - end; -end; - -procedure VariantToVarRec(const V: variant; var result: TVarRec); -begin - result.VType := vtVariant; - if TVarData(V).VType=varByRef or varVariant then - result.VVariant := TVarData(V).VPointer else - result.VVariant := @V; -end; - -function VarRecToVariant(const V: TVarRec): variant; -begin - VarRecToVariant(V,result); -end; - -procedure VarRecToVariant(const V: TVarRec; var result: variant); -begin - VarClear(result); - with TVarData(result) do - case V.VType of - vtPointer: - VType := varNull; - vtBoolean: begin - VType := varBoolean; - VBoolean := V.VBoolean; - end; - vtInteger: begin - VType := varInteger; - VInteger := V.VInteger; - end; - vtInt64: begin - VType := varInt64; - VInt64 := V.VInt64^; - end; - {$ifdef FPC} - vtQWord: begin - VType := varQWord; - VQWord := V.VQWord^; - end; - {$endif} - vtCurrency: begin - VType := varCurrency; - VCurrency := V.VCurrency^; - end; - vtExtended: begin - VType := varDouble; - VDouble := V.VExtended^; - end; - vtVariant: - result := V.VVariant^; - vtAnsiString: begin - VType := varString; - VAny := nil; - RawByteString(VAny) := RawByteString(V.VAnsiString); - end; - vtString, {$ifdef HASVARUSTRING}vtUnicodeString,{$endif} - vtPChar, vtChar, vtWideChar, vtWideString, vtClass: begin - VType := varString; - VString := nil; // avoid GPF on next line - VarRecToUTF8(V,RawUTF8(VString)); // convert to a new RawUTF8 instance - end; - vtObject: // class instance will be serialized as a TDocVariant - ObjectToVariant(V.VObject,result,[woDontStoreDefault]); - else raise ESynException.CreateUTF8('Unhandled TVarRec.VType=%',[V.VType]); - end; -end; - - -{ TSynInvokeableVariantType } - -function TSynInvokeableVariantType.IterateCount(const V: TVarData): integer; -begin - result := -1; // this is not an array -end; - -procedure TSynInvokeableVariantType.Iterate(var Dest: TVarData; const V: TVarData; - Index: integer); -begin // do nothing -end; - -{$ifndef FPC} -{$ifndef DELPHI6OROLDER} -function TSynInvokeableVariantType.FixupIdent(const AText: string): string; -begin - result := AText; // NO uppercased identifier for our custom types! -end; -{$endif DELPHI6OROLDER} -{$endif FPC} - -function TSynInvokeableVariantType.IntGet(var Dest: TVarData; const Instance: TVarData; - Name: PAnsiChar; NameLen: PtrInt): boolean; -begin - raise ESynException.CreateUTF8('Unexpected %.IntGet(%): this kind of '+ - 'custom variant does not support sub-fields',[self,Name]); -end; - -function TSynInvokeableVariantType.IntSet(const Instance, Value: TVarData; - Name: PAnsiChar; NameLen: PtrInt): boolean; -begin - raise ESynException.CreateUTF8('Unexpected %.IntSet(%): this kind of '+ - 'custom variant is read-only',[self,Name]); -end; - - -function TSynInvokeableVariantType.GetProperty(var Dest: TVarData; - const V: TVarData; const Name: String): Boolean; -{$ifdef UNICODE} var Buf: array[byte] of AnsiChar; {$endif} -begin - IntGet(Dest,V,{$ifdef UNICODE}Buf,RawUnicodeToUtf8(Buf,SizeOf(Buf), - pointer(Name),length(Name),[]){$else}pointer(Name),length(Name){$endif}); - result := true; // IntGet=false+Dest=null e.g. if dvoReturnNullForUnknownProperty -end; - -{$ifdef FPC_VARIANTSETVAR} // see http://mantis.freepascal.org/view.php?id=26773 -function TSynInvokeableVariantType.SetProperty(var V: TVarData; - const Name: string; const Value: TVarData): Boolean; -{$else} -function TSynInvokeableVariantType.SetProperty(const V: TVarData; - const Name: string; const Value: TVarData): Boolean; -{$endif} -var ValueSet: TVarData; - PropName: PAnsiChar; - Unicode: pointer; - PropNameLen, UnicodeLen: PtrInt; - vt: cardinal; -{$ifdef UNICODE} - Buf: array[byte] of AnsiChar; // to avoid heap allocation -{$endif} -begin -{$ifdef UNICODE} - PropNameLen := RawUnicodeToUtf8(Buf,SizeOf(Buf),pointer(Name),length(Name),[]); - PropName := @Buf[0]; -{$else} - PropName := pointer(Name); - PropNameLen := length(Name); -{$endif} - vt := Value.VType; - if vt=varByRef or varOleStr then begin - Unicode := PPointer(Value.VAny)^; - UnicodeLen := length(WideString(Unicode)); - end else - if vt=varOleStr then begin - Unicode := Value.VAny; - UnicodeLen := length(WideString(Unicode)); - end else - {$ifdef HASVARUSTRING} - if vt=varByRef or varUString then begin - Unicode := PPointer(Value.VAny)^; - UnicodeLen := length(UnicodeString(Unicode)); - end else - if vt=varUString then begin - Unicode := Value.VAny; - UnicodeLen := length(UnicodeString(Unicode)); - end else - {$endif} - if SetVariantUnRefSimpleValue(variant(Value),ValueSet) then begin - result := IntSet(V,ValueSet,PropName,PropNameLen); - exit; - end else begin - result := IntSet(V,Value,PropName,PropNameLen); - exit; - end; - try // unpatched RTL does not like Unicode values :( -> use a temp RawUTF8 - ValueSet.VType := varString; - ValueSet.VString := nil; // to avoid GPF in next line - RawUnicodeToUtf8(Unicode,UnicodeLen,RawUTF8(ValueSet.VString)); - result := IntSet(V,ValueSet,PropName,PropNameLen); - finally - RawUTF8(ValueSet.VString) := ''; // avoid memory leak - end; -end; - -procedure TSynInvokeableVariantType.Clear(var V: TVarData); -begin - ZeroFill(@V); // will set V.VType := varEmpty -end; - -procedure TSynInvokeableVariantType.Copy(var Dest: TVarData; - const Source: TVarData; const Indirect: Boolean); -begin - if Indirect then - SimplisticCopy(Dest,Source,true) else begin - VarClear(variant(Dest)); // Dest may be a complex type - Dest := Source; - end; -end; - -procedure TSynInvokeableVariantType.CopyByValue(var Dest: TVarData; const Source: TVarData); -begin - Copy(Dest,Source,false); -end; - -function TSynInvokeableVariantType.TryJSONToVariant(var JSON: PUTF8Char; - var Value: variant; EndOfObject: PUTF8Char): boolean; -begin - result := false; -end; - -procedure TSynInvokeableVariantType.ToJSON(W: TTextWriter; const Value: variant; - Escape: TTextWriterKind); -begin - raise ESynException.CreateUTF8('%.ToJSON: unimplemented variant type',[self]); -end; - -function TSynInvokeableVariantType.IsOfType(const V: variant): boolean; -var vt: cardinal; - vd: PVarData; -begin - if self<>nil then begin - vd := @V; - repeat - vt := vd^.VType; - if vt<>varByRef or varVariant then - break; - vd := vd^.VPointer; - until false; - result := vt=VarType; - end else - result := false; -end; - -var // owned by Variants.pas as TInvokeableVariantType/TCustomVariantType - SynVariantTypes: array of TSynInvokeableVariantType; - -function FindSynVariantTypeFromVType(aVarType: cardinal): TSynInvokeableVariantType; - {$ifdef HASINLINE}inline;{$endif} -var i: integer; - t: ^TSynInvokeableVariantType; -begin - t := pointer(SynVariantTypes); - for i := 1 to length(TObjectDynArray(t)) do begin - result := t^; - if result.VarType=aVarType then - exit; - inc(t); - end; - result := nil; -end; - -function TSynInvokeableVariantType.FindSynVariantType(aVarType: Word; - out CustomType: TSynInvokeableVariantType): boolean; -begin - if aVarType=VarType then - CustomType := self else - CustomType := FindSynVariantTypeFromVType(VarType); - result := CustomType<>nil; -end; - -procedure TSynInvokeableVariantType.Lookup(var Dest: TVarData; const Instance: TVarData; - FullName: PUTF8Char); -var handler: TSynInvokeableVariantType; - v, tmp: TVarData; // PVarData wouldn't store e.g. RowID/count - vt: cardinal; - itemName: ShortString; -begin - PInteger(@Dest)^ := varEmpty; // left to Unassigned if not found - v := Instance; - repeat - vt := v.VType; - if vt<>varByRef or varVariant then - break; - v := PVarData(v.VPointer)^; - until false; - repeat - if vt<=varString then - exit; // we need a complex type to lookup - GetNextItemShortString(FullName,itemName,'.'); - if itemName[0] in [#0,#255] then - exit; - itemName[ord(itemName[0])+1] := #0; // ensure is ASCIIZ - if vt=VarType then - handler := self else begin - handler := FindSynVariantTypeFromVType(vt); - if handler=nil then - exit; - end; - tmp := v; // v will be modified in-place - PInteger(@v)^ := varEmpty; // IntGet() would clear it otherwise! - if not handler.IntGet(v,tmp,@itemName[1],ord(itemName[0])) then - exit; // property not found - repeat - vt := v.VType; - if vt<>varByRef or varVariant then - break; - v := PVarData(v.VPointer)^; - until false; - if (vt=cardinal(DocVariantVType)) and (TDocVariantData(v).VCount=0) then - v.VType := varNull; // recognize void TDocVariant as null - until FullName=nil; - Dest := v; -end; - -procedure GetJSONToAnyVariant(var Value: variant; var JSON: PUTF8Char; - EndOfObject: PUTF8Char; Options: PDocVariantOptions; AllowDouble: boolean); -// internal method used by VariantLoadJSON(), GetVariantFromJSON() and -// TDocVariantData.InitJSON() - procedure ProcessField; - var val: PUTF8Char; - wasString: boolean; - begin - val := GetJSONField(JSON,JSON,@wasString,EndOfObject); - GetVariantFromJSON(val,wasString,Value,nil,AllowDouble); - if JSON=nil then - JSON := @NULCHAR; - end; -var i: integer; - t: ^TSynInvokeableVariantType; - ToBeParsed: PUTF8Char; - wasParsedWithinString: boolean; - wasString: boolean; -begin - VarClear(Value); - if (Options<>nil) and (dvoAllowDoubleValue in Options^) then - AllowDouble := true; // for ProcessField() above - if EndOfObject<>nil then - EndOfObject^ := ' '; - while (JSON^<=' ') and (JSON^<>#0) do inc(JSON); - if (Options=nil) or (JSON^ in ['-','0'..'9']) or (PInteger(JSON)^=NULL_LOW) or - (PInteger(JSON)^=TRUE_LOW) or (PInteger(JSON)^=FALSE_LOW) then begin - ProcessField; // obvious simple type - exit; - end; - wasParsedWithinString := false; - if JSON^='"' then - if dvoJSONObjectParseWithinString in Options^ then begin - ToBeParsed := GetJSONField(JSON,JSON,@wasString,EndOfObject); - EndOfObject := nil; // already set just above - wasParsedWithinString := true; - end else begin - ProcessField; - exit; - end else - ToBeParsed := JSON; - t := pointer(SynVariantTypes); - if (t<>nil) and not(dvoJSONParseDoNotTryCustomVariants in Options^) then - for i := {$ifdef FPC}0{$else}1{$endif} to PDALen(PtrUInt(t)-_DALEN)^ do - if t^.TryJSONToVariant(ToBeParsed,Value,EndOfObject) then begin - if not wasParsedWithinString then - JSON := ToBeParsed; - exit; - end else - inc(t); - if ToBeParsed^ in ['[','{'] then begin - // default JSON parsing and conversion to TDocVariant instance - ToBeParsed := TDocVariantData(Value).InitJSONInPlace(ToBeParsed,Options^,EndOfObject); - if ToBeParsed=nil then begin - TDocVariantData(Value).Clear; - exit; // eror parsing - end; - if not wasParsedWithinString then - JSON := ToBeParsed; - end else - // back to simple variant types - if wasParsedWithinString then - GetVariantFromJSON(ToBeParsed,wasString,Value,nil,AllowDouble) else - ProcessField; -end; - -function TextToVariantNumberTypeNoDouble(json: PUTF8Char): cardinal; -var start: PUTF8Char; - c: AnsiChar; -begin - result := varString; - c := json[0]; - if (jcDigitFirstChar in JSON_CHARS[c]) and - (((c>='1') and (c<='9')) or // is first char numeric? - ((c='0') and ((json[1]='.') or (json[1]=#0))) or // '012' excluded by JSON - ((c='-') and (json[1]>='0') and (json[1]<='9'))) then begin - start := json; - repeat inc(json) until (json^<'0') or (json^>'9'); // check digits - case json^ of - '.': - if (json[1]>='0') and (json[1]<='9') and (json[2] in [#0,'0'..'9']) then - if (json[2]=#0) or (json[3]=#0) or - ((json[3]>='0') and (json[3]<='9') and (json[4]=#0) or - ((json[4]>='0') and (json[4]<='9') and (json[5]=#0))) then - result := varCurrency; // currency ###.1234 number - #0: - if json-start<=19 then // signed Int64 precision - result := varInt64; - end; - end; -end; - -function TextToVariantNumberType(json: PUTF8Char): cardinal; -var start: PUTF8Char; - exp: PtrInt; - c: AnsiChar; -label exponent; -begin - result := varString; - c := json[0]; - if (jcDigitFirstChar in JSON_CHARS[c]) and - (((c>='1') and (c<='9')) or // is first char numeric? - ((c='0') and ((json[1]='.') or (json[1]=#0))) or // '012' excluded by JSON - ((c='-') and (json[1]>='0') and (json[1]<='9'))) then begin - start := json; - repeat inc(json) until (json^<'0') or (json^>'9'); // check digits - case json^ of - #0: - if json-start<=19 then // signed Int64 precision - result := varInt64 else - result := varDouble; // we may lost precision, but still a number - '.': - if (json[1]>='0') and (json[1]<='9') and (json[2] in [#0,'e','E','0'..'9']) then - if (json[2]=#0) or (json[3]=#0) or - ((json[3]>='0') and (json[3]<='9') and (json[4]=#0) or - ((json[4]>='0') and (json[4]<='9') and (json[5]=#0))) then - result := varCurrency // currency ###.1234 number - else begin - repeat // more than 4 decimals - inc(json) - until (json^<'0') or (json^>'9'); - case json^ of - #0: - result := varDouble; - 'e','E': begin -exponent: inc(json); // inlined custom GetInteger() - start := json; - c := json^; - if (c='-') or (c='+') then begin - inc(json); - c := json^; - end; - inc(json); - dec(c,48); - if c>#9 then - exit; - exp := ord(c); - c := json^; - dec(c,48); - if c<=#9 then begin - inc(json); - exp := exp*10+ord(c); - c := json^; - dec(c,48); - if c<=#9 then begin - inc(json); - exp := exp*10+ord(c); - end; - end; - if json^<>#0 then - exit; - if start^='-' then - exp := -exp; - if (exp>-324) and (exp<308) then - result := varDouble; // 5.0 x 10^-324 .. 1.7 x 10^308 - end; - end; - end; - 'e','E': - goto exponent; - end; - end; -end; - -function GetNumericVariantFromJSON(JSON: PUTF8Char; var Value: TVarData; - AllowVarDouble: boolean): boolean; -var err: integer; - typ: cardinal; -label dbl; -begin - if JSON<>nil then begin - if AllowVarDouble then - typ := TextToVariantNumberType(JSON) else - typ := TextToVariantNumberTypeNoDouble(JSON); - with Value do - case typ of - varInt64: begin - VInt64 := GetInt64(JSON,err); - if err<>0 then // overflow (>$7FFFFFFFFFFFFFFF) -> try floating point - if AllowVarDouble then - goto dbl else begin - result:= false; - exit; - end; - if (VInt64<=high(integer)) and (VInt64>=low(integer)) then - VType := varInteger else - VType := varInt64; - result := true; - exit; - end; - varCurrency: begin - VInt64 := StrToCurr64(JSON); - VType := varCurrency; - result := true; - exit; - end; - varDouble: begin -dbl: VDouble := GetExtended(JSON,err); - if err=0 then begin - VType := varDouble; - result := true; - exit; - end; - end; - end; - end; - result := false; -end; - -procedure JSONToVariantInPlace(var Value: variant; JSON: PUTF8Char; - Options: TDocVariantOptions; AllowDouble: boolean); -begin - if (JSON<>nil) and (JSON^<>#0) then - GetJSONToAnyVariant(Value,JSON,nil,@Options,AllowDouble) else - VarClear(Value); -end; - -function JSONToVariant(const JSON: RawUTF8; Options: TDocVariantOptions; - AllowDouble: boolean): variant; -var tmp: TSynTempBuffer; -begin - tmp.Init(JSON); // temp copy before in-place decoding - try - JSONToVariantInPlace(result,tmp.buf,Options,AllowDouble); - finally - tmp.Done; - end; -end; - -procedure TextToVariant(const aValue: RawUTF8; AllowVarDouble: boolean; - out aDest: variant); -begin - if not GetNumericVariantFromJSON(pointer(aValue),TVarData(aDest),AllowVarDouble) then - RawUTF8ToVariant(aValue,aDest); -end; - -function GetNextItemToVariant(var P: PUTF8Char; out Value: Variant; - Sep: AnsiChar; AllowDouble: boolean): boolean; -var temp: RawUTF8; -begin - if P=nil then - result := false else begin - GetNextItem(P,Sep,temp); - if not GetNumericVariantFromJSON(pointer(temp),TVarData(Value),AllowDouble) then - RawUTF8ToVariant(temp,Value); - result := true; - end; -end; - -function GetVariantFromNotStringJSON(JSON: PUTF8Char; var Value: TVarData; - AllowDouble: boolean): boolean; -begin - if JSON<>nil then - while (JSON^<=' ') and (JSON^<>#0) do inc(JSON); - if (JSON=nil) or - ((PInteger(JSON)^=NULL_LOW) and (jcEndOfJSONValueField in JSON_CHARS[JSON[4]])) then - Value.VType := varNull else - if (PInteger(JSON)^=FALSE_LOW) and (JSON[4]='e') and - (jcEndOfJSONValueField in JSON_CHARS[JSON[5]]) then begin - Value.VType := varBoolean; - Value.VBoolean := false; - end else - if (PInteger(JSON)^=TRUE_LOW) and (jcEndOfJSONValueField in JSON_CHARS[JSON[4]]) then begin - Value.VType := varBoolean; - Value.VBoolean := true; - end else - if not GetNumericVariantFromJSON(JSON,Value,AllowDouble) then begin - result := false; - exit; - end; - result := true; -end; - -procedure GetVariantFromJSON(JSON: PUTF8Char; wasString: Boolean; var Value: variant; - TryCustomVariants: PDocVariantOptions; AllowDouble: boolean); -begin - // first handle any strict-JSON syntax objects or arrays into custom variants - // (e.g. when called directly from TSQLPropInfoRTTIVariant.SetValue) - if (TryCustomVariants<>nil) and (JSON<>nil) then - if (GotoNextNotSpace(JSON)^ in ['{','[']) and not wasString then begin - GetJSONToAnyVariant(Value,JSON,nil,TryCustomVariants,AllowDouble); - exit; - end else - AllowDouble := dvoAllowDoubleValue in TryCustomVariants^; - // handle simple text or numerical values - VarClear(Value); - if not wasString and GetVariantFromNotStringJSON(JSON,TVarData(Value),AllowDouble) then - exit; - with TVarData(Value) do begin - // found no numerical value -> return a string in the expected format - VType := varString; - VString := nil; // avoid GPF below when assigning a string variable to VAny - FastSetString(RawUTF8(VString),JSON,StrLen(JSON)); - end; -end; - -{$ifndef FPC} // better not try it with FPC - rely on the current implementation - -function ParseParamPointer(P: pointer; aType: cardinal; var Value: TVarData): pointer; -var Size: Cardinal; - ByRef: Boolean; - V: Variant absolute Value; -const TYPE_BYREF = 128; - TYPE_BYREF_MASK = TYPE_BYREF-1; -begin // this code should copy parameters without any reference count handling - ZeroFill(@Value); // TVarData is expected to be bulk stack: no VarClear needed - ByRef := (aType and TYPE_BYREF)<>0; - Size := SizeOf(pointer); - case aType and TYPE_BYREF_MASK of - varShortInt, varSmallint, varInteger, varByte, varWord, varLongWord, varSingle: begin - if ByRef then - P := pointer(P^); - Value.VType := aType and TYPE_BYREF_MASK; - Value.VInteger := PInteger(P)^; - {$ifdef CPU64} - if not ByRef then - Size := SizeOf(Integer); - {$endif} - end; - varDouble, varCurrency, varDate, varInt64, varWord64, varOleStr: begin - if ByRef then - P := pointer(P^); - Value.VType := aType and TYPE_BYREF_MASK; - Value.VInt64 := PInt64(P)^; - {$ifndef CPU64} - if not ByRef then - Size := SizeOf(Int64); - {$endif} - end; - varStrArg: begin - if ByRef then - P := pointer(P^); - Value.VType := varString; - Value.VString := PPointer(P)^; - end; - {$ifdef HASVARUSTRARG} - varUStrArg: begin - if ByRef then - P := pointer(P^); - Value.VType := varUString; - Value.VUString := PPointer(P)^; - end; - {$endif} - varBoolean: - if ByRef then - V := PWordBool(pointer(P^))^ else - V := PWordBool(P)^; - varVariant: - {$ifdef CPU64} // circumvent Delphi x64 compiler oddiness - Value := PVarData(pointer(P^))^ - {$else} - if ByRef then - Value := PVarData(pointer(P^))^ else begin - Value := PVarData(P)^; - Size := SizeOf(Value); - end; - {$endif} - else - raise EInvalidCast.CreateFmt('ParseParamPointer: Invalid VarType=%d', - [aType and TYPE_BYREF_MASK]); - end; - result := PAnsiChar(P)+Size; -end; - -var - LastDispInvokeType: TSynInvokeableVariantType; - -procedure SynVarDispProc(Result: PVarData; const Instance: TVarData; - CallDesc: PCallDesc; Params: Pointer); cdecl; -const DO_PROP = 1; GET_PROP = 2; SET_PROP = 4; -var Value: TVarData; - Handler: TSynInvokeableVariantType; - CacheDispInvokeType: TSynInvokeableVariantType; // to be thread-safe -begin - if Instance.VType=varByRef or varVariant then // handle By Ref variants - SynVarDispProc(Result,PVarData(Instance.VPointer)^,CallDesc,Params) else begin - if Result<>nil then - VarClear(Variant(Result^)); - case Instance.VType of - varDispatch, varDispatch or varByRef, - varUnknown, varUnknown or varByRef, varAny: - // process Ole Automation variants - if Assigned(VarDispProc) then - VarDispProc(pointer(Result),Variant(Instance),CallDesc,@Params); - else begin - // first we check for our own TSynInvokeableVariantType types - if SynVariantTypes<>nil then begin - // simple cache for the latest type: most gets are grouped - CacheDispInvokeType := LastDispInvokeType; - if (CacheDispInvokeType<>nil) and - (CacheDispInvokeType.VarType=TVarData(Instance).VType) and - (CallDesc^.CallType in [GET_PROP, DO_PROP]) and - (Result<>nil) and (CallDesc^.ArgCount=0) then begin - CacheDispInvokeType.IntGet(Result^,Instance, - @CallDesc^.ArgTypes[0],StrLen(@CallDesc^.ArgTypes[0])); - exit; - end; - end; - // handle any custom variant type - if FindCustomVariantType(Instance.VType,TCustomVariantType(Handler)) then begin - if Handler.InheritsFrom(TSynInvokeableVariantType) then - case CallDesc^.CallType of - GET_PROP, DO_PROP: // fast direct call of our IntGet() virtual method - if (Result<>nil) and (CallDesc^.ArgCount=0) then begin - Handler.IntGet(Result^,Instance, - @CallDesc^.ArgTypes[0],StrLen(@CallDesc^.ArgTypes[0])); - LastDispInvokeType := Handler; // speed up in loop - exit; - end; - SET_PROP: // fast direct call of our IntSet() virtual method - if (Result=nil) and (CallDesc^.ArgCount=1) then begin - ParseParamPointer(@Params,CallDesc^.ArgTypes[0],Value); - Handler.IntSet(Instance,Value, - @CallDesc^.ArgTypes[1],StrLen(@CallDesc^.ArgTypes[1])); - exit; - end; - end; - // here we call the default code handling custom types - Handler.DispInvoke({$ifdef DELPHI6OROLDER}Result^{$else}Result{$endif}, - Instance,CallDesc,@Params) - end else - raise EInvalidOp.CreateFmt('Invalid variant type %d invoke',[Instance.VType]); - end; - end; - end; -end; - -function VariantsDispInvokeAddress: pointer; -asm - {$ifdef CPU64} - mov rax,offset Variants.@DispInvoke - {$else} - mov eax,offset Variants.@DispInvoke - {$endif} -end; - -{$ifdef DOPATCHTRTL} - {$define DOPATCHDISPINVOKE} // much faster late-binding process for our types -{$endif} -{$ifdef CPU64} - {$define DOPATCHDISPINVOKE} - // we NEED our patched DispInvoke to circumvent some Delphi bugs on Win64 -{$endif} -{$ifdef DELPHI6OROLDER} - {$define DOPATCHDISPINVOKE} - // to circumvent LIdent := Uppercase() in TInvokeableVariantType.DispInvoke() -{$endif} - -{$endif FPC} - -function SynRegisterCustomVariantType(aClass: TSynInvokeableVariantTypeClass): TSynInvokeableVariantType; -var i: PtrInt; -{$ifdef DOPATCHDISPINVOKE} -{$ifdef NOVARCOPYPROC} - VarMgr: TVariantManager; -{$endif} -{$endif} -begin - {$ifdef DOPATCHDISPINVOKE} - if SynVariantTypes=nil then begin - {$ifndef CPU64} // we NEED our patched RTL on Win64 - if DebugHook=0 then // patch VCL/RTL only outside debugging - {$endif} begin - {$ifdef NOVARCOPYPROC} - GetVariantManager(VarMgr); - VarMgr.DispInvoke := @SynVarDispProc; - SetVariantManager(VarMgr); - {$else} - RedirectCode(VariantsDispInvokeAddress,@SynVarDispProc); - {$endif NOVARCOPYPROC} - end; - end else - {$endif DOPATCHDISPINVOKE} - for i := 0 to length(SynVariantTypes)-1 do - if PPointer(SynVariantTypes[i])^=pointer(aClass) then begin - result := SynVariantTypes[i]; // returns already registered instance - exit; - end; - result := aClass.Create; // register variant type - ObjArrayAdd(SynVariantTypes,result); -end; - - -function VariantDynArrayToJSON(const V: TVariantDynArray): RawUTF8; -var tmp: TDocVariantData; -begin - tmp.InitArrayFromVariants(V); - result := tmp.ToJSON; -end; - -function JSONToVariantDynArray(const JSON: RawUTF8): TVariantDynArray; -var tmp: TDocVariantData; -begin - tmp.InitJSON(JSON,JSON_OPTIONS_FAST); - result := tmp.VValue; -end; - -function ValuesToVariantDynArray(const items: array of const): TVariantDynArray; -var tmp: TDocVariantData; -begin - tmp.InitArray(items,JSON_OPTIONS_FAST); - result := tmp.VValue; -end; - - -{ TDocVariantData } - -function TDocVariantData.GetKind: TDocVariantKind; -var opt: TDocVariantOptions; -begin - opt := VOptions; - if dvoIsArray in opt then - result := dvArray else - if dvoIsObject in opt then - result := dvObject else - result := dvUndefined; -end; - -function DocVariantData(const DocVariant: variant): PDocVariantData; -var docv,vt: integer; -begin - result := @DocVariant; - docv := DocVariantVType; - vt := result^.VType; - if vt=docv then - exit else - if vt=varByRef or varVariant then begin - result := PVarData(result)^.VPointer; - if integer(result^.VType)=docv then - exit; - end; - raise EDocVariant.CreateUTF8('DocVariantType.Data(%<>TDocVariant)',[ord(result^.VType)]); -end; - -function _Safe(const DocVariant: variant): PDocVariantData; -{$ifdef FPC_OR_PUREPASCAL} -var docv,vt: integer; -begin - result := @DocVariant; - docv := DocVariantVType; - vt := result^.VType; - if vt=docv then - exit else - if vt=varByRef or varVariant then begin - result := PVarData(result)^.VPointer; - if integer(result^.VType)=docv then - exit; - end; - result := @DocVariantDataFake; -end; -{$else} -asm - mov ecx,DocVariantVType - movzx edx,word ptr [eax].TVarData.VType - cmp edx,ecx - jne @by - ret -@ptr: mov eax,[eax].TVarData.VPointer - movzx edx,word ptr [eax].TVarData.VType - cmp edx,ecx - je @ok -@by: cmp edx,varByRef or varVariant - je @ptr - lea eax,[DocVariantDataFake] -@ok: -end; -{$endif} - -function _Safe(const DocVariant: variant; ExpectedKind: TDocVariantKind): PDocVariantData; -var o: TDocVariantOptions; -begin - result := _Safe(DocVariant); - o := result^.VOptions; - if dvoIsArray in o then begin - if ExpectedKind=dvArray then - exit; - end else if (dvoIsObject in o) and (ExpectedKind=dvObject) then - exit; - raise EDocVariant.CreateUTF8('_Safe(%)?',[ToText(ExpectedKind)^]); -end; - -function _CSV(const DocVariantOrString: variant): RawUTF8; -begin - with _Safe(DocVariantOrString)^ do - if dvoIsArray in VOptions then - result := ToCSV else - if (dvoIsObject in VOptions) or (TDocVariantData(DocVariantOrString).VType<=varNull) or - not VariantToUTF8(DocVariantOrString,result) then - result := ''; // VariantToUTF8() returns 'null' for empty/null -end; - -function TDocVariantData.GetValueIndex(const aName: RawUTF8): integer; -begin - result := GetValueIndex(Pointer(aName),Length(aName),dvoNameCaseSensitive in VOptions); -end; - -function TDocVariantData.GetCapacity: integer; -begin - result := length(VValue); -end; - -function TDocVariant.InternNames: TRawUTF8Interning; -begin - if fInternNames=nil then - fInternNames := TRawUTF8Interning.Create; - result := fInternNames; -end; - -function TDocVariant.InternValues: TRawUTF8Interning; -begin - if fInternValues=nil then - fInternValues := TRawUTF8Interning.Create; - result := fInternValues; -end; - -procedure TDocVariantData.SetOptions(const opt: TDocVariantOptions); -begin - VOptions := (opt-[dvoIsArray,dvoIsObject])+(VOptions*[dvoIsArray,dvoIsObject]); -end; - -procedure TDocVariantData.Init(aOptions: TDocVariantOptions; aKind: TDocVariantKind); -begin - aOptions := aOptions-[dvoIsArray,dvoIsObject]; - case aKind of - dvArray: include(aOptions,dvoIsArray); - dvObject: include(aOptions,dvoIsObject); - end; - ZeroFill(@self); - VType := DocVariantVType; - VOptions := aOptions; -end; - -procedure TDocVariantData.InitFast; -begin - ZeroFill(@self); - VType := DocVariantVType; - VOptions := JSON_OPTIONS_FAST; -end; - -procedure TDocVariantData.InitFast(InitialCapacity: integer; aKind: TDocVariantKind); -begin - InitFast; - case aKind of - dvArray: include(VOptions,dvoIsArray); - dvObject: include(VOptions,dvoIsObject); - end; - if aKind=dvObject then - SetLength(VName,InitialCapacity); - SetLength(VValue,InitialCapacity); -end; - -procedure TDocVariantData.InitObject(const NameValuePairs: array of const; - aOptions: TDocVariantOptions=[]); -begin - Init(aOptions,dvObject); - AddNameValuesToObject(NameValuePairs); -end; - -procedure TDocVariantData.AddNameValuesToObject(const NameValuePairs: array of const); -var n,arg: PtrInt; - tmp: variant; -begin - n := length(NameValuePairs); - if (n=0) or (n and 1=1) or (dvoIsArray in VOptions) then - exit; // nothing to add - include(VOptions,dvoIsObject); - n := n shr 1; - if length(VValue)=0 then begin - VCount := length(Items); - SetLength(VValue,VCount); - if dvoValueCopiedByReference in VOptions then - for arg := 0 to high(Items) do - VarRecToVariant(Items[arg],VValue[arg]) else - for arg := 0 to high(Items) do begin - VarRecToVariant(Items[arg],tmp); - SetVariantByValue(tmp,VValue[arg]); - end; - end; -end; - -procedure TDocVariantData.InitArrayFromVariants(const Items: TVariantDynArray; - aOptions: TDocVariantOptions; ItemsCopiedByReference: boolean); -begin - if Items=nil then - VType := varNull else begin - Init(aOptions,dvArray); - VCount := length(Items); - VValue := Items; // fast by-reference copy of VValue[] - if not ItemsCopiedByReference then - InitCopy(variant(self),aOptions); - end; -end; - -procedure TDocVariantData.InitArrayFromObjArray(const ObjArray; - aOptions: TDocVariantOptions; aWriterOptions: TTextWriterWriteObjectOptions); -var ndx: integer; - Items: TObjectDynArray absolute ObjArray; -begin - if Items=nil then - VType := varNull else begin - Init(aOptions,dvArray); - VCount := length(Items); - SetLength(VValue,VCount); - for ndx := 0 to VCount-1 do - ObjectToVariant(Items[ndx],VValue[ndx],aWriterOptions); - end; -end; - -procedure TDocVariantData.InitArrayFrom(const Items: TRawUTF8DynArray; - aOptions: TDocVariantOptions); -var ndx: integer; -begin - if Items=nil then - VType := varNull else begin - Init(aOptions,dvArray); - VCount := length(Items); - SetLength(VValue,VCount); - for ndx := 0 to VCount-1 do - RawUTF8ToVariant(Items[ndx],VValue[ndx]); - end; -end; - -procedure TDocVariantData.InitArrayFrom(const Items: TIntegerDynArray; - aOptions: TDocVariantOptions); -var ndx: integer; -begin - if Items=nil then - VType := varNull else begin - Init(aOptions,dvArray); - VCount := length(Items); - SetLength(VValue,VCount); - for ndx := 0 to VCount-1 do - VValue[ndx] := Items[ndx]; - end; -end; - -procedure TDocVariantData.InitArrayFrom(const Items: TInt64DynArray; - aOptions: TDocVariantOptions); -var ndx: integer; -begin - if Items=nil then - VType := varNull else begin - Init(aOptions,dvArray); - VCount := length(Items); - SetLength(VValue,VCount); - for ndx := 0 to VCount-1 do - VValue[ndx] := Items[ndx]; - end; -end; - -procedure TDocVariantData.InitFromTypeInfo(const aValue; aTypeInfo: pointer; - aEnumSetsAsText: boolean; aOptions: TDocVariantOptions); -var tmp: RawUTF8; -begin - tmp := SaveJSON(aValue,aTypeInfo,aEnumSetsAsText); - InitJSONInPlace(pointer(tmp),aOptions); -end; - -procedure TDocVariantData.InitObjectFromVariants(const aNames: TRawUTF8DynArray; - const aValues: TVariantDynArray; aOptions: TDocVariantOptions); -begin - if (aNames=nil) or (aValues=nil) or (length(aNames)<>length(aValues)) then - VType := varNull else begin - Init(aOptions,dvObject); - VCount := length(aNames); - VName := aNames; // fast by-reference copy of VName[] and VValue[] - VValue := aValues; - end; -end; - -procedure TDocVariantData.InitObjectFromPath(const aPath: RawUTF8; const aValue: variant; - aOptions: TDocVariantOptions); -var right: RawUTF8; -begin - if aPath='' then - VType := varNull else begin - Init(aOptions,dvObject); - VCount := 1; - SetLength(VName,1); - SetLength(VValue,1); - split(aPath,'.',VName[0],right); - if right='' then - VValue[0] := aValue else - PDocVariantData(@VValue[0])^.InitObjectFromPath(right,aValue,aOptions); - end; -end; - -function TDocVariantData.InitJSONInPlace(JSON: PUTF8Char; - aOptions: TDocVariantOptions; aEndOfObject: PUTF8Char): PUTF8Char; -var EndOfObject: AnsiChar; - Name: PUTF8Char; - NameLen, n: integer; - intnames, intvalues: TRawUTF8Interning; -begin - Init(aOptions); - result := nil; - if JSON=nil then - exit; - if dvoInternValues in VOptions then - intvalues := DocVariantType.InternValues else - intvalues := nil; - while (JSON^<=' ') and (JSON^<>#0) do inc(JSON); - case JSON^ of - '[': begin - repeat inc(JSON); if JSON^=#0 then exit; until JSON^>' '; - n := JSONArrayCount(JSON); // may be slow if JSON is huge (not very common) - if n<0 then - exit; // invalid content - include(VOptions,dvoIsArray); - if n>0 then begin - SetLength(VValue,n); - repeat - if VCount>=n then - exit; // unexpected array size means invalid JSON - GetJSONToAnyVariant(VValue[VCount],JSON,@EndOfObject,@VOptions,false); - if JSON=nil then - if EndOfObject=']' then // valid array end - JSON := @NULCHAR else - exit; // invalid input - if intvalues<>nil then - intvalues.UniqueVariant(VValue[VCount]); - inc(VCount); - until EndOfObject=']'; - end else - if JSON^=']' then // n=0 - repeat inc(JSON) until (JSON^=#0) or (JSON^>' ') else - exit; - end; - '{': begin - repeat inc(JSON); if JSON^=#0 then exit; until JSON^>' '; - n := JSONObjectPropCount(JSON); // may be slow if JSON is huge (not very common) - if n<0 then - exit; // invalid content - include(VOptions,dvoIsObject); - if dvoInternNames in VOptions then - intnames := DocVariantType.InternNames else - intnames := nil; - if n>0 then begin - SetLength(VValue,n); - SetLength(VName,n); - repeat - if VCount>=n then - exit; // unexpected object size means invalid JSON - // see http://docs.mongodb.org/manual/reference/mongodb-extended-json - Name := GetJSONPropName(JSON,@NameLen); - if Name=nil then - exit; - FastSetString(VName[VCount],Name,NameLen); - if intnames<>nil then - intnames.UniqueText(VName[VCount]); - GetJSONToAnyVariant(VValue[VCount],JSON,@EndOfObject,@VOptions,false); - if JSON=nil then - if EndOfObject='}' then // valid object end - JSON := @NULCHAR else - exit; // invalid input - if intvalues<>nil then - intvalues.UniqueVariant(VValue[VCount]); - inc(VCount); - until EndOfObject='}'; - end else - if JSON^='}' then // n=0 - repeat inc(JSON) until (JSON^=#0) or (JSON^>' ') else - exit; - end; - 'n','N': begin - if IdemPChar(JSON+1,'ULL') then begin - include(VOptions,dvoIsObject); - result := GotoNextNotSpace(JSON+4); - end; - exit; - end; - else exit; - end; - while (JSON^<=' ') and (JSON^<>#0) do inc(JSON); - if aEndOfObject<>nil then - aEndOfObject^ := JSON^; - if JSON^<>#0 then - repeat inc(JSON) until (JSON^=#0) or (JSON^>' '); - result := JSON; // indicates successfully parsed -end; - -function TDocVariantData.InitJSON(const JSON: RawUTF8; - aOptions: TDocVariantOptions): boolean; -var tmp: TSynTempBuffer; -begin - if JSON='' then - result := false else begin - tmp.Init(JSON); - try - result := InitJSONInPlace(tmp.buf,aOptions)<>nil; - finally - tmp.Done; - end; - end; -end; - -function TDocVariantData.InitJSONFromFile(const JsonFile: TFileName; - aOptions: TDocVariantOptions; RemoveComments: boolean): boolean; -var content: RawUTF8; -begin - content := AnyTextFileToRawUTF8(JsonFile,true); - if RemoveComments then - RemoveCommentsFromJSON(pointer(content)); - result := InitJSONInPlace(pointer(content),aOptions)<>nil; -end; - -procedure TDocVariantData.InitCSV(CSV: PUTF8Char; aOptions: TDocVariantOptions; - NameValueSep, ItemSep: AnsiChar; DoTrim: boolean); -var n,v: RawUTF8; - val: variant; -begin - Init(aOptions,dvObject); - while CSV<>nil do begin - GetNextItem(CSV,NameValueSep,n); - if ItemSep=#10 then - GetNextItemTrimedCRLF(CSV,v) else - GetNextItem(CSV,ItemSep,v); - if DoTrim then - v := trim(v); - if n='' then - break; - RawUTF8ToVariant(v,val); - AddValue(n,val); - end; -end; - -procedure TDocVariantData.InitCSV(const CSV: RawUTF8; aOptions: TDocVariantOptions; - NameValueSep, ItemSep: AnsiChar; DoTrim: boolean); -begin - InitCSV(pointer(CSV),aOptions,NameValueSep,ItemSep,DoTrim); -end; - -procedure TDocVariantData.InitCopy(const SourceDocVariant: variant; - aOptions: TDocVariantOptions); -var ndx,vt: integer; - Source: PDocVariantData; - SourceVValue: TVariantDynArray; - Handler: TCustomVariantType; - v: PVarData; -begin - with TVarData(SourceDocVariant) do - if integer(VType)=varByRef or varVariant then - Source := VPointer else - Source := @SourceDocVariant; - if integer(Source^.VType)<>DocVariantVType then - raise ESynException.CreateUTF8('No TDocVariant for InitCopy(%)',[ord(Source.VType)]); - SourceVValue := Source^.VValue; // local fast per-reference copy - if Source<>@self then begin - VType := Source^.VType; - VCount := Source^.VCount; - pointer(VName) := nil; // avoid GPF - pointer(VValue) := nil; - aOptions := aOptions-[dvoIsArray,dvoIsObject]; // may not be same as Source - if dvoIsArray in Source^.VOptions then - include(aOptions,dvoIsArray) else - if dvoIsObject in Source^.VOptions then begin - include(aOptions,dvoIsObject); - SetLength(VName,VCount); - for ndx := 0 to VCount-1 do - VName[ndx] := Source^.VName[ndx]; // manual copy is needed - if dvoInternNames in aOptions then - with DocVariantType.InternNames do - for ndx := 0 to VCount-1 do - UniqueText(VName[ndx]); - end; - VOptions := aOptions; - end else begin - SetOptions(aOptions); - VariantDynArrayClear(VValue); // full copy of all values - end; - if VCount>0 then begin - SetLength(VValue,VCount); - for ndx := 0 to VCount-1 do begin - v := @SourceVValue[ndx]; - repeat - vt := v^.VType; - if vt<>varByRef or varVariant then - break; - v := v^.VPointer; - until false; - if vt<=varNativeString then // simple string/number types copy - VValue[ndx] := variant(v^) else - if vt=DocVariantVType then // direct recursive copy for TDocVariant - TDocVariantData(VValue[ndx]).InitCopy(variant(v^),VOptions) else - if FindCustomVariantType(vt,Handler) then - if Handler.InheritsFrom(TSynInvokeableVariantType) then - TSynInvokeableVariantType(Handler).CopyByValue(TVarData(VValue[ndx]),v^) else - Handler.Copy(TVarData(VValue[ndx]),v^,false) else - VValue[ndx] := variant(v^); // default copy - end; - if dvoInternValues in VOptions then - with DocVariantType.InternValues do - for ndx := 0 to VCount-1 do - UniqueVariant(VValue[ndx]); - end; - VariantDynArrayClear(SourceVValue); -end; - -procedure TDocVariantData.Clear; -begin - if integer(VType)=DocVariantVType then begin - PInteger(@VType)^ := 0; - RawUTF8DynArrayClear(VName); - VariantDynArrayClear(VValue); - VCount := 0; - end else - VarClear(variant(self)); -end; - -procedure TDocVariantData.Reset; -var backup: TDocVariantOptions; -begin - if VCount=0 then - exit; - backup := VOptions-[dvoIsArray,dvoIsObject]; - DocVariantType.Clear(TVarData(self)); - VType := DocVariantVType; - VOptions := backup; -end; - -procedure TDocVariantData.FillZero; -var ndx: integer; -begin - for ndx := 0 to VCount-1 do - SynCommons.FillZero(VValue[ndx]); - Reset; -end; - -procedure TDocVariantData.SetCount(aCount: integer); -begin - VCount := aCount; -end; - -function TDocVariantData.InternalAdd(const aName: RawUTF8): integer; -var len: integer; -begin - if aName<>'' then begin - if dvoIsArray in VOptions then - raise EDocVariant.CreateUTF8('Add: Unexpected [%] object property in an array',[aName]); - if not(dvoIsObject in VOptions) then begin - VType := DocVariantVType; // may not be set yet - include(VOptions,dvoIsObject); - end; - end else begin - if dvoIsObject in VOptions then - raise EDocVariant.Create('Add: Unexpected array item in an object'); - if not(dvoIsArray in VOptions) then begin - VType := DocVariantVType; // may not be set yet - include(VOptions,dvoIsArray); - end; - end; - len := length(VValue); - if VCount>=len then begin - len := NextGrow(VCount); - SetLength(VValue,len); - end; - if aName<>'' then begin - if Length(VName)<>len then - SetLength(VName,len); - if dvoInternNames in VOptions then begin // inlined InternNames method - if DocVariantType.fInternNames=nil then - DocVariantType.fInternNames := TRawUTF8Interning.Create; - DocVariantType.fInternNames.Unique(VName[VCount],aName); - end else - VName[VCount] := aName; - end; - result := VCount; - inc(VCount); -end; - -procedure TDocVariantData.SetCapacity(aValue: integer); -begin - if dvoIsObject in VOptions then - SetLength(VName,aValue); - SetLength(VValue,aValue); -end; - -function TDocVariantData.AddValue(const aName: RawUTF8; - const aValue: variant; aValueOwned: boolean): integer; -begin - if dvoCheckForDuplicatedNames in VOptions then begin - result := GetValueIndex(aName); - if result>=0 then - raise EDocVariant.CreateUTF8('AddValue: Duplicated [%] name',[aName]); - end; - result := InternalAdd(aName); - if aValueOwned then - VValue[result] := aValue else - SetVariantByValue(aValue,VValue[result]); - if dvoInternValues in VOptions then - DocVariantType.InternValues.UniqueVariant(VValue[result]); -end; - -function TDocVariantData.AddValue(aName: PUTF8Char; aNameLen: integer; - const aValue: variant; aValueOwned: boolean): integer; -var tmp: RawUTF8; -begin - FastSetString(tmp,aName,aNameLen); - result := AddValue(tmp,aValue,aValueOwned); -end; - -function TDocVariantData.AddValueFromText(const aName,aValue: RawUTF8; - Update, AllowVarDouble: boolean): integer; -begin - if aName='' then begin - result := -1; - exit; - end; - result := GetValueIndex(aName); - if not Update and (dvoCheckForDuplicatedNames in VOptions) and (result>=0) then - raise EDocVariant.CreateUTF8('AddValueFromText: Duplicated [%] name',[aName]); - if result<0 then - result := InternalAdd(aName); - VarClear(VValue[result]); - if not GetNumericVariantFromJSON(pointer(aValue),TVarData(VValue[result]),AllowVarDouble) then - if dvoInternValues in VOptions then - DocVariantType.InternValues.UniqueVariant(VValue[result],aValue) else - RawUTF8ToVariant(aValue,VValue[result]); -end; - -procedure TDocVariantData.AddByPath(const aSource: TDocVariantData; - const aPaths: array of RawUTF8); -var p,added: integer; - v: TVarData; -begin - if (aSource.Count=0) or not(dvoIsObject in aSource.VOptions) or - (dvoIsArray in VOptions) then - exit; - for p := 0 to High(aPaths) do begin - DocVariantType.Lookup(v,TVarData(aSource),pointer(aPaths[p])); - if integer(v.VType)=0) and VariantEquals(VValue[result],aPropValue,aPropValueCaseSensitive) then - exit; - end else - if dvoIsArray in VOptions then - for result := 0 to VCount-1 do - with _Safe(VValue[result])^ do - if dvoIsObject in VOptions then begin - ndx := GetValueIndex(aPropName); - if (ndx>=0) and VariantEquals(VValue[ndx],aPropValue,aPropValueCaseSensitive) then - exit; - end; - result := -1; -end; - -function TDocVariantData.SearchItemByProp(const aPropNameFmt: RawUTF8; - const aPropNameArgs: array of const; const aPropValue: RawUTF8; - aPropValueCaseSensitive: boolean): integer; -var name: RawUTF8; -begin - FormatUTF8(aPropNameFmt,aPropNameArgs,name); - result := SearchItemByProp(name,aPropValue,aPropValueCaseSensitive); -end; - -function TDocVariantData.SearchItemByValue(const aValue: Variant; - CaseInsensitive: boolean; StartIndex: integer): integer; -begin - for result := StartIndex to VCount-1 do - if SortDynArrayVariantComp(TVarData(VValue[result]),TVarData(aValue),CaseInsensitive)=0 then - exit; - result := -1; -end; - -type - TQuickSortDocVariant = object - names: PPointerArray; - values: PVariantArray; - nameCompare: TUTF8Compare; - valueCompare: TVariantCompare; - procedure SortByName(L, R: PtrInt); - procedure SortByValue(L, R: PtrInt); - end; - -procedure TQuickSortDocVariant.SortByName(L, R: PtrInt); -var I, J, P: PtrInt; - pivot: pointer; -begin - if L0 do Dec(J); - if I <= J then begin - if I <> J then begin - ExchgPointer(@names[I],@names[J]); - ExchgVariant(@values[I],@values[J]); - end; - if P = I then P := J else if P = J then P := I; - inc(I); dec(J); - end; - until I > J; - if J - L < R - I then begin // use recursion only for smaller range - if L < J then - SortByName(L,J); - L := I; - end else begin - if I < R then - SortByName(I,R); - R := J; - end; - until L >= R; -end; - -procedure TQuickSortDocVariant.SortByValue(L, R: PtrInt); -var I, J, P: PtrInt; - pivot: PVariant; -begin - if L0 do Dec(J); - if I <= J then begin - if I <> J then begin - if names<>nil then - ExchgPointer(@names[I],@names[J]); - ExchgVariant(@values[I],@values[J]); - end; - if P = I then P := J else if P = J then P := I; - inc(I); dec(J); - end; - until I > J; - if J - L < R - I then begin // use recursion only for smaller range - if L < J then - SortByValue(L,J); - L := I; - end else begin - if I < R then - SortByValue(I,R); - R := J; - end; - until L >= R; -end; - -procedure TDocVariantData.SortByName(Compare: TUTF8Compare); -var qs: TQuickSortDocVariant; -begin - if not(dvoIsObject in VOptions) or (VCount<=0) then - exit; - if Assigned(Compare) then - qs.nameCompare := Compare else - qs.nameCompare := @StrIComp; - qs.names := pointer(VName); - qs.values := pointer(VValue); - qs.SortByName(0,VCount-1); -end; - -procedure TDocVariantData.SortByValue(Compare: TVariantCompare); -var qs: TQuickSortDocVariant; -begin - if VCount<=0 then - exit; - if Assigned(Compare) then - qs.valueCompare := Compare else - qs.valueCompare := @VariantCompare; - qs.names := pointer(VName); - qs.values := pointer(VValue); - qs.SortByValue(0,VCount-1); -end; - -type - {$ifdef USERECORDWITHMETHODS}TQuickSortDocVariantValuesByField = record - {$else}TQuickSortDocVariantValuesByField = object{$endif} - Lookup: array of PVariant; - Compare: TVariantCompare; - Doc: PDocVariantData; - Reverse: boolean; - procedure Sort(L, R: PtrInt); - end; - -procedure TQuickSortDocVariantValuesByField.Sort(L, R: PtrInt); -var I, J, P: PtrInt; - pivot: PVariant; -begin - if L0 do Dec(J); - end - else begin - while Compare(Lookup[I]^,pivot^)>0 do Inc(I); - while Compare(Lookup[J]^,pivot^)<0 do Dec(J); - end; - if I <= J then begin - if I <> J then begin - if Doc.VName<>nil then - ExchgPointer(@Doc.VName[I],@Doc.VName[J]); - ExchgVariant(@Doc.VValue[I],@Doc.VValue[J]); - pivot := Lookup[I]; - Lookup[I] := Lookup[J]; - Lookup[J] := pivot; - end; - if P = I then P := J else if P = J then P := I; - inc(I); dec(J); - end; - until I > J; - if J - L < R - I then begin // use recursion only for smaller range - if L < J then - Sort(L,J); - L := I; - end else begin - if I < R then - Sort(I,R); - R := J; - end; - until L >= R; -end; - -procedure TDocVariantData.SortArrayByField(const aItemPropName: RawUTF8; - aValueCompare: TVariantCompare; aValueCompareReverse: boolean; aNameSortedCompare: TUTF8Compare); -var - QS: TQuickSortDocVariantValuesByField; - p: pointer; - row: PtrInt; -begin - if (VCount<=0) or (aItemPropName='') or not (dvoIsArray in VOptions) then - exit; - if not Assigned(aValueCompare) then - QS.Compare := VariantCompare else - QS.Compare := aValueCompare; - QS.Reverse := aValueCompareReverse; - SetLength(QS.Lookup,VCount); - for row := 0 to VCount-1 do begin // resolve GetPVariantByName(aIdemPropName) once - p := _Safe(VValue[row])^.GetVarData(aItemPropName,aNameSortedCompare); - if p = nil then - p := @NullVarData; - QS.Lookup[row] := p; - end; - QS.Doc := @self; - QS.Sort(0,VCount-1); -end; - -procedure TDocVariantData.Reverse; -var arr: TDynArray; -begin - if VCount=0 then - exit; - if VName<>nil then begin - SetLength(VName,VCount); - arr.Init(TypeInfo(TRawUTF8DynArray),VName); - arr.Reverse; - end; - if VValue<>nil then begin - SetLength(VValue,VCount); - arr.Init(TypeInfo(TVariantDynArray),VValue); - arr.Reverse; - end; -end; - -function TDocVariantData.Reduce(const aPropNames: array of RawUTF8; - aCaseSensitive,aDoNotAddVoidProp: boolean): variant; -begin - VarClear(result); - Reduce(aPropNames,aCaseSensitive,PDocVariantData(@result)^,aDoNotAddVoidProp); -end; - -procedure TDocVariantData.Reduce(const aPropNames: array of RawUTF8; - aCaseSensitive: boolean; out result: TDocVariantData; aDoNotAddVoidProp: boolean); -var ndx,j: integer; - reduced: TDocVariantData; -begin - result.InitFast; - if (VCount=0) or (high(aPropNames)<0) then - exit; - if dvoIsObject in VOptions then begin - if aCaseSensitive then begin - for j := 0 to high(aPropNames) do - for ndx := 0 to VCount-1 do - if VName[ndx]=aPropNames[j] then begin - if not aDoNotAddVoidProp or not VarIsVoid(VValue[ndx]) then - result.AddValue(VName[ndx],VValue[ndx]); - break; - end; - end else - for j := 0 to high(aPropNames) do - for ndx := 0 to VCount-1 do - if IdemPropNameU(VName[ndx],aPropNames[j]) then begin - if not aDoNotAddVoidProp or not VarIsVoid(VValue[ndx]) then - result.AddValue(VName[ndx],VValue[ndx]); - break; - end; - end else - if dvoIsArray in VOptions then - for ndx := 0 to VCount-1 do begin - _Safe(VValue[ndx])^.Reduce(aPropNames,aCaseSensitive,reduced,aDoNotAddVoidProp); - if dvoIsObject in reduced.VOptions then - result.AddItem(variant(reduced)); - end; -end; - -function TDocVariantData.ReduceAsArray(const aPropName: RawUTF8; - OnReduce: TOnReducePerItem): variant; -begin - VarClear(result); - ReduceAsArray(aPropName,PDocVariantData(@result)^,OnReduce); -end; - -procedure TDocVariantData.ReduceAsArray(const aPropName: RawUTF8; - out result: TDocVariantData; OnReduce: TOnReducePerItem); -var ndx,j: integer; - item: PDocVariantData; -begin - result.InitFast; - if (VCount=0) or (aPropName='') or not(dvoIsArray in VOptions) then - exit; - for ndx := 0 to VCount-1 do begin - item := _Safe(VValue[ndx]); - j := item^.GetValueIndex(aPropName); - if j>=0 then - if not Assigned(OnReduce) or OnReduce(item) then - result.AddItem(item^.VValue[j]); - end; -end; - -function TDocVariantData.ReduceAsArray(const aPropName: RawUTF8; - OnReduce: TOnReducePerValue): variant; -begin - VarClear(result); - ReduceAsArray(aPropName,PDocVariantData(@result)^,OnReduce); -end; - -procedure TDocVariantData.ReduceAsArray(const aPropName: RawUTF8; - out result: TDocVariantData; OnReduce: TOnReducePerValue); -var ndx,j: integer; - item: PDocVariantData; - v: PVariant; -begin - result.InitFast; - if (VCount=0) or (aPropName='') or not(dvoIsArray in VOptions) then - exit; - for ndx := 0 to VCount-1 do begin - item := _Safe(VValue[ndx]); - j := item^.GetValueIndex(aPropName); - if j>=0 then begin - v := @item^.VValue[j]; - if not Assigned(OnReduce) or OnReduce(v^) then - result.AddItem(v^); - end; - end; -end; - -function TDocVariantData.Rename(const aFromPropName, aToPropName: TRawUTF8DynArray): integer; -var n, p, ndx: integer; -begin - result := 0; - n := length(aFromPropName); - if length(aToPropName)=n then - for p := 0 to n-1 do begin - ndx := GetValueIndex(aFromPropName[p]); - if ndx>=0 then begin - VName[ndx] := aToPropName[p]; - inc(result); - end; - end; -end; - -function TDocVariantData.FlattenAsNestedObject(const aObjectPropName: RawUTF8): boolean; -var ndx,len: integer; - Up: array[byte] of AnsiChar; - nested: TDocVariantData; -begin // {"p.a1":5,"p.a2":"dfasdfa"} -> {"p":{"a1":5,"a2":"dfasdfa"}} - result := false; - if (VCount=0) or (aObjectPropName='') or not(dvoIsObject in VOptions) then - exit; - PWord(UpperCopy255(Up,aObjectPropName))^ := ord('.'); // e.g. 'P.' - for ndx := 0 to Count-1 do - if not IdemPChar(pointer(VName[ndx]),Up) then - exit; // all fields should match "p.####" - len := length(aObjectPropName)+1; - for ndx := 0 to Count-1 do - system.delete(VName[ndx],1,len); - nested := self; - Clear; - InitObject([aObjectPropName,variant(nested)]); - result := true; -end; - -function TDocVariantData.Delete(Index: integer): boolean; -begin - if cardinal(Index)>=cardinal(VCount) then - result := false else begin - dec(VCount); - if VName<>nil then begin - if PDACnt(PtrUInt(VName)-_DAREFCNT)^>1 then - DynArrayMakeUnique(@VName,TypeInfo(TRawUTF8DynArray)); - VName[Index] := ''; - end; - if PDACnt(PtrUInt(VValue)-_DAREFCNT)^>1 then - DynArrayMakeUnique(@VValue,TypeInfo(TVariantDynArray)); - VarClear(VValue[Index]); - if Indexnil then begin - MoveFast(VName[Index+1],VName[Index],(VCount-Index)*SizeOf(pointer)); - PtrUInt(VName[VCount]) := 0; // avoid GPF - end; - MoveFast(VValue[Index+1],VValue[Index],(VCount-Index)*SizeOf(variant)); - TVarData(VValue[VCount]).VType := varEmpty; // avoid GPF - end; - result := true; - end; -end; - -function TDocVariantData.Delete(const aName: RawUTF8): boolean; -begin - result := Delete(GetValueIndex(aName)); -end; - -function TDocVariantData.DeleteByProp(const aPropName,aPropValue: RawUTF8; - aPropValueCaseSensitive: boolean): boolean; -var ndx: integer; -begin - ndx := SearchItemByProp(aPropName,aPropValue,aPropValueCaseSensitive); - if ndx<0 then - result := false else - result := Delete(ndx); -end; - -function TDocVariantData.DeleteByValue(const aValue: Variant; - CaseInsensitive: boolean): integer; -var ndx: PtrInt; -begin - result := 0; - if VarIsEmptyOrNull(aValue) then begin - for ndx := VCount-1 downto 0 do - if VarDataIsEmptyOrNull(@VValue[ndx]) then begin - Delete(ndx); - inc(result); - end; - end else - for ndx := VCount-1 downto 0 do - if SortDynArrayVariantComp(TVarData(VValue[ndx]),TVarData(aValue),CaseInsensitive)=0 then begin - Delete(ndx); - inc(result); - end; -end; - -function TDocVariantData.DeleteByStartName(aStartName: PUTF8Char; aStartNameLen: integer): integer; -var ndx: integer; - upname: array[byte] of AnsiChar; -begin - result := 0; - if aStartNameLen=0 then - aStartNameLen := StrLen(aStartName); - if (VCount=0) or not(dvoIsObject in VOptions) or (aStartNameLen=0) then - exit; - UpperCopy255Buf(upname,aStartName,aStartNameLen)^ := #0; - for ndx := Count-1 downto 0 do - if IdemPChar(pointer(names[ndx]),upname) then begin - Delete(ndx); - inc(result); - end; -end; - -function FindNonVoidRawUTF8(n: PPtrInt; name: PUTF8Char; len: TStrLen; count: PtrInt): PtrInt; -begin // FPC does proper inlining in this loop - for result := 0 to count-1 do // all VName[]<>'' so n^<>0 - if (PStrLen(n^-_STRLEN)^=len) and CompareMemFixed(pointer(n^),name,len) then - exit else - inc(n); - result := -1; -end; - -function FindNonVoidRawUTF8I(n: PPtrInt; name: PUTF8Char; len: TStrLen; count: PtrInt): PtrInt; -begin - for result := 0 to count-1 do - if (PStrLen(n^-_STRLEN)^=len) and IdemPropNameUSameLen(pointer(n^),name,len) then - exit else - inc(n); - result := -1; -end; - -function TDocVariantData.GetValueIndex(aName: PUTF8Char; aNameLen: PtrInt; - aCaseSensitive: boolean): integer; -var err: integer; -begin - if (integer(VType)=DocVariantVType) and (VCount>0) and (aName<>nil) and(aNameLen>0) then - if dvoIsArray in VOptions then begin // try index text in array document - result := GetInteger(aName,err); - if (err<>0) or (cardinal(result)>=cardinal(VCount)) then - result := -1; - end else - // O(n) lookup for object names -> efficient brute force sub-functions - if aCaseSensitive then - result := FindNonVoidRawUTF8(pointer(VName),aName,aNameLen,VCount) else - result := FindNonVoidRawUTF8I(pointer(VName),aName,aNameLen,VCount) else - result := -1; -end; - -function TDocVariantData.GetValueOrRaiseException(const aName: RawUTF8): variant; -begin - RetrieveValueOrRaiseException(pointer(aName),length(aName), - dvoNameCaseSensitive in VOptions,result,false); -end; - -function TDocVariantData.GetValueOrDefault(const aName: RawUTF8; - const aDefault: variant): variant; -var ndx: integer; -begin - if (integer(VType)<>DocVariantVType) or not(dvoIsObject in VOptions) then - result := aDefault else begin - ndx := GetValueIndex(aName); - if ndx>=0 then - result := VValue[ndx] else - result := aDefault; - end; -end; - -function TDocVariantData.GetValueOrNull(const aName: RawUTF8): variant; -var ndx: integer; -begin - if (integer(VType)<>DocVariantVType) or not(dvoIsObject in VOptions) then - SetVariantNull(result) else begin - ndx := GetValueIndex(aName); - if ndx>=0 then - result := VValue[ndx] else - SetVariantNull(result); - end; -end; - -function TDocVariantData.GetValueOrEmpty(const aName: RawUTF8): variant; -var ndx: integer; -begin - VarClear(result); - if (integer(VType)=DocVariantVType) and (dvoIsObject in VOptions) then begin - ndx := GetValueIndex(aName); - if ndx>=0 then - result := VValue[ndx]; - end; -end; - -function TDocVariantData.GetAsBoolean(const aName: RawUTF8; out aValue: boolean; - aSortedCompare: TUTF8Compare): Boolean; -var found: PVarData; -begin - found := GetVarData(aName,aSortedCompare); - if found=nil then - result := false else - result := VariantToBoolean(PVariant(found)^,aValue) -end; - -function TDocVariantData.GetAsInteger(const aName: RawUTF8; out aValue: integer; - aSortedCompare: TUTF8Compare): Boolean; -var found: PVarData; -begin - found := GetVarData(aName,aSortedCompare); - if found=nil then - result := false else - result := VariantToInteger(PVariant(found)^,aValue); -end; - -function TDocVariantData.GetAsInt64(const aName: RawUTF8; out aValue: Int64; - aSortedCompare: TUTF8Compare): Boolean; -var found: PVarData; -begin - found := GetVarData(aName,aSortedCompare); - if found=nil then - result := false else - result := VariantToInt64(PVariant(found)^,aValue) -end; - -function TDocVariantData.GetAsDouble(const aName: RawUTF8; out aValue: double; - aSortedCompare: TUTF8Compare): Boolean; -var found: PVarData; -begin - found := GetVarData(aName,aSortedCompare); - if found=nil then - result := false else - result := VariantToDouble(PVariant(found)^,aValue); -end; - -function TDocVariantData.GetAsRawUTF8(const aName: RawUTF8; out aValue: RawUTF8; - aSortedCompare: TUTF8Compare): Boolean; -var found: PVarData; - wasString: boolean; -begin - found := GetVarData(aName,aSortedCompare); - if found=nil then - result := false else begin - if integer(found^.VType)>varNull then // default VariantToUTF8(null)='null' - VariantToUTF8(PVariant(found)^,aValue,wasString); - result := true; - end; -end; - -function TDocVariantData.GetValueEnumerate(const aName: RawUTF8; - aTypeInfo: pointer; out aValue; aDeleteFoundEntry: boolean): boolean; -var text: RawUTF8; - ndx, ord: integer; -begin - result := false; - ndx := GetValueIndex(aName); - if ndx<0 then - exit; - VariantToUTF8(Values[ndx],text); - ord := GetEnumNameValue(aTypeInfo,text,true); - if ord<0 then - exit; - byte(aValue) := ord; - if aDeleteFoundEntry then - Delete(ndx); - result := true; -end; - -function TDocVariantData.GetAsDocVariant(const aName: RawUTF8; out aValue: PDocVariantData; - aSortedCompare: TUTF8Compare): boolean; -var found: PVarData; -begin - found := GetVarData(aName,aSortedCompare); - if found=nil then - result := false else begin - aValue := _Safe(PVariant(found)^); - result := aValue<>@DocVariantDataFake; - end; -end; - -function TDocVariantData.GetAsDocVariantSafe(const aName: RawUTF8; - aSortedCompare: TUTF8Compare): PDocVariantData; -var found: PVarData; -begin - found := GetVarData(aName,aSortedCompare); - if found=nil then - result := @DocVariantDataFake else - result := _Safe(PVariant(found)^); -end; - -function TDocVariantData.GetAsPVariant(const aName: RawUTF8; out aValue: PVariant; - aSortedCompare: TUTF8Compare): boolean; -begin - aValue := pointer(GetVarData(aName,aSortedCompare)); - result := aValue<>nil; -end; - -function TDocVariantData.GetAsPVariant(aName: PUTF8Char; aNameLen: PtrInt): PVariant; -var ndx: integer; -begin - ndx := GetValueIndex(aName,aNameLen,dvoNameCaseSensitive in VOptions); - if ndx>=0 then - result := @VValue[ndx] else - result := nil; -end; - -function TDocVariantData.GetVarData(const aName: RawUTF8; - aSortedCompare: TUTF8Compare): PVarData; -var ndx: integer; -begin - if (integer(VType)<>DocVariantVType) or not(dvoIsObject in VOptions) or - (VCount=0) or (aName='') then - result := nil else begin - if Assigned(aSortedCompare) then - if @aSortedCompare=@StrComp then // to use branchless asm for StrComp() - ndx := FastFindPUTF8CharSorted(pointer(VName),VCount-1,pointer(aName)) else - ndx := FastFindPUTF8CharSorted(pointer(VName),VCount-1,pointer(aName),aSortedCompare) else - if dvoNameCaseSensitive in VOptions then - ndx := FindNonVoidRawUTF8(pointer(VName),pointer(aName),length(aName),VCount) else - ndx := FindNonVoidRawUTF8I(pointer(VName),pointer(aName),length(aName),VCount); - if ndx>=0 then - result := @VValue[ndx] else - result := nil; - end; -end; - -function TDocVariantData.GetVarData(const aName: RawUTF8; - var aValue: TVarData; aSortedCompare: TUTF8Compare): boolean; -var found: PVarData; -begin - found := GetVarData(aName,aSortedCompare); - if found=nil then - result := false else begin - aValue := found^; - result := true; - end; -end; - -function TDocVariantData.GetValueByPath(const aPath: RawUTF8): variant; -var Dest: TVarData; -begin - VarClear(result); - if (integer(VType)<>DocVariantVType) or not(dvoIsObject in VOptions) then - exit; - DocVariantType.Lookup(Dest,TVarData(self),pointer(aPath)); - if integer(Dest.VType)>=varNull then - result := variant(Dest); // copy -end; - -function TDocVariantData.GetValueByPath(const aPath: RawUTF8; out aValue: variant): boolean; -var Dest: TVarData; -begin - result := false; - if (integer(VType)<>DocVariantVType) or not(dvoIsObject in VOptions) then - exit; - DocVariantType.Lookup(Dest,TVarData(self),pointer(aPath)); - if Dest.VType=varEmpty then - exit; - aValue := variant(Dest); // copy - result := true; -end; - -function TDocVariantData.GetPVariantByPath(const aPath: RawUTF8): PVariant; -var p: PUTF8Char; - item: RawUTF8; - par: PVariant; -begin - result := nil; - if (integer(VType)<>DocVariantVType) or (aPath='') or - not(dvoIsObject in VOptions) or (Count=0) then - exit; - par := @self; - P := pointer(aPath); - repeat - GetNextItem(P,'.',item); - if _Safe(par^).GetAsPVariant(item,result) then - par := result else begin - result := nil; - exit; - end; - until P=nil; - // if we reached here, we have par=result=found item -end; - -function TDocVariantData.GetDocVariantByPath(const aPath: RawUTF8; - out aValue: PDocVariantData): boolean; -var v: PVariant; -begin - v := GetPVariantByPath(aPath); - if v<>nil then begin - aValue := _Safe(v^); - result := integer(aValue^.VType)>varNull; - end else - result := false; -end; - -function TDocVariantData.GetValueByPath(const aDocVariantPath: array of RawUTF8): variant; -var found,res: PVarData; - vt,P: integer; -begin - VarClear(result); - if (integer(VType)<>DocVariantVType) or not(dvoIsObject in VOptions) or - (high(aDocVariantPath)<0) then - exit; - found := @self; - P := 0; - repeat - found := PDocVariantData(found).GetVarData(aDocVariantPath[P]); - if found=nil then - exit; - if P=high(aDocVariantPath) then - break; // we found the item! - inc(P); - // if we reached here, we should try for the next scope within Dest - repeat - vt := found^.VType; - if vt<>varByRef or varVariant then - break; - found := found^.VPointer; - until false; - if vt=VType then - continue; - exit; - until false; - res := found; - while integer(res^.VType)=varByRef or varVariant do - res := res^.VPointer; - if (integer(res^.VType)=VType) and (PDocVariantData(res)^.VCount=0) then - // return void TDocVariant as null - TVarData(result).VType := varNull else - // copy found value - result := PVariant(found)^; -end; - -function TDocVariantData.GetItemByProp(const aPropName,aPropValue: RawUTF8; - aPropValueCaseSensitive: boolean; var Dest: variant; DestByRef: boolean): boolean; -var ndx: integer; -begin - result := false; - if not(dvoIsArray in VOptions) then - exit; - ndx := SearchItemByProp(aPropName,aPropValue,aPropValueCaseSensitive); - if ndx<0 then - exit; - RetrieveValueOrRaiseException(ndx,Dest,DestByRef); - result := true; -end; - -function TDocVariantData.GetDocVariantByProp(const aPropName,aPropValue: RawUTF8; - aPropValueCaseSensitive: boolean; out Dest: PDocVariantData): boolean; -var ndx: integer; -begin - result := false; - if not(dvoIsArray in VOptions) then - exit; - ndx := SearchItemByProp(aPropName,aPropValue,aPropValueCaseSensitive); - if ndx<0 then - exit; - Dest := _Safe(VValue[ndx]); - result := Dest^.VType>varNull; -end; - -function TDocVariantData.GetJsonByStartName(const aStartName: RawUTF8): RawUTF8; -var Up: array[byte] of AnsiChar; - temp: TTextWriterStackBuffer; - ndx: integer; - W: TTextWriter; -begin - if not(dvoIsObject in VOptions) or (VCount=0) then begin - result := NULL_STR_VAR; - exit; - end; - UpperCopy255(Up,aStartName)^ := #0; - W := DefaultTextWriterSerializer.CreateOwnedStream(temp); - try - W.Add('{'); - for ndx := 0 to VCount-1 do - if IdemPChar(Pointer(VName[ndx]),Up) then begin - if (dvoSerializeAsExtendedJson in VOptions) and - JsonPropNameValid(pointer(VName[ndx])) then begin - W.AddNoJSONEscape(pointer(VName[ndx]),Length(VName[ndx])); - end else begin - W.Add('"'); - W.AddJSONEscape(pointer(VName[ndx])); - W.Add('"'); - end; - W.Add(':'); - W.AddVariant(VValue[ndx],twJSONEscape); - W.Add(','); - end; - W.CancelLastComma; - W.Add('}'); - W.SetText(result); - finally - W.Free; - end; -end; - -function TDocVariantData.GetValuesByStartName(const aStartName: RawUTF8; - TrimLeftStartName: boolean): variant; -var Up: array[byte] of AnsiChar; - ndx: integer; - name: RawUTF8; -begin - if aStartName='' then begin - result := Variant(self); - exit; - end; - if not(dvoIsObject in VOptions) or (VCount=0) then begin - SetVariantNull(result); - exit; - end; - TDocVariant.NewFast(result); - UpperCopy255(Up,aStartName)^ := #0; - for ndx := 0 to VCount-1 do - if IdemPChar(Pointer(VName[ndx]),Up) then begin - name := VName[ndx]; - if TrimLeftStartName then - system.delete(name,1,length(aStartName)); - TDocVariantData(result).AddValue(name,VValue[ndx]); - end; -end; - -procedure TDocVariantData.SetValueOrRaiseException(Index: integer; const NewValue: variant); -begin - if cardinal(Index)>=cardinal(VCount) then - raise EDocVariant.CreateUTF8('Out of range Values[%] (count=%)',[Index,VCount]) else - VValue[Index] := NewValue; -end; - -procedure TDocVariantData.RetrieveNameOrRaiseException(Index: integer; - var Dest: RawUTF8); -begin - if (cardinal(Index)>=cardinal(VCount)) or (VName=nil) then - if dvoReturnNullForUnknownProperty in VOptions then - Dest := '' else - raise EDocVariant.CreateUTF8('Out of range Names[%] (count=%)',[Index,VCount]) else - Dest := VName[Index]; -end; - -procedure TDocVariantData.RetrieveValueOrRaiseException(Index: integer; - var Dest: variant; DestByRef: boolean); -var Source: PVariant; -begin - if cardinal(Index)>=cardinal(VCount) then - if dvoReturnNullForUnknownProperty in VOptions then - SetVariantNull(Dest) else - raise EDocVariant.CreateUTF8('Out of range Values[%] (count=%)',[Index,VCount]) else - if DestByRef then - SetVariantByRef(VValue[Index],Dest) else begin - Source := @VValue[Index]; - while PVarData(Source)^.VType=varVariant or varByRef do - Source := PVarData(Source)^.VPointer; - Dest := Source^; - end; -end; - -function TDocVariantData.RetrieveValueOrRaiseException( - aName: PUTF8Char; aNameLen: integer; aCaseSensitive: boolean; - var Dest: variant; DestByRef: boolean): boolean; -var ndx: Integer; -begin - ndx := GetValueIndex(aName,aNameLen,aCaseSensitive); - if ndx<0 then - if dvoReturnNullForUnknownProperty in VOptions then - SetVariantNull(Dest) else - raise EDocVariant.CreateUTF8('[%] property not found',[aName]) else - RetrieveValueOrRaiseException(ndx,Dest,DestByRef); - result := ndx>=0; -end; - -function TDocVariantData.GetValueOrItem(const aNameOrIndex: variant): variant; -var wasString: boolean; - Name: RawUTF8; -begin - if dvoIsArray in VOptions then // fast index lookup e.g. for Value[1] - RetrieveValueOrRaiseException(VariantToIntegerDef(aNameOrIndex,-1),result,true) else begin - VariantToUTF8(aNameOrIndex,Name,wasString); // by name lookup e.g. for Value['abc'] - if wasString then - RetrieveValueOrRaiseException(pointer(Name),length(Name), - dvoNameCaseSensitive in VOptions,result,true) else - RetrieveValueOrRaiseException(GetIntegerDef(pointer(Name),-1),result,true); - end; -end; - -procedure TDocVariantData.SetValueOrItem(const aNameOrIndex, aValue: variant); -var wasString: boolean; - ndx: integer; - Name: RawUTF8; -begin - if dvoIsArray in VOptions then // fast index lookup e.g. for Value[1] - SetValueOrRaiseException(VariantToIntegerDef(aNameOrIndex,-1),aValue) else begin - VariantToUTF8(aNameOrIndex,Name,wasString); // by name lookup e.g. for Value['abc'] - if wasString then begin - ndx := GetValueIndex(Name); - if ndx<0 then - ndx := InternalAdd(Name); - SetVariantByValue(aValue,VValue[ndx]); - if dvoInternValues in VOptions then - DocVariantType.InternValues.UniqueVariant(VValue[ndx]); - end else - SetValueOrRaiseException(VariantToIntegerDef(aNameOrIndex,-1),aValue); - end; -end; - -function TDocVariantData.AddOrUpdateValue(const aName: RawUTF8; - const aValue: variant; wasAdded: PBoolean; OnlyAddMissing: boolean): integer; -begin - if dvoIsArray in VOptions then - raise EDocVariant.CreateUTF8('AddOrUpdateValue("%") on an array',[aName]); - result := GetValueIndex(aName); - if result<0 then begin - result := InternalAdd(aName); - if wasAdded<>nil then - wasAdded^ := true; - end else begin - if wasAdded<>nil then - wasAdded^ := false; - if OnlyAddMissing then - exit; - end; - SetVariantByValue(aValue,VValue[result]); - if dvoInternValues in VOptions then - DocVariantType.InternValues.UniqueVariant(VValue[result]); -end; - -function TDocVariantData.ToJSON(const Prefix, Suffix: RawUTF8; - Format: TTextWriterJSONFormat): RawUTF8; -var W: TTextWriter; - temp: TTextWriterStackBuffer; -begin - if (integer(VType)<>DocVariantVType) and (VType>varNull) then begin - result := ''; // null -> 'null' - exit; - end; - W := DefaultTextWriterSerializer.CreateOwnedStream(temp); - try - W.AddString(Prefix); - DocVariantType.ToJSON(W,variant(self),twJSONEscape); - W.AddString(Suffix); - W.SetText(result, Format); - finally - W.Free; - end; -end; - -function TDocVariantData.ToNonExpandedJSON: RawUTF8; -var fields: TRawUTF8DynArray; - fieldsCount: integer; - W: TTextWriter; - r,f: integer; - row: PDocVariantData; - temp: TTextWriterStackBuffer; -begin - fields := nil; // to please Kylix - fieldsCount := 0; - if not(dvoIsArray in VOptions) then begin - result := ''; - exit; - end; - if VCount=0 then begin - result := '[]'; - exit; - end; - with _Safe(VValue[0])^ do - if dvoIsObject in VOptions then begin - fields := VName; - fieldsCount := VCount; - end; - if fieldsCount=0 then - raise EDocVariant.Create('ToNonExpandedJSON: Value[0] is not an object'); - W := DefaultTextWriterSerializer.CreateOwnedStream(temp); - try - W.Add('{"fieldCount":%,"rowCount":%,"values":[',[fieldsCount,VCount]); - for f := 0 to fieldsCount-1 do begin - W.Add('"'); - W.AddJSONEscape(pointer(fields[f])); - W.Add('"',','); - end; - for r := 0 to VCount-1 do begin - row := _Safe(VValue[r]); - if (r>0) and (not(dvoIsObject in row^.VOptions) or (row^.VCount<>fieldsCount)) then - raise EDocVariant.CreateUTF8('ToNonExpandedJSON: Value[%] not expected object',[r]); - for f := 0 to fieldsCount-1 do - if (r>0) and not IdemPropNameU(row^.VName[f],fields[f]) then - raise EDocVariant.CreateUTF8('ToNonExpandedJSON: Value[%] field=% expected=%', - [r,row^.VName[f],fields[f]]) else begin - W.AddVariant(row^.VValue[f],twJSONEscape); - W.Add(','); - end; - end; - W.CancelLastComma; - W.Add(']','}'); - W.SetText(result); - finally - W.Free; - end; -end; - -procedure TDocVariantData.ToRawUTF8DynArray(out Result: TRawUTF8DynArray); -var ndx: integer; - wasString: boolean; -begin - if dvoIsObject in VOptions then - raise EDocVariant.Create('ToRawUTF8DynArray expects a dvArray'); - if dvoIsArray in VOptions then begin - SetLength(Result,VCount); - for ndx := 0 to VCount-1 do - VariantToUTF8(VValue[ndx],Result[ndx],wasString); - end; -end; - -function TDocVariantData.ToRawUTF8DynArray: TRawUTF8DynArray; -begin - ToRawUTF8DynArray(result); -end; - -function TDocVariantData.ToCSV(const Separator: RawUTF8): RawUTF8; -var tmp: TRawUTF8DynArray; // fast enough in practice -begin - ToRawUTF8DynArray(tmp); - result := RawUTF8ArrayToCSV(tmp,Separator); -end; - -procedure TDocVariantData.ToTextPairsVar(out result: RawUTF8; - const NameValueSep, ItemSep: RawUTF8; escape: TTextWriterKind); -var ndx: integer; - temp: TTextWriterStackBuffer; -begin - if dvoIsArray in VOptions then - raise EDocVariant.Create('ToTextPairs expects a dvObject'); - if (VCount>0) and (dvoIsObject in VOptions) then - with DefaultTextWriterSerializer.CreateOwnedStream(temp) do - try - ndx := 0; - repeat - AddString(VName[ndx]); - AddString(NameValueSep); - AddVariant(VValue[ndx],escape); - inc(ndx); - if ndx=VCount then - break; - AddString(ItemSep); - until false; - SetText(result); - finally - Free; - end; -end; - -function TDocVariantData.ToTextPairs(const NameValueSep: RawUTF8; - const ItemSep: RawUTF8; Escape: TTextWriterKind): RawUTF8; -begin - ToTextPairsVar(result,NameValueSep,ItemSep,escape); -end; - -procedure TDocVariantData.ToArrayOfConst(out Result: TTVarRecDynArray); -var ndx: integer; -begin - if dvoIsObject in VOptions then - raise EDocVariant.Create('ToArrayOfConst expects a dvArray'); - if dvoIsArray in VOptions then begin - SetLength(Result,VCount); - for ndx := 0 to VCount-1 do begin - Result[ndx].VType := vtVariant; - Result[ndx].VVariant := @VValue[ndx]; - end; - end; -end; - -function TDocVariantData.ToArrayOfConst: TTVarRecDynArray; -begin - ToArrayOfConst(result); -end; - -function TDocVariantData.ToUrlEncode(const UriRoot: RawUTF8): RawUTF8; -var json: RawUTF8; // temporary in-place modified buffer -begin - VariantSaveJSON(variant(self),twJSONEscape,json); - result := UrlEncodeJsonObject(UriRoot,Pointer(json),[]); -end; - -function TDocVariantData.GetOrAddIndexByName(const aName: RawUTF8): integer; -begin - result := GetValueIndex(aName); - if result<0 then - result := InternalAdd(aName); -end; - -function TDocVariantData.GetOrAddPVariantByName(const aName: RawUTF8): PVariant; -var ndx: integer; -begin - ndx := GetValueIndex(aName); - if ndx<0 then - ndx := InternalAdd(aName); - result := @VValue[ndx]; -end; - -function TDocVariantData.GetPVariantByName(const aName: RawUTF8): PVariant; -var ndx: Integer; -begin - ndx := GetValueIndex(aName); - if ndx<0 then - if dvoReturnNullForUnknownProperty in VOptions then - result := @DocVariantDataFake else - raise EDocVariant.CreateUTF8('[%] property not found',[aName]) else - result := @VValue[ndx]; -end; - -function TDocVariantData.GetInt64ByName(const aName: RawUTF8): Int64; -begin - if not VariantToInt64(GetPVariantByName(aName)^,result) then - result := 0; -end; - -function TDocVariantData.GetRawUTF8ByName(const aName: RawUTF8): RawUTF8; -var wasString: boolean; - v: PVariant; -begin - v := GetPVariantByName(aName); - if PVarData(v)^.VType<=varNull then // default VariantToUTF8(null)='null' - result := '' else - VariantToUTF8(v^,result,wasString); -end; - -function TDocVariantData.GetStringByName(const aName: RawUTF8): string; -begin - result := VariantToString(GetPVariantByName(aName)^); -end; - -procedure TDocVariantData.SetInt64ByName(const aName: RawUTF8; - const aValue: Int64); -begin - GetOrAddPVariantByName(aName)^ := aValue; -end; - -procedure TDocVariantData.SetRawUTF8ByName(const aName, aValue: RawUTF8); -begin - RawUTF8ToVariant(aValue,GetOrAddPVariantByName(aName)^); -end; - -procedure TDocVariantData.SetStringByName(const aName: RawUTF8; const aValue: string); -begin - RawUTF8ToVariant(StringToUTF8(aValue),GetOrAddPVariantByName(aName)^); -end; - -function TDocVariantData.GetBooleanByName(const aName: RawUTF8): Boolean; -begin - if not VariantToBoolean(GetPVariantByName(aName)^,result) then - result := false; -end; - -procedure TDocVariantData.SetBooleanByName(const aName: RawUTF8; aValue: Boolean); -begin - GetOrAddPVariantByName(aName)^ := aValue; -end; - -function TDocVariantData.GetDoubleByName(const aName: RawUTF8): Double; -begin - if not VariantToDouble(GetPVariantByName(aName)^,result) then - result := 0; -end; - -procedure TDocVariantData.SetDoubleByName(const aName: RawUTF8; - const aValue: Double); -begin - GetOrAddPVariantByName(aName)^ := aValue; -end; - -function TDocVariantData.GetDocVariantExistingByName(const aName: RawUTF8; - aNotMatchingKind: TDocVariantKind): PDocVariantData; -begin - result := GetAsDocVariantSafe(aName); - if result^.Kind=aNotMatchingKind then - result := @DocVariantDataFake; -end; - -function TDocVariantData.GetDocVariantOrAddByName(const aName: RawUTF8; - aKind: TDocVariantKind): PDocVariantData; -var ndx: integer; -begin - ndx := GetOrAddIndexByName(aName); - result := _Safe(VValue[ndx]); - if result^.Kind<>aKind then begin - result := @VValue[ndx]; - VarClear(PVariant(result)^); - result^.Init(JSON_OPTIONS_FAST,aKind); - end; -end; - -function TDocVariantData.GetObjectExistingByName(const aName: RawUTF8): PDocVariantData; -begin - result := GetDocVariantExistingByName(aName,dvArray); -end; - -function TDocVariantData.GetObjectOrAddByName(const aName: RawUTF8): PDocVariantData; -begin - result := GetDocVariantOrAddByName(aName,dvObject); -end; - -function TDocVariantData.GetArrayExistingByName(const aName: RawUTF8): PDocVariantData; -begin - result := GetDocVariantExistingByName(aName,dvObject); -end; - -function TDocVariantData.GetArrayOrAddByName(const aName: RawUTF8): PDocVariantData; -begin - result := GetDocVariantOrAddByName(aName,dvArray); -end; - -function TDocVariantData.GetAsDocVariantByIndex(aIndex: integer): PDocVariantData; -begin - if cardinal(aIndex)4) and (Name[0]='_') and - IntGetPseudoProp(IdemPCharArray(@Name[1],['COUNT','KIND','JSON']),dv,variant(Dest)) then - result := true else - result := dv.RetrieveValueOrRaiseException(pointer(Name),NameLen, - dvoNameCaseSensitive in dv.VOptions,PVariant(@Dest)^,{byref=}true); -end; - -function TDocVariant.IntSet(const Instance, Value: TVarData; - Name: PAnsiChar; NameLen: PtrInt): boolean; -var ndx: Integer; - aName: RawUTF8; - dv: TDocVariantData absolute Instance; -begin - result := true; - if (dvoIsArray in dv.VOptions) and (PWord(Name)^=ord('_')) then begin - ndx := dv.InternalAdd(''); - SetVariantByValue(variant(Value),dv.VValue[ndx]); - if dvoInternValues in dv.VOptions then - DocVariantType.InternValues.UniqueVariant(dv.VValue[ndx]); - exit; - end; - ndx := dv.GetValueIndex(pointer(Name),NameLen,dvoNameCaseSensitive in dv.VOptions); - if ndx<0 then begin - FastSetString(aName,Name,NameLen); - ndx := dv.InternalAdd(aName); - end; - SetVariantByValue(variant(Value),dv.VValue[ndx]); - if dvoInternValues in dv.VOptions then - DocVariantType.InternValues.UniqueVariant(dv.VValue[ndx]); -end; - -function TDocVariant.IterateCount(const V: TVarData): integer; -var Data: TDocVariantData absolute V; -begin - if dvoIsArray in Data.VOptions then - result := Data.VCount else - result := -1; -end; - -procedure TDocVariant.Iterate(var Dest: TVarData; const V: TVarData; Index: integer); -var Data: TDocVariantData absolute V; -begin - if (dvoIsArray in Data.VOptions) and (cardinal(Index) read/only - 0: if SameText(Name,'Clear') then begin - Data^.VCount := 0; - Data^.VOptions := Data^.VOptions-[dvoIsObject,dvoIsArray]; - exit; - end; {$endif FPC} - 1: {$ifndef FPC} if SameText(Name,'Add') then begin - ndx := Data^.InternalAdd(''); - SetVariantByValue(variant(Arguments[0]),Data^.VValue[ndx]); - if dvoInternValues in Data^.VOptions then - DocVariantType.InternValues.UniqueVariant(Data^.VValue[ndx]); - exit; - end else - if SameText(Name,'Delete') then begin - SetTempFromFirstArgument; - Data^.Delete(Data^.GetValueIndex(temp)); - exit; - end else {$endif FPC} - if SameText(Name,'Exists') then begin - SetTempFromFirstArgument; - variant(Dest) := Data^.GetValueIndex(temp)>=0; - exit; - end else - if SameText(Name,'NameIndex') then begin - SetTempFromFirstArgument; - variant(Dest) := Data^.GetValueIndex(temp); - exit; - end else - if VariantToInteger(variant(Arguments[0]),ndx) then begin - if (Name='_') or SameText(Name,'Value') then begin - Data^.RetrieveValueOrRaiseException(ndx,variant(Dest),true); - exit; - end else - if SameText(Name,'Name') then begin - Data^.RetrieveNameOrRaiseException(ndx,temp); - RawUTF8ToVariant(temp,variant(Dest)); - exit; - end; - end else - if (Name='_') or SameText(Name,'Value') then begin - SetTempFromFirstArgument; - Data^.RetrieveValueOrRaiseException(pointer(temp),length(temp), - dvoNameCaseSensitive in Data^.VOptions,variant(Dest),true); - exit; - end; - 2:{$ifndef FPC} if SameText(Name,'Add') then begin - SetTempFromFirstArgument; - ndx := Data^.InternalAdd(temp); - SetVariantByValue(variant(Arguments[1]),Data^.VValue[ndx]); - if dvoInternValues in Data^.VOptions then - DocVariantType.InternValues.UniqueVariant(Data^.VValue[ndx]); - exit; - end; {$endif FPC} - end; - result := false; -end; - -procedure TDocVariant.ToJSON(W: TTextWriter; const Value: variant; - escape: TTextWriterKind); -var ndx: integer; - vt: cardinal; - forced: TTextWriterOptions; - checkExtendedPropName: boolean; -begin - vt := TDocVariantData(Value).VType; - if vt>varNull then - if vt=cardinal(DocVariantVType) then - with TDocVariantData(Value) do - if [dvoIsArray,dvoIsObject]*VOptions=[] then - W.AddShort('null') else begin - if [twoForceJSONExtended,twoForceJSONStandard]*W.CustomOptions=[] then begin - if dvoSerializeAsExtendedJson in VOptions then - forced := [twoForceJSONExtended] else - forced := [twoForceJSONStandard]; - W.CustomOptions := W.CustomOptions+forced; - end else - forced := []; - if dvoIsObject in VOptions then begin - checkExtendedPropName := twoForceJSONExtended in W.CustomOptions; - W.Add('{'); - for ndx := 0 to VCount-1 do begin - if checkExtendedPropName and JsonPropNameValid(pointer(VName[ndx])) then begin - W.AddNoJSONEscape(pointer(VName[ndx]),Length(VName[ndx])); - end else begin - W.Add('"'); - W.AddJSONEscape(pointer(VName[ndx])); - W.Add('"'); - end; - W.Add(':'); - W.AddVariant(VValue[ndx],twJSONEscape); - W.Add(','); - end; - W.CancelLastComma; - W.Add('}'); - end else begin - W.Add('['); - for ndx := 0 to VCount-1 do begin - W.AddVariant(VValue[ndx],twJSONEscape); - W.Add(','); - end; - W.CancelLastComma; - W.Add(']'); - end; - if forced<>[] then - W.CustomOptions := W.CustomOptions-forced; - end else - raise ESynException.CreateUTF8('Unexpected variant type %',[vt]) else - W.AddShort('null'); -end; - -procedure TDocVariant.Clear(var V: TVarData); -var dv: TDocVariantData absolute V; -begin - //Assert(V.VType=DocVariantVType); - RawUTF8DynArrayClear(dv.VName); - VariantDynArrayClear(dv.VValue); - ZeroFill(@V); // will set V.VType := varEmpty and VCount=0 -end; - -procedure TDocVariant.Copy(var Dest: TVarData; const Source: TVarData; - const Indirect: Boolean); -begin - //Assert(Source.VType=DocVariantVType); - if Indirect then - SimplisticCopy(Dest,Source,true) else - if dvoValueCopiedByReference in TDocVariantData(Source).Options then begin - VarClear(variant(Dest)); // Dest may be a complex type - pointer(TDocVariantData(Dest).VName) := nil; // avoid GPF - pointer(TDocVariantData(Dest).VValue) := nil; - TDocVariantData(Dest) := TDocVariantData(Source); // copy whole record - end else - CopyByValue(Dest,Source); -end; - -procedure TDocVariant.CopyByValue(var Dest: TVarData; const Source: TVarData); -var S: TDocVariantData absolute Source; - D: TDocVariantData absolute Dest; - i: integer; -begin - //Assert(Source.VType=DocVariantVType); - VarClear(variant(Dest)); // Dest may be a complex type - D.VType := S.VType; - D.VOptions := S.VOptions; // copies also Kind - D.VCount := S.VCount; - pointer(D.VName) := nil; // avoid GPF - pointer(D.VValue) := nil; - if S.VCount=0 then - exit; // no data to copy - D.VName := S.VName; // names can always be safely copied - // slower but safe by-value copy - SetLength(D.VValue,S.VCount); - for i := 0 to S.VCount-1 do - D.VValue[i] := S.VValue[i]; -end; - -procedure TDocVariant.Cast(var Dest: TVarData; const Source: TVarData); -begin - CastTo(Dest,Source,VarType); -end; - -procedure TDocVariant.CastTo(var Dest: TVarData; - const Source: TVarData; const AVarType: TVarType); -var Tmp: RawUTF8; - wasString: boolean; -begin - if AVarType=VarType then begin - VariantToUTF8(Variant(Source),Tmp,wasString); - if wasString then begin - VarClear(variant(Dest)); - variant(Dest) := _JSONFast(Tmp); // convert from JSON text - exit; - end; - RaiseCastError; - end else begin - if Source.VType<>VarType then - RaiseCastError; - VariantSaveJSON(variant(Source),twJSONEscape,tmp); - RawUTF8ToVariant(Tmp,Dest,AVarType); // convert to JSON text - end; -end; - -procedure TDocVariant.Compare(const Left, Right: TVarData; - var Relationship: TVarCompareResult); -var res: integer; - LeftU,RightU: RawUTF8; -begin - VariantSaveJSON(variant(Left),twJSONEscape,LeftU); - VariantSaveJSON(variant(Right),twJSONEscape,RightU); - if LeftU=RightU then - Relationship := crEqual else begin - res := StrComp(pointer(LeftU),pointer(RightU)); - if res<0 then - Relationship := crLessThan else - if res>0 then - Relationship := crGreaterThan else - Relationship := crEqual; - end; -end; - -class procedure TDocVariant.New(out aValue: variant; - aOptions: TDocVariantOptions); -begin - TDocVariantData(aValue).Init(aOptions); -end; - -class procedure TDocVariant.NewFast(out aValue: variant); -begin - TDocVariantData(aValue).InitFast; -end; - -class procedure TDocVariant.IsOfTypeOrNewFast(var aValue: variant); -begin - if DocVariantType.IsOfType(aValue) then - exit; - VarClear(aValue); - TDocVariantData(aValue).InitFast; -end; - -class procedure TDocVariant.NewFast(const aValues: array of PDocVariantData); -var i: integer; -begin - for i := 0 to high(aValues) do - aValues[i]^.InitFast; -end; - -class function TDocVariant.New(Options: TDocVariantOptions): Variant; -begin - VarClear(result); - TDocVariantData(result).Init(Options); -end; - -class function TDocVariant.NewObject(const NameValuePairs: array of const; - Options: TDocVariantOptions): variant; -begin - VarClear(result); - TDocVariantData(result).InitObject(NameValuePairs,Options); -end; - -class function TDocVariant.NewArray(const Items: array of const; - Options: TDocVariantOptions): variant; -begin - VarClear(result); - TDocVariantData(result).InitArray(Items,Options); -end; - -class function TDocVariant.NewArray(const Items: TVariantDynArray; - Options: TDocVariantOptions): variant; -begin - VarClear(result); - TDocVariantData(result).InitArrayFromVariants(Items,Options); -end; - -class function TDocVariant.NewJSON(const JSON: RawUTF8; - Options: TDocVariantOptions): variant; -begin - _Json(JSON,result,Options); -end; - -class function TDocVariant.NewUnique(const SourceDocVariant: variant; - Options: TDocVariantOptions): variant; -begin - VarClear(result); - TDocVariantData(result).InitCopy(SourceDocVariant,Options); -end; - -class procedure TDocVariant.GetSingleOrDefault(const docVariantArray, default: variant; - var result: variant); -var vt: integer; -begin - vt := TVarData(DocVariantArray).VType; - if vt=varByRef or varVariant then - GetSingleOrDefault(PVariant(TVarData(DocVariantArray).VPointer)^,default,result) else - if (vt<>DocVariantVType) or (TDocVariantData(DocVariantArray).Count<>1) or - not(dvoIsArray in TDocVariantData(DocVariantArray).VOptions) then - result := default else - result := TDocVariantData(DocVariantArray).Values[0]; -end; - -function ToText(kind: TDocVariantKind): PShortString; -begin - result := GetEnumName(TypeInfo(TDocVariantKind),ord(kind)); -end; - -function _Obj(const NameValuePairs: array of const; - Options: TDocVariantOptions): variant; -begin - VarClear(result); - TDocVariantData(result).InitObject(NameValuePairs,Options); -end; - -function _Arr(const Items: array of const; - Options: TDocVariantOptions): variant; -begin - VarClear(result); - TDocVariantData(result).InitArray(Items,Options); -end; - -procedure _ObjAddProps(const NameValuePairs: array of const; var Obj: variant); -var o: PDocVariantData; -begin - o := _Safe(Obj); - if not(dvoIsObject in o^.VOptions) then begin // create new object - VarClear(Obj); - TDocVariantData(Obj).InitObject(NameValuePairs,JSON_OPTIONS_FAST); - end else begin // append new names/values to existing object - TVarData(Obj) := PVarData(o)^; // ensure not stored by reference - o^.AddNameValuesToObject(NameValuePairs); - end; -end; - -procedure _ObjAddProps(const Document: variant; var Obj: variant); -var ndx: integer; - d,o: PDocVariantData; -begin - d := _Safe(Document); - o := _Safe(Obj); - if dvoIsObject in d.VOptions then - if not(dvoIsObject in o.VOptions) then - Obj := Document else - for ndx := 0 to d^.VCount-1 do - o^.AddOrUpdateValue(d^.VName[ndx],d^.VValue[ndx]); -end; - -function _ObjFast(const NameValuePairs: array of const): variant; -begin - VarClear(result); - TDocVariantData(result).InitObject(NameValuePairs,JSON_OPTIONS_FAST); -end; - -function _ObjFast(aObject: TObject; aOptions: TTextWriterWriteObjectOptions): variant; -begin - VarClear(result); - if TDocVariantData(result).InitJSONInPlace( - pointer(ObjectToJson(aObject,aOptions)),JSON_OPTIONS_FAST)=nil then - VarClear(result); -end; - -function _ArrFast(const Items: array of const): variant; -begin - VarClear(result); - TDocVariantData(result).InitArray(Items,JSON_OPTIONS_FAST); -end; - -function _Json(const JSON: RawUTF8; Options: TDocVariantOptions): variant; -begin - _Json(JSON,result,Options); -end; - -function _JsonFast(const JSON: RawUTF8): variant; -begin - _Json(JSON,result,JSON_OPTIONS_FAST); -end; - -function _JsonFastFloat(const JSON: RawUTF8): variant; -begin - _Json(JSON,result,JSON_OPTIONS_FAST_FLOAT); -end; - -function _JsonFastExt(const JSON: RawUTF8): variant; -begin - _Json(JSON,result,JSON_OPTIONS_FAST_EXTENDED); -end; - -function _JsonFmt(const Format: RawUTF8; const Args,Params: array of const; - Options: TDocVariantOptions): variant; -begin - _JsonFmt(Format,Args,Params,Options,result); -end; - -procedure _JsonFmt(const Format: RawUTF8; const Args,Params: array of const; - Options: TDocVariantOptions; out result: variant); -var temp: RawUTF8; -begin - temp := FormatUTF8(Format,Args,Params,true); - if TDocVariantData(result).InitJSONInPlace(pointer(temp),Options)=nil then - TDocVariantData(result).Clear; -end; - -function _JsonFastFmt(const Format: RawUTF8; const Args,Params: array of const): variant; -begin - _JsonFmt(Format,Args,Params,JSON_OPTIONS_FAST,result); -end; - -function _Json(const JSON: RawUTF8; var Value: variant; - Options: TDocVariantOptions): boolean; -begin - VarClear(Value); - if not TDocVariantData(Value).InitJSON(JSON,Options) then begin - VarClear(Value); - result := false; - end else - result := true; -end; - -procedure _Unique(var DocVariant: variant); -begin // TDocVariantData(DocVariant): InitCopy() will check the DocVariant type - TDocVariantData(DocVariant).InitCopy(DocVariant,JSON_OPTIONS[false]); -end; - -procedure _UniqueFast(var DocVariant: variant); -begin // TDocVariantData(DocVariant): InitCopy() will check the DocVariant type - TDocVariantData(DocVariant).InitCopy(DocVariant,JSON_OPTIONS_FAST); -end; - -function _Copy(const DocVariant: variant): variant; -begin - result := TDocVariant.NewUnique(DocVariant,JSON_OPTIONS[false]); -end; - -function _CopyFast(const DocVariant: variant): variant; -begin - result := TDocVariant.NewUnique(DocVariant,JSON_OPTIONS_FAST); -end; - -function _ByRef(const DocVariant: variant; Options: TDocVariantOptions): variant; -begin - VarClear(result); - TDocVariantData(result) := _Safe(DocVariant)^; // fast byref copy - TDocVariantData(result).SetOptions(Options); -end; - -procedure _ByRef(const DocVariant: variant; out Dest: variant; - Options: TDocVariantOptions); -begin - TDocVariantData(Dest) := _Safe(DocVariant)^; // fast byref copy - TDocVariantData(Dest).SetOptions(Options); -end; - -function ObjectToVariant(Value: TObject; EnumSetsAsText: boolean): variant; -const OPTIONS: array[boolean] of TTextWriterWriteObjectOptions = ( - [woDontStoreDefault],[woDontStoreDefault,woEnumSetsAsText]); -begin - VarClear(result); - ObjectToVariant(Value,result,OPTIONS[EnumSetsAsText]); -end; - -procedure ObjectToVariant(Value: TObject; out Dest: variant); -begin - ObjectToVariant(Value,Dest,[woDontStoreDefault]); -end; - -procedure ObjectToVariant(Value: TObject; var result: variant; - Options: TTextWriterWriteObjectOptions); -var json: RawUTF8; -begin - json := ObjectToJSON(Value,Options); - PDocVariantData(@result)^.InitJSONInPlace(pointer(json),JSON_OPTIONS_FAST); -end; - -{$endif NOVARIANTS} - - -{ ****************** TDynArray wrapper } - -{$ifndef DELPHI5OROLDER} // do not know why Delphi 5 compiler does not like CopyFrom() -procedure DynArrayCopy(var Dest; const Source; SourceMaxElem: integer; - TypeInfo: pointer); -var DestDynArray: TDynArray; -begin - DestDynArray.Init(TypeInfo,Dest); - DestDynArray.CopyFrom(Source,SourceMaxElem); -end; -{$endif DELPHI5OROLDER} - -function DynArrayLoad(var Value; Source: PAnsiChar; TypeInfo: pointer): PAnsiChar; -var DynArray: TDynArray; -begin - DynArray.Init(TypeInfo,Value); - result := DynArray.LoadFrom(Source); -end; - -function DynArraySave(var Value; TypeInfo: pointer): RawByteString; -var DynArray: TDynArray; -begin - DynArray.Init(TypeInfo,Value); - result := DynArray.SaveTo; -end; - -function DynArrayLoadJSON(var Value; JSON: PUTF8Char; TypeInfo: pointer; - EndOfObject: PUTF8Char): PUTF8Char; -var DynArray: TDynArray; -begin - DynArray.Init(TypeInfo,Value); - result := DynArray.LoadFromJSON(JSON,EndOfObject); -end; - -function DynArrayLoadJSON(var Value; const JSON: RawUTF8; TypeInfo: pointer): boolean; -var tmp: TSynTempBuffer; -begin - tmp.Init(JSON); // make private copy before in-place decoding - try - result := DynArrayLoadJSON(Value,tmp.buf,TypeInfo)<>nil; - finally - tmp.Done; - end; -end; - -function DynArraySaveJSON(const Value; TypeInfo: pointer; - EnumSetsAsText: boolean): RawUTF8; -begin - result := SaveJSON(Value,TypeInfo,EnumSetsAsText); -end; - -{$ifndef DELPHI5OROLDER} -function DynArrayEquals(TypeInfo: pointer; var Array1, Array2; - Array1Count, Array2Count: PInteger): boolean; -var DA1, DA2: TDynArray; -begin - DA1.Init(TypeInfo,Array1,Array1Count); - DA2.Init(TypeInfo,Array2,Array2Count); - result := DA1.Equals(DA2); -end; -{$endif DELPHI5OROLDER} - -function DynArrayBlobSaveJSON(TypeInfo, BlobValue: pointer): RawUTF8; -var DynArray: TDynArray; - Value: pointer; // store the temporary dynamic array - temp: TTextWriterStackBuffer; -begin - Value := nil; - DynArray.Init(TypeInfo,Value); - try - if DynArray.LoadFrom(BlobValue)=nil then - result := '' else begin - with DefaultTextWriterSerializer.CreateOwnedStream(temp) do - try - AddDynArrayJSON(TypeInfo,Value); - SetText(result); - finally - Free; - end; - end; - finally - DynArray.SetCount(0); - end; -end; - -function DynArrayElementTypeName(TypeInfo: pointer; ElemTypeInfo: PPointer; - ExactType: boolean): RawUTF8; -var DynArray: TDynArray; - VoidArray: pointer; -const KNOWNTYPE_ITEMNAME: array[TDynArrayKind] of RawUTF8 = ('', - 'boolean','byte','word','integer','cardinal','single','Int64','QWord', - 'double','currency','TTimeLog','TDateTime','TDateTimeMS', - 'RawUTF8','WinAnsiString','string','RawByteString','WideString','SynUnicode', - 'THash128','THash256','THash512','IInterface',{$ifndef NOVARIANTS}'variant',{$endif}''); -begin - VoidArray := nil; - DynArray.Init(TypeInfo,VoidArray); - result := ''; - if ElemTypeInfo<>nil then - ElemTypeInfo^ := DynArray.ElemType; - if DynArray.ElemType<>nil then - TypeInfoToName(ElemTypeInfo,result) else - result := KNOWNTYPE_ITEMNAME[DynArray.GuessKnownType(ExactType)]; -end; - -procedure RawRecordDynArrayClear(v: PAnsiChar; info: PTypeInfo; n: integer); -var fields,f: PFieldInfo; - nfields,i: integer; -begin - info := GetTypeInfo(info); - nfields := GetManagedFields(info,fields); // inlined RecordClear() - if nfields>0 then - repeat - f := fields; - i := nfields; - repeat - {$ifdef FPC}FPCFinalize{$else}_Finalize{$endif}(v+f^.Offset, - {$ifdef HASDIRECTTYPEINFO}f^.TypeInfo{$else}PPointer(f^.TypeInfo)^{$endif}); - inc(f); - dec(i); - until i=0; - inc(v,info^.recSize); - dec(n); - until n=0; -end; - -procedure RawAnsiStringDynArrayClear(v: PPointer; n: PtrInt); -var p: PStrRec; -begin - repeat - p := v^; - if p<>nil then begin - v^ := nil; - dec(p); - if (p^.refCnt>=0) and StrCntDecFree(p^.refCnt) then - freemem(p); - end; - inc(v); - dec(n); - until n=0; -end; - -procedure FastFinalizeArray(v: PPointer; ElemTypeInfo: pointer; n: integer); -begin // caller ensured ElemTypeInfo<>nil and n>0 - case PTypeKind(ElemTypeInfo)^ of - tkRecord{$ifdef FPC},tkObject{$endif}: - RawRecordDynArrayClear(pointer(v),ElemTypeinfo,n); - {$ifndef NOVARIANTS} - tkVariant: - RawVariantDynArrayClear(pointer(v),n); - {$endif} - tkLString{$ifdef FPC},tkLStringOld{$endif}: - RawAnsiStringDynArrayClear(pointer(v),n); - tkWString: - repeat - if v^<>nil then - {$ifdef FPC}Finalize(WideString(v^)){$else}WideString(v^) := ''{$endif}; - inc(v); - dec(n); - until n=0; - {$ifdef HASVARUSTRING} - tkUString: - repeat - if v^<>nil then - {$ifdef FPC}Finalize(UnicodeString(v^)){$else}UnicodeString(v^) := ''{$endif}; - inc(v); - dec(n); - until n=0; - {$endif} - {$ifndef DELPHI5OROLDER} - tkInterface: - repeat - if v^<>nil then - {$ifdef FPC}Finalize(IInterface(v^)){$else}IInterface(v^) := nil{$endif}; - inc(v); - dec(n); - until n=0; - {$endif} - tkDynArray: begin - ElemTypeInfo := Deref(GetTypeInfo(ElemTypeInfo)^.elType); - repeat - if v^<>nil then - FastDynArrayClear(v,ElemTypeInfo); - inc(v); - dec(n); - until n=0; - end; - else // fallback to regular finalization code for less common types - {$ifdef FPC}FPCFinalizeArray{$else}_FinalizeArray{$endif}(v,ElemTypeInfo,n); - end; -end; - -procedure FastDynArrayClear(Value: PPointer; ElemTypeInfo: pointer); -var p: PDynArrayRec; -begin - if Value<>nil then begin - p := Value^; - if p<>nil then begin - dec(p); - if (p^.refCnt>=0) and DACntDecFree(p^.refCnt) then begin - if ElemTypeInfo<>nil then - FastFinalizeArray(Value^,ElemTypeInfo,p^.length); - Freemem(p); - end; - Value^ := nil; - end; - end; -end; - -{$ifdef FPC_X64} -procedure _dynarray_decr_ref_free(p: PDynArrayRec; info: pointer); -begin - info := Deref(GetTypeInfo(info)^.elType); - if info <> nil then - FastFinalizeArray(pointer(PAnsiChar(p) + SizeOf(p^)), info, p^.length); - Freemem(p); -end; -{$endif FPC_X64} - -function SortDynArrayBoolean(const A,B): integer; -begin - if boolean(A) then // normalize (seldom used, anyway) - if boolean(B) then - result := 0 else - result := 1 else - if boolean(B) then - result := -1 else - result := 0; -end; - -function SortDynArrayByte(const A,B): integer; -begin - result := byte(A)-byte(B); -end; - -function SortDynArraySmallint(const A,B): integer; -begin - result := smallint(A)-smallint(B); -end; - -function SortDynArrayShortint(const A,B): integer; -begin - result := shortint(A)-shortint(B); -end; - -function SortDynArrayWord(const A,B): integer; -begin - result := word(A)-word(B); -end; - -function SortDynArrayPUTF8CharI(const A,B): integer; -begin - result := StrIComp(PUTF8Char(A),PUTF8Char(B)); -end; - -function SortDynArrayString(const A,B): integer; -begin - {$ifdef UNICODE} - result := StrCompW(PWideChar(A),PWideChar(B)); - {$else} - result := StrComp(PUTF8Char(A),PUTF8Char(B)); - {$endif} -end; - -function SortDynArrayStringI(const A,B): integer; -begin - {$ifdef UNICODE} - result := AnsiICompW(PWideChar(A),PWideChar(B)); - {$else} - result := StrIComp(PUTF8Char(A),PUTF8Char(B)); - {$endif} -end; - -function SortDynArrayFileName(const A,B): integer; -var Aname, Aext, Bname, Bext: TFileName; -begin // code below is not very fast, but is correct ;) - AName := GetFileNameWithoutExt(string(A),@Aext); - BName := GetFileNameWithoutExt(string(B),@Bext); - result := AnsiCompareFileName(Aext,Bext); - if result=0 then // if both extensions matches, compare by filename - result := AnsiCompareFileName(Aname,Bname); -end; - -function SortDynArrayUnicodeString(const A,B): integer; -begin // works for tkWString and tkUString - result := StrCompW(PWideChar(A),PWideChar(B)); -end; - -function SortDynArrayUnicodeStringI(const A,B): integer; -begin - result := AnsiICompW(PWideChar(A),PWideChar(B)); -end; - -function SortDynArray128(const A,B): integer; -begin - if THash128Rec(A).LoTHash128Rec(B).Lo then - result := 1 else - if THash128Rec(A).HiTHash128Rec(B).Hi then - result := 1 else - result := 0; -end; - -function SortDynArray256(const A,B): integer; -begin - result := SortDynArray128(THash256Rec(A).Lo,THash256Rec(B).Lo); - if result = 0 then - result := SortDynArray128(THash256Rec(A).Hi,THash256Rec(B).Hi); -end; - -function SortDynArray512(const A,B): integer; -begin - result := SortDynArray128(THash512Rec(A).c0,THash512Rec(B).c0); - if result = 0 then begin - result := SortDynArray128(THash512Rec(A).c1,THash512Rec(B).c1); - if result = 0 then begin - result := SortDynArray128(THash512Rec(A).c2,THash512Rec(B).c2); - if result = 0 then - result := SortDynArray128(THash512Rec(A).c3,THash512Rec(B).c3); - end; - end; -end; - -{$ifndef NOVARIANTS} - -function VariantCompare(const V1,V2: variant): PtrInt; -begin - result := SortDynArrayVariantComp(TVarData(V1), TVarData(V2), false); -end; - -function VariantCompareI(const V1,V2: variant): PtrInt; -begin - result := SortDynArrayVariantComp(TVarData(V1), TVarData(V2), true); -end; - -function SortDynArrayVariantCompareAsString(const A,B: variant): integer; -var UA,UB: RawUTF8; - wasString: boolean; -begin - VariantToUTF8(A,UA,wasString); - VariantToUTF8(B,UB,wasString); - result := StrComp(pointer(UA),pointer(UB)); -end; - -function SortDynArrayVariantCompareAsStringI(const A,B: variant): integer; -var UA,UB: RawUTF8; - wasString: boolean; -begin - VariantToUTF8(A,UA,wasString); - VariantToUTF8(B,UB,wasString); - result := StrIComp(pointer(UA),pointer(UB)); -end; - -function SortDynArrayZero(const A,B): integer; -begin - result := 0; -end; - -function SortDynArrayVariantComp(const A,B: TVarData; caseInsensitive: boolean): integer; -type - TSortDynArrayVariantComp = function(const A,B: variant): integer; -const - CMP: array[boolean] of TSortDynArrayVariantComp = ( - SortDynArrayVariantCompareAsString,SortDynArrayVariantCompareAsStringI); - ICMP: array[TVariantRelationship] of integer = (0,-1,1,1); - SORT1: array[varEmpty..varDate] of TDynArraySortCompare = ( - SortDynArrayZero, SortDynArrayZero, SortDynArraySmallInt, SortDynArrayInteger, - SortDynArraySingle, SortDynArrayDouble, SortDynArrayInt64, SortDynArrayDouble); - SORT2: array[varShortInt..varWord64] of TDynArraySortCompare = ( - SortDynArrayShortInt, SortDynArrayByte, SortDynArrayWord, SortDynArrayCardinal, - SortDynArrayInt64, SortDynArrayQWord); -var AT,BT: integer; -begin - AT := integer(A.VType); - BT := integer(B.VType); - if AT=varVariant or varByRef then - result := SortDynArrayVariantComp(PVarData(A.VPointer)^,B,caseInsensitive) else - if BT=varVariant or varByRef then - result := SortDynArrayVariantComp(A,PVarData(B.VPointer)^,caseInsensitive) else - if AT=BT then - case AT of // optimized comparison if A and B share the same type - low(SORT1)..high(SORT1): - result := SORT1[AT](A.VAny,B.VAny); - low(SORT2)..high(SORT2): - result := SORT2[AT](A.VAny,B.VAny); - varString: // RawUTF8 most of the time (e.g. from TDocVariant) - if caseInsensitive then - result := StrIComp(A.VAny,B.VAny) else - result := StrComp(A.VAny,B.VAny); - varBoolean: - if A.VBoolean then // normalize - if B.VBoolean then - result := 0 else - result := 1 else - if B.VBoolean then - result := -1 else - result := 0; - varOleStr{$ifdef HASVARUSTRING},varUString{$endif}: - if caseInsensitive then - result := AnsiICompW(A.VAny,B.VAny) else - result := StrCompW(A.VAny,B.VAny); - else - if ATvarNull)-ord(BT>varNull) else - if (AT0 then - result := PInteger(result)^ else begin - result := PtrUInt(fValue); - if result<>0 then begin - result := PPtrInt(result)^; - if result<>0 then - result := PDALen(result-_DALEN)^{$ifdef FPC}+1{$endif}; - end; - end; -end; - -procedure TDynArray.ElemCopy(const A; var B); -begin - if ElemType=nil then - MoveFast(A,B,ElemSize) else begin - {$ifdef FPC} - {$ifdef FPC_OLDRTTI} - FPCFinalize(@B,ElemType); // inlined CopyArray() - Move(A,B,ElemSize); - FPCRecordAddRef(B,ElemType); - {$else} - FPCRecordCopy(A,B,ElemType); // works for any kind of ElemTyp - {$endif FPC_OLDRTTI} - {$else} - CopyArray(@B,@A,ElemType,1); - {$endif FPC} - end; -end; - -function TDynArray.Add(const Elem): PtrInt; -var p: PtrUInt; -begin - result := GetCount; - if fValue=nil then - exit; // avoid GPF if void - SetCount(result+1); - p := PtrUInt(fValue^)+PtrUInt(result)*ElemSize; - if ElemType=nil then - MoveFast(Elem,pointer(p)^,ElemSize) else - {$ifdef FPC} - FPCRecordCopy(Elem,pointer(p)^,ElemType); - {$else} - CopyArray(pointer(p),@Elem,ElemType,1); - {$endif} -end; - -function TDynArray.New: integer; -begin - result := GetCount; - if fValue=nil then - exit; // avoid GPF if void - SetCount(result+1); -end; - -function TDynArray.Peek(var Dest): boolean; -var index: PtrInt; -begin - index := GetCount-1; - result := index>=0; - if result then - ElemCopy(pointer(PtrUInt(fValue^)+PtrUInt(index)*ElemSize)^,Dest); -end; - -function TDynArray.Pop(var Dest): boolean; -var index: integer; -begin - index := GetCount-1; - result := index>=0; - if result then begin - ElemMoveTo(index,Dest); - SetCount(index); - end; -end; - -procedure TDynArray.Insert(Index: PtrInt; const Elem); -var n: PtrInt; - P: PByteArray; -begin - if fValue=nil then - exit; // avoid GPF if void - n := GetCount; - SetCount(n+1); - if PtrUInt(Index)nil then // avoid GPF in ElemCopy() below - FillCharFast(P^,ElemSize,0); - end else - // Index>=Count -> add at the end - P := pointer(PtrUInt(fValue^)+PtrUInt(n)*ElemSize); - ElemCopy(Elem,P^); -end; - -procedure TDynArray.Clear; -begin - SetCount(0); -end; - -function TDynArray.ClearSafe: boolean; -begin - try - SetCount(0); - result := true; - except // weak code, but may be a good idea in a destructor - result := false; - end; -end; - -function TDynArray.GetIsObjArray: boolean; -begin - result := (fIsObjArray=oaTrue) or ((fIsObjArray=oaUnknown) and ComputeIsObjArray); -end; - -function TDynArray.Delete(aIndex: PtrInt): boolean; -var n, len: PtrInt; - P: PAnsiChar; -begin - result := false; - if fValue=nil then - exit; // avoid GPF if void - n := GetCount; - if PtrUInt(aIndex)>=PtrUInt(n) then - exit; // out of range - if PDACnt(PtrUInt(fValue^)-_DAREFCNT)^>1 then - InternalSetLength(n,n); // unique - dec(n); - P := pointer(PtrUInt(fValue^)+PtrUInt(aIndex)*ElemSize); - if ElemType<>nil then - {$ifdef FPC}FPCFinalize{$else}_Finalize{$endif}(P,ElemType) else - if (fIsObjArray=oaTrue) or ((fIsObjArray=oaUnknown) and ComputeIsObjArray) then - FreeAndNil(PObject(P)^); - if n>aIndex then begin - len := PtrUInt(n-aIndex)*ElemSize; - MoveFast(P[ElemSize],P[0],len); - FillCharFast(P[len],ElemSize,0); - end else - FillCharFast(P^,ElemSize,0); - SetCount(n); - result := true; -end; - -function TDynArray.ElemPtr(index: PtrInt): pointer; -label ok; -var c: PtrUInt; -begin // very efficient code on FPC and modern Delphi - result := pointer(fValue); - if result=nil then - exit; - result := PPointer(result)^; - if result=nil then - exit; - c := PtrUInt(fCountP); - if c<>0 then begin - if PtrUInt(index)nil then - if ElemType=nil then - MoveFast(p^,Dest,ElemSize) else - {$ifdef FPC} - FPCRecordCopy(p^,Dest,ElemType); // works for any kind of ElemTyp - {$else} - CopyArray(@Dest,p,ElemType,1); - {$endif} -end; - -procedure TDynArray.ElemMoveTo(index: PtrInt; var Dest); -var p: pointer; -begin - p := ElemPtr(index); - if (p=nil) or (@Dest=nil) then - exit; - ElemClear(Dest); - MoveFast(p^,Dest,ElemSize); - FillCharFast(p^,ElemSize,0); // ElemType=nil for ObjArray -end; - -procedure TDynArray.ElemCopyFrom(const Source; index: PtrInt; ClearBeforeCopy: boolean); -var p: pointer; -begin - p := ElemPtr(index); - if p<>nil then - if ElemType=nil then - MoveFast(Source,p^,ElemSize) else begin - if ClearBeforeCopy then // safer if Source is a copy of p^ - {$ifdef FPC}FPCFinalize{$else}_Finalize{$endif}(p,ElemType); - {$ifdef FPC} - FPCRecordCopy(Source,p^,ElemType); - {$else} - CopyArray(p,@Source,ElemType,1); - {$endif} - end; -end; - -procedure TDynArray.Reverse; -var n, siz: PtrInt; - P1, P2: PAnsiChar; - c: AnsiChar; - i32: integer; - i64: Int64; -begin - n := GetCount-1; - if n>0 then begin - siz := ElemSize; - P1 := fValue^; - case siz of - 1: begin // optimized version for TByteDynArray and such - P2 := P1+n; - while P1MemStream.Size then - MemStream.Size := PosiEnd; - if SaveTo(PAnsiChar(MemStream.Memory)+Posi)-MemStream.Memory<>PosiEnd then - raise EStreamError.Create('TDynArray.SaveToStream: SaveTo'); - MemStream.Seek(PosiEnd,soBeginning); - end else begin - tmp := SaveTo; - if Stream.Write(pointer(tmp)^,length(tmp))<>length(tmp) then - raise EStreamError.Create('TDynArray.SaveToStream: Write error'); - end; -end; - -procedure TDynArray.LoadFromStream(Stream: TCustomMemoryStream); -var P: PAnsiChar; -begin - P := PAnsiChar(Stream.Memory)+Stream.Seek(0,soCurrent); - Stream.Seek(LoadFrom(P,nil,false,PAnsiChar(Stream.Memory)+Stream.Size)-P,soCurrent); -end; - -function TDynArray.SaveToTypeInfoHash(crc: cardinal): cardinal; -begin - if ElemType=nil then // hash fElemSize only if no pointer within - result := crc32c(crc,@fElemSize,4) else begin - result := crc; - ManagedTypeSaveRTTIHash(ElemType,result); - end; -end; - -function TDynArray.SaveTo(Dest: PAnsiChar): PAnsiChar; -var i, n, LenBytes: integer; - P: PAnsiChar; -begin - if fValue=nil then begin - result := Dest; - exit; // avoid GPF if void - end; - // store the element size+type to check for the format (name='' mostly) - Dest := PAnsiChar(ToVarUInt32(ElemSize,pointer(Dest))); - if ElemType=nil then - Dest^ := #0 else - {$ifdef FPC} - Dest^ := AnsiChar(FPCTODELPHI[PTypeKind(ElemType)^]); - {$else} - Dest^ := PAnsiChar(ElemType)^; - {$endif} - inc(Dest); - // store dynamic array count - n := GetCount; - Dest := PAnsiChar(ToVarUInt32(n,pointer(Dest))); - if n=0 then begin - result := Dest; - exit; - end; - inc(Dest,SizeOf(Cardinal)); // leave space for Hash32 checksum - result := Dest; - // store dynamic array elements content - P := fValue^; - if ElemType=nil then // FPC: nil also if not Kind in tkManagedTypes - if GetIsObjArray then - raise ESynException.CreateUTF8('TDynArray.SaveTo(%) is a T*ObjArray', - [ArrayTypeShort^]) else begin - n := n*integer(ElemSize); // binary types: store as one - MoveFast(P^,Dest^,n); - inc(Dest,n); - end else - if PTypeKind(ElemType)^ in tkRecordTypes then - for i := 1 to n do begin - Dest := RecordSave(P^,Dest,ElemType,LenBytes); - inc(P,LenBytes); - end else - for i := 1 to n do begin - Dest := ManagedTypeSave(P,Dest,ElemType,LenBytes); - if Dest=nil then - break; - inc(P,LenBytes); - end; - // store Hash32 checksum - if Dest<>nil then // may be nil if RecordSave/ManagedTypeSave failed - PCardinal(result-SizeOf(Cardinal))^ := Hash32(pointer(result),Dest-result); - result := Dest; -end; - -function TDynArray.SaveToLength: integer; -var i,n,L,size: integer; - P: PAnsiChar; -begin - if fValue=nil then begin - result := 0; - exit; // avoid GPF if void - end; - n := GetCount; - result := ToVarUInt32Length(ElemSize)+ToVarUInt32Length(n)+1; - if n=0 then - exit; - if ElemType=nil then // FPC: nil also if not Kind in tkManagedTypes - if GetIsObjArray then - raise ESynException.CreateUTF8('TDynArray.SaveToLength(%) is a T*ObjArray', - [ArrayTypeShort^]) else - inc(result,integer(ElemSize)*n) else begin - P := fValue^; - case PTypeKind(ElemType)^ of // inlined the most used kind of items - tkLString{$ifdef FPC},tkLStringOld{$endif}: - for i := 1 to n do begin - if PPtrUInt(P)^=0 then - inc(result) else - inc(result,ToVarUInt32LengthWithData(PStrLen(PPtrUInt(P)^-_STRLEN)^)); - inc(P,SizeOf(pointer)); - end; - tkRecord{$ifdef FPC},tkObject{$endif}: - for i := 1 to n do begin - inc(result,RecordSaveLength(P^,ElemType)); - inc(P,ElemSize); - end; - else - for i := 1 to n do begin - L := ManagedTypeSaveLength(P,ElemType,size); - if L=0 then - break; // invalid record type (wrong field type) - inc(result,L); - inc(P,size); - end; - end; - end; - inc(result,SizeOf(Cardinal)); // Hash32 checksum -end; - -function TDynArray.SaveTo: RawByteString; -var Len: integer; -begin - Len := SaveToLength; - SetString(result,nil,Len); - if Len<>0 then - if SaveTo(pointer(result))-pointer(result)<>Len then - raise ESynException.Create('TDynArray.SaveTo len concern'); -end; - -function TDynArray.SaveToJSON(EnumSetsAsText: boolean; reformat: TTextWriterJSONFormat): RawUTF8; -begin - SaveToJSON(result,EnumSetsAsText,reformat); -end; - -procedure TDynArray.SaveToJSON(out Result: RawUTF8; EnumSetsAsText: boolean; - reformat: TTextWriterJSONFormat); -var temp: TTextWriterStackBuffer; -begin - with DefaultTextWriterSerializer.CreateOwnedStream(temp) do - try - if EnumSetsAsText then - CustomOptions := CustomOptions+[twoEnumSetsAsTextInRecord]; - AddDynArrayJSON(self); - SetText(result,reformat); - finally - Free; - end; -end; - -const - PTRSIZ = SizeOf(Pointer); - KNOWNTYPE_SIZE: array[TDynArrayKind] of byte = ( - 0, 1,1, 2, 4,4,4, 8,8,8,8,8,8,8, PTRSIZ,PTRSIZ,PTRSIZ,PTRSIZ,PTRSIZ,PTRSIZ, - 16,32,64, PTRSIZ, - {$ifndef NOVARIANTS}SizeOf(Variant),{$endif} 0); - DYNARRAY_PARSERUNKNOWN = -2; - -var // for TDynArray.LoadKnownType - KINDTYPE_INFO: array[TDynArrayKind] of pointer; - -function TDynArray.GetArrayTypeName: RawUTF8; -begin - TypeInfoToName(fTypeInfo,result); -end; - -function TDynArray.GetArrayTypeShort: PShortString; -begin // not inlined since PTypeInfo is private to implementation section - if fTypeInfo=nil then - result := @NULCHAR else - result := PShortString(@PTypeInfo(fTypeInfo).NameLen); -end; - -function TDynArray.GuessKnownType(exactType: boolean): TDynArrayKind; -const - RTTI: array[TJSONCustomParserRTTIType] of TDynArrayKind = ( - djNone, djBoolean, djByte, djCardinal, djCurrency, djDouble, djNone, djInt64, - djInteger, djQWord, djRawByteString, djNone, djRawUTF8, djNone, djSingle, - djString, djSynUnicode, djDateTime, djDateTimeMS, djHash128, djInt64, djTimeLog, - {$ifdef HASVARUSTRING} {$ifdef UNICODE}djSynUnicode{$else}djNone{$endif}, {$endif} - {$ifndef NOVARIANTS} djVariant, {$endif} djWideString, djWord, djNone); -var info: PTypeInfo; - field: PFieldInfo; -label bin, rec; -begin - result := fKnownType; - if result<>djNone then - exit; - info := fTypeInfo; - case ElemSize of // very fast guess of most known exact dynarray types - 1: if info=TypeInfo(TBooleanDynArray) then - result := djBoolean; - 4: if info=TypeInfo(TCardinalDynArray) then - result := djCardinal else - if info=TypeInfo(TSingleDynArray) then - result := djSingle - {$ifdef CPU64} ; 8: {$else} else {$endif} - if info=TypeInfo(TRawUTF8DynArray) then - result := djRawUTF8 else - if info=TypeInfo(TStringDynArray) then - result := djString else - if info=TypeInfo(TWinAnsiDynArray) then - result := djWinAnsi else - if info=TypeInfo(TRawByteStringDynArray) then - result := djRawByteString else - if info=TypeInfo(TSynUnicodeDynArray) then - result := djSynUnicode else - if (info=TypeInfo(TClassDynArray)) or - (info=TypeInfo(TPointerDynArray)) then - result := djPointer else - {$ifndef DELPHI5OROLDER} - if info=TypeInfo(TInterfaceDynArray) then - result := djInterface - {$endif DELPHI5OROLDER} - {$ifdef CPU64} else {$else} ; 8: {$endif} - if info=TypeInfo(TDoubleDynArray) then - result := djDouble else - if info=TypeInfo(TCurrencyDynArray) then - result := djCurrency else - if info=TypeInfo(TTimeLogDynArray) then - result := djTimeLog else - if info=TypeInfo(TDateTimeDynArray) then - result := djDateTime else - if info=TypeInfo(TDateTimeMSDynArray) then - result := djDateTimeMS; - end; - if result=djNone then begin // guess from RTTU - fKnownSize := 0; - if fElemType=nil then begin - {$ifdef DYNARRAYELEMTYPE2} // not backward compatible - disabled - if fElemType2<>nil then // try if a simple type known by extended RTTI - result := RTTI[TJSONCustomParserRTTI.TypeInfoToSimpleRTTIType(fElemType2)]; - if result=djNone then - {$endif} -bin: case fElemSize of - 1: result := djByte; - 2: result := djWord; - 4: result := djInteger; - 8: result := djInt64; - 16: result := djHash128; - 32: result := djHash256; - 64: result := djHash512; - else fKnownSize := fElemSize; - end; - end else // try to guess from 1st record/object field - if not exacttype and (PTypeKind(fElemType)^ in tkRecordTypes) then begin - info := fElemType; // inlined GetTypeInfo() -rec: {$ifdef HASALIGNTYPEDATA} - info := FPCTypeInfoOverName(info); - {$else} - inc(PByte(info),info^.NameLen); - {$endif} - {$ifdef FPC_OLDRTTI} - field := OldRTTIFirstManagedField(info); - if field=nil then - {$else} - if GetManagedFields(info,field)=0 then // only binary content - {$endif} - goto Bin; - case field^.Offset of - 0: begin - info := DeRef(field^.TypeInfo); - if info=nil then // paranoid check - goto bin else - if info^.kind in tkRecordTypes then - goto rec; // nested records - result := RTTI[TJSONCustomParserRTTI.TypeInfoToSimpleRTTIType(info)]; - if result=djNone then - goto Bin; - end; - 1: result := djByte; - 2: result := djWord; - 4: result := djInteger; - 8: result := djInt64; - 16: result := djHash128; - 32: result := djHash256; - 64: result := djHash512; - else fKnownSize := field^.Offset; - end; - end else - // will recognize simple arrays from PTypeKind(fElemType)^ - result := RTTI[TJSONCustomParserRTTI.TypeInfoToSimpleRTTIType(fElemType)]; - end; - if KNOWNTYPE_SIZE[result]<>0 then - fKnownSize := KNOWNTYPE_SIZE[result]; - fKnownType := result; -end; - -function TDynArray.ElemCopyFirstField(Source,Dest: Pointer): boolean; -begin - if fKnownType=djNone then - GuessKnownType(false); - case fKnownType of - djBoolean..djDateTimeMS,djHash128..djHash512: // no managed field - MoveFast(Source^,Dest^,fKnownSize); - djRawUTF8, djWinAnsi, djRawByteString: - PRawByteString(Dest)^ := PRawByteString(Source)^; - djSynUnicode: - PSynUnicode(Dest)^ := PSynUnicode(Source)^; - djString: - PString(Dest)^ := PString(Source)^; - djWideString: - PWideString(Dest)^ := PWideString(Source)^; - {$ifndef NOVARIANTS}djVariant: PVariant(Dest)^ := PVariant(Source)^;{$endif} - else begin // djNone, djInterface, djCustom - result := false; - exit; - end; - end; - result := true; -end; - -function TDynArray.LoadKnownType(Data,Source,SourceMax: PAnsiChar): boolean; -var info: PTypeInfo; -begin - if fKnownType=djNone then - GuessKnownType({exacttype=}false); // set fKnownType and fKnownSize - if fKnownType in [djBoolean..djDateTimeMS,djHash128..djHash512] then - if (SourceMax<>nil) and (Source+fKnownSize>SourceMax) then - result := false else begin - MoveFast(Source^,Data^,fKnownSize); - result := true; - end else begin - info := KINDTYPE_INFO[fKnownType]; - if info=nil then - result := false else - result := (ManagedTypeLoad(Data,Source,info,SourceMax)<>0) and (Source<>nil); - end; -end; - -const // kind of types which are serialized as JSON text - DJ_STRING = [djTimeLog..djHash512]; - -function TDynArray.LoadFromJSON(P: PUTF8Char; aEndOfObject: PUTF8Char{$ifndef NOVARIANTS}; - CustomVariantOptions: PDocVariantOptions{$endif}): PUTF8Char; -var n, i, ValLen: integer; - T: TDynArrayKind; - wasString, expectedString, isValid: boolean; - EndOfObject: AnsiChar; - Val: PUTF8Char; - V: pointer; - CustomReader: TDynArrayJSONCustomReader; - NestedDynArray: TDynArray; -begin // code below must match TTextWriter.AddDynArrayJSON() - result := nil; - if (P=nil) or (fValue=nil) then - exit; - P := GotoNextNotSpace(P); - if P^<>'[' then begin - if (PInteger(P)^=NULL_LOW) and (jcEndOfJSONValueField in JSON_CHARS[P[4]]) then begin - SetCount(0); - result := P+4; // handle 'null' as void array - end; - exit; - end; - repeat inc(P) until not(P^ in [#1..' ']); - n := JSONArrayCount(P); - if n<0 then - exit; // invalid array content - if n=0 then begin - if NextNotSpaceCharIs(P,']') then begin - SetCount(0); - result := P; - end; - exit; // handle '[]' array - end; - {$ifndef NOVARIANTS} - if CustomVariantOptions=nil then - CustomVariantOptions := @JSON_OPTIONS[true]; - {$endif} - if HasCustomJSONParser then - CustomReader := GlobalJSONCustomParsers.fParser[fParser].Reader else - CustomReader := nil; - if Assigned(CustomReader) then - T := djCustom else - T := GuessKnownType({exacttype=}true); - if (T=djNone) and (P^='[') and (PTypeKind(ElemType)^=tkDynArray) then begin - Count := n; // fast allocation of the whole dynamic array memory at once - for i := 0 to n-1 do begin - NestedDynArray.Init(ElemType,PPointerArray(fValue^)^[i]); - P := NestedDynArray.LoadFromJSON(P,@EndOfObject{$ifndef NOVARIANTS}, - CustomVariantOptions{$endif}); - if P=nil then - exit; - EndOfObject := P^; // ',' or ']' for the last item of the array - inc(P); - end; - end else - if (T=djNone) or - (PCardinal(P)^=JSON_BASE64_MAGIC_QUOTE) then begin - if n<>1 then - exit; // expect one Base64 encoded string value preceded by \uFFF0 - Val := GetJSONField(P,P,@wasString,@EndOfObject,@ValLen); - if (Val=nil) or (ValLen<3) or not wasString or - (PInteger(Val)^ and $00ffffff<>JSON_BASE64_MAGIC) or - not LoadFromBinary(Base64ToBin(PAnsiChar(Val)+3,ValLen-3)) then - exit; // invalid content - end else begin - if GetIsObjArray then - for i := 0 to Count-1 do // force release any previous instance - FreeAndNil(PObjectArray(fValue^)^[i]); - SetCount(n); // fast allocation of the whole dynamic array memory at once - case T of - {$ifndef NOVARIANTS} - djVariant: - for i := 0 to n-1 do - P := VariantLoadJSON(PVariantArray(fValue^)^[i],P,@EndOfObject,CustomVariantOptions); - {$endif} - djCustom: begin - Val := fValue^; - for i := 1 to n do begin - P := CustomReader(P,Val^,isValid{$ifndef NOVARIANTS},CustomVariantOptions{$endif}); - if not isValid then - exit; - EndOfObject := P^; // ',' or ']' for the last item of the array - inc(P); - inc(Val,ElemSize); - end; - end; - else begin - V := fValue^; - expectedString := T in DJ_STRING; - for i := 0 to n-1 do begin - Val := GetJSONField(P,P,@wasString,@EndOfObject,@ValLen); - if (Val=nil) or (wasString<>expectedString) then - exit; - case T of - djBoolean: PBooleanArray(V)^[i] := GetBoolean(Val); - djByte: PByteArray(V)^[i] := GetCardinal(Val); - djWord: PWordArray(V)^[i] := GetCardinal(Val); - djInteger: PIntegerArray(V)^[i] := GetInteger(Val); - djCardinal: PCardinalArray(V)^[i] := GetCardinal(Val); - djSingle: PSingleArray(V)^[i] := GetExtended(Val); - djInt64: SetInt64(Val,PInt64Array(V)^[i]); - djQWord: SetQWord(Val,PQWordArray(V)^[i]); - djTimeLog: PInt64Array(V)^[i] := Iso8601ToTimeLogPUTF8Char(Val,ValLen); - djDateTime, djDateTimeMS: - Iso8601ToDateTimePUTF8CharVar(Val,ValLen,PDateTimeArray(V)^[i]); - djDouble: PDoubleArray(V)^[i] := GetExtended(Val); - djCurrency: PInt64Array(V)^[i] := StrToCurr64(Val); - djRawUTF8: FastSetString(PRawUTF8Array(V)^[i],Val,ValLen); - djRawByteString: - if not Base64MagicCheckAndDecode(Val,ValLen,PRawByteStringArray(V)^[i]) then - FastSetString(PRawUTF8Array(V)^[i],Val,ValLen); - djWinAnsi: WinAnsiConvert.UTF8BufferToAnsi(Val,ValLen,PRawByteStringArray(V)^[i]); - djString: UTF8DecodeToString(Val,ValLen,string(PPointerArray(V)^[i])); - djWideString: UTF8ToWideString(Val,ValLen,WideString(PPointerArray(V)^[i])); - djSynUnicode: UTF8ToSynUnicode(Val,ValLen,SynUnicode(PPointerArray(V)^[i])); - djHash128: if ValLen<>SizeOf(THash128)*2 then FillZero(PHash128Array(V)^[i]) else - HexDisplayToBin(pointer(Val),@PHash128Array(V)^[i],SizeOf(THash128)); - djHash256: if ValLen<>SizeOf(THash256)*2 then FillZero(PHash256Array(V)^[i]) else - HexDisplayToBin(pointer(Val),@PHash256Array(V)^[i],SizeOf(THash256)); - djHash512: if ValLen<>SizeOf(THash512)*2 then FillZero(PHash512Array(V)^[i]) else - HexDisplayToBin(pointer(Val),@PHash512Array(V)^[i],SizeOf(THash512)); - else raise ESynException.CreateUTF8('% not readable',[ToText(T)^]); - end; - end; - end; - end; - end; - if aEndOfObject<>nil then - aEndOfObject^ := EndOfObject; - if EndOfObject=']' then - if P=nil then - result := @NULCHAR else - result := P; -end; - -{$ifndef NOVARIANTS} -function TDynArray.LoadFromVariant(const DocVariant: variant): boolean; -begin - with _Safe(DocVariant)^ do - if dvoIsArray in Options then - result := LoadFromJSON(pointer(_Safe(DocVariant)^.ToJSON))<>nil else - result := false; -end; -{$endif NOVARIANTS} - -function TDynArray.LoadFromBinary(const Buffer: RawByteString; - NoCheckHash: boolean): boolean; -var P: PAnsiChar; - len: PtrInt; -begin - len := length(Buffer); - P := LoadFrom(pointer(Buffer),nil,NoCheckHash,PAnsiChar(pointer(Buffer))+len); - result := (P<>nil) and (P-pointer(Buffer)=len); -end; - -function TDynArray.LoadFromHeader(var Source: PByte; SourceMax: PByte): integer; -var n: cardinal; -begin - // check context - result := -1; // to notify error - if (Source=nil) or (fValue=nil) then - exit; - // ignore legacy element size for cross-platform compatibility - if not FromVarUInt32(Source,SourceMax,n) or - ((SourceMax<>nil) and (PAnsiChar(Source)>=PAnsiChar(SourceMax))) then - exit; - // check stored element type - if ElemType=nil then begin - if Source^<>0 then - exit; - end else - if Source^<>{$ifdef FPC}ord(FPCTODELPHI[PTypeKind(ElemType)^]){$else} - PByte(ElemType)^{$endif} then - exit; - inc(Source); - // retrieve dynamic array count - if FromVarUInt32(Source,SourceMax,n) then - if (n=0) or (SourceMax=nil) or - (PAnsiChar(Source)+SizeOf(cardinal)nil) and (Source+n>SourceMax) then exit; - MoveFast(Source^,P^,n); - inc(Source,n); - end else - if PTypeKind(ElemType)^ in tkRecordTypes then - for i := 1 to n do begin - Source := RecordLoad(P^,Source,ElemType,nil,SourceMax); - if Source=nil then exit; - if Assigned(AfterEach) then - AfterEach(P^); - inc(P,ElemSize); - end else - for i := 1 to n do begin - ManagedTypeLoad(P,Source,ElemType,SourceMax); - if Source=nil then exit; - if Assigned(AfterEach) then - AfterEach(P^); - inc(P,ElemSize); - end; - // check security checksum (Hash[0]=0 from mORMot2 DynArraySave) - if NoCheckHash or (Source=nil) or (Hash[0]=0) or - (Hash32(@Hash[1],Source-PAnsiChar(@Hash[1]))=Hash[0]) then - result := Source; -end; - -function TDynArray.Find(const Elem; const aIndex: TIntegerDynArray; - aCompare: TDynArraySortCompare): PtrInt; -var n, L: PtrInt; - cmp: integer; - P: PAnsiChar; -begin - n := GetCount; - if (@aCompare<>nil) and (n>0) then begin - dec(n); - P := fValue^; - if (n>10) and (length(aIndex)>=n) then begin - // array should be sorted via aIndex[] -> use fast O(log(n)) binary search - L := 0; - repeat - result := (L+n) shr 1; - cmp := aCompare(P[cardinal(aIndex[result])*ElemSize],Elem); - if cmp=0 then begin - result := aIndex[result]; // returns index in TDynArray - exit; - end; - if cmp<0 then - L := result+1 else - n := result-1; - until L>n; - end else - // array is not sorted, or aIndex=nil -> use O(n) iterating search - for result := 0 to n do - if aCompare(P^,Elem)=0 then - exit else - inc(P,ElemSize); - end; - result := -1; -end; - -function TDynArray.FindIndex(const Elem; aIndex: PIntegerDynArray; - aCompare: TDynArraySortCompare): PtrInt; -begin - if aIndex<>nil then - result := Find(Elem,aIndex^,aCompare) else - if Assigned(aCompare) then - result := Find(Elem,nil,aCompare) else - result := Find(Elem); -end; - -function TDynArray.FindAndFill(var Elem; aIndex: PIntegerDynArray; - aCompare: TDynArraySortCompare): integer; -begin - result := FindIndex(Elem,aIndex,aCompare); - if result>=0 then // if found, fill Elem with the matching item - ElemCopy(PAnsiChar(fValue^)[cardinal(result)*ElemSize],Elem); -end; - -function TDynArray.FindAndDelete(const Elem; aIndex: PIntegerDynArray; - aCompare: TDynArraySortCompare): integer; -begin - result := FindIndex(Elem,aIndex,aCompare); - if result>=0 then - Delete(result); -end; - -function TDynArray.FindAndUpdate(const Elem; aIndex: PIntegerDynArray; - aCompare: TDynArraySortCompare): integer; -begin - result := FindIndex(Elem,aIndex,aCompare); - if result>=0 then // if found, fill Elem with the matching item - ElemCopy(Elem,PAnsiChar(fValue^)[cardinal(result)*ElemSize]); -end; - -function TDynArray.FindAndAddIfNotExisting(const Elem; aIndex: PIntegerDynArray; - aCompare: TDynArraySortCompare): integer; -begin - result := FindIndex(Elem,aIndex,aCompare); - if result<0 then - Add(Elem); // -1 will mark success -end; - -function TDynArray.Find(const Elem): PtrInt; -var n, L: PtrInt; - cmp: integer; - P: PAnsiChar; -begin - n := GetCount; - if (@fCompare<>nil) and (n>0) then begin - dec(n); - P := fValue^; - if fSorted and (n>10) then begin - // array is sorted -> use fast O(log(n)) binary search - L := 0; - repeat - result := (L+n) shr 1; - cmp := fCompare(P[cardinal(result)*ElemSize],Elem); - if cmp=0 then - exit; - if cmp<0 then - L := result+1 else - n := result-1; - until L>n; - end else // array is very small, or not sorted - for result := 0 to n do - if fCompare(P^,Elem)=0 then // O(n) search - exit else - inc(P,ElemSize); - end; - result := -1; -end; - -function TDynArray.FindAllSorted(const Elem; out FirstIndex,LastIndex: Integer): boolean; -var found,last: integer; - P: PAnsiChar; -begin - result := FastLocateSorted(Elem,found); - if not result then - exit; - FirstIndex := found; - P := fValue^; - while (FirstIndex>0) and (fCompare(P[cardinal(FirstIndex-1)*ElemSize],Elem)=0) do - dec(FirstIndex); - last := GetCount-1; - LastIndex := found; - while (LastIndexnil then - if n=0 then // a void array is always sorted - Index := 0 else - if fSorted then begin - P := fValue^; - dec(n); - cmp := fCompare(Elem,P[cardinal(n)*ElemSize]); - if cmp>=0 then begin // greater than last sorted item - Index := n; - if cmp=0 then - result := true else // returns true + index of existing Elem - inc(Index); // returns false + insert after last position - exit; - end; - Index := 0; - while Index<=n do begin // O(log(n)) binary search of the sorted position - i := (Index+n) shr 1; - cmp := fCompare(P[cardinal(i)*ElemSize],Elem); - if cmp=0 then begin - Index := i; // returns true + index of existing Elem - result := True; - exit; - end else - if cmp<0 then - Index := i+1 else - n := i-1; - end; - // Elem not found: returns false + the index where to insert - end else - Index := -1 else // not Sorted - Index := -1; // no fCompare() -end; - -procedure TDynArray.FastAddSorted(Index: Integer; const Elem); -begin - Insert(Index,Elem); - fSorted := true; // Insert -> SetCount -> fSorted := false -end; - -procedure TDynArray.FastDeleteSorted(Index: Integer); -begin - Delete(Index); - fSorted := true; // Delete -> SetCount -> fSorted := false -end; - -function TDynArray.FastLocateOrAddSorted(const Elem; wasAdded: PBoolean): integer; -var toInsert: boolean; -begin - toInsert := not FastLocateSorted(Elem,result) and (result>=0); - if toInsert then begin - Insert(result,Elem); - fSorted := true; // Insert -> SetCount -> fSorted := false - end; - if wasAdded<>nil then - wasAdded^ := toInsert; -end; - -type - // internal structure used to make QuickSort faster & with less stack usage - TDynArrayQuickSort = object - Compare: TDynArraySortCompare; - CompareEvent: TEventDynArraySortCompare; - Pivot: pointer; - Index: PCardinalArray; - ElemSize: cardinal; - P: PtrInt; - Value: PAnsiChar; - IP, JP: PAnsiChar; - procedure QuickSort(L, R: PtrInt); - procedure QuickSortIndexed(L, R: PtrInt); - procedure QuickSortEvent(L, R: PtrInt); - procedure QuickSortEventReverse(L, R: PtrInt); - end; - -procedure QuickSortIndexedPUTF8Char(Values: PPUtf8CharArray; Count: Integer; - var SortedIndexes: TCardinalDynArray; CaseSensitive: boolean); -var QS: TDynArrayQuickSort; -begin - if CaseSensitive then - QS.Compare := SortDynArrayPUTF8Char else - QS.Compare := SortDynArrayPUTF8CharI; - QS.Value := pointer(Values); - QS.ElemSize := SizeOf(PUTF8Char); - SetLength(SortedIndexes,Count); - FillIncreasing(pointer(SortedIndexes),0,Count); - QS.Index := pointer(SortedIndexes); - QS.QuickSortIndexed(0,Count-1); -end; - -procedure DynArraySortIndexed(Values: pointer; ElemSize, Count: Integer; - out Indexes: TSynTempBuffer; Compare: TDynArraySortCompare); -var QS: TDynArrayQuickSort; -begin - QS.Compare := Compare; - QS.Value := Values; - QS.ElemSize := ElemSize; - QS.Index := pointer(Indexes.InitIncreasing(Count)); - QS.QuickSortIndexed(0,Count-1); -end; - -procedure TDynArrayQuickSort.QuickSort(L, R: PtrInt); -var I, J: PtrInt; - {$ifndef PUREPASCAL}tmp: pointer;{$endif} -begin - if L0 do begin - dec(J); - dec(JP,ElemSize); - end; - if I <= J then begin - if I<>J then - {$ifndef PUREPASCAL} // inlined Exchg() is just fine - if ElemSize=SizeOf(pointer) then begin - // optimized version e.g. for TRawUTF8DynArray/TObjectDynArray - tmp := PPointer(IP)^; - PPointer(IP)^ := PPointer(JP)^; - PPointer(JP)^ := tmp; - end else - {$endif} - // generic exchange of row element data - Exchg(IP,JP,ElemSize); - if P = I then P := J else - if P = J then P := I; - Inc(I); Dec(J); - end; - until I > J; - if J - L < R - I then begin // use recursion only for smaller range - if L < J then - QuickSort(L, J); - L := I; - end else begin - if I < R then - QuickSort(I, R); - R := J; - end; - until L >= R; -end; - -procedure TDynArrayQuickSort.QuickSortEvent(L, R: PtrInt); -var I, J: PtrInt; -begin - if L0 do begin - dec(J); - dec(JP,ElemSize); - end; - if I <= J then begin - if I<>J then - Exchg(IP,JP,ElemSize); - if P = I then P := J else - if P = J then P := I; - Inc(I); Dec(J); - end; - until I > J; - if J - L < R - I then begin // use recursion only for smaller range - if L < J then - QuickSortEvent(L, J); - L := I; - end else begin - if I < R then - QuickSortEvent(I, R); - R := J; - end; - until L >= R; -end; - -procedure TDynArrayQuickSort.QuickSortEventReverse(L, R: PtrInt); -var I, J: PtrInt; -begin - if L0 do begin - inc(I); - inc(IP,ElemSize); - end; - while CompareEvent(JP^,Pivot^)<0 do begin - dec(J); - dec(JP,ElemSize); - end; - if I <= J then begin - if I<>J then - Exchg(IP,JP,ElemSize); - if P = I then P := J else - if P = J then P := I; - Inc(I); Dec(J); - end; - until I > J; - if J - L < R - I then begin // use recursion only for smaller range - if L < J then - QuickSortEventReverse(L, J); - L := I; - end else begin - if I < R then - QuickSortEventReverse(I, R); - R := J; - end; - until L >= R; -end; - -procedure TDynArrayQuickSort.QuickSortIndexed(L, R: PtrInt); -var I, J: PtrInt; - tmp: integer; -begin - if L0 do dec(J); - if I <= J then begin - if I<>J then begin - tmp := Index[I]; - Index[I] := Index[J]; - Index[J] := tmp; - end; - if P = I then P := J else - if P = J then P := I; - Inc(I); Dec(J); - end; - until I > J; - if J - L < R - I then begin // use recursion only for smaller range - if L < J then - QuickSortIndexed(L, J); - L := I; - end else begin - if I < R then - QuickSortIndexed(I, R); - R := J; - end; - until L >= R; -end; - -procedure TDynArray.Sort(aCompare: TDynArraySortCompare); -begin - SortRange(0,Count-1,aCompare); - fSorted := true; -end; - -procedure QuickSortPtr(L, R: PtrInt; Compare: TDynArraySortCompare; V: PPointerArray); -var I, J, P: PtrInt; - tmp: pointer; -begin - if L0 do - dec(J); - if I <= J then begin - tmp := V[I]; - V[I] := V[J]; - V[J] := tmp; - if P = I then P := J else - if P = J then P := I; - Inc(I); Dec(J); - end; - until I > J; - if J - L < R - I then begin // use recursion only for smaller range - if L < J then - QuickSortPtr(L, J, Compare, V); - L := I; - end else begin - if I < R then - QuickSortPtr(I, R, Compare, V); - R := J; - end; - until L >= R; -end; - -procedure TDynArray.SortRange(aStart, aStop: integer; aCompare: TDynArraySortCompare); -var QuickSort: TDynArrayQuickSort; -begin - if aStop<=aStart then - exit; // nothing to sort - if @aCompare=nil then - Quicksort.Compare := @fCompare else - Quicksort.Compare := aCompare; - if (@Quicksort.Compare<>nil) and (fValue<>nil) and (fValue^<>nil) then - if ElemSize=SizeOf(pointer) then - QuickSortPtr(aStart,aStop,QuickSort.Compare,fValue^) else begin - Quicksort.Value := fValue^; - Quicksort.ElemSize := ElemSize; - Quicksort.QuickSort(aStart,aStop); - end; -end; - -procedure TDynArray.Sort(const aCompare: TEventDynArraySortCompare; aReverse: boolean); -var QuickSort: TDynArrayQuickSort; - R: PtrInt; -begin - if not Assigned(aCompare) or (fValue = nil) or (fValue^=nil) then - exit; // nothing to sort - Quicksort.CompareEvent := aCompare; - Quicksort.Value := fValue^; - Quicksort.ElemSize := ElemSize; - R := Count-1; - if aReverse then - Quicksort.QuickSortEventReverse(0,R) else - Quicksort.QuickSortEvent(0,R); -end; - -procedure TDynArray.CreateOrderedIndex(var aIndex: TIntegerDynArray; - aCompare: TDynArraySortCompare); -var QuickSort: TDynArrayQuickSort; - n: integer; -begin - if @aCompare=nil then - Quicksort.Compare := @fCompare else - Quicksort.Compare := aCompare; - if (@QuickSort.Compare<>nil) and (fValue<>nil) and (fValue^<>nil) then begin - n := GetCount; - if length(aIndex)nil) and (fValue<>nil) and (fValue^<>nil) then begin - n := GetCount; - Quicksort.Value := fValue^; - Quicksort.ElemSize := ElemSize; - Quicksort.Index := PCardinalArray(aIndex.InitIncreasing(n)); - Quicksort.QuickSortIndexed(0,n-1); - end else - aIndex.buf := nil; // avoid GPF in aIndex.Done -end; - -procedure TDynArray.CreateOrderedIndexAfterAdd(var aIndex: TIntegerDynArray; - aCompare: TDynArraySortCompare); -var ndx: integer; -begin - ndx := GetCount-1; - if ndx<0 then - exit; - if aIndex<>nil then begin // whole FillIncreasing(aIndex[]) for first time - if ndx>=length(aIndex) then - SetLength(aIndex,NextGrow(ndx)); // grow aIndex[] if needed - aIndex[ndx] := ndx; - end; - CreateOrderedIndex(aIndex,aCompare); -end; - -function TDynArray.ElemEquals(const A,B): boolean; -begin - if @fCompare<>nil then - result := fCompare(A,B)=0 else - if ElemType=nil then - case ElemSize of // optimized versions for arrays of common types - 1: result := byte(A)=byte(B); - 2: result := word(A)=word(B); - 4: result := cardinal(A)=cardinal(B); - 8: result := Int64(A)=Int64(B); - 16: result := IsEqual(THash128(A),THash128(B)); - else result := CompareMemFixed(@A,@B,ElemSize); // binary comparison - end else - if PTypeKind(ElemType)^ in tkRecordTypes then // most likely - result := RecordEquals(A,B,ElemType) else - result := ManagedTypeCompare(@A,@B,ElemType)>0; // other complex types -end; - -{$ifndef DELPHI5OROLDER} // disabled for Delphi 5 buggy compiler -procedure TDynArray.InitFrom(const aAnother: TDynArray; var aValue); -begin - self := aAnother; - fValue := @aValue; - fCountP := nil; -end; - -procedure TDynArray.AddDynArray(const aSource: TDynArray; aStartIndex: integer; - aCount: integer); -var SourceCount: integer; -begin - if (aSource.fValue<>nil) and (ArrayType=aSource.ArrayType) then begin - SourceCount := aSource.Count; - if (aCount<0) or (aCount>SourceCount) then - aCount := SourceCount; // force use of external Source.Count, if any - AddArray(aSource.fValue^,aStartIndex,aCount); - end; -end; - -function TDynArray.Equals(const B: TDynArray; ignorecompare: boolean): boolean; -var i, n: integer; - P1,P2: PAnsiChar; - A1: PPointerArray absolute P1; - A2: PPointerArray absolute P2; - function HandleObjArray: boolean; - var tmp1,tmp2: RawUTF8; - begin - SaveToJSON(tmp1); - B.SaveToJSON(tmp2); - result := tmp1=tmp2; - end; -begin - result := false; - if ArrayType<>B.ArrayType then - exit; // array types should match exactly - n := GetCount; - if n<>B.Count then - exit; - if GetIsObjArray then begin - result := HandleObjArray; - exit; - end; - P1 := fValue^; - P2 := B.fValue^; - if (@fCompare<>nil) and not ignorecompare then // use customized comparison - for i := 1 to n do - if fCompare(P1^,P2^)<>0 then - exit else begin - inc(P1,ElemSize); - inc(P2,ElemSize); - end else - if ElemType=nil then begin // binary type is compared as a whole - result := CompareMem(P1,P2,ElemSize*cardinal(n)); - exit; - end else - case PTypeKind(ElemType)^ of // some optimized versions for most used types - tkLString{$ifdef FPC},tkLStringOld{$endif}: - for i := 0 to n-1 do - if AnsiString(A1^[i])<>AnsiString(A2^[i]) then - exit; - tkWString: - for i := 0 to n-1 do - if WideString(A1^[i])<>WideString(A2^[i]) then - exit; - {$ifdef HASVARUSTRING} - tkUString: - for i := 0 to n-1 do - if UnicodeString(A1^[i])<>UnicodeString(A2^[i]) then - exit; - {$endif} - tkRecord{$ifdef FPC},tkObject{$endif}: - for i := 1 to n do - if not RecordEquals(P1^,P2^,ElemType) then - exit else begin - inc(P1,ElemSize); - inc(P2,ElemSize); - end; - else // generic TypeInfoCompare() use - for i := 1 to n do - if ManagedTypeCompare(P1,P2,ElemType)<=0 then - exit else begin // A^<>B^ or unexpected type - inc(P1,ElemSize); - inc(P2,ElemSize); - end; - end; - result := true; -end; - -procedure TDynArray.Copy(const Source: TDynArray; ObjArrayByRef: boolean); -var n: Cardinal; -begin - if (fValue=nil) or (ArrayType<>Source.ArrayType) then - exit; - if (fCountP<>nil) and (Source.fCountP<>nil) then - SetCapacity(Source.GetCapacity); - n := Source.Count; - SetCount(n); - if n<>0 then - if ElemType=nil then - if not ObjArrayByRef and GetIsObjArray then - LoadFromJSON(pointer(Source.SaveToJSON)) else - MoveFast(Source.fValue^^,fValue^^,n*ElemSize) else - CopyArray(fValue^,Source.fValue^,ElemType,n); -end; - -procedure TDynArray.CopyFrom(const Source; MaxElem: integer; ObjArrayByRef: boolean); -var SourceDynArray: TDynArray; -begin - SourceDynArray.Init(fTypeInfo,pointer(@Source)^); - SourceDynArray.fCountP := @MaxElem; // would set Count=0 at Init() - Copy(SourceDynArray,ObjArrayByRef); -end; - -procedure TDynArray.CopyTo(out Dest; ObjArrayByRef: boolean); -var DestDynArray: TDynArray; -begin - DestDynArray.Init(fTypeInfo,Dest); - DestDynArray.Copy(self,ObjArrayByRef); -end; -{$endif DELPHI5OROLDER} - -function TDynArray.IndexOf(const Elem): PtrInt; -var P: PPointerArray; - max: PtrInt; -begin - if fValue<>nil then begin - max := GetCount-1; - P := fValue^; - if @Elem<>nil then - if ElemType=nil then begin - result := AnyScanIndex(P,@Elem,max+1,ElemSize); - exit; - end else - case PTypeKind(ElemType)^ of - tkLString{$ifdef FPC},tkLStringOld{$endif}: - for result := 0 to max do - if AnsiString(P^[result])=AnsiString(Elem) then exit; - tkWString: - for result := 0 to max do - if WideString(P^[result])=WideString(Elem) then exit; - {$ifdef HASVARUSTRING} - tkUString: - for result := 0 to max do - if UnicodeString(P^[result])=UnicodeString(Elem) then exit; - {$endif} - {$ifndef NOVARIANTS} - tkVariant: - for result := 0 to max do - if SortDynArrayVariantComp(PVarDataStaticArray(P)^[result], - TVarData(Elem),false)=0 then exit; - {$endif} - tkRecord{$ifdef FPC},tkObject{$endif}: - // RecordEquals() works with packed records containing binary and string types - for result := 0 to max do - if RecordEquals(P^,Elem,ElemType) then - exit else - inc(PByte(P),ElemSize); - tkInterface: - for result := 0 to max do - if P^[result]=pointer(Elem) then exit; - else - for result := 0 to max do - if ManagedTypeCompare(pointer(P),@Elem,ElemType)>0 then - exit else - inc(PByte(P),ElemSize); - end; - end; - result := -1; -end; - -procedure TDynArray.Init(aTypeInfo: pointer; var aValue; aCountPointer: PInteger); -begin - fValue := @aValue; - fTypeInfo := aTypeInfo; - if PTypeKind(aTypeInfo)^<>tkDynArray then // inlined GetTypeInfo() - raise ESynException.CreateUTF8('TDynArray.Init: % is %, expected tkDynArray', - [ArrayTypeShort^,ToText(PTypeKind(aTypeInfo)^)^]); - {$ifdef HASALIGNTYPEDATA} - aTypeInfo := FPCTypeInfoOverName(aTypeInfo); - {$else} - inc(PByte(aTypeInfo),PTypeInfo(aTypeInfo)^.NameLen); - {$endif} - fElemSize := PTypeInfo(aTypeInfo)^.elSize {$ifdef FPC}and $7FFFFFFF{$endif}; - fElemType := PTypeInfo(aTypeInfo)^.elType; - if fElemType<>nil then begin // inlined DeRef() - {$ifndef HASDIRECTTYPEINFO} - // FPC compatibility: if you have a GPF here at startup, your 3.1 trunk - // revision seems older than June 2016 - // -> enable HASDIRECTTYPEINFO conditional below $ifdef VER3_1 in Synopse.inc - // or in your project's options - fElemType := PPointer(fElemType)^; - {$endif HASDIRECTTYPEINFO} - {$ifdef FPC} - if not (PTypeKind(fElemType)^ in tkManagedTypes) then - fElemType := nil; // as with Delphi - {$endif FPC} - end; - {$ifdef DYNARRAYELEMTYPE2} // disabled not to break backward compatibility - fElemType2 := PTypeInfo(aTypeInfo)^.elType2; - {$endif} - fCountP := aCountPointer; - if fCountP<>nil then - fCountP^ := 0; - fCompare := nil; - fParser := DYNARRAY_PARSERUNKNOWN; - fKnownSize := 0; - fSorted := false; - fKnownType := djNone; - fIsObjArray := oaUnknown; -end; - -procedure TDynArray.InitSpecific(aTypeInfo: pointer; var aValue; aKind: TDynArrayKind; - aCountPointer: PInteger; aCaseInsensitive: boolean); -var Comp: TDynArraySortCompare; -begin - Init(aTypeInfo,aValue,aCountPointer); - Comp := DYNARRAY_SORTFIRSTFIELD[aCaseInsensitive,aKind]; - if @Comp=nil then - raise ESynException.CreateUTF8('TDynArray.InitSpecific(%) wrong aKind=%', - [ArrayTypeShort^,ToText(aKind)^]); - fCompare := Comp; - fKnownType := aKind; - fKnownSize := KNOWNTYPE_SIZE[aKind]; -end; - -procedure TDynArray.UseExternalCount(var aCountPointer: Integer); -begin - fCountP := @aCountPointer; -end; - -function TDynArray.HasCustomJSONParser: boolean; -begin - if fParser=DYNARRAY_PARSERUNKNOWN then - fParser := GlobalJSONCustomParsers.DynArraySearch(ArrayType,ElemType); - result := cardinal(fParser)nil); - if result then - fIsObjArray := oaTrue else - fIsObjArray := oaFalse; -end; - -procedure TDynArray.SetIsObjArray(aValue: boolean); -begin - if aValue then - fIsObjArray := oaTrue else - fIsObjArray := oaFalse; -end; - -procedure TDynArray.InternalSetLength(OldLength,NewLength: PtrUInt); -var p: PDynArrayRec; - NeededSize, minLength: PtrUInt; - pp: pointer; -begin // this method is faster than default System.DynArraySetLength() function - p := fValue^; - // check that new array length is not just a finalize in disguise - if NewLength=0 then begin - if p<>nil then begin // FastDynArrayClear() with ObjArray support - dec(p); - if (p^.refCnt>=0) and DACntDecFree(p^.refCnt) then begin - if OldLength<>0 then - if ElemType<>nil then - FastFinalizeArray(fValue^,ElemType,OldLength) else - if GetIsObjArray then - RawObjectsClear(fValue^,OldLength); - FreeMem(p); - end; - fValue^ := nil; - end; - exit; - end; - // calculate the needed size of the resulting memory structure on heap - NeededSize := NewLength*ElemSize+SizeOf(TDynArrayRec); - {$ifndef CPU64} - if NeededSize>1024*1024*1024 then // max workable memory block is 1 GB - raise ERangeError.CreateFmt('TDynArray SetLength(%s,%d) size concern', - [ArrayTypeShort^,NewLength]); - {$endif} - // if not shared (refCnt=1), resize; if shared, create copy (not thread safe) - if p=nil then begin - p := AllocMem(NeededSize); // RTL/OS will return zeroed memory - OldLength := NewLength; // no FillcharFast() below - end else begin - dec(PtrUInt(p),SizeOf(TDynArrayRec)); // p^ = start of heap object - if (p^.refCnt>=0) and DACntDecFree(p^.refCnt) then begin - if NewLengthnil then // release managed types in trailing items - FastFinalizeArray(pointer(PAnsiChar(p)+NeededSize),ElemType,OldLength-NewLength) else - if GetIsObjArray then // FreeAndNil() of resized objects list - RawObjectsClear(pointer(PAnsiChar(p)+NeededSize),OldLength-NewLength); - ReallocMem(p,NeededSize); - end else begin // make copy - GetMem(p,NeededSize); - minLength := OldLength; - if minLength>NewLength then - minLength := NewLength; - pp := PAnsiChar(p)+SizeOf(TDynArrayRec); - if ElemType<>nil then begin - FillCharFast(pp^,minLength*elemSize,0); - CopyArray(pp,fValue^,ElemType,minLength); - end else - MoveFast(fValue^^,pp^,minLength*elemSize); - end; - end; - // set refCnt=1 and new length to the heap header - with p^ do begin - refCnt := 1; - {$ifdef FPC} - high := newLength-1; - {$else} - length := newLength; - {$endif} - end; - inc(PByte(p),SizeOf(p^)); // p^ = start of dynamic aray items - fValue^ := p; - // reset new allocated elements content to zero - if NewLength>OldLength then begin - OldLength := OldLength*elemSize; - FillCharFast(PAnsiChar(p)[OldLength],NewLength*ElemSize-OldLength,0); - end; -end; - -procedure TDynArray.SetCount(aCount: PtrInt); -const MINIMUM_SIZE = 64; -var oldlen, extcount, arrayptr, capa, delta: PtrInt; -begin - arrayptr := PtrInt(fValue); - extcount := PtrInt(fCountP); - fSorted := false; - if arrayptr=0 then - exit; // avoid GPF if void - arrayptr := PPtrInt(arrayptr)^; - if extcount<>0 then begin // fCountP^ as external capacity - oldlen := PInteger(extcount)^; - delta := aCount-oldlen; - if delta=0 then - exit; - PInteger(extcount)^ := aCount; // store new length - if arrayptr=0 then begin // void array - if (delta>0) and (aCount0 then begin // size-up - if capa>=aCount then - exit; // no need to grow - capa := NextGrow(capa); - if capa>aCount then - aCount := capa; // grow by chunks - end else // size-down - if (aCount>0) and ((capa<=MINIMUM_SIZE) or (capa-aCount realloc - InternalSetLength(oldlen,aCount); -end; - -function TDynArray.GetCapacity: PtrInt; -begin // capacity = length(DynArray) - result := PtrInt(fValue); - if result<>0 then begin - result := PPtrInt(result)^; - if result<>0 then - result := PDALen(result-_DALEN)^{$ifdef FPC}+1{$endif}; - end; -end; - -procedure TDynArray.SetCapacity(aCapacity: PtrInt); -var oldlen,capa: PtrInt; -begin - if fValue=nil then - exit; - capa := GetCapacity; - if fCountP<>nil then begin - oldlen := fCountP^; - if oldlen>aCapacity then - fCountP^ := aCapacity; - end else - oldlen := capa; - if capa<>aCapacity then - InternalSetLength(oldlen,aCapacity); -end; - -procedure TDynArray.SetCompare(const aCompare: TDynArraySortCompare); -begin - if @aCompare<>@fCompare then begin - @fCompare := @aCompare; - fSorted := false; - end; -end; - -procedure TDynArray.Slice(var Dest; aCount, aFirstIndex: cardinal); -var n: Cardinal; - D: PPointer; - P: PAnsiChar; -begin - if fValue=nil then - exit; // avoid GPF if void - n := GetCount; - if aFirstIndex>=n then - aCount := 0 else - if aCount>=n-aFirstIndex then - aCount := n-aFirstIndex; - DynArray(ArrayType,Dest).SetCapacity(aCount); - if aCount>0 then begin - D := @Dest; - P := PAnsiChar(fValue^)+aFirstIndex*ElemSize; - if ElemType=nil then - MoveFast(P^,D^^,aCount*ElemSize) else - CopyArray(D^,P,ElemType,aCount); - end; -end; - -function TDynArray.AddArray(const DynArrayVar; aStartIndex, aCount: integer): integer; -var c, n: integer; - PS,PD: pointer; -begin - result := 0; - if fValue=nil then - exit; // avoid GPF if void - c := DynArrayLength(pointer(DynArrayVar)); - if aStartIndex>=c then - exit; // nothing to copy - if (aCount<0) or (cardinal(aStartIndex+aCount)>cardinal(c)) then - aCount := c-aStartIndex; - if aCount<=0 then - exit; - result := aCount; - n := GetCount; - SetCount(n+aCount); - PS := pointer(PtrUInt(DynArrayVar)+cardinal(aStartIndex)*ElemSize); - PD := pointer(PtrUInt(fValue^)+cardinal(n)*ElemSize); - if ElemType=nil then - MoveFast(PS^,PD^,cardinal(aCount)*ElemSize) else - CopyArray(PD,PS,ElemType,aCount); -end; - -procedure TDynArray.ElemClear(var Elem); -begin - if @Elem=nil then - exit; // avoid GPF - if ElemType<>nil then - {$ifdef FPC}FPCFinalize{$else}_Finalize{$endif}(@Elem,ElemType) else - if (fIsObjArray=oaTrue) or ((fIsObjArray=oaUnknown) and ComputeIsObjArray) then - TObject(Elem).Free; - FillCharFast(Elem,ElemSize,0); // always -end; - -function TDynArray.ElemLoad(Source,SourceMax: PAnsiChar): RawByteString; -begin - if (Source<>nil) and (ElemType=nil) then - SetString(result,Source,ElemSize) else begin - SetString(result,nil,ElemSize); - FillCharFast(pointer(result)^,ElemSize,0); - ElemLoad(Source,pointer(result)^); - end; -end; - -procedure TDynArray.ElemLoadClear(var ElemTemp: RawByteString); -begin - ElemClear(pointer(ElemTemp)); - ElemTemp := ''; -end; - -procedure TDynArray.ElemLoad(Source: PAnsiChar; var Elem; SourceMax: PAnsiChar); -begin - if Source<>nil then // avoid GPF - if ElemType=nil then begin - if (SourceMax=nil) or (Source+ElemSize<=SourceMax) then - MoveFast(Source^,Elem,ElemSize); - end else - ManagedTypeLoad(@Elem,Source,ElemType,SourceMax); -end; - -function TDynArray.ElemSave(const Elem): RawByteString; -var itemsize: integer; -begin - if ElemType=nil then - SetString(result,PAnsiChar(@Elem),ElemSize) else begin - SetString(result,nil,ManagedTypeSaveLength(@Elem,ElemType,itemsize)); - if result<>'' then - ManagedTypeSave(@Elem,pointer(result),ElemType,itemsize); - end; -end; - -function TDynArray.ElemLoadFind(Source, SourceMax: PAnsiChar): integer; -var tmp: array[0..2047] of byte; - data: pointer; -begin - result := -1; - if (Source=nil) or (ElemSize>SizeOf(tmp)) then - exit; - if ElemType=nil then - data := Source else begin - FillCharFast(tmp,ElemSize,0); - ManagedTypeLoad(@tmp,Source,ElemType,SourceMax); - if Source=nil then - exit; - data := @tmp; - end; - try - if @fCompare=nil then - result := IndexOf(data^) else - result := Find(data^); - finally - if ElemType<>nil then - {$ifdef FPC}FPCFinalize{$else}_Finalize{$endif}(data,ElemType); - end; -end; - - -{ TDynArrayLoadFrom } - -function TDynArrayLoadFrom.Init(ArrayTypeInfo: pointer; Source: PAnsiChar; - SourceMaxLen: PtrInt): boolean; -var fake: pointer; -begin - result := false; - Position := nil; // force Step() to return false if called aterwards - if Source=nil then - exit; - if SourceMaxLen=0 then - PositionEnd := nil else - PositionEnd := Source+SourceMaxLen; - DynArray.Init(ArrayTypeInfo,fake); // just to retrieve RTTI - Count := DynArray.LoadFromHeader(PByte(Source),PByte(PositionEnd)); - if Count<0 then - exit; - Hash := pointer(Source); - Position := @Hash[1]; - Current := 0; - result := true; -end; - -function TDynArrayLoadFrom.Init(ArrayTypeInfo: pointer; const Source: RawByteString): boolean; -begin - result := Init(ArrayTypeInfo,pointer(Source),length(Source)); -end; - -function TDynArrayLoadFrom.Step(out Elem): boolean; -begin - result := false; - if (Position<>nil) and (Currentnil) and (Position+DynArray.ElemSize>PositionEnd) then - exit; - MoveFast(Position^,Elem,DynArray.ElemSize); - inc(Position,DynArray.ElemSize); - end else begin - ManagedTypeLoad(@Elem,Position,DynArray.ElemType,PositionEnd); - if Position=nil then - exit; - end; - inc(Current); - result := true; - end; -end; - -function TDynArrayLoadFrom.FirstField(out Field): boolean; -begin - if (Position<>nil) and (Currentnil) and (Hash32(@Hash[1],Position-PAnsiChar(@Hash[1]))=Hash[0]); -end; - - -{ TDynArrayHasher } - -function HashFile(const FileName: TFileName; Hasher: THasher): cardinal; -var buf: array[word] of cardinal; // 256KB of buffer - read: integer; - f: THandle; -begin - if not Assigned(Hasher) then - Hasher := DefaultHasher; - result := 0; - f := FileOpenSequentialRead(FileName); - if PtrInt(f)>=0 then begin - repeat - read := FileRead(f,buf,SizeOf(buf)); - if read<=0 then - break; - result := Hasher(result,@buf,read); - until false; - FileClose(f); - end; -end; - -function HashAnsiString(const Elem; Hasher: THasher): cardinal; -begin - if PtrUInt(Elem)=0 then - result := 0 else - result := Hasher(0,Pointer(Elem),PStrLen(PtrUInt(Elem)-_STRLEN)^); -end; - -function HashAnsiStringI(const Elem; Hasher: THasher): cardinal; -var tmp: array[byte] of AnsiChar; // avoid slow heap allocation -begin - if PtrUInt(Elem)=0 then - result := 0 else - result := Hasher(0,tmp,UpperCopy255Buf(tmp, - pointer(Elem),PStrLen(PtrUInt(Elem)-_STRLEN)^)-tmp); -end; - -{$ifdef UNICODE} - -function HashUnicodeString(const Elem; Hasher: THasher): cardinal; -begin - if PtrUInt(Elem)=0 then - result := 0 else - result := Hasher(0,Pointer(Elem),length(UnicodeString(Elem))*2); -end; - -function HashUnicodeStringI(const Elem; Hasher: THasher): cardinal; -var tmp: array[byte] of AnsiChar; // avoid slow heap allocation -begin - if PtrUInt(Elem)=0 then - result := 0 else - result := Hasher(0,tmp,UpperCopy255W(tmp,Pointer(Elem),length(UnicodeString(Elem)))-tmp); -end; - -{$endif UNICODE} - -function HashSynUnicode(const Elem; Hasher: THasher): cardinal; -begin - if PtrUInt(Elem)=0 then - result := 0 else - result := Hasher(0,Pointer(Elem),length(SynUnicode(Elem))*2); -end; - -function HashSynUnicodeI(const Elem; Hasher: THasher): cardinal; -var tmp: array[byte] of AnsiChar; // avoid slow heap allocation -begin - if PtrUInt(Elem)=0 then - result := 0 else - result := Hasher(0,tmp,UpperCopy255W(tmp,SynUnicode(Elem))-tmp); -end; - -function HashWideString(const Elem; Hasher: THasher): cardinal; -begin // WideString internal size is in bytes, not WideChar - if PtrUInt(Elem)=0 then - result := 0 else - result := Hasher(0,Pointer(Elem),Length(WideString(Elem))*2); -end; - -function HashWideStringI(const Elem; Hasher: THasher): cardinal; -var tmp: array[byte] of AnsiChar; // avoid slow heap allocation -begin - if PtrUInt(Elem)=0 then - result := 0 else - result := Hasher(0,tmp,UpperCopy255W(tmp,pointer(Elem),Length(WideString(Elem)))-tmp); -end; - -function HashPtrUInt(const Elem; Hasher: THasher): cardinal; -begin - result := Hasher(0,@Elem,SizeOf(PtrUInt)); -end; - -function HashPointer(const Elem; Hasher: THasher): cardinal; -begin - result := Hasher(0,@Elem,SizeOf(pointer)); -end; - -function HashByte(const Elem; Hasher: THasher): cardinal; -begin - result := Hasher(0,@Elem,SizeOf(byte)); -end; - -function HashWord(const Elem; Hasher: THasher): cardinal; -begin - result := Hasher(0,@Elem,SizeOf(word)); -end; - -function HashInteger(const Elem; Hasher: THasher): cardinal; -begin - result := Hasher(0,@Elem,SizeOf(integer)); -end; - -function HashInt64(const Elem; Hasher: THasher): cardinal; -begin - result := Hasher(0,@Elem,SizeOf(Int64)); -end; - -function Hash128(const Elem; Hasher: THasher): cardinal; -begin - result := Hasher(0,@Elem,SizeOf(THash128)); -end; - -function Hash256(const Elem; Hasher: THasher): cardinal; -begin - result := Hasher(0,@Elem,SizeOf(THash256)); -end; - -function Hash512(const Elem; Hasher: THasher): cardinal; -begin - result := Hasher(0,@Elem,SizeOf(THash512)); -end; - -{$ifndef NOVARIANTS} -function VariantHash(const value: variant; CaseInsensitive: boolean; - Hasher: THasher): cardinal; -var Up: array[byte] of AnsiChar; // avoid heap allocation - vt: cardinal; - procedure ComplexType; - var tmp: RawUTF8; - begin // slow but always working conversion to string - VariantSaveJSON(value,twNone,tmp); - if CaseInsensitive then - result := Hasher(vt,Up,UpperCopy255(Up,tmp)-Up) else - result := Hasher(vt,pointer(tmp),length(tmp)); - end; -begin - if not Assigned(Hasher) then - Hasher := DefaultHasher; - vt := TVarData(value).VType; - with TVarData(value) do - case vt of - varNull, varEmpty: - result := vt; // good enough for void values - varShortInt, varByte: - result := Hasher(vt,@VByte,1); - varSmallint, varWord, varBoolean: - result := Hasher(vt,@VWord,2); - varLongWord, varInteger, varSingle: - result := Hasher(vt,@VLongWord,4); - varInt64, varDouble, varDate, varCurrency, varWord64: - result := Hasher(vt,@VInt64,SizeOf(Int64)); - varString: - if CaseInsensitive then - result := Hasher(vt,Up,UpperCopy255Buf(Up,VString,length(RawUTF8(VString)))-Up) else - result := Hasher(vt,VString,length(RawUTF8(VString))); - varOleStr {$ifdef HASVARUSTRING}, varUString{$endif}: - if CaseInsensitive then - result := Hasher(vt,Up,UpperCopy255W(Up,VOleStr,StrLenW(VOleStr))-Up) else - result := Hasher(vt,VAny,StrLenW(VOleStr)*2); - else - ComplexType; - end; -end; - -function HashVariant(const Elem; Hasher: THasher): cardinal; -begin - result := VariantHash(variant(Elem),false,Hasher); -end; - -function HashVariantI(const Elem; Hasher: THasher): cardinal; -begin - result := VariantHash(variant(Elem),true,Hasher); -end; -{$endif NOVARIANTS} - -procedure TDynArrayHasher.Init(aDynArray: PDynArray; aHashElement: TDynArrayHashOne; - aEventHash: TEventDynArrayHashOne; aHasher: THasher; aCompare: TDynArraySortCompare; - aEventCompare: TEventDynArraySortCompare; aCaseInsensitive: boolean); -begin - DynArray := aDynArray; - if @aHasher=nil then - Hasher := DefaultHasher else - Hasher := aHasher; - HashElement := aHashElement; - EventHash := aEventHash; - if (@HashElement=nil) and (@EventHash=nil) then // fallback to first field RTTI - HashElement := DYNARRAY_HASHFIRSTFIELD[aCaseInsensitive,DynArray^.GuessKnownType]; - Compare := aCompare; - EventCompare := aEventCompare; - if (@Compare=nil) and (@EventCompare=nil) then - Compare := DYNARRAY_SORTFIRSTFIELD[aCaseInsensitive,DynArray^.GuessKnownType]; - CountTrigger := 32; - Clear; -end; - -procedure TDynArrayHasher.InitSpecific(aDynArray: PDynArray; aKind: TDynArrayKind; - aCaseInsensitive: boolean); -var cmp: TDynArraySortCompare; - hsh: TDynArrayHashOne; -begin - cmp := DYNARRAY_SORTFIRSTFIELD[aCaseInsensitive,aKind]; - hsh := DYNARRAY_HASHFIRSTFIELD[aCaseInsensitive,aKind]; - if (@hsh=nil) or (@cmp=nil) then - raise ESynException.CreateUTF8('TDynArrayHasher.InitSpecific: %?',[ToText(aKind)^]); - Init(aDynArray,hsh,nil,nil,cmp,nil,aCaseInsensitive) -end; - -procedure TDynArrayHasher.Clear; -begin - HashTable := nil; - HashTableSize := 0; - ScanCounter := 0; - if Assigned(HashElement) or Assigned(EventHash) then - State := [hasHasher] else - byte(State) := 0; -end; - -function TDynArrayHasher.HashOne(Elem: pointer): cardinal; -begin - if Assigned(EventHash) then - result := EventHash(Elem^) else - if Assigned(HashElement) then - result := HashElement(Elem^,Hasher) else - result := 0; // will be ignored afterwards for sure -end; - -const // primes reduce memory consumption and enhance distribution - _PRIMES: array[0..38{$ifndef CPU32DELPHI}+15{$endif}] of integer = ( - {$ifndef CPU32DELPHI} 31, 127, 251, 499, 797, 1259, 2011, 3203, 5087, 8089, - 12853, 20399, 81649, 129607, 205759, {$endif} - // following HASH_PO2=2^18=262144 for Delphi Win32 - 326617, 411527, 518509, 653267, 823117, 1037059, 1306601, 1646237, - 2074129, 2613229, 3292489, 4148279, 5226491, 6584983, 8296553, 10453007, - 13169977, 16593127, 20906033, 26339969, 33186281, 41812097, 52679969, - 66372617, 83624237, 105359939, 132745199, 167248483, 210719881, 265490441, - 334496971, 421439783, 530980861, 668993977, 842879579, 1061961721, - 1337987929, 1685759167, 2123923447); - -function NextPrime(v: integer): integer; {$ifdef HASINLINE}inline;{$endif} -var i: PtrInt; - P: PIntegerArray; -begin - P := @_PRIMES; - for i := 0 to high(_PRIMES) do begin - result := P^[i]; - if result>v then - exit; - end; -end; - -function TDynArrayHasher.HashTableIndex(aHashCode: cardinal): cardinal; -begin - result := HashTableSize; - {$ifdef CPU32DELPHI} // Delphi Win32 is not efficient with 64-bit multiplication - if result>HASH_PO2 then - result := aHashCode mod result else - result := aHashCode and (result-1); - {$else} // FPC or dcc64 compile next line as very optimized asm - result := (QWord(aHashCode)*result)shr 32; - // see https://lemire.me/blog/2016/06/27/a-fast-alternative-to-the-modulo-reduction - {$endif CPU32DELPHI} -end; - -function TDynArrayHasher.Find(aHashCode: cardinal; aForAdd: boolean): integer; -var first,last: integer; - ndx,siz: PtrInt; - P: PAnsiChar; -begin - P := DynArray^.Value^; - siz := DynArray^.ElemSize; - if not(canHash in State) then begin // Count=0 or Count search once from HashTable[0] to HashTable[first-1] - if result=first then - break else begin - result := 0; - last := first; - end; - until false; - RaiseFatalCollision('Find',aHashCode); -end; - -function TDynArrayHasher.FindOrNew(aHashCode: cardinal; Elem: pointer; - aHashTableIndex: PInteger): integer; -var first,last,ndx,cmp: integer; - P: PAnsiChar; -begin - if not(canHash in State) then begin // e.g. Countnil then - aHashTableIndex^ := result; - result := ndx; - exit; - end; - // hash or slot collision -> search next item - {$ifdef DYNARRAYHASHCOLLISIONCOUNT} - inc(FindCollisions); - {$endif} - //inc(TDynArrayHashedCollisionCount); - inc(result); - if result=last then - // reached the end -> search once from HashTable[0] to HashTable[first-1] - if result=first then - break else begin - result := 0; - last := first; - end; - until false; - RaiseFatalCollision('FindOrNew',aHashCode); -end; - -procedure TDynArrayHasher.HashAdd(aHashCode: cardinal; var result: integer); -var n: integer; -begin // on input: HashTable[result] slot is already computed - n := DynArray^.Count; - if HashTableSize=0 then - RaiseFatalCollision('HashAdd',aHashCode); - end; - HashTable[-result-1] := n+1; // store Index+1 (0 means void slot) - result := n; -end; // on output: result holds the position in fValue[] - - -// brute force O(n) indexes fix after deletion (much faster than full ReHash) -procedure DynArrayHashTableAdjust(P: PIntegerArray; deleted: integer; count: PtrInt); -{$ifdef CPUX64ASM} // SSE2 simd is 25x faster than "if P^>deleted then dec(P^)" -{$ifdef FPC}nostackframe; assembler; asm {$else} -asm .noframe // rcx=P, edx=deleted, r8=count (Linux: rdi,esi,rdx) -{$endif FPC} -{$ifdef Linux} - mov r8, rdx - mov rcx, rdi - mov rdx, rsi -{$endif Linux} - xor eax, eax // reset eax high bits for setg al below - movq xmm0, rdx // xmm0 = 128-bit of quad deleted - pshufd xmm0, xmm0, 0 - test cl, 3 - jnz @1 // paranoid: a dword dynamic array is always dword-aligned - // ensure P is 256-bit aligned (for avx2) -@align: test cl, 31 - jz @ok - cmp dword ptr[rcx], edx - setg al // P[]>deleted -> al=1, 0 otherwise - sub dword ptr[rcx], eax // branchless dec(P[]) - add rcx, 4 - dec r8 - jmp @align -@ok: {$ifdef FPC} // AVX2 asm is not supported by Delphi (even 10.3) :( - test byte ptr[rip+CPUIDX64], 1 shl cpuAVX2 - jz @sse2 - vpshufd ymm0, ymm0, 0 // shuffle to ymm0 128-bit low lane - vperm2f128 ymm0, ymm0, ymm0, 0 // copy to ymm0 128-bit high lane - // avx process of 128 bytes (32 indexes) per loop iteration - align 16 -@avx2: sub r8, 32 - vmovdqa ymm1, [rcx] // 4 x 256-bit process = 4 x 8 integers - vmovdqa ymm3, [rcx + 32] - vmovdqa ymm5, [rcx + 64] - vmovdqa ymm7, [rcx + 96] - vpcmpgtd ymm2, ymm1, ymm0 // compare P[]>deleted -> -1, 0 otherwise - vpcmpgtd ymm4, ymm3, ymm0 - vpcmpgtd ymm6, ymm5, ymm0 - vpcmpgtd ymm8, ymm7, ymm0 - vpaddd ymm1, ymm1, ymm2 // adjust by adding -1 / 0 - vpaddd ymm3, ymm3, ymm4 - vpaddd ymm5, ymm5, ymm6 - vpaddd ymm7, ymm7, ymm8 - vmovdqa [rcx], ymm1 - vmovdqa [rcx + 32], ymm3 - vmovdqa [rcx + 64], ymm5 - vmovdqa [rcx + 96], ymm7 - add rcx, 128 - cmp r8, 32 - jae @avx2 - vzeroupper - jmp @2 - {$endif FPC} - // SSE2 process of 64 bytes (16 indexes) per loop iteration -{$ifdef FPC} align 16 {$else} .align 16 {$endif} -@sse2: sub r8, 16 - movaps xmm1, dqword [rcx] // 4 x 128-bit process = 4 x 4 integers - movaps xmm3, dqword [rcx + 16] - movaps xmm5, dqword [rcx + 32] - movaps xmm7, dqword [rcx + 48] - movaps xmm2, xmm1 // keep copy for paddd below - movaps xmm4, xmm3 - movaps xmm6, xmm5 - movaps xmm8, xmm7 - pcmpgtd xmm1, xmm0 // quad compare P[]>deleted -> -1, 0 otherwise - pcmpgtd xmm3, xmm0 - pcmpgtd xmm5, xmm0 - pcmpgtd xmm7, xmm0 - paddd xmm1, xmm2 // quad adjust by adding -1 / 0 - paddd xmm3, xmm4 - paddd xmm5, xmm6 - paddd xmm7, xmm8 - movaps dqword [rcx], xmm1 // quad store back - movaps dqword [rcx + 16], xmm3 - movaps dqword [rcx + 32], xmm5 - movaps dqword [rcx + 48], xmm7 - add rcx, 64 - cmp r8, 16 - jae @sse2 - jmp @2 - // trailing indexes -@1: dec r8 - cmp dword ptr[rcx + r8 * 4], edx - setg al - sub dword ptr[rcx + r8 * 4], eax -@2: test r8, r8 - jnz @1 -end; -{$else} -begin - repeat - dec(count,8); - dec(P[0],ord(P[0]>deleted)); // branchless code is 10x faster than if :) - dec(P[1],ord(P[1]>deleted)); - dec(P[2],ord(P[2]>deleted)); - dec(P[3],ord(P[3]>deleted)); - dec(P[4],ord(P[4]>deleted)); - dec(P[5],ord(P[5]>deleted)); - dec(P[6],ord(P[6]>deleted)); - dec(P[7],ord(P[7]>deleted)); - P := @P[8]; - until count<8; - while count>0 do begin - dec(count); - dec(P[count],ord(P[count]>deleted)); - end; -end; -{$endif CPUX64ASM} // SSE2 asm is invalid prior to Delphi XE7 (to be refined) - -// with x86_64/sse2 for 200,000 items: adjust=200.57ms (11.4GB/s) hash=2.46ms -// -> TDynArray.Delete move() takes more time than the HashTable update :) - -{ some numbers, with CITIES_MAX=200000, deleting 1/128 entries - first column (3..23) is the max number of indexes[] chunk to rehash -1. naive loop - for i := 0 to HashTableSize-1 do - if HashTable[i]>aArrayIndex then - dec(HashTable[i]); - 3 #257 adjust=7.95ms 191.7MB hash=8us - 8 #384 adjust=11.93ms 255.8MB hash=10us - 11 #1019 adjust=32.09ms 332.8MB hash=26us - 13 #16259 adjust=511.10ms 379.2MB hash=230us - 13 #32515 adjust=1.01s 383.6MB/s hash=440us - 14 #33531 adjust=1.04s 382.2MB hash=459us - 17 #46612 adjust=1.44s 386.3MB hash=639us - 17 #65027 adjust=1.97s 396.3MB/s hash=916us - 17 #97539 adjust=2.79s 419.9MB/s hash=1.37ms - 18 #109858 adjust=3.05s 431.2MB hash=1.51ms - 18 #130051 adjust=3.44s 454.1MB/s hash=1.75ms - 18 #162563 adjust=3.93s 496.9MB/s hash=2.14ms - 23 #172723 adjust=4.05s 511.7MB hash=2.26ms - 23 #195075 adjust=4.27s 548.6MB/s hash=2.47ms -2. branchless pure pascal code is about 10x faster! - 3 #257 adjust=670us 2.2GB hash=8us - 8 #384 adjust=1ms 2.9GB hash=9us - 11 #1019 adjust=2.70ms 3.8GB hash=21us - 13 #16259 adjust=43.65ms 4.3GB hash=210us - 13 #32515 adjust=87.75ms 4.3GB/s hash=423us - 14 #33531 adjust=90.44ms 4.3GB hash=441us - 17 #46612 adjust=127.68ms 4.2GB hash=627us - 17 #65027 adjust=179.64ms 4.2GB/s hash=908us - 17 #97539 adjust=267.44ms 4.2GB/s hash=1.35ms - 18 #109858 adjust=301.27ms 4.2GB hash=1.50ms - 18 #130051 adjust=355.37ms 4.2GB/s hash=1.74ms - 18 #162563 adjust=438.79ms 4.3GB/s hash=2.11ms - 23 #172723 adjust=465.23ms 4.3GB hash=2.23ms - 23 #195075 adjust=520.85ms 4.3GB/s hash=2.45ms -3. SSE2 simd assembly makes about 3x improvement - 3 #257 adjust=290us 5.1GB hash=8us - 8 #384 adjust=427us 6.9GB hash=10us - 11 #1019 adjust=1.11ms 9.3GB hash=20us - 13 #16259 adjust=18.33ms 10.3GB hash=219us - 13 #32515 adjust=36.32ms 10.5GB/s hash=435us - 14 #33531 adjust=37.39ms 10.4GB hash=452us - 17 #46612 adjust=51.70ms 10.5GB hash=622us - 17 #65027 adjust=72.47ms 10.5GB/s hash=893us - 17 #97539 adjust=107ms 10.6GB/s hash=1.32ms - 18 #109858 adjust=120.08ms 10.7GB hash=1.46ms - 18 #130051 adjust=140.50ms 10.8GB/s hash=1.71ms - 18 #162563 adjust=171.44ms 11.1GB/s hash=2.10ms - 23 #172723 adjust=181.02ms 11.1GB hash=2.22ms - 23 #195075 adjust=201.53ms 11.3GB/s hash=2.44ms -4. AVX2 simd assembly gives some additional 40% (consistent on my iCore3 cpu) - 3 #257 adjust=262us 5.6GB hash=8us - 8 #384 adjust=383us 7.7GB hash=10us - 11 #1019 adjust=994us 10.4GB hash=21us - 13 #16259 adjust=16.34ms 11.5GB hash=248us - 13 #32515 adjust=32.12ms 11.8GB/s hash=464us - 14 #33531 adjust=33.06ms 11.8GB hash=484us - 17 #46612 adjust=45.49ms 11.9GB hash=678us - 17 #65027 adjust=62.36ms 12.2GB/s hash=966us - 17 #97539 adjust=90.80ms 12.6GB/s hash=1.43ms - 18 #109858 adjust=101.82ms 12.6GB hash=1.59ms - 18 #130051 adjust=117.37ms 13GB/s hash=1.83ms - 18 #162563 adjust=140.08ms 13.6GB/s hash=2.23ms - 23 #172723 adjust=147.20ms 13.7GB hash=2.34ms - 23 #195075 adjust=161.73ms 14.1GB/s hash=2.57ms -} -procedure TDynArrayHasher.HashDelete(aArrayIndex,aHashTableIndex: integer; aHashCode: cardinal); -var first,next,last,ndx,i,n: integer; - P: PAnsiChar; - indexes: array[0..511] of cardinal; // to be rehashed -begin - // retrieve hash table entries to be recomputed - first := aHashTableIndex; - last := HashTableSize; - next := first; - n := 0; - repeat - HashTable[next] := 0; // Clear slots - inc(next); - if next=last then - if next=first then - RaiseFatalCollision('HashDelete down',aHashCode) else begin - next := 0; - last := first; - end; - ndx := HashTable[next]-1; // stored index+1 - if ndx<0 then - break; // stop at void entry - if n=high(indexes) then // typical 0..23 - RaiseFatalCollision('HashDelete indexes overflow',aHashCode); - indexes[n] := ndx; - inc(n); - until false; - // ReHash collided entries - note: item is not yet deleted in Value^[] - for i := 0 to n-1 do begin - P := PAnsiChar(DynArray^.Value^)+indexes[i]*DynArray^.ElemSize; - ndx := FindOrNew(HashOne(P),P,nil); - if ndx<0 then - HashTable[-ndx-1] := indexes[i]+1; // ignore ndx>=0 dups (like ReHash) - end; - // adjust all stored indexes - DynArrayHashTableAdjust(pointer(HashTable),aArrayIndex,HashTableSize); -end; - -function TDynArrayHasher.FindBeforeAdd(Elem: pointer; - out wasAdded: boolean; aHashCode: cardinal): integer; -var n: integer; -begin - wasAdded := false; - if not(canHash in State) then begin - n := DynArray^.Count; - if n=0 then - exit; // item found - if not(canHash in State) then begin - wasadded := true; - result := n; - exit; - end; - end; - end; - if not(canHash in State) then - ReHash({forced=}true); // hash previous CountTrigger items - result := FindOrNew(aHashCode,Elem,nil); - if result<0 then begin // found no matching item - wasAdded := true; - HashAdd(aHashCode,result); - end; -end; - -function TDynArrayHasher.FindBeforeDelete(Elem: pointer): integer; -var hc: cardinal; - ht: integer; -begin - if canHash in State then begin - hc := HashOne(Elem); - result := FindOrNew(hc,Elem,@ht); - if result<0 then - result := -1 else - HashDelete(result,ht,hc); - end else - result := Scan(Elem); -end; - -procedure TDynArrayHasher.RaiseFatalCollision(const caller: RawUTF8; - aHashCode: cardinal); -begin // a dedicated sub-procedure reduces code size - raise ESynException.CreateUTF8('TDynArrayHasher.% fatal collision: '+ - 'aHashCode=% HashTableSize=% Count=% Capacity=% ArrayType=% KnownType=%', - [caller,CardinalToHexShort(aHashCode),HashTableSize,DynArray^.Count, - DynArray^.Capacity,DynArray^.ArrayTypeShort^,ToText(DynArray^.KnownType)^]); -end; - -function TDynArrayHasher.GetHashFromIndex(aIndex: PtrInt): cardinal; -var P: pointer; -begin - P := DynArray^.ElemPtr(aIndex); - if P<>nil then - result := HashOne(P) else - result := 0; -end; - -procedure TDynArrayHasher.SetEventHash(const event: TEventDynArrayHashOne); -begin - EventHash := event; - Clear; -end; - -function TDynArrayHasher.Scan(Elem: pointer): integer; -var P: PAnsiChar; - i,max: integer; - siz: PtrInt; -begin - result := -1; - max := DynArray^.Count-1; - P := DynArray^.Value^; - siz := DynArray^.ElemSize; - if Assigned(EventCompare) then // custom comparison - for i := 0 to max do - if EventCompare(P^,Elem^)=0 then begin - result := i; - break; - end else - inc(P,siz) else - if Assigned(Compare) then - for i := 0 to max do - if Compare(P^,Elem^)=0 then begin - result := i; - break; - end else - inc(P,siz); - // enable hashing if Scan() called 2*CountTrigger - if (hasHasher in State) and (max>7) then begin - inc(ScanCounter); - if ScanCounter>=CountTrigger*2 then begin - CountTrigger := 2; // rather use hashing from now on - ReHash(false); // set HashTable[] and canHash - end; - end; -end; - -function TDynArrayHasher.Find(Elem: pointer): integer; -begin - result := Find(Elem,HashOne(Elem)); -end; - -function TDynArrayHasher.Find(Elem: pointer; aHashCode: cardinal): integer; -begin - result := FindOrNew(aHashCode,Elem,nil); // fallback to Scan() if needed - if result<0 then - result := -1; // for coherency with most search methods -end; - -function TDynArrayHasher.ReHash(forced: boolean): integer; -var i, n, cap, siz, ndx: integer; - P: PAnsiChar; - hc: cardinal; -begin - result := 0; - n := DynArray^.Count; - if not (Assigned(HashElement) or Assigned(EventHash)) or - (not forced and ((n=0) or (n=0 then - inc(result) else // found duplicated value - HashTable[-ndx-1] := i; // store index+1 (0 means void entry) - inc(P,DynArray^.ElemSize); - end; -end; - - -{ TDynArrayHashed } - -{$ifdef UNDIRECTDYNARRAY} // some Delphi 2009+ wrapper definitions - -function TDynArrayHashed.GetCount: PtrInt; -begin - result := InternalDynArray.GetCount; -end; -procedure TDynArrayHashed.SetCount(aCount: PtrInt); -begin - InternalDynArray.SetCount(aCount); -end; -function TDynArrayHashed.GetCapacity: PtrInt; -begin - result := InternalDynArray.GetCapacity; -end; -procedure TDynArrayHashed.SetCapacity(aCapacity: PtrInt); -begin - InternalDynArray.SetCapacity(aCapacity); -end; -function TDynArrayHashed.Value: PPointer; -begin - result := InternalDynArray.fValue; -end; -function TDynArrayHashed.ElemSize: PtrUInt; -begin - result := InternalDynArray.fElemSize; -end; -function TDynArrayHashed.ElemType: Pointer; -begin - result := InternalDynArray.fElemType; -end; -procedure TDynArrayHashed.ElemCopy(const A; var B); -begin - InternalDynArray.ElemCopy(A,B); -end; -function TDynArrayHashed.ElemPtr(index: PtrInt): pointer; -begin - result := InternalDynArray.ElemPtr(index); -end; -procedure TDynArrayHashed.ElemCopyAt(index: PtrInt; var Dest); -begin - InternalDynArray.ElemCopyAt(index,Dest); -end; -function TDynArrayHashed.KnownType: TDynArrayKind; -begin - result := InternalDynArray.KnownType; -end; -procedure TDynArrayHashed.Clear; -begin - InternalDynArray.SetCount(0); -end; -function TDynArrayHashed.Add(const Elem): integer; -begin - result := InternalDynArray.Add(Elem); -end; -procedure TDynArrayHashed.Delete(aIndex: PtrInt); -begin - InternalDynArray.Delete(aIndex); -end; -function TDynArrayHashed.SaveTo: RawByteString; -begin - result := InternalDynArray.SaveTo; -end; -function TDynArrayHashed.LoadFrom(Source: PAnsiChar; AfterEach: TDynArrayAfterLoadFrom; - NoCheckHash: boolean; SourceMax: PAnsiChar): PAnsiChar; -begin - result := InternalDynArray.LoadFrom(Source,AfterEach,NoCheckHash,SourceMax); -end; -function TDynArrayHashed.LoadFromBinary(const Buffer: RawByteString; NoCheckHash: boolean): boolean; -begin - result := InternalDynArray.LoadFromBinary(Buffer,NoCheckHash); -end; -function TDynArrayHashed.SaveTo(Dest: PAnsiChar): PAnsiChar; -begin - result := InternalDynArray.SaveTo(Dest); -end; -function TDynArrayHashed.SaveToJSON(EnumSetsAsText: boolean; - reformat: TTextWriterJSONFormat): RawUTF8; -begin - result := InternalDynArray.SaveToJSON(EnumSetsAsText,reformat); -end; -procedure TDynArrayHashed.Sort(aCompare: TDynArraySortCompare); -begin - InternalDynArray.Sort(aCompare); -end; -procedure TDynArrayHashed.CreateOrderedIndex(var aIndex: TIntegerDynArray; - aCompare: TDynArraySortCompare); -begin - InternalDynArray.CreateOrderedIndex(aIndex,aCompare); -end; -function TDynArrayHashed.LoadFromJSON(P: PUTF8Char; aEndOfObject: PUTF8Char{$ifndef NOVARIANTS}; - CustomVariantOptions: PDocVariantOptions{$endif}): PUTF8Char; -begin - result := InternalDynArray.LoadFromJSON(P,aEndOfObject{$ifndef NOVARIANTS}, - CustomVariantOptions{$endif}); -end; -function TDynArrayHashed.SaveToLength: integer; -begin - result := InternalDynArray.SaveToLength; -end; - -{$endif UNDIRECTDYNARRAY} - -procedure TDynArrayHashed.Init(aTypeInfo: pointer; var aValue; - aHashElement: TDynArrayHashOne; aCompare: TDynArraySortCompare; - aHasher: THasher; aCountPointer: PInteger; aCaseInsensitive: boolean); -begin - {$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$else}inherited{$endif} - Init(aTypeInfo,aValue,aCountPointer); - fHash.Init(@self,aHashElement,nil,aHasher,aCompare,nil,aCaseInsensitive); - {$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$endif}SetCompare(fHash.Compare); -end; - -procedure TDynArrayHashed.InitSpecific(aTypeInfo: pointer; var aValue; - aKind: TDynArrayKind; aCountPointer: PInteger; aCaseInsensitive: boolean); -begin - {$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$else}inherited{$endif} - Init(aTypeInfo,aValue,aCountPointer); - fHash.InitSpecific(@self,aKind,aCaseInsensitive); - {$ifdef UNDIRECTDYNARRAY}with InternalDynArray do{$endif} begin - fCompare := fHash.Compare; - fKnownType := aKind; - fKnownSize := KNOWNTYPE_SIZE[aKind]; - end; -end; - -function TDynArrayHashed.Scan(const Elem): integer; -begin - result := fHash.Scan(@Elem); -end; - -function TDynArrayHashed.FindHashed(const Elem): integer; -begin - result := fHash.FindOrNew(fHash.HashOne(@Elem),@Elem); - if result<0 then - result := -1; // for coherency with most methods -end; - -function TDynArrayHashed.FindFromHash(const Elem; aHashCode: cardinal): integer; -begin // overload FindHashed() trigger F2084 Internal Error: C2130 on Delphi XE3 - result := fHash.FindOrNew(aHashCode,@Elem); // fallback to Scan() if needed - if result<0 then - result := -1; // for coherency with most methods -end; - -function TDynArrayHashed.FindHashedForAdding(const Elem; out wasAdded: boolean; - noAddEntry: boolean): integer; -begin - result := FindHashedForAdding(Elem,wasAdded,fHash.HashOne(@Elem),noAddEntry); -end; - -function TDynArrayHashed.FindHashedForAdding(const Elem; out wasAdded: boolean; - aHashCode: cardinal; noAddEntry: boolean): integer; -begin - result := fHash.FindBeforeAdd(@Elem,wasAdded,aHashCode); - if wasAdded and not noAddEntry then - SetCount(result+1); // reserve space for a void element in array -end; - -function TDynArrayHashed.AddAndMakeUniqueName(aName: RawUTF8): pointer; -var ndx,j: integer; - added: boolean; - aName_: RawUTF8; -begin - if aName='' then - aName := '_'; - ndx := FindHashedForAdding(aName,added); - if not added then begin // force unique column name - aName_ := aName+'_'; - j := 1; - repeat - aName := aName_+UInt32ToUTF8(j); - ndx := FindHashedForAdding(aName,added); - inc(j); - until added; - end; - result := PAnsiChar(Value^)+cardinal(ndx)*ElemSize; - PRawUTF8(result)^ := aName; // store unique name at 1st elem position -end; - -function TDynArrayHashed.AddUniqueName(const aName: RawUTF8; aNewIndex: PInteger): pointer; -begin - result := AddUniqueName(aName,'',[],aNewIndex); -end; - -function TDynArrayHashed.AddUniqueName(const aName: RawUTF8; - const ExceptionMsg: RawUTF8; const ExceptionArgs: array of const; aNewIndex: PInteger): pointer; -var ndx: integer; - added: boolean; -begin - ndx := FindHashedForAdding(aName,added); - if added then begin - if aNewIndex<>nil then - aNewIndex^ := ndx; - result := PAnsiChar(Value^)+cardinal(ndx)*ElemSize; - PRawUTF8(result)^ := aName; // store unique name at 1st elem position - end else - if ExceptionMsg='' then - raise ESynException.CreateUTF8('Duplicated [%] name',[aName]) else - raise ESynException.CreateUTF8(ExceptionMsg,ExceptionArgs); -end; - -function TDynArrayHashed.FindHashedAndFill(var ElemToFill): integer; -begin - result := fHash.FindOrNew(fHash.HashOne(@ElemtoFill),@ElemToFill); - if result<0 then - result := -1 else - ElemCopy(PAnsiChar(Value^)[cardinal(result)*ElemSize],ElemToFill); -end; - -procedure TDynArrayHashed.SetEventHash(const event: TEventDynArrayHashOne); -begin - fHash.SetEventHash(event); -end; - -function TDynArrayHashed.FindHashedAndUpdate(const Elem; AddIfNotExisting: boolean): integer; -var hc: cardinal; -label doh; -begin - if canHash in fHash.State then begin -doh:hc := fHash.HashOne(@Elem); - result := fHash.FindOrNew(hc,@Elem); - if (result<0) and AddIfNotExisting then begin - fHash.HashAdd(hc,result); // ReHash only if necessary - SetCount(result+1); // add new item - end; - end else begin - result := fHash.Scan(@Elem); - if result<0 then begin - if AddIfNotExisting then - if canHash in fHash.State then // Scan triggered ReHash - goto doh else begin - result := Add(Elem); // regular Add - exit; - end; - end; - end; - if result>=0 then - ElemCopy(Elem,PAnsiChar(Value^)[cardinal(result)*ElemSize]); // update -end; - -function TDynArrayHashed.FindHashedAndDelete(const Elem; FillDeleted: pointer; - noDeleteEntry: boolean): integer; -begin - result := fHash.FindBeforeDelete(@Elem); - if result>=0 then begin - if FillDeleted<>nil then - ElemCopyAt(result,FillDeleted^); - if not noDeleteEntry then - Delete(result); - end; -end; - -function TDynArrayHashed.GetHashFromIndex(aIndex: PtrInt): Cardinal; -begin - result := fHash.GetHashFromIndex(aIndex); -end; - -function TDynArrayHashed.ReHash(forAdd: boolean): integer; -begin - result := fHash.ReHash(forAdd); -end; - - -function DynArray(aTypeInfo: pointer; var aValue; aCountPointer: PInteger): TDynArray; -begin - result.Init(aTypeInfo,aValue,aCountPointer); -end; - -function SimpleDynArrayLoadFrom(Source: PAnsiChar; aTypeInfo: pointer; - var Count, ElemSize: integer; NoHash32Check: boolean): pointer; -var Hash: PCardinalArray absolute Source; - info: PTypeInfo; -begin - result := nil; - info := GetTypeInfo(aTypeInfo,tkDynArray); - if info=nil then - exit; // invalid type information - ElemSize := info^.elSize {$ifdef FPC}and $7FFFFFFF{$endif}; - if (info^.ElType<>nil) or (Source=nil) or - (Source[0]<>AnsiChar(ElemSize)) or (Source[1]<>#0) then - exit; // invalid type information or Source content - inc(Source,2); - Count := FromVarUInt32(PByte(Source)); // dynamic array count - if (Count<>0) and (NoHash32Check or (Hash32(@Hash[1],Count*ElemSize)=Hash[0])) then - result := @Hash[1]; // returns valid Source content -end; - -function IntegerDynArrayLoadFrom(Source: PAnsiChar; var Count: integer; - NoHash32Check: boolean): PIntegerArray; -var Hash: PCardinalArray absolute Source; -begin - result := nil; - if (Source=nil) or (Source[0]<>#4) or (Source[1]<>#0) then - exit; // invalid Source content - inc(Source,2); - Count := FromVarUInt32(PByte(Source)); // dynamic array count - if (Count<>0) and (NoHash32Check or (Hash32(@Hash[1],Count*4)=Hash[0])) then - result := @Hash[1]; // returns valid Source content -end; - -function RawUTF8DynArrayLoadFromContains(Source: PAnsiChar; - Value: PUTF8Char; ValueLen: PtrInt; CaseSensitive: boolean): PtrInt; -var Count, Len: PtrInt; -begin - if (Value=nil) or (ValueLen=0) or - (Source=nil) or (Source[0]<>AnsiChar(SizeOf(PtrInt))) - {$ifndef FPC}or (Source[1]<>AnsiChar(tkLString)){$endif} then begin - result := -1; - exit; // invalid Source or Value content - end; - inc(Source,2); - Count := FromVarUInt32(PByte(Source)); // dynamic array count - inc(Source,SizeOf(cardinal)); // ignore Hash32 security checksum - for result := 0 to Count-1 do begin - Len := FromVarUInt32(PByte(Source)); - if CaseSensitive then begin - if (Len=ValueLen) and CompareMemFixed(Value,Source,Len) then - exit; - end else - if UTF8ILComp(Value,pointer(Source),ValueLen,Len)=0 then - exit; - inc(Source,Len); - end; - result := -1; -end; - - -{ TObjectDynArrayWrapper } - -constructor TObjectDynArrayWrapper.Create(var aValue; aOwnObjects: boolean); -begin - fValue := @aValue; - fOwnObjects := aOwnObjects; -end; - -destructor TObjectDynArrayWrapper.Destroy; -begin - Clear; - inherited; -end; - -function TObjectDynArrayWrapper.Find(Instance: TObject): integer; -var P: PObjectArray; -begin - P := fValue^; - if P<>nil then - for result := 0 to fCount-1 do - if P[result]=Instance then - exit; - result := -1; -end; - -function TObjectDynArrayWrapper.Add(Instance: TObject): integer; -var cap: integer; -begin - cap := length(TObjectDynArray(fValue^)); - if cap<=fCount then - SetLength(TObjectDynArray(fValue^),NextGrow(cap)); - result := fCount; - TObjectDynArray(fValue^)[result] := Instance; - inc(fCount); -end; - -procedure TObjectDynArrayWrapper.Delete(Index: integer); -var P: PObjectArray; -begin - P := fValue^; - if (P=nil) or (cardinal(Index)>=cardinal(fCount)) then - exit; // avoid Out of range - if fOwnObjects then - P[Index].Free; - dec(fCount); - if fCount>Index then - MoveFast(P[Index+1],P[Index],(fCount-Index)*SizeOf(pointer)); -end; - -procedure TObjectDynArrayWrapper.Clear; -var i: PtrInt; - P: PObjectArray; -begin - P := fValue^; - if P<>nil then begin - if fOwnObjects then - for i := fCount-1 downto 0 do - try - P[i].Free; - except - on Exception do; - end; - TObjectDynArray(fValue^) := nil; // set capacity to 0 - fCount := 0; - end else - if fCount>0 then - raise ESynException.Create('You MUST define your IObjectDynArray field '+ - 'BEFORE the corresponding dynamic array'); -end; - -procedure TObjectDynArrayWrapper.Slice; -begin - SetLength(TObjectDynArray(fValue^),fCount); -end; - -function TObjectDynArrayWrapper.Count: integer; -begin - result := fCount; -end; - -function TObjectDynArrayWrapper.Capacity: integer; -begin - result := length(TObjectDynArray(fValue^)); -end; - -procedure TObjectDynArrayWrapper.Sort(Compare: TDynArraySortCompare); -begin - if (@Compare<>nil) and (fCount>0) then - QuickSortPtr(0,fCount-1,Compare,fValue^); -end; - -function NewSynLocker: PSynLocker; -begin - result := AllocMem(SizeOf(result^)); - result^.Init; -end; - -function PtrArrayAdd(var aPtrArray; aItem: pointer): integer; -var a: TPointerDynArray absolute aPtrArray; -begin - result := length(a); - SetLength(a,result+1); - a[result] := aItem; -end; - -function PtrArrayAddOnce(var aPtrArray; aItem: pointer): integer; -var a: TPointerDynArray absolute aPtrArray; - n: integer; -begin - n := length(a); - result := PtrUIntScanIndex(pointer(a),n,PtrUInt(aItem)); - if result>=0 then - exit; - SetLength(a,n+1); - a[n] := aItem; - result := n; -end; - -procedure PtrArrayDelete(var aPtrArray; aIndex: integer; aCount: PInteger); -var a: TPointerDynArray absolute aPtrArray; - n: integer; -begin - if aCount=nil then - n := length(a) else - n := aCount^; - if cardinal(aIndex)>=cardinal(n) then - exit; // out of range - dec(n); - if n>aIndex then - MoveFast(a[aIndex+1],a[aIndex],(n-aIndex)*SizeOf(pointer)); - if aCount=nil then - SetLength(a,n) else - aCount^ := n; -end; - -function PtrArrayDelete(var aPtrArray; aItem: pointer; aCount: PInteger): integer; -var a: TPointerDynArray absolute aPtrArray; - n: integer; -begin - if aCount=nil then - n := length(a) else - n := aCount^; - result := PtrUIntScanIndex(pointer(a),n,PtrUInt(aItem)); - if result<0 then - exit; - dec(n); - if n>result then - MoveFast(a[result+1],a[result],(n-result)*SizeOf(pointer)); - if aCount=nil then - SetLength(a,n) else - aCount^ := n; -end; - -function PtrArrayFind(var aPtrArray; aItem: pointer): integer; -var a: TPointerDynArray absolute aPtrArray; -begin - result := PtrUIntScanIndex(pointer(a),length(a),PtrUInt(aItem)); -end; - -{ wrapper functions to T*ObjArr types } - -function ObjArrayAdd(var aObjArray; aItem: TObject): PtrInt; -var a: TObjectDynArray absolute aObjArray; -begin - result := length(a); - SetLength(a,result+1); - a[result] := aItem; -end; - -function ObjArrayAddFrom(var aDestObjArray; const aSourceObjArray): PtrInt; -var n: PtrInt; - s: TObjectDynArray absolute aSourceObjArray; - d: TObjectDynArray absolute aDestObjArray; -begin - result := length(d); - n := length(s); - SetLength(d,result+n); - MoveFast(s[0],d[result],n*SizeOf(pointer)); - inc(result,n); -end; - -function ObjArrayAppend(var aDestObjArray, aSourceObjArray): PtrInt; -begin - result := ObjArrayAddFrom(aDestObjArray,aSourceObjArray); - TObjectDynArray(aSourceObjArray) := nil; // aSourceObjArray[] changed ownership -end; - -function ObjArrayAddCount(var aObjArray; aItem: TObject; var aObjArrayCount: integer): PtrInt; -var a: TObjectDynArray absolute aObjArray; -begin - result := aObjArrayCount; - if result=length(a) then - SetLength(a,NextGrow(result)); - a[result] := aItem; - inc(aObjArrayCount); -end; - -procedure ObjArrayAddOnce(var aObjArray; aItem: TObject); -var a: TObjectDynArray absolute aObjArray; - n: PtrInt; -begin - n := length(a); - if not PtrUIntScanExists(pointer(a),n,PtrUInt(aItem)) then begin - SetLength(a,n+1); - a[n] := aItem; - end; -end; - -function ObjArrayAddOnceFrom(var aDestObjArray; const aSourceObjArray): PtrInt; -var n, i: PtrInt; - s: TObjectDynArray absolute aSourceObjArray; - d: TObjectDynArray absolute aDestObjArray; -begin - result := length(d); - n := length(s); - if n=0 then - exit; - SetLength(d,result+n); - for i := 0 to n-1 do - if not PtrUIntScanExists(pointer(d),result,PtrUInt(s[i])) then begin - d[result] := s[i]; - inc(result); - end; - if result<>length(d) then - SetLength(d,result); -end; - -procedure ObjArraySetLength(var aObjArray; aLength: integer); -begin - SetLength(TObjectDynArray(aObjArray),aLength); -end; - -function ObjArrayFind(const aObjArray; aItem: TObject): PtrInt; -begin - result := PtrUIntScanIndex(pointer(aObjArray), - length(TObjectDynArray(aObjArray)),PtrUInt(aItem)); -end; - -function ObjArrayFind(const aObjArray; aCount: integer; aItem: TObject): PtrInt; -begin - result := PtrUIntScanIndex(pointer(aObjArray),aCount,PtrUInt(aItem)); -end; - -function ObjArrayCount(const aObjArray): integer; -var i: PtrInt; - a: TObjectDynArray absolute aObjArray; -begin - result := 0; - for i := 0 to length(a)-1 do - if a[i]<>nil then - inc(result); -end; - -procedure ObjArrayDelete(var aObjArray; aItemIndex: PtrInt; - aContinueOnException: boolean; aCount: PInteger); -var n: PtrInt; - a: TObjectDynArray absolute aObjArray; -begin - if aCount=nil then - n := length(a) else - n := aCount^; - if cardinal(aItemIndex)>=cardinal(n) then - exit; // out of range - if aContinueOnException then - try - a[aItemIndex].Free; - except - end else - a[aItemIndex].Free; - dec(n); - if n>aItemIndex then - MoveFast(a[aItemIndex+1],a[aItemIndex],(n-aItemIndex)*SizeOf(TObject)); - if aCount=nil then - SetLength(a,n) else - aCount^ := n; -end; - -function ObjArrayDelete(var aObjArray; aItem: TObject): PtrInt; -begin - result := PtrUIntScanIndex(pointer(aObjArray), - length(TObjectDynArray(aObjArray)),PtrUInt(aItem)); - if result>=0 then - ObjArrayDelete(aObjArray,result); -end; - -function ObjArrayDelete(var aObjArray; aCount: integer; aItem: TObject): PtrInt; overload; -begin - result := PtrUIntScanIndex(pointer(aObjArray),aCount,PtrUInt(aItem)); - if result>=0 then - ObjArrayDelete(aObjArray,result,false,@aCount); -end; - -procedure ObjArraySort(var aObjArray; Compare: TDynArraySortCompare); -begin - if @Compare<>nil then - QuickSortPtr(0,length(TObjectDynArray(aObjArray))-1,Compare,pointer(aObjArray)); -end; - -procedure RawObjectsClear(o: PObject; n: integer); -var obj: TObject; -begin - if n>0 then - repeat - obj := o^; - if obj<>nil then begin // inlined FreeAndNil(o^) - o^ := nil; - obj.Destroy; - end; - inc(o); - dec(n); - until n=0; -end; - -procedure ObjArrayClear(var aObjArray); -var a: TObjectDynArray absolute aObjArray; -begin - if a=nil then - exit; - RawObjectsClear(pointer(aObjArray),length(a)); - a := nil; -end; - -procedure ObjArrayClear(var aObjArray; aCount: integer); -var a: TObjectDynArray absolute aObjArray; - n: integer; -begin - n := length(a); - if n=0 then - exit; - if n>aCount then - aCount := n; - RawObjectsClear(pointer(aObjArray),aCount); - a := nil; -end; - -procedure ObjArrayClear(var aObjArray; aContinueOnException: boolean; - aCount: PInteger); -var n,i: PtrInt; - a: TObjectDynArray absolute aObjArray; -begin - if aCount=nil then - n := length(a) else begin - n := aCount^; - aCount^ := 0; - end; - if n=0 then - exit; - if aContinueOnException then - for i := 0 to n-1 do - try - a[i].Free; - except - end - else - RawObjectsClear(pointer(a),n); - a := nil; -end; - -function ObjArrayToJSON(const aObjArray; aOptions: TTextWriterWriteObjectOptions): RawUTF8; -var temp: TTextWriterStackBuffer; -begin - with DefaultTextWriterSerializer.CreateOwnedStream(temp) do - try - if woEnumSetsAsText in aOptions then - CustomOptions := CustomOptions+[twoEnumSetsAsTextInRecord]; - AddObjArrayJSON(aObjArray,aOptions); - SetText(result); - finally - Free; - end; -end; - - -procedure ObjArrayObjArrayClear(var aObjArray); -var i: PtrInt; - a: TPointerDynArray absolute aObjArray; -begin - if a<>nil then begin - for i := 0 to length(a)-1 do - ObjArrayClear(a[i]); - a := nil; - end; -end; - -procedure ObjArraysClear(const aObjArray: array of pointer); -var i: PtrInt; -begin - for i := 0 to high(aObjArray) do - if aObjArray[i]<>nil then - ObjArrayClear(aObjArray[i]^); -end; - -{$ifndef DELPHI5OROLDER} - -function InterfaceArrayAdd(var aInterfaceArray; const aItem: IUnknown): PtrInt; -var a: TInterfaceDynArray absolute aInterfaceArray; -begin - result := length(a); - SetLength(a,result+1); - a[result] := aItem; -end; - -procedure InterfaceArrayAddOnce(var aInterfaceArray; const aItem: IUnknown); -var a: TInterfaceDynArray absolute aInterfaceArray; - n: PtrInt; -begin - if PtrUIntScanExists(pointer(aInterfaceArray), - length(TInterfaceDynArray(aInterfaceArray)),PtrUInt(aItem)) then - exit; - n := length(a); - SetLength(a,n+1); - a[n] := aItem; -end; - -function InterfaceArrayFind(const aInterfaceArray; const aItem: IUnknown): PtrInt; -begin - result := PtrUIntScanIndex(pointer(aInterfaceArray), - length(TInterfaceDynArray(aInterfaceArray)),PtrUInt(aItem)); -end; - -procedure InterfaceArrayDelete(var aInterfaceArray; aItemIndex: PtrInt); -var n: PtrInt; - a: TInterfaceDynArray absolute aInterfaceArray; -begin - n := length(a); - if PtrUInt(aItemIndex)>=PtrUInt(n) then - exit; // out of range - a[aItemIndex] := nil; - dec(n); - if n>aItemIndex then - MoveFast(a[aItemIndex+1],a[aItemIndex],(n-aItemIndex)*SizeOf(IInterface)); - TPointerDynArray(aInterfaceArray)[n] := nil; // avoid GPF in SetLength() - SetLength(a,n); -end; - -function InterfaceArrayDelete(var aInterfaceArray; const aItem: IUnknown): PtrInt; -begin - result := InterfaceArrayFind(aInterfaceArray,aItem); - if result>=0 then - InterfaceArrayDelete(aInterfaceArray,result); -end; - -{$endif DELPHI5OROLDER} - - -{ TInterfacedObjectWithCustomCreate } - -constructor TInterfacedObjectWithCustomCreate.Create; -begin // nothing to do by default - overridden constructor may add custom code -end; - -procedure TInterfacedObjectWithCustomCreate.RefCountUpdate(Release: boolean); -begin - if Release then - _Release else - _AddRef; -end; - - -{ TAutoLock } - -type - /// used by TAutoLocker.ProtectMethod and TSynLocker.ProtectMethod - TAutoLock = class(TInterfacedObject) - protected - fLock: PSynLocker; - public - constructor Create(aLock: PSynLocker); - destructor Destroy; override; - end; - -constructor TAutoLock.Create(aLock: PSynLocker); -begin - fLock := aLock; - fLock^.Lock; -end; - -destructor TAutoLock.Destroy; -begin - fLock^.UnLock; -end; - - -{ TSynLocker } - -const - SYNLOCKER_VTYPENOCLEAR = [varEmpty..varDate,varBoolean, - varShortInt..varWord64,varUnknown]; - -procedure TSynLocker.Init; -begin - fLockCount := 0; - PaddingUsedCount := 0; - InitializeCriticalSection(fSection); - fInitialized := true; -end; - -procedure TSynLocker.Done; -var i: PtrInt; -begin - for i := 0 to PaddingUsedCount-1 do - if not(integer(Padding[i].VType) in SYNLOCKER_VTYPENOCLEAR) then - VarClear(variant(Padding[i])); - DeleteCriticalSection(fSection); - fInitialized := false; -end; - -procedure TSynLocker.DoneAndFreeMem; -begin - Done; - FreeMem(@self); -end; - -function TSynLocker.GetIsLocked: boolean; -begin - result := fLockCount <> 0; -end; - -procedure TSynLocker.Lock; -begin - EnterCriticalSection(fSection); - inc(fLockCount); -end; - -procedure TSynLocker.UnLock; -begin - dec(fLockCount); - LeaveCriticalSection(fSection); -end; - -function TSynLocker.TryLock: boolean; -begin - result := TryEnterCriticalSection(fSection){$ifdef LINUX}{$ifdef FPC}<>0{$endif}{$endif}; - if result then - inc(fLockCount); -end; - -function TSynLocker.TryLockMS(retryms: integer): boolean; -begin - repeat - result := TryLock; - if result or (retryms <= 0) then - break; - SleepHiRes(1); - dec(retryms); - until false; -end; - -function TSynLocker.ProtectMethod: IUnknown; -begin - result := TAutoLock.Create(@self); -end; - -{$ifndef NOVARIANTS} - -function TSynLocker.GetVariant(Index: integer): Variant; -begin - if cardinal(Index)=PaddingUsedCount then - PaddingUsedCount := Index+1; - variant(Padding[Index]) := Value; - finally - UnLock; - end; -end; - -function TSynLocker.GetInt64(Index: integer): Int64; -begin - if cardinal(Index)=cardinal(PaddingUsedCount)) or - not VariantToInt64(variant(Padding[index]),result) then - result := 0; -end; - -procedure TSynLocker.SetUnlockedInt64(Index: integer; const Value: Int64); -begin - if cardinal(Index)<=high(Padding) then begin - if Index>=PaddingUsedCount then - PaddingUsedCount := Index+1; - variant(Padding[Index]) := Value; - end; -end; - -function TSynLocker.GetPointer(Index: integer): Pointer; -begin - if cardinal(Index)=PaddingUsedCount then - PaddingUsedCount := Index+1; - with Padding[index] do begin - if not(integer(VType) in SYNLOCKER_VTYPENOCLEAR) then - VarClear(PVariant(@VType)^); - VType := varUnknown; - VUnknown := Value; - end; - finally - UnLock; - end; -end; - -function TSynLocker.GetUTF8(Index: integer): RawUTF8; -var wasString: Boolean; -begin - if cardinal(Index)=PaddingUsedCount then - PaddingUsedCount := Index+1; - RawUTF8ToVariant(Value,Padding[Index],varString); - finally - UnLock; - end; -end; - -function TSynLocker.LockedInt64Increment(Index: integer; const Increment: Int64): Int64; -begin - if cardinal(Index)<=high(Padding) then - try - Lock; - result := 0; - if Index nil then - SourceName := Source.ClassName else - SourceName := 'nil'; - raise EConvertError.CreateFmt('Cannot assign a %s to a %s', [SourceName, ClassName]); -end; - -procedure TSynPersistent.AssignTo(Dest: TSynPersistent); -begin - Dest.AssignError(Self); -end; - -procedure TSynPersistent.Assign(Source: TSynPersistent); -begin - if Source<>nil then - Source.AssignTo(Self) else - AssignError(nil); -end; - -{$ifdef FPC_OR_PUREPASCAL} -class function TSynPersistent.NewInstance: TObject; -begin // bypass vmtIntfTable and vmt^.vInitTable (FPC management operators) - {$ifdef FPC_X64MM} - result := _AllocMem(InstanceSize); - {$else} - GetMem(pointer(result),InstanceSize); // InstanceSize is inlined - FillCharFast(pointer(result)^,InstanceSize,0); - {$endif} - PPointer(result)^ := pointer(self); // store VMT -end; // no benefit of rewriting FreeInstance/CleanupInstance -{$else} -class function TSynPersistent.NewInstance: TObject; -asm - push eax // class - mov eax, [eax].vmtInstanceSize - push eax // size - call System.@GetMem - pop edx // size - push eax // self - mov cl, 0 - call dword ptr[FillcharFast] - pop eax // self - pop edx // class - mov [eax], edx // store VMT -end; // TSynPersistent has no interface -> bypass vmtIntfTable - -procedure TSynPersistent.FreeInstance; -asm - push ebx - mov ebx, eax -@loop: mov ebx, [ebx] // handle three VMT levels per iteration - mov edx, [ebx].vmtInitTable - mov ebx, [ebx].vmtParent - test edx, edx - jnz @clr - test ebx, ebx - jz @end - mov ebx, [ebx] - mov edx, [ebx].vmtInitTable - mov ebx, [ebx].vmtParent - test edx, edx - jnz @clr - test ebx, ebx - jz @end - mov ebx, [ebx] - mov edx, [ebx].vmtInitTable - mov ebx, [ebx].vmtParent - test edx, edx - jnz @clr - test ebx, ebx - jnz @loop -@end: pop ebx - jmp System.@FreeMem - // TSynPersistent has no TMonitor -> bypass TMonitor.Destroy(self) - // BTW, TMonitor.Destroy is private, so unreachable -@clr: push offset @loop // parent has never any vmtInitTable -> @loop - jmp RecordClear // eax=self edx=typeinfo -end; -{$endif FPC_OR_PUREPASCAL} - - -{ TSynPersistentLock } - -constructor TSynPersistentLock.Create; -begin - inherited Create; - fSafe := NewSynLocker; -end; - -destructor TSynPersistentLock.Destroy; -begin - inherited Destroy; - fSafe^.DoneAndFreeMem; -end; - - -{ TSynList } - -function TSynList.Add(item: pointer): integer; -begin - result := ObjArrayAddCount(fList,item,fCount); -end; - -procedure TSynList.Clear; -begin - fList := nil; - fCount := 0; -end; - -procedure TSynList.Delete(index: integer); -begin - PtrArrayDelete(fList,index,@fCount); - if (fCount>64) and (length(fList)>fCount*2) then - SetLength(fList,fCount); // reduce capacity when half list is void -end; - -function TSynList.Exists(item: pointer): boolean; -begin - result := PtrUIntScanExists(pointer(fList),fCount,PtrUInt(item)); -end; - -function TSynList.Get(index: Integer): pointer; -begin - if cardinal(index)=0 then - Delete(result); -end; - - -{ TSynObjectList } - -constructor TSynObjectList.Create(aOwnObjects: boolean); -begin - fOwnObjects := aOwnObjects; - inherited Create; -end; - -procedure TSynObjectList.Delete(index: integer); -begin - if cardinal(index)>=cardinal(fCount) then - exit; - if fOwnObjects then - TObject(fList[index]).Free; - inherited Delete(index); -end; - -procedure TSynObjectList.Clear; -begin - if fOwnObjects then - RawObjectsClear(pointer(fList),fCount); - inherited Clear; -end; - -procedure TSynObjectList.ClearFromLast; -var i: PtrInt; -begin - if fOwnObjects then - for i := fCount-1 downto 0 do - TObject(fList[i]).Free; - inherited Clear; -end; - -destructor TSynObjectList.Destroy; -begin - Clear; - inherited Destroy; -end; - - -{ TSynObjectListLocked } - -constructor TSynObjectListLocked.Create(AOwnsObjects: Boolean); -begin - inherited Create(AOwnsObjects); - fSafe.Init; -end; - -destructor TSynObjectListLocked.Destroy; -begin - inherited Destroy; - fSafe.Done; -end; - -function TSynObjectListLocked.Add(item: pointer): integer; -begin - Safe.Lock; - try - result := inherited Add(item); - finally - Safe.UnLock; - end; -end; - -function TSynObjectListLocked.Remove(item: pointer): integer; -begin - Safe.Lock; - try - result := inherited Remove(item); - finally - Safe.UnLock; - end; -end; - -function TSynObjectListLocked.Exists(item: pointer): boolean; -begin - Safe.Lock; - try - result := inherited Exists(item); - finally - Safe.UnLock; - end; -end; - -procedure TSynObjectListLocked.Clear; -begin - Safe.Lock; - try - inherited Clear; - finally - Safe.UnLock; - end; -end; - -procedure TSynObjectListLocked.ClearFromLast; -begin - Safe.Lock; - try - inherited ClearFromLast; - finally - Safe.UnLock; - end; -end; - - -{ ****************** text buffer and JSON functions and classes ********* } - -{ TTextWriter } - -procedure TTextWriter.Add(c: AnsiChar); -begin - if B>=BEnd then - FlushToStream; - inc(B); - B^ := c; -end; - -procedure TTextWriter.AddOnce(c: AnsiChar); -begin - if (B>=fTempBuf) and (B^=c) then - exit; // no duplicate - if B>=BEnd then - FlushToStream; - inc(B); - B^ := c; -end; - -procedure TTextWriter.Add(c1, c2: AnsiChar); -begin - if BEnd-B<=1 then - FlushToStream; - B[1] := c1; - B[2] := c2; - inc(B,2); -end; - -procedure TTextWriter.CancelLastChar; -begin - if B>=fTempBuf then // Add() methods append at B+1 - dec(B); -end; - -function TTextWriter.LastChar: AnsiChar; -begin - if B>=fTempBuf then - result := B^ else - result := #0; -end; - -procedure TTextWriter.CancelLastChar(aCharToCancel: AnsiChar); -begin - if (B>=fTempBuf) and (B^=aCharToCancel) then - dec(B); -end; - -function TTextWriter.PendingBytes: PtrUInt; -begin - result := B-fTempBuf+1; -end; - -procedure TTextWriter.CancelLastComma; -begin - if (B>=fTempBuf) and (B^=',') then - dec(B); -end; - -procedure TTextWriter.Add(Value: PtrInt); -var tmp: array[0..23] of AnsiChar; - P: PAnsiChar; - Len: PtrInt; -begin - if BEnd-B<=24 then - FlushToStream; - if PtrUInt(Value)<=high(SmallUInt32UTF8) then begin - P := pointer(SmallUInt32UTF8[Value]); - Len := PStrLen(P-_STRLEN)^; - end else begin - P := StrInt32(@tmp[23],value); - Len := @tmp[23]-P; - end; - MoveSmall(P,B+1,Len); - inc(B,Len); -end; - -{$ifndef CPU64} // Add(Value: PtrInt) already implemented it -procedure TTextWriter.Add(Value: Int64); -var tmp: array[0..23] of AnsiChar; - P: PAnsiChar; - Len: integer; -begin - if BEnd-B<=24 then - FlushToStream; - if Value<0 then begin - P := StrUInt64(@tmp[23],-Value)-1; - P^ := '-'; - Len := @tmp[23]-P; - end else - if Value<=high(SmallUInt32UTF8) then begin - P := pointer(SmallUInt32UTF8[Value]); - Len := PStrLen(P-_STRLEN)^; - end else begin - P := StrUInt64(@tmp[23],Value); - Len := @tmp[23]-P; - end; - MoveSmall(P,B+1,Len); - inc(B,Len); -end; -{$endif CPU64} - -procedure TTextWriter.AddCurr64(const Value: Int64); -var tmp: array[0..31] of AnsiChar; - P: PAnsiChar; - Len: PtrInt; -begin - if BEnd-B<=31 then - FlushToStream; - P := StrCurr64(@tmp[31],Value); - Len := @tmp[31]-P; - if Len>4 then - if P[Len-1]='0' then - if P[Len-2]='0' then - if P[Len-3]='0' then - if P[Len-4]='0' then - dec(Len,5) else - dec(Len,3) else - dec(Len,2) else - dec(Len); - MoveSmall(P,B+1,Len); - inc(B,Len); -end; - -procedure TTextWriter.AddCurr64(const Value: currency); -begin - AddCurr64(PInt64(@Value)^); -end; - -procedure TTextWriter.AddTimeLog(Value: PInt64); -begin - if BEnd-B<=31 then - FlushToStream; - inc(B,PTimeLogBits(Value)^.Text(B+1,true,'T')); -end; - -procedure TTextWriter.AddUnixTime(Value: PInt64); -begin // inlined UnixTimeToDateTime() - AddDateTime(Value^/SecsPerDay+UnixDateDelta); -end; - -procedure TTextWriter.AddUnixMSTime(Value: PInt64; WithMS: boolean); -begin // inlined UnixMSTimeToDateTime() - AddDateTime(Value^/MSecsPerDay+UnixDateDelta,WithMS); -end; - -procedure TTextWriter.AddDateTime(Value: PDateTime; FirstChar: AnsiChar; - QuoteChar: AnsiChar; WithMS: boolean); -begin - if (Value^=0) and (QuoteChar=#0) then - exit; - if BEnd-B<=26 then - FlushToStream; - inc(B); - if QuoteChar<>#0 then - B^ := QuoteChar else - dec(B); - if Value^<>0 then begin - inc(B); - if trunc(Value^)<>0 then - B := DateToIso8601PChar(Value^,B,true); - if frac(Value^)<>0 then - B := TimeToIso8601PChar(Value^,B,true,FirstChar,WithMS); - dec(B); - end; - if twoDateTimeWithZ in fCustomOptions then begin - inc(B); - B^ := 'Z'; - end; - if QuoteChar<>#0 then begin - inc(B); - B^ := QuoteChar; - end; -end; - -procedure TTextWriter.AddDateTime(const Value: TDateTime; WithMS: boolean); -begin - if Value=0 then - exit; - if BEnd-B<=24 then - FlushToStream; - inc(B); - if trunc(Value)<>0 then - B := DateToIso8601PChar(Value,B,true); - if frac(Value)<>0 then - B := TimeToIso8601PChar(Value,B,true,'T',WithMS); - if twoDateTimeWithZ in fCustomOptions then - B^ := 'Z' else - dec(B); -end; - -procedure TTextWriter.AddDateTimeMS(const Value: TDateTime; Expanded: boolean; - FirstTimeChar: AnsiChar; const TZD: RawUTF8); -var T: TSynSystemTime; -begin - if Value=0 then - exit; - T.FromDateTime(Value); - Add(DTMS_FMT[Expanded], [UInt4DigitsToShort(T.Year), - UInt2DigitsToShortFast(T.Month),UInt2DigitsToShortFast(T.Day),FirstTimeChar, - UInt2DigitsToShortFast(T.Hour),UInt2DigitsToShortFast(T.Minute), - UInt2DigitsToShortFast(T.Second),UInt3DigitsToShort(T.MilliSecond),TZD]); -end; - -procedure TTextWriter.AddU(Value: cardinal); -var tmp: array[0..23] of AnsiChar; - P: PAnsiChar; - Len: PtrInt; -begin - if BEnd-B<=24 then - FlushToStream; - if Value<=high(SmallUInt32UTF8) then begin - P := pointer(SmallUInt32UTF8[Value]); - Len := PStrLen(P-_STRLEN)^; - end else begin - P := StrUInt32(@tmp[23],Value); - Len := @tmp[23]-P; - end; - MoveSmall(P,B+1,Len); - inc(B,Len); -end; - -procedure TTextWriter.AddQ(Value: QWord); -var tmp: array[0..23] of AnsiChar; - V: Int64Rec absolute Value; - P: PAnsiChar; - Len: PtrInt; -begin - if BEnd-B<=32 then - FlushToStream; - if (V.Hi=0) and (V.Lo<=high(SmallUInt32UTF8)) then begin - P := pointer(SmallUInt32UTF8[V.Lo]); - Len := PStrLen(P-_STRLEN)^; - end else begin - P := StrUInt64(@tmp[23],Value); - Len := @tmp[23]-P; - end; - MoveSmall(P,B+1,Len); - inc(B,Len); -end; - -procedure TTextWriter.AddQHex(Value: QWord); -begin - AddBinToHexDisplayQuoted(@Value,SizeOf(Value)); -end; - -procedure TTextWriter.Add(Value: Extended; precision: integer; noexp: boolean); -var tmp: ShortString; -begin - AddShort(ExtendedToJSON(tmp,Value,precision,noexp)^); -end; - -procedure TTextWriter.AddDouble(Value: double; noexp: boolean); -var tmp: ShortString; -begin - AddShort(DoubleToJSON(tmp,Value,noexp)^); -end; - -procedure TTextWriter.AddSingle(Value: single; noexp: boolean); -var tmp: ShortString; -begin - AddShort(ExtendedToJSON(tmp,Value,SINGLE_PRECISION,noexp)^); -end; - -procedure TTextWriter.Add(Value: boolean); -var PS: PShortString; -begin - if Value then // normalize: boolean may not be in the expected [0,1] range - PS := @BOOL_STR[true] else - PS := @BOOL_STR[false]; - AddShort(PS^); -end; - -procedure TTextWriter.AddFloatStr(P: PUTF8Char); -begin - if StrLen(P)>127 then - exit; // clearly invalid input - if BEnd-B<=127 then - FlushToStream; - inc(B); - if P<>nil then - B := FloatStrCopy(P,B)-1 else - B^ := '0'; -end; - -procedure TTextWriter.Add({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID); -begin - if BEnd-B<=36 then - FlushToStream; - GUIDToText(B+1,@guid); - inc(B,36); -end; - -procedure TTextWriter.AddCR; -begin - if BEnd-B<=1 then - FlushToStream; - PWord(B+1)^ := 13+10 shl 8; // CR + LF - inc(B,2); -end; - -procedure TTextWriter.AddCRAndIndent; -var ntabs: cardinal; -begin - if B^=#9 then - exit; // we most probably just added an indentation level - ntabs := fHumanReadableLevel; - if ntabs>=cardinal(fTempBufSize) then - exit; // avoid buffer overflow - if BEnd-B<=Integer(ntabs)+1 then - FlushToStream; - PWord(B+1)^ := 13+10 shl 8; // CR + LF - FillCharFast(B[3],ntabs,9); // #9=tab - inc(B,ntabs+2); -end; - -procedure TTextWriter.AddChars(aChar: AnsiChar; aCount: integer); -var n: integer; -begin - repeat - n := BEnd-B; - if aCount99 then - PCardinal(B+1)^ := $3030+ord(',')shl 16 else // '00,' if overflow - PCardinal(B+1)^ := TwoDigitLookupW[Value]+ord(',')shl 16; - inc(B,3); -end; - -procedure TTextWriter.Add4(Value: PtrUInt); -begin - if BEnd-B<=5 then - FlushToStream; - if Value>9999 then - PCardinal(B+1)^ := $30303030 else // '0000,' if overflow - YearToPChar(Value,B+1); - inc(B,5); - B^ := ','; -end; - -procedure TTextWriter.AddCurrentLogTime(LocalTime: boolean); -var time: TSynSystemTime; -begin - FromGlobalTime(LocalTime,time); - time.AddLogTime(self); -end; - -procedure TTextWriter.AddCurrentNCSALogTime(LocalTime: boolean); -var time: TSynSystemTime; -begin - FromGlobalTime(LocalTime,time); - if BEnd-B<=21 then - FlushToStream; - inc(B,time.ToNCSAText(B+1)); -end; - -function Value3Digits(V: PtrUInt; P: PUTF8Char; W: PWordArray): PtrUInt; - {$ifdef HASINLINE}inline;{$endif} -begin - result := V div 100; - PWord(P+1)^ := W[V-result*100]; - V := result; - result := result div 10; - P^ := AnsiChar(V-result*10+48); -end; - -procedure TTextWriter.AddMicroSec(MS: cardinal); -var W: PWordArray; -begin // in 00.000.000 TSynLog format - if BEnd-B<=17 then - FlushToStream; - B[3] := '.'; - B[7] := '.'; - inc(B); - W := @TwoDigitLookupW; - MS := Value3Digits(Value3Digits(MS,B+7,W),B+3,W); - if MS>99 then - MS := 99; - PWord(B)^:= W[MS]; - inc(B,9); -end; - -procedure TTextWriter.Add3(Value: PtrUInt); -var V: PtrUInt; -begin - if BEnd-B<=4 then - FlushToStream; - if Value>999 then - PCardinal(B+1)^ := $303030 else begin// '0000,' if overflow - V := Value div 10; - PCardinal(B+1)^ := TwoDigitLookupW[V]+(Value-V*10+48)shl 16; - end; - inc(B,4); - B^ := ','; -end; - -procedure TTextWriter.AddCSVInteger(const Integers: array of Integer); -var i: PtrInt; -begin - if length(Integers)=0 then - exit; - for i := 0 to high(Integers) do begin - Add(Integers[i]); - Add(','); - end; - CancelLastComma; -end; - -procedure TTextWriter.AddCSVDouble(const Doubles: array of double); -var i: PtrInt; -begin - if length(Doubles)=0 then - exit; - for i := 0 to high(Doubles) do begin - AddDouble(Doubles[i]); - Add(','); - end; - CancelLastComma; -end; - -procedure TTextWriter.AddCSVUTF8(const Values: array of RawUTF8); -var i: PtrInt; -begin - if length(Values)=0 then - exit; - for i := 0 to high(Values) do begin - Add('"'); - AddJSONEscape(pointer(Values[i])); - Add('"',','); - end; - CancelLastComma; -end; - -procedure TTextWriter.AddCSVConst(const Values: array of const); -var i: PtrInt; -begin - if length(Values)=0 then - exit; - for i := 0 to high(Values) do begin - AddJSONEscape(Values[i]); - Add(','); - end; - CancelLastComma; -end; - -procedure TTextWriter.Add(const Values: array of const); -var i: PtrInt; -begin - for i := 0 to high(Values) do - AddJSONEscape(Values[i]); -end; - -procedure TTextWriter.WriteObject(Value: TObject; Options: TTextWriterWriteObjectOptions); -var i: PtrInt; -begin - if Value<>nil then - if Value.InheritsFrom(Exception) then - Add('{"%":"%"}',[Value.ClassType,Exception(Value).Message]) else - if Value.InheritsFrom(TRawUTF8List) then - with TRawUTF8List(Value) do begin - self.Add('['); - for i := 0 to fCount-1 do begin - self.Add('"'); - self.AddJSONEscape(pointer(fValue[i])); - self.Add('"',','); - end; - self.CancelLastComma; - self.Add(']'); - exit; - end else - if Value.InheritsFrom(TStrings) then - with TStrings(Value) do begin - self.Add('['); - for i := 0 to Count-1 do begin - self.Add('"'); - {$ifdef UNICODE} - self.AddJSONEscapeW(pointer(Strings[i]),Length(Strings[i])); - {$else} - self.AddJSONEscapeAnsiString(Strings[i]); - {$endif} - self.Add('"',','); - end; - self.CancelLastComma; - self.Add(']'); - exit; - end else - if not(woFullExpand in Options) or - not(Value.InheritsFrom(TList) - {$ifndef LVCL} or Value.InheritsFrom(TCollection){$endif}) then - Value := nil; - if Value=nil then begin - AddShort('null'); - exit; - end; - Add('{'); - AddInstanceName(Value,':'); - Add('['); - if Value.InheritsFrom(TList) then - for i := 0 to TList(Value).Count-1 do - AddInstanceName(TList(Value).List[i],',') - {$ifndef LVCL} else - if Value.InheritsFrom(TCollection) then - for i := 0 to TCollection(Value).Count-1 do - AddInstanceName(TCollection(Value).Items[i],',') {$endif} ; - CancelLastComma; - Add(']','}'); -end; - -function TTextWriter.InternalJSONWriter: TTextWriter; -begin - if fInternalJSONWriter=nil then - fInternalJSONWriter := DefaultTextWriterSerializer.CreateOwnedStream else - fInternalJSONWriter.CancelAll; - result := fInternalJSONWriter; -end; - -procedure TTextWriter.AddJSONEscape(Source: TTextWriter); -begin - if Source.fTotalFileSize=0 then - AddJSONEscape(Source.fTempBuf,Source.B-Source.fTempBuf+1) else - AddJSONEscape(Pointer(Source.Text)); -end; - -procedure TTextWriter.AddNoJSONEscape(Source: TTextWriter); -begin - if Source.fTotalFileSize=0 then - AddNoJSONEscape(Source.fTempBuf,Source.B-Source.fTempBuf+1) else - AddNoJSONEscapeUTF8(Source.Text); -end; - -procedure TTextWriter.AddRawJSON(const json: RawJSON); -begin - if json='' then - AddShort('null') else - AddNoJSONEscape(pointer(json),length(json)); -end; - -procedure TTextWriter.WriteObjectAsString(Value: TObject; - Options: TTextWriterWriteObjectOptions); -begin - Add('"'); - InternalJSONWriter.WriteObject(Value,Options); - AddJSONEscape(fInternalJSONWriter); - Add('"'); -end; - -class procedure TTextWriter.RegisterCustomJSONSerializer(aTypeInfo: pointer; - aReader: TDynArrayJSONCustomReader; aWriter: TDynArrayJSONCustomWriter); -begin - GlobalJSONCustomParsers.RegisterCallbacks(aTypeInfo,aReader,aWriter); -end; - -class procedure TTextWriter.UnRegisterCustomJSONSerializer(aTypeInfo: pointer); -begin - GlobalJSONCustomParsers.RegisterCallbacks(aTypeInfo,nil,nil); -end; - -class function TTextWriter.GetCustomJSONParser(var DynArray: TDynArray; - out CustomReader: TDynArrayJSONCustomReader; - out CustomWriter: TDynArrayJSONCustomWriter): boolean; -begin - result := DynArray.HasCustomJSONParser; // use var above since may set fParser - if result then - with GlobalJSONCustomParsers.fParser[DynArray.fParser] do begin - CustomReader := Reader; - CustomWriter := Writer; - end; -end; - -{$ifndef NOVARIANTS} -class procedure TTextWriter.RegisterCustomJSONSerializerForVariant( - aClass: TCustomVariantType; aReader: TDynArrayJSONCustomReader; - aWriter: TDynArrayJSONCustomWriter); -begin // here we register TCustomVariantTypeClass info instead of TypeInfo() - GlobalJSONCustomParsers.RegisterCallbacksVariant(aClass,aReader,aWriter); -end; - -class procedure TTextWriter.RegisterCustomJSONSerializerForVariantByType(aVarType: TVarType; - aReader: TDynArrayJSONCustomReader; aWriter: TDynArrayJSONCustomWriter); -var aClass: TCustomVariantType; -begin - if FindCustomVariantType(aVarType,aClass) then - RegisterCustomJSONSerializerForVariant(aClass,aReader,aWriter); -end; -{$endif NOVARIANTS} - -class function TTextWriter.RegisterCustomJSONSerializerFromText(aTypeInfo: pointer; - const aRTTIDefinition: RawUTF8): TJSONRecordAbstract; -begin - result := GlobalJSONCustomParsers.RegisterFromText(aTypeInfo,aRTTIDefinition); -end; - -class procedure TTextWriter.RegisterCustomJSONSerializerFromText( - const aTypeInfoTextDefinitionPairs: array of const); -var n,i: integer; - def: RawUTF8; -begin - n := length(aTypeInfoTextDefinitionPairs); - if (n=0) or (n and 1=1) then - exit; - n := n shr 1; - if n=0 then - exit; - for i := 0 to n-1 do - if (aTypeInfoTextDefinitionPairs[i*2].VType<>vtPointer) or - not VarRecToUTF8IsString(aTypeInfoTextDefinitionPairs[i*2+1],def) then - raise ESynException.Create('RegisterCustomJSONSerializerFromText[?]') else - GlobalJSONCustomParsers.RegisterFromText( - aTypeInfoTextDefinitionPairs[i*2].VPointer,def); -end; - -class function TTextWriter.RegisterCustomJSONSerializerSetOptions(aTypeInfo: pointer; - aOptions: TJSONCustomParserSerializationOptions; aAddIfNotExisting: boolean): boolean; -var ndx: integer; -begin - result := false; - if aTypeInfo=nil then - exit; - case PTypeKind(aTypeInfo)^ of - tkRecord{$ifdef FPC},tkObject{$endif}: - ndx := GlobalJSONCustomParsers.RecordSearch(aTypeInfo,aAddIfNotExisting); - tkDynArray: - ndx := GlobalJSONCustomParsers.DynArraySearch(aTypeInfo,nil,aAddIfNotExisting); - else - exit; - end; - if (ndx>=0) and - (GlobalJSONCustomParsers.fParser[ndx].RecordCustomParser<>nil) then begin - GlobalJSONCustomParsers.fParser[ndx].RecordCustomParser.Options := aOptions; - result := true; - end; -end; - -class function TTextWriter.RegisterCustomJSONSerializerSetOptions( - const aTypeInfo: array of pointer; aOptions: TJSONCustomParserSerializationOptions; - aAddIfNotExisting: boolean): boolean; -var i: integer; -begin - result := true; - for i := 0 to high(aTypeInfo) do - if not RegisterCustomJSONSerializerSetOptions(aTypeInfo[i],aOptions,aAddIfNotExisting) then - result := false; -end; - -class function TTextWriter.RegisterCustomJSONSerializerFindParser( - aTypeInfo: pointer; aAddIfNotExisting: boolean): TJSONRecordAbstract; -var ndx: integer; -begin - result := nil; - if aTypeInfo=nil then - exit; - case PTypeKind(aTypeInfo)^ of - tkRecord{$ifdef FPC},tkObject{$endif}: - ndx := GlobalJSONCustomParsers.RecordSearch(aTypeInfo,aAddIfNotExisting); - tkDynArray: - ndx := GlobalJSONCustomParsers.DynArraySearch(aTypeInfo,nil,aAddIfNotExisting); - else - exit; - end; - if ndx>=0 then - result := GlobalJSONCustomParsers.fParser[ndx].RecordCustomParser; -end; - -class procedure TTextWriter.RegisterCustomJSONSerializerFromTextSimpleType( - aTypeInfo: pointer; const aTypeName: RawUTF8); -begin - JSONSerializerFromTextSimpleTypeAdd(aTypeName,aTypeInfo,0,0); -end; - -class procedure TTextWriter.RegisterCustomJSONSerializerFromTextSimpleType( - const aTypeInfos: array of pointer); -var i: integer; -begin - for i := 0 to high(aTypeInfos) do - RegisterCustomJSONSerializerFromTextSimpleType(aTypeInfos[i],''); -end; - -class procedure TTextWriter.RegisterCustomJSONSerializerFromTextBinaryType( - aTypeInfo: pointer; aDataSize, aFieldSize: integer); -begin - JSONSerializerFromTextSimpleTypeAdd('',aTypeInfo,aDataSize,aFieldSize); -end; - -class procedure TTextWriter.RegisterCustomJSONSerializerFromTextBinaryType( - const aTypeInfoDataFieldSize: array of const); -var n,i: integer; - s1,s2: Int64; -begin - n := length(aTypeInfoDataFieldSize); - if n mod 3=0 then - for i := 0 to (n div 3)-1 do - if (aTypeInfoDataFieldSize[i*3].VType<>vtPointer) or - not VarRecToInt64(aTypeInfoDataFieldSize[i*3+1],s1) or - not VarRecToInt64(aTypeInfoDataFieldSize[i*3+2],s2) then - raise ESynException.CreateUTF8('RegisterCustomJSONSerializerFromTextBinaryType[%]',[i]) else - JSONSerializerFromTextSimpleTypeAdd('',aTypeInfoDataFieldSize[i*3].VPointer,s1,s2); -end; - -procedure TTextWriter.AddRecordJSON(const Rec; TypeInfo: pointer); -var customWriter: TDynArrayJSONCustomWriter; -begin - if (self=nil) or (@Rec=nil) or (TypeInfo=nil) or - not(PTypeKind(TypeInfo)^ in tkRecordTypes) then - raise ESynException.CreateUTF8('Invalid %.AddRecordJSON(%)',[self,TypeInfo]); - if GlobalJSONCustomParsers.RecordSearch(TypeInfo,customWriter,nil) then - customWriter(self,Rec) else - WrRecord(Rec,TypeInfo); -end; - -procedure TTextWriter.AddVoidRecordJSON(TypeInfo: pointer); -var tmp: TBytes; - info: PTypeInfo; -begin - info := GetTypeInfo(TypeInfo,tkRecordKinds); - if (self=nil) or (info=nil) then - raise ESynException.CreateUTF8('Invalid %.AddVoidRecordJSON(%)',[self,TypeInfo]); - SetLength(tmp,info^.recSize {$ifdef FPC}and $7FFFFFFF{$endif}); - AddRecordJSON(tmp[0],TypeInfo); -end; - -{$ifndef NOVARIANTS} -procedure TTextWriter.AddVariant(const Value: variant; Escape: TTextWriterKind); -var CustomVariantType: TCustomVariantType; - vt: cardinal; -begin - vt := TVarData(Value).VType; - with TVarData(Value) do - case vt of - varEmpty, - varNull: AddShort('null'); - varSmallint: Add(VSmallint); - varShortInt: Add(VShortInt); - varByte: AddU(VByte); - varWord: AddU(VWord); - varLongWord: AddU(VLongWord); - varInteger: Add(VInteger); - varInt64: Add(VInt64); - varWord64: AddQ(VInt64); - varSingle: AddSingle(VSingle); - varDouble: AddDouble(VDouble); - varDate: AddDateTime(@VDate,'T','"'); - varCurrency: AddCurr64(VInt64); - varBoolean: Add(VBoolean); // 'true'/'false' - varVariant: AddVariant(PVariant(VPointer)^,Escape); - varString: begin - if Escape=twJSONEscape then - Add('"'); - {$ifdef HASCODEPAGE} - AddAnyAnsiString(RawByteString(VString),Escape); - {$else} // VString is expected to be a RawUTF8 - Add(VString,length(RawUTF8(VString)),Escape); - {$endif} - if Escape=twJSONEscape then - Add('"'); - end; - varOleStr {$ifdef HASVARUSTRING}, varUString{$endif}: begin - if Escape=twJSONEscape then - Add('"'); - AddW(VAny,0,Escape); - if Escape=twJSONEscape then - Add('"'); - end; - else - if vt=varVariant or varByRef then - AddVariant(PVariant(VPointer)^,Escape) else - if vt=varByRef or varString then begin - if Escape=twJSONEscape then - Add('"'); - {$ifdef HASCODEPAGE} - AddAnyAnsiString(PRawByteString(VAny)^,Escape); - {$else} // VString is expected to be a RawUTF8 - Add(PPointer(VAny)^,length(PRawUTF8(VAny)^),Escape); - {$endif} - if Escape=twJSONEscape then - Add('"'); - end else - if {$ifdef HASVARUSTRING}(vt=varByRef or varUString) or {$endif} - (vt=varByRef or varOleStr) then begin - if Escape=twJSONEscape then - Add('"'); - AddW(PPointer(VAny)^,0,Escape); - if Escape=twJSONEscape then - Add('"'); - end else - if FindCustomVariantType(vt,CustomVariantType) then - if CustomVariantType.InheritsFrom(TSynInvokeableVariantType) then - TSynInvokeableVariantType(CustomVariantType).ToJson(self,Value,Escape) else - GlobalJSONCustomParsers.VariantWrite(CustomVariantType,self,Value,Escape) else - raise ESynException.CreateUTF8('%.AddVariant VType=%',[self,vt]); - end; -end; -{$endif NOVARIANTS} - -procedure TTextWriter.AddDynArrayJSON(var aDynArray: TDynArrayHashed); -begin - AddDynArrayJson(PDynArray(@aDynArray)^); -end; - -procedure TTextWriter.AddDynArrayJSON(aTypeInfo: pointer; const aValue); -var DynArray: TDynArray; -begin - DynArray.Init(aTypeInfo,pointer(@aValue)^); - AddDynArrayJSON(DynArray); -end; - -procedure TTextWriter.AddDynArrayJSONAsString(aTypeInfo: pointer; var aValue); -begin - Add('"'); - InternalJSONWriter.AddDynArrayJSON(aTypeInfo,aValue); - AddJSONEscape(fInternalJSONWriter); - Add('"'); -end; - -procedure TTextWriter.AddObjArrayJSON(const aObjArray; aOptions: TTextWriterWriteObjectOptions); -var i: integer; - a: TObjectDynArray absolute aObjArray; -begin - Add('['); - for i := 0 to length(a)-1 do begin - WriteObject(a[i],aOptions); - Add(','); - end; - CancelLastComma; - Add(']'); -end; - -procedure TTextWriter.AddTypedJSON(aTypeInfo: pointer; const aValue); -var max, i: Integer; - PS: PShortString; - customWriter: TDynArrayJSONCustomWriter; - DynArray: TDynArray; - procedure AddPS; overload; - begin - Add('"'); - if twoTrimLeftEnumSets in fCustomOptions then - AddTrimLeftLowerCase(PS) else - AddShort(PS^); - Add('"'); - end; - procedure AddPS(bool: boolean); overload; - begin - AddPS; - Add(':'); - Add(bool); - end; -begin - case PTypeKind(aTypeInfo)^ of - tkClass: - WriteObject(TObject(aValue),[woFullExpand]); - tkEnumeration: - if twoEnumSetsAsBooleanInRecord in fCustomOptions then begin - PS := GetEnumName(aTypeInfo,byte(aValue)); - AddPS(true); - end else - if twoEnumSetsAsTextInRecord in fCustomOptions then begin - PS := GetEnumName(aTypeInfo,byte(aValue)); - AddPS; - end else - AddU(byte(aValue)); - tkSet: - if GetSetInfo(aTypeInfo,max,PS) then - if twoEnumSetsAsBooleanInRecord in fCustomOptions then begin - Add('{'); - for i := 0 to max do begin - AddPS(GetBitPtr(@aValue,i)); - Add(','); - inc(PByte(PS),PByte(PS)^+1); // next - end; - CancelLastComma; - Add('}'); - end else - if twoEnumSetsAsTextInRecord in fCustomOptions then begin - Add('['); - if (twoFullSetsAsStar in fCustomOptions) and - GetAllBits(cardinal(aValue),max+1) then - AddShort('"*"') else begin - for i := 0 to max do begin - if GetBitPtr(@aValue,i) then begin - AddPS; - Add(','); - end; - inc(PByte(PS),PByte(PS)^+1); // next - end; - CancelLastComma; - end; - Add(']'); - end else - if max<8 then - AddU(byte(aValue)) else - if max<16 then - AddU(word(aValue)) else - if max<32 then - AddU(cardinal(aValue)) else - Add(Int64(aValue)) - else AddShort('null'); - tkRecord{$ifdef FPC},tkObject{$endif}: // inlined AddRecordJSON() - if GlobalJSONCustomParsers.RecordSearch(aTypeInfo,customWriter,nil) then - customWriter(self,aValue) else - WrRecord(aValue,aTypeInfo); - tkDynArray: begin - DynArray.Init(aTypeInfo,(@aValue)^); - AddDynArrayJSON(DynArray); - end; -{$ifndef NOVARIANTS} - tkVariant: - AddVariant(variant(aValue),twJSONEscape); -{$endif} - else - AddShort('null'); - end; -end; - -function TTextWriter.AddJSONReformat(JSON: PUTF8Char; - Format: TTextWriterJSONFormat; EndOfObject: PUTF8Char): PUTF8Char; -var objEnd: AnsiChar; - Name,Value: PUTF8Char; - NameLen,ValueLen: integer; -begin - result := nil; - if JSON=nil then - exit; - while (JSON^<=' ') and (JSON^<>#0) do inc(JSON); - case JSON^ of - '[': begin // array - repeat inc(JSON) until (JSON^=#0) or (JSON^>' '); - if JSON^=']' then begin - Add('['); - inc(JSON); - end else begin - if not (Format in [jsonCompact,jsonUnquotedPropNameCompact]) then - AddCRAndIndent; - inc(fHumanReadableLevel); - Add('['); - repeat - if JSON=nil then - exit; - if not (Format in [jsonCompact,jsonUnquotedPropNameCompact]) then - AddCRAndIndent; - JSON := AddJSONReformat(JSON,Format,@objEnd); - if objEnd=']' then - break; - Add(objEnd); - until false; - dec(fHumanReadableLevel); - if not (Format in [jsonCompact,jsonUnquotedPropNameCompact]) then - AddCRAndIndent; - end; - Add(']'); - end; - '{': begin // object - repeat inc(JSON) until (JSON^=#0) or (JSON^>' '); - Add('{'); - inc(fHumanReadableLevel); - if not (Format in [jsonCompact,jsonUnquotedPropNameCompact]) then - AddCRAndIndent; - if JSON^='}' then - repeat inc(JSON) until (JSON^=#0) or (JSON^>' ') else - repeat - Name := GetJSONPropName(JSON,@NameLen); - if Name=nil then - exit; - if (Format in [jsonUnquotedPropName,jsonUnquotedPropNameCompact]) and - JsonPropNameValid(Name) then - AddNoJSONEscape(Name,NameLen) else begin - Add('"'); - AddJSONEscape(Name); - Add('"'); - end; - if Format in [jsonCompact,jsonUnquotedPropNameCompact] then - Add(':') else - Add(':',' '); - while (JSON^<=' ') and (JSON^<>#0) do inc(JSON); - JSON := AddJSONReformat(JSON,Format,@objEnd); - if objEnd='}' then - break; - Add(objEnd); - if not (Format in [jsonCompact,jsonUnquotedPropNameCompact]) then - AddCRAndIndent; - until false; - dec(fHumanReadableLevel); - if not (Format in [jsonCompact,jsonUnquotedPropNameCompact]) then - AddCRAndIndent; - Add('}'); - end; - '"': begin // string - Value := JSON; - JSON := GotoEndOfJSONString(JSON); - if JSON^<>'"' then - exit; - inc(JSON); - AddNoJSONEscape(Value,JSON-Value); - end; - else begin // numeric or true/false/null - Value := GetJSONField(JSON,result,nil,EndOfObject,@ValueLen); // let wasString=nil - if Value=nil then - AddShort('null') else begin - while (ValueLen>0) and (Value[ValueLen-1]<=' ') do dec(ValueLen); - AddNoJSONEscape(Value,ValueLen); - end; - exit; - end; - end; - if JSON<>nil then begin - while (JSON^<=' ') and (JSON^<>#0) do inc(JSON); - if EndOfObject<>nil then - EndOfObject^ := JSON^; - if JSON^<>#0 then - repeat inc(JSON) until (JSON^=#0) or (JSON^>' '); - end; - result := JSON; -end; - -function TTextWriter.AddJSONToXML(JSON: PUTF8Char; ArrayName,EndOfObject: PUTF8Char): PUTF8Char; -var objEnd: AnsiChar; - Name,Value: PUTF8Char; - n,c: integer; -begin - result := nil; - if JSON=nil then - exit; - while (JSON^<=' ') and (JSON^<>#0) do inc(JSON); - case JSON^ of - '[': begin - repeat inc(JSON) until (JSON^=#0) or (JSON^>' '); - if JSON^=']' then - JSON := GotoNextNotSpace(JSON+1) else begin - n := 0; - repeat - if JSON=nil then - exit; - Add('<'); - if ArrayName=nil then - Add(n) else - AddXmlEscape(ArrayName); - Add('>'); - JSON := AddJSONToXML(JSON,nil,@objEnd); - Add('<','/'); - if ArrayName=nil then - Add(n) else - AddXmlEscape(ArrayName); - Add('>'); - inc(n); - until objEnd=']'; - end; - end; - '{': begin - repeat inc(JSON) until (JSON^=#0) or (JSON^>' '); - if JSON^='}' then - repeat inc(JSON) until (JSON^=#0) or (JSON^>' ') else begin - repeat - Name := GetJSONPropName(JSON); - if Name=nil then - exit; - while (JSON^<=' ') and (JSON^<>#0) do inc(JSON); - if JSON^='[' then // arrays are written as list of items, without root - JSON := AddJSONToXML(JSON,Name,@objEnd) else begin - Add('<'); - AddXmlEscape(Name); - Add('>'); - JSON := AddJSONToXML(JSON,Name,@objEnd); - Add('<','/'); - AddXmlEscape(Name); - Add('>'); - end; - until objEnd='}'; - end; - end; - else begin - Value := GetJSONField(JSON,result,nil,EndOfObject); // let wasString=nil - if Value=nil then - AddShort('null') else begin - c := PInteger(Value)^ and $ffffff; - if (c=JSON_BASE64_MAGIC) or (c=JSON_SQLDATE_MAGIC) then - inc(Value,3); // just ignore the Magic codepoint encoded as UTF-8 - AddXmlEscape(Value); - end; - exit; - end; - end; - if JSON<>nil then begin - while (JSON^<=' ') and (JSON^<>#0) do inc(JSON); - if EndOfObject<>nil then - EndOfObject^ := JSON^; - if JSON^<>#0 then - repeat inc(JSON) until (JSON^=#0) or (JSON^>' '); - end; - result := JSON; -end; - -procedure TTextWriter.AddDynArrayJSON(var aDynArray: TDynArray); -var i,n: PtrInt; - P: Pointer; - T: TDynArrayKind; - tmp: RawByteString; - customWriter: TDynArrayJSONCustomWriter; - customParser: TJSONRecordAbstract; - nested: TDynArray; - hr: boolean; -begin // code below must match TDynArray.LoadFromJSON - n := aDynArray.Count-1; - if n<0 then begin - Add('[',']'); - exit; - end; - if aDynArray.HasCustomJSONParser then - with GlobalJSONCustomParsers.fParser[aDynArray.fParser] do begin - customWriter := Writer; - customParser := RecordCustomParser; - end else begin - customWriter := nil; - customParser := nil; - end; - if Assigned(customWriter) then - T := djCustom else - T := aDynArray.GuessKnownType({exacttype=}true); - P := aDynArray.fValue^; - Add('['); - case T of - djNone: - if (aDynArray.ElemType<>nil) and - (PTypeKind(aDynArray.ElemType)^=tkDynArray) then begin - for i := 0 to n do begin - nested.Init(aDynArray.ElemType,P^); - AddDynArrayJSON(nested); - Add(','); - inc(PByte(P),aDynArray.ElemSize); - end; - end else begin - tmp := aDynArray.SaveTo; - WrBase64(pointer(tmp),length(tmp),{withMagic=}true); - end; - djCustom: begin - if customParser=nil then - hr := false else - hr := soWriteHumanReadable in customParser.Options; - if hr then - Inc(fHumanReadableLevel); - for i := 0 to n do begin - customWriter(self,P^); - Add(','); - inc(PByte(P),aDynArray.ElemSize); - end; - if hr then begin - dec(fHumanReadableLevel); - CancelLastComma; - AddCRAndIndent; - end; - end; - {$ifndef NOVARIANTS} - djVariant: - for i := 0 to n do begin - AddVariant(PVariantArray(P)^[i],twJSONEscape); - Add(','); - end; - {$endif} - djRawUTF8: - for i := 0 to n do begin - Add('"'); - AddJSONEscape(PPointerArray(P)^[i]); - Add('"',','); - end; - djRawByteString: - for i := 0 to n do begin - WrBase64(PPointerArray(P)^[i],Length(PRawByteStringArray(P)^[i]),{withMagic=}true); - Add(','); - end; - djInteger: - for i := 0 to n do begin - Add(PIntegerArray(P)^[i]); - Add(','); - end; - djInt64: - for i := 0 to n do begin - Add(PInt64Array(P)^[i]); - Add(','); - end; - djQWord: - for i := 0 to n do begin - AddQ(PQwordArray(P)^[i]); - Add(','); - end; - else // slightly less efficient for less-used types - if T in DJ_STRING then - for i := 0 to n do begin - Add('"'); - case T of - djTimeLog: AddTimeLog(@PInt64Array(P)^[i]); - djDateTime: AddDateTime(@PDoubleArray(P)^[i],'T',#0,false); - djDateTimeMS: AddDateTime(@PDoubleArray(P)^[i],'T',#0,true); - djWideString, djSynUnicode: AddJSONEscapeW(PPointerArray(P)^[i]); - djWinAnsi: AddAnyAnsiString(PRawByteStringArray(P)^[i],twJSONEscape,CODEPAGE_US); - djString: - {$ifdef UNICODE} - AddJSONEscapeW(PPointerArray(P)^[i]); - {$else} - AddAnyAnsiString(PRawByteStringArray(P)^[i],twJSONEscape,0); - {$endif} - djHash128: AddBinToHexDisplayLower(@PHash128Array(P)[i],SizeOf(THash128)); - djHash256: AddBinToHexDisplayLower(@PHash256Array(P)[i],SizeOf(THash256)); - djHash512: AddBinToHexDisplayLower(@PHash512Array(P)[i],SizeOf(THash512)); - djInterface: AddPointer(PPtrIntArray(P)^[i]); - else raise ESynException.CreateUTF8('AddDynArrayJSON unsupported %',[ToText(T)^]); - end; - Add('"',','); - end else - for i := 0 to n do begin - case T of - djBoolean: Add(PBooleanArray(P)^[i]); - djByte: AddU(PByteArray(P)^[i]); - djWord: AddU(PWordArray(P)^[i]); - djCardinal: AddU(PCardinalArray(P)^[i]); - djSingle: AddSingle(PSingleArray(P)^[i]); - djDouble: AddDouble(PDoubleArray(P)^[i]); - djCurrency: AddCurr64(PInt64Array(P)^[i]); - else raise ESynException.CreateUTF8('AddDynArrayJSON unsupported %',[ToText(T)^]); - end; - Add(','); - end; - end; - CancelLastComma; - Add(']'); -end; - -procedure TTextWriter.Add(const Format: RawUTF8; const Values: array of const; - Escape: TTextWriterKind; WriteObjectOptions: TTextWriterWriteObjectOptions); -var ValuesIndex: integer; - F: PUTF8Char; -label write; -begin // we put const char > #127 as #??? -> asiatic MBCS codepage OK - if Format='' then - exit; - if (Format='%') and (high(Values)>=0) then begin - Add(Values[0],Escape); - exit; - end; - ValuesIndex := 0; - F := pointer(Format); - repeat - repeat - case ord(F^) of - 0: exit; - ord('%'): break; - {$ifdef OLDTEXTWRITERFORMAT} - 164: AddCR; // currency sign -> add CR,LF - 167: if B^=',' then dec(B); // section sign to ignore next comma - ord('|'): begin - inc(F); // |% -> % - goto write; - end; - ord('$'),163,181: // dollar, pound, micro sign - break; // process command value - {$endif} - else begin -write: if B>=BEnd then - FlushToStream; - B[1] := F^; - inc(B); - end; - end; - inc(F); - until false; - // add next value as text - if ValuesIndex<=high(Values) then // missing value will display nothing - case ord(F^) of - ord('%'): - Add(Values[ValuesIndex],Escape,WriteObjectOptions); - {$ifdef OLDTEXTWRITERFORMAT} - ord('$'): with Values[ValuesIndex] do - if Vtype=vtInteger then Add2(VInteger); - 163: with Values[ValuesIndex] do // pound sign - if Vtype=vtInteger then Add4(VInteger); - 181: with Values[ValuesIndex] do // micro sign - if Vtype=vtInteger then Add3(VInteger); - {$endif} - end; - inc(F); - inc(ValuesIndex); - until false; -end; - -procedure TTextWriter.AddLine(const Text: shortstring); -var L: PtrInt; -begin - L := ord(Text[0]); - if BEnd-B<=L+2 then - FlushToStream; - inc(B); - if L>0 then begin - MoveFast(Text[1],B^,L); - inc(B,L); - end; - PWord(B)^ := 13+10 shl 8; // CR + LF - inc(B); -end; - -procedure TTextWriter.AddBinToHexDisplay(Bin: pointer; BinBytes: integer); -begin - if cardinal(BinBytes*2-1)>=cardinal(fTempBufSize) then - exit; - if BEnd-B<=BinBytes*2 then - FlushToStream; - BinToHexDisplay(Bin,PAnsiChar(B+1),BinBytes); - inc(B,BinBytes*2); -end; - -procedure TTextWriter.AddBinToHexDisplayLower(Bin: pointer; BinBytes: integer); -begin - if cardinal(BinBytes*2-1)>=cardinal(fTempBufSize) then - exit; - if BEnd-B<=BinBytes*2 then - FlushToStream; - BinToHexDisplayLower(Bin,PAnsiChar(B+1),BinBytes); - inc(B,BinBytes*2); -end; - -procedure TTextWriter.AddBinToHexDisplayQuoted(Bin: pointer; BinBytes: integer); -begin - if cardinal(BinBytes*2+2)>=cardinal(fTempBufSize) then - exit; - if BEnd-B<=BinBytes*2+2 then - FlushToStream; - B[1] := '"'; - BinToHexDisplayLower(Bin,PAnsiChar(B+2),BinBytes); - inc(B,BinBytes*2); - B[2] := '"'; - inc(B,2); -end; - -procedure TTextWriter.AddBinToHexDisplayMinChars(Bin: pointer; BinBytes: PtrInt); -begin - if (BinBytes<=0) or (cardinal(BinBytes*2-1)>=cardinal(fTempBufSize)) then - exit; - repeat // append hexa chars up to the last non zero byte - dec(BinBytes); - until (BinBytes=0) or (PByteArray(Bin)[BinBytes]<>0); - inc(BinBytes); - if BEnd-B<=BinBytes*2 then - FlushToStream; - BinToHexDisplayLower(Bin,PAnsiChar(B+1),BinBytes); - inc(B,BinBytes*2); -end; - -procedure TTextWriter.AddPointer(P: PtrUInt); -begin - AddBinToHexDisplayMinChars(@P,SizeOf(P)); -end; - -procedure TTextWriter.AddBinToHex(Bin: Pointer; BinBytes: integer); -var ChunkBytes: PtrInt; -begin - if BinBytes<=0 then - exit; - if B>=BEnd then - FlushToStream; - inc(B); - repeat - // guess biggest size to be added into buf^ at once - ChunkBytes := (BEnd-B) shr 1; // div 2, *2 -> two hexa chars per byte - if BinBytes special one below: - WriteToStream(fTempBuf,B-fTempBuf); - B := fTempBuf; - until false; - dec(B); // allow CancelLastChar -end; - -procedure TTextWriter.AddQuotedStr(Text: PUTF8Char; Quote: AnsiChar; - TextMaxLen: PtrInt); -var BMax: PUTF8Char; - c: AnsiChar; -begin - if TextMaxLen<=0 then - TextMaxLen := maxInt else - if TextMaxLen>5 then - dec(TextMaxLen,5); - BMax := BEnd-3; - if B>=BMax then begin - FlushToStream; - BMax := BEnd-3; - end; - inc(B); - B^ := Quote; - inc(B); - if Text<>nil then - repeat - if B0 then begin - c := Text^; - inc(Text); - if c=#0 then - break; - B^ := c; - inc(B); - if c<>Quote then - continue; - B^ := c; - inc(B); - end else begin - PCardinal(B)^ := ord('.')+ord('.')shl 8+ord('.')shl 16; - inc(B,3); - break; - end; - end else begin - FlushToStream; - BMax := BEnd-3; - end; - until false; - B^ := Quote; -end; - -const - HTML_ESC: array[hfAnyWhere..high(TTextWriterHTMLFormat)] of TSynAnsicharSet = ( - [#0,'&','"','<','>'],[#0,'&','<','>'],[#0,'&','"']); - -procedure TTextWriter.AddHtmlEscape(Text: PUTF8Char; Fmt: TTextWriterHTMLFormat); -var B: PUTF8Char; - esc: ^TSynAnsicharSet; -begin - if Text=nil then - exit; - if Fmt=hfNone then begin - AddNoJSONEscape(Text); - exit; - end; - esc := @HTML_ESC[Fmt]; - repeat - B := Text; - while not(Text^ in esc^) do - inc(Text); - AddNoJSONEscape(B,Text-B); - case Text^ of - #0: exit; - '<': AddShort('<'); - '>': AddShort('>'); - '&': AddShort('&'); - '"': AddShort('"'); - end; - inc(Text); - until Text^=#0; -end; - -procedure TTextWriter.AddHtmlEscape(Text: PUTF8Char; TextLen: PtrInt; - Fmt: TTextWriterHTMLFormat); -var B: PUTF8Char; - esc: ^TSynAnsicharSet; -begin - if (Text=nil) or (TextLen<=0) then - exit; - if Fmt=hfNone then begin - AddNoJSONEscape(Text,TextLen); - exit; - end; - inc(TextLen,PtrInt(Text)); // TextLen = final PtrInt(Text) - esc := @HTML_ESC[Fmt]; - repeat - B := Text; - while (PtrInt(Text)': AddShort('>'); - '&': AddShort('&'); - '"': AddShort('"'); - end; - inc(Text); - until false; -end; - -procedure TTextWriter.AddHtmlEscapeString(const Text: string; Fmt: TTextWriterHTMLFormat); -begin - AddHtmlEscape(pointer(StringToUTF8(Text)),Fmt); -end; - -procedure TTextWriter.AddHtmlEscapeUTF8(const Text: RawUTF8; Fmt: TTextWriterHTMLFormat); -begin - AddHtmlEscape(pointer(Text),length(Text),Fmt); -end; - -procedure TTextWriter.AddXmlEscape(Text: PUTF8Char); -const XML_ESCAPE: TSynByteSet = - [0..31,ord('<'),ord('>'),ord('&'),ord('"'),ord('''')]; -var i,beg: PtrInt; -begin - if Text=nil then - exit; - i := 0; - repeat - beg := i; - if not(ord(Text[i]) in XML_ESCAPE) then begin - repeat // it is faster to handle all not-escaped chars at once - inc(i); - until ord(Text[i]) in XML_ESCAPE; - AddNoJSONEscape(Text+beg,i-beg); - end; - repeat - case Text[i] of - #0: exit; - #1..#8,#11,#12,#14..#31: - ; // ignore invalid character - see http://www.w3.org/TR/xml/#NT-Char - #9,#10,#13: begin // characters below ' ', #9 e.g. -> // ' ' - AddShort('&#x'); - AddByteToHex(ord(Text[i])); - Add(';'); - end; - '<': AddShort('<'); - '>': AddShort('>'); - '&': AddShort('&'); - '"': AddShort('"'); - '''': AddShort('''); - else break; // should match XML_ESCAPE[] constant above - end; - inc(i); - until false; - until false; -end; - -procedure TTextWriter.AddReplace(Text: PUTF8Char; Orig,Replaced: AnsiChar); -begin - if Text<>nil then - while Text^<>#0 do begin - if Text^=Orig then - Add(Replaced) else - Add(Text^); - inc(Text); - end; -end; - -procedure TTextWriter.AddByteToHex(Value: byte); -begin - if BEnd-B<=1 then - FlushToStream; - PWord(B+1)^ := TwoDigitsHexWB[Value]; - inc(B,2); -end; - -procedure TTextWriter.AddInt18ToChars3(Value: cardinal); -begin - if BEnd-B<=3 then - FlushToStream; - PCardinal(B+1)^ := ((Value shr 12) and $3f)+ - ((Value shr 6) and $3f)shl 8+ - (Value and $3f)shl 16+$202020; - //assert(Chars3ToInt18(B+1)=Value); - inc(B,3); -end; - -function Int18ToChars3(Value: cardinal): RawUTF8; -begin - FastSetString(result,nil,3); - PCardinal(result)^ := ((Value shr 12) and $3f)+ - ((Value shr 6) and $3f)shl 8+ - (Value and $3f)shl 16+$202020; -end; - -procedure Int18ToChars3(Value: cardinal; var result: RawUTF8); -begin - FastSetString(result,nil,3); - PCardinal(result)^ := ((Value shr 12) and $3f)+ - ((Value shr 6) and $3f)shl 8+ - (Value and $3f)shl 16+$202020; -end; - -function Chars3ToInt18(P: pointer): cardinal; -begin - result := PCardinal(P)^-$202020; - result := ((result shr 16)and $3f)+ - ((result shr 8) and $3f)shl 6+ - (result and $3f)shl 12; -end; - -procedure TTextWriter.AddNoJSONEscape(P: Pointer); -begin - AddNoJSONEscape(P,StrLen(PUTF8Char(P))); -end; - -procedure TTextWriter.AddNoJSONEscape(P: Pointer; Len: PtrInt); -var i: PtrInt; -begin - if (P<>nil) and (Len>0) then begin - inc(B); // allow CancelLastChar - repeat - i := BEnd-B+1; // guess biggest size to be added into buf^ at once - if Len0 then begin - MoveFast(P^,B^,i); - inc(B,i); - end; - if i=Len then - break; - inc(PByte(P),i); - dec(Len,i); - // FlushInc writes B-buf+1 -> special one below: - WriteToStream(fTempBuf,B-fTempBuf); - B := fTempBuf; - until false; - dec(B); // allow CancelLastChar - end; -end; - -procedure TTextWriter.AddNoJSONEscapeUTF8(const text: RawByteString); -begin - AddNoJSONEscape(pointer(text),length(text)); -end; - -procedure TTextWriter.AddNoJSONEscapeW(WideChar: PWord; WideCharCount: integer); -var PEnd: PtrUInt; - BMax: PUTF8Char; -begin - if WideChar=nil then - exit; - BMax := BEnd-7; // ensure enough space for biggest Unicode glyph as UTF-8 - if WideCharCount=0 then - repeat - if B>=BMax then begin - FlushToStream; - BMax := BEnd-7; // B may have been resized -> recompute BMax - end; - if WideChar^=0 then - break; - if WideChar^<=126 then begin - B[1] := AnsiChar(ord(WideChar^)); - inc(WideChar); - inc(B); - end else - inc(B,UTF16CharToUtf8(B+1,WideChar)); - until false else begin - PEnd := PtrUInt(WideChar)+PtrUInt(WideCharCount)*SizeOf(WideChar^); - repeat - if B>=BMax then begin - FlushToStream; - BMax := BEnd-7; - end; - if WideChar^=0 then - break; - if WideChar^<=126 then begin - B[1] := AnsiChar(ord(WideChar^)); - inc(WideChar); - inc(B); - if PtrUInt(WideChar)nil then - case Escape of - twNone: AddNoJSONEscape(P,StrLen(P)); - twJSONEscape: AddJSONEscape(P); - twOnSameLine: AddOnSameLine(P); - end; -end; - -procedure TTextWriter.Add(P: PUTF8Char; Len: PtrInt; Escape: TTextWriterKind); -begin - if P<>nil then - case Escape of - twNone: AddNoJSONEscape(P,Len); - twJSONEscape: AddJSONEscape(P,Len); - twOnSameLine: AddOnSameLine(P,Len); - end; -end; - -procedure TTextWriter.AddW(P: PWord; Len: PtrInt; Escape: TTextWriterKind); -begin - if P<>nil then - case Escape of - twNone: AddNoJSONEscapeW(P,Len); - twJSONEscape: AddJSONEScapeW(P,Len); - twOnSameLine: AddOnSameLineW(P,Len); - end; -end; - -procedure TTextWriter.AddAnsiString(const s: AnsiString; Escape: TTextWriterKind); -begin - AddAnyAnsiBuffer(pointer(s),length(s),Escape,0); -end; - -procedure TTextWriter.AddAnyAnsiString(const s: RawByteString; - Escape: TTextWriterKind; CodePage: Integer); -var L: integer; -begin - L := length(s); - if L=0 then - exit; - if (L>2) and (PInteger(s)^ and $ffffff=JSON_BASE64_MAGIC) then begin - AddNoJSONEscape(pointer(s),L); // identified as a BLOB content - exit; - end; - if CodePage<0 then - {$ifdef HASCODEPAGE} - CodePage := PStrRec(PtrUInt(s)-STRRECSIZE)^.codePage; - {$else} - CodePage := 0; // TSynAnsiConvert.Engine(0)=CurrentAnsiConvert - {$endif} - AddAnyAnsiBuffer(pointer(s),L,Escape,CodePage); -end; - -procedure TTextWriter.AddAnyAnsiBuffer(P: PAnsiChar; Len: PtrInt; - Escape: TTextWriterKind; CodePage: Integer); -var B: PUTF8Char; -begin - if Len>0 then - case CodePage of - CP_UTF8: // direct write of RawUTF8 content - if Escape<>twJSONEscape then - Add(PUTF8Char(P),Len,Escape) else - Add(PUTF8Char(P),0,Escape); - CP_RAWBYTESTRING: - Add(PUTF8Char(P),Len,Escape); // direct write of RawByteString content - CP_UTF16: - AddW(PWord(P),0,Escape); // direct write of UTF-16 content - CP_SQLRAWBLOB: begin - AddNoJSONEscape(@PByteArray(@JSON_BASE64_MAGIC_QUOTE_VAR)[1],3); - WrBase64(P,Len,{withMagic=}false); - end; - else begin - // first handle trailing 7 bit ASCII chars, by quad - B := pointer(P); - if Len>=4 then - repeat - if PCardinal(P)^ and $80808080<>0 then - break; // break on first non ASCII quad - inc(P,4); - dec(Len,4); - until Len<4; - if (Len>0) and (P^<#128) then - repeat - inc(P); - dec(Len); - until (Len=0) or (P^>=#127); - if P<>pointer(B) then - Add(B,P-B,Escape); - if Len=0 then - exit; - // rely on explicit conversion for all remaining ASCII characters - TSynAnsiConvert.Engine(CodePage).InternalAppendUTF8(P,Len,self,Escape); - end; - end; -end; - -var - /// fast 256-byte branchless lookup table - // - 0 indicates no escape needed - // - 1 indicates #0 (end of string) - // - 2 should be escaped as \u00xx - // - b,t,n,f,r,\," as escaped character for #8,#9,#10,#12,#13,\," - JSON_ESCAPE: TNormTableByte; - -function NeedsJsonEscape(P: PUTF8Char; PLen: integer): boolean; -var tab: PNormTableByte; -begin - result := true; - tab := @JSON_ESCAPE; - if PLen>0 then - repeat - if tab[ord(P^)]<>0 then - exit; - inc(P); - dec(PLen); - until PLen=0; - result := false; -end; - -function NeedsJsonEscape(const Text: RawUTF8): boolean; -begin - result := NeedsJsonEscape(pointer(Text),length(Text)); -end; - -function NeedsJsonEscape(P: PUTF8Char): boolean; -var tab: PNormTableByte; - esc: byte; -begin - result := false; - if P=nil then - exit; - tab := @JSON_ESCAPE; - repeat - esc := tab[ord(P^)]; - if esc=0 then - inc(P) else - if esc=1 then - exit else // #0 reached - break; - until false; - result := true; -end; - -procedure TTextWriter.InternalAddFixedAnsi(Source: PAnsiChar; SourceChars: Cardinal; - AnsiToWide: PWordArray; Escape: TTextWriterKind); -var c: cardinal; - esc: byte; -begin - while SourceChars>0 do begin - c := byte(Source^); - if c<=$7F then begin - if c=0 then - exit; - if B>=BEnd then - FlushToStream; - case Escape of - twNone: begin - inc(B); - B^ := AnsiChar(c); - end; - twJSONEscape: begin - esc := JSON_ESCAPE[c]; - if esc=0 then begin // no escape needed - inc(B); - B^ := AnsiChar(c); - end else - if esc=1 then // #0 - exit else - if esc=2 then begin // #7 e.g. -> \u0007 - AddShort('\u00'); - AddByteToHex(c); - end else - Add('\',AnsiChar(esc)); // escaped as \ + b,t,n,f,r,\," - end; - twOnSameLine: begin - inc(B); - if c<32 then - B^ := ' ' else - B^ := AnsiChar(c); - end; - end - end else begin // no surrogate is expected in TSynAnsiFixedWidth charsets - if BEnd-B<=3 then - FlushToStream; - c := AnsiToWide[c]; // convert FixedAnsi char into Unicode char - if c>$7ff then begin - B[1] := AnsiChar($E0 or (c shr 12)); - B[2] := AnsiChar($80 or ((c shr 6) and $3F)); - B[3] := AnsiChar($80 or (c and $3F)); - inc(B,3); - end else begin - B[1] := AnsiChar($C0 or (c shr 6)); - B[2] := AnsiChar($80 or (c and $3F)); - inc(B,2); - end; - end; - dec(SourceChars); - inc(Source); - end; -end; - -procedure TTextWriter.AddOnSameLine(P: PUTF8Char); -begin - if P<>nil then - while P^<>#0 do begin - if B>=BEnd then - FlushToStream; - if P^<' ' then - B[1] := ' ' else - B[1] := P^; - inc(P); - inc(B); - end; -end; - -procedure TTextWriter.AddOnSameLine(P: PUTF8Char; Len: PtrInt); -var i: PtrInt; -begin - if P<>nil then - for i := 0 to Len-1 do begin - if B>=BEnd then - FlushToStream; - if P[i]<' ' then - B[1] := ' ' else - B[1] := P[i]; - inc(B); - end; -end; - -procedure TTextWriter.AddOnSameLineW(P: PWord; Len: PtrInt); -var PEnd: PtrUInt; -begin - if P=nil then exit; - if Len=0 then - PEnd := 0 else - PEnd := PtrUInt(P)+PtrUInt(Len)*SizeOf(WideChar); - while (Len=0) or (PtrUInt(P) UTF-8 encode - inc(B,UTF16CharToUtf8(B+1,P)); - end; - end; -end; - -procedure TTextWriter.AddJSONEscape(P: Pointer; Len: PtrInt); -var i,start: PtrInt; - {$ifdef CPUX86NOTPIC}tab: TNormTableByte absolute JSON_ESCAPE; - {$else}tab: PNormTableByte;{$endif} -label noesc; -begin - if P=nil then - exit; - if Len=0 then - dec(Len); // -1 = no end - i := 0; - {$ifndef CPUX86NOTPIC} tab := @JSON_ESCAPE; {$endif} - if tab[PByteArray(P)[i]]=0 then begin -noesc:start := i; - if Len<0 then - repeat // fastest loop is for AddJSONEscape(P,nil) - inc(i); - until tab[PByteArray(P)[i]]<>0 else - repeat - inc(i); - until (i>=Len) or (tab[PByteArray(P)[i]]<>0); - inc(PByte(P),start); - dec(i,start); - if Len>=0 then - dec(Len,start); - if BEnd-B<=i then - AddNoJSONEscape(P,i) else begin - MoveFast(P^,B[1],i); - inc(B,i); - end; - if (Len>=0) and (i>=Len) then - exit; - end; - repeat - if BEnd-B<=10 then - FlushToStream; - case tab[PByteArray(P)[i]] of - 0: goto noesc; - 1: exit; // #0 - 2: begin // characters below ' ', #7 e.g. -> // 'u0007' - PCardinal(B+1)^ := ord('\')+ord('u')shl 8+ord('0')shl 16+ord('0')shl 24; - inc(B,4); - PWord(B+1)^ := TwoDigitsHexWB[PByteArray(P)[i]]; - end; - else // escaped as \ + b,t,n,f,r,\," - PWord(B+1)^ := (integer(tab[PByteArray(P)[i]]) shl 8) or ord('\'); - end; - inc(i); - inc(B,2); - until (Len>=0) and (i>=Len); -end; - -procedure TTextWriter.AddJSONEscapeW(P: PWord; Len: PtrInt); -var i,c,s: PtrInt; - esc: byte; -begin - if P=nil then - exit; - if Len=0 then - Len := MaxInt; - i := 0; - while i0) then - break; - inc(i); - until i>=Len; - if i<>s then - AddNoJSONEscapeW(@PWordArray(P)[s],i-s); - if i>=Len then - exit; - c := PWordArray(P)[i]; - if c=0 then - exit; - esc := JSON_ESCAPE[c]; - if esc=1 then // #0 - exit else - if esc=2 then begin // characters below ' ', #7 e.g. -> \u0007 - AddShort('\u00'); - AddByteToHex(c); - end else - Add('\',AnsiChar(esc)); // escaped as \ + b,t,n,f,r,\," - inc(i); - end; -end; - -procedure TTextWriter.AddJSONEscape(const V: TVarRec); -begin - with V do - case VType of - vtPointer: AddShort('null'); - vtString, vtAnsiString,{$ifdef HASVARUSTRING}vtUnicodeString,{$endif} - vtPChar, vtChar, vtWideChar, vtWideString, vtClass: begin - Add('"'); - case VType of - vtString: if VString^[0]<>#0 then AddJSONEscape(@VString^[1],ord(VString^[0])); - vtAnsiString: AddJSONEscape(VAnsiString); - {$ifdef HASVARUSTRING} - vtUnicodeString: AddJSONEscapeW( - pointer(UnicodeString(VUnicodeString)),length(UnicodeString(VUnicodeString))); - {$endif} - vtPChar: AddJSONEscape(VPChar); - vtChar: AddJSONEscape(@VChar,1); - vtWideChar: AddJSONEscapeW(@VWideChar,1); - vtWideString: AddJSONEscapeW(VWideString); - vtClass: AddClassName(VClass); - end; - Add('"'); - end; - vtBoolean: Add(VBoolean); // 'true'/'false' - vtInteger: Add(VInteger); - vtInt64: Add(VInt64^); - {$ifdef FPC} - vtQWord: AddQ(V.VQWord^); - {$endif} - vtExtended: AddDouble(VExtended^); - vtCurrency: AddCurr64(VInt64^); - vtObject: WriteObject(VObject); - {$ifndef NOVARIANTS} - vtVariant: AddVariant(VVariant^,twJSONEscape); - {$endif} - end; -end; - -procedure TTextWriter.AddJSONString(const Text: RawUTF8); -begin - Add('"'); - AddJSONEscape(pointer(Text)); - Add('"'); -end; - -procedure TTextWriter.Add(const V: TVarRec; Escape: TTextWriterKind; - WriteObjectOptions: TTextWriterWriteObjectOptions); -begin - with V do - case VType of - vtInteger: Add(VInteger); - vtBoolean: if VBoolean then Add('1') else Add('0'); // normalize - vtChar: Add(@VChar,1,Escape); - vtExtended: AddDouble(VExtended^); - vtCurrency: AddCurr64(VInt64^); - vtInt64: Add(VInt64^); - {$ifdef FPC} - vtQWord: AddQ(VQWord^); - {$endif} - {$ifndef NOVARIANTS} - vtVariant: AddVariant(VVariant^,Escape); - {$endif} - vtString: if VString^[0]<>#0 then Add(@VString^[1],ord(VString^[0]),Escape); - vtInterface, - vtPointer: AddBinToHexDisplayMinChars(@VPointer,SizeOf(VPointer)); - vtPChar: Add(PUTF8Char(VPChar),Escape); - vtObject: WriteObject(VObject,WriteObjectOptions); - vtClass: AddClassName(VClass); - vtWideChar: AddW(@VWideChar,1,Escape); - vtPWideChar: - AddW(pointer(VPWideChar),StrLenW(VPWideChar),Escape); - vtAnsiString: - if VAnsiString<>nil then - Add(VAnsiString,length(RawUTF8(VAnsiString)),Escape); // expect RawUTF8 - vtWideString: - if VWideString<>nil then - AddW(VWideString,length(WideString(VWideString)),Escape); - {$ifdef HASVARUSTRING} - vtUnicodeString: - if VUnicodeString<>nil then // convert to UTF-8 - AddW(VUnicodeString,length(UnicodeString(VUnicodeString)),Escape); - {$endif} - end; -end; - -{$ifndef NOVARIANTS} -procedure TTextWriter.AddJSON(const Format: RawUTF8; const Args,Params: array of const); -var temp: variant; -begin - _JsonFmt(Format,Args,Params,JSON_OPTIONS_FAST,temp); - AddVariant(temp,twJSONEscape); -end; -{$endif} - -procedure TTextWriter.AddJSONArraysAsJSONObject(keys,values: PUTF8Char); -var k,v: PUTF8Char; -begin - if (keys=nil) or (keys^<>'[') or (values=nil) or (values^<>'[') then begin - AddShort('null'); - exit; - end; - inc(keys); // jump initial [ - inc(values); - Add('{'); - repeat - k := GotoEndJSONItem(keys); - v := GotoEndJSONItem(values); - if (k=nil) or (v=nil) then - break; // invalid JSON input - AddNoJSONEscape(keys,k-keys); - Add(':'); - AddNoJSONEscape(values,v-values); - Add(','); - if (k^<>',') or (v^<>',') then - break; // reached the end of the input JSON arrays - keys := k+1; - values := v+1; - until false; - CancelLastComma; - Add('}'); -end; - -procedure TTextWriter.AddJSONEscape(const NameValuePairs: array of const); -var a: integer; -procedure WriteValue; -begin - case VarRecAsChar(NameValuePairs[a]) of - ord('['): begin - Add('['); - while a'' then - {$ifdef UNICODE} - AddNoJSONEscapeW(pointer(s),0); - {$else} - AddAnsiString(s,twNone); - {$endif} -end; - -procedure TTextWriter.AddJSONEscapeString(const s: string); -begin - if s<>'' then - {$ifdef UNICODE} - AddJSONEscapeW(pointer(s),Length(s)); - {$else} - AddAnyAnsiString(s,twJSONEscape,0); - {$endif} -end; - -procedure TTextWriter.AddJSONEscapeAnsiString(const s: AnsiString); -begin - AddAnyAnsiString(s,twJSONEscape,0); -end; - -procedure TTextWriter.AddProp(PropName: PUTF8Char; PropNameLen: PtrInt); -begin - if PropNameLen=0 then - exit; // paranoid check - if BEnd-B<=PropNameLen+3 then - FlushToStream; - if twoForceJSONExtended in CustomOptions then begin - MoveSmall(PropName,B+1,PropNameLen); - inc(B,PropNameLen+1); - B^ := ':'; - end else begin - B[1] := '"'; - MoveSmall(PropName,B+2,PropNameLen); - inc(B,PropNameLen+2); - PWord(B)^ := ord('"')+ord(':')shl 8; - inc(B); - end; -end; - -procedure TTextWriter.AddPropName(const PropName: ShortString); -begin - AddProp(@PropName[1],ord(PropName[0])); -end; - -procedure TTextWriter.AddPropJSONString(const PropName: shortstring; const Text: RawUTF8); -begin - AddProp(@PropName[1],ord(PropName[0])); - AddJSONString(Text); - Add(','); -end; - -procedure TTextWriter.AddPropJSONInt64(const PropName: shortstring; Value: Int64); -begin - AddProp(@PropName[1],ord(PropName[0])); - Add(Value); - Add(','); -end; - -procedure TTextWriter.AddFieldName(const FieldName: RawUTF8); -begin - AddProp(Pointer(FieldName),length(FieldName)); -end; - -procedure TTextWriter.AddClassName(aClass: TClass); -begin - if aClass<>nil then - AddShort(PShortString(PPointer(PtrInt(PtrUInt(aClass))+vmtClassName)^)^); -end; - -procedure TTextWriter.AddInstanceName(Instance: TObject; SepChar: AnsiChar); -begin - Add('"'); - if Instance=nil then - AddShort('void') else - AddShort(PShortString(PPointer(PPtrInt(Instance)^+vmtClassName)^)^); - Add('('); - AddBinToHexDisplayMinChars(@Instance,SizeOf(Instance)); - Add(')','"'); - if SepChar<>#0 then - Add(SepChar); -end; - -procedure TTextWriter.AddInstancePointer(Instance: TObject; SepChar: AnsiChar; - IncludeUnitName, IncludePointer: boolean); -var info: PTypeInfo; -begin - if IncludeUnitName then begin - info := PPointer(PPtrInt(Instance)^+vmtTypeInfo)^; - if info<>nil then begin // avoid GPF if no RTTI for this class - AddShort(PShortString(@GetTypeInfo(info)^.UnitNameLen)^); - Add('.'); - end; - end; - AddShort(PShortString(PPointer(PPtrInt(Instance)^+vmtClassName)^)^); - if IncludePointer then begin - Add('('); - AddBinToHexDisplayMinChars(@Instance,SizeOf(Instance)); - Add(')'); - end; - if SepChar<>#0 then - Add(SepChar); -end; - -procedure TTextWriter.AddShort(const Text: ShortString); -var L: PtrInt; -begin - L := ord(Text[0]); - if L=0 then - exit; - if BEnd-B<=L then - FlushToStream; - MoveFast(Text[1],B[1],L); - inc(B,L); -end; - -procedure TTextWriter.AddQuotedStringAsJSON(const QuotedString: RawUTF8); -var L: integer; - P,B: PUTF8Char; - quote: AnsiChar; -begin - L := length(QuotedString); - if L>0 then begin - quote := QuotedString[1]; - if (quote in ['''','"']) and (QuotedString[L]=quote) then begin - Add('"'); - P := pointer(QuotedString); - inc(P); - repeat - B := P; - while P[0]<>quote do inc(P); - if P[1]<>quote then - break; // end quote - inc(P); - AddJSONEscape(B,P-B); - inc(P); // ignore double quote - until false; - if P-B<>0 then - AddJSONEscape(B,P-B); - Add('"'); - end else - AddNoJSONEscape(pointer(QuotedString),length(QuotedString)); - end; -end; - -procedure TTextWriter.AddTrimLeftLowerCase(Text: PShortString); -var P: PAnsiChar; - L: integer; -begin - L := length(Text^); - P := @Text^[1]; - while (L>0) and (P^ in ['a'..'z']) do begin - inc(P); - dec(L); - end; - if L=0 then - AddShort(Text^) else - AddNoJSONEscape(P,L); -end; - -procedure TTextWriter.AddTrimSpaces(const Text: RawUTF8); -begin - AddTrimSpaces(pointer(Text)); -end; - -procedure TTextWriter.AddTrimSpaces(P: PUTF8Char); -var c: AnsiChar; -begin - if P<>nil then - repeat - c := P^; - inc(P); - if c>' ' then - Add(c); - until c=#0; -end; - -procedure TTextWriter.AddString(const Text: RawUTF8); -var L: PtrInt; -begin - L := PtrInt(Text); - if L=0 then - exit; - L := PStrLen(L-_STRLEN)^; - if L0 then begin - if len0 then - if L*count>fTempBufSize then - for i := 1 to count do - AddString(Text) else begin - if BEnd-B<=L*count then - FlushToStream; - for i := 1 to count do begin - MoveFast(pointer(Text)^,B[1],L); - inc(B,L); - end; - end; -end; - -procedure TTextWriter.CancelAll; -begin - if self=nil then - exit; // avoid GPF - if fTotalFileSize<>0 then - fTotalFileSize := fStream.Seek(fInitialStreamPosition,soBeginning); - B := fTempBuf-1; -end; - -procedure TTextWriter.SetBuffer(aBuf: pointer; aBufSize: integer); -begin - if aBufSize<=16 then - raise ESynException.CreateUTF8('%.SetBuffer(size=%)',[self,aBufSize]); - if aBuf=nil then - GetMem(fTempBuf,aBufSize) else begin - fTempBuf := aBuf; - Include(fCustomOptions,twoBufferIsExternal); - end; - fTempBufSize := aBufSize; - B := fTempBuf-1; // Add() methods will append at B+1 - BEnd := fTempBuf+fTempBufSize-16; // -16 to avoid buffer overwrite/overread - if DefaultTextWriterTrimEnum then - Include(fCustomOptions,twoTrimLeftEnumSets); -end; - -constructor TTextWriter.Create(aStream: TStream; aBufSize: integer); -begin - SetStream(aStream); - if aBufSize<256 then - aBufSize := 256; - SetBuffer(nil,aBufSize); -end; - -constructor TTextWriter.Create(aStream: TStream; aBuf: pointer; aBufSize: integer); -begin - SetStream(aStream); - SetBuffer(aBuf,aBufSize); -end; - -constructor TTextWriter.CreateOwnedStream(aBufSize: integer); -begin - Create(TRawByteStringStream.Create,aBufSize); - Include(fCustomOptions,twoStreamIsOwned); -end; - -constructor TTextWriter.CreateOwnedStream(aBuf: pointer; aBufSize: integer); -begin - SetStream(TRawByteStringStream.Create); - SetBuffer(aBuf,aBufSize); - Include(fCustomOptions,twoStreamIsOwned); -end; - -constructor TTextWriter.CreateOwnedStream(var aStackBuf: TTextWriterStackBuffer; - aBufSize: integer); -begin - if aBufSize>SizeOf(aStackBuf) then // too small -> allocate on heap - CreateOwnedStream(aBufSize) else - CreateOwnedStream(@aStackBuf,SizeOf(aStackBuf)); -end; - -constructor TTextWriter.CreateOwnedFileStream(const aFileName: TFileName; - aBufSize: integer); -begin - DeleteFile(aFileName); - Create(TFileStream.Create(aFileName,fmCreate or fmShareDenyWrite),aBufSize); - Include(fCustomOptions,twoStreamIsOwned); -end; - -destructor TTextWriter.Destroy; -begin - if twoStreamIsOwned in fCustomOptions then - fStream.Free; - if not (twoBufferIsExternal in fCustomOptions) then - FreeMem(fTempBuf); - fInternalJSONWriter.Free; - inherited; -end; - -class procedure TTextWriter.SetDefaultEnumTrim(aShouldTrimEnumsAsText: boolean); -begin - DefaultTextWriterTrimEnum := aShouldTrimEnumsAsText; -end; - -procedure TTextWriter.SetStream(aStream: TStream); -begin - if fStream<>nil then - if twoStreamIsOwned in fCustomOptions then begin - FreeAndNil(fStream); - Exclude(fCustomOptions,twoStreamIsOwned); - end; - if aStream<>nil then begin - fStream := aStream; - fInitialStreamPosition := fStream.Seek(0,soCurrent); - fTotalFileSize := fInitialStreamPosition; - end; -end; - -procedure TTextWriter.FlushToStream; -var i: PtrInt; - s: PtrUInt; -begin - i := B-fTempBuf+1; - if i<=0 then - exit; - WriteToStream(fTempBuf,i); - if not (twoFlushToStreamNoAutoResize in fCustomOptions) then begin - s := fTotalFileSize-fInitialStreamPosition; - if (fTempBufSize<49152) and (s>PtrUInt(fTempBufSize)*4) then - s := fTempBufSize*2 else // tune small (stack-alloc?) buffer - if (fTempBufSize<1 shl 20) and (s>40 shl 20) then - s := 1 shl 20 else // 40MB -> 1MB buffer - s := 0; - if s>0 then begin - fTempBufSize := s; - if twoBufferIsExternal in fCustomOptions then // use heap, not stack - exclude(fCustomOptions,twoBufferIsExternal) else - FreeMem(fTempBuf); // with big content comes bigger buffer - GetMem(fTempBuf,fTempBufSize); - BEnd := fTempBuf+(fTempBufSize-16); - end; - end; - B := fTempBuf-1; -end; - -procedure TTextWriter.WriteToStream(data: pointer; len: PtrUInt); -begin - if Assigned(fOnFlushToStream) then - fOnFlushToStream(data,len); - fStream.WriteBuffer(data^,len); - inc(fTotalFileSize,len); -end; - -function TTextWriter.GetTextLength: PtrUInt; -begin - if self=nil then - result := 0 else - result := PtrUInt(B-fTempBuf+1)+fTotalFileSize-fInitialStreamPosition; -end; - -function TTextWriter.Text: RawUTF8; -begin - SetText(result); -end; - -procedure TTextWriter.ForceContent(const text: RawUTF8); -begin - CancelAll; - if (fInitialStreamPosition=0) and fStream.InheritsFrom(TRawByteStringStream) then - TRawByteStringStream(fStream).fDataString := text else - fStream.WriteBuffer(pointer(text)^,length(text)); - fTotalFileSize := fInitialStreamPosition+cardinal(length(text)); -end; - -procedure TTextWriter.FlushFinal; -begin - Include(fCustomOptions,twoFlushToStreamNoAutoResize); - FlushToStream; -end; - -procedure TTextWriter.SetText(var result: RawUTF8; reformat: TTextWriterJSONFormat); -var Len: cardinal; -begin - FlushFinal; - Len := fTotalFileSize-fInitialStreamPosition; - if Len=0 then - result := '' else - if fStream.InheritsFrom(TRawByteStringStream) then - with TRawByteStringStream(fStream) do - if fInitialStreamPosition=0 then begin - {$ifdef HASCODEPAGE} // FPC expects this - SetCodePage(fDataString,CP_UTF8,false); - {$endif} - result := fDataString; - fDataString := ''; - end else - FastSetString(result,PAnsiChar(pointer(DataString))+fInitialStreamPosition,Len) else - if fStream.InheritsFrom(TCustomMemoryStream) then - with TCustomMemoryStream(fStream) do - FastSetString(result,PAnsiChar(Memory)+fInitialStreamPosition,Len) else begin - FastSetString(result,nil,Len); - fStream.Seek(fInitialStreamPosition,soBeginning); - fStream.Read(pointer(result)^,Len); - end; - if reformat<>jsonCompact then begin // reformat using the very same instance - CancelAll; - AddJSONReformat(pointer(result),reformat,nil); - SetText(result); - end; -end; - -procedure TTextWriter.WrRecord(const Rec; TypeInfo: pointer); -var L: integer; - tmp: RawByteString; -begin - L := RecordSaveLength(Rec,TypeInfo); - SetString(tmp,nil,L); - if L<>0 then - RecordSave(Rec,pointer(tmp),TypeInfo); - WrBase64(pointer(tmp),L,{withMagic=}true); -end; - -procedure TTextWriter.WrBase64(P: PAnsiChar; Len: PtrUInt; withMagic: boolean); -var trailing, main, n: PtrUInt; -begin - if withMagic then - if Len<=0 then begin - AddShort('null'); // JSON null is better than "" for BLOBs - exit; - end else - AddNoJSONEscape(@JSON_BASE64_MAGIC_QUOTE_VAR,4); - if len>0 then begin - n := Len div 3; - trailing := Len-n*3; - dec(Len,trailing); - if BEnd-B>integer(n+1) shl 2 then begin - // will fit in available space in Buf -> fast in-buffer Base64 encoding - n := Base64EncodeMain(@B[1],P,Len); - inc(B,n*4); - inc(P,n*3); - end else begin - // bigger than available space in Buf -> do it per chunk - FlushToStream; - while Len>0 do begin // length(buf) const -> so is ((length(buf)-4)shr2 )*3 - n := ((fTempBufSize-4)shr 2)*3; - if Len0 then begin - Base64EncodeTrailing(@B[1],P,trailing); - inc(B,4); - end; - end; - if withMagic then - Add('"'); -end; - - -{ TTextWriterWithEcho } - -procedure TTextWriterWithEcho.AddEndOfLine(aLevel: TSynLogInfo=sllNone); -var i: integer; -begin - if BEnd-B<=1 then - FlushToStream; - if twoEndOfLineCRLF in fCustomOptions then begin - PWord(B+1)^ := 13+10 shl 8; // CR + LF - inc(B,2); - end else begin - B[1] := #10; // LF - inc(B); - end; - if fEchos<>nil then begin - fEchoStart := EchoFlush; - for i := length(fEchos)-1 downto 0 do // for MultiEventRemove() below - try - fEchos[i](self,aLevel,fEchoBuf); - except // remove callback in case of exception during echoing in user code - MultiEventRemove(fEchos,i); - end; - fEchoBuf := ''; - end; -end; - -procedure TTextWriterWithEcho.FlushToStream; -begin - if fEchos<>nil then begin - EchoFlush; - fEchoStart := 0; - end; - inherited FlushToStream; -end; - -procedure TTextWriterWithEcho.EchoAdd(const aEcho: TOnTextWriterEcho); -begin - if self<>nil then - if MultiEventAdd(fEchos,TMethod(aEcho)) then - if fEchos<>nil then - fEchoStart := B-fTempBuf+1; // ignore any previous buffer -end; - -procedure TTextWriterWithEcho.EchoRemove(const aEcho: TOnTextWriterEcho); -begin - if self<>nil then - MultiEventRemove(fEchos,TMethod(aEcho)); -end; - -function TTextWriterWithEcho.EchoFlush: PtrInt; -var L,LI: PtrInt; - P: PByteArray; -begin - result := B-fTempBuf+1; - L := result-fEchoStart; - P := @PByteArray(fTempBuf)[fEchoStart]; - while (L>0) and (P[L-1] in [10,13]) do // trim right CR/LF chars - dec(L); - LI := length(fEchoBuf); // fast append to fEchoBuf - SetLength(fEchoBuf,LI+L); - MoveFast(P^,PByteArray(fEchoBuf)[LI],L); -end; - -procedure TTextWriterWithEcho.EchoReset; -begin - fEchoBuf := ''; -end; - -function TTextWriterWithEcho.GetEndOfLineCRLF: boolean; -begin - result := twoEndOfLineCRLF in fCustomOptions; -end; - -procedure TTextWriterWithEcho.SetEndOfLineCRLF(aEndOfLineCRLF: boolean); -begin - if aEndOfLineCRLF then - include(fCustomOptions,twoEndOfLineCRLF) else - exclude(fCustomOptions,twoEndOfLineCRLF); -end; - - - -function JSONEncode(const NameValuePairs: array of const): RawUTF8; -var temp: TTextWriterStackBuffer; -begin - if high(NameValuePairs)<1 then - result := '{}' else // return void JSON object on error - with DefaultTextWriterSerializer.CreateOwnedStream(temp) do - try - AddJSONEscape(NameValuePairs); - SetText(result); - finally - Free - end; -end; - -{$ifndef NOVARIANTS} -function JSONEncode(const Format: RawUTF8; const Args,Params: array of const): RawUTF8; -var temp: TTextWriterStackBuffer; -begin - with DefaultTextWriterSerializer.CreateOwnedStream(temp) do - try - AddJSON(Format,Args,Params); - SetText(result); - finally - Free - end; -end; -{$endif} - -function JSONEncodeArrayDouble(const Values: array of double): RawUTF8; -var W: TTextWriter; - temp: TTextWriterStackBuffer; -begin - W := TTextWriter.CreateOwnedStream(temp); - try - W.Add('['); - W.AddCSVDouble(Values); - W.Add(']'); - W.SetText(result); - finally - W.Free - end; -end; - -function JSONEncodeArrayUTF8(const Values: array of RawUTF8): RawUTF8; -var W: TTextWriter; - temp: TTextWriterStackBuffer; -begin - W := TTextWriter.CreateOwnedStream(temp); - try - W.Add('['); - W.AddCSVUTF8(Values); - W.Add(']'); - W.SetText(result); - finally - W.Free - end; -end; - -function JSONEncodeArrayInteger(const Values: array of integer): RawUTF8; -var W: TTextWriter; - temp: TTextWriterStackBuffer; -begin - W := TTextWriter.CreateOwnedStream(temp); - try - W.Add('['); - W.AddCSVInteger(Values); - W.Add(']'); - W.SetText(result); - finally - W.Free - end; -end; - -function JSONEncodeArrayOfConst(const Values: array of const; - WithoutBraces: boolean): RawUTF8; -begin - JSONEncodeArrayOfConst(Values,WithoutBraces,result); -end; - -procedure JSONEncodeArrayOfConst(const Values: array of const; - WithoutBraces: boolean; var result: RawUTF8); -var temp: TTextWriterStackBuffer; -begin - if length(Values)=0 then - if WithoutBraces then - result := '' else - result := '[]' else - with DefaultTextWriterSerializer.CreateOwnedStream(temp) do - try - if not WithoutBraces then - Add('['); - AddCSVConst(Values); - if not WithoutBraces then - Add(']'); - SetText(result); - finally - Free - end; -end; - -procedure JSONEncodeNameSQLValue(const Name,SQLValue: RawUTF8; - var result: RawUTF8); -var temp: TTextWriterStackBuffer; -begin - if (SQLValue<>'') and (SQLValue[1] in ['''','"']) then - // unescape SQL quoted string value into a valid JSON string - with TTextWriter.CreateOwnedStream(temp) do - try - Add('{','"'); - AddNoJSONEscapeUTF8(Name); - Add('"',':'); - AddQuotedStringAsJSON(SQLValue); - Add('}'); - SetText(result); - finally - Free; - end else - // Value is a number or null/true/false - result := '{"'+Name+'":'+SQLValue+'}'; -end; - -{ TValuePUTF8Char } - -procedure TValuePUTF8Char.ToUTF8(var Text: RawUTF8); -begin - FastSetString(Text,Value,ValueLen); -end; - -function TValuePUTF8Char.ToUTF8: RawUTF8; -begin - FastSetString(result,Value,ValueLen); -end; - -function TValuePUTF8Char.ToString: string; -begin - UTF8DecodeToString(Value,ValueLen,result); -end; - -function TValuePUTF8Char.ToInteger: PtrInt; -begin - result := GetInteger(Value); -end; - -function TValuePUTF8Char.ToCardinal: PtrUInt; -begin - result := GetCardinal(Value); -end; - -function TValuePUTF8Char.Idem(const Text: RawUTF8): boolean; -begin - if length(Text)=ValueLen then - result := IdemPropNameUSameLen(pointer(Text),Value,ValueLen) else - result := false; -end; - -procedure JSONDecode(var JSON: RawUTF8; const Names: array of RawUTF8; - Values: PValuePUTF8CharArray; HandleValuesAsObjectOrArray: Boolean); -begin - JSONDecode(UniqueRawUTF8(JSON),Names,Values,HandleValuesAsObjectOrArray); -end; - -procedure JSONDecode(var JSON: RawJSON; const Names: array of RawUTF8; - Values: PValuePUTF8CharArray; HandleValuesAsObjectOrArray: Boolean); -begin - JSONDecode(UniqueRawUTF8(RawUTF8(JSON)),Names,Values,HandleValuesAsObjectOrArray); -end; - -function JSONDecode(P: PUTF8Char; const Names: array of RawUTF8; - Values: PValuePUTF8CharArray; HandleValuesAsObjectOrArray: Boolean): PUTF8Char; -var n, i: PtrInt; - namelen, valuelen: integer; - name, value: PUTF8Char; - EndOfObject: AnsiChar; -begin - result := nil; - if Values=nil then - exit; // avoid GPF - n := length(Names); - FillCharFast(Values[0],n*SizeOf(Values[0]),0); - dec(n); - if P=nil then - exit; - while P^<>'{' do - if P^=#0 then - exit else - inc(P); - inc(P); // jump { - repeat - name := GetJSONPropName(P,@namelen); - if name=nil then - exit; // invalid JSON content - value := GetJSONFieldOrObjectOrArray(P,nil,@EndOfObject,HandleValuesAsObjectOrArray,true,@valuelen); - if not(EndOfObject in [',','}']) then - exit; // invalid item separator - for i := 0 to n do - if (Values[i].Value=nil) and IdemPropNameU(Names[i],name,namelen) then begin - Values[i].Value := value; - Values[i].ValueLen := valuelen; - break; - end; - until (P=nil) or (EndOfObject='}'); - if P=nil then // result=nil indicates failure -> points to #0 for end of text - result := @NULCHAR else - result := P; -end; - -function JSONDecode(var JSON: RawUTF8; const aName: RawUTF8; - wasString: PBoolean; HandleValuesAsObjectOrArray: Boolean): RawUTF8; -var P, Name, Value: PUTF8Char; - NameLen, ValueLen: integer; - EndOfObject: AnsiChar; -begin - result := ''; - P := pointer(JSON); - if P=nil then - exit; - while P^<>'{' do - if P^=#0 then - exit else - inc(P); - inc(P); // jump { - repeat - Name := GetJSONPropName(P,@NameLen); - if Name=nil then - exit; // invalid JSON content - Value := GetJSONFieldOrObjectOrArray( - P,wasString,@EndOfObject,HandleValuesAsObjectOrArray,true,@ValueLen); - if not(EndOfObject in [',','}']) then - exit; // invalid item separator - if IdemPropNameU(aName,Name,NameLen) then begin - FastSetString(result,Value,ValueLen); - exit; - end; - until (P=nil) or (EndOfObject='}'); -end; - -function JSONDecode(P: PUTF8Char; out Values: TNameValuePUTF8CharDynArray; - HandleValuesAsObjectOrArray: Boolean): PUTF8Char; -var n: PtrInt; - field: TNameValuePUTF8Char; - EndOfObject: AnsiChar; -begin - {$ifdef FPC} - Values := nil; - {$endif} - result := nil; - n := 0; - if P<>nil then begin - while P^<>'{' do - if P^=#0 then - exit else - inc(P); - inc(P); // jump { - repeat - field.Name := GetJSONPropName(P,@field.NameLen); - if field.Name=nil then - exit; // invalid JSON content - field.Value := GetJSONFieldOrObjectOrArray(P,nil,@EndOfObject, - HandleValuesAsObjectOrArray,true,@field.ValueLen); - if not(EndOfObject in [',','}']) then - exit; // invalid item separator - if n=length(Values) then - SetLength(Values,n+32); - Values[n] := field; - inc(n); - until (P=nil) or (EndOfObject='}'); - end; - SetLength(Values,n); - if P=nil then // result=nil indicates failure -> points to #0 for end of text - result := @NULCHAR else - result := P; -end; - -function JSONRetrieveStringField(P: PUTF8Char; out Field: PUTF8Char; - out FieldLen: integer; ExpectNameField: boolean): PUTF8Char; -begin - result := nil; - // retrieve string field - if P=nil then - exit; - while (P^<=' ') and (P^<>#0) do inc(P); - if P^<>'"' then exit; - Field := P+1; - P := GotoEndOfJSONString(P); - if P^<>'"' then - exit; // here P^ should be '"' - FieldLen := P-Field; - // check valid JSON delimiter - repeat inc(P) until (P^>' ') or (P^=#0); - if ExpectNameField then begin - if P^<>':' then - exit; // invalid name field - end else - if not (P^ in ['}',',']) then - exit; // invalid value field - result := P; // return either ':' for name field, either '}',',' for value -end; - -// decode a JSON field into an UTF-8 encoded buffer, stored inplace of input buffer -function GetJSONField(P: PUTF8Char; out PDest: PUTF8Char; - wasString: PBoolean; EndOfObject: PUTF8Char; Len: PInteger): PUTF8Char; -var D: PUTF8Char; - c4,surrogate,j: integer; - c: AnsiChar; - b: byte; - jsonset: PJsonCharSet; - {$ifdef CPUX86NOTPIC} tab: TNormTableByte absolute ConvertHexToBin; - {$else} tab: PNormTableByte; {$endif} -label slash,num,lit; -begin // see http://www.ietf.org/rfc/rfc4627.txt - if wasString<>nil then - wasString^ := false; // not a string by default - if Len<>nil then - Len^ := 0; // avoid buffer overflow on parsing error - PDest := nil; // PDest=nil indicates parsing error (e.g. unexpected #0 end) - result := nil; - if P=nil then exit; - if P^<=' ' then repeat inc(P); if P^=#0 then exit; until P^>' '; - case P^ of - '"': begin // " -> unescape P^ into D^ - if wasString<>nil then - wasString^ := true; - inc(P); - result := P; - D := P; - repeat - c := P^; - if c=#0 then exit else - if c='"' then break else - if c='\' then goto slash; - inc(P); - D^ := c; - inc(D); - continue; -slash:inc(P); // unescape JSON string - c := P^; - if (c='"') or (c='\') then begin -lit: inc(P); - D^ := c; // most common case - inc(D); - continue; - end else - if c=#0 then - exit else // to avoid potential buffer overflow issue on \#0 - if c='b' then - c := #8 else - if c='t' then - c := #9 else - if c='n' then - c := #10 else - if c='f' then - c := #12 else - if c='r' then - c := #13 else - if c='u' then begin - // inlined decoding of '\u0123' UTF-16 codepoint(s) into UTF-8 - {$ifndef CPUX86NOTPIC}tab := @ConvertHexToBin;{$endif} - c4 := tab[ord(P[1])]; - if c4<=15 then begin - b := tab[ord(P[2])]; - if b<=15 then begin - c4 := c4 shl 4; - c4 := c4 or b; - b := tab[ord(P[3])]; - if b<=15 then begin - c4 := c4 shl 4; - c4 := c4 or b; - b := tab[ord(P[4])]; - if b<=15 then begin - c4 := c4 shl 4; - c4 := c4 or b; - case c4 of - 0: begin - D^ := '?'; // \u0000 is an invalid value - inc(D); - end; - 1..$7f: begin - D^ := AnsiChar(c4); - inc(D); - end; - $80..$7ff: begin - D[0] := AnsiChar($C0 or (c4 shr 6)); - D[1] := AnsiChar($80 or (c4 and $3F)); - inc(D,2); - end; - UTF16_HISURROGATE_MIN..UTF16_LOSURROGATE_MAX: - if PWord(P+5)^=ord('\')+ord('u') shl 8 then begin - inc(P,6); // optimistic conversion (no check) - surrogate := (ConvertHexToBin[ord(P[1])] shl 12)+ - (ConvertHexToBin[ord(P[2])] shl 8)+ - (ConvertHexToBin[ord(P[3])] shl 4)+ - ConvertHexToBin[ord(P[4])]; - case c4 of // inlined UTF16CharToUtf8() - UTF16_HISURROGATE_MIN..UTF16_HISURROGATE_MAX: - c4 := ((c4-$D7C0)shl 10)+(surrogate xor UTF16_LOSURROGATE_MIN); - UTF16_LOSURROGATE_MIN..UTF16_LOSURROGATE_MAX: - c4 := ((surrogate-$D7C0)shl 10)+(c4 xor UTF16_LOSURROGATE_MIN); - end; - case c4 of - 0..$7ff: b := 2; - $800..$ffff: b := 3; - $10000..$1FFFFF: b := 4; - $200000..$3FFFFFF: b := 5; - else b := 6; - end; - for j := b-1 downto 1 do begin - D[j] := AnsiChar((c4 and $3f)+$80); - c4 := c4 shr 6; - end; - D^ := AnsiChar(Byte(c4) or UTF8_FIRSTBYTE[b]); - inc(D,b); - end else begin - D^ := '?'; // unexpected surrogate without its pair - inc(D); - end; - else begin - D[0] := AnsiChar($E0 or (c4 shr 12)); - D[1] := AnsiChar($80 or ((c4 shr 6) and $3F)); - D[2] := AnsiChar($80 or (c4 and $3F)); - inc(D,3); - end; - end; - inc(P,5); - continue; - end; - end; - end; - end; - c := '?'; // bad formated hexa number -> '?0123' - end; - goto lit; - until false; - // here P^='"' - D^ := #0; // make zero-terminated - if Len<>nil then - Len^ := D-result; - inc(P); - if P^=#0 then - exit; - end; - '0': - if P[1] in ['0'..'9'] then // 0123 excluded by JSON! - exit else // leave PDest=nil for unexpected end - goto num;// may be 0.123 - '-','1'..'9': begin // numerical field: all chars before end of field -num:result := P; - jsonset := @JSON_CHARS; - repeat - if not (jcDigitFloatChar in jsonset[P^]) then - break; - inc(P); - until false; - if P^=#0 then - exit; - if Len<>nil then - Len^ := P-result; - if P^<=' ' then begin - P^ := #0; // force numerical field with no trailing ' ' - inc(P); - end; - end; - 'n': - if (PInteger(P)^=NULL_LOW) and (jcEndOfJSONValueField in JSON_CHARS[P[4]]) then begin - result := nil; // null -> returns nil and wasString=false - if Len<>nil then - Len^ := 0; // when result is converted to string - inc(P,4); - end else - exit; - 'f': - if (PInteger(P+1)^=FALSE_LOW2) and (jcEndOfJSONValueField in JSON_CHARS[P[5]]) then begin - result := P; // false -> returns 'false' and wasString=false - if Len<>nil then - Len^ := 5; - inc(P,5); - end else - exit; - 't': - if (PInteger(P)^=TRUE_LOW) and (jcEndOfJSONValueField in JSON_CHARS[P[4]]) then begin - result := P; // true -> returns 'true' and wasString=false - if Len<>nil then - Len^ := 4; - inc(P,4); - end else - exit; - else - exit; // PDest=nil to indicate error - end; - jsonset := @JSON_CHARS; - while not (jcEndOfJSONField in jsonset[P^]) do begin - if P^=#0 then - exit; // leave PDest=nil for unexpected end - inc(P); - end; - if EndOfObject<>nil then - EndOfObject^ := P^; - P^ := #0; // make zero-terminated - PDest := @P[1]; - if P[1]=#0 then - PDest := nil; -end; - -function GetJSONPropName(var P: PUTF8Char; Len: PInteger): PUTF8Char; -var Name: PUTF8Char; - wasString: boolean; - c, EndOfObject: AnsiChar; - tab: PJsonCharSet; -begin // should match GotoNextJSONObjectOrArray() and JsonPropNameValid() - result := nil; - if P=nil then - exit; - while (P^<=' ') and (P^<>#0) do inc(P); - Name := P; // put here to please some versions of Delphi compiler - c := P^; - if c='"' then begin - Name := GetJSONField(P,P,@wasString,@EndOfObject,Len); - if (Name=nil) or not wasString or (EndOfObject<>':') then - exit; - end else - if c = '''' then begin // single quotes won't handle nested quote character - inc(P); - Name := P; - while P^<>'''' do - if P^<' ' then - exit else - inc(P); - if Len<>nil then - Len^ := P-Name; - P^ := #0; - repeat inc(P) until (P^>' ') or (P^=#0); - if P^<>':' then - exit; - inc(P); - end else begin // e.g. '{age:{$gt:18}}' - tab := @JSON_CHARS; - if not (jcJsonIdentifierFirstChar in tab[c]) then - exit; - repeat - inc(P); - until not (jcJsonIdentifier in tab[P^]); - if Len<>nil then - Len^ := P-Name; - if (P^<=' ') and (P^<>#0) then begin - P^ := #0; - inc(P); - end; - while (P^<=' ') and (P^<>#0) do inc(P); - if not (P^ in [':','=']) then // allow both age:18 and age=18 pairs - exit; - P^ := #0; - inc(P); - end; - result := Name; -end; - -procedure GetJSONPropName(var P: PUTF8Char; out PropName: shortstring); -var Name: PAnsiChar; - c: AnsiChar; - tab: PJsonCharSet; -begin // match GotoNextJSONObjectOrArray() and overloaded GetJSONPropName() - PropName[0] := #0; - if P=nil then - exit; - while (P^<=' ') and (P^<>#0) do inc(P); - Name := pointer(P); - c := P^; - if c='"' then begin - inc(Name); - P := GotoEndOfJSONString(P); - if P^<>'"' then - exit; - SetString(PropName,Name,P-Name); // note: won't unescape JSON strings - repeat inc(P) until (P^>' ') or (P^=#0); - if P^<>':' then begin - PropName[0] := #0; - exit; - end; - inc(P); - end else - if c='''' then begin // single quotes won't handle nested quote character - inc(P); - inc(Name); - while P^<>'''' do - if P^<' ' then - exit else - inc(P); - SetString(PropName,Name,P-Name); - repeat inc(P) until (P^>' ') or (P^=#0); - if P^<>':' then begin - PropName[0] := #0; - exit; - end; - inc(P); - end else begin // e.g. '{age:{$gt:18}}' - tab := @JSON_CHARS; - if not (jcJsonIdentifierFirstChar in tab[c]) then - exit; - repeat - inc(P); - until not (jcJsonIdentifier in tab[P^]); - SetString(PropName,Name,P-Name); - while (P^<=' ') and (P^<>#0) do inc(P); - if not (P^ in [':','=']) then begin // allow both age:18 and age=18 pairs - PropName[0] := #0; - exit; - end; - inc(P); - end; -end; - -function GotoNextJSONPropName(P: PUTF8Char): PUTF8Char; -var c: AnsiChar; - tab: PJsonCharSet; -label s; -begin // should match GotoNextJSONObjectOrArray() - while (P^<=' ') and (P^<>#0) do inc(P); - result := nil; - if P=nil then - exit; - c := P^; - if c='"' then begin - P := GotoEndOfJSONString(P); - if P^<>'"' then - exit; -s: repeat inc(P) until (P^>' ') or (P^=#0); - if P^<>':' then - exit; - end else - if c='''' then begin // single quotes won't handle nested quote character - inc(P); - while P^<>'''' do - if P^<' ' then - exit else - inc(P); - goto s; - end else begin // e.g. '{age:{$gt:18}}' - tab := @JSON_CHARS; - if not (jcJsonIdentifierFirstChar in tab[c]) then - exit; - repeat - inc(P); - until not (jcJsonIdentifier in tab[P^]); - if (P^<=' ') and (P^<>#0) then - inc(P); - while (P^<=' ') and (P^<>#0) do inc(P); - if not (P^ in [':','=']) then // allow both age:18 and age=18 pairs - exit; - end; - repeat inc(P) until (P^>' ') or (P^=#0); - result := P; -end; - -function GetJSONFieldOrObjectOrArray(var P: PUTF8Char; wasString: PBoolean; - EndOfObject: PUTF8Char; HandleValuesAsObjectOrArray: Boolean; - NormalizeBoolean: Boolean; Len: PInteger): PUTF8Char; -var Value: PUTF8Char; - wStr: boolean; -begin - result := nil; - if P=nil then - exit; - while ord(P^) in [1..32] do inc(P); - if HandleValuesAsObjectOrArray and (P^ in ['{','[']) then begin - Value := P; - P := GotoNextJSONObjectOrArray(P); - if P=nil then - exit; // invalid content - if Len<>nil then - Len^ := P-Value; - if wasString<>nil then - wasString^ := false; // was object or array - while ord(P^) in [1..32] do inc(P); - if EndOfObject<>nil then - EndOfObject^ := P^; - P^ := #0; // make zero-terminated - if P[1]=#0 then - P := nil else - inc(P); - result := Value; - end else begin - result := GetJSONField(P,P,@wStr,EndOfObject,Len); - if wasString<>nil then - wasString^ := wStr; - if not wStr and NormalizeBoolean and (result<>nil) then begin - if PInteger(result)^=TRUE_LOW then - result := pointer(SmallUInt32UTF8[1]) else // normalize true -> 1 - if PInteger(result)^=FALSE_LOW then - result := pointer(SmallUInt32UTF8[0]) else // normalize false -> 0 - exit; - if Len<>nil then - Len^ := 1; - end; - end; -end; - -function IsString(P: PUTF8Char): boolean; // test if P^ is a "string" value -begin - if P=nil then begin - result := false; - exit; - end; - while (P^<=' ') and (P^<>#0) do inc(P); - if (P[0] in ['0'..'9']) or // is first char numeric? - ((P[0] in ['-','+']) and (P[1] in ['0'..'9'])) then begin - // check if P^ is a true numerical value - repeat inc(P) until not (P^ in ['0'..'9']); // check digits - if P^='.' then - repeat inc(P) until not (P^ in ['0'..'9']); // check fractional digits - if ((P^='e') or (P^='E')) and (P[1] in ['0'..'9','+','-']) then begin - inc(P); - if P^='+' then inc(P) else - if P^='-' then inc(P); - while (P^>='0') and (P^<='9') do inc(P); - end; - while (P^<=' ') and (P^<>#0) do inc(P); - result := (P^<>#0); - exit; - end else - result := true; // don't begin with a numerical value -> must be a string -end; - -function IsStringJSON(P: PUTF8Char): boolean; // test if P^ is a "string" value -var c4: integer; - c: AnsiChar; - tab: PJsonCharSet; -begin - if P=nil then begin - result := false; - exit; - end; - while (P^<=' ') and (P^<>#0) do inc(P); - tab := @JSON_CHARS; - c4 := PInteger(P)^; - if (((c4=NULL_LOW)or(c4=TRUE_LOW)) and (jcEndOfJSONValueField in tab[P[4]])) or - ((c4=FALSE_LOW) and (P[4]='e') and (jcEndOfJSONValueField in tab[P[5]])) then begin - result := false; // constants are no string - exit; - end; - c := P^; - if (jcDigitFirstChar in tab[c]) and - (((c>='1') and (c<='9')) or // is first char numeric? - ((c='0') and ((P[1]<'0') or (P[1]>'9'))) or // '012' excluded by JSON - ((c='-') and (P[1]>='0') and (P[1]<='9'))) then begin - // check if c is a true numerical value - repeat inc(P) until (P^<'0') or (P^>'9'); // check digits - if P^='.' then - repeat inc(P) until (P^<'0') or (P^>'9'); // check fractional digits - if ((P^='e') or (P^='E')) and (jcDigitChar in tab[P[1]]) then begin - inc(P); - c := P^; - if c='+' then inc(P) else - if c='-' then inc(P); - while (P^>='0') and (P^<='9') do inc(P); - end; - while (P^<=' ') and (P^<>#0) do inc(P); - result := (P^<>#0); - exit; - end else - result := true; // don't begin with a numerical value -> must be a string -end; - -function IsValidJSON(const s: RawUTF8): boolean; -begin - result := IsValidJSON(pointer(s),length(s)); -end; - -function IsValidJSON(P: PUTF8Char; len: PtrInt): boolean; -var B: PUTF8Char; -begin - result := false; - if (P=nil) or (len<=0) or (StrLen(P)<>len) then - exit; - B := P; - P := GotoEndJSONItem(B,{strict=}true); - result := (P<>nil) and (P-B=len); -end; - -procedure GetJSONItemAsRawJSON(var P: PUTF8Char; var result: RawJSON; - EndOfObject: PAnsiChar); -var B: PUTF8Char; -begin - result := ''; - if P=nil then - exit; - B := GotoNextNotSpace(P); - P := GotoEndJSONItem(B); - if P=nil then - exit; - FastSetString(RawUTF8(result),B,P-B); - while (P^<=' ') and (P^<>#0) do inc(P); - if EndOfObject<>nil then - EndOfObject^ := P^; - if P^<>#0 then //if P^=',' then - repeat inc(P) until (P^>' ') or (P^=#0); -end; - -function GetJSONItemAsRawUTF8(var P: PUTF8Char; var output: RawUTF8; - wasString: PBoolean; EndOfObject: PUTF8Char): boolean; -var V: PUTF8Char; - VLen: integer; -begin - V := GetJSONFieldOrObjectOrArray(P,wasstring,EndOfObject,true,true,@VLen); - if V=nil then // parsing error - result := false else begin - FastSetString(output,V,VLen); - result := true; - end; -end; - -function GotoNextJSONObjectOrArrayInternal(P,PMax: PUTF8Char; EndChar: AnsiChar): PUTF8Char; -var tab: PJsonCharSet; -label Prop; -begin // should match GetJSONPropName() - result := nil; - repeat - case P^ of - '{','[': begin - if PMax=nil then - P := GotoNextJSONObjectOrArray(P) else - P := GotoNextJSONObjectOrArrayMax(P,PMax); - if P=nil then exit; - end; - ':': if EndChar<>'}' then exit else inc(P); // syntax for JSON object only - ',': inc(P); // comma appears in both JSON objects and arrays - '}': if EndChar='}' then break else exit; - ']': if EndChar=']' then break else exit; - '"': begin - P := GotoEndOfJSONString(P); - if P^<>'"' then - exit; - inc(P); - end; - '-','+','0'..'9': begin // '0123' excluded by JSON, but not here - tab := @JSON_CHARS; - repeat - inc(P); - until not (jcDigitFloatChar in tab[P^]); - end; - 't': if PInteger(P)^=TRUE_LOW then inc(P,4) else goto Prop; - 'f': if PInteger(P+1)^=FALSE_LOW2 then inc(P,5) else goto Prop; - 'n': if PInteger(P)^=NULL_LOW then inc(P,4) else goto Prop; - '''': begin // single-quoted identifier - repeat inc(P); if P^<=' ' then exit; until P^=''''; - repeat inc(P) until (P^>' ') or (P^=#0); - if P^<>':' then exit; - end; - '/': begin - repeat // allow extended /regex/ syntax - inc(P); - if P^=#0 then - exit; - until P^='/'; - repeat inc(P) until (P^>' ') or (P^=#0); - end; - else begin -Prop: tab := @JSON_CHARS; - if not (jcJsonIdentifierFirstChar in tab[P^]) then - exit; - repeat - inc(P); - until not (jcJsonIdentifier in tab[P^]); - while (P^<=' ') and (P^<>#0) do inc(P); - if P^='(' then begin // handle e.g. "born":isodate("1969-12-31") - inc(P); - while (P^<=' ') and (P^<>#0) do inc(P); - if P^='"' then begin - P := GotoEndOfJSONString(P); - if P^<>'"' then - exit; - end; - inc(P); - while (P^<=' ') and (P^<>#0) do inc(P); - if P^<>')' then - exit; - inc(P); - end - else - if P^<>':' then exit; - end; - end; - while (P^<=' ') and (P^<>#0) do inc(P); - if (PMax<>nil) and (P>=PMax) then - exit; - until P^=EndChar; - result := P+1; -end; - -function GotoEndJSONItem(P: PUTF8Char; strict: boolean): PUTF8Char; -var tab: PJsonCharSet; -label pok,ok; -begin - result := nil; // to notify unexpected end - if P=nil then - exit; - while (P^<=' ') and (P^<>#0) do inc(P); - case P^ of - #0: exit; - '"': begin - P := GotoEndOfJSONString(P); - if P^<>'"' then - exit; - inc(P); - goto ok; - end; - '[': begin - repeat inc(P) until (P^>' ') or (P^=#0); - P := GotoNextJSONObjectOrArrayInternal(P,nil,']'); - goto pok; - end; - '{': begin - repeat inc(P) until (P^>' ') or (P^=#0); - P := GotoNextJSONObjectOrArrayInternal(P,nil,'}'); -pok:if P=nil then - exit; -ok: while (P^<=' ') and (P^<>#0) do inc(P); - result := P; - exit; - end; - end; - if strict then - case P^ of - 't': if PInteger(P)^=TRUE_LOW then begin inc(P,4); goto ok; end; - 'f': if PInteger(P+1)^=FALSE_LOW2 then begin inc(P,5); goto ok; end; - 'n': if PInteger(P)^=NULL_LOW then begin inc(P,4); goto ok; end; - '-','+','0'..'9': begin - tab := @JSON_CHARS; - repeat inc(P) until not (jcDigitFloatChar in tab[P^]); - goto ok; - end; - end else begin // not strict - tab := @JSON_CHARS; - repeat // numeric or true/false/null or MongoDB extended {age:{$gt:18}} - inc(P); - until jcEndOfJSONFieldOr0 in tab[P^]; - if P^=#0 then exit; // unexpected end - end; - if P^=#0 then - exit; - result := P; -end; - -function GotoNextJSONItem(P: PUTF8Char; NumberOfItemsToJump: cardinal; - EndOfObject: PAnsiChar): PUTF8Char; -var tab: PJsonCharSet; -label pok,n; -begin - result := nil; // to notify unexpected end - while NumberOfItemsToJump>0 do begin - while (P^<=' ') and (P^<>#0) do inc(P); - // get a field - case P^ of - #0: exit; - '"': begin - P := GotoEndOfJSONString(P); - if P^<>'"' then - exit; // P^ should be '"' here - end; - '[': begin - repeat inc(P) until (P^>' ') or (P^=#0); - P := GotoNextJSONObjectOrArrayInternal(P,nil,']'); - goto pok; - end; - '{': begin - repeat inc(P) until (P^>' ') or (P^=#0); - P := GotoNextJSONObjectOrArrayInternal(P,nil,'}'); -pok: if P=nil then - exit; - while (P^<=' ') and (P^<>#0) do inc(P); - goto n; - end; - end; - tab := @JSON_CHARS; - repeat // numeric or true/false/null or MongoDB extended {age:{$gt:18}} - inc(P); - until jcEndOfJSONFieldOr0 in tab[P^]; -n: if P^=#0 then - exit; - if EndOfObject<>nil then - EndOfObject^ := P^; - inc(P); - dec(NumberOfItemsToJump); - end; - result := P; -end; - -function GotoNextJSONObjectOrArray(P: PUTF8Char): PUTF8Char; -var EndChar: AnsiChar; -begin // should match GetJSONPropName() - result := nil; // mark error or unexpected end (#0) - while (P^<=' ') and (P^<>#0) do inc(P); - case P^ of - '[': EndChar := ']'; - '{': EndChar := '}'; - else exit; - end; - repeat inc(P) until (P^>' ') or (P^=#0); - result := GotoNextJSONObjectOrArrayInternal(P,nil,EndChar); -end; - -function GotoNextJSONObjectOrArray(P: PUTF8Char; EndChar: AnsiChar): PUTF8Char; -begin // should match GetJSONPropName() - while (P^<=' ') and (P^<>#0) do inc(P); - result := GotoNextJSONObjectOrArrayInternal(P,nil,EndChar); -end; - -function GotoNextJSONObjectOrArrayMax(P,PMax: PUTF8Char): PUTF8Char; -var EndChar: AnsiChar; -begin // should match GetJSONPropName() - result := nil; // mark error or unexpected end (#0) - while (P^<=' ') and (P^<>#0) do inc(P); - case P^ of - '[': EndChar := ']'; - '{': EndChar := '}'; - else exit; - end; - repeat inc(P) until (P^>' ') or (P^=#0); - result := GotoNextJSONObjectOrArrayInternal(P,PMax,EndChar); -end; - -function JSONArrayCount(P: PUTF8Char): integer; -var n: integer; -begin - result := -1; - n := 0; - P := GotoNextNotSpace(P); - if P^<>']' then - repeat - case P^ of - '"': begin - P := GotoEndOfJSONString(P); - if P^<>'"' then - exit; - inc(P); - end; - '{','[': begin - P := GotoNextJSONObjectOrArray(P); - if P=nil then - exit; // invalid content - end; - end; - while not (P^ in [#0,',',']']) do inc(P); - inc(n); - if P^<>',' then break; - repeat inc(P) until (P^>' ') or (P^=#0); - until false; - if P^=']' then - result := n; -end; - -function JSONArrayDecode(P: PUTF8Char; out Values: TPUTF8CharDynArray): boolean; -var n,max: integer; -begin - result := false; - max := 0; - n := 0; - P := GotoNextNotSpace(P); - if P^<>']' then - repeat - if max=n then begin - max := NextGrow(max); - SetLength(Values,max); - end; - Values[n] := P; - case P^ of - '"': begin - P := GotoEndOfJSONString(P); - if P^<>'"' then - exit; - inc(P); - end; - '{','[': begin - P := GotoNextJSONObjectOrArray(P); - if P=nil then - exit; // invalid content - end; - end; - while not (P^ in [#0,',',']']) do inc(P); - inc(n); - if P^<>',' then break; - repeat inc(P) until (P^>' ') or (P^=#0); - until false; - if P^=']' then begin - SetLength(Values,n); - result := true; - end else - Values := nil; -end; - -function JSONArrayItem(P: PUTF8Char; Index: integer): PUTF8Char; -begin - if P<>nil then begin - P := GotoNextNotSpace(P); - if P^='[' then begin - P := GotoNextNotSpace(P+1); - if P^<>']' then - repeat - if Index<=0 then begin - result := P; - exit; - end; - case P^ of - '"': begin - P := GotoEndOfJSONString(P); - if P^<>'"' then - break; // invalid content - inc(P); - end; - '{','[': begin - P := GotoNextJSONObjectOrArray(P); - if P=nil then - break; // invalid content - end; - end; - while not (P^ in [#0,',',']']) do inc(P); - if P^<>',' then break; - repeat inc(P) until (P^>' ') or (P^=#0); - dec(Index); - until false; - end; - end; - result := nil; -end; - -function JSONArrayCount(P,PMax: PUTF8Char): integer; -var n: integer; -begin - result := -1; - n := 0; - P := GotoNextNotSpace(P); - if P^<>']' then - while P'"' then - exit; - inc(P); - end; - '{','[': begin - P := GotoNextJSONObjectOrArrayMax(P,PMax); - if P=nil then - exit; // invalid content or PMax reached - end; - end; - while not (P^ in [#0,',',']']) do inc(P); - inc(n); - if P^<>',' then break; - repeat inc(P) until (P^>' ') or (P^=#0); - end; - if P^=']' then - result := n; -end; - -function JSONObjectPropCount(P: PUTF8Char): integer; -var n: integer; -begin - result := -1; - n := 0; - P := GotoNextNotSpace(P); - if P^<>'}' then - repeat - P := GotoNextJSONPropName(P); - if P=nil then - exit; - case P^ of - '"': begin - P := GotoEndOfJSONString(P); - if P^<>'"' then - exit; - inc(P); - end; - '{','[': begin - P := GotoNextJSONObjectOrArray(P); - if P=nil then - exit; // invalid content - end; - end; - while not (P^ in [#0,',','}']) do inc(P); - inc(n); - if P^<>',' then break; - repeat inc(P) until (P^>' ') or (P^=#0); - until false; - if P^='}' then - result := n; -end; - -function JsonObjectItem(P: PUTF8Char; const PropName: RawUTF8; - PropNameFound: PRawUTF8): PUTF8Char; -var name: shortstring; // no memory allocation nor P^ modification - PropNameLen: integer; - PropNameUpper: array[byte] of AnsiChar; -begin - if P<>nil then begin - P := GotoNextNotSpace(P); - PropNameLen := length(PropName); - if PropNameLen<>0 then begin - if PropName[PropNameLen]='*' then begin - UpperCopy255Buf(PropNameUpper,pointer(PropName),PropNameLen-1)^ := #0; - PropNameLen := 0; - end; - if P^='{' then - P := GotoNextNotSpace(P+1); - if P^<>'}' then - repeat - GetJSONPropName(P,name); - if (name[0]=#0) or (name[0]>#200) then - break; - while (P^<=' ') and (P^<>#0) do inc(P); - if PropNameLen=0 then begin - name[ord(name[0])+1] := #0; // make ASCIIZ - if IdemPChar(@name[1],PropNameUpper) then begin - if PropNameFound<>nil then - FastSetString(PropNameFound^,@name[1],ord(name[0])); - result := P; - exit; - end; - end else - if IdemPropName(name,pointer(PropName),PropNameLen) then begin - result := P; - exit; - end; - case P^ of - '"': begin - P := GotoEndOfJSONString(P); - if P^<>'"' then - break; // invalid content - inc(P); - end; - '{','[': begin - P := GotoNextJSONObjectOrArray(P); - if P=nil then - break; // invalid content - end; - end; - while not (P^ in [#0,',','}']) do inc(P); - if P^<>',' then break; - repeat inc(P) until (P^>' ') or (P^=#0); - until false; - end; - end; - result := nil; -end; - -function JsonObjectByPath(JsonObject,PropPath: PUTF8Char): PUTF8Char; -var objName: RawUTF8; -begin - result := nil; - if (JsonObject=nil) or (PropPath=nil) then - exit; - repeat - GetNextItem(PropPath,'.',objName); - if objName='' then - exit; - JsonObject := JsonObjectItem(JsonObject,objName); - if JsonObject=nil then - exit; - until PropPath=nil; // found full name scope - result := JsonObject; -end; - -function JsonObjectsByPath(JsonObject,PropPath: PUTF8Char): RawUTF8; -var itemName,objName,propNameFound,objPath: RawUTF8; - start,ending,obj: PUTF8Char; - WR: TTextWriter; - temp: TTextWriterStackBuffer; - procedure AddFromStart(const name: RaWUTF8); - begin - start := GotoNextNotSpace(start); - ending := GotoEndJSONItem(start); - if ending=nil then - exit; - if WR=nil then begin - WR := TTextWriter.CreateOwnedStream(temp); - WR.Add('{'); - end else - WR.Add(','); - WR.AddFieldName(name); - while (ending>start) and (ending[-1]<=' ') do dec(ending); // trim right - WR.AddNoJSONEscape(start,ending-start); - end; -begin - result := ''; - if (JsonObject=nil) or (PropPath=nil) then - exit; - WR := nil; - try - repeat - GetNextItem(PropPath,',',itemName); - if itemName='' then - break; - if itemName[length(itemName)]<>'*' then begin - start := JsonObjectByPath(JsonObject,pointer(itemName)); - if start<>nil then - AddFromStart(itemName); - end else begin - objPath := ''; - obj := pointer(itemName); - repeat - GetNextItem(obj,'.',objName); - if objName='' then - exit; - propNameFound := ''; - JsonObject := JsonObjectItem(JsonObject,objName,@propNameFound); - if JsonObject=nil then - exit; - if obj=nil then begin // found full name scope - start := JsonObject; - repeat - AddFromStart(objPath+propNameFound); - ending := GotoNextNotSpace(ending); - if ending^<>',' then - break; - propNameFound := ''; - start := JsonObjectItem(GotoNextNotSpace(ending+1),objName,@propNameFound); - until start=nil; - break; - end else - objPath := objPath+objName+'.'; - until false; - end; - until PropPath=nil; - if WR<>nil then begin - WR.Add('}'); - WR.SetText(result); - end; - finally - WR.Free; - end; -end; - -function JSONObjectAsJSONArrays(JSON: PUTF8Char; out keys,values: RawUTF8): boolean; -var wk,wv: TTextWriter; - kb,ke,vb,ve: PUTF8Char; - temp1,temp2: TTextWriterStackBuffer; -begin - result := false; - if (JSON=nil) or (JSON^<>'{') then - exit; - wk := TTextWriter.CreateOwnedStream(temp1); - wv := TTextWriter.CreateOwnedStream(temp2); - try - wk.Add('['); - wv.Add('['); - kb := JSON+1; - repeat - ke := GotoEndJSONItem(kb); - if (ke=nil) or (ke^<>':') then - exit; // invalid input content - vb := ke+1; - ve := GotoEndJSONItem(vb); - if (ve=nil) or not(ve^ in [',','}']) then - exit; - wk.AddNoJSONEscape(kb,ke-kb); - wk.Add(','); - wv.AddNoJSONEscape(vb,ve-vb); - wv.Add(','); - kb := ve+1; - until ve^='}'; - wk.CancelLastComma; - wk.Add(']'); - wk.SetText(keys); - wv.CancelLastComma; - wv.Add(']'); - wv.SetText(values); - result := true; - finally - wv.Free; - wk.Free; - end; -end; - -function TryRemoveComment(P: PUTF8Char): PUTF8Char; {$ifdef HASINLINE}inline;{$endif} -begin - result := P + 1; - case result^ of - '/': begin // this is // comment - replace by ' ' - dec(result); - repeat - result^ := ' '; - inc(result) - until result^ in [#0, #10, #13]; - if result^<>#0 then inc(result); - end; - '*': begin // this is /* comment - replace by ' ' but keep CRLF - result[-1] := ' '; - repeat - if not(result^ in [#10, #13]) then - result^ := ' '; // keep CRLF for correct line numbering (e.g. for error) - inc(result); - if PWord(result)^=ord('*')+ord('/')shl 8 then begin - PWord(result)^ := $2020; - inc(result,2); - break; - end; - until result^=#0; - end; - end; -end; - -procedure RemoveCommentsFromJSON(P: PUTF8Char); -var PComma: PUTF8Char; -begin // replace comments by ' ' characters which will be ignored by parser - if P<>nil then - while P^<>#0 do begin - case P^ of - '"': begin - P := GotoEndOfJSONString(P); - if P^<>'"' then - exit else - Inc(P); - end; - '/': P := TryRemoveComment(P); - ',': begin // replace trailing comma by space for strict JSON parsers - PComma := P; - repeat inc(P) until (P^>' ') or (P^=#0); - if P^='/' then - P := TryRemoveComment(P); - while (P^<=' ') and (P^<>#0) do inc(P); - if P^ in ['}', ']'] then - PComma^ := ' '; // see https://github.com/synopse/mORMot/pull/349 - end; - else - inc(P); - end; - end; -end; - -procedure JSONBufferToXML(P: PUTF8Char; const Header,NameSpace: RawUTF8; - out result: RawUTF8); -var i,j,L: integer; - temp: TTextWriterStackBuffer; -begin - if P=nil then - result := Header else - with TTextWriter.CreateOwnedStream(temp) do - try - AddNoJSONEscape(pointer(Header),length(Header)); - L := length(NameSpace); - if L<>0 then - AddNoJSONEscape(pointer(NameSpace),L); - AddJSONToXML(P); - if L<>0 then - for i := 1 to L do - if NameSpace[i]='<' then begin - for j := i+1 to L do - if NameSpace[j] in [' ','>'] then begin - Add('<','/'); - AddStringCopy(NameSpace,i+1,j-i-1); - Add('>'); - break; - end; - break; - end; - SetText(result); - finally - Free; - end; -end; - -function JSONToXML(const JSON: RawUTF8; const Header: RawUTF8; - const NameSpace: RawUTF8): RawUTF8; -var tmp: TSynTempBuffer; -begin - tmp.Init(JSON); - try - JSONBufferToXML(tmp.buf,Header,NameSpace,result); - finally - tmp.Done; - end; -end; - -procedure JSONBufferReformat(P: PUTF8Char; out result: RawUTF8; - Format: TTextWriterJSONFormat); -var temp: array[word] of byte; // 64KB buffer -begin - if P<>nil then - with TTextWriter.CreateOwnedStream(@temp,SizeOf(temp)) do - try - AddJSONReformat(P,Format,nil); - SetText(result); - finally - Free; - end; -end; - -function JSONReformat(const JSON: RawUTF8; Format: TTextWriterJSONFormat): RawUTF8; -var tmp: TSynTempBuffer; -begin - tmp.Init(JSON); - try - JSONBufferReformat(tmp.buf,result,Format); - finally - tmp.Done; - end; -end; - -function JSONBufferReformatToFile(P: PUTF8Char; const Dest: TFileName; - Format: TTextWriterJSONFormat): boolean; -var F: TFileStream; - temp: array[word] of word; // 128KB -begin - try - F := TFileStream.Create(Dest,fmCreate); - try - with TTextWriter.Create(F,@temp,SizeOf(temp)) do - try - AddJSONReformat(P,Format,nil); - FlushFinal; - finally - Free; - end; - result := true; - finally - F.Free; - end; - except - on Exception do - result := false; - end; -end; - -function JSONReformatToFile(const JSON: RawUTF8; const Dest: TFileName; - Format: TTextWriterJSONFormat=jsonHumanReadable): boolean; -var tmp: TSynTempBuffer; -begin - tmp.Init(JSON); - try - result := JSONBufferReformatToFile(tmp.buf,Dest,Format); - finally - tmp.Done; - end; -end; - - -procedure KB(bytes: Int64; out result: TShort16; nospace: boolean); -type TUnits = (kb,mb,gb,tb,pb,eb,b); -const TXT: array[boolean,TUnits] of RawUTF8 = - ((' KB',' MB',' GB',' TB',' PB',' EB','% B'), ('KB','MB','GB','TB','PB','EB','%B')); -var hi,rem: cardinal; - u: TUnits; -begin - if bytes<1 shl 10-(1 shl 10) div 10 then begin - FormatShort16(TXT[nospace,b],[integer(bytes)],result); - exit; - end; - if bytes<1 shl 20-(1 shl 20) div 10 then begin - u := kb; - rem := bytes; - hi := bytes shr 10; - end else - if bytes<1 shl 30-(1 shl 30) div 10 then begin - u := mb; - rem := bytes shr 10; - hi := bytes shr 20; - end else - if bytes0 then - rem := rem div 102; - if rem=10 then begin - rem := 0; - inc(hi); // round up as expected by (most) human beings - end; - if rem<>0 then - FormatShort16('%.%%',[hi,rem,TXT[nospace,u]],result) else - FormatShort16('%%',[hi,TXT[nospace,u]],result); -end; - -function KB(bytes: Int64): TShort16; -begin - KB(bytes,result,{nospace=}false); -end; - -function KBNoSpace(bytes: Int64): TShort16; -begin - KB(bytes,result,{nospace=}true); -end; - -function KB(bytes: Int64; nospace: boolean): TShort16; -begin - KB(bytes,result,nospace); -end; - -function KB(const buffer: RawByteString): TShort16; -begin - KB(length(buffer),result,{nospace=}false); -end; - -procedure KBU(bytes: Int64; var result: RawUTF8); -var tmp: TShort16; -begin - KB(bytes,tmp,{nospace=}false); - FastSetString(result,@tmp[1],ord(tmp[0])); -end; - -function IntToThousandString(Value: integer; const ThousandSep: TShort4): shortstring; -var i,L,Len: cardinal; -begin - str(Value,result); - L := length(result); - Len := L+1; - if Value<0 then - dec(L,2) else // ignore '-' sign - dec(L); - for i := 1 to L div 3 do - insert(ThousandSep,result,Len-i*3); -end; - -function MicroSecToString(Micro: QWord): TShort16; -begin - MicroSecToString(Micro,result); -end; - -procedure MicroSecToString(Micro: QWord; out result: TShort16); - procedure TwoDigitToString(value: cardinal; const u: shortstring; var result: TShort16); - var d100: TDiv100Rec; - begin - if value<100 then - FormatShort16('0.%%',[UInt2DigitsToShortFast(value),u],result) else begin - Div100(value,d100); - if d100.m=0 then - FormatShort16('%%',[d100.d,u],result) else - FormatShort16('%.%%',[d100.d,UInt2DigitsToShortFast(d100.m),u],result); - end; - end; - procedure TimeToString(value: cardinal; const u: shortstring; var result: TShort16); - var d: cardinal; - begin - d := value div 60; - FormatShort16('%%%',[d,u,UInt2DigitsToShortFast(value-(d*60))],result); - end; -begin - if Int64(Micro)<=0 then - result := '0us' else - if Micro<1000 then - FormatShort16('%us',[Micro],result) else - if Micro<1000000 then - TwoDigitToString({$ifdef CPU32}PCardinal(@Micro)^{$else}Micro{$endif} div 10,'ms',result) else - if Micro<60000000 then - TwoDigitToString({$ifdef CPU32}PCardinal(@Micro)^{$else}Micro{$endif} div 10000,'s',result) else - if Micro0) or (fTime<>0); -end; - -procedure TPrecisionTimer.Resume; -begin - if fStart=0 then - {$ifdef LINUX}QueryPerformanceMicroSeconds{$else}QueryPerformanceCounter{$endif}(fStart); -end; - -procedure TPrecisionTimer.Pause; -begin - if fStart=0 then - exit; - {$ifdef LINUX}QueryPerformanceMicroSeconds{$else}QueryPerformanceCounter{$endif}(fStop); - FromExternalQueryPerformanceCounters(fStop-fStart); - inc(fPauseCount); -end; - -procedure TPrecisionTimer.FromExternalMicroSeconds(const MicroSeconds: QWord); -begin - fLastTime := MicroSeconds; - inc(fTime,MicroSeconds); - fStart := 0; // indicates time has been computed -end; - -function TPrecisionTimer.FromExternalQueryPerformanceCounters(const CounterDiff: QWord): QWord; -begin // mimics Pause from already known elapsed time - {$ifdef LINUX} - FromExternalMicroSeconds(CounterDiff); - {$else} - if fWinFreq=0 then - QueryPerformanceFrequency(fWinFreq); - if fWinFreq<>0 then - FromExternalMicroSeconds((CounterDiff*1000000)div PQWord(@fWinFreq)^); - {$endif LINUX} - result := fLastTime; -end; - -function TPrecisionTimer.Stop: TShort16; -begin - if fStart<>0 then - Pause; - MicroSecToString(fTime,result); -end; - -function TPrecisionTimer.StopInMicroSec: TSynMonitorTotalMicroSec; -begin - if fStart<>0 then - Pause; - result := fTime; -end; - -function TPrecisionTimer.Time: TShort16; -begin - if fStart<>0 then - Pause; - MicroSecToString(fTime,result); -end; - -function TPrecisionTimer.LastTime: TShort16; -begin - if fStart<>0 then - Pause; - MicroSecToString(fLastTime,result); -end; - -function TPrecisionTimer.ByCount(Count: QWord): TShort16; -begin - if Count=0 then // avoid div per 0 exception - result := '0' else begin - if fStart<>0 then - Pause; - MicroSecToString(fTime div Count,result); - end; -end; - -function TPrecisionTimer.PerSec(const Count: QWord): QWord; -begin - if fStart<>0 then - Pause; - if fTime<=0 then // avoid negative value in case of incorrect Start/Stop sequence - result := 0 else // avoid div per 0 exception - result := (Count*1000000) div fTime; -end; - -function TPrecisionTimer.SizePerSec(Size: QWord): shortstring; -begin - FormatShort('% in % i.e. %/s',[KB(Size),Stop,KB(PerSec(Size))],result); -end; - - -type - /// a class used internaly by TPrecisionTimer.ProfileMethod - TPrecisionTimerProfiler = class(TInterfacedObject) - protected - fTimer: PPrecisionTimer; - public - constructor Create(aTimer: PPrecisionTimer); - destructor Destroy; override; - end; - -constructor TPrecisionTimerProfiler.Create(aTimer: PPrecisionTimer); -begin - fTimer := aTimer; -end; - -destructor TPrecisionTimerProfiler.Destroy; -begin - if fTimer<>nil then - fTimer^.Pause; - inherited; -end; - - -function TPrecisionTimer.ProfileCurrentMethod: IUnknown; -begin - Resume; - result := TPrecisionTimerProfiler.Create(@self); -end; - - -{ TLocalPrecisionTimer } - -function TLocalPrecisionTimer.ByCount(Count: cardinal): RawUTF8; -begin - result := fTimer.ByCount(Count); -end; - -procedure TLocalPrecisionTimer.Pause; -begin - fTimer.Pause; -end; - -function TLocalPrecisionTimer.PerSec(Count: cardinal): cardinal; -begin - result := fTimer.PerSec(Count); -end; - -procedure TLocalPrecisionTimer.Resume; -begin - fTimer.Resume; -end; - -procedure TLocalPrecisionTimer.Start; -begin - fTimer.Start; -end; - -function TLocalPrecisionTimer.Stop: TShort16; -begin - result := fTimer.Stop; -end; - -constructor TLocalPrecisionTimer.CreateAndStart; -begin - inherited; - fTimer.Start; -end; - -{ TSynMonitorTime } - -function TSynMonitorTime.GetAsText: TShort16; -begin - MicroSecToString(fMicroSeconds,result); -end; - -function TSynMonitorTime.PerSecond(const Count: QWord): QWord; -begin - if {$ifdef FPC}Int64(fMicroSeconds){$else}PInt64(@fMicroSeconds)^{$endif}<=0 then - result := 0 else // avoid negative or div per 0 - result := (Count*1000000) div fMicroSeconds; -end; - - -{ TSynMonitorOneTime } - -function TSynMonitorOneTime.GetAsText: TShort16; -begin - MicroSecToString(fMicroSeconds,result); -end; - -function TSynMonitorOneTime.PerSecond(const Count: QWord): QWord; -begin - if {$ifdef FPC}Int64(fMicroSeconds){$else}PInt64(@fMicroSeconds)^{$endif}<=0 then - result := 0 else - result := (Count*QWord(1000000)) div fMicroSeconds; -end; - - -{ TSynMonitorSizeParent } - -constructor TSynMonitorSizeParent.Create(aTextNoSpace: boolean); -begin - inherited Create; - fTextNoSpace := aTextNoSpace; -end; - -{ TSynMonitorSize } - -function TSynMonitorSize.GetAsText: TShort16; -begin - KB(fBytes,result,fTextNoSpace); -end; - -{ TSynMonitorOneSize } - -function TSynMonitorOneSize.GetAsText: TShort16; -begin - KB(fBytes,result,fTextNoSpace); -end; - -{ TSynMonitorThroughput } - -function TSynMonitorThroughput.GetAsText: TShort16; -begin - FormatShort16('%/s',[KB(fBytesPerSec,fTextNoSpace)],result); -end; - - -{ TSynMonitor } - -constructor TSynMonitor.Create; -begin - inherited Create; - fTotalTime := TSynMonitorTime.Create; - fLastTime := TSynMonitorOneTime.Create; - fMinimalTime := TSynMonitorOneTime.Create; - fAverageTime := TSynMonitorOneTime.Create; - fMaximalTime := TSynMonitorOneTime.Create; -end; - -constructor TSynMonitor.Create(const aName: RawUTF8); -begin - Create; - fName := aName; -end; - -destructor TSynMonitor.Destroy; -begin - fMaximalTime.Free; - fAverageTime.Free; - fMinimalTime.Free; - fLastTime.Free; - fTotalTime.Free; - inherited Destroy; -end; - -procedure TSynMonitor.Lock; -begin - fSafe^.Lock; -end; - -procedure TSynMonitor.UnLock; -begin - fSafe^.UnLock; -end; - -procedure TSynMonitor.Changed; -begin // do nothing by default - overriden classes may track modified changes -end; - -procedure TSynMonitor.ProcessStart; -begin - if fProcessing then - raise ESynException.CreateUTF8('Reentrant %.ProcessStart',[self]); - fSafe^.Lock; - try - InternalTimer.Resume; - fTaskStatus := taskNotStarted; - fProcessing := true; - finally - fSafe^.UnLock; - end; -end; - -procedure TSynMonitor.ProcessDoTask; -begin - fSafe^.Lock; - try - inc(fTaskCount); - fTaskStatus := taskStarted; - Changed; - finally - fSafe^.UnLock; - end; -end; - -procedure TSynMonitor.ProcessStartTask; -begin - if fProcessing then - raise ESynException.CreateUTF8('Reentrant %.ProcessStart',[self]); - fSafe^.Lock; - try - InternalTimer.Resume; - fProcessing := true; - inc(fTaskCount); - fTaskStatus := taskStarted; - Changed; - finally - fSafe^.UnLock; - end; -end; - -procedure TSynMonitor.ProcessEnd; -begin - fSafe^.Lock; - try - InternalTimer.Pause; - LockedFromProcessTimer; - finally - fSafe^.UnLock; - end; -end; - -procedure TSynMonitor.LockedFromProcessTimer; -begin - fTotalTime.MicroSec := InternalTimer.TimeInMicroSec; - if fTaskStatus=taskStarted then begin - fLastTime.MicroSec := InternalTimer.LastTimeInMicroSec; - if (fMinimalTime.MicroSec=0) or - (InternalTimer.LastTimeInMicroSecfMaximalTime.MicroSec then - fMaximalTime.MicroSec := InternalTimer.LastTimeInMicroSec; - fTaskStatus := taskNotStarted; - end; - LockedPerSecProperties; - fProcessing := false; - Changed; -end; - -function TSynMonitor.FromExternalQueryPerformanceCounters(const CounterDiff: QWord): QWord; -begin - fSafe^.Lock; - try // thread-safe ProcessStart+ProcessDoTask+ProcessEnd - inc(fTaskCount); - fTaskStatus := taskStarted; - result := InternalTimer.FromExternalQueryPerformanceCounters(CounterDiff); - LockedFromProcessTimer; - finally - fSafe^.UnLock; - end; -end; - -procedure TSynMonitor.FromExternalMicroSeconds(const MicroSecondsElapsed: QWord); -begin - fSafe^.Lock; - try // thread-safe ProcessStart+ProcessDoTask+ProcessEnd - inc(fTaskCount); - fTaskStatus := taskStarted; - InternalTimer.FromExternalMicroSeconds(MicroSecondsElapsed); - LockedFromProcessTimer; - finally - fSafe^.UnLock; - end; -end; - -class procedure TSynMonitor.InitializeObjArray(var ObjArr; Count: integer); -var i: integer; -begin - ObjArrayClear(ObjArr); - SetLength(TPointerDynArray(ObjArr),Count); - for i := 0 to Count-1 do - TPointerDynArray(ObjArr)[i] := Create; -end; - -procedure TSynMonitor.ProcessError(const info: variant); -begin - fSafe^.Lock; - try - if not VarIsEmptyOrNull(info) then - inc(fInternalErrors); - fLastInternalError := info; - Changed; - finally - fSafe^.UnLock; - end; -end; - -procedure TSynMonitor.ProcessErrorFmt(const Fmt: RawUTF8; const Args: array of const); -begin - ProcessError({$ifndef NOVARIANTS}RawUTF8ToVariant{$endif}(FormatUTF8(Fmt,Args))); -end; - -procedure TSynMonitor.ProcessErrorRaised(E: Exception); -begin - {$ifndef NOVARIANTS}if E.InheritsFrom(ESynException) then - ProcessError(_ObjFast([E,ObjectToVariant(E,true)])) else{$endif} - ProcessErrorFmt('%: %', [E,E.Message]); -end; - -procedure TSynMonitor.ProcessErrorNumber(info: integer); -begin - ProcessError(info); -end; - -procedure TSynMonitor.LockedPerSecProperties; -begin - if fTaskCount=0 then - exit; // avoid division per zero - fPerSec := fTotalTime.PerSecond(fTaskCount); - fAverageTime.MicroSec := fTotalTime.MicroSec div fTaskCount; -end; - -procedure TSynMonitor.Sum(another: TSynMonitor); -begin - if (self=nil) or (another=nil) then - exit; - fSafe^.Lock; - another.fSafe^.Lock; - try - LockedSum(another); - finally - another.fSafe^.UnLock; - fSafe^.UnLock; - end; -end; - -procedure TSynMonitor.LockedSum(another: TSynMonitor); -begin - fTotalTime.MicroSec := fTotalTime.MicroSec+another.fTotalTime.MicroSec; - if (fMinimalTime.MicroSec=0) or - (another.fMinimalTime.MicroSecfMaximalTime.MicroSec then - fMaximalTime.MicroSec := another.fMaximalTime.MicroSec; - inc(fTaskCount,another.fTaskCount); - if another.Processing then - fProcessing := true; // if any thread is active, whole daemon is active - inc(fInternalErrors,another.Errors); -end; - -procedure TSynMonitor.WriteDetailsTo(W: TTextWriter); -begin - fSafe^.Lock; - try - W.WriteObject(self); - finally - fSafe^.UnLock; - end; -end; - -procedure TSynMonitor.ComputeDetailsTo(W: TTextWriter); -begin - fSafe^.Lock; - try - LockedPerSecProperties; // may not have been calculated after Sum() - WriteDetailsTo(W); - finally - fSafe^.UnLock; - end; -end; - -function TSynMonitor.ComputeDetailsJSON: RawUTF8; -var W: TTextWriter; - temp: TTextWriterStackBuffer; -begin - W := DefaultTextWriterSerializer.CreateOwnedStream(temp); - try - ComputeDetailsTo(W); - W.SetText(result); - finally - W.Free; - end; -end; - -{$ifndef NOVARIANTS} -function TSynMonitor.ComputeDetails: variant; -begin - _Json(ComputeDetailsJSON,result,JSON_OPTIONS_FAST); -end; -{$endif} - - -{ TSynMonitorWithSize} - -constructor TSynMonitorWithSize.Create; -begin - inherited Create; - fSize := TSynMonitorSize.Create({nospace=}false); - fThroughput := TSynMonitorThroughput.Create({nospace=}false); -end; - -destructor TSynMonitorWithSize.Destroy; -begin - inherited Destroy; - fThroughput.Free; - fSize.Free; -end; - -procedure TSynMonitorWithSize.LockedPerSecProperties; -begin - inherited LockedPerSecProperties; - fThroughput.BytesPerSec := fTotalTime.PerSecond(fSize.Bytes); -end; - -procedure TSynMonitorWithSize.AddSize(const Bytes: QWord); -begin - fSafe^.Lock; - try - fSize.Bytes := fSize.Bytes+Bytes; - finally - fSafe^.UnLock; - end; -end; - -procedure TSynMonitorWithSize.LockedSum(another: TSynMonitor); -begin - inherited LockedSum(another); - if another.InheritsFrom(TSynMonitorWithSize) then - AddSize(TSynMonitorWithSize(another).Size.Bytes); -end; - - -{ TSynMonitorInputOutput } - -constructor TSynMonitorInputOutput.Create; -begin - inherited Create; - fInput := TSynMonitorSize.Create({nospace=}false); - fOutput := TSynMonitorSize.Create({nospace=}false); - fInputThroughput := TSynMonitorThroughput.Create({nospace=}false); - fOutputThroughput := TSynMonitorThroughput.Create({nospace=}false); -end; - -destructor TSynMonitorInputOutput.Destroy; -begin - fOutputThroughput.Free; - fOutput.Free; - fInputThroughput.Free; - fInput.Free; - inherited Destroy; -end; - -procedure TSynMonitorInputOutput.LockedPerSecProperties; -begin - inherited LockedPerSecProperties; - fInputThroughput.BytesPerSec := fTotalTime.PerSecond(fInput.Bytes); - fOutputThroughput.BytesPerSec := fTotalTime.PerSecond(fOutput.Bytes); -end; - -procedure TSynMonitorInputOutput.AddSize(const Incoming, Outgoing: QWord); -begin - fSafe^.Lock; - try - fInput.Bytes := fInput.Bytes+Incoming; - fOutput.Bytes := fOutput.Bytes+Outgoing; - finally - fSafe^.UnLock; - end; -end; - -procedure TSynMonitorInputOutput.LockedSum(another: TSynMonitor); -begin - inherited LockedSum(another); - if another.InheritsFrom(TSynMonitorInputOutput) then begin - fInput.Bytes := fInput.Bytes+TSynMonitorInputOutput(another).Input.Bytes; - fOutput.Bytes := fOutput.Bytes+TSynMonitorInputOutput(another).Output.Bytes; - end; -end; - - -{ TSynMonitorServer } - -procedure TSynMonitorServer.ClientConnect; -begin - if self=nil then - exit; - fSafe^.Lock; - try - inc(fClientsCurrent); - if fClientsCurrent>fClientsMax then - fClientsMax := fClientsCurrent; - Changed; - finally - fSafe^.UnLock; - end; -end; - -procedure TSynMonitorServer.ClientDisconnect; -begin - if self=nil then - exit; - fSafe^.Lock; - try - if fClientsCurrent>0 then - dec(fClientsCurrent); - Changed; - finally - fSafe^.UnLock; - end; -end; - -procedure TSynMonitorServer.ClientDisconnectAll; -begin - if self=nil then - exit; - fSafe^.Lock; - try - fClientsCurrent := 0; - Changed; - finally - fSafe^.UnLock; - end; -end; - -function TSynMonitorServer.GetClientsCurrent: TSynMonitorOneCount; -begin - if self=nil then begin - result := 0; - exit; - end; - fSafe^.Lock; - try - result := fClientsCurrent; - finally - fSafe^.UnLock; - end; -end; - -function TSynMonitorServer.AddCurrentRequestCount(diff: integer): integer; -begin - if self=nil then begin - result := 0; - exit; - end; - fSafe^.Lock; - try - inc(fCurrentRequestCount,diff); - result := fCurrentRequestCount; - finally - fSafe^.UnLock; - end; -end; - - -{ ******************* cross-cutting classes and functions ***************** } - -{ TSynInterfacedObject } - -function TSynInterfacedObject._AddRef: {$ifdef FPC}longint{$else}integer{$endif}; -begin - result := VirtualAddRef; -end; - -function TSynInterfacedObject._Release: {$ifdef FPC}longint{$else}integer{$endif}; -begin - result := VirtualRelease; -end; - -{$ifdef FPC} -function TSynInterfacedObject.QueryInterface( - {$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID; - out Obj): longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; -{$else} -function TSynInterfacedObject.QueryInterface(const IID: TGUID; out Obj): HResult; -{$endif} -begin - result := VirtualQueryInterface(IID,Obj); -end; - -function TSynInterfacedObject.VirtualQueryInterface(const IID: TGUID; out Obj): HResult; -begin - result := E_NOINTERFACE; -end; - -{$ifdef CPUINTEL} -{$ifndef DELPHI5OROLDER} - -{ TSynFPUException } - -function TSynFPUException.VirtualAddRef: integer; -begin - if fRefCount=0 then begin - {$ifndef CPU64} - fSaved8087 := Get8087CW; - Set8087CW(fExpected8087); // set FPU exceptions mask - {$else} - fSavedMXCSR := GetMXCSR; - SetMXCSR(fExpectedMXCSR); // set FPU exceptions mask - {$endif} - end; - inc(fRefCount); - result := 1; // should never be 0 (mark release of TSynFPUException instance) -end; - -function TSynFPUException.VirtualRelease: integer; -begin - dec(fRefCount); - if fRefCount=0 then - {$ifndef CPU64} - Set8087CW(fSaved8087); - {$else} - SetMXCSR(fSavedMXCSR); - {$endif} - result := 1; // should never be 0 (mark release of TSynFPUException instance) -end; - -threadvar - GlobalSynFPUExceptionDelphi, - GlobalSynFPUExceptionLibrary: TSynFPUException; - -{$ifndef CPU64} -constructor TSynFPUException.Create(Expected8087Flag: word); -begin // $1372=Delphi $137F=library (mask all exceptions) - inherited Create; - fExpected8087 := Expected8087Flag; -end; -{$else} -constructor TSynFPUException.Create(ExpectedMXCSR: word); -begin // $1920=Delphi $1FA0=library (mask all exceptions) - inherited Create; - fExpectedMXCSR := ExpectedMXCSR; -end; -{$endif} - -class function TSynFPUException.ForLibraryCode: IUnknown; -var obj: TSynFPUException; -begin - result := GlobalSynFPUExceptionLibrary; - if result<>nil then - exit; - {$ifndef CPU64} - obj := TSynFPUException.Create($137F); - {$else} - obj := TSynFPUException.Create($1FA0); - {$endif} - GarbageCollector.Add(obj); - GlobalSynFPUExceptionLibrary := obj; - result := obj; -end; - -class function TSynFPUException.ForDelphiCode: IUnknown; -var obj: TSynFPUException; -begin - result := GlobalSynFPUExceptionDelphi; - if result<>nil then - exit; - {$ifndef CPU64} - obj := TSynFPUException.Create($1372); - {$else} - obj := TSynFPUException.Create($1920); - {$endif} - GarbageCollector.Add(obj); - GlobalSynFPUExceptionDelphi := obj; - result := obj; -end; - -{$endif DELPHI5OROLDER} -{$endif CPUINTEL} - - -{ TAutoFree } - -constructor TAutoFree.Create(var localVariable; obj: TObject); -begin - fObject := obj; - TObject(localVariable) := obj; -end; - -class function TAutoFree.One(var localVariable; obj: TObject): IAutoFree; -begin - result := Create(localVariable,obj); -end; - -class function TAutoFree.Several(const varObjPairs: array of pointer): IAutoFree; -begin - result := Create(varObjPairs); -end; - -constructor TAutoFree.Create(const varObjPairs: array of pointer); -var n,i: integer; -begin - n := length(varObjPairs); - if (n=0) or (n and 1=1) then - exit; - n := n shr 1; - if n=0 then - exit; - SetLength(fObjectList,n); - for i := 0 to n-1 do begin - fObjectList[i] := varObjPairs[i*2+1]; - PPointer(varObjPairs[i*2])^ := fObjectList[i]; - end; -end; - -procedure TAutoFree.Another(var localVariable; obj: TObject); -var n: integer; -begin - n := length(fObjectList); - SetLength(fObjectList,n+1); - fObjectList[n] := obj; - TObject(localVariable) := obj; -end; - -destructor TAutoFree.Destroy; -var i: integer; -begin - if fObjectList<>nil then - for i := high(fObjectList) downto 0 do // release FILO - fObjectList[i].Free; - fObject.Free; - inherited; -end; - - -{ TAutoLocker } - -constructor TAutoLocker.Create; -begin - fSafe.Init; -end; - -destructor TAutoLocker.Destroy; -begin - fSafe.Done; - inherited; -end; - -function TAutoLocker.ProtectMethod: IUnknown; -begin - result := TAutoLock.Create(@fSafe); -end; - -procedure TAutoLocker.Enter; -begin - fSafe.Lock; -end; - -procedure TAutoLocker.Leave; -begin - fSafe.UnLock; -end; - -function TAutoLocker.Safe: PSynLocker; -begin - result := @fSafe; -end; - -{$ifndef DELPHI5OROLDER} // internal error C3517 under Delphi 5 :( -{$ifndef NOVARIANTS} - -{ TLockedDocVariant } - -constructor TLockedDocVariant.Create; -begin - Create(JSON_OPTIONS_FAST); -end; - -constructor TLockedDocVariant.Create(FastStorage: boolean); -begin - Create(JSON_OPTIONS[FastStorage]); -end; - -constructor TLockedDocVariant.Create(options: TDocVariantOptions); -begin - fLock := TAutoLocker.Create; - fValue.Init(options); -end; - -destructor TLockedDocVariant.Destroy; -begin - inherited; - fLock.Free; -end; - -function TLockedDocVariant.Lock: TAutoLocker; -begin - result := fLock; -end; - -function TLockedDocVariant.Exists(const Name: RawUTF8; out Value: Variant): boolean; -var i: integer; -begin - fLock.Enter; - try - i := fValue.GetValueIndex(Name); - if i<0 then - result := false else begin - Value := fValue.Values[i]; - result := true; - end; - finally - fLock.Leave; - end; -end; - -function TLockedDocVariant.ExistsOrLock(const Name: RawUTF8; out Value: Variant): boolean; -var i: integer; -begin - result := true; - fLock.Enter; - try - i := fValue.GetValueIndex(Name); - if i<0 then - result := false else - Value := fValue.Values[i]; - finally - if result then - fLock.Leave; - end; -end; - -procedure TLockedDocVariant.ReplaceAndUnlock( - const Name: RawUTF8; const Value: Variant; out LocalValue: Variant); -begin // caller made fLock.Enter - try - SetValue(Name,Value); - LocalValue := Value; - finally - fLock.Leave; - end; -end; - -function TLockedDocVariant.AddExistingPropOrLock(const Name: RawUTF8; - var Obj: variant): boolean; -var i: integer; -begin - result := true; - fLock.Enter; - try - i := fValue.GetValueIndex(Name); - if i<0 then - result := false else - _ObjAddProps([Name,fValue.Values[i]],Obj); - finally - if result then - fLock.Leave; - end; -end; - -procedure TLockedDocVariant.AddNewPropAndUnlock(const Name: RawUTF8; - const Value: variant; - var Obj: variant); -begin // caller made fLock.Enter - try - SetValue(Name,Value); - _ObjAddProps([Name,Value],Obj); - finally - fLock.Leave; - end; -end; - -function TLockedDocVariant.AddExistingProp(const Name: RawUTF8; - var Obj: variant): boolean; -var i: integer; -begin - result := true; - fLock.Enter; - try - i := fValue.GetValueIndex(Name); - if i<0 then - result := false else - _ObjAddProps([Name,fValue.Values[i]],Obj); - finally - fLock.Leave; - end; -end; - -procedure TLockedDocVariant.AddNewProp(const Name: RawUTF8; - const Value: variant; var Obj: variant); -begin - fLock.Enter; - try - SetValue(Name,Value); - _ObjAddProps([Name,Value],Obj); - finally - fLock.Leave; - end; -end; - -function TLockedDocVariant.GetValue(const Name: RawUTF8): Variant; -begin - fLock.Enter; - try - fValue.RetrieveValueOrRaiseException(pointer(Name),length(Name), - dvoNameCaseSensitive in fValue.Options,result,false); - finally - fLock.Leave; - end; -end; - -procedure TLockedDocVariant.SetValue(const Name: RawUTF8; - const Value: Variant); -begin - fLock.Enter; - try - fValue.AddOrUpdateValue(Name,Value); - finally - fLock.Leave; - end; -end; - -procedure TLockedDocVariant.AddItem(const Value: variant); -begin - fLock.Enter; - try - fValue.AddItem(Value); - finally - fLock.Leave; - end; -end; - -function TLockedDocVariant.Copy: variant; -begin - VarClear(result); - fLock.Enter; - try - TDocVariantData(result).InitCopy(variant(fValue),JSON_OPTIONS_FAST); - finally - fLock.Leave; - end; -end; - -procedure TLockedDocVariant.Clear; -var opt: TDocVariantOptions; -begin - fLock.Enter; - try - opt := fValue.Options; - fValue.Clear; - fValue.Init(opt); - finally - fLock.Leave; - end; -end; - -function TLockedDocVariant.ToJSON(HumanReadable: boolean): RawUTF8; -var tmp: RawUTF8; -begin - fLock.Enter; - try - VariantSaveJSON(variant(fValue),twJSONEscape,tmp); - finally - fLock.Leave; - end; - if HumanReadable then - JSONBufferReformat(pointer(tmp),result) else - result := tmp; -end; - -{$endif NOVARIANTS} -{$endif DELPHI5OROLDER} - - -function GetDelphiCompilerVersion: RawUTF8; -begin - result := -{$ifdef FPC} - 'Free Pascal' - {$ifdef VER2_6_4}+' 2.6.4'{$endif} - {$ifdef VER3_0_0}+' 3.0.0'{$endif} - {$ifdef VER3_0_1}+' 3.0.1'{$endif} - {$ifdef VER3_0_2}+' 3.0.2'{$endif} - {$ifdef VER3_1_1}+' 3.1.1'{$endif} - {$ifdef VER3_2} +' 3.2' {$endif} - {$ifdef VER3_3_1}+' 3.3.1'{$endif} -{$else} - {$ifdef VER130} 'Delphi 5'{$endif} - {$ifdef CONDITIONALEXPRESSIONS} // Delphi 6 or newer - {$if defined(KYLIX3)}'Kylix 3' - {$elseif defined(VER140)}'Delphi 6' - {$elseif defined(VER150)}'Delphi 7' - {$elseif defined(VER160)}'Delphi 8' - {$elseif defined(VER170)}'Delphi 2005' - {$elseif defined(VER185)}'Delphi 2007' - {$elseif defined(VER180)}'Delphi 2006' - {$elseif defined(VER200)}'Delphi 2009' - {$elseif defined(VER210)}'Delphi 2010' - {$elseif defined(VER220)}'Delphi XE' - {$elseif defined(VER230)}'Delphi XE2' - {$elseif defined(VER240)}'Delphi XE3' - {$elseif defined(VER250)}'Delphi XE4' - {$elseif defined(VER260)}'Delphi XE5' - {$elseif defined(VER265)}'AppMethod 1' - {$elseif defined(VER270)}'Delphi XE6' - {$elseif defined(VER280)}'Delphi XE7' - {$elseif defined(VER290)}'Delphi XE8' - {$elseif defined(VER300)}'Delphi 10 Seattle' - {$elseif defined(VER310)}'Delphi 10.1 Berlin' - {$elseif defined(VER320)}'Delphi 10.2 Tokyo' - {$elseif defined(VER330)}'Delphi 10.3 Rio' - {$elseif defined(VER340)}'Delphi 10.4 Sydney' - {$elseif defined(VER350)}'Delphi 11 Alexandria' - {$elseif defined(VER360)}'Delphi 11.1 Next' - {$ifend} - {$endif CONDITIONALEXPRESSIONS} -{$endif FPC} -{$ifdef CPU64} +' 64 bit' {$else} +' 32 bit' {$endif} -end; - - -{ TRawUTF8List } - -constructor TRawUTF8List.Create(aOwnObjects, aNoDuplicate, aCaseSensitive: boolean); -begin - if aOwnObjects then - include(fFlags,fObjectsOwned); - if aNoDuplicate then - include(fFlags,fNoDuplicate); - if aCaseSensitive then - include(fFlags,fCaseSensitive); - Create(fFlags); -end; - -constructor TRawUTF8List.Create(aFlags: TRawUTF8ListFlags); -begin - fNameValueSep := '='; - fFlags := aFlags; - fValues.InitSpecific(TypeInfo(TRawUTF8DynArray),fValue,djRawUTF8,@fCount, - not (fCaseSensitive in aFlags)); - fSafe.Init; -end; - -destructor TRawUTF8List.Destroy; -begin - SetCapacity(0); - inherited; - fSafe.Done; -end; - -procedure TRawUTF8List.SetCaseSensitive(Value: boolean); -begin - if (self=nil) or (fCaseSensitive in fFlags=Value) then - exit; - fSafe.Lock; - try - if Value then - include(fFlags,fCaseSensitive) else - exclude(fFlags,fCaseSensitive); - fValues.Hasher.InitSpecific(@fValues,djRawUTF8,not Value); - Changed; - finally - fSafe.UnLock; - end; -end; - -procedure TRawUTF8List.SetCapacity(const capa: PtrInt); -begin - if self<>nil then begin - fSafe.Lock; - try - if capa<=0 then begin // clear - if fObjects<>nil then begin - if fObjectsOwned in fFlags then - RawObjectsClear(pointer(fObjects),fCount); - fObjects := nil; - end; - fValues.Clear; - if fNoDuplicate in fFlags then - fValues.Hasher.Clear; - Changed; - end else begin // resize - if capanil then begin - if fObjectsOwned in fFlags then - RawObjectsClear(@fObjects[capa],fCount-capa-1); - SetLength(fObjects,capa); - end; - fValues.Count := capa; - if fNoDuplicate in fFlags then - fValues.ReHash; - Changed; - end; - if capa>length(fValue) then begin // resize up - SetLength(fValue,capa); - if fObjects<>nil then - SetLength(fObjects,capa); - end; - end; - finally - fSafe.UnLock; - end; - end; -end; - -function TRawUTF8List.Add(const aText: RawUTF8; aRaiseExceptionIfExisting: boolean): PtrInt; -begin - result := AddObject(aText,nil,aRaiseExceptionIfExisting); -end; - -function TRawUTF8List.AddObject(const aText: RawUTF8; aObject: TObject; - aRaiseExceptionIfExisting: boolean; aFreeAndReturnExistingObject: PPointer): PtrInt; -var added: boolean; - obj: TObject; -begin - result := -1; - if self=nil then - exit; - fSafe.Lock; - try - if fNoDuplicate in fFlags then begin - result := fValues.FindHashedForAdding(aText,added,{noadd=}true); - if not added then begin - obj := GetObject(result); - if (obj=aObject) and (obj<>nil) then - exit; // found identical aText/aObject -> behave as if added - if aFreeAndReturnExistingObject<>nil then begin - aObject.Free; - aFreeAndReturnExistingObject^ := obj; - end; - if aRaiseExceptionIfExisting then - raise ESynException.CreateUTF8('%.Add duplicate [%]',[self,aText]); - result := -1; - exit; - end; - end; - result := fValues.Add(aText); - if (fObjects<>nil) or (aObject<>nil) then begin - if result>=length(fObjects) then - SetLength(fObjects,length(fValue)); // same capacity - if aObject<>nil then - fObjects[result] := aObject; - end; - if Assigned(fOnChange) then - Changed; - finally - fSafe.UnLock; - end; -end; - -procedure TRawUTF8List.AddObjectUnique(const aText: RawUTF8; - aObjectToAddOrFree: PPointer); -begin - if fNoDuplicate in fFlags then - AddObject(aText,aObjectToAddOrFree^,{raiseexc=}false, - {freeandreturnexisting=}aObjectToAddOrFree); -end; - -procedure TRawUTF8List.AddRawUTF8List(List: TRawUTF8List); -var i: PtrInt; -begin - if List<>nil then begin - BeginUpdate; // includes Safe.Lock - try - for i := 0 to List.fCount-1 do - AddObject(List.fValue[i],List.GetObject(i)); - finally - EndUpdate; - end; - end; -end; - -procedure TRawUTF8List.BeginUpdate; -begin - if InterLockedIncrement(fOnChangeLevel)>1 then - exit; - fSafe.Lock; - fOnChangeBackupForBeginUpdate := fOnChange; - fOnChange := OnChangeHidden; - exclude(fFlags,fOnChangeTrigerred); -end; - -procedure TRawUTF8List.EndUpdate; -begin - if (fOnChangeLevel<=0) or (InterLockedDecrement(fOnChangeLevel)>0) then - exit; // allows nested BeginUpdate..EndUpdate calls - fOnChange := fOnChangeBackupForBeginUpdate; - if (fOnChangeTrigerred in fFlags) and Assigned(fOnChange) then - Changed; - exclude(fFlags,fOnChangeTrigerred); - fSafe.UnLock; -end; - -procedure TRawUTF8List.Changed; -begin - if Assigned(fOnChange) then - try - fOnChange(self); - except // ignore any exception in user code (may not trigger fSafe.UnLock) - end; -end; - -procedure TRawUTF8List.Clear; -begin - SetCapacity(0); // will also call Changed -end; - -procedure TRawUTF8List.InternalDelete(Index: PtrInt); -begin // caller ensured Index is correct - fValues.Delete(Index); // includes dec(fCount) - if PtrUInt(Index)Index then - MoveFast(fObjects[Index+1],fObjects[Index],(fCount-Index)*SizeOf(pointer)); - fObjects[fCount] := nil; - end; - if Assigned(fOnChange) then - Changed; -end; - -procedure TRawUTF8List.Delete(Index: PtrInt); -begin - if (self<>nil) and (PtrUInt(Index)=0 then - InternalDelete(result); - finally - fSafe.UnLock; - end; -end; - -function TRawUTF8List.DeleteFromName(const Name: RawUTF8): PtrInt; -begin - fSafe.Lock; - try - result := IndexOfName(Name); - Delete(result); - finally - fSafe.UnLock; - end; -end; - -function TRawUTF8List.IndexOf(const aText: RawUTF8): PtrInt; -begin - if self<>nil then begin - fSafe.Lock; - try - if fNoDuplicate in fFlags then - result := fValues.FindHashed(aText) else - result := FindRawUTF8(pointer(fValue),aText,fCount,fCaseSensitive in fFlags); - finally - fSafe.UnLock; - end; - end else - result := -1; -end; - -function TRawUTF8List.Get(Index: PtrInt): RawUTF8; -begin - if (self=nil) or (PtrUInt(Index)>=PtrUInt(fCount)) then - result := '' else - result := fValue[Index]; -end; - -function TRawUTF8List.GetCapacity: PtrInt; -begin - if self=nil then - result := 0 else - result := length(fValue); -end; - -function TRawUTF8List.GetCount: PtrInt; -begin - if self=nil then - result := 0 else - result := fCount; -end; - -function TRawUTF8List.GetTextPtr: PPUtf8CharArray; -begin - if self=nil then - result := nil else - result := pointer(fValue); -end; - -function TRawUTF8List.GetObjectPtr: PPointerArray; -begin - if self=nil then - result := nil else - result := pointer(fObjects); -end; - -function TRawUTF8List.GetName(Index: PtrInt): RawUTF8; -begin - result := Get(Index); - if result='' then - exit; - Index := PosExChar(NameValueSep,result); - if Index=0 then - result := '' else - SetLength(result,Index-1); -end; - -function TRawUTF8List.GetObject(Index: PtrInt): pointer; -begin - if (self<>nil) and (fObjects<>nil) and (PtrUInt(Index)nil) and (fObjects<>nil) then begin - fSafe.Lock; - try - ndx := IndexOf(aText); - if ndx0 then begin - MoveFast(pointer(fValue[i])^,P^,Len); - inc(P,Len); - end; - inc(i); - if i>=fCount then - Break; - if DelimLen>0 then begin - MoveSmall(pointer(Delimiter),P,DelimLen); - inc(P,DelimLen); - end; - until false; - finally - fSafe.UnLock; - end; -end; - -procedure TRawUTF8List.SaveToStream(Dest: TStream; const Delimiter: RawUTF8); -var W: TTextWriter; - i: PtrInt; - temp: TTextWriterStackBuffer; -begin - if (self=nil) or (fCount=0) then - exit; - fSafe.Lock; - try - W := TTextWriter.Create(Dest,@temp,SizeOf(temp)); - try - i := 0; - repeat - W.AddString(fValue[i]); - inc(i); - if i>=fCount then - Break; - W.AddString(Delimiter); - until false; - W.FlushFinal; - finally - W.Free; - end; - finally - fSafe.UnLock; - end; -end; - -procedure TRawUTF8List.SaveToFile(const FileName: TFileName; const Delimiter: RawUTF8); -var FS: TFileStream; -begin - FS := TFileStream.Create(FileName,fmCreate); - try - SaveToStream(FS,Delimiter); - finally - FS.Free; - end; -end; - -function TRawUTF8List.GetTextCRLF: RawUTF8; -begin - result := GetText; -end; - -function TRawUTF8List.GetValue(const Name: RawUTF8): RawUTF8; -begin - fSafe.Lock; - try - result := GetValueAt(IndexOfName(Name)); - finally - fSafe.UnLock; - end; -end; - -function TRawUTF8List.GetValueAt(Index: PtrInt): RawUTF8; -begin - if (self=nil) or (PtrUInt(Index)>=PtrUInt(fCount)) then - result := '' else - result := Get(Index); - if result='' then - exit; - Index := PosExChar(NameValueSep,result); - if Index=0 then - result := '' else - result := copy(result,Index+1,maxInt); -end; - -function TRawUTF8List.IndexOfName(const Name: RawUTF8): PtrInt; -var UpperName: array[byte] of AnsiChar; -begin - if self<>nil then begin - PWord(UpperCopy255(UpperName,Name))^ := ord(NameValueSep); - for result := 0 to fCount-1 do - if IdemPChar(Pointer(fValue[result]),UpperName) then - exit; - end; - result := -1; -end; - -function TRawUTF8List.IndexOfObject(aObject: TObject): PtrInt; -begin - if (self<>nil) and (fObjects<>nil) then begin - fSafe.Lock; - try - result := PtrUIntScanIndex(pointer(fObjects),fCount,PtrUInt(aObject)); - finally - fSafe.UnLock; - end - end else - result := -1; -end; - -function TRawUTF8List.Contains(const aText: RawUTF8; aFirstIndex: integer): PtrInt; -var i: PtrInt; // use a temp variable to make oldest Delphi happy :( -begin - result := -1; - if self<>nil then begin - fSafe.Lock; - try - for i := aFirstIndex to fCount-1 do - if PosEx(aText,fValue[i])>0 then begin - result := i; - exit; - end; - finally - fSafe.UnLock; - end; - end; -end; - -procedure TRawUTF8List.OnChangeHidden(Sender: TObject); -begin - if self<>nil then - include(fFlags,fOnChangeTrigerred); -end; - -procedure TRawUTF8List.Put(Index: PtrInt; const Value: RawUTF8); -begin - if (self<>nil) and (PtrUInt(Index)nil) and (PtrUInt(Index)0 then begin - if TextFileKind(Map)=isUTF8 then begin // ignore UTF-8 BOM - P := pointer(Map.Buffer+3); - SetTextPtr(P,P+Map.Size-3,#13#10); - end else begin - P := pointer(Map.Buffer); - SetTextPtr(P,P+Map.Size,#13#10); - end; - end; - finally - Map.UnMap; - end; -end; - -procedure TRawUTF8List.SetTextPtr(P,PEnd: PUTF8Char; const Delimiter: RawUTF8); -var DelimLen: PtrInt; - DelimFirst: AnsiChar; - PBeg, DelimNext: PUTF8Char; - Line: RawUTF8; -begin - DelimLen := length(Delimiter); - BeginUpdate; // also makes fSafe.Lock - try - Clear; - if (P<>nil) and (DelimLen>0) and (P=PEnd then - break; - inc(P,DelimLen); - until P>=PEnd; - end; - finally - EndUpdate; - end; -end; - -procedure TRawUTF8List.SetTextCRLF(const Value: RawUTF8); -begin - SetText(Value,#13#10); -end; - -procedure TRawUTF8List.SetFrom(const aText: TRawUTF8DynArray; const aObject: TObjectDynArray); -var n: integer; -begin - BeginUpdate; // also makes fSafe.Lock - try - Clear; - n := length(aText); - if n=0 then - exit; - SetCapacity(n); - fCount := n; - fValue := aText; - fObjects := aObject; - if fNoDuplicate in fFlags then - fValues.ReHash; - finally - EndUpdate; - end; -end; - -procedure TRawUTF8List.SetValue(const Name, Value: RawUTF8); -var i: PtrInt; - txt: RawUTF8; -begin - txt := Name+RawUTF8(NameValueSep)+Value; - fSafe.Lock; - try - i := IndexOfName(Name); - if i<0 then - AddObject(txt,nil) else - if fValue[i]<>txt then begin - fValue[i] := txt; - if fNoDuplicate in fFlags then - fValues.Hasher.Clear; // invalidate internal hash table - Changed; - end; - finally - fSafe.UnLock; - end; -end; - -function TRawUTF8List.GetCaseSensitive: boolean; -begin - result := (self<>nil) and (fCaseSensitive in fFlags); -end; - -function TRawUTF8List.GetNoDuplicate: boolean; -begin - result := (self<>nil) and (fNoDuplicate in fFlags); -end; - -function TRawUTF8List.UpdateValue(const Name: RawUTF8; var Value: RawUTF8; - ThenDelete: boolean): boolean; -var i: PtrInt; -begin - result := false; - fSafe.Lock; - try - i := IndexOfName(Name); - if i>=0 then begin - Value := GetValueAt(i); // copy value - if ThenDelete then - Delete(i); // optionally delete - result := true; - end; - finally - fSafe.UnLock; - end; -end; - -function TRawUTF8List.PopFirst(out aText: RawUTF8; aObject: PObject): boolean; -begin - result := false; - if fCount=0 then - exit; - fSafe.Lock; - try - if fCount>0 then begin - aText := fValue[0]; - if aObject<>nil then - if fObjects<>nil then - aObject^ := fObjects[0] else - aObject^ := nil; - Delete(0); - result := true; - end; - finally - fSafe.UnLock; - end; -end; - -function TRawUTF8List.PopLast(out aText: RawUTF8; aObject: PObject): boolean; -var last: PtrInt; -begin - result := false; - if fCount=0 then - exit; - fSafe.Lock; - try - last := fCount-1; - if last>=0 then begin - aText := fValue[last]; - if aObject<>nil then - if fObjects<>nil then - aObject^ := fObjects[last] else - aObject^ := nil; - Delete(last); - result := true; - end; - finally - fSafe.UnLock; - end; -end; - - -{ TObjectListHashedAbstract} - -constructor TObjectListHashedAbstract.Create(aFreeItems: boolean); -begin - inherited Create; - fHash.Init(TypeInfo(TObjectDynArray),fList,@HashPtrUInt,@SortDynArrayPointer,nil,@fCount); - fHash.{$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$endif}SetIsObjArray(aFreeItems); -end; - -destructor TObjectListHashedAbstract.Destroy; -begin - fHash.Clear; // will free items if needed - inherited; -end; - -procedure TObjectListHashedAbstract.Delete(aIndex: integer); -begin - if (self<>nil) and - fHash.{$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$endif}Delete(aIndex) then - fHash.fHash.Clear; -end; - -procedure TObjectListHashedAbstract.Delete(aObject: TObject); -begin - Delete(IndexOf(aObject)); -end; - -{ TObjectListHashed } - -function TObjectListHashed.Add(aObject: TObject; out wasAdded: boolean): integer; -begin - wasAdded := false; - if self<>nil then begin - result := fHash.FindHashedForAdding(aObject,wasAdded); - if wasAdded then - fList[result] := aObject; - end else - result := -1; -end; - -function TObjectListHashed.IndexOf(aObject: TObject): integer; -begin - if (self<>nil) and (fCount>0) then - result := fHash.FindHashed(aObject) else - result := -1; -end; - -procedure TObjectListHashed.Delete(aObject: TObject); -begin - fHash.FindHashedAndDelete(aObject); -end; - -{ TObjectListPropertyHashed } - -constructor TObjectListPropertyHashed.Create( - aSubPropAccess: TObjectListPropertyHashedAccessProp; - aHashElement: TDynArrayHashOne; aCompare: TDynArraySortCompare; - aFreeItems: boolean); -begin - inherited Create(aFreeItems); - fSubPropAccess := aSubPropAccess; - if Assigned(aHashElement) then - fHash.fHash.HashElement := aHashElement; - if Assigned(aCompare) then - fHash.fHash.Compare := aCompare; - fHash.EventCompare := IntComp; - fHash.EventHash := IntHash; -end; - -function TObjectListPropertyHashed.IntHash(const Elem): cardinal; -var O: TObject; -begin - O := fSubPropAccess(TObject(Elem)); - result := fHash.fHash.HashElement(O,fHash.fHash.Hasher); -end; - -function TObjectListPropertyHashed.IntComp(const A,B): integer; -var O: TObject; -begin - O := fSubPropAccess(TObject(A)); - result := fHash.{$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$endif}fCompare(O,B); -end; - -function TObjectListPropertyHashed.Add(aObject: TObject; out wasAdded: boolean): integer; -begin - wasAdded := false; - if self<>nil then begin - result := fHash.FindHashedForAdding(aObject,wasAdded, - fHash.fHash.HashElement(aObject,fHash.fHash.Hasher)); - if wasAdded then - fList[result] := aObject; - end else - result := -1; -end; - -function TObjectListPropertyHashed.IndexOf(aObject: TObject): integer; -var h: cardinal; -begin - if fCount>0 then begin - h := fHash.fHash.HashElement(aObject,fHash.fHash.Hasher); - result := fHash.fHash.FindOrNew(h,@aObject); // fallback to Scan() if needed - if result>=0 then - exit else // found - result := -1; // for consistency - end else - result := -1; -end; - -{ TPointerClassHashed } - -constructor TPointerClassHashed.Create(aInfo: pointer); -begin - fInfo := aInfo; -end; - -{ TPointerClassHash } - -function PointerClassHashProcess(aObject: TPointerClassHashed): pointer; -begin - if aObject=nil then // may happen for Rehash after SetCount(n+1) - result := nil else - result := aObject.Info; -end; - -constructor TPointerClassHash.Create; -begin - inherited Create(@PointerClassHashProcess); -end; - -function TPointerClassHash.TryAdd(aInfo: pointer): PPointerClassHashed; -var wasAdded: boolean; - i: integer; -begin - i := inherited Add(aInfo,wasAdded); - if wasAdded then - result := @List[i] else - result := nil; -end; - -function TPointerClassHash.Find(aInfo: pointer): TPointerClassHashed; -var i: integer; - p: ^TPointerClassHashed; -begin - if self<>nil then begin - if fCount<64 then begin // brute force is faster for small count - p := pointer(List); - for i := 1 to fCount do begin - result := p^; - if result.fInfo=aInfo then - exit; - inc(p); - end; - end else begin - i := IndexOf(aInfo); // use hashing - if i>=0 then begin - result := TPointerClassHashed(List[i]); - exit; - end; - end; - end; - result := nil; -end; - -{ TPointerClassHashLocked } - -constructor TPointerClassHashLocked.Create; -begin - inherited Create; - fSafe.Init; -end; - -destructor TPointerClassHashLocked.Destroy; -begin - fSafe.Done; - inherited Destroy; -end; - -function TPointerClassHashLocked.FindLocked(aInfo: pointer): TPointerClassHashed; -begin - if self=nil then - result := nil else begin - fSafe.Lock; - try - result := inherited Find(aInfo); - finally - fSafe.UnLock; - end; - end; -end; - -function TPointerClassHashLocked.TryAddLocked(aInfo: pointer; - out aNewEntry: PPointerClassHashed): boolean; -var wasAdded: boolean; - i: integer; -begin - fSafe.Lock; - i := inherited Add(aInfo,wasAdded); - if wasAdded then begin - aNewEntry := @List[i]; - result := true; // caller should call Unlock - end else begin - fSafe.UnLock; - result := false; - end; -end; - -procedure TPointerClassHashLocked.Unlock; -begin - fSafe.UnLock; -end; - - -{ TSynDictionary } - -const - DIC_KEYCOUNT = 0; - DIC_KEY = 1; - DIC_VALUECOUNT = 2; - DIC_VALUE = 3; - DIC_TIMECOUNT = 4; - DIC_TIMESEC = 5; - DIC_TIMETIX = 6; - -function TSynDictionary.KeyFullHash(const Elem): cardinal; -begin - result := fKeys.fHash.Hasher(0,@Elem,fKeys.ElemSize); -end; - -function TSynDictionary.KeyFullCompare(const A,B): integer; -var i: PtrInt; -begin - - for i := 0 to fKeys.ElemSize-1 do begin - result := TByteArray(A)[i]-TByteArray(B)[i]; - if result<>0 then - exit; - end; - result := 0; -end; - -constructor TSynDictionary.Create(aKeyTypeInfo,aValueTypeInfo: pointer; - aKeyCaseInsensitive: boolean; aTimeoutSeconds: cardinal; aCompressAlgo: TAlgoCompress); -begin - inherited Create; - fSafe.Padding[DIC_KEYCOUNT].VType := varInteger; - fSafe.Padding[DIC_KEY].VType := varUnknown; - fSafe.Padding[DIC_VALUECOUNT].VType := varInteger; - fSafe.Padding[DIC_VALUE].VType := varUnknown; - fSafe.Padding[DIC_TIMECOUNT].VType := varInteger; - fSafe.Padding[DIC_TIMESEC].VType := varInteger; - fSafe.Padding[DIC_TIMETIX].VType := varInteger; - fSafe.PaddingUsedCount := DIC_TIMETIX+1; - fKeys.Init(aKeyTypeInfo,fSafe.Padding[DIC_KEY].VAny,nil,nil,nil, - @fSafe.Padding[DIC_KEYCOUNT].VInteger,aKeyCaseInsensitive); - if not Assigned(fKeys.HashElement) then - fKeys.EventHash := KeyFullHash; - if not Assigned(fKeys.{$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$endif}fCompare) then - fKeys.EventCompare := KeyFullCompare; - fValues.Init(aValueTypeInfo,fSafe.Padding[DIC_VALUE].VAny, - @fSafe.Padding[DIC_VALUECOUNT].VInteger); - fTimeouts.Init(TypeInfo(TIntegerDynArray),fTimeOut,@fSafe.Padding[DIC_TIMECOUNT].VInteger); - if aCompressAlgo=nil then - aCompressAlgo := AlgoSynLZ; - fCompressAlgo := aCompressAlgo; - fSafe.Padding[DIC_TIMESEC].VInteger := aTimeoutSeconds; -end; - -function TSynDictionary.ComputeNextTimeOut: cardinal; -begin - result := fSafe.Padding[DIC_TIMESEC].VInteger; - if result<>0 then - result := cardinal({$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64 shr 10)+result; -end; - -function TSynDictionary.GetCapacity: integer; -begin - fSafe.Lock; - result := fKeys.GetCapacity; - fSafe.UnLock; -end; - -procedure TSynDictionary.SetCapacity(const Value: integer); -begin - fSafe.Lock; - fKeys.Capacity := Value; - fValues.Capacity := Value; - if fSafe.Padding[DIC_TIMESEC].VInteger>0 then - fTimeOuts.Capacity := Value; - fSafe.UnLock; -end; - -function TSynDictionary.GetTimeOutSeconds: cardinal; -begin - result := fSafe.Padding[DIC_TIMESEC].VInteger; -end; - -procedure TSynDictionary.SetTimeouts; -var i: PtrInt; - timeout: cardinal; -begin - if fSafe.Padding[DIC_TIMESEC].VInteger=0 then - exit; - fTimeOuts.SetCount(fSafe.Padding[DIC_KEYCOUNT].VInteger); - timeout := ComputeNextTimeOut; - for i := 0 to fSafe.Padding[DIC_TIMECOUNT].VInteger-1 do - fTimeOut[i] := timeout; -end; - -function TSynDictionary.DeleteDeprecated: integer; -var i: PtrInt; - now: cardinal; -begin - result := 0; - if (self=nil) or (fSafe.Padding[DIC_TIMECOUNT].VInteger=0) or // no entry - (fSafe.Padding[DIC_TIMESEC].VInteger=0) then // nothing in fTimeOut[] - exit; - now := {$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64 shr 10; - if fSafe.Padding[DIC_TIMETIX].VInteger=integer(now) then - exit; // no need to search more often than every second - fSafe.Lock; - try - fSafe.Padding[DIC_TIMETIX].VInteger := now; - for i := fSafe.Padding[DIC_TIMECOUNT].VInteger-1 downto 0 do - if (now>fTimeOut[i]) and (fTimeOut[i]<>0) and - (not Assigned(fOnCanDelete) or - fOnCanDelete(fKeys.ElemPtr(i)^,fValues.ElemPtr(i)^,i)) then begin - fKeys.Delete(i); - fValues.Delete(i); - fTimeOuts.Delete(i); - inc(result); - end; - if result>0 then - fKeys.Rehash; // mandatory after fKeys.Delete(i) - finally - fSafe.UnLock; - end; -end; - -procedure TSynDictionary.DeleteAll; -begin - if self=nil then - exit; - fSafe.Lock; - try - fKeys.Clear; - fKeys.Hasher.Clear; // mandatory to avoid GPF - fValues.Clear; - if fSafe.Padding[DIC_TIMESEC].VInteger>0 then - fTimeOuts.Clear; - finally - fSafe.UnLock; - end; -end; - -destructor TSynDictionary.Destroy; -begin - fKeys.Clear; - fValues.Clear; - inherited Destroy; -end; - -function TSynDictionary.Add(const aKey, aValue): integer; -var added: boolean; - tim: cardinal; -begin - fSafe.Lock; - try - result := fKeys.FindHashedForAdding(aKey,added); - if added then begin - with fKeys{$ifdef UNDIRECTDYNARRAY}.InternalDynArray{$endif} do - ElemCopyFrom(aKey,result); // fKey[result] := aKey; - if fValues.Add(aValue)<>result then - raise ESynException.CreateUTF8('%.Add fValues.Add',[self]); - tim := ComputeNextTimeOut; - if tim>0 then - fTimeOuts.Add(tim); - end else - result := -1; - finally - fSafe.UnLock; - end; -end; - -function TSynDictionary.AddOrUpdate(const aKey, aValue): integer; -var added: boolean; - tim: cardinal; -begin - fSafe.Lock; - try - tim := ComputeNextTimeOut; - result := fKeys.FindHashedForAdding(aKey,added); - if added then begin - with fKeys{$ifdef UNDIRECTDYNARRAY}.InternalDynArray{$endif} do - ElemCopyFrom(aKey,result); // fKey[result] := aKey - if fValues.Add(aValue)<>result then - raise ESynException.CreateUTF8('%.AddOrUpdate fValues.Add',[self]); - if tim<>0 then - fTimeOuts.Add(tim); - end else begin - fValues.ElemCopyFrom(aValue,result,{ClearBeforeCopy=}true); - if tim<>0 then - fTimeOut[result] := tim; - end; - finally - fSafe.UnLock; - end; -end; - -function TSynDictionary.Clear(const aKey): integer; -begin - fSafe.Lock; - try - result := fKeys.FindHashed(aKey); - if result>=0 then begin - fValues.ElemClear(fValues.ElemPtr(result)^); - if fSafe.Padding[DIC_TIMESEC].VInteger>0 then - fTimeOut[result] := 0; - end; - finally - fSafe.UnLock; - end; -end; - -function TSynDictionary.Delete(const aKey): integer; -begin - fSafe.Lock; - try - result := fKeys.FindHashedAndDelete(aKey); - if result>=0 then begin - fValues.Delete(result); - if fSafe.Padding[DIC_TIMESEC].VInteger>0 then - fTimeOuts.Delete(result); - end; - finally - fSafe.UnLock; - end; -end; - -function TSynDictionary.DeleteAt(aIndex: integer): boolean; -begin - if cardinal(aIndex)tkDynArray) then - raise ESynException.CreateUTF8('%.Values: % items are not dynamic arrays', - [self,fValues.ArrayTypeShort^]); - fSafe.Lock; - try - ndx := fKeys.FindHashed(aKey); - if ndx<0 then - exit; - nested.Init(fValues.ElemType,fValues.ElemPtr(ndx)^); - case aAction of - iaFind: - result := nested.Find(aArrayValue)>=0; - iaFindAndDelete: - result := nested.FindAndDelete(aArrayValue)>=0; - iaFindAndUpdate: - result := nested.FindAndUpdate(aArrayValue)>=0; - iaFindAndAddIfNotExisting: - result := nested.FindAndAddIfNotExisting(aArrayValue)>=0; - iaAdd: - result := nested.Add(aArrayValue)>=0; - end; - finally - fSafe.UnLock; - end; -end; - -function TSynDictionary.FindInArray(const aKey, aArrayValue): boolean; -begin - result := InArray(aKey,aArrayValue,iaFind); -end; - -function TSynDictionary.FindKeyFromValue(const aValue; out aKey; - aUpdateTimeOut: boolean): boolean; -var ndx: integer; -begin - fSafe.Lock; - try - ndx := fValues.IndexOf(aValue); - result := ndx>=0; - if result then begin - fKeys.ElemCopyAt(ndx,aKey); - if aUpdateTimeOut then - SetTimeoutAtIndex(ndx); - end; - finally - fSafe.UnLock; - end; -end; - -function TSynDictionary.DeleteInArray(const aKey, aArrayValue): boolean; -begin - result := InArray(aKey,aArrayValue,iaFindAndDelete); -end; - -function TSynDictionary.UpdateInArray(const aKey, aArrayValue): boolean; -begin - result := InArray(aKey,aArrayValue,iaFindAndUpdate); -end; - -function TSynDictionary.AddInArray(const aKey, aArrayValue): boolean; -begin - result := InArray(aKey,aArrayValue,iaAdd); -end; - -function TSynDictionary.AddOnceInArray(const aKey, aArrayValue): boolean; -begin - result := InArray(aKey,aArrayValue,iaFindAndAddIfNotExisting); -end; - -function TSynDictionary.Find(const aKey; aUpdateTimeOut: boolean): integer; -var tim: cardinal; -begin // caller is expected to call fSafe.Lock/Unlock - if self=nil then - result := -1 else - result := fKeys.FindHashed(aKey); - if aUpdateTimeOut and (result>=0) then begin - tim := fSafe.Padding[DIC_TIMESEC].VInteger; - if tim>0 then // inlined fTimeout[result] := GetTimeout - fTimeout[result] := cardinal({$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64 shr 10)+tim; - end; -end; - -function TSynDictionary.FindValue(const aKey; aUpdateTimeOut: boolean; aIndex: PInteger): pointer; -var ndx: PtrInt; -begin - ndx := Find(aKey,aUpdateTimeOut); - if aIndex<>nil then - aIndex^ := ndx; - if ndx<0 then - result := nil else - result := pointer(PtrUInt(fValues.fValue^)+PtrUInt(ndx)*fValues.ElemSize); -end; - -function TSynDictionary.FindValueOrAdd(const aKey; var added: boolean; - aIndex: PInteger): pointer; -var ndx: integer; - tim: cardinal; -begin - tim := fSafe.Padding[DIC_TIMESEC].VInteger; // inlined tim := GetTimeout - if tim<>0 then - tim := cardinal({$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64 shr 10)+tim; - ndx := fKeys.FindHashedForAdding(aKey,added); - if added then begin - with fKeys{$ifdef UNDIRECTDYNARRAY}.InternalDynArray{$endif} do - ElemCopyFrom(aKey,ndx); // fKey[i] := aKey - fValues.SetCount(ndx+1); // reserve new place for associated value - if tim>0 then - fTimeOuts.Add(tim); - end else - if tim>0 then - fTimeOut[ndx] := tim; - if aIndex<>nil then - aIndex^ := ndx; - result := fValues.ElemPtr(ndx); -end; - -function TSynDictionary.FindAndCopy(const aKey; out aValue; aUpdateTimeOut: boolean): boolean; -var ndx: integer; -begin - fSafe.Lock; - try - ndx := Find(aKey, aUpdateTimeOut); - if ndx>=0 then begin - fValues.ElemCopyAt(ndx,aValue); - result := true; - end else - result := false; - finally - fSafe.UnLock; - end; -end; - -function TSynDictionary.FindAndExtract(const aKey; out aValue): boolean; -var ndx: integer; -begin - fSafe.Lock; - try - ndx := fKeys.FindHashedAndDelete(aKey); - if ndx>=0 then begin - fValues.ElemCopyAt(ndx,aValue); - fValues.Delete(ndx); - if fSafe.Padding[DIC_TIMESEC].VInteger>0 then - fTimeOuts.Delete(ndx); - result := true; - end else - result := false; - finally - fSafe.UnLock; - end; -end; - -function TSynDictionary.Exists(const aKey): boolean; -begin - fSafe.Lock; - try - result := fKeys.FindHashed(aKey)>=0; - finally - fSafe.UnLock; - end; -end; - -{$ifndef DELPHI5OROLDER} -procedure TSynDictionary.CopyValues(out Dest; ObjArrayByRef: boolean); -begin - fSafe.Lock; - try - fValues.CopyTo(Dest,ObjArrayByRef); - finally - fSafe.UnLock; - end; -end; -{$endif DELPHI5OROLDER} - -function TSynDictionary.ForEach(const OnEach: TSynDictionaryEvent; Opaque: pointer): integer; -var k,v: PAnsiChar; - i,n,ks,vs: integer; -begin - result := 0; - fSafe.Lock; - try - n := fSafe.Padding[DIC_KEYCOUNT].VInteger; - if (n=0) or not Assigned(OnEach) then - exit; - k := fKeys.Value^; - ks := fKeys.ElemSize; - v := fValues.Value^; - vs := fValues.ElemSize; - for i := 0 to n-1 do begin - inc(result); - if not OnEach(k^,v^,i,n,Opaque) then - break; - inc(k,ks); - inc(v,vs); - end; - finally - fSafe.UnLock; - end; -end; - -function TSynDictionary.ForEach(const OnMatch: TSynDictionaryEvent; - KeyCompare,ValueCompare: TDynArraySortCompare; const aKey,aValue; - Opaque: pointer): integer; -var k,v: PAnsiChar; - i,n,ks,vs: integer; -begin - fSafe.Lock; - try - result := 0; - if not Assigned(OnMatch) or - (not Assigned(KeyCompare) and not Assigned(ValueCompare)) then - exit; - n := fSafe.Padding[DIC_KEYCOUNT].VInteger; - k := fKeys.Value^; - ks := fKeys.ElemSize; - v := fValues.Value^; - vs := fValues.ElemSize; - for i := 0 to n-1 do begin - if (Assigned(KeyCompare) and (KeyCompare(k^,aKey)=0)) or - (Assigned(ValueCompare) and (ValueCompare(v^,aValue)=0)) then begin - inc(result); - if not OnMatch(k^,v^,i,n,Opaque) then - break; - end; - inc(k,ks); - inc(v,vs); - end; - finally - fSafe.UnLock; - end; -end; - -procedure TSynDictionary.SetTimeoutAtIndex(aIndex: integer); -var tim: cardinal; -begin - if cardinal(aIndex) >= cardinal(fSafe.Padding[DIC_KEYCOUNT].VInteger) then - exit; - tim := fSafe.Padding[DIC_TIMESEC].VInteger; - if tim > 0 then - fTimeOut[aIndex] := cardinal({$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64 shr 10)+tim; -end; - -function TSynDictionary.Count: integer; -begin - {$ifdef NOVARIANTS} - result := RawCount; - {$else} - result := fSafe.LockedInt64[DIC_KEYCOUNT]; - {$endif} -end; - -function TSynDictionary.RawCount: integer; -begin - result := fSafe.Padding[DIC_KEYCOUNT].VInteger; -end; - -procedure TSynDictionary.SaveToJSON(W: TTextWriter; EnumSetsAsText: boolean); -var k,v: RawUTF8; -begin - fSafe.Lock; - try - fKeys.{$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$endif}SaveToJSON(k,EnumSetsAsText); - fValues.SaveToJSON(v,EnumSetsAsText); - finally - fSafe.UnLock; - end; - W.AddJSONArraysAsJSONObject(pointer(k),pointer(v)); -end; - -function TSynDictionary.SaveToJSON(EnumSetsAsText: boolean): RawUTF8; -var W: TTextWriter; - temp: TTextWriterStackBuffer; -begin - W := DefaultTextWriterSerializer.CreateOwnedStream(temp); - try - SaveToJSON(W,EnumSetsAsText); - W.SetText(result); - finally - W.Free; - end; -end; - -function TSynDictionary.SaveValuesToJSON(EnumSetsAsText: boolean): RawUTF8; -begin - fSafe.Lock; - try - fValues.SaveToJSON(result,EnumSetsAsText); - finally - fSafe.UnLock; - end; -end; - -function TSynDictionary.LoadFromJSON(const JSON: RawUTF8 - {$ifndef NOVARIANTS}; CustomVariantOptions: PDocVariantOptions{$endif}): boolean; -begin // pointer(JSON) is not modified in-place thanks to JSONObjectAsJSONArrays() - result := LoadFromJSON(pointer(JSON){$ifndef NOVARIANTS},CustomVariantOptions{$endif}); -end; - -function TSynDictionary.LoadFromJSON(JSON: PUTF8Char{$ifndef NOVARIANTS}; - CustomVariantOptions: PDocVariantOptions{$endif}): boolean; -var k,v: RawUTF8; // private copy of the JSON input, expanded as Keys/Values arrays -begin - result := false; - if not JSONObjectAsJSONArrays(JSON,k,v) then - exit; - fSafe.Lock; - try - if fKeys.LoadFromJSON(pointer(k),nil{$ifndef NOVARIANTS},CustomVariantOptions{$endif})<>nil then - if fValues.LoadFromJSON(pointer(v),nil{$ifndef NOVARIANTS},CustomVariantOptions{$endif})<>nil then - if fKeys.Count=fValues.Count then begin - SetTimeouts; - fKeys.Rehash; // warning: duplicated keys won't be identified - result := true; - end; - finally - fSafe.UnLock; - end; -end; - -function TSynDictionary.LoadFromBinary(const binary: RawByteString): boolean; -var plain: RawByteString; - P,PEnd: PAnsiChar; -begin - result := false; - plain := fCompressAlgo.Decompress(binary); - P := pointer(plain); - if P=nil then - exit; - PEnd := P+length(plain); - fSafe.Lock; - try - P := fKeys.LoadFrom(P,nil,{checkhash=}false,PEnd); - if P<>nil then - P := fValues.LoadFrom(P,nil,{checkhash=}false,PEnd); - if (P<>nil) and (fKeys.Count=fValues.Count) then begin - SetTimeouts; // set ComputeNextTimeOut for all items - fKeys.ReHash; // optimistic: input from safe TSynDictionary.SaveToBinary - result := true; - end; - finally - fSafe.UnLock; - end; -end; - -class function TSynDictionary.OnCanDeleteSynPersistentLock(const aKey, aValue; - aIndex: integer): boolean; -begin - result := not TSynPersistentLock(aValue).Safe^.IsLocked; -end; - -class function TSynDictionary.OnCanDeleteSynPersistentLocked(const aKey, aValue; - aIndex: integer): boolean; -begin - result := not TSynPersistentLock(aValue).Safe.IsLocked; -end; - -function TSynDictionary.SaveToBinary(NoCompression: boolean): RawByteString; -var tmp: TSynTempBuffer; - trigger: integer; -begin - fSafe.Lock; - try - result := ''; - if fSafe.Padding[DIC_KEYCOUNT].VInteger = 0 then - exit; - tmp.Init(fKeys.SaveToLength+fValues.SaveToLength); - if fValues.SaveTo(fKeys.SaveTo(tmp.buf))-PAnsiChar(tmp.buf)=tmp.len then begin - if NoCompression then - trigger := maxInt else - trigger := 128; - result := fCompressAlgo.Compress(tmp.buf,tmp.len,trigger); - end; - tmp.Done; - finally - fSafe.UnLock; - end; -end; - - -{ TMemoryMap } - -function TMemoryMap.Map(aFile: THandle; aCustomSize: PtrUInt; aCustomOffset: Int64): boolean; -var Available: Int64; -begin - fBuf := nil; - fBufSize := 0; - {$ifdef MSWINDOWS} - fMap := 0; - {$endif} - fFileLocal := false; - fFile := aFile; - fFileSize := FileSeek64(fFile,0,soFromEnd); - if fFileSize=0 then begin - result := true; // handle 0 byte file without error (but no memory map) - exit; - end; - result := false; - if (fFileSize<=0) {$ifdef CPU32}or (fFileSize>maxInt){$endif} then - /// maxInt = $7FFFFFFF = 1.999 GB (2GB would induce PtrInt errors) - exit; - if aCustomSize=0 then - fBufSize := fFileSize else begin - Available := fFileSize-aCustomOffset; - if Available<0 then - exit; - if aCustomSize>Available then - fBufSize := Available; - fBufSize := aCustomSize; - end; - {$ifdef MSWINDOWS} - with PInt64Rec(@fFileSize)^ do - fMap := CreateFileMapping(fFile,nil,PAGE_READONLY,Hi,Lo,nil); - if fMap=0 then - raise ESynException.Create('TMemoryMap.Map: CreateFileMapping()=0'); - with PInt64Rec(@aCustomOffset)^ do - fBuf := MapViewOfFile(fMap,FILE_MAP_READ,Hi,Lo,fBufSize); - if fBuf=nil then begin - // Windows failed to find a contiguous VA space -> fall back on direct read - CloseHandle(fMap); - fMap := 0; - {$else} - if aCustomOffset<>0 then - if aCustomOffset and (SystemInfo.dwPageSize-1)<>0 then - raise ESynException.CreateUTF8('fpmmap(aCustomOffset=%) with SystemInfo.dwPageSize=%', - [aCustomOffset,SystemInfo.dwPageSize]) else - aCustomOffset := aCustomOffset div SystemInfo.dwPageSize; - fBuf := {$ifdef KYLIX3}mmap{$else}fpmmap{$endif}( - nil,fBufSize,PROT_READ,MAP_SHARED,fFile,aCustomOffset); - if fBuf=MAP_FAILED then begin - fBuf := nil; - {$endif} - end else - result := true; -end; - -procedure TMemoryMap.Map(aBuffer: pointer; aBufferSize: PtrUInt); -begin - fBuf := aBuffer; - fFileSize := aBufferSize; - fBufSize := aBufferSize; - {$ifdef MSWINDOWS} - fMap := 0; - {$endif} - fFile := 0; - fFileLocal := false; -end; - -function TMemoryMap.Map(const aFileName: TFileName): boolean; -var F: THandle; -begin - result := false; - // Memory-mapped file access does not go through the cache manager so - // using FileOpenSequentialRead() is pointless here - F := FileOpen(aFileName,fmOpenRead or fmShareDenyNone); - if PtrInt(F)<0 then - exit; - if Map(F) then - result := true else - FileClose(F); - fFileLocal := result; -end; - -procedure TMemoryMap.UnMap; -begin - {$ifdef MSWINDOWS} - if fMap<>0 then begin - UnmapViewOfFile(fBuf); - CloseHandle(fMap); - fMap := 0; - end; - {$else} - if (fBuf<>nil) and (fBufSize>0) and (fFile<>0) then - {$ifdef KYLIX3}munmap{$else}fpmunmap{$endif}(fBuf,fBufSize); - {$endif} - fBuf := nil; - fBufSize := 0; - if fFile<>0 then begin - if fFileLocal then - FileClose(fFile); - fFile := 0; - end; -end; - - -{ TSynMemoryStream } - -constructor TSynMemoryStream.Create(const aText: RawByteString); -begin - inherited Create; - SetPointer(pointer(aText),length(aText)); -end; - -constructor TSynMemoryStream.Create(Data: pointer; DataLen: PtrInt); -begin - inherited Create; - SetPointer(Data,DataLen); -end; - -function TSynMemoryStream.Write(const Buffer; Count: Integer): Longint; -begin - {$ifdef FPC} - result := 0; // makes FPC compiler happy - {$endif} - raise EStreamError.CreateFmt('Unexpected %s.Write',[ClassNameShort(self)^]); -end; - - -{ TSynMemoryStreamMapped } - -constructor TSynMemoryStreamMapped.Create(const aFileName: TFileName; - aCustomSize: PtrUInt; aCustomOffset: Int64); -begin - fFileName := aFileName; - // Memory-mapped file access does not go through the cache manager so - // using FileOpenSequentialRead() is pointless here - fFileStream := TFileStream.Create(aFileName,fmOpenRead or fmShareDenyNone); - Create(fFileStream.Handle,aCustomSize,aCustomOffset); -end; - -constructor TSynMemoryStreamMapped.Create(aFile: THandle; - aCustomSize: PtrUInt; aCustomOffset: Int64); -begin - if not fMap.Map(aFile,aCustomSize,aCustomOffset) then - raise ESynException.CreateUTF8('%.Create(%) mapping error',[self,fFileName]); - inherited Create(fMap.fBuf,fMap.fBufSize); -end; - -destructor TSynMemoryStreamMapped.Destroy; -begin - fMap.UnMap; - fFileStream.Free; - inherited; -end; - -function FileSeek64(Handle: THandle; const Offset: Int64; Origin: DWORD): Int64; -{$ifdef MSWINDOWS} -var R64: packed record Lo, Hi: integer; end absolute Result; -begin - Result := Offset; - R64.Lo := integer(SetFilePointer(Handle,R64.Lo,@R64.Hi,Origin)); - if (R64.Lo=-1) and (GetLastError<>0) then - R64.Hi := -1; // so result=-1 -end; -{$else} -begin - {$ifdef FPC} - result := FPLSeek(Handle,Offset,Origin); - {$else} - {$ifdef KYLIX3} - result := LibC.lseek64(Handle,Offset,Origin); - {$else} - // warning: this won't handle file size > 2 GB :( - result := FileSeek(Handle,Offset,Origin); - {$endif} - {$endif} -end; -{$endif} - -function PropNameValid(P: PUTF8Char): boolean; -var tab: PTextCharSet; -begin - result := false; - tab := @TEXT_CHARS; - if (P=nil) or not (tcIdentifierFirstChar in tab[P^]) then - exit; // first char must be alphabetical - repeat - inc(P); // following chars can be alphanumerical - if tcIdentifier in tab[P^] then - continue; - if P^=#0 then - break; - exit; - until false; - result := true; -end; - -function PropNamesValid(const Values: array of RawUTF8): boolean; -var i,j: integer; - tab: PTextCharSet; -begin - result := false; - tab := @TEXT_CHARS; - for i := 0 to high(Values) do - for j := 1 to length(Values[i]) do - if not (tcIdentifier in tab[Values[i][j]]) then - exit; - result := true; -end; - -function JsonPropNameValid(P: PUTF8Char): boolean; -var tab: PJsonCharSet; -begin - tab := @JSON_CHARS; - if (P<>nil) and (jcJsonIdentifierFirstChar in tab[P^]) then begin - repeat - inc(P); - until not(jcJsonIdentifier in tab[P^]); - result := P^ = #0; - end else - result := false; -end; - -function StrCompL(P1,P2: PUTF8Char; L, Default: Integer): PtrInt; -var i: PtrInt; -begin - i := 0; - repeat - result := PtrInt(P1[i])-PtrInt(P2[i]); - if result=0 then begin - inc(i); - if inil then begin - f := PInt64(FieldName)^; - result := (f and $ffdfdf=(ord('I')+ord('D')shl 8)) or (f and $ffdfdfdfdfdf= - (ord('R')+ord('O')shl 8+ord('W')shl 16+ord('I')shl 24+Int64(ord('D')) shl 32)) - end -{$else} -begin - if FieldName<>nil then - result := (PInteger(FieldName)^ and $ffdfdf=ord('I')+ord('D')shl 8) or - ((PIntegerArray(FieldName)^[0] and $dfdfdfdf= - ord('R')+ord('O')shl 8+ord('W')shl 16+ord('I')shl 24) and - (PIntegerArray(FieldName)^[1] and $ffdf=ord('D'))) -{$endif} else result := false; -end; - -function IsRowID(FieldName: PUTF8Char; FieldLen: integer): boolean; -begin - case FieldLen of - 2: result := - PWord(FieldName)^ and $dfdf=ord('I')+ord('D')shl 8; - 5: result := - (PInteger(FieldName)^ and $dfdfdfdf= - ord('R')+ord('O')shl 8+ord('W')shl 16+ord('I')shl 24) and - (ord(FieldName[4]) and $df=ord('D')); - else result := false; - end; -end; - -function IsRowIDShort(const FieldName: shortstring): boolean; -begin - result := - (PInteger(@FieldName)^ and $DFDFFF= - 2+ord('I')shl 8+ord('D')shl 16) or - ((PIntegerArray(@FieldName)^[0] and $dfdfdfff= - 5+ord('R')shl 8+ord('O')shl 16+ord('W')shl 24) and - (PIntegerArray(@FieldName)^[1] and $dfdf= - ord('I')+ord('D')shl 8)); -end; - -function GotoNextSqlIdentifier(P: PUtf8Char; tab: PTextCharSet): PUtf8Char; - {$ifdef HASINLINE} inline; {$endif} -begin - while tcCtrlNot0Comma in tab[P^] do inc(P); // in [#1..' ', ';'] - if PWord(P)^=ord('/')+ord('*') shl 8 then begin // ignore e.g. '/*nocache*/' - repeat - inc(P); - if PWord(P)^ = ord('*')+ord('/') shl 8 then begin - inc(P, 2); - break; - end; - until P^ = #0; - while tcCtrlNot0Comma in tab[P^] do inc(P); - end; - result := P; -end; - -function GetNextFieldProp(var P: PUTF8Char; var Prop: RawUTF8): boolean; -var B: PUTF8Char; - tab: PTextCharSet; -begin - tab := @TEXT_CHARS; - P := GotoNextSqlIdentifier(P, tab); - B := P; - while tcIdentifier in tab[P^] do inc(P); // go to end of field name - FastSetString(Prop,B,P-B); - P := GotoNextSqlIdentifier(P, tab); - result := Prop<>''; -end; - -function GetNextFieldPropSameLine(var P: PUTF8Char; var Prop: ShortString): boolean; -var B: PUTF8Char; - tab: PTextCharSet; -begin - tab := @TEXT_CHARS; - while tcCtrlNotLF in tab[P^] do inc(P); - B := P; - while tcIdentifier in tab[P^] do inc(P); // go to end of field name - SetString(Prop,PAnsiChar(B),P-B); - while tcCtrlNotLF in TEXT_CHARS[P^] do inc(P); - result := Prop<>''; -end; - - -type - TSynLZHead = packed record - Magic: cardinal; - CompressedSize: integer; - HashCompressed: cardinal; - UnCompressedSize: integer; - HashUncompressed: cardinal; - end; - PSynLZHead = ^TSynLZHead; - TSynLZTrailer = packed record - HeaderRelativeOffset: cardinal; - Magic: cardinal; - end; - PSynLZTrailer = ^TSynLZTrailer; - -function StreamSynLZComputeLen(P: PAnsiChar; Len, aMagic: cardinal): integer; -begin - if (P=nil) or (Len<=SizeOf(TSynLZTrailer)) then - result := 0 else - with PSynLZTrailer(P+Len-SizeOf(TSynLZTrailer))^ do - if (Magic=aMagic) and (HeaderRelativeOffset0 then // '' is compressed and uncompressed to '' - if Compress then begin - len := SynLZcompressdestlen(DataLen)+8; - SetString(result,nil,len); - P := pointer(result); - PCardinal(P)^ := Hash32(pointer(Data),DataLen); - len := SynLZcompress1(pointer(Data),DataLen,P+8); - PCardinal(P+4)^ := Hash32(pointer(P+8),len); - SetString(Data,P,len+8); - end else begin - result := ''; - P := pointer(Data); - if (DataLen<=8) or (Hash32(pointer(P+8),DataLen-8)<>PCardinal(P+4)^) then - exit; - len := SynLZdecompressdestlen(P+8); - SetLength(result,len); - if (len<>0) and ((SynLZDecompress1(P+8,DataLen-8,pointer(result))<>len) or - (Hash32(pointer(result),len)<>PCardinal(P)^)) then begin - result := ''; - exit; - end else - SetString(Data,PAnsiChar(pointer(result)),len); - end; - result := 'synlz'; -end; - -function StreamSynLZ(Source: TCustomMemoryStream; Dest: TStream; Magic: cardinal): integer; -var DataLen: integer; - S,D: pointer; - Head: TSynLZHead; - Trailer: TSynLZTrailer; - tmp: TSynTempBuffer; -begin - if Dest=nil then begin - result := 0; - exit; - end; - if Source<>nil then begin - S := Source.Memory; - DataLen := Source.Size; - end else begin - S := nil; - DataLen := 0; - end; - tmp.Init(SynLZcompressdestlen(DataLen)); - try - Head.Magic := Magic; - Head.UnCompressedSize := DataLen; - Head.HashUncompressed := Hash32(S,DataLen); - result := SynLZcompress1(S,DataLen,tmp.buf); - if result>tmp.len then - raise ESynException.Create('StreamLZ: SynLZ compression overflow'); - if result>DataLen then begin - result := DataLen; // compression not worth it - D := S; - end else - D := tmp.buf; - Head.CompressedSize := result; - Head.HashCompressed := Hash32(D,result); - Dest.WriteBuffer(Head,SizeOf(Head)); - Dest.WriteBuffer(D^,Head.CompressedSize); - Trailer.HeaderRelativeOffset := result+(SizeOf(Head)+SizeOf(Trailer)); - Trailer.Magic := Magic; - Dest.WriteBuffer(Trailer,SizeOf(Trailer)); - result := Head.CompressedSize+(SizeOf(Head)+SizeOf(Trailer)); - finally - tmp.Done; - end; -end; - -function StreamSynLZ(Source: TCustomMemoryStream; const DestFile: TFileName; - Magic: cardinal): integer; -var F: TFileStream; -begin - F := TFileStream.Create(DestFile,fmCreate); - try - result := StreamSynLZ(Source,F,Magic); - finally - F.Free; - end; -end; - -function FileSynLZ(const Source, Dest: TFileName; Magic: Cardinal): boolean; -var src,dst: RawByteString; - S,D: THandleStream; - Head: TSynLZHead; - Count,Max: Int64; -begin - result := false; - if FileExists(Source) then - try - S := FileStreamSequentialRead(Source); - try - DeleteFile(Dest); - Max := 128 shl 20; // 128 MB default compression chunk - D := TFileStream.Create(Dest,fmCreate); - try - Head.Magic := Magic; - Count := S.Size; - while Count>0 do begin - if Count>Max then - Head.UnCompressedSize := Max else - Head.UnCompressedSize := Count; - if src='' then - SetString(src,nil,Head.UnCompressedSize); - if dst='' then - SetString(dst,nil,SynLZcompressdestlen(Head.UnCompressedSize)); - Head.UnCompressedSize := S.Read(pointer(src)^,Head.UnCompressedSize); - {$ifdef MSWINDOWS} - if (Head.UnCompressedSize<=0) and - (GetLastError=ERROR_NO_SYSTEM_RESOURCES) then begin - Max := 32 shl 20; // we observed a 32MB chunk size limitation on XP - Head.UnCompressedSize := S.Read(pointer(src)^,Max); - end; - {$endif MSWINDOWS} - if Head.UnCompressedSize<=0 then - exit; // read error - Head.HashUncompressed := Hash32(pointer(src),Head.UnCompressedSize); - Head.CompressedSize := - SynLZcompress1(pointer(src),Head.UnCompressedSize,pointer(dst)); - Head.HashCompressed := Hash32(pointer(dst),Head.CompressedSize); - if (D.Write(Head,SizeOf(Head))<>SizeOf(Head)) or - (D.Write(pointer(dst)^,Head.CompressedSize)<>Head.CompressedSize) then - exit; - dec(Count,Head.UnCompressedSize); - end; - finally - D.Free; - end; - result := FileSetDateFrom(Dest,S.Handle); - finally - S.Free; - end; - except - on Exception do - result := false; - end; -end; - -function FileUnSynLZ(const Source, Dest: TFileName; Magic: Cardinal): boolean; -var src,dst: RawByteString; - S,D: THandleStream; - Count: Int64; - Head: TSynLZHead; -begin - result := false; - if FileExists(Source) then - try - S := FileStreamSequentialRead(Source); - try - DeleteFile(Dest); - D := TFileStream.Create(Dest,fmCreate); - try - Count := S.Size; - while Count>0 do begin - if S.Read(Head,SizeOf(Head))<>SizeOf(Head) then - exit; - dec(Count,SizeOf(Head)); - if (Head.Magic<>Magic) or - (Head.CompressedSize>Count) then - exit; - if Head.CompressedSize>length(src) then - SetString(src,nil,Head.CompressedSize); - if S.Read(pointer(src)^,Head.CompressedSize)<>Head.CompressedSize then - exit; - dec(Count,Head.CompressedSize); - if (Hash32(pointer(src),Head.CompressedSize)<>Head.HashCompressed) or - (SynLZdecompressdestlen(pointer(src))<>Head.UnCompressedSize) then - exit; - if Head.UnCompressedSize>length(dst) then - SetString(dst,nil,Head.UnCompressedSize); - if (SynLZDecompress1(pointer(src),Head.CompressedSize,pointer(dst))<>Head.UnCompressedSize) or - (Hash32(pointer(dst),Head.UnCompressedSize)<>Head.HashUncompressed) then - exit; - if D.Write(pointer(dst)^,Head.UncompressedSize)<>Head.UncompressedSize then - exit; - end; - finally - D.Free; - end; - result := FileSetDateFrom(Dest,S.Handle); - finally - S.Free; - end; - except - on Exception do - result := false; - end; -end; - -function FileIsSynLZ(const Name: TFileName; Magic: Cardinal): boolean; -var S: TFileStream; - Head: TSynLZHead; -begin - result := false; - if FileExists(Name) then - try - S := TFileStream.Create(Name,fmOpenRead or fmShareDenyNone); - try - if S.Read(Head,SizeOf(Head))=SizeOf(Head) then - if Head.Magic=Magic then - result := true; // only check magic, since there may be several chunks - finally - S.Free; - end; - except - on Exception do - result := false; - end; -end; - -function StreamUnSynLZ(const Source: TFileName; Magic: cardinal): TMemoryStream; -var S: TStream; -begin - try - S := TSynMemoryStreamMapped.Create(Source); - try - result := StreamUnSynLZ(S,Magic); - finally - S.Free; - end; - except - on E: Exception do - result := nil; - end; -end; - -function StreamUnSynLZ(Source: TStream; Magic: cardinal): TMemoryStream; -var S,D: PAnsiChar; - sourcePosition,resultSize,sourceSize: Int64; - Head: TSynLZHead; - Trailer: TSynLZTrailer; - buf: RawByteString; - stored: boolean; -begin - result := nil; - if Source=nil then - exit; - sourceSize := Source.Size; - {$ifndef CPU64} - if sourceSize>maxInt then - exit; // result TMemoryStream should stay in memory! - {$endif} - sourcePosition := Source.Position; - if sourceSize-sourcePositionSizeOf(Head)) or - (Head.Magic<>Magic) then begin - // Source not positioned as expected -> try from the end - Source.Position := sourceSize-SizeOf(Trailer); - if (Source.Read(Trailer,SizeOf(Trailer))<>SizeOf(Trailer)) or - (Trailer.Magic<>Magic) then - exit; - sourcePosition := sourceSize-Trailer.HeaderRelativeOffset; - Source.Position := sourcePosition; - if (Source.Read(Head,SizeOf(Head))<>SizeOf(Head)) or - (Head.Magic<>Magic) then - exit; - end; - inc(sourcePosition,SizeOf(Head)); - if sourcePosition+Head.CompressedSize>sourceSize then - exit; - if Source.InheritsFrom(TCustomMemoryStream) then begin - S := PAnsiChar(TCustomMemoryStream(Source).Memory)+PtrUInt(sourcePosition); - Source.Seek(Head.CompressedSize,soCurrent); - end else begin - if Head.CompressedSize>length(Buf) then - SetString(Buf,nil,Head.CompressedSize); - S := pointer(Buf); - Source.Read(S^,Head.CompressedSize); - end; - inc(sourcePosition,Head.CompressedSize); - if (Source.Read(Trailer,SizeOf(Trailer))<>SizeOf(Trailer)) or - (Trailer.Magic<>Magic) then - // trailer not available in old .synlz layout, or in FileSynLZ multiblocks - Source.Position := sourcePosition else - sourceSize := 0; // should be monoblock - // Source stream will now point after all data - stored := (Head.CompressedSize=Head.UnCompressedSize) and - (Head.HashCompressed=Head.HashUncompressed); - if not stored then - if SynLZdecompressdestlen(S)<>Head.UnCompressedSize then - exit; - if Hash32(pointer(S),Head.CompressedSize)<>Head.HashCompressed then - exit; - if result=nil then - result := THeapMemoryStream.Create else begin - {$ifndef CPU64} - if resultSize+Head.UnCompressedSize>maxInt then begin - FreeAndNil(result); // result TMemoryStream should stay in memory! - break; - end; - {$endif CPU64} - end; - result.Size := resultSize+Head.UnCompressedSize; - D := PAnsiChar(result.Memory)+resultSize; - inc(resultSize,Head.UnCompressedSize); - if stored then - MoveFast(S^,D^,Head.CompressedSize) else - if SynLZDecompress1(S,Head.CompressedSize,D)<>Head.UnCompressedSize then - FreeAndNil(result) else - if Hash32(pointer(D),Head.UnCompressedSize)<>Head.HashUncompressed then - FreeAndNil(result); - until (result=nil) or (sourcePosition>=sourceSize); -end; - - -{ TAlgoCompress } - -const - COMPRESS_STORED = #0; - COMPRESS_SYNLZ = 1; - -var - SynCompressAlgos: TSynObjectList; - -constructor TAlgoCompress.Create; -var existing: TAlgoCompress; -begin - inherited Create; - if SynCompressAlgos=nil then - GarbageCollectorFreeAndNil(SynCompressAlgos,TSynObjectList.Create) else begin - existing := Algo(AlgoID); - if existing<>nil then - raise ESynException.CreateUTF8('%.Create: AlgoID=% already registered by %', - [self,AlgoID,existing.ClassType]); - end; - SynCompressAlgos.Add(self); -end; - -class function TAlgoCompress.Algo(const Comp: RawByteString): TAlgoCompress; -begin - result := Algo(Pointer(Comp),Length(Comp)); -end; - -class function TAlgoCompress.Algo(const Comp: TByteDynArray): TAlgoCompress; -begin - result := Algo(Pointer(Comp),Length(Comp)); -end; - -class function TAlgoCompress.Algo(Comp: PAnsiChar; CompLen: integer): TAlgoCompress; -begin - if (Comp<>nil) and (CompLen>9) then - if ord(Comp[4])<=1 then // inline-friendly Comp[4]<=COMPRESS_SYNLZ - result := AlgoSynLZ else // COMPRESS_STORED is also handled as SynLZ - result := Algo(ord(Comp[4])) else - result := nil; -end; - -class function TAlgoCompress.Algo(Comp: PAnsiChar; CompLen: integer; out IsStored: boolean): TAlgoCompress; -begin - if (Comp<>nil) and (CompLen>9) then begin - IsStored := Comp[4]=COMPRESS_STORED; - result := Algo(ord(Comp[4])); - end else begin - IsStored := false; - result := nil; - end; -end; - -class function TAlgoCompress.Algo(AlgoID: byte): TAlgoCompress; -var i: integer; - ptr: ^TAlgoCompress; -begin - if AlgoID<=COMPRESS_SYNLZ then // COMPRESS_STORED is handled as SynLZ - result := AlgoSynLZ else begin - if SynCompressAlgos<>nil then begin - ptr := pointer(SynCompressAlgos.List); - inc(ptr); // ignore List[0] = AlgoSynLZ - for i := 2 to SynCompressAlgos.Count do - if ptr^.AlgoID=AlgoID then begin - result := ptr^; - exit; - end - else - inc(ptr); - end; - result := nil; - end; -end; - -class function TAlgoCompress.UncompressedSize(const Comp: RawByteString): integer; -begin - result := Algo(Comp).DecompressHeader(pointer(Comp),length(Comp)); -end; - -function TAlgoCompress.AlgoName: TShort16; -var s: PShortString; - i: integer; -begin - if self=nil then - result := 'none' else begin - s := ClassNameShort(self); - if IdemPChar(@s^[1],'TALGO') then begin - result[0] := AnsiChar(ord(s^[0])-5); - inc(PByte(s),5); - end else - result[0] := s^[0]; - if result[0]>#16 then - result[0] := #16; - for i := 1 to ord(result[0]) do - result[i] := NormToLower[s^[i]]; - end; -end; - -function TAlgoCompress.AlgoHash(Previous: cardinal; Data: pointer; DataLen: integer): cardinal; -begin - result := crc32c(Previous,Data,DataLen); -end; - -function TAlgoCompress.Compress(const Plain: RawByteString; CompressionSizeTrigger: integer; - CheckMagicForCompressed: boolean; BufferOffset: integer): RawByteString; -begin - result := Compress(pointer(Plain),Length(Plain),CompressionSizeTrigger, - CheckMagicForCompressed,BufferOffset); -end; - -function TAlgoCompress.Compress(Plain: PAnsiChar; PlainLen: integer; CompressionSizeTrigger: integer; - CheckMagicForCompressed: boolean; BufferOffset: integer): RawByteString; -var len: integer; - R: PAnsiChar; - crc: cardinal; - tmp: array[0..16383] of AnsiChar; // big enough to resize Result in-place -begin - if (self=nil) or (PlainLen=0) or (Plain=nil) then begin - result := ''; - exit; - end; - crc := AlgoHash(0,Plain,PlainLen); - if (PlainLenSizeOf(tmp) then begin - SetString(result,nil,len); - R := pointer(result); - end else - R := @tmp; - inc(R,BufferOffset); - PCardinal(R)^ := crc; - len := AlgoCompress(Plain,PlainLen,R+9); - if len+64>=PlainLen then begin // store if compression was not worth it - R[4] := COMPRESS_STORED; - PCardinal(R+5)^ := crc; - MoveFast(Plain^,R[9],PlainLen); - len := PlainLen; - end else begin - R[4] := AnsiChar(AlgoID); - PCardinal(R+5)^ := AlgoHash(0,R+9,len); - end; - if R=@tmp[BufferOffset] then - SetString(result,tmp,len+BufferOffset+9) else - SetLength(result,len+BufferOffset+9); // MM may not move the data - end; -end; - -function TAlgoCompress.Compress(Plain, Comp: PAnsiChar; PlainLen, CompLen: integer; - CompressionSizeTrigger: integer; CheckMagicForCompressed: boolean): integer; -var len: integer; -begin - result := 0; - if (self=nil) or (PlainLen=0) or (CompLen=CompressionSizeTrigger) and - not(CheckMagicForCompressed and IsContentCompressed(Plain,PlainLen)) then begin - len := CompressDestLen(PlainLen); - if CompLen=PlainLen then begin // store if compression not worth it - R[4] := COMPRESS_STORED; - PCardinal(R+5)^ := crc; - MoveFast(Plain^,R[9],PlainLen); - len := PlainLen; - end else begin - R[4] := AnsiChar(AlgoID); - PCardinal(R+5)^ := AlgoHash(0,R+9,len); - end; - SetLength(result,len+9); - end; -end; - -function TAlgoCompress.CompressToBytes(const Plain: RawByteString; - CompressionSizeTrigger: integer; CheckMagicForCompressed: boolean): TByteDynArray; -begin - result := CompressToBytes(pointer(Plain),Length(Plain), - CompressionSizeTrigger,CheckMagicForCompressed); -end; - -function TAlgoCompress.Decompress(const Comp: TByteDynArray): RawByteString; -begin - Decompress(pointer(Comp),length(Comp),result); -end; - -procedure TAlgoCompress.Decompress(Comp: PAnsiChar; CompLen: integer; - out Result: RawByteString; Load: TAlgoCompressLoad; BufferOffset: integer); -var len: integer; - dec: PAnsiChar; -begin - len := DecompressHeader(Comp,CompLen,Load); - if len=0 then - exit; - SetString(result,nil,len+BufferOffset); - dec := pointer(result); - if not DecompressBody(Comp,dec+BufferOffset,CompLen,len,Load) then - result := ''; -end; - -function TAlgoCompress.Decompress(const Comp: RawByteString; - Load: TAlgoCompressLoad; BufferOffset: integer): RawByteString; -begin - Decompress(pointer(Comp),length(Comp),result,Load,BufferOffset); -end; - -function TAlgoCompress.TryDecompress(const Comp: RawByteString; - out Dest: RawByteString; Load: TAlgoCompressLoad): boolean; -var len: integer; -begin - result := Comp=''; - if result then - exit; - len := DecompressHeader(pointer(Comp),length(Comp),Load); - if len=0 then - exit; // invalid crc32c - SetString(Dest,nil,len); - if DecompressBody(pointer(Comp),pointer(Dest),length(Comp),len,Load) then - result := true else - Dest := ''; -end; - -function TAlgoCompress.Decompress(const Comp: RawByteString; - out PlainLen: integer; var tmp: RawByteString; Load: TAlgoCompressLoad): pointer; -begin - result := Decompress(pointer(Comp),length(Comp),PlainLen,tmp,Load); -end; - -function TAlgoCompress.Decompress(Comp: PAnsiChar; CompLen: integer; - out PlainLen: integer; var tmp: RawByteString; Load: TAlgoCompressLoad): pointer; -begin - result := nil; - PlainLen := DecompressHeader(Comp,CompLen,Load); - if PlainLen=0 then - exit; - if Comp[4]=COMPRESS_STORED then - result := Comp+9 else begin - if PlainLen > length(tmp) then - SetString(tmp,nil,PlainLen); - if DecompressBody(Comp,pointer(tmp),CompLen,PlainLen,Load) then - result := pointer(tmp); - end; -end; - -function TAlgoCompress.DecompressPartial(Comp, Partial: PAnsiChar; - CompLen, PartialLen, PartialLenMax: integer): integer; -var BodyLen: integer; -begin - result := 0; - if (self=nil) or (CompLen<=9) or (Comp=nil) or (PartialLenMaxBodyLen then - PartialLen := BodyLen; - if Comp[4]=COMPRESS_STORED then - MoveFast(Comp[9],Partial[0],PartialLen) else - if AlgoDecompressPartial(Comp+9,CompLen-9,Partial,PartialLen,PartialLenMax)aclNoCrcFast) and (AlgoHash(0,Comp+9,CompLen-9)<>PCardinal(Comp+5)^)) then - exit; - if Comp[4]=COMPRESS_STORED then begin - if PCardinal(Comp)^=PCardinal(Comp+5)^ then - result := CompLen-9; - end else - if Comp[4]=AnsiChar(AlgoID) then - result := AlgoDecompressDestLen(Comp+9); -end; - -function TAlgoCompress.DecompressBody(Comp, Plain: PAnsiChar; - CompLen, PlainLen: integer; Load: TAlgoCompressLoad): boolean; -begin - result := false; - if (self=nil) or (PlainLen<=0) then - exit; - if Comp[4]=COMPRESS_STORED then - MoveFast(Comp[9],Plain[0],PlainLen) else - if Comp[4]=AnsiChar(AlgoID) then - case Load of - aclNormal: - if (AlgoDecompress(Comp+9,CompLen-9,Plain)<>PlainLen) or - (AlgoHash(0,Plain,PlainLen)<>PCardinal(Comp)^) then - exit; - aclSafeSlow: - if (AlgoDecompressPartial(Comp+9,CompLen-9,Plain,PlainLen,PlainLen)<>PlainLen) or - (AlgoHash(0,Plain,PlainLen)<>PCardinal(Comp)^) then - exit; - aclNoCrcFast: - if (AlgoDecompress(Comp+9,CompLen-9,Plain)<>PlainLen) then - exit; - end; - result := true; -end; - - -{ TAlgoSynLZ } - -function TAlgoSynLZ.AlgoID: byte; -begin - result := COMPRESS_SYNLZ; // =1 -end; - -function TAlgoSynLZ.AlgoCompress(Plain: pointer; PlainLen: integer; - Comp: pointer): integer; -begin - result := SynLZcompress1(Plain,PlainLen,Comp); -end; - -function TAlgoSynLZ.AlgoCompressDestLen(PlainLen: integer): integer; -begin - result := SynLZcompressdestlen(PlainLen); -end; - -function TAlgoSynLZ.AlgoDecompress(Comp: pointer; CompLen: integer; - Plain: pointer): integer; -begin - result := SynLZdecompress1(Comp,CompLen,Plain); -end; - -function TAlgoSynLZ.AlgoDecompressDestLen(Comp: pointer): integer; -begin - result := SynLZdecompressdestlen(Comp); -end; - -function TAlgoSynLZ.AlgoDecompressPartial(Comp: pointer; - CompLen: integer; Partial: pointer; PartialLen, PartialLenMax: integer): integer; -begin - result := SynLZdecompress1partial(Comp,CompLen,Partial,PartialLen); -end; - -// deprecated wrapper methods - use SynLZ global variable instead - -function SynLZCompress(const Data: RawByteString; CompressionSizeTrigger: integer; - CheckMagicForCompressed: boolean): RawByteString; -begin - result := AlgoSynLZ.Compress(pointer(Data),length(Data),CompressionSizeTrigger, - CheckMagicForCompressed); -end; - -procedure SynLZCompress(P: PAnsiChar; PLen: integer; out Result: RawByteString; - CompressionSizeTrigger: integer; CheckMagicForCompressed: boolean); -begin - result := AlgoSynLZ.Compress(P,PLen,CompressionSizeTrigger,CheckMagicForCompressed); -end; - -function SynLZCompress(P, Dest: PAnsiChar; PLen, DestLen: integer; - CompressionSizeTrigger: integer; CheckMagicForCompressed: boolean): integer; -begin - result := AlgoSynLZ.Compress(P,Dest,PLen,DestLen,CompressionSizeTrigger,CheckMagicForCompressed); -end; - -function SynLZDecompress(const Data: RawByteString): RawByteString; -begin - AlgoSynLZ.Decompress(pointer(Data),Length(Data),result); -end; - -function SynLZDecompressHeader(P: PAnsiChar; PLen: integer): integer; -begin - result := AlgoSynLZ.DecompressHeader(P,PLen); -end; - -function SynLZDecompressBody(P,Body: PAnsiChar; PLen,BodyLen: integer; - SafeDecompression: boolean): boolean; -begin - result := AlgoSynLZ.DecompressBody(P,Body,PLen,BodyLen,ALGO_SAFE[SafeDecompression]); -end; - -function SynLZDecompressPartial(P,Partial: PAnsiChar; PLen,PartialLen: integer): integer; -begin - result := AlgoSynLZ.DecompressPartial(P,Partial,PLen,PartialLen,PartialLen); -end; - -procedure SynLZDecompress(P: PAnsiChar; PLen: integer; out Result: RawByteString; - SafeDecompression: boolean); -begin - AlgoSynLZ.Decompress(P,PLen,Result); -end; - -function SynLZDecompress(const Data: RawByteString; out Len: integer; - var tmp: RawByteString): pointer; -begin - result := AlgoSynLZ.Decompress(pointer(Data),length(Data),Len,tmp); -end; - -function SynLZDecompress(P: PAnsiChar; PLen: integer; out Len: integer; - var tmp: RawByteString): pointer; -begin - result := AlgoSynLZ.Decompress(P,PLen,Len,tmp); -end; - -function SynLZCompressToBytes(const Data: RawByteString; - CompressionSizeTrigger: integer): TByteDynArray; -begin - result := AlgoSynLZ.CompressToBytes(pointer(Data),length(Data),CompressionSizeTrigger); -end; - -function SynLZCompressToBytes(P: PAnsiChar; PLen,CompressionSizeTrigger: integer): TByteDynArray; -begin - result := AlgoSynLZ.CompressToBytes(P,PLen,CompressionSizeTrigger); -end; - -function SynLZDecompress(const Data: TByteDynArray): RawByteString; -begin - AlgoSynLZ.Decompress(pointer(Data),length(Data),result); -end; - - -{ TAlgoCompressWithNoDestLen } - -function TAlgoCompressWithNoDestLen.AlgoCompress(Plain: pointer; - PlainLen: integer; Comp: pointer): integer; -begin - Comp := ToVarUInt32(PlainLen,Comp); // deflate don't store PlainLen - result := RawProcess(Plain,Comp,PlainLen,AlgoCompressDestLen(PlainLen),0,doCompress); - if result>0 then - inc(result,ToVarUInt32Length(PlainLen)); -end; - -function TAlgoCompressWithNoDestLen.AlgoDecompress(Comp: pointer; - CompLen: integer; Plain: pointer): integer; -var start: PAnsiChar; -begin - start := Comp; - result := FromVarUInt32(PByte(Comp)); - if RawProcess(Comp,Plain,CompLen+(Start-Comp),result,0,doUnCompress)<>result then - result := 0; -end; - -function TAlgoCompressWithNoDestLen.AlgoDecompressDestLen(Comp: pointer): integer; -begin - if Comp=nil then - result := 0 else - result := FromVarUInt32(PByte(Comp)); -end; - -function TAlgoCompressWithNoDestLen.AlgoDecompressPartial(Comp: pointer; - CompLen: integer; Partial: pointer; PartialLen, PartialLenMax: integer): integer; -var start: PAnsiChar; -begin - start := Comp; - result := FromVarUInt32(PByte(Comp)); - if PartialLenMax>result then - PartialLenMax := result; - result := RawProcess(Comp,Partial,CompLen+(Start-Comp),PartialLen,PartialLenMax,doUncompressPartial); -end; - - -{ ESynException } - -constructor ESynException.CreateUTF8(const Format: RawUTF8; const Args: array of const); -var msg: string; -begin - FormatString(Format,Args,msg); - inherited Create(msg); -end; - -constructor ESynException.CreateLastOSError( - const Format: RawUTF8; const Args: array of const; const Trailer: RawUtf8); -var tmp: RawUTF8; - error: integer; -begin - error := GetLastError; - FormatUTF8(Format,Args,tmp); - CreateUTF8('% % [%] %',[Trailer,error,SysErrorMessage(error),tmp]); -end; - -{$ifndef NOEXCEPTIONINTERCEPT} -function ESynException.CustomLog(WR: TTextWriter; - const Context: TSynLogExceptionContext): boolean; -begin - if Assigned(TSynLogExceptionToStrCustom) then - result := TSynLogExceptionToStrCustom(WR,Context) else - if Assigned(DefaultSynLogExceptionToStr) then - result := DefaultSynLogExceptionToStr(WR,Context) else - result := false; -end; -{$endif} - - -{ TMemoryMapText } - -constructor TMemoryMapText.Create; -begin -end; - -constructor TMemoryMapText.Create(aFileContent: PUTF8Char; aFileSize: integer); -begin - Create; - fMap.Map(aFileContent,aFileSize); - LoadFromMap; -end; - -constructor TMemoryMapText.Create(const aFileName: TFileName); -begin - Create; - fFileName := aFileName; - if fMap.Map(aFileName) then - LoadFromMap; -end; // invalid file or unable to memory map its content -> Count := 0 - -destructor TMemoryMapText.Destroy; -begin - Freemem(fLines); - fMap.UnMap; - inherited; -end; - -procedure TMemoryMapText.SaveToStream(Dest: TStream; const Header: RawUTF8); -var i: integer; - W: TTextWriter; - temp: TTextWriterStackBuffer; -begin - i := length(Header); - if i>0 then - Dest.WriteBuffer(pointer(Header)^,i); - if fMap.Size>0 then - Dest.WriteBuffer(fMap.Buffer^,fMap.Size); - if fAppendedLinesCount=0 then - exit; - W := TTextWriter.Create(Dest,@temp,SizeOf(temp)); - try - if (fMap.Size>0) and (fMap.Buffer[fMap.Size-1]>=' ') then - W.Add(#10); - for i := 0 to fAppendedLinesCount-1 do begin - W.AddString(fAppendedLines[i]); - W.Add(#10); - end; - W.FlushFinal; - finally - W.Free; - end; -end; - -procedure TMemoryMapText.SaveToFile(FileName: TFileName; const Header: RawUTF8); -var FS: TFileStream; -begin - FS := TFileStream.Create(FileName,fmCreate); - try - SaveToStream(FS,Header); - finally - FS.Free; - end; -end; - -function TMemoryMapText.GetLine(aIndex: integer): RawUTF8; -begin - if (self=nil) or (cardinal(aIndex)>=cardinal(fCount)) then - result := '' else - FastSetString(result,fLines[aIndex],GetLineSize(fLines[aIndex],fMapEnd)); -end; - -function TMemoryMapText.GetString(aIndex: integer): string; -begin - if (self=nil) or (cardinal(aIndex)>=cardinal(fCount)) then - result := '' else - UTF8DecodeToString(fLines[aIndex],GetLineSize(fLines[aIndex],fMapEnd),result); -end; - -function GetLineContains(p, pEnd, up: PUTF8Char): boolean; -var - i: PtrInt; - {$ifdef CPUX86NOTPIC} table: TNormTable absolute NormToUpperAnsi7Byte; - {$else} table: PNormTable; {$endif} -label - Fnd1, LF1, Fnd2, LF2, Ok; // ugly but fast -begin - if (p<>nil) and (up<>nil) then begin - {$ifndef CPUX86NOTPIC} table := @NormToUpperAnsi7; {$endif} - if pEnd=nil then - repeat - if p^<=#13 then - goto LF1 - else if table[p^]=up^ then - goto Fnd1; - inc(p); - continue; -LF1: if (p^=#0) or (p^=#13) or (p^=#10) then - break; - inc(p); - continue; -Fnd1: i := 0; - repeat - inc(i); - if up[i]<>#0 then - if up[i]=table[p[i]] then - continue else - break else begin -Ok: result := true; // found - exit; - end; - until false; - inc(p); - until false - else - repeat - if p>=pEnd then - break; - if p^<=#13 then - goto LF2 - else if table[p^]=up^ then - goto Fnd2; - inc(p); - continue; -LF2: if (p^=#13) or (p^=#10) then - break; - inc(p); - continue; -Fnd2: i := 0; - repeat - inc(i); - if up[i]=#0 then - goto Ok; - if p+i>=pEnd then - break; - until up[i]<>table[p[i]]; - inc(p); - until false; - end; - result := false; -end; - -function TMemoryMapText.LineContains(const aUpperSearch: RawUTF8; - aIndex: Integer): Boolean; -begin - if (self=nil) or (cardinal(aIndex)>=cardinal(fCount)) or (aUpperSearch='') then - result := false else - result := GetLineContains(fLines[aIndex],fMapEnd,pointer(aUpperSearch)); -end; - -function TMemoryMapText.LineSize(aIndex: integer): integer; -begin - result := GetLineSize(fLines[aIndex],fMapEnd); -end; - -function GetLineSizeSmallerThan(P,PEnd: PUTF8Char; aMinimalCount: integer): boolean; -begin - if P<>nil then - while (P#10) and (P^<>#13) do - if aMinimalCount=0 then begin - result := false; - exit; - end else begin - dec(aMinimalCount); - inc(P); - end; - result := true; -end; - -function TMemoryMapText.LineSizeSmallerThan(aIndex, aMinimalCount: integer): boolean; -begin - result := GetLineSizeSmallerThan(fLines[aIndex],fMapEnd,aMinimalCount); -end; - -procedure TMemoryMapText.ProcessOneLine(LineBeg, LineEnd: PUTF8Char); -begin - if fCount=fLinesMax then begin - fLinesMax := NextGrow(fLinesMax); - ReallocMem(fLines,fLinesMax*SizeOf(pointer)); - end; - fLines[fCount] := LineBeg; - inc(fCount); -end; - -procedure TMemoryMapText.LoadFromMap(AverageLineLength: integer=32); - procedure ParseLines(P,PEnd: PUTF8Char); - var PBeg: PUTF8Char; - begin // generated asm is much better with a local proc - while P#13) and (P^<>#10) do - inc(P); - ProcessOneLine(PBeg,P); - if P+1>=PEnd then - break; - if P[0]=#13 then - if P[1]=#10 then - inc(P,2) else // ignore #13#10 - inc(P) else // ignore #13 - inc(P); // ignore #10 - end; - end; -var P: PUTF8Char; -begin - fLinesMax := fMap.fFileSize div AverageLineLength+8; - GetMem(fLines,fLinesMax*SizeOf(pointer)); - P := pointer(fMap.Buffer); - fMapEnd := P+fMap.Size; - if TextFileKind(Map)=isUTF8 then - inc(PByte(P),3); // ignore UTF-8 BOM - ParseLines(P,fMapEnd); - if fLinesMax>fCount+16384 then - Reallocmem(fLines,fCount*SizeOf(pointer)); // size down only if worth it -end; - -procedure TMemoryMapText.AddInMemoryLine(const aNewLine: RawUTF8); -var P: PUTF8Char; -begin - if aNewLine='' then - exit; - AddRawUTF8(fAppendedLines,fAppendedLinesCount,aNewLine); - P := pointer(fAppendedLines[fAppendedLinesCount-1]); - ProcessOneLine(P,P+StrLen(P)); -end; - -procedure TMemoryMapText.AddInMemoryLinesClear; -begin - dec(fCount,fAppendedLinesCount); - fAppendedLinesCount := 0; - fAppendedLines := nil; -end; - - -{ TRawByteStringStream } - -constructor TRawByteStringStream.Create(const aString: RawByteString); -begin - fDataString := aString; -end; - -function TRawByteStringStream.Read(var Buffer; Count: Integer): Longint; -begin - if Count<=0 then - Result := 0 else begin - Result := Length(fDataString)-fPosition; - if Result>Count then - Result := Count; - MoveFast(PByteArray(fDataString)[fPosition],Buffer,Result); - inc(fPosition, Result); - end; -end; - -function TRawByteStringStream.Seek(Offset: Integer; Origin: Word): Longint; -begin - case Origin of - soFromBeginning: fPosition := Offset; - soFromCurrent: fPosition := fPosition+Offset; - soFromEnd: fPosition := Length(fDataString)-Offset; - end; - if fPosition>Length(fDataString) then - fPosition := Length(fDataString) else - if fPosition<0 then - fPosition := 0; - result := fPosition; -end; - -procedure TRawByteStringStream.SetSize(NewSize: Integer); -begin - SetLength(fDataString, NewSize); - if fPosition>NewSize then - fPosition := NewSize; -end; - -function TRawByteStringStream.Write(const Buffer; Count: Integer): Longint; -begin - if Count<=0 then - Result := 0 else begin - Result := Count; - SetLength(fDataString,fPosition+Result); - MoveFast(Buffer,PByteArray(fDataString)[fPosition],Result); - inc(FPosition,Result); - end; -end; - - -{ TFakeWriterStream } - -function TFakeWriterStream.Read(var Buffer; Count: Longint): Longint; -begin // do nothing - result := Count; -end; - -function TFakeWriterStream.Write(const Buffer; Count: Longint): Longint; -begin // do nothing - result := Count; -end; - -function TFakeWriterStream.Seek(Offset: Longint; Origin: Word): Longint; -begin - result := Offset; -end; - - -{ TSynNameValue } - -procedure TSynNameValue.Add(const aName, aValue: RawUTF8; aTag: PtrInt); -var added: boolean; - i: Integer; -begin - i := DynArray.FindHashedForAdding(aName,added); - with List[i] do begin - if added then - Name := aName; - Value := aValue; - Tag := aTag; - end; - if Assigned(fOnAdd) then - fOnAdd(List[i],i); -end; - -procedure TSynNameValue.InitFromIniSection(Section: PUTF8Char; - OnTheFlyConvert: TOnSynNameValueConvertRawUTF8; OnAdd: TOnSynNameValueNotify); -var s: RawUTF8; - i: integer; -begin - Init(false); - fOnAdd := OnAdd; - while (Section<>nil) and (Section^<>'[') do begin - s := GetNextLine(Section,Section); - i := PosExChar('=',s); - if (i>1) and not(s[1] in [';','[']) then - if Assigned(OnTheFlyConvert) then - Add(copy(s,1,i-1),OnTheFlyConvert(copy(s,i+1,1000))) else - Add(copy(s,1,i-1),copy(s,i+1,1000)); - end; -end; - -procedure TSynNameValue.InitFromCSV(CSV: PUTF8Char; NameValueSep,ItemSep: AnsiChar); -var n,v: RawUTF8; -begin - Init(false); - while CSV<>nil do begin - GetNextItem(CSV,NameValueSep,n); - if ItemSep=#10 then - GetNextItemTrimedCRLF(CSV,v) else - GetNextItem(CSV,ItemSep,v); - if n='' then - break; - Add(n,v); - end; -end; - -procedure TSynNameValue.InitFromNamesValues(const Names, Values: array of RawUTF8); -var i: integer; -begin - Init(false); - if high(Names)<>high(Values) then - exit; - DynArray.SetCapacity(length(Names)); - for i := 0 to high(Names) do - Add(Names[i],Values[i]); -end; - -function TSynNameValue.InitFromJSON(JSON: PUTF8Char; aCaseSensitive: boolean): boolean; -var N,V: PUTF8Char; - nam,val: RawUTF8; - Nlen, Vlen, c: integer; - EndOfObject: AnsiChar; -begin - result := false; - Init(aCaseSensitive); - if JSON=nil then - exit; - while (JSON^<=' ') and (JSON^<>#0) do inc(JSON); - if JSON^<>'{' then - exit; - repeat inc(JSON) until (JSON^=#0) or (JSON^>' '); - c := JSONObjectPropCount(JSON); - if c<=0 then - exit; - DynArray.SetCapacity(c); - repeat - N := GetJSONPropName(JSON,@Nlen); - if N=nil then - exit; - V := GetJSONFieldOrObjectOrArray(JSON,nil,@EndOfObject,true,true,@Vlen); - if V=nil then - exit; - FastSetString(nam,N,Nlen); - FastSetString(val,V,Vlen); - Add(nam,val); - until EndOfObject='}'; - result := true; -end; - -procedure TSynNameValue.Init(aCaseSensitive: boolean); -begin - // release dynamic arrays memory before FillcharFast() - List := nil; - DynArray.fHash.Clear; - // initialize hashed storage - FillCharFast(self,SizeOf(self),0); - DynArray.InitSpecific(TypeInfo(TSynNameValueItemDynArray),List, - djRawUTF8,@Count,not aCaseSensitive); -end; - -function TSynNameValue.Find(const aName: RawUTF8): integer; -begin - result := DynArray.FindHashed(aName); -end; - -function TSynNameValue.FindStart(const aUpperName: RawUTF8): integer; -begin - for result := 0 to Count-1 do - if IdemPChar(pointer(List[result].Name),pointer(aUpperName)) then - exit; - result := -1; -end; - -function TSynNameValue.FindByValue(const aValue: RawUTF8): integer; -begin - for result := 0 to Count-1 do - if List[result].Value=aValue then - exit; - result := -1; -end; - -function TSynNameValue.Delete(const aName: RawUTF8): boolean; -begin - result := DynArray.FindHashedAndDelete(aName)>=0; -end; - -function TSynNameValue.DeleteByValue(const aValue: RawUTF8; Limit: integer): integer; -var ndx: integer; -begin - result := 0; - if Limit<1 then - exit; - for ndx := Count-1 downto 0 do - if List[ndx].Value=aValue then begin - DynArray.Delete(ndx); - inc(result); - if result>=Limit then - break; - end; - if result>0 then - DynArray.ReHash; -end; - -function TSynNameValue.Value(const aName: RawUTF8; const aDefaultValue: RawUTF8): RawUTF8; -var i: integer; -begin - if @self=nil then - i := -1 else - i := DynArray.FindHashed(aName); - if i<0 then - result := aDefaultValue else - result := List[i].Value; -end; - -function TSynNameValue.ValueInt(const aName: RawUTF8; const aDefaultValue: Int64): Int64; -var i,err: integer; -begin - i := DynArray.FindHashed(aName); - if i<0 then - result := aDefaultValue else begin - result := {$ifdef CPU64}GetInteger{$else}GetInt64{$endif}(pointer(List[i].Value),err); - if err<>0 then - result := aDefaultValue; - end; -end; - -function TSynNameValue.ValueBool(const aName: RawUTF8): Boolean; -begin - result := Value(aName)='1'; -end; - -function TSynNameValue.ValueEnum(const aName: RawUTF8; aEnumTypeInfo: pointer; - out aEnum; aEnumDefault: byte): boolean; -var v: RawUTF8; - err,i: integer; -begin - result := false; - byte(aEnum) := aEnumDefault; - v := trim(Value(aName,'')); - if v='' then - exit; - i := GetInteger(pointer(v),err); - if (err<>0) or (i<0) then - i := GetEnumNameValue(aEnumTypeInfo,v,true); - if i>=0 then begin - byte(aEnum) := i; - result := true; - end; -end; - -function TSynNameValue.Initialized: boolean; -begin - result := DynArray.Value=@List; -end; - -function TSynNameValue.GetBlobData: RawByteString; -begin - result := DynArray.SaveTo; -end; - -procedure TSynNameValue.SetBlobDataPtr(aValue: pointer); -begin - DynArray.LoadFrom(aValue); - DynArray.ReHash; -end; - -procedure TSynNameValue.SetBlobData(const aValue: RawByteString); -begin - DynArray.LoadFromBinary(aValue); - DynArray.ReHash; -end; - -function TSynNameValue.GetStr(const aName: RawUTF8): RawUTF8; -begin - result := Value(aName,''); -end; - -function TSynNameValue.GetInt(const aName: RawUTF8): Int64; -begin - result := ValueInt(aName,0); -end; - -function TSynNameValue.GetBool(const aName: RawUTF8): Boolean; -begin - result := Value(aName)='1'; -end; - -function TSynNameValue.AsCSV(const KeySeparator,ValueSeparator,IgnoreKey: RawUTF8): RawUTF8; -var i: integer; - temp: TTextWriterStackBuffer; -begin - with TTextWriter.CreateOwnedStream(temp) do - try - for i := 0 to Count-1 do - if (IgnoreKey='') or (List[i].Name<>IgnoreKey) then begin - AddNoJSONEscapeUTF8(List[i].Name); - AddNoJSONEscapeUTF8(KeySeparator); - AddNoJSONEscapeUTF8(List[i].Value); - AddNoJSONEscapeUTF8(ValueSeparator); - end; - SetText(result); - finally - Free; - end; -end; - -function TSynNameValue.AsJSON: RawUTF8; -var i: integer; - temp: TTextWriterStackBuffer; -begin - with TTextWriter.CreateOwnedStream(temp) do - try - Add('{'); - for i := 0 to Count-1 do - with List[i] do begin - AddProp(pointer(Name),length(Name)); - Add('"'); - AddJSONEscape(pointer(Value)); - Add('"',','); - end; - CancelLastComma; - Add('}'); - SetText(result); - finally - Free; - end; -end; - -procedure TSynNameValue.AsNameValues(out Names,Values: TRawUTF8DynArray); -var i: integer; -begin - SetLength(Names,Count); - SetLength(Values,Count); - for i := 0 to Count-1 do begin - Names[i] := List[i].Name; - Values[i] := List[i].Value; - end; -end; - -{$ifndef NOVARIANTS} -function TSynNameValue.ValueVariantOrNull(const aName: RawUTF8): variant; -var i: integer; -begin - i := Find(aName); - if i<0 then - SetVariantNull(result) else - RawUTF8ToVariant(List[i].Value,result); -end; - -procedure TSynNameValue.AsDocVariant(out DocVariant: variant; - ExtendedJson,ValueAsString,AllowVarDouble: boolean); -var ndx: integer; -begin - if Count>0 then - with TDocVariantData(DocVariant) do begin - Init(JSON_OPTIONS_NAMEVALUE[ExtendedJson],dvObject); - VCount := self.Count; - SetLength(VName,VCount); - SetLength(VValue,VCount); - for ndx := 0 to VCount-1 do begin - VName[ndx] := List[ndx].Name; - if ValueAsString or not GetNumericVariantFromJSON(pointer(List[ndx].Value), - TVarData(VValue[ndx]),AllowVarDouble) then - RawUTF8ToVariant(List[ndx].Value,VValue[ndx]); - end; - end else - TVarData(DocVariant).VType := varNull; -end; - -function TSynNameValue.AsDocVariant(ExtendedJson,ValueAsString: boolean): variant; -begin - AsDocVariant(result,ExtendedJson,ValueAsString); -end; - -function TSynNameValue.MergeDocVariant(var DocVariant: variant; - ValueAsString: boolean; ChangedProps: PVariant; ExtendedJson,AllowVarDouble: Boolean): integer; -var DV: TDocVariantData absolute DocVariant; - i,ndx: integer; - v: variant; - intvalues: TRawUTF8Interning; -begin - if integer(DV.VType)<>DocVariantVType then - TDocVariant.New(DocVariant,JSON_OPTIONS_NAMEVALUE[ExtendedJson]); - if ChangedProps<>nil then - TDocVariant.New(ChangedProps^,DV.Options); - if dvoInternValues in DV.Options then - intvalues := DocVariantType.InternValues else - intvalues := nil; - result := 0; // returns number of changed values - for i := 0 to Count-1 do - if List[i].Name<>'' then begin - VarClear(v); - if ValueAsString or not GetNumericVariantFromJSON(pointer(List[i].Value), - TVarData(v),AllowVarDouble) then - RawUTF8ToVariant(List[i].Value,v); - ndx := DV.GetValueIndex(List[i].Name); - if ndx<0 then - ndx := DV.InternalAdd(List[i].Name) else - if SortDynArrayVariantComp(TVarData(v),TVarData(DV.Values[ndx]),false)=0 then - continue; // value not changed -> skip - if ChangedProps<>nil then - PDocVariantData(ChangedProps)^.AddValue(List[i].Name,v); - SetVariantByValue(v,DV.VValue[ndx]); - if intvalues<>nil then - intvalues.UniqueVariant(DV.VValue[ndx]); - inc(result); - end; -end; -{$endif NOVARIANTS} - - -{$ifdef MSWINDOWS} -function IsDebuggerPresent: BOOL; stdcall; external kernel32; // since XP -{$endif} - -procedure SetCurrentThreadName(const Format: RawUTF8; const Args: array of const); -begin - SetThreadName(GetCurrentThreadId,Format,Args); -end; - -procedure SetThreadName(ThreadID: TThreadID; const Format: RawUTF8; - const Args: array of const); -var name: RawUTF8; -begin - FormatUTF8(Format,Args,name); - name := StringReplaceAll(name,['TSQLRest','', 'TSQL','', 'TWebSocket','WS', - 'TServiceFactory','SF', 'TSyn','', 'Thread','', 'Process','', - 'Background','Bgd', 'Server','Svr', 'Client','Clt', 'WebSocket','WS', - 'Timer','Tmr', 'Thread','Thd']); - SetThreadNameInternal(ThreadID,name); -end; - -procedure SetThreadNameDefault(ThreadID: TThreadID; const Name: RawUTF8); -{$ifndef FPC} -{$ifndef NOSETTHREADNAME} -var s: RawByteString; - {$ifndef ISDELPHIXE2} - {$ifdef MSWINDOWS} - info: record - FType: LongWord; // must be 0x1000 - FName: PAnsiChar; // pointer to name (in user address space) - FThreadID: LongWord; // thread ID (-1 indicates caller thread) - FFlags: LongWord; // reserved for future use, must be zero - end; - {$endif} - {$endif} -{$endif NOSETTHREADNAME} -{$endif FPC} -begin -{$ifdef FPC} - {$ifdef LINUX} - if ThreadID<>MainThreadID then // don't change the main process name - SetUnixThreadName(ThreadID, Name); // call pthread_setname_np() - {$endif} -{$else} -{$ifndef NOSETTHREADNAME} - {$ifdef MSWINDOWS} - if not IsDebuggerPresent then - exit; - {$endif MSWINDOWS} - s := CurrentAnsiConvert.UTF8ToAnsi(Name); - {$ifdef ISDELPHIXE2} - TThread.NameThreadForDebugging(s,ThreadID); - {$else} - {$ifdef MSWINDOWS} - info.FType := $1000; - info.FName := pointer(s); - info.FThreadID := ThreadID; - info.FFlags := 0; - try - RaiseException($406D1388,0,SizeOf(info) div SizeOf(LongWord),@info); - except {ignore} end; - {$endif MSWINDOWS} - {$endif ISDELPHIXE2} -{$endif NOSETTHREADNAME} -{$endif FPC} -end; - - -{ MultiEvent* functions } - -function MultiEventFind(const EventList; const Event: TMethod): integer; -var Events: TMethodDynArray absolute EventList; -begin - if Event.Code<>nil then // callback assigned - for result := 0 to length(Events)-1 do - if (Events[result].Code=Event.Code) and - (Events[result].Data=Event.Data) then - exit; - result := -1; -end; - -function MultiEventAdd(var EventList; const Event: TMethod): boolean; -var Events: TMethodDynArray absolute EventList; - n: integer; -begin - result := false; - n := MultiEventFind(EventList,Event); - if n>=0 then - exit; // already registered - result := true; - n := length(Events); - SetLength(Events,n+1); - Events[n] := Event; -end; - -procedure MultiEventRemove(var EventList; const Event: TMethod); -begin - MultiEventRemove(EventList,MultiEventFind(EventList,Event)); -end; - -procedure MultiEventRemove(var EventList; Index: Integer); -var Events: TMethodDynArray absolute EventList; - max: integer; -begin - max := length(Events); - if cardinal(index)nil) and (po^<>nil) then - FreeAndNil(po^); - except - on E: Exception do - ; // just ignore exceptions in client code destructors - end; - FreeAndNil(GarbageCollectorFreeAndNilList); -end; - -procedure GarbageCollectorFreeAndNil(var InstanceVariable; Instance: TObject); -begin - TObject(InstanceVariable) := Instance; - GarbageCollectorFreeAndNilList.Add(@InstanceVariable); -end; - -var - GlobalCriticalSection: TRTLCriticalSection; - -procedure GlobalLock; -begin - EnterCriticalSection(GlobalCriticalSection); -end; - -procedure GlobalUnLock; -begin - LeaveCriticalSection(GlobalCriticalSection); -end; - -{$ifdef CPUINTEL} -function IsXmmYmmOSEnabled: boolean; assembler; {$ifdef FPC} nostackframe; assembler; {$endif} -asm // see https://software.intel.com/en-us/blogs/2011/04/14/is-avx-enabled - xor ecx, ecx // specify control register XCR0 = XFEATURE_ENABLED_MASK - db $0f, $01, $d0 // XGETBV reads XCR0 into EDX:EAX - and eax, 6 // check OS has enabled both XMM (bit 1) and YMM (bit 2) - cmp al, 6 - sete al -end; - -procedure TestIntelCpuFeatures; -var regs: TRegisters; - c: cardinal; -begin - // retrieve CPUID raw flags - regs.edx := 0; - regs.ecx := 0; - GetCPUID(1,regs); - PIntegerArray(@CpuFeatures)^[0] := regs.edx; - PIntegerArray(@CpuFeatures)^[1] := regs.ecx; - GetCPUID(7,regs); - PIntegerArray(@CpuFeatures)^[2] := regs.ebx; - PIntegerArray(@CpuFeatures)^[3] := regs.ecx; - PIntegerArray(@CpuFeatures)^[4] := regs.edx; - {$ifdef DISABLE_SSE42} // paranoid execution on Darwin x64 (as reported by alf) - CpuFeatures := CpuFeatures-[cfSSE42,cfAESNI]; - {$endif DISABLE_SSE42} - if not(cfOSXS in CpuFeatures) or not IsXmmYmmOSEnabled then - CpuFeatures := CpuFeatures-[cfAVX,cfAVX2,cfFMA]; - {$ifndef ABSOLUTEPASCAL} - {$ifdef CPUX64} - {$ifdef WITH_ERMS} - if cfERMS in CpuFeatures then // actually slower than our AVX code -> disabled - include(CPUIDX64,cpuERMS); - {$endif WITH_ERMS} - if cfAVX in CpuFeatures then begin - include(CPUIDX64,cpuAVX); - if cfAVX2 in CpuFeatures then - include(CPUIDX64,cpuAVX2); - end; - {$endif CPUX64} - {$endif ABSOLUTEPASCAL} - // validate accuracy of most used HW opcodes - if cfRAND in CpuFeatures then - try - c := RdRand32; - if RdRand32=c then // most probably a RDRAND bug, e.g. on AMD Rizen 3000 - exclude(CpuFeatures,cfRAND); - except // may trigger an illegal instruction exception on some Ivy Bridge - exclude(CpuFeatures,cfRAND); - end; - if cfSSE42 in CpuFeatures then - try - if crc32cBy4SSE42(0,1)<>3712330424 then - raise ESynException.Create('Invalid crc32cBy4SSE42'); - except // disable now on illegal instruction or incorrect result - exclude(CpuFeatures,cfSSE42); - end; -end; -{$endif CPUINTEL} - -procedure InitFunctionsRedirection; -begin - {$ifdef CPUINTEL} - TestIntelCpuFeatures; - {$endif CPUINTEL} - {$ifndef MSWINDOWS} // now for RedirectCode (RetrieveSystemInfo is too late) - SystemInfo.dwPageSize := getpagesize; // use libc for this value - if SystemInfo.dwPageSize=0 then // should not be 0 - SystemInfo.dwPageSize := 4096; - {$endif MSWINDOWS} - {$ifdef PUREPASCAL} - {$ifndef HASINLINE} - PosEx := @PosExPas; - {$endif HASINLINE} - PosExString := @PosExStringPas; // fast pure pascal process - {$else not PUREPASCAL} - {$ifdef UNICODE} - PosExString := @PosExStringPas; // fast PWideChar process - {$else} - PosExString := @PosEx; // use optimized PAnsiChar i386 asm - {$endif UNICODE} - {$endif PUREPASCAL} - crc32c := @crc32cfast; // now to circumvent Internal Error C11715 for Delphi 5 - crc32cBy4 := @crc32cBy4fast; - {$ifndef CPUX64} - MoveFast := @System.Move; - {$endif CPUX64} - {$ifdef FPC} - {$ifdef CPUX64} - {$ifndef ABSOLUTEPASCAL} - if @System.FillChar<>@FillCharFast then begin - // force to use our optimized x86_64 asm versions - RedirectCode(@System.FillChar,@FillcharFast); - RedirectCode(@System.Move,@MoveFast); - {$ifdef DOPATCHTRTL} - PatchCode(@fpc_ansistr_incr_ref,@_ansistr_incr_ref,$17); // fpclen=$2f - PatchJmp(@fpc_ansistr_decr_ref,@_ansistr_decr_ref,$27); // fpclen=$3f - PatchJmp(@fpc_ansistr_assign,@_ansistr_assign,$3f); // fpclen=$3f - PatchCode(@fpc_ansistr_compare,@_ansistr_compare,$77); // fpclen=$12f - PatchCode(@fpc_ansistr_compare_equal,@_ansistr_compare_equal,$57); // =$cf - PatchCode(@fpc_unicodestr_incr_ref,@_ansistr_incr_ref,$17); // fpclen=$2f - PatchJmp(@fpc_unicodestr_decr_ref,@_ansistr_decr_ref,$27); // fpclen=$3f - PatchJmp(@fpc_unicodestr_assign,@_ansistr_assign,$3f); // fpclen=$3f - PatchCode(@fpc_dynarray_incr_ref,@_dynarray_incr_ref,$17); // fpclen=$2f - PatchJmp(@fpc_dynarray_clear,@_dynarray_decr_ref,$2f,PtrUInt(@_dynarray_decr_ref_free)); - RedirectCode(@fpc_dynarray_decr_ref,@fpc_dynarray_clear); - {$ifdef FPC_HAS_CPSTRING} - {$ifdef LINUX} - if (DefaultSystemCodePage=CP_UTF8) or (DefaultSystemCodePage=0) then begin - RedirectRtl(@_fpc_ansistr_concat,@_ansistr_concat_utf8); - RedirectRtl(@_fpc_ansistr_concat_multi,@_ansistr_concat_multi_utf8); - end; - {$endif LINUX} - {$ifdef FPC_X64MM} - RedirectCode(@fpc_ansistr_setlength,@_ansistr_setlength); - {$endif FPC_X64MM} - {$endif FPC_HAS_CPSTRING} - {$ifdef FPC_X64MM} - RedirectCode(@fpc_getmem,@_Getmem); - RedirectCode(@fpc_freemem,@_Freemem); - {$endif FPC_X64MM} - {$endif DOPATCHTRTL} - end; - {$endif ABSOLUTEPASCAL} - {$else} - FillCharFast := @System.FillChar; // fallback to FPC cross-platform RTL - {$endif CPUX64} - {$else Dephi: } - {$ifdef CPUARM} - FillCharFast := @System.FillChar; - {$else} - {$ifndef CPUX64} - Pointer(@FillCharFast) := SystemFillCharAddress; - {$endif CPUX64} - {$ifdef DELPHI5OROLDER} - StrLen := @StrLenX86; - MoveFast := @MoveX87; - FillcharFast := @FillCharX87; - {$else DELPHI5OROLDER} - {$ifdef CPU64} // x86_64 redirection - {$ifdef HASAESNI} - {$ifdef FORCE_STRSSE42} - if cfSSE42 in CpuFeatures then begin - StrLen := @StrLenSSE42; - StrComp := @StrCompSSE42; - end else - {$endif FORCE_STRSSE42} - {$endif HASAESNI} - StrLen := @StrLenSSE2; - {$else} // i386 redirection - {$ifdef CPUINTEL} - if cfSSE2 in CpuFeatures then begin - {$ifdef FORCE_STRSSE42} - if cfSSE42 in CpuFeatures then - StrLen := @StrLenSSE42 else - {$endif FORCE_STRSSE42} - StrLen := @StrLenSSE2; - FillcharFast := @FillCharSSE2; - end else begin - StrLen := @StrLenX86; - FillcharFast := @FillCharX87; - end; - {$ifdef WITH_ERMS} // disabled by default (much slower for small blocks) - if cfERMS in CpuFeatures then begin - MoveFast := @MoveERMSB; - FillcharFast := @FillCharERMSB; - end else {$endif} - MoveFast := @MoveX87; // SSE2 is not faster than X87 version on 32-bit CPU - {$endif CPUINTEL} - {$endif CPU64} - {$endif DELPHI5OROLDER} - {$ifndef USEPACKAGES} - // do redirection from RTL to our fastest version - {$ifdef DOPATCHTRTL} - if DebugHook=0 then begin // patch only outside debugging - RedirectCode(SystemFillCharAddress,@FillcharFast); - RedirectCode(@System.Move,@MoveFast); - {$ifdef CPUX86} - RedirectCode(SystemRecordCopyAddress,@RecordCopy); - RedirectCode(SystemFinalizeRecordAddress,@RecordClear); - RedirectCode(SystemInitializeRecordAddress,@_InitializeRecord); - {$ifndef UNICODE} // buggy Delphi 2009+ RTL expects a TMonitor.Destroy call - RedirectCode(@TObject.CleanupInstance,@TObjectCleanupInstance); - {$endif UNICODE} - {$endif} - end; - {$endif DOPATCHTRTL} - {$endif USEPACKAGES} - {$endif CPUARM} - {$endif FPC} - UpperCopy255Buf := @UpperCopy255BufPas; - DefaultHasher := @xxHash32; // faster than crc32cfast for small content - {$ifndef ABSOLUTEPASCAL} - {$ifdef CPUINTEL} - {$ifdef FPC} // StrLen was set above for Delphi - {$ifdef CPUX86} - if cfSSE2 in CpuFeatures then - {$endif CPUX86} - StrLen := @StrLenSSE2; - {$endif FPC} - if cfSSE42 in CpuFeatures then begin - crc32c := @crc32csse42; // seems safe on all targets - crc32cby4 := @crc32cby4sse42; - crcblock := @crcblockSSE42; - crcblocks := @crcblocksSSE42; - {$ifdef FORCE_STRSSE42} // disabled by default: may trigger random GPF - strspn := @strspnSSE42; - strcspn := @strcspnSSE42; - {$ifdef CPU64} - {$ifdef FPC} // done in InitRedirectCode for Delphi - {$ifdef HASAESNI} - StrLen := @StrLenSSE42; - StrComp := @StrCompSSE42; - {$endif HASAESNI} - {$endif FPC} - {$endif CPU64} - {$ifndef PUREPASCAL} - {$ifndef DELPHI5OROLDER} - UpperCopy255Buf := @UpperCopy255BufSSE42; - {$endif DELPHI5OROLDER} - {$endif PUREPASCAL} - {$ifndef PUREPASCAL} - StrComp := @StrCompSSE42; - DYNARRAY_SORTFIRSTFIELD[false,djRawUTF8] := @SortDynArrayAnsiStringSSE42; - DYNARRAY_SORTFIRSTFIELD[false,djWinAnsi] := @SortDynArrayAnsiStringSSE42; - {$ifndef UNICODE} - DYNARRAY_SORTFIRSTFIELD[false,djString] := @SortDynArrayAnsiStringSSE42; - {$endif} - DYNARRAY_SORTFIRSTFIELDHASHONLY[true] := @SortDynArrayAnsiStringSSE42; - {$endif PUREPASCAL} - {$endif FORCE_STRSSE42} - DefaultHasher := crc32c; - end; - if cfPOPCNT in CpuFeatures then - GetBitsCountPtrInt := @GetBitsCountSSE42; - {$endif CPUINTEL} - {$endif ABSOLUTEPASCAL} - InterningHasher := DefaultHasher; -end; - -procedure InitSynCommonsConversionTables; -var i,n: integer; - v: byte; - c: AnsiChar; - crc: cardinal; - tmp: array[0..15] of AnsiChar; - P: PAnsiChar; -{$ifdef OWNNORMTOUPPER} - d: integer; -const n2u: array[138..255] of byte = - (83,139,140,141,90,143,144,145,146,147,148,149,150,151,152,153,83,155,140, - 157,90,89,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175, - 176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,65,65,65, - 65,65,65,198,67,69,69,69,69,73,73,73,73,68,78,79,79,79,79,79,215,79,85,85, - 85,85,89,222,223,65,65,65,65,65,65,198,67,69,69,69,69,73,73,73,73,68,78,79, - 79,79,79,79,247,79,85,85,85,85,89,222,89); -{$endif OWNNORMTOUPPER} -const HexChars: array[0..15] of AnsiChar = '0123456789ABCDEF'; - HexCharsLower: array[0..15] of AnsiChar = '0123456789abcdef'; -begin - JSON_CONTENT_TYPE_VAR := JSON_CONTENT_TYPE; - JSON_CONTENT_TYPE_HEADER_VAR := JSON_CONTENT_TYPE_HEADER; - NULL_STR_VAR := 'null'; - BOOL_UTF8[false] := 'false'; - BOOL_UTF8[true] := 'true'; - {$ifdef FPC} - {$ifdef ISFPC27} - {$ifndef MSWINDOWS} - GetACP := GetSystemCodePage; - {$endif MSWINDOWS} - SetMultiByteConversionCodePage(CP_UTF8); - SetMultiByteRTLFileSystemCodePage(CP_UTF8); - {$endif ISFPC27} - {$endif FPC} - {$ifdef KYLIX3} - // if default locale is set to *.UTF-8, which is the case in most modern - // linux default configuration, unicode decode will fail in SysUtils.CheckLocale - setlocale(LC_CTYPE,'en_US'); // force locale for a UTF-8 server - {$endif} -{$ifndef EXTENDEDTOSHORT_USESTR} - {$ifdef ISDELPHIXE} - SettingsUS := TFormatSettings.Create($0409); - {$else} - GetLocaleFormatSettings($0409,SettingsUS); - {$endif} - SettingsUS.DecimalSeparator := '.'; // value may have been overriden :( -{$endif} - for i := 0 to 255 do - NormToNormByte[i] := i; - NormToUpperAnsi7Byte := NormToNormByte; - for i := ord('a') to ord('z') do - dec(NormToUpperAnsi7Byte[i],32); - {$ifdef OWNNORMTOUPPER} - MoveFast(NormToUpperAnsi7,NormToUpper,138); - MoveFast(n2u,NormToUpperByte[138],SizeOf(n2u)); - for i := 0 to 255 do begin - d := NormToUpperByte[i]; - if d in [ord('A')..ord('Z')] then - inc(d,32); - NormToLowerByte[i] := d; - end; - {$endif OWNNORMTOUPPER} - FillcharFast(ConvertHexToBin[0],SizeOf(ConvertHexToBin),255); // all to 255 - v := 0; - for i := ord('0') to ord('9') do begin - ConvertHexToBin[i] := v; - inc(v); - end; - for i := ord('A') to ord('F') do begin - ConvertHexToBin[i] := v; - ConvertHexToBin[i+(ord('a')-ord('A'))] := v; - inc(v); - end; - for i := 0 to 255 do begin - TwoDigitsHex[i][1] := HexChars[i shr 4]; - TwoDigitsHex[i][2] := HexChars[i and $f]; - end; - for i := 0 to 255 do begin - TwoDigitsHexLower[i][1] := HexCharsLower[i shr 4]; - TwoDigitsHexLower[i][2] := HexCharsLower[i and $f]; - end; - MoveFast(TwoDigitLookup[0], TwoDigitByteLookupW[0], SizeOf(TwoDigitLookup)); - for i := 0 to 199 do - dec(PByteArray(@TwoDigitByteLookupW)[i],ord('0')); // '0'..'9' -> 0..9 - FillcharFast(ConvertBase64ToBin,256,255); // invalid value set to -1 - for i := 0 to high(b64enc) do - ConvertBase64ToBin[b64enc[i]] := i; - ConvertBase64ToBin['='] := -2; // special value for '=' - for i := 0 to high(b64urienc) do - ConvertBase64uriToBin[b64urienc[i]] := i; - for i := high(Baudot2Char) downto 0 do - if Baudot2Char[i]<#128 then - Char2Baudot[Baudot2Char[i]] := i; - for i := ord('a') to ord('z') do - Char2Baudot[AnsiChar(i-32)] := Char2Baudot[AnsiChar(i)]; // A-Z -> a-z - JSON_ESCAPE[0] := 1; // 1 for #0 end of input - for i := 1 to 31 do // 0 indicates no JSON escape needed - JSON_ESCAPE[i] := 2; // 2 should be escaped as \u00xx - JSON_ESCAPE[8] := ord('b'); // others contain the escaped character - JSON_ESCAPE[9] := ord('t'); - JSON_ESCAPE[10] := ord('n'); - JSON_ESCAPE[12] := ord('f'); - JSON_ESCAPE[13] := ord('r'); - JSON_ESCAPE[ord('\')] := ord('\'); - JSON_ESCAPE[ord('"')] := ord('"'); - include(JSON_CHARS[#0], jcEndOfJSONFieldOr0); - for c := low(c) to high(c) do begin - if not (c in [#0,#10,#13]) then - include(TEXT_CHARS[c], tcNot01013); - if c in [#10,#13] then - include(TEXT_CHARS[c], tc1013); - if c in ['0'..'9','a'..'z','A'..'Z'] then - include(TEXT_CHARS[c], tcWord); - if c in ['_','a'..'z','A'..'Z'] then - include(TEXT_CHARS[c], tcIdentifierFirstChar); - if c in ['_','0'..'9','a'..'z','A'..'Z'] then - include(TEXT_CHARS[c], tcIdentifier); - if c in ['_','-','.','0'..'9','a'..'z','A'..'Z'] then - // '~' is part of the RFC 3986 but should be escaped in practice - // see https://blog.synopse.info/?post/2020/08/11/The-RFC%2C-The-URI%2C-and-The-Tilde - include(TEXT_CHARS[c], tcURIUnreserved); - if c in [#1..#9,#11,#12,#14..' '] then - include(TEXT_CHARS[c], tcCtrlNotLF); - if c in [#1..' ',';'] then - include(TEXT_CHARS[c], tcCtrlNot0Comma); - if c in [',',']','}',':'] then begin - include(JSON_CHARS[c], jcEndOfJSONField); - include(JSON_CHARS[c], jcEndOfJSONFieldOr0); - end; - if c in [#0,#9,#10,#13,' ',',','}',']'] then - include(JSON_CHARS[c], jcEndOfJSONValueField); - if c in ['-','0'..'9'] then - include(JSON_CHARS[c], jcDigitFirstChar); - if c in ['-','+','0'..'9'] then - include(JSON_CHARS[c], jcDigitChar); - if c in ['-','+','0'..'9','.','E','e'] then - include(JSON_CHARS[c], jcDigitFloatChar); - if c in ['_','0'..'9','a'..'z','A'..'Z','$'] then - include(JSON_CHARS[c], jcJsonIdentifierFirstChar); - if c in ['_','0'..'9','a'..'z','A'..'Z','.','[',']'] then - include(JSON_CHARS[c], jcJsonIdentifier); - end; - TSynAnsiConvert.Engine(0); // define CurrentAnsi/WinAnsi/UTF8AnsiConvert - for i := 0 to 255 do begin - crc := i; - for n := 1 to 8 do - if (crc and 1)<>0 then // polynom is not the same as with zlib's crc32() - crc := (crc shr 1) xor $82f63b78 else - crc := crc shr 1; - crc32ctab[0,i] := crc; // for crc32cfast() and SymmetricEncrypt/FillRandom - end; - for i := 0 to 255 do begin - crc := crc32ctab[0,i]; - for n := 1 to high(crc32ctab) do begin - crc := (crc shr 8) xor crc32ctab[0,ToByte(crc)]; - crc32ctab[n,i] := crc; - end; - end; - for i := 0 to high(SmallUInt32UTF8) do begin - P := StrUInt32(@tmp[15],i); - FastSetString(SmallUInt32UTF8[i],P,@tmp[15]-P); - end; - KINDTYPE_INFO[djRawUTF8] := TypeInfo(RawUTF8); // for TDynArray.LoadKnownType - KINDTYPE_INFO[djWinAnsi] := TypeInfo(WinAnsiString); - KINDTYPE_INFO[djString] := TypeInfo(String); - KINDTYPE_INFO[djRawByteString] := TypeInfo(RawByteString); - KINDTYPE_INFO[djWideString] := TypeInfo(WideString); - KINDTYPE_INFO[djSynUnicode] := TypeInfo(SynUnicode); - {$ifndef NOVARIANTS}KINDTYPE_INFO[djVariant] := TypeInfo(variant);{$endif} -end; - -initialization - // initialization of internal dynamic functions and tables - InitFunctionsRedirection; - InitializeCriticalSection(GlobalCriticalSection); - GarbageCollectorFreeAndNilList := TSynList.Create; - GarbageCollectorFreeAndNil(GarbageCollector,TSynObjectList.Create); - InitSynCommonsConversionTables; - RetrieveSystemInfo; - SetExecutableVersion(0,0,0,0); - AlgoSynLZ := TAlgoSynLZ.Create; - GarbageCollectorFreeAndNil(GlobalCustomJSONSerializerFromTextSimpleType, - TSynDictionary.Create(TypeInfo(TRawUTF8DynArray), - TypeInfo(TJSONSerializerFromTextSimpleDynArray),true)); - TTextWriter.RegisterCustomJSONSerializerFromTextSimpleType( - {$ifdef ISDELPHI2010}TypeInfo(TGUID){$else}nil{$endif},'TGUID'); - TTextWriter.RegisterCustomJSONSerializerFromText([ - TypeInfo(TFindFilesDynArray), - 'Name:string Attr:Integer Size:Int64 Timestamp:TDateTime']); - // some paranoid cross-platform/cross-compiler assertions - {$ifndef NOVARIANTS} - Assert(SizeOf(TVarData)={$ifdef CPU64}24{$else}16{$endif}); // for ExchgVariant - Assert(SizeOf(TDocVariantData)=SizeOf(TVarData)); - DocVariantType := TDocVariant(SynRegisterCustomVariantType(TDocVariant)); - DocVariantVType := DocVariantType.VarType; - {$endif NOVARIANTS} - {$ifndef FPC}{$warnings OFF}{$endif} - Assert((MAX_SQLFIELDS>=64)and(MAX_SQLFIELDS<=256)); - {$ifndef FPC}{$warnings ON}{$endif} - Assert(SizeOf(THash128Rec)=SizeOf(THash128)); - Assert(SizeOf(THash256Rec)=SizeOf(THash256)); - Assert(SizeOf(TBlock128)=SizeOf(THash128)); - assert(SizeOf(TSynSystemTime)=SizeOf(TSystemTime)); - assert(SizeOf(TSynSystemTime)=SizeOf(THash128)); - Assert(SizeOf(TOperatingSystemVersion)=SizeOf(integer)); - Assert(SizeOf(TSynLocker)>=128,'cpucacheline'); - Assert(SizeOf(TJsonChar)=1); - Assert(SizeOf(TTextChar)=1); - {$ifdef MSWINDOWS} - {$ifndef CPU64} - Assert(SizeOf(TFileTime)=SizeOf(Int64)); // see e.g. FileTimeToInt64 - {$endif CPU64} - {$endif MSWINDOWS} - -finalization - {$ifndef NOVARIANTS} - DocVariantType.Free; - {$endif NOVARIANTS} - GarbageCollectorFree; - DeleteCriticalSection(GlobalCriticalSection); - //writeln('TDynArrayHashedCollisionCount=',TDynArrayHashedCollisionCount); readln; -end. diff --git a/lib/dmustache/SynDoubleToText.inc b/lib/dmustache/SynDoubleToText.inc deleted file mode 100644 index 1d5a0322..00000000 --- a/lib/dmustache/SynDoubleToText.inc +++ /dev/null @@ -1,950 +0,0 @@ -/// efficient double to text conversion using the GRISU-1 algorithm -// - as a complement to SynCommons, which tended to increase too much -// - licensed under a MPL/GPL/LGPL tri-license; version 1.18 - -{ - Implement 64-bit floating point (double) to ASCII conversion using the - GRISU-1 efficient algorithm. - - Original Code in flt_core.inc flt_conv.inc flt_pack.inc from FPC RTL. - Copyright (C) 2013 by Max Nazhalov - Licenced with LGPL 2 with the linking exception. - If you don't agree with these License terms, disable this feature - by undefining DOUBLETOSHORT_USEGRISU in Synopse.inc - - GRISU Original Algorithm - Copyright (c) 2009 Florian Loitsch - - We extracted a double-to-ascii only cut-down version of those files, - and made a huge refactoring to reach the best performance, especially - tuning the Intel target with some dedicated asm and code rewrite. - - With Delphi 10.3 on Win32: (no benefit) - 100000 FloatToText in 38.11ms i.e. 2,623,570/s, aver. 0us, 47.5 MB/s - 100000 str in 43.19ms i.e. 2,315,082/s, aver. 0us, 50.7 MB/s - 100000 DoubleToShort in 45.50ms i.e. 2,197,367/s, aver. 0us, 43.8 MB/s - 100000 DoubleToAscii in 42.44ms i.e. 2,356,045/s, aver. 0us, 47.8 MB/s - - With Delphi 10.3 on Win64: - 100000 FloatToText in 61.83ms i.e. 1,617,233/s, aver. 0us, 29.3 MB/s - 100000 str in 53.20ms i.e. 1,879,663/s, aver. 0us, 41.2 MB/s - 100000 DoubleToShort in 18.45ms i.e. 5,417,998/s, aver. 0us, 108 MB/s - 100000 DoubleToAscii in 18.19ms i.e. 5,496,921/s, aver. 0us, 111.5 MB/s - - With FPC on Win32: - 100000 FloatToText in 115.62ms i.e. 864,842/s, aver. 1us, 15.6 MB/s - 100000 str in 57.30ms i.e. 1,745,109/s, aver. 0us, 39.9 MB/s - 100000 DoubleToShort in 23.88ms i.e. 4,187,078/s, aver. 0us, 83.5 MB/s - 100000 DoubleToAscii in 23.34ms i.e. 4,284,490/s, aver. 0us, 86.9 MB/s - - With FPC on Win64: - 100000 FloatToText in 76.92ms i.e. 1,300,052/s, aver. 0us, 23.5 MB/s - 100000 str in 27.70ms i.e. 3,609,456/s, aver. 0us, 82.6 MB/s - 100000 DoubleToShort in 14.73ms i.e. 6,787,944/s, aver. 0us, 135.4 MB/s - 100000 DoubleToAscii in 13.78ms i.e. 7,253,735/s, aver. 0us, 147.2 MB/s - - With FPC on Linux x86_64: - 100000 FloatToText in 81.48ms i.e. 1,227,249/s, aver. 0us, 22.2 MB/s - 100000 str in 36.98ms i.e. 2,703,871/s, aver. 0us, 61.8 MB/s - 100000 DoubleToShort in 13.11ms i.e. 7,626,601/s, aver. 0us, 152.1 MB/s - 100000 DoubleToAscii in 12.59ms i.e. 7,942,180/s, aver. 0us, 161.2 MB/s - - - Our rewrite is twice faster than original flt_conv.inc from FPC RTL (str) - - Delphi Win32 has trouble making 64-bit computation - no benefit since it - has good optimized i87 asm (but slower than our code with FPC/Win32) - - FPC is more efficient when compiling integer arithmetic; we avoided slow - division by calling our Div100(), but Delphi Win64 is still far behind - - Delphi Win64 has very slow FloatToText and str() - -} - - -// Controls printing of NaN-sign. -// Undefine to print NaN sign during float->ASCII conversion. -// IEEE does not interpret the sign of a NaN, so leave it defined. -{$define GRISU1_F2A_NAN_SIGNLESS} - -// Controls rounding of generated digits when formatting with narrowed -// width (either fixed or exponential notation). -// Traditionally, FPC and BP7/Delphi use "roundTiesToAway" mode. -// Undefine to use "roundTiesToEven" approach. -{$define GRISU1_F2A_HALF_ROUNDUP} - -// This one is a hack against Grusu sub-optimality. -// It may be used only strictly together with GRISU1_F2A_HALF_ROUNDUP. -// It does not violate most general rules due to the fact that it is -// applicable only when formatting with narrowed width, where the fine -// view is more desirable, and the precision is already lost, so it can -// be used in general-purpose applications. -// Refer to its implementation. -{$define GRISU1_F2A_AGRESSIVE_ROUNDUP} // Defining this fixes several tests. - -// Undefine to enable SNaN support. -// Note: IEEE [754-2008, page 31] requires (1) to recognize "SNaN" during -// ASCII->float, and (2) to generate the "invalid FP operation" exception -// either when SNaN is printed as "NaN", or "SNaN" is evaluated to QNaN, -// so it would be preferable to undefine these settings, -// but the FPC RTL is not ready for this right now.. -{$define GRISU1_F2A_NO_SNAN} - -/// If Value=0 would just store '0', whatever frac_digits is supplied. -{$define GRISU1_F2A_ZERONOFRACT} - - -{$ifndef FPC} - -// those functions are intrinsics with FPC :) - -function BSRdword(c: cardinal): cardinal; -asm - {$ifdef CPU64} - .noframe - mov eax, c - {$endif} - bsr eax, eax -end; // in our code below, we are sure that c<>0 - -function BSRqword(const q: qword): cardinal; -asm - {$ifdef CPU32} - bsr eax, [esp + 8] - jz @1 - add eax, 32 - ret -@1: bsr eax, [esp + 4] -@2: {$else} - .noframe - mov rax, q - bsr rax, rax - {$endif} -end; // in our code below, we are sure that q<>0 - - -{$endif FPC} - -const - // TFloatFormatProfile for double - nDig_mantissa = 17; - nDig_exp10 = 3; - -type - // "Do-It-Yourself Floating Point" structures - TDIY_FP = record - f: qword; - e: integer; - end; - - TDIY_FP_Power_of_10 = record - c: TDIY_FP; - e10: integer; - end; - PDIY_FP_Power_of_10 = ^TDIY_FP_Power_of_10; - -const - ROUNDER = $80000000; - -{$ifdef CPUINTEL} // our faster version using 128-bit x86_64 multiplication - -procedure d2a_diy_fp_multiply(var x, y: TDIY_FP; normalize: boolean; - out result: TDIY_FP); {$ifdef HASINLINE} inline; {$endif} -var - p: THash128Rec; -begin - mul64x64(x.f, y.f, p); // fast x86_64 / i386 asm - if (p.c1 and ROUNDER) <> 0 then - inc(p.h); - result.f := p.h; - result.e := PtrInt(x.e) + PtrInt(y.e) + 64; - if normalize then - if (PQWordRec(@result.f)^.h and ROUNDER) = 0 then - begin - result.f := result.f * 2; - dec(result.e); - end; -end; - -{$else} // regular Grisu method - optimized for 32-bit CPUs - -procedure d2a_diy_fp_multiply(var x, y: TDIY_FP; normalize: boolean; out result: TDIY_FP); -var - _x: TQWordRec absolute x; - _y: TQWordRec absolute y; - r: TQWordRec absolute result; - ac, bc, ad, bd, t1: TQWordRec; -begin - ac.v := qword(_x.h) * _y.h; - bc.v := qword(_x.l) * _y.h; - ad.v := qword(_x.h) * _y.l; - bd.v := qword(_x.l) * _y.l; - t1.v := qword(ROUNDER) + bd.h + bc.l + ad.l; - result.f := ac.v + ad.h + bc.h + t1.h; - result.e := x.e + y.e + 64; - if normalize then - if (r.h and ROUNDER) = 0 then - begin - inc(result.f, result.f); - dec(result.e); - end; -end; - -{$endif CPUINTEL} - -const - // alpha =-61; gamma = 0 - // full cache: 1E-450 .. 1E+432, step = 1E+18 - // sparse = 1/10 - C_PWR10_DELTA = 18; - C_PWR10_COUNT = 50; - -type - TDIY_FP_Cached_Power10 = record - base: array [ 0 .. 9 ] of TDIY_FP_Power_of_10; - factor_plus: array [ 0 .. 1 ] of TDIY_FP_Power_of_10; - factor_minus: array [ 0 .. 1 ] of TDIY_FP_Power_of_10; - // extra mantissa correction [ulp; signed] - corrector: array [ 0 .. C_PWR10_COUNT - 1 ] of shortint; - end; - -const - CACHED_POWER10: TDIY_FP_Cached_Power10 = ( - base: ( - ( c: ( f: qword($825ECC24C8737830); e: -362 ); e10: -90 ), - ( c: ( f: qword($E2280B6C20DD5232); e: -303 ); e10: -72 ), - ( c: ( f: qword($C428D05AA4751E4D); e: -243 ); e10: -54 ), - ( c: ( f: qword($AA242499697392D3); e: -183 ); e10: -36 ), - ( c: ( f: qword($9392EE8E921D5D07); e: -123 ); e10: -18 ), - ( c: ( f: qword($8000000000000000); e: -63 ); e10: 0 ), - ( c: ( f: qword($DE0B6B3A76400000); e: -4 ); e10: 18 ), - ( c: ( f: qword($C097CE7BC90715B3); e: 56 ); e10: 36 ), - ( c: ( f: qword($A70C3C40A64E6C52); e: 116 ); e10: 54 ), - ( c: ( f: qword($90E40FBEEA1D3A4B); e: 176 ); e10: 72 ) - ); - factor_plus: ( - ( c: ( f: qword($F6C69A72A3989F5C); e: 534 ); e10: 180 ), - ( c: ( f: qword($EDE24AE798EC8284); e: 1132 ); e10: 360 ) - ); - factor_minus: ( - ( c: ( f: qword($84C8D4DFD2C63F3B); e: -661 ); e10: -180 ), - ( c: ( f: qword($89BF722840327F82); e: -1259 ); e10: -360 ) - ); - corrector: ( - 0, 0, 0, 0, 1, 0, 0, 0, 1, -1, - 0, 1, 1, 1, -1, 0, 0, 1, 0, -1, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - -1, 0, 0, -1, 0, 0, 0, 0, 0, -1, - 0, 0, 0, 0, 1, 0, 0, 0, -1, 0 - )); - CACHED_POWER10_MIN10 = -90 -360; - // = ref.base[low(ref.base)].e10 + ref.factor_minus[high(ref.factor_minus)].e10 - -// return normalized correctly rounded approximation of the power of 10 -// scaling factor, intended to shift a binary exponent of the original number -// into selected [ alpha .. gamma ] range -procedure d2a_diy_fp_cached_power10(exp10: integer; out factor: TDIY_FP_Power_of_10); -var - i, xmul: integer; - A, B: PDIY_FP_Power_of_10; - cx: PtrInt; - ref: ^TDIY_FP_Cached_Power10; -begin - ref := @CACHED_POWER10; // much better code generation on PIC/x86_64 - // find non-sparse index - if exp10 <= CACHED_POWER10_MIN10 then - i := 0 - else - begin - i := (exp10 - CACHED_POWER10_MIN10) div C_PWR10_DELTA; - if i * C_PWR10_DELTA + CACHED_POWER10_MIN10 <> exp10 then - inc(i); // round-up - if i > C_PWR10_COUNT - 1 then - i := C_PWR10_COUNT - 1; - end; - // generate result - xmul := i div length(ref.base); - A := @ref.base[i - (xmul * length(ref.base))]; // fast mod - dec(xmul, length(ref.factor_minus)); - if xmul = 0 then - begin - // base - factor := A^; - exit; - end; - // surrogate - if xmul > 0 then - begin - dec(xmul); - B := @ref.factor_plus[xmul]; - end - else - begin - xmul := -(xmul + 1); - B := @ref.factor_minus[xmul]; - end; - factor.e10 := A.e10 + B.e10; - if A.e10 <> 0 then - begin - d2a_diy_fp_multiply(A.c, B.c, true, factor.c); - // adjust mantissa - cx := ref.corrector[i]; - if cx <> 0 then - inc(int64(factor.c.f), int64(cx)); - end - else - // exact - factor.c := B^.c; -end; - - -procedure d2a_unpack_float(const f: double; out minus: boolean; out result: TDIY_FP); - {$ifdef HASINLINE} inline;{$endif} -type - TSplitFloat = packed record - case byte of - 0: (f: double); - 1: (b: array[0..7] of byte); - 2: (w: array[0..3] of word); - 3: (d: array[0..1] of cardinal); - 4: (l: qword); - end; -var - doublebits: TSplitFloat; -begin -{$ifdef FPC_DOUBLE_HILO_SWAPPED} - // high and low cardinal are swapped when using the arm fpa - doublebits.d[0] := TSplitFloat(f).d[1]; - doublebits.d[1] := TSplitFloat(f).d[0]; -{$else not FPC_DOUBLE_HILO_SWAPPED} - doublebits.f := f; -{$endif FPC_DOUBLE_HILO_SWAPPED} -{$ifdef endian_big} - minus := (doublebits.b[0] and $80 <> 0); - result.e := (doublebits.w[0] shr 4) and $7FF; -{$else endian_little} - minus := (doublebits.b[7] and $80 <> 0); - result.e := (doublebits.w[3] shr 4) and $7FF; -{$endif endian} - result.f := doublebits.l and $000FFFFFFFFFFFFF; -end; - -const - C_FRAC2_BITS = 52; - C_EXP2_BIAS = 1023; - C_DIY_FP_Q = 64; - C_GRISU_ALPHA = -61; - C_GRISU_GAMMA = 0; - - C_EXP2_SPECIAL = C_EXP2_BIAS * 2 + 1; - C_MANT2_INTEGER = qword(1) shl C_FRAC2_BITS; - -type - TAsciiDigits = array[0..47] of byte; - PAsciiDigits = ^TAsciiDigits; - -// convert unsigned integers into decimal digits - -{$ifdef FPC_64} // leverage efficient FPC 64-bit division as mul reciprocal - -function d2a_gen_digits_64(buf: PAsciiDigits; x: qword): PtrInt; -var - tab: PWordArray; - P: PAnsiChar; - c100: qword; -begin - tab := @TwoDigitByteLookupW; // 0..99 value -> two byte digits (0..9) - P := PAnsiChar(@buf[24]); // append backwards - repeat - if x >= 100 then - begin - dec(P, 2); - c100 := x div 100; - dec(x, c100 * 100); - PWord(P)^ := tab[x]; - if c100 = 0 then - break; - x := c100; - continue; - end; - if x < 10 then - begin - dec(P); - P^ := AnsiChar(x); - break; - end; - dec(P, 2); - PWord(P)^ := tab[x]; - break; - until false; - PQWordArray(buf)[0] := PQWordArray(P)[0]; // faster than MoveSmall(P,buf,result) - PQWordArray(buf)[1] := PQWordArray(P)[1]; - PQWordArray(buf)[2] := PQWordArray(P)[2]; - result := PAnsiChar(@buf[24]) - P; -end; - -{$else not FPC_64} // use three 32-bit groups of digit - -function d2a_gen_digits_32(buf: PAsciiDigits; x: dword; pad_9zero: boolean): PtrInt; -const - digits: array[0..9] of cardinal = ( - 0, 10, 100, 1000, 10000, 100000, 1000000, 10000000, 100000000, 1000000000); -var - n: PtrInt; - m: cardinal; - {$ifdef FPC} - z: cardinal; - {$else} - d100: TDiv100Rec; - {$endif FPC} - tab: PWordArray; -begin - // Calculate amount of digits - if x = 0 then - n := 0 // emit nothing if padding is not required - else - begin - n := integer((BSRdword(x) + 1) * 1233) shr 12; - if x >= digits[n] then - inc(n); - end; - if pad_9zero and (n < 9) then - n := 9; - result := n; - if n = 0 then - exit; - // Emit digits - dec(PByte(buf)); - tab := @TwoDigitByteLookupW; - m := x; - while (n >= 2) and (m <> 0) do - begin - dec(n); - {$ifdef FPC} // FPC will use fast mul reciprocal - z := m div 100; // compute two 0..9 digits - PWord(@buf[n])^ := tab^[m - z * 100]; - m := z; - {$else} - Div100(m, d100); // our asm is faster than Delphi div operation - PWord(@buf[n])^ := tab^[d100.M]; - m := d100.D; - {$endif FPC} - dec(n); - end; - if n = 0 then - exit; - if m <> 0 then - begin - if m > 9 then - m := m mod 10; // compute last 0..9 digit - buf[n] := m; - dec(n); - if n = 0 then - exit; - end; - repeat - buf[n] := 0; // padding with 0 - dec(n); - until n = 0; -end; - -function d2a_gen_digits_64(buf: PAsciiDigits; const x: qword): PtrInt; -var - n_digits: PtrInt; - temp: qword; - splitl, splitm, splith: cardinal; -begin - // Split X into 3 unsigned 32-bit integers; lower two should be < 10 digits long - n_digits := 0; - if x < 1000000000 then - splitl := x - else - begin - temp := x div 1000000000; - splitl := x - temp * 1000000000; - if temp < 1000000000 then - splitm := temp - else - begin - splith := temp div 1000000000; - splitm := cardinal(temp) - splith * 1000000000; - n_digits := d2a_gen_digits_32(buf, splith, false); // Generate hi digits - end; - inc(n_digits, d2a_gen_digits_32(@buf[n_digits], splitm, n_digits <> 0)); - end; - // Generate digits - inc(n_digits, d2a_gen_digits_32(@buf[n_digits], splitl, n_digits <> 0)); - result := n_digits; -end; - -{$endif FPC_64} - -// Performs digit sequence rounding, returns decimal point correction -function d2a_round_digits(var buf: TAsciiDigits; var n_current: integer; - n_max: PtrInt; half_round_to_even: boolean = true): PtrInt; -var - n: PtrInt; - dig_round, dig_sticky: byte; - {$ifdef GRISU1_F2A_AGRESSIVE_ROUNDUP} - i: PtrInt; - {$endif} -begin - result := 0; - n := n_current; - n_current := n_max; - // Get round digit - dig_round := buf[n_max]; -{$ifdef GRISU1_F2A_AGRESSIVE_ROUNDUP} - // Detect if rounding-up the second last digit turns the "dig_round" - // into "5"; also make sure we have at least 1 digit between "dig_round" - // and the second last. - if not half_round_to_even then - if (dig_round = 4) and (n_max < n - 3) then - if buf[n - 2] >= 8 then // somewhat arbitrary... - begin - // check for only "9" are in between - i := n - 2; - repeat - dec(i); - until (i = n_max) or (buf[i] <> 9); - if i = n_max then - // force round-up - dig_round := 9; // any value ">=5" - end; -{$endif GRISU1_F2A_AGRESSIVE_ROUNDUP} - if dig_round < 5 then - exit; - // Handle "round half to even" case - if (dig_round = 5) and half_round_to_even and - ((n_max = 0) or (buf[n_max - 1] and 1 = 0)) then - begin - // even and a half: check if exactly the half - dig_sticky := 0; - while (n > n_max + 1) and (dig_sticky = 0) do - begin - dec(n); - dig_sticky := buf[n]; - end; - if dig_sticky = 0 then - exit; // exactly a half -> no rounding is required - end; - // Round-up - while n_max > 0 do - begin - dec(n_max); - inc(buf[n_max]); - if buf[n_max] < 10 then - begin - // no more overflow: stop now - n_current := n_max + 1; - exit; - end; - // continue rounding - end; - // Overflow out of the 1st digit, all n_max digits became 0 - buf[0] := 1; - n_current := 1; - result := 1; -end; - - -// format the number in the fixed-point representation -procedure d2a_return_fixed(str: PAnsiChar; minus: boolean; var digits: TAsciiDigits; - n_digits_have, fixed_dot_pos, frac_digits: integer); -var - p: PAnsiChar; - d: PByte; - cut_digits_at, n_before_dot, n_before_dot_pad0, n_after_dot_pad0, - n_after_dot, n_tail_pad0: integer; -begin - // Round digits if necessary - cut_digits_at := fixed_dot_pos + frac_digits; - if cut_digits_at < 0 then - // zero - n_digits_have := 0 - else if cut_digits_at < n_digits_have then - // round digits - inc(fixed_dot_pos, d2a_round_digits(digits, n_digits_have, cut_digits_at - {$ifdef GRISU1_F2A_HALF_ROUNDUP}, false {$endif} )); - // Before dot: digits, pad0 - if (fixed_dot_pos <= 0) or (n_digits_have = 0) then - begin - n_before_dot := 0; - n_before_dot_pad0 := 1; - end - else if fixed_dot_pos > n_digits_have then - begin - n_before_dot := n_digits_have; - n_before_dot_pad0 := fixed_dot_pos - n_digits_have; - end - else - begin - n_before_dot := fixed_dot_pos; - n_before_dot_pad0 := 0; - end; - // After dot: pad0, digits, pad0 - if fixed_dot_pos < 0 then - n_after_dot_pad0 := -fixed_dot_pos - else - n_after_dot_pad0 := 0; - if n_after_dot_pad0 > frac_digits then - n_after_dot_pad0 := frac_digits; - n_after_dot := n_digits_have - n_before_dot; - n_tail_pad0 := frac_digits - n_after_dot - n_after_dot_pad0; - p := str + 1; - // Sign - if minus then - begin - p^ := '-'; - inc(p); - end; - // Integer significant digits - d := @digits; - if n_before_dot > 0 then - repeat - p^ := AnsiChar(d^ + ord('0')); - inc(p); - inc(d); - dec(n_before_dot); - until n_before_dot = 0; - // Integer 0-padding - if n_before_dot_pad0 > 0 then - repeat - p^ := '0'; - inc(p); - dec(n_before_dot_pad0); - until n_before_dot_pad0 = 0; - // - if frac_digits <> 0 then - begin - // Dot - p^ := '.'; - inc(p); - // Pre-fraction 0-padding - if n_after_dot_pad0 > 0 then - repeat - p^ := '0'; - inc(p); - dec(n_after_dot_pad0); - until n_after_dot_pad0 = 0; - // Fraction significant digits - if n_after_dot > 0 then - repeat - p^ := AnsiChar(d^ + ord('0')); - inc(p); - inc(d); - dec(n_after_dot); - until n_after_dot = 0; - // Tail 0-padding - if n_tail_pad0 > 0 then - repeat - p^ := '0'; - inc(p); - dec(n_tail_pad0); - until n_tail_pad0 = 0; - end; - // Store length - str[0] := AnsiChar(p - str - 1); -end; - -// formats the number as exponential representation -procedure d2a_return_exponential(str: PAnsiChar; minus: boolean; - digits: PByte; n_digits_have, n_digits_req, d_exp: PtrInt); -var - p, exp: PAnsiChar; -begin - p := str + 1; - // Sign - if minus then - begin - p^ := '-'; - inc(p); - end; - // Integer part - if n_digits_have > 0 then - begin - p^ := AnsiChar(digits^ + ord('0')); - dec(n_digits_have); - end - else - p^ := '0'; - inc(p); - // Dot - if n_digits_req > 1 then - begin - p^ := '.'; - inc(p); - end; - // Fraction significant digits - if n_digits_req < n_digits_have then - n_digits_have := n_digits_req; - if n_digits_have > 0 then - begin - repeat - inc(digits); - p^ := AnsiChar(digits^ + ord('0')); - inc(p); - dec(n_digits_have); - until n_digits_have = 0; - while p[-1] = '0' do - dec(p); // trim #.###00000 -> #.### - if p[-1] = '.' then - dec(p); // #.0 -> # - end; - // Exponent designator - p^ := 'E'; - inc(p); - // Exponent sign (+ is not stored, as in Delphi) - if d_exp < 0 then - begin - p^ := '-'; - d_exp := -d_exp; - inc(p); - end; - // Exponent digits - exp := pointer(SmallUInt32UTF8[d_exp]); // 0..999 range is fine - PCardinal(p)^ := PCardinal(exp)^; - inc(p, PStrLen(exp - _STRLEN)^); - // Store length - str[0] := AnsiChar(p - str - 1); -end; - -/// set one of special results with proper sign -procedure d2a_return_special(str: PAnsiChar; sign: integer; const spec: shortstring); -begin - // Compute length - str[0] := spec[0]; - if sign <> 0 then - inc(str[0]); - inc(str); - // Sign - if sign <> 0 then - begin - if sign > 0 then - str^ := '+' - else - str^ := '-'; - inc(str); - end; - // Special text (3 chars) - PCardinal(str)^ := PCardinal(@spec[1])^; -end; - - -// Calculates the exp10 of a factor required to bring the binary exponent -// of the original number into selected [ alpha .. gamma ] range: -// result := ceiling[ ( alpha - e ) * log10(2) ] -function d2a_k_comp(e, alpha{, gamma}: integer): integer; -var - dexp: double; -const - D_LOG10_2: double = 0.301029995663981195213738894724493027; // log10(2) -var - x, n: integer; -begin - x := alpha - e; - dexp := x * D_LOG10_2; - // ceil( dexp ) - n := trunc(dexp); - if x > 0 then - if dexp <> n then - inc(n); // round-up - result := n; -end; - - -/// raw function to convert a 64-bit double into a shortstring, stored in str -// - implements Fabian Loitsch's Grisu algorithm dedicated to double values -// - currently, SynCommnons only set min_width=0 (for DoubleToShortNoExp to avoid -// any scientific notation ) or min_width=C_NO_MIN_WIDTH (for DoubleToShort to -// force the scientific notation when the double cannot be represented as -// a simple fractinal number) -procedure DoubleToAscii(min_width, frac_digits: integer; const v: double; str: PAnsiChar); -var - w, D: TDIY_FP; - c_mk: TDIY_FP_Power_of_10; - n, mk, dot_pos, n_digits_need, n_digits_have: integer; - n_digits_req, n_digits_sci: integer; - minus: boolean; - fl, one_maskl: qword; - one_e: integer; - {$ifdef CPU32} - one_mask, f: cardinal; // run a 2nd loop with 32-bit range - {$endif CPU32} - buf: TAsciiDigits; -begin - // Limit parameters - if frac_digits > 216 then - frac_digits := 216; // Delphi compatible - if min_width <= C_NO_MIN_WIDTH then - min_width := -1 // no minimal width - else if min_width < 0 then - min_width := 0; // minimal width is as short as possible - // Format profile: select "n_digits_need" (and "n_digits_exp") - n_digits_req := nDig_mantissa; - // number of digits to be calculated by Grisu - n_digits_need := nDig_mantissa; - if n_digits_req < n_digits_need then - n_digits_need := n_digits_req; - // number of mantissa digits to be printed in exponential notation - if min_width < 0 then - n_digits_sci := n_digits_req - else - begin - n_digits_sci := min_width -1 {sign} -1 {dot} -1 {E} -1 {E-sign} - nDig_exp10; - if n_digits_sci < 2 then - n_digits_sci := 2; // at least 2 digits - if n_digits_sci > n_digits_req then - n_digits_sci := n_digits_req; // at most requested by real_type - end; - // Float -> DIY_FP - d2a_unpack_float(v, minus, w); - // Handle Zero - if (w.e = 0) and (w.f = 0) then - begin - {$ifdef GRISU1_F2A_ZERONOFRACT} - PWord(str)^ := 1 + ord('0') shl 8; // just return '0' - {$else} - if frac_digits >= 0 then - d2a_return_fixed(str, minus, buf, 0, 1, frac_digits) - else - d2a_return_exponential(str, minus, @buf, 0, n_digits_sci, 0); - {$endif GRISU1_F2A_ZERONOFRACT} - exit; - end; - // Handle specials - if w.e = C_EXP2_SPECIAL then - begin - n := 1 - ord(minus) * 2; // default special sign [-1|+1] - if w.f = 0 then - d2a_return_special(str, n, C_STR_INF) - else - begin - // NaN [also pseudo-NaN, pseudo-Inf, non-normal for floatx80] - {$ifdef GRISU1_F2A_NAN_SIGNLESS} - n := 0; - {$endif} - {$ifndef GRISU1_F2A_NO_SNAN} - if (w.f and (C_MANT2_INTEGER shr 1)) = 0 then - return_special(str, n, C_STR_SNAN) - else - {$endif GRISU1_F2A_NO_SNAN} - d2a_return_special(str, n, C_STR_QNAN); - end; - exit; - end; - // Handle denormals - if w.e <> 0 then - begin - // normal - w.f := w.f or C_MANT2_INTEGER; - n := C_DIY_FP_Q - C_FRAC2_BITS - 1; - end - else - begin - // denormal (w.e=0) - n := 63 - BSRqword(w.f); // we are sure that w.f<>0 - see Handle Zero above - inc(w.e); - end; - // Final normalization - w.f := w.f shl n; - dec(w.e, C_EXP2_BIAS + n + C_FRAC2_BITS); - // 1. Find the normalized "c_mk = f_c * 2^e_c" such that - // "alpha <= e_c + e_w + q <= gamma" - // 2. Define "V = D * 10^k": multiply the input number by "c_mk", do not - // normalize to land into [ alpha .. gamma ] - // 3. Generate digits ( n_digits_need + "round" ) - if (C_GRISU_ALPHA <= w.e) and (w.e <= C_GRISU_GAMMA) then - begin - // no scaling required - D := w; - c_mk.e10 := 0; - end - else - begin - mk := d2a_k_comp(w.e, C_GRISU_ALPHA{, C_GRISU_GAMMA} ); - d2a_diy_fp_cached_power10(mk, c_mk); - // Let "D = f_D * 2^e_D := w (*) c_mk" - if c_mk.e10 = 0 then - D := w - else - d2a_diy_fp_multiply(w, c_mk.c, false, D); - end; - // Generate digits: integer part - n_digits_have := d2a_gen_digits_64(@buf, D.f shr (-D.e)); - dot_pos := n_digits_have; - // Generate digits: fractional part - {$ifdef CPU32} - f := 0; // "sticky" digit - {$endif CPU32} - if D.e < 0 then - repeat - // MOD by ONE - one_e := D.e; - one_maskl := qword(1) shl (-D.e) - 1; - fl := D.f and one_maskl; - // 64-bit loop (very efficient on x86_64, slower on i386) - while {$ifdef CPU32} (one_e < -29) and {$endif} - (n_digits_have < n_digits_need + 1) and (fl <> 0) do - begin - // f := f * 5; - inc(fl, fl shl 2); - // one := one / 2 - one_maskl := one_maskl shr 1; - inc(one_e); - // DIV by one - buf[n_digits_have] := fl shr (-one_e); - // MOD by one - fl := fl and one_maskl; - // next - inc(n_digits_have); - end; - {$ifdef CPU32} - if n_digits_have >= n_digits_need + 1 then - begin - // only "sticky" digit remains - f := ord(fl <> 0); - break; - end; - one_mask := cardinal(one_maskl); - f := cardinal(fl); - // 32-bit loop - while (n_digits_have < n_digits_need + 1) and (f <> 0) do - begin - // f := f * 5; - inc(f, f shl 2); - // one := one / 2 - one_mask := one_mask shr 1; - inc(one_e); - // DIV by one - buf[n_digits_have] := f shr (-one_e); - // MOD by one - f := f and one_mask; - // next - inc(n_digits_have); - end; - {$endif CPU32} - until true; - {$ifdef CPU32} - // Append "sticky" digit if any - if (f <> 0) and (n_digits_have >= n_digits_need + 1) then - begin - // single "<>0" digit is enough - n_digits_have := n_digits_need + 2; - buf[n_digits_need + 1] := 1; - end; - {$endif CPU32} - // Round to n_digits_need using "roundTiesToEven" - if n_digits_have > n_digits_need then - inc(dot_pos, d2a_round_digits(buf, n_digits_have, n_digits_need)); - // Generate output - if frac_digits >= 0 then - begin - d2a_return_fixed(str, minus, buf, n_digits_have, dot_pos - c_mk.e10, - frac_digits); - exit; - end; - if n_digits_have > n_digits_sci then - inc(dot_pos, d2a_round_digits(buf, n_digits_have, n_digits_sci - {$ifdef GRISU1_F2A_HALF_ROUNDUP}, false {$endif} )); - d2a_return_exponential(str, minus, @buf, n_digits_have, n_digits_sci, - dot_pos - c_mk.e10 - 1); -end; - diff --git a/lib/dmustache/SynFPCLinux.pas b/lib/dmustache/SynFPCLinux.pas deleted file mode 100644 index b6b8671f..00000000 --- a/lib/dmustache/SynFPCLinux.pas +++ /dev/null @@ -1,1201 +0,0 @@ -/// wrapper of some Windows-like functions translated to Linux/BSD for FPC -// - this unit is a part of the freeware Synopse mORMot framework, -// licensed under a MPL/GPL/LGPL tri-license; version 1.18 -unit SynFPCLinux; - -{ - This file is part of Synopse mORMot framework. - - Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez - Synopse Informatique - https://synopse.info - - *** BEGIN LICENSE BLOCK ***** - Version: MPL 1.1/GPL 2.0/LGPL 2.1 - - The contents of this file are subject to the Mozilla Public License Version - 1.1 (the "License"); you may not use this file except in compliance with - the License. You may obtain a copy of the License at - http://www.mozilla.org/MPL - - Software distributed under the License is distributed on an "AS IS" basis, - WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License - for the specific language governing rights and limitations under the License. - - The Original Code is Synopse mORMot framework. - - The Initial Developer of the Original Code is Alfred Glaenzer. - - Portions created by the Initial Developer are Copyright (C) 2022 - the Initial Developer. All Rights Reserved. - - Contributor(s): - - Alan Chate - - Arnaud Bouchez - - - Alternatively, the contents of this file may be used under the terms of - either the GNU General Public License Version 2 or later (the "GPL"), or - the GNU Lesser General Public License Version 2.1 or later (the "LGPL"), - in which case the provisions of the GPL or the LGPL are applicable instead - of those above. if you wish to allow use of your version of this file only - under the terms of either the GPL or the LGPL, and not to allow others to - use your version of this file under the terms of the MPL, indicate your - decision by deleting the provisions above and replace them with the notice - and other provisions required by the GPL or the LGPL. if you do not delete - the provisions above, a recipient may use your version of this file under - the terms of any one of the MPL, the GPL or the LGPL. - - ***** END LICENSE BLOCK ***** - -} - -interface - - -{$ifndef FPC} - 'this unit is for FPC only - do not include it in any Delphi project!' -{$endif FPC} - - -{$I Synopse.inc} // set proper flags, and define LINUX for BSD and ANDROID - -uses - {$ifdef LINUX} - BaseUnix, - UnixType, - {$endif LINUX} - SysUtils; - -const - { HRESULT codes, delphi-like } - NOERROR = 0; - NO_ERROR = 0; - INVALID_HANDLE_VALUE = THandle(-1); - - LOCALE_USER_DEFAULT = $400; - - // for CompareStringW() - NORM_IGNORECASE = 1 shl ord(coIgnoreCase); // [widestringmanager.coIgnoreCase] - -/// compatibility function, wrapping Win32 API mutex initialization -procedure InitializeCriticalSection(var cs : TRTLCriticalSection); inline; - -/// compatibility function, wrapping Win32 API mutex finalization -procedure DeleteCriticalSection(var cs : TRTLCriticalSection); inline; - -{$ifdef LINUX} - -/// used by SynCommons to compute the sizes in byte -function getpagesize: Integer; cdecl; external 'c'; - -/// compatibility function, wrapping Win32 API high resolution timer -// - returns nanoseconds resolution, calling e.g. CLOCK_MONOTONIC on Linux/BSD -procedure QueryPerformanceCounter(out Value: Int64); - -/// slightly faster than QueryPerformanceCounter() div 1000 - but not for Windows -// - returns microseconds resolution, calling e.g. CLOCK_MONOTONIC on Linux/BSD -procedure QueryPerformanceMicroSeconds(out Value: Int64); inline; - -/// compatibility function, wrapping Win32 API high resolution timer -// - hardcoded to 1e9 for clock_gettime() nanoseconds resolution on Linux/BSD -function QueryPerformanceFrequency(out Value: Int64): boolean; - -/// compatibility function, wrapping Win32 API file position change -function SetFilePointer(hFile: cInt; lDistanceToMove: TOff; - lpDistanceToMoveHigh: Pointer; dwMoveMethod: cint): TOff; inline; - -/// compatibility function, wrapping Win32 API file size retrieval -function GetFileSize(hFile: cInt; lpFileSizeHigh: PDWORD): DWORD; - -/// compatibility function, wrapping Win32 API file truncate at current position -procedure SetEndOfFile(hFile: cInt); inline; - -/// compatibility function, wrapping Win32 API file flush to disk -procedure FlushFileBuffers(hFile: cInt); inline; - -/// compatibility function, wrapping Win32 API last error code -function GetLastError: longint; inline; - -/// compatibility function, wrapping Win32 API last error code -procedure SetLastError(error: longint); inline; - -/// compatibility function, wrapping Win32 API text comparison -// - will use the system ICU library if available, or the widestringmanager -// - seldom called, unless our proprietary WIN32CASE collation is used in SynSQLite3 -function CompareStringW(GetThreadLocale: DWORD; dwCmpFlags: DWORD; lpString1: PWideChar; - cchCount1: integer; lpString2: PWideChar; cchCount2: integer): integer; - -/// compatibility function, wrapping Win32 API text case conversion -function CharUpperBuffW(W: PWideChar; WLen: integer): integer; - -/// compatibility function, wrapping Win32 API text case conversion -function CharLowerBuffW(W: PWideChar; WLen: integer): integer; - -/// compatibility function, wrapping Win32 MultiByteToWideChar API conversion -// - will use the system ICU library for efficient conversion -function AnsiToWideICU(codepage: cardinal; Source: PAnsiChar; Dest: PWideChar; - SourceChars: PtrInt): PtrInt; - -/// compatibility function, wrapping Win32 WideCharToMultiByte API conversion -// - will use the system ICU library for efficient conversion -function WideToAnsiICU(codepage: cardinal; Source: PWideChar; Dest: PAnsiChar; - SourceChars: PtrInt): PtrInt; - -/// returns the current UTC time -// - will convert from clock_gettime(CLOCK_REALTIME_COARSE) if available -function GetNowUTC: TDateTime; - -/// returns the current UTC time, as Unix Epoch seconds -// - will call clock_gettime(CLOCK_REALTIME_COARSE) if available -function GetUnixUTC: Int64; - -/// returns the current UTC time, as Unix Epoch milliseconds -// - will call clock_gettime(CLOCK_REALTIME_COARSE) if available -function GetUnixMSUTC: Int64; - -/// returns the current UTC time as TSystemTime -// - will convert from clock_gettime(CLOCK_REALTIME_COARSE) if available -procedure GetNowUTCSystem(out result: TSystemTime); - -var - /// will contain the current Linux kernel revision, as one 24-bit integer - // - e.g. $030d02 for 3.13.2, or $020620 for 2.6.32 - KernelRevision: cardinal; - -/// calls the pthread_setname_np() function, if available on this system -// - under Linux/FPC, this API truncates the name to 16 chars -procedure SetUnixThreadName(ThreadID: TThreadID; const Name: RawByteString); - -/// calls mprotect() syscall or clib -function SynMProtect(addr:pointer; size:size_t; prot:integer): longint; - -{$ifdef BSD} -function fpsysctlhwint(hwid: cint): Int64; -function fpsysctlhwstr(hwid: cint; var temp: shortstring): pointer; -{$endif BSD} - -{$ifndef DARWIN} // OSX has no clock_gettime() API - -{$ifdef BSD} -const // see https://github.com/freebsd/freebsd/blob/master/sys/sys/time.h - CLOCK_REALTIME = 0; -{$ifdef OpenBSD} - CLOCK_MONOTONIC = 3; - CLOCK_REALTIME_COARSE = CLOCK_REALTIME; // no faster alternative - CLOCK_MONOTONIC_COARSE = CLOCK_MONOTONIC; -{$else} - CLOCK_MONOTONIC = 4; - CLOCK_REALTIME_COARSE = 10; // named CLOCK_REALTIME_FAST in FreeBSD 8.1+ - CLOCK_MONOTONIC_COARSE = 12; -{$endif OPENBSD} - -{$else} -const - CLOCK_REALTIME = 0; - CLOCK_MONOTONIC = 1; - CLOCK_REALTIME_COARSE = 5; // see http://lwn.net/Articles/347811 - CLOCK_MONOTONIC_COARSE = 6; -{$endif BSD} - -var - // contains CLOCK_REALTIME_COARSE since kernel 2.6.32 - CLOCK_REALTIME_FAST: integer = CLOCK_REALTIME; - // contains CLOCK_MONOTONIC_COARSE since kernel 2.6.32 - CLOCK_MONOTONIC_FAST: integer = CLOCK_MONOTONIC; - -{$endif DARWIN} -{$endif LINUX} - -/// compatibility function, to be implemented according to the running OS -// - expect more or less the same result as the homonymous Win32 API function -// - will call clock_gettime(CLOCK_MONOTONIC_COARSE) if available -function GetTickCount64: Int64; - -/// compatibility function, to be implemented according to the running OS -// - expect more or less the same result as the homonymous Win32 API function -// - will call clock_gettime(CLOCK_MONOTONIC_COARSE) if available -function GetTickCount: cardinal; - -var - /// could be set to TRUE to force SleepHiRes(0) to call the sched_yield API - // - in practice, it has been reported as buggy under POSIX systems - // - even Linus Torvald himself raged against its usage - see e.g. - // https://www.realworldtech.com/forum/?threadid=189711&curpostid=189752 - // - you may tempt the devil and try it by yourself - SleepHiRes0Yield: boolean = false; - -/// similar to Windows sleep() API call, to be truly cross-platform -// - using millisecond resolution -// - SleepHiRes(0) calls ThreadSwitch on windows, but this POSIX version will -// wait 10 microsecond unless SleepHiRes0Yield is forced to true (bad idea) -// - in respect to RTL's Sleep() function, it will return on ESysEINTR -procedure SleepHiRes(ms: cardinal); - -/// check if any char is pending from StdInputHandle file descriptor -function UnixKeyPending: boolean; - - -{$ifdef LINUX} - -type - /// the libraries supported by TExternalLibrariesAPI - TExternalLibrary = ( - elPThread, elICU {$ifdef LINUXNOTBSD} , elSystemD {$endif}); - /// set of libraries supported by TExternalLibrariesAPI - TExternalLibraries = set of TExternalLibrary; - - /// implements late-binding of system libraries - // - about systemd: see https://www.freedesktop.org/wiki/Software/systemd - // and http://0pointer.de/blog/projects/socket-activation.html - to get headers - // on debian: `sudo apt install libsystemd-dev && cd /usr/include/systemd` - TExternalLibrariesAPI = object - private - Lock: TRTLCriticalSection; - Loaded: TExternalLibraries; - {$ifdef LINUX} - pthread: pointer; - {$ifdef LINUXNOTBSD} - systemd: pointer; - {$endif LINUXNOTBSD} - {$endif LINUX} - icu, icudata, icui18n: pointer; - procedure LoadIcuWithVersion; - procedure Done; - public - {$ifdef LINUXNOTBSD} - /// customize the name of a thread (truncated to 16 bytes) - // - see https://stackoverflow.com/a/7989973 - pthread_setname_np: function(thread: pointer; name: PAnsiChar): longint; cdecl; - /// systemd: returns how many file descriptors have been passed to process - // - if result=1 then socket for accepting connection is SD_LISTEN_FDS_START - sd_listen_fds: function(unset_environment: integer): integer; cdecl; - /// systemd: returns 1 if the file descriptor is an AF_UNIX socket of the specified type and path - sd_is_socket_unix: function(fd, typr, listening: integer; - var path: TFileName; pathLength: PtrUInt): integer; cdecl; - /// systemd: submit simple, plain text log entries to the system journal - // - priority value can be obtained using longint(LOG_TO_SYSLOG[logLevel]) - // - WARNING: args strings processed using C printf semantic, so % is a printf - // placeholder and should be either escaped using %% or all formatting args must be passed - sd_journal_print: function(priority: longint; args: array of const): longint; cdecl; - /// systemd: submit array of iov structures instead of the format string to the system journal. - // - each structure should reference one field of the entry to submit. - // - the second argument specifies the number of structures in the array. - sd_journal_sendv: function(const iov: Piovec; n: longint): longint; cdecl; - /// systemd: sends notification to systemd - // - see https://www.freedesktop.org/software/systemd/man/sd_notify.html - // status notification sample: sd.notify(0, 'READY=1'); - // watchdog notification: sd.notify(0, 'WATCHDOG=1'); - sd_notify: function(unset_environment: longint; state: PAnsiChar): longint; cdecl; - /// systemd: check whether the service manager expects watchdog keep-alive - // notifications from a service - // - if result > 0 then usec contains the notification interval (app should - // notify every usec/2) - sd_watchdog_enabled: function(unset_environment: longint; usec: Puint64): longint; cdecl; - {$endif LINUXNOTBSD} - /// Initialize an ICU text converter for a given encoding - ucnv_open: function (converterName: PAnsiChar; var err: SizeInt): pointer; cdecl; - /// finalize the ICU text converter for a given encoding - ucnv_close: procedure (converter: pointer); cdecl; - /// customize the ICU text converter substitute char - ucnv_setSubstChars: procedure (converter: pointer; - subChars: PAnsiChar; len: byte; var err: SizeInt); cdecl; - /// enable the ICU text converter fallback - ucnv_setFallback: procedure (cnv: pointer; usesFallback: LongBool); cdecl; - /// ICU text conversion from UTF-16 to a given encoding - ucnv_fromUChars: function (cnv: pointer; dest: PAnsiChar; destCapacity: cardinal; - src: PWideChar; srcLength: cardinal; var err: SizeInt): cardinal; cdecl; - /// ICU text conversion from a given encoding to UTF-16 - ucnv_toUChars: function (cnv: pointer; dest: PWideChar; destCapacity: cardinal; - src: PAnsiChar; srcLength: cardinal; var err: SizeInt): cardinal; cdecl; - /// ICU UTF-16 text conversion to uppercase - u_strToUpper: function (dest: PWideChar; destCapacity: cardinal; - src: PWideChar; srcLength: cardinal; locale: PAnsiChar; - var err: SizeInt): cardinal; cdecl; - /// ICU UTF-16 text conversion to lowercase - u_strToLower: function (dest: PWideChar; destCapacity: cardinal; - src: PWideChar; srcLength: cardinal; locale: PAnsiChar; - var err: SizeInt): cardinal; cdecl; - /// ICU UTF-16 text comparison - u_strCompare: function (s1: PWideChar; length1: cardinal; - s2: PWideChar; length2: cardinal; codePointOrder: LongBool): cardinal; cdecl; - /// ICU UTF-16 text comparison with options, e.g. for case-insensitive - u_strCaseCompare: function (s1: PWideChar; length1: cardinal; - s2: PWideChar; length2: cardinal; options: cardinal; - var err: SizeInt): cardinal; cdecl; - /// get the ICU data folder - u_getDataDirectory: function: PAnsiChar; cdecl; - /// set the ICU data folder - u_setDataDirectory: procedure(directory: PAnsiChar); cdecl; - /// initialize the ICU library - u_init: procedure(var status: SizeInt); cdecl; - /// Initialize an ICU text converter for a given codepage - // - returns nil if ICU is not available on this system - function ucnv(codepage: cardinal): pointer; - /// thread-safe loading of a system library - // - caller should then check the API function to be not nil - procedure EnsureLoaded(lib: TExternalLibrary); - end; - -var - /// late-binding of system libraries - ExternalLibraries: TExternalLibrariesAPI; - -{$ifdef LINUXNOTBSD} { the systemd API is Linux-specific } - -const - /// The first passed file descriptor is fd 3 - SD_LISTEN_FDS_START = 3; - - /// low-level libcurl library file name, depending on the running OS - LIBSYSTEMD_PATH = 'libsystemd.so.0'; - - ENV_INVOCATION_ID: PAnsiChar = 'INVOCATION_ID'; - -type - /// low-level exception raised during systemd library access - ESystemd = class(Exception); - -/// returns true in case process is started by systemd -// - For systemd v232+ -function ProcessIsStartedBySystemd: boolean; - -/// initialize the libsystemd API -// - do nothing if the library has already been loaded -// - will raise ESsytemd exception on any loading issue -procedure LibSystemdInitialize; - -/// returns TRUE if a systemd library is available -// - will load and initialize it, calling LibSystemdInitialize if necessary, -// catching any exception during the process -function SystemdIsAvailable: boolean; inline; - -{$endif LINUXNOTBSD} - -{$endif LINUX} - - -implementation - -{$ifdef LINUX} -uses - Classes, - Unix, - {$ifdef BSD} - sysctl, - {$else} - Linux, - SysCall, - {$endif BSD} - dl; -{$endif LINUX} - -procedure InitializeCriticalSection(var cs : TRTLCriticalSection); -begin - InitCriticalSection(cs); -end; - -procedure DeleteCriticalSection(var cs : TRTLCriticalSection); -begin - {$ifdef LINUXNOTBSD} - if cs.__m_kind<>0 then - {$else} - {$ifdef BSD} - {$ifdef Darwin} - if cs.sig<>0 then - {$else} - if Assigned(cs) then - {$endif Darwin} - {$endif BSD} - {$endif LINUXNOTBSD} - DoneCriticalSection(cs); -end; - -function UnixKeyPending: boolean; -var - fdsin: tfdSet; -begin - fpFD_ZERO(fdsin); - fpFD_SET(StdInputHandle,fdsin); - result := fpSelect(StdInputHandle+1,@fdsin,nil,nil,0)>0; -end; - -{$ifdef LINUX} - -const // Date Translation - see http://en.wikipedia.org/wiki/Julian_day - HoursPerDay = 24; - MinsPerHour = 60; - SecsPerMin = 60; - MinsPerDay = HoursPerDay*MinsPerHour; - SecsPerDay = MinsPerDay*SecsPerMin; - SecsPerHour = MinsPerHour*SecsPerMin; - C1970 = 2440588; - D0 = 1461; - D1 = 146097; - D2 = 1721119; - UnixDelta = 25569; - - C_THOUSAND = Int64(1000); - C_MILLION = Int64(C_THOUSAND * C_THOUSAND); - C_BILLION = Int64(C_THOUSAND * C_THOUSAND * C_THOUSAND); - -procedure JulianToGregorian(JulianDN: PtrUInt; out result: TSystemTime); - {$ifdef HASINLINE}inline;{$endif} -var YYear,XYear,Temp,TempMonth: PtrUInt; -begin - Temp := ((JulianDN-D2)*4)-1; - JulianDN := Temp div D1; - XYear := (Temp-(JulianDN*D1)) or 3; - YYear := XYear div D0; - Temp := (((XYear-(YYear*D0)+4) shr 2)*5)-3; - TempMonth := Temp div 153; - result.Day := ((Temp-(TempMonth*153))+5) div 5; - if TempMonth>=10 then begin - inc(YYear); - dec(TempMonth,12-3); - end else - inc(TempMonth,3); - result.Month := TempMonth; - result.Year := YYear+(JulianDN*100); - // initialize fake dayOfWeek - as used by SynCommons.FromGlobalTime RCU128 - result.DayOfWeek := 0; -end; - -procedure EpochToSystemTime(epoch: PtrUInt; out result: TSystemTime); -var t: PtrUInt; -begin - t := epoch div SecsPerDay; - JulianToGregorian(t+C1970,result); - dec(epoch,t*SecsPerDay); - t := epoch div SecsPerHour; - result.Hour := t; - dec(epoch,t*SecsPerHour); - t := epoch div SecsPerMin; - result.Minute := t; - result.Second := epoch-t*SecsPerMin; -end; - -function GetTickCount: cardinal; -begin - result := cardinal(GetTickCount64); -end; - -{$ifdef DARWIN} -// clock_gettime() is not implemented: http://stackoverflow.com/a/5167506 - -type - TTimebaseInfoData = record - Numer: cardinal; - Denom: cardinal; - end; - -function mach_absolute_time: UInt64; - cdecl external 'libc.dylib' name 'mach_absolute_time'; -function mach_timebase_info(var TimebaseInfoData: TTimebaseInfoData): Integer; - cdecl external 'libc.dylib' name 'mach_timebase_info'; - -var - mach_timeinfo: TTimebaseInfoData; - mach_timecoeff: double; - mach_timenanosecond: boolean; // very likely to be TRUE on Intel CPUs - -procedure QueryPerformanceCounter(out Value: Int64); -begin // returns time in nano second resolution - Value := mach_absolute_time; - if mach_timeinfo.Denom=1 then - if mach_timeinfo.Numer=1 then - // seems to be the case on Intel CPUs - exit else - Value := Value*mach_timeinfo.Numer else - // use floating point to avoid potential overflow - Value := round(Value*mach_timecoeff); -end; - -procedure QueryPerformanceMicroSeconds(out Value: Int64); -begin - if mach_timenanosecond then - Value := mach_absolute_time div C_THOUSAND else begin - QueryPerformanceCounter(Value); - Value := Value div C_THOUSAND; // ns to us - end; -end; - -function GetTickCount64: Int64; -begin - if mach_timenanosecond then - result := mach_absolute_time else - QueryPerformanceCounter(result); - result := result div C_MILLION; // ns to ms -end; - -function GetUnixUTC: Int64; -var tz: timeval; -begin - fpgettimeofday(@tz,nil); - result := tz.tv_sec; -end; - -function GetUnixMSUTC: Int64; -var tz: timeval; -begin - fpgettimeofday(@tz,nil); - result := (tz.tv_sec*C_THOUSAND)+tz.tv_usec div C_THOUSAND; // in milliseconds -end; - -procedure GetNowUTCSystem(out result: TSystemTime); -var tz: timeval; -begin - fpgettimeofday(@tz,nil); - EpochToSystemTime(tz.tv_sec,result); - result.MilliSecond := tz.tv_usec div C_THOUSAND; -end; - -{$else} - -{$ifdef BSD} - -function clock_gettime(ID: cardinal; r: ptimespec): Integer; - cdecl external 'libc.so' name 'clock_gettime'; -function clock_getres(ID: cardinal; r: ptimespec): Integer; - cdecl external 'libc.so' name 'clock_getres'; - -{$else} - -// libc's clock_gettime function uses vDSO (avoid syscall) while FPC by default -// is compiled without FPC_USE_LIBC defined and do a syscall each time -// GetTickCount64 fpc 2 494 563 op/sec -// GetTickCount64 libc 119 919 893 op/sec -// note: for high-resolution QueryPerformanceMicroSeconds, calling the kernel -// is also slower -function clock_gettime(clk_id : clockid_t; tp: ptimespec) : cint; - cdecl; external 'c' name 'clock_gettime'; - -{$endif BSD} - -function GetTickCount64: Int64; -var tp: timespec; -begin - clock_gettime(CLOCK_MONOTONIC_FAST,@tp); // likely = CLOCK_MONOTONIC_COARSE - Result := (Int64(tp.tv_sec) * C_THOUSAND) + (tp.tv_nsec div C_MILLION); // in ms -end; - -function GetUnixMSUTC: Int64; -var r: timespec; -begin - clock_gettime(CLOCK_REALTIME_FAST,@r); // likely = CLOCK_REALTIME_COARSE - result := (Int64(r.tv_sec) * C_THOUSAND) + (r.tv_nsec div C_MILLION); // in ms -end; - -function GetUnixUTC: Int64; -var r: timespec; -begin - clock_gettime(CLOCK_REALTIME_FAST,@r); - result := r.tv_sec; -end; - -procedure QueryPerformanceCounter(out Value: Int64); -var r : TTimeSpec; -begin - clock_gettime(CLOCK_MONOTONIC, @r); - value := r.tv_nsec+r.tv_sec*C_BILLION; // returns nanoseconds resolution -end; - -procedure QueryPerformanceMicroSeconds(out Value: Int64); -var r : TTimeSpec; -begin - clock_gettime(CLOCK_MONOTONIC, @r); - value := PtrUInt(r.tv_nsec) div C_THOUSAND+r.tv_sec*C_MILLION; // as microseconds -end; - -procedure GetNowUTCSystem(out result: TSystemTime); -var r: timespec; -begin - clock_gettime(CLOCK_REALTIME_FAST,@r); // faster than fpgettimeofday() - EpochToSystemTime(r.tv_sec,result); - result.MilliSecond := r.tv_nsec div C_MILLION; -end; - -{$endif DARWIN} - -{$ifdef BSD} -function fpsysctlhwint(hwid: cint): Int64; -var mib: array[0..1] of cint; - len: cint; -begin - result := 0; - mib[0] := CTL_HW; - mib[1] := hwid; - len := SizeOf(result); - fpsysctl(pointer(@mib),2,@result,@len,nil,0); -end; - -function fpsysctlhwstr(hwid: cint; var temp: shortstring): pointer; -var mib: array[0..1] of cint; - len: cint; -begin - mib[0] := CTL_HW; - mib[1] := hwid; - FillChar(temp,SizeOf(temp),0); // use shortstring as temp 0-terminated buffer - len := SizeOf(temp); - fpsysctl(pointer(@mib),2,@temp,@len,nil,0); - if temp[0]<>#0 then - result := @temp else - result := nil; -end; -{$endif BSD} - -function GetNowUTC: TDateTime; -begin - result := GetUnixMSUTC / MSecsPerDay + UnixDelta; -end; - -function QueryPerformanceFrequency(out Value: Int64): boolean; -begin - Value := C_BILLION; // 1 second = 1e9 nanoseconds - result := true; -end; - -function SetFilePointer(hFile: cInt; lDistanceToMove: TOff; - lpDistanceToMoveHigh: Pointer; dwMoveMethod: cint): TOff; -var offs: Int64; -begin - Int64Rec(offs).Lo := lDistanceToMove; - if lpDistanceToMoveHigh=nil then - Int64Rec(offs).Hi := 0 else - Int64Rec(offs).Hi := PDWord(lpDistanceToMoveHigh)^; - offs := FpLseek(hFile,offs,dwMoveMethod); - result := Int64Rec(offs).Lo; - if lpDistanceToMoveHigh<>nil then - PDWord(lpDistanceToMoveHigh)^ := Int64Rec(offs).Hi; -end; - -procedure SetEndOfFile(hFile: cInt); -begin - FpFtruncate(hFile,FPLseek(hFile,0,SEEK_CUR)); -end; - -procedure FlushFileBuffers(hFile: cInt); -begin - FpFsync(hFile); -end; - -function GetLastError: longint; -begin - result := fpgeterrno; -end; - -procedure SetLastError(error: longint); -begin - fpseterrno(error); -end; - -function CompareStringRTL(a, b: PWideChar; al, bl, flags: integer): integer; -var - U1, U2: UnicodeString; -begin - SetString(U1,a,al); - SetString(U2,b,bl); - result := widestringmanager.CompareUnicodeStringProc(U1,U2,TCompareOptions(flags)); -end; - -function CompareStringW(GetThreadLocale: DWORD; dwCmpFlags: DWORD; lpString1: PWideChar; - cchCount1: integer; lpString2: PWideChar; cchCount2: integer): integer; -const - U_COMPARE_CODE_POINT_ORDER = $8000; -var - err: SizeInt; -begin - if cchCount1 < 0 then - cchCount1 := StrLen(lpString1); - if cchCount2 < 0 then - cchCount2 := StrLen(lpString2); - with ExternalLibraries do - begin - if not (elICU in Loaded) then - EnsureLoaded(elICU); - if Assigned(ucnv_open) then - begin - err := 0; - if dwCmpFlags and NORM_IGNORECASE <> 0 then - result := u_strCaseCompare(lpString1, cchCount1, lpString2, cchCount2, - U_COMPARE_CODE_POINT_ORDER, err) - else - result := u_strCompare(lpString1, cchCount1, lpString2, cchCount2, true); - end - else - result := CompareStringRTL(lpString1, lpString2, cchCount1, cchCount2, dwCmpFlags); - end; - inc(result, 2); // caller would make -2 to get regular -1/0/1 comparison values -end; - -function CharUpperBuffW(W: PWideChar; WLen: integer): integer; -var - err: SizeInt; -begin - with ExternalLibraries do - begin - if not (elICU in Loaded) then - EnsureLoaded(elICU); - if Assigned(ucnv_open) then - begin - err := 0; - result := u_strToUpper(W, WLen, W, WLen, nil, err); - end - else - result := WLen; - end; -end; - -function CharLowerBuffW(W: PWideChar; WLen: integer): integer; -var - err: SizeInt; -begin - with ExternalLibraries do - begin - if not (elICU in Loaded) then - EnsureLoaded(elICU); - if Assigned(ucnv_open) then - begin - err := 0; - result := u_strToLower(W, WLen, W, WLen, nil, err); - end - else - result := WLen; - end; -end; - -function AnsiToWideRTL(codepage: cardinal; Source: PAnsiChar; Dest: PWideChar; - SourceChars: PtrInt): PtrInt; -var - tmp: UnicodeString; -begin - widestringmanager.Ansi2UnicodeMoveProc(Source, codepage, tmp, SourceChars); - result := length(tmp); - Move(pointer(tmp)^, Dest^, result * 2); -end; - -function AnsiToWideICU(codepage: cardinal; Source: PAnsiChar; Dest: PWideChar; - SourceChars: PtrInt): PtrInt; -var - cnv: pointer; - err: SizeInt; -begin - if codepage = CP_UTF8 then - exit(Utf8ToUnicode(Dest, Source, SourceChars)); - cnv := ExternalLibraries.ucnv(codepage); - if cnv = nil then - exit(AnsiToWideRTL(codepage, Source, Dest, SourceChars)); - err := 0; - result := ExternalLibraries.ucnv_toUChars( - cnv, Dest, SourceChars, Source, SourceChars, err); - if result < 0 then - result := 0; - ExternalLibraries.ucnv_close(cnv); -end; - -function WideToAnsiRTL(codepage: cardinal; Source: PWideChar; Dest: PAnsiChar; - SourceChars: PtrInt): PtrInt; -var - tmp: RawByteString; -begin - widestringmanager.Unicode2AnsiMoveProc(Source, tmp, codepage, SourceChars); - result := length(tmp); - Move(pointer(tmp)^, Dest^, result); -end; - -function WideToAnsiICU(codepage: cardinal; Source: PWideChar; Dest: PAnsiChar; - SourceChars: PtrInt): PtrInt; -var - cnv: pointer; - err: SizeInt; -begin - if codepage = CP_UTF8 then - // fallback to RTL - exit(UnicodeToUTF8(Dest, Source, SourceChars)); - cnv := ExternalLibraries.ucnv(codepage); - if cnv = nil then - exit(WideToAnsiRTL(codepage, Source, Dest, SourceChars)); - err := 0; - result := ExternalLibraries.ucnv_fromUChars( - cnv, Dest, SourceChars * 3, Source, SourceChars, err); - if result < 0 then - result := 0; - ExternalLibraries.ucnv_close(cnv); -end; - - -function GetFileSize(hFile: cInt; lpFileSizeHigh: PDWORD): DWORD; -var FileInfo: TStat; -begin - if fpFstat(hFile,FileInfo)<>0 then - FileInfo.st_Size := 0; // returns 0 on error - result := Int64Rec(FileInfo.st_Size).Lo; - if lpFileSizeHigh<>nil then - lpFileSizeHigh^ := Int64Rec(FileInfo.st_Size).Hi; -end; - -procedure SleepHiRes(ms: cardinal); -var timeout: TTimespec; -begin - if ms=0 then // handle SleepHiRes(0) special case - if SleepHiRes0Yield then begin // reported as buggy by Alan on POSIX - ThreadSwitch; // call e.g. pthread's sched_yield API - exit; - end else begin - timeout.tv_sec := 0; - timeout.tv_nsec := 10000; // 10us is around timer resolution on modern HW - end else begin - timeout.tv_sec := ms div 1000; - timeout.tv_nsec := 1000000*(ms mod 1000); - end; - fpnanosleep(@timeout,nil) - // no retry loop on ESysEINTR (as with regular RTL's Sleep) -end; - -{$ifdef BSD} -function mprotect(Addr: Pointer; Len: size_t; Prot: Integer): Integer; - {$ifdef Darwin} cdecl external 'libc.dylib' name 'mprotect'; - {$else} cdecl external 'libc.so' name 'mprotect'; {$endif} -{$endif BSD} - -function SynMProtect(addr: pointer; size: size_t; prot: integer): longint; -begin - result := -1; - {$ifdef UNIX} - {$ifdef BSD} - result := mprotect(addr, size, prot); - {$else} - if Do_SysCall(syscall_nr_mprotect, PtrUInt(addr), size, prot) >= 0 then - result := 0; - {$endif BSD} - {$endif UNIX} -end; - -procedure GetKernelRevision; -var uts: UtsName; - P: PAnsiChar; - tp: timespec; - function GetNext: cardinal; - var c: cardinal; - begin - result := 0; - repeat - c := ord(P^)-48; - if c>9 then - break else - result := result*10+c; - inc(P); - until false; - if P^ in ['.','-',' '] then - inc(P); - end; -begin - if fpuname(uts)=0 then begin - P := @uts.release[0]; - KernelRevision := GetNext shl 16+GetNext shl 8+GetNext; - end else - uts.release[0] := #0; - {$ifdef DARWIN} - mach_timebase_info(mach_timeinfo); - mach_timecoeff := mach_timeinfo.Numer/mach_timeinfo.Denom; - mach_timenanosecond := (mach_timeinfo.Numer=1) and (mach_timeinfo.Denom=1); - {$else} - {$ifdef LINUX} - // try Linux kernel 2.6.32+ or FreeBSD 8.1+ fastest clocks - if (CLOCK_REALTIME_COARSE <> CLOCK_REALTIME_FAST) and - (clock_gettime(CLOCK_REALTIME_COARSE, @tp) = 0) then - CLOCK_REALTIME_FAST := CLOCK_REALTIME_COARSE; - if (CLOCK_MONOTONIC_COARSE <> CLOCK_MONOTONIC_FAST) and - (clock_gettime(CLOCK_MONOTONIC_COARSE, @tp) = 0) then - CLOCK_MONOTONIC_FAST := CLOCK_MONOTONIC_COARSE; - if (clock_gettime(CLOCK_REALTIME_FAST,@tp)<>0) or // paranoid check - (clock_gettime(CLOCK_MONOTONIC_FAST,@tp)<>0) then - raise Exception.CreateFmt('clock_gettime() not supported by %s kernel - errno=%d', - [PAnsiChar(@uts.release),GetLastError]); - {$endif LINUX} - {$endif DARWIN} -end; - - -{ TExternalLibrariesAPI } - -procedure TExternalLibrariesAPI.LoadIcuWithVersion; -const - NAMES: array[0..12] of string = ( - 'ucnv_open', 'ucnv_close', 'ucnv_setSubstChars', 'ucnv_setFallback', - 'ucnv_fromUChars', 'ucnv_toUChars', 'u_strToUpper', 'u_strToLower', - 'u_strCompare', 'u_strCaseCompare', 'u_getDataDirectory', - 'u_setDataDirectory', 'u_init'); -{$ifdef ANDROID} -// from https://developer.android.com/guide/topics/resources/internationalization - ICU_VER: array[1..13] of string = ( - '_3_8', '_4_2', '_44', '_46', '_48', '_50', '_51', '_53', '_55', '_56', '_58', '_60', '_63'); - SYSDATA: PAnsiChar = '/system/usr/icu'; -{$else} - SYSDATA: PAnsiChar = ''; -{$endif ANDROID} -var - i, j: integer; - err: SizeInt; - P: PPointer; - v, vers: string; - data: PAnsiChar; -begin - {$ifdef ANDROID} - for i := high(ICU_VER) downto 1 do - begin - if dlsym(icu, pointer(NAMES[0] + ICU_VER[i])) <> nil then - begin - vers := ICU_VER[i]; - break; - end; - end; - if vers <> '' then - {$endif ANDROID} - if dlsym(icu, 'ucnv_open') = nil then - for i := 80 downto 44 do - begin - str(i, v); - if dlsym(icu, pointer('ucnv_open_' + v)) <> nil then - begin - vers := '_' + v; - break; - end; - end; - P := @@ucnv_open; - for i := 0 to high(NAMES) do - begin - P[i] := dlsym(icu, pointer(NAMES[i] + vers)); - if P[i] = nil then - begin - @ucnv_open := nil; - exit; - end; - end; - data := u_getDataDirectory; - if (data = nil) or (data^ = #0) then - if SYSDATA <> '' then - u_setDataDirectory(SYSDATA); - err := 0; - u_init(err); -end; - -function TExternalLibrariesAPI.ucnv(codepage: cardinal): pointer; -var - s: shortstring; - err: SizeInt; - {$ifdef CPUINTEL} - mask: cardinal; - {$endif CPUINTEL} -begin - if not (elICU in Loaded) then - EnsureLoaded(elICU); - if not Assigned(ucnv_open) then - exit(nil); - str(codepage, s); - Move(s[1], s[3], ord(s[0])); - PWord(@s[1])^ := ord('c') + ord('p') shl 8; - inc(s[0], 3); - s[ord(s[0])] := #0; - {$ifdef CPUINTEL} - mask := GetMXCSR; - SetMXCSR(mask or $0080 {MM_MaskInvalidOp} or $1000 {MM_MaskPrecision}); - {$endif CPUINTEL} - err := 0; - result := ucnv_open(@s[1], err); - if result <> nil then - begin - err := 0; - ucnv_setSubstChars(result, '?', 1, err); - ucnv_setFallback(result, true); - end; - {$ifdef CPUINTEL} - SetMXCSR(mask); - {$endif CPUINTEL} -end; - -procedure TExternalLibrariesAPI.EnsureLoaded(lib: TExternalLibrary); -var - p: PPointer; - i, j: integer; -const - NAMES: array[0..5] of PAnsiChar = ( - 'sd_listen_fds', 'sd_is_socket_unix', 'sd_journal_print', 'sd_journal_sendv', - 'sd_notify', 'sd_watchdog_enabled'); -begin - if lib in Loaded then - exit; - EnterCriticalSection(Lock); - if not (lib in Loaded) then - case lib of - elPThread: - begin - {$ifdef LINUX} - pthread := dlopen({$ifdef ANDROID}'libc.so'{$else}'libpthread.so.0'{$endif}, RTLD_LAZY); - if pthread <> nil then - begin - {$ifdef LINUXNOTBSD} - @pthread_setname_np := dlsym(pthread, 'pthread_setname_np'); - {$endif LINUXNOTBSD} - end; - {$endif LINUX} - include(Loaded, elPThread); - end; - elICU: - begin - {$ifdef DARWIN} - icu := dlopen('libicuuc.dylib', RTLD_LAZY); - if icu <> nil then - icui18n := dlopen('libicui18n.dylib', RTLD_LAZY); - {$else} - // libicudata should be loaded first because other two depend on it - icudata := dlopen('libicudata.so', RTLD_LAZY); - if icudata <> nil then - begin - icu := dlopen('libicuuc.so', RTLD_LAZY); - if icu <> nil then - icui18n := dlopen('libicui18n.so', RTLD_LAZY); - end; - {$endif DARWIN} - if icui18n = nil then - begin - if icu <> nil then - dlclose(icu); - if icudata <> nil then - dlclose(icudata); - end - else - // ICU append a version prefix to all its functions e.g. ucnv_open_66 - LoadIcuWithVersion; - include(Loaded, elICU); - end; - {$ifdef LINUXNOTBSD} - elSystemD: - begin - systemd := dlopen(LIBSYSTEMD_PATH, RTLD_LAZY); - if systemd <> nil then - begin - p := @@sd_listen_fds; - for i := 0 to high(NAMES) do - begin - p^ := dlsym(systemd, NAMES[i]); - if p^ = nil then - begin - p := @@sd_listen_fds; - for j := 0 to i do - begin - p^ := nil; - inc(p); - end; - break; - end; - inc(p); - end; - end; - include(Loaded, elSystemD); - end; - {$endif LINUXNOTBSD} - end; - LeaveCriticalSection(Lock); -end; - -procedure TExternalLibrariesAPI.Done; -begin - EnterCriticalSection(Lock); - if elPThread in Loaded then - begin - {$ifdef LINUX} - {$ifdef LINUXNOTBSD} - @pthread_setname_np := nil; - {$endif LINUXNOTBSD} - if pthread <> nil then - dlclose(pthread); - {$endif LINUX} - end; - if elICU in Loaded then - begin - if icui18n <> nil then - dlclose(icui18n); - if icu <> nil then - dlclose(icu); - if icudata <> nil then - dlclose(icudata); - @ucnv_open := nil; - end; - {$ifdef LINUXNOTBSD} - if (elSystemD in Loaded) and (systemd <> nil) then - dlclose(systemd); - {$endif LINUXNOTBSD} - LeaveCriticalSection(Lock); - DeleteCriticalSection(Lock); -end; - -procedure SetUnixThreadName(ThreadID: TThreadID; const Name: RawByteString); -var trunc: array[0..15] of AnsiChar; // truncated to 16 bytes (including #0) - i,L: integer; -begin - {$ifdef LINUXNOTBSD} - if not(elPThread in ExternalLibraries.Loaded) then - ExternalLibraries.EnsureLoaded(elPThread); - if not Assigned(ExternalLibraries.pthread_setname_np) then - exit; - if Name = '' then - exit; - L := 0; // trim unrelevant spaces and prefixes when filling the 16 chars - i := 1; - if Name[1] = 'T' then - if PCardinal(Name)^ = ord('T') + ord('S') shl 8 + ord('Q') shl 16 + ord('L') shl 24 then - i := 5 - else - i := 2; - while i <= length(Name) do begin - if Name[i]>' ' then begin - trunc[L] := Name[i]; - inc(L); - if L = high(trunc) then - break; - end; - inc(i); - end; - if L = 0 then - exit; - trunc[L] := #0; - ExternalLibraries.pthread_setname_np(pointer(ThreadID), @trunc[0]); - {$endif LINUXNOTBSD} -end; - - -{$ifdef LINUXNOTBSD} - -function SystemdIsAvailable: boolean; -begin - if not(elSystemD in ExternalLibraries.Loaded) then - ExternalLibraries.EnsureLoaded(elSystemD); - result := Assigned(ExternalLibraries.sd_listen_fds); -end; - -function ProcessIsStartedBySystemd: boolean; -begin - result := SystemdIsAvailable and - // note: for example on Ubuntu 20.04 INVOCATION_ID is always defined - // from the other side PPID 1 can be set if we run under docker and started - // by init.d so let's verify both - (fpgetppid() = 1) and (fpGetenv(ENV_INVOCATION_ID) <> nil); -end; - -procedure LibSystemdInitialize; -begin - if not SystemdIsAvailable then - raise ESystemd.Create('Impossible to load ' + LIBSYSTEMD_PATH); -end; - -{$endif LINUXNOTBSD} - - -initialization - GetKernelRevision; - InitializeCriticalSection(ExternalLibraries.Lock); - -finalization - ExternalLibraries.Done; -{$endif LINUX} -end. diff --git a/lib/dmustache/SynFPCTypInfo.pas b/lib/dmustache/SynFPCTypInfo.pas deleted file mode 100644 index 42ab29ad..00000000 --- a/lib/dmustache/SynFPCTypInfo.pas +++ /dev/null @@ -1,200 +0,0 @@ -/// wrapper around FPC typinfo.pp unit for SynCommons.pas and mORMot.pas -// - this unit is a part of the freeware Synopse mORMot framework, -// licensed under a MPL/GPL/LGPL tri-license; version 1.18 -unit SynFPCTypInfo; - -{ - This file is part of Synopse mORMot framework. - - Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez - Synopse Informatique - https://synopse.info - - *** BEGIN LICENSE BLOCK ***** - Version: MPL 1.1/GPL 2.0/LGPL 2.1 - - The contents of this file are subject to the Mozilla Public License Version - 1.1 (the "License"); you may not use this file except in compliance with - the License. You may obtain a copy of the License at - http://www.mozilla.org/MPL - - Software distributed under the License is distributed on an "AS IS" basis, - WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License - for the specific language governing rights and limitations under the License. - - The Original Code is Synopse mORMot framework. - - The Initial Developer of the Original Code is Alfred Glaenzer. - - Portions created by the Initial Developer are Copyright (C) 2022 - the Initial Developer. All Rights Reserved. - - Contributor(s): - - Arnaud Bouchez - - - Alternatively, the contents of this file may be used under the terms of - either the GNU General Public License Version 2 or later (the "GPL"), or - the GNU Lesser General Public License Version 2.1 or later (the "LGPL"), - in which case the provisions of the GPL or the LGPL are applicable instead - of those above. if you wish to allow use of your version of this file only - under the terms of either the GPL or the LGPL, and not to allow others to - use your version of this file under the terms of the MPL, indicate your - decision by deleting the provisions above and replace them with the notice - and other provisions required by the GPL or the LGPL. if you do not delete - the provisions above, a recipient may use your version of this file under - the terms of any one of the MPL, the GPL or the LGPL. - - ***** END LICENSE BLOCK ***** - - Unit created to avoid polluting the SynCommons.pas/mORMot.pas namespace - with overloaded typinfo.pp types. - -} - -interface - -{$ifndef FPC} - 'this unit is for FPC only - do not include it in any Delphi project!' -{$endif FPC} - -{$I Synopse.inc} // define HASINLINE CPU32 CPU64 OWNNORMTOUPPER - -uses - SysUtils, - TypInfo; - -{$ifdef FPC_PROVIDE_ATTR_TABLE} -type - // if you have a compilation error here, your FPC trunk is too old - // - TTypeData.AttributeTable was introduced in SVN 42356-42411 (2019/07) - // -> undefine FPC_PROVIDE_ATTR_TABLE in Synopse.inc and recompile - PFPCAttributeTable = TypInfo.PAttributeTable; -{$endif FPC_PROVIDE_ATTR_TABLE} - -{$ifdef HASALIGNTYPEDATA} -function AlignTypeData(p: pointer): pointer; inline; -function AlignTypeDataClean(p: pointer): pointer; inline; -{$else} -type - AlignTypeData = pointer; - AlignTypeDataClean = pointer; -{$endif HASALIGNTYPEDATA} - - -{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} -function AlignToPtr(p: pointer): pointer; inline; -function AlignPTypeInfo(p: pointer): pointer; inline; -{$else FPC_REQUIRES_PROPER_ALIGNMENT} -type - AlignToPtr = pointer; - AlignPTypeInfo = pointer; -{$endif FPC_REQUIRES_PROPER_ALIGNMENT} - -type - /// some type definition to avoid inclusion of TypInfo in SynCommons/mORMot.pas - PFPCInterfaceData = TypInfo.PInterfaceData; - PFPCVmtMethodParam = TypInfo.PVmtMethodParam; - PFPCIntfMethodTable = TypInfo.PIntfMethodTable; - PFPCIntfMethodEntry = TypInfo.PIntfMethodEntry; -{$ifdef FPC_NEWRTTI} - PFPCRecInitData = TypInfo.PRecInitData; - -{$endif FPC_NEWRTTI} - -procedure FPCDynArrayClear(var a: Pointer; TypeInfo: Pointer); -procedure FPCFinalizeArray(p: Pointer; TypeInfo: Pointer; elemCount: PtrUInt); -procedure FPCFinalize(Data: Pointer; TypeInfo: Pointer); -procedure FPCRecordCopy(const Source; var Dest; TypeInfo: pointer); -procedure FPCRecordAddRef(var Data; TypeInfo : pointer); - - -implementation - -procedure FPCDynArrayClear(var a: Pointer; TypeInfo: Pointer); - external name 'FPC_DYNARRAY_CLEAR'; -procedure FPCFinalizeArray(p: Pointer; TypeInfo: Pointer; elemCount: PtrUInt); - external name 'FPC_FINALIZE_ARRAY'; -procedure FPCFinalize(Data: Pointer; TypeInfo: Pointer); - external name 'FPC_FINALIZE'; -procedure FPCRecordCopy(const Source; var Dest; TypeInfo: pointer); - external name 'FPC_COPY'; -procedure FPCRecordAddRef(var Data; TypeInfo : pointer); - external name 'FPC_ADDREF'; - -{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} // copied from latest typinfo.pp -function AlignToPtr(p: pointer): pointer; -begin - result := align(p,sizeof(p)); -end; - -function AlignTypeData(p: pointer): pointer; -{$packrecords c} - type - TAlignCheck = record // match RTTI TTypeInfo definition - b : byte; // = TTypeKind - q : qword; // = this is where the PTypeData begins - end; -{$packrecords default} -begin -{$ifdef VER3_0} - result := Pointer(align(p,SizeOf(Pointer))); -{$else VER3_0} - result := Pointer(align(p,PtrInt(@TAlignCheck(nil^).q))); -{$endif VER3_0} - {$ifdef FPC_PROVIDE_ATTR_TABLE} - inc(PByte(result),SizeOf(PFPCAttributeTable)); // ignore attributes table - result := Pointer(align(result,PtrInt(@TAlignCheck(nil^).q))); - {$endif FPC_PROVIDE_ATTR_TABLE} -end; -{$else} -{$ifdef FPC_PROVIDE_ATTR_TABLE} -function AlignTypeData(p: pointer): pointer; -begin - result := p; - inc(PByte(result),SizeOf(PFPCAttributeTable)); // ignore attributes table -end; -{$endif FPC_PROVIDE_ATTR_TABLE} -{$endif FPC_REQUIRES_PROPER_ALIGNMENT} - -{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} // copied from latest typinfo.pp - -function AlignTypeDataClean(p: pointer): pointer; -{$packrecords c} - type - TAlignCheck = record // match RTTI TTypeInfo definition - b : byte; // = TTypeKind - q : qword; // = this is where the PTypeData begins - end; -{$packrecords default} -begin - {$ifdef VER3_0} - result := Pointer(align(p,SizeOf(Pointer))); - {$else VER3_0} - result := Pointer(align(p,PtrInt(@TAlignCheck(nil^).q))); - {$endif VER3_0} -end; - -function AlignPTypeInfo(p: pointer): pointer; inline; -{$packrecords c} - type - TAlignCheck = record - b : byte; - p : pointer; - end; -{$packrecords default} -begin - Result := Pointer(align(p,PtrInt(@TAlignCheck(nil^).p))) - -end; - -{$else} -{$ifdef HASALIGNTYPEDATA} -function AlignTypeDataClean(p: pointer): pointer; -begin - result := p; -end; -{$endif HASALIGNTYPEDATA} - -{$endif FPC_REQUIRES_PROPER_ALIGNMENT} - -end. diff --git a/lib/dmustache/SynLZ.pas b/lib/dmustache/SynLZ.pas deleted file mode 100644 index 1c66a661..00000000 --- a/lib/dmustache/SynLZ.pas +++ /dev/null @@ -1,1474 +0,0 @@ -/// SynLZ Compression routines -// - licensed under a MPL/GPL/LGPL tri-license; version 1.18 -unit SynLZ; - -{ - This file is part of Synopse SynLZ Compression. - - Synopse SynLZ Compression. Copyright (C) 2022 Arnaud Bouchez - Synopse Informatique - https://synopse.info - - *** BEGIN LICENSE BLOCK ***** - Version: MPL 1.1/GPL 2.0/LGPL 2.1 - - The contents of this file are subject to the Mozilla Public License Version - 1.1 (the "License"); you may not use this file except in compliance with - the License. You may obtain a copy of the License at - http://www.mozilla.org/MPL - - Software distributed under the License is distributed on an "AS IS" basis, - WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License - for the specific language governing rights and limitations under the License. - - The Original Code is Synopse SynLZ Compression. - - The Initial Developer of the Original Code is Arnaud Bouchez. - - Portions created by the Initial Developer are Copyright (C) 2022 - the Initial Developer. All Rights Reserved. - - Contributor(s): - - Alternatively, the contents of this file may be used under the terms of - either the GNU General Public License Version 2 or later (the "GPL"), or - the GNU Lesser General Public License Version 2.1 or later (the "LGPL"), - in which case the provisions of the GPL or the LGPL are applicable instead - of those above. If you wish to allow use of your version of this file only - under the terms of either the GPL or the LGPL, and not to allow others to - use your version of this file under the terms of the MPL, indicate your - decision by deleting the provisions above and replace them with the notice - and other provisions required by the GPL or the LGPL. If you do not delete - the provisions above, a recipient may use your version of this file under - the terms of any one of the MPL, the GPL or the LGPL. - - ***** END LICENSE BLOCK ***** - - - SynLZ Compression / Decompression library - ========================================= - - * SynLZ is a very FAST lossless data compression library - written in optimized pascal code for FPC and Delphi 3 and up - with a tuned asm version available - * symetrical compression and decompression speed (which is - very rare above all other compression algorithms in the wild) - * good compression rate (usualy better than LZO) - * fastest averrage compression speed (ideal for xml/text communication, e.g.) - - SynLZ implements a new LZ compression algorithm with the following features: - * hashing+dictionary compression in one pass, with no huffman table - * optimized 32bits control word, embedded in the data stream - * in-memory compression (the dictionary is the input stream itself) - * compression and decompression have the same speed (both use hashing) - * thread safe and lossless algorithm - * supports overlapping compression and in-place decompression - * code size for compression/decompression functions is smaller than LZO's - - Implementation notes: - - this format is NOT stream compatible with any lz* official format - => meant for proprietary server-side content real-time compression - => use it internally in your application, not as exchange format - => consider our SynLizard.pas unit for Lizard (LZ5) compression standard - - very small code size (less than 1KB for both compressor/decompressor) - - the uncompressed data length is stored in the beginning of the stream - and can be retrieved easily for proper out_p memory allocation - - please give correct data to the decompressor (i.e. first CRC in_p data) - => we recommend crc32c() from SynCommons, or a zip-like container - - a 2nd more tuned algorithm is included, but is somewhat slower in practice - => use SynLZ[de]compres1*() functions in your applications - - tested and benchmarked with a lot of data types/sizes - => use the asm code, which is very tuned: SynLZ[de]compress1asm() - - a hashing limitation makes SynLZ sometimes unable to pack continuous - blocks of same byte -> SynLZ is perfect for xml/text (e.g. log files), - but SynZip or SynLizard may be prefered for database files - - if you include it in your application, please give me some credits: - "use SynLZ compression by https://synopse.info" - - use at your own risk! - - Benchmark update - introducing LZ4 at http://code.google.com/p/lz4 - 190 MB file containing pascal sources, on a Core 2 duo PC, using x86 asm: - LZ4 compression = 1.25 sec, comp. size = 71 MB, decompression = 0.44 sec - SynLZ compression = 1.09 sec, comp. size = 63 MB, decompression = 0.51 sec - zip (1) compression = 6.44 sec, comp. size = 52 MB, decompression = 1.49 sec - zip (6) compression = 20.1 sec, comp. size = 42 MB, decompression = 1.35 sec - Note: zip decompression here uses fast asm optimized version of SynZip.pas - Decompression is slower in SynLZ, due to the algorithm used: it does recreate - the hash table even at decompression, while it is not needed by LZ4. - Having the hash table at hand allows more patterns to be available, so - compression ratio is better, at the expand of a slower speed. - - Conclusion: - SynLZ compresses better than LZ4, SynLZ is faster to compress than LZ4, - but slower to decompress than LZ4. So SynLZ is still very competitive for - our Client-Server mORMot purpose, since it is a simple pascal unit with - no external .obj/.o/.dll dependency. ;) - - Updated benchmarks on a Core i7, with the 2017/08 x86 and x64 optimized asm: - Win32 Processing devpcm.log = 98.7 MB - Snappy compress in 125.07ms, ratio=84%, 789.3 MB/s - Snappy uncompress in 70.35ms, 1.3 GB/s - SynLZ compress in 103.61ms, ratio=93%, 952.8 MB/s - SynLZ uncompress in 68.71ms, 1.4 GB/s - Win64 Processing devpcm.log = 98.7 MB - Snappy compress in 107.13ms, ratio=84%, 921.5 MB/s - Snappy uncompress in 61.06ms, 1.5 GB/s - SynLZ compress in 97.25ms, ratio=93%, 1015.1 MB/s - SynLZ uncompress in 61.27ms, 1.5 GB/s - -} - -interface - -{$I Synopse.inc} - -/// get maximum possible (worse) compressed size for out_p -function SynLZcompressdestlen(in_len: integer): integer; - -/// get uncompressed size from lz-compressed buffer (to reserve memory, e.g.) -function SynLZdecompressdestlen(in_p: PAnsiChar): integer; - -/// 1st compression algorithm uses hashing with a 32bits control word -function SynLZcompress1pas(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; - -/// 1st compression algorithm uses hashing with a 32bits control word -// - this is the fastest pure pascal implementation -function SynLZdecompress1pas(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; - -/// 1st compression algorithm uses hashing with a 32bits control word -// - this overload function is slower, but will allow to uncompress only the start -// of the content (e.g. to read some metadata header) -// - it will also check for dst buffer overflow, so will be more secure than -// other functions, which expect the content to be verified (e.g. via CRC) -function SynLZdecompress1partial(src: PAnsiChar; size: integer; dst: PAnsiChar; - maxDst: integer): integer; - -{$ifdef CPUINTEL} -/// optimized x86/x64 asm version of the 1st compression algorithm -function SynLZcompress1(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; -/// optimized x86/x64 asm version of the 1st compression algorithm -function SynLZdecompress1(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; -{$else} -var - /// fast redirection to pure pascal SynLZ compression (using 1st algorithm) - SynLZCompress1: function( - src: PAnsiChar; size: integer; dst: PAnsiChar): integer = SynLZcompress1pas; - - /// fast redirection to pure pascal SynLZ decompression (using 1st algorithm) - SynLZDecompress1: function( - src: PAnsiChar; size: integer; dst: PAnsiChar): integer = SynLZDecompress1pas; -{$endif CPUINTEL} - -/// 2nd compression algorithm optimizing pattern copy -// - this algorithm is a bit smaller, but slower, so the 1st method is preferred -function SynLZcompress2(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; -/// 2nd compression algorithm optimizing pattern copy -// - this algorithm is a bit smaller, but slower, so the 1st method is preferred -function SynLZdecompress2(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; - - -implementation - -function SynLZcompressdestlen(in_len: integer): integer; -begin // get maximum possible (worse) compressed size for out_p - result := in_len+in_len shr 3+16; -end; - -type // some cross-platform and cross-compiler definitions - {$ifndef FPC} - PtrInt = {$ifdef CPU64}NativeInt{$else}integer{$endif}; - PtrUInt = {$ifdef CPU64}NativeUInt{$else}cardinal{$endif}; - {$endif} - {$ifdef DELPHI5OROLDER} // Delphi 5 doesn't have those base types defined :( - PByte = ^Byte; - PWord = ^Word; - PInteger = ^integer; - PCardinal = ^Cardinal; - IntegerArray = array[0..$effffff] of integer; - PIntegerArray = ^IntegerArray; - {$endif} - TOffsets = array[0..4095] of PAnsiChar; // 16KB/32KB hashing code - -function SynLZdecompressdestlen(in_p: PAnsiChar): integer; -begin // get uncompressed size from lz-compressed buffer (to reserve memory, e.g.) - result := PWord(in_p)^; - if result and $8000<>0 then - result := (result and $7fff) or (integer(PWord(in_p+2)^) shl 15); -end; - -{$ifdef CPUINTEL} -// using direct x86 jmp also circumvents Internal Error C11715 for Delphi 5 -{$ifdef CPUX86} -function SynLZcompress1(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; - {$ifdef FPC} nostackframe; assembler; {$endif} -asm - push ebp - push ebx - push esi - push edi - push eax - add esp, -4092 - push eax - add esp, -4092 - push eax - add esp, -4092 - push eax - add esp, -4092 - push eax - add esp, -4092 - push eax - add esp, -4092 - push eax - add esp, -4092 - push eax - add esp, -4092 - push eax - add esp, -32 - mov esi, eax // esi=src - mov edi, ecx // edi=dst - mov [esp+08H], ecx - mov eax, edx - cmp eax, 32768 - jl @@0889 - or ax, 8000H - mov [edi], eax - mov eax, edx - shr eax, 15 - mov [edi+2], eax - add edi, 4 - jmp @@0891 -@@0890: mov eax, 2 - jmp @@0904 -@@0889: mov [edi], eax - test eax, eax - jz @@0890 - add edi, 2 -@@0891: lea eax, [edx+esi] - mov [esp+18H], edi - mov [esp+0CH], eax - sub eax, 11 - mov [esp+4], eax - lea ebx, [esp+24H] - xor eax, eax - mov ecx, 1024 -@@089I: mov [ebx], eax // faster than FillChar / stosb - mov [ebx+4], eax - mov [ebx+8], eax - mov [ebx+12], eax - add ebx, 16 - dec ecx - jnz @@089I - mov [edi], eax - add edi, 4 - mov ebx, 1 // ebx=1 shl CWbit - // main loop: - cmp esi, [esp+4] - ja @@0900 -@@0892: mov edx, [esi] - mov eax, edx - shr edx, 12 - xor edx, eax - and edx, 0FFFH - mov ebp, [esp+edx*4+24H] - mov ecx, [esp+edx*4+4024H] - mov [esp+edx*4+24H], esi - xor ecx, eax - test ecx, 0FFFFFFH - mov [esp+edx*4+4024H], eax - jnz @@0897 - mov eax, esi - or ebp, ebp - jz @@0897 - sub eax, ebp - mov ecx, [esp+18H] - cmp eax, 2 - jle @@0897 - lea esi, [esi+2] - or dword ptr[ecx], ebx - mov ecx, [esp+0CH] - add ebp, 2 - mov eax, 1 - sub ecx, esi - dec ecx - mov [esp], ecx - cmp ecx, 271 - jl @@0894 - mov dword ptr [esp], 271 - jmp @@0894 -@@0893: inc eax -@@0894: mov ecx, [ebp+eax] - cmp cl, [esi+eax] - jnz @@0895 - cmp eax, [esp] - jge @@0895 - inc eax - cmp ch, [esi+eax] - jnz @@0895 - shr ecx, 16 - cmp eax, [esp] - jge @@0895 - inc eax - cmp cl, [esi+eax] - jnz @@0895 - cmp eax, [esp] - jge @@0895 - inc eax - cmp ch, [esi+eax] - jnz @@0895 - cmp eax, [esp] - jl @@0893 -@@0895: add esi, eax - shl edx, 4 - cmp eax, 15 - jg @@0896 - or eax, edx - mov word ptr [edi], ax - add edi, 2 - jmp @@0898 -@@0896: sub eax, 16 - mov [edi], dx - mov [edi+2H], al - add edi, 3 - jmp @@0898 -@@0897: mov al, [esi] // movsb is actually slower! - mov [edi], al - inc esi - inc edi -@@0898: add ebx, ebx - jz @@0899 - cmp esi, [esp+4] - jbe @@0892 - jmp @@0900 -@@0899: mov [esp+18H], edi - mov [edi], ebx - inc ebx - add edi, 4 - cmp esi, [esp+4] - jbe @@0892 -@@0900: cmp esi, [esp+0CH] - jnc @@0903 -@@0901: mov al, [esi] - mov [edi], al - inc esi - inc edi - add ebx, ebx - jz @@0902 - cmp esi, [esp+0CH] - jc @@0901 - jmp @@0903 -@@0902: mov [edi], ebx - inc ebx - add edi, 4 - cmp esi, [esp+0CH] - jc @@0901 -@@0903: mov eax, edi - sub eax, [esp+08H] -@@0904: add esp, 32804 - pop edi - pop esi - pop ebx - pop ebp -{$else CPUX86} -function SynLZcompress1(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; -var off: TOffsets; - cache: array[0..4095] of cardinal; // uses 32KB+16KB=48KB on stack -asm // rcx=src, edx=size, r8=dest - {$ifdef win64} // additional registers to preserve - push rdi - push rsi - {$else} // Linux 64-bit ABI - mov r8, rdx - mov rdx, rsi - mov rcx, rdi - {$endif win64} - push rbx - push r12 - push r13 - push r14 - push r15 - mov r15, r8 // r8=dest r15=dst_beg - mov rbx, rcx // rbx=src - cmp edx, 32768 - jc @03 - mov eax, edx - and eax, 7FFFH - or eax, 8000H - mov word ptr [r8], ax - mov eax, edx - shr eax, 15 - mov word ptr [r8+2H], ax - add r8, 4 - jmp @05 -@03: mov word ptr [r8], dx - test edx, edx - jnz @04 - mov r15d, 2 - jmp @19 - nop -@04: add r8, 2 -@05: lea r9, [rdx+rbx] // r9=src_end - lea r10, [r9-0BH] // r10=src_endmatch - mov ecx, 1 // ecx=CWBits - mov r11, r8 // r11=CWpoint - mov dword ptr [r8], 0 - add r8, 4 - pxor xmm0, xmm0 - mov eax, 32768-64 -@06: movaps dqword ptr [off+rax-48], xmm0 // stack is aligned to 16 bytes - movaps dqword ptr [off+rax-32], xmm0 - movaps dqword ptr [off+rax-16], xmm0 - movaps dqword ptr [off+rax], xmm0 - sub eax, 64 - jae @06 - cmp rbx, r10 - ja @15 -@07: mov edx, dword ptr [rbx] - mov rax, rdx - mov r12, rdx - shr rax, 12 - xor rax, rdx - and rax, 0FFFH // rax=h - mov r14, qword ptr [off+rax*8] // r14=o - mov edx, dword ptr [cache+rax*4] - mov qword ptr [off+rax*8], rbx - mov dword ptr [cache+rax*4], r12d - xor rdx, r12 - test r14, r14 - lea rdi, [r9-1] - je @12 - and rdx, 0FFFFFFH - jne @12 - mov rdx, rbx - sub rdx, r14 - cmp rdx, 2 - jbe @12 - or dword ptr[r11], ecx - add rbx, 2 - add r14, 2 - mov esi, 1 - sub rdi, rbx - cmp rdi, 271 - jc @09 - mov edi, 271 - jmp @09 -@08: inc rsi -@09: mov edx, dword ptr [r14+rsi] - cmp dl, byte ptr [rbx+rsi] - jnz @10 - cmp rsi, rdi - jge @10 - inc rsi - cmp dh, byte ptr [rbx+rsi] - jnz @10 - shr edx, 16 - cmp rsi, rdi - jge @10 - inc rsi - cmp dl, byte ptr [rbx+rsi] - jnz @10 - cmp rsi, rdi - jge @10 - inc rsi - cmp dh, byte ptr [rbx+rsi] - jnz @10 - cmp rsi, rdi - jc @08 -@10: add rbx, rsi - shl rax, 4 - cmp rsi, 15 - ja @11 - or rax, rsi - mov word ptr [r8], ax - add r8, 2 - jmp @13 -@11: sub rsi, 16 - mov word ptr [r8], ax - mov byte ptr [r8+2H], sil - add r8, 3 - jmp @13 -@12: mov al, byte ptr [rbx] - mov byte ptr [r8], al - add rbx, 1 - add r8, 1 -@13: add ecx, ecx - jnz @14 - mov r11, r8 - mov [r8], ecx - add r8, 4 - add ecx, 1 -@14: cmp rbx, r10 - jbe @07 -@15: cmp rbx, r9 - jnc @18 -@16: mov al, byte ptr [rbx] - mov byte ptr [r8], al - add rbx, 1 - add r8, 1 - add ecx, ecx - jnz @17 - mov [r8], ecx - add r8, 4 - add ecx, 1 -@17: cmp rbx, r9 - jc @16 -@18: sub r8, r15 - mov r15, r8 -@19: mov rax, r15 - pop r15 - pop r14 - pop r13 - pop r12 - pop rbx - {$ifdef win64} // additional registers to preserve - pop rsi - pop rdi - {$endif win64} -{$endif CPUX86} -end; -{$endif CPUINTEL} - -function SynLZcompress1pas(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; -var dst_beg, // initial dst value - src_end, // real last byte available in src - src_endmatch, // last byte to try for hashing - o: PAnsiChar; - CWbit: byte; - CWpoint: PCardinal; - v, h, cached, t, tmax: PtrUInt; - offset: TOffsets; - cache: array[0..4095] of cardinal; // 16KB+16KB=32KB on stack (48KB under Win64) -begin - dst_beg := dst; - // 1. store in_len - if size>=$8000 then begin // size in 32KB..2GB -> stored as integer - PWord(dst)^ := $8000 or (size and $7fff); - PWord(dst+2)^ := size shr 15; - inc(dst,4); - end else begin - PWord(dst)^ := size ; // size<32768 -> stored as word - if size=0 then begin - result := 2; - exit; - end; - inc(dst,2); - end; - // 2. compress - src_end := src+size; - src_endmatch := src_end-(6+5); - CWbit := 0; - CWpoint := pointer(dst); - PCardinal(dst)^ := 0; - inc(dst,sizeof(CWpoint^)); - fillchar(offset,sizeof(offset),0); // fast 16KB reset to 0 - // 1. main loop to search using hash[] - if src<=src_endmatch then - repeat - v := PCardinal(src)^; - h := ((v shr 12) xor v) and 4095; - o := offset[h]; - offset[h] := src; - cached := v xor cache[h]; // o=nil if cache[h] is uninitialized - cache[h] := v; - if (cached and $00ffffff=0) and (o<>nil) and (src-o>2) then begin - CWpoint^ := CWpoint^ or (cardinal(1) shl CWbit); - inc(src,2); - inc(o,2); - t := 1; - tmax := src_end-src-1; - if tmax>=(255+16) then - tmax := (255+16); - while (o[t]=src[t]) and (t0 - if t<=15 then begin // mark 2 to 17 bytes -> size=1..15 - PWord(dst)^ := integer(t or h); - inc(dst,2); - end else begin // mark 18 to (255+16) bytes -> size=0, next byte=t - dec(t,16); - PWord(dst)^ := h; // size=0 - dst[2] := ansichar(t); - inc(dst,3); - end; - end else begin - dst^ := src^; - inc(src); - inc(dst); - end; - if CWbit<31 then begin - inc(CWbit); - if src<=src_endmatch then continue else break; - end else begin - CWpoint := pointer(dst); - PCardinal(dst)^ := 0; - inc(dst,sizeof(CWpoint^)); - CWbit := 0; - if src<=src_endmatch then continue else break; - end; - until false; - // 2. store remaining bytes - if src0 then begin - result := (result and $7fff) or (integer(PWord(src)^) shl 15); - inc(src,2); - end; - // 2. decompress - last_hashed := dst-1; - CWbit := 32; -nextCW: - CW := PCardinal(src)^; - inc(src,4); - CWbit := CWbit-32; - if src=src_end then break; - while last_hashed=src_end then break; - if last_hashed=dst; - inc(dst,t); - if src>=src_end then break; - last_hashed := dst-1; - inc(CWbit); - CW := CW shr 1; - if CWbit<32 then - continue else - goto nextCW; - end; - until false; -// assert(result=dst-dst_beg); -end; - -{$ifdef CPUINTEL} -{$ifdef CPUX86} -// using direct x86 jmp also circumvents Internal Error C11715 for Delphi 5 -function SynLZdecompress1(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; - {$ifdef FPC} nostackframe; assembler; {$endif} -asm - push ebp - push ebx - push esi - push edi - push eax - add esp, -4092 - push eax - add esp, -4092 - push eax - add esp, -4092 - push eax - add esp, -4092 - push eax - add esp, -24 - mov esi, ecx - mov ebx, eax - add edx, eax - mov [esp+8H], esi - mov [esp+10H], edx - movzx eax, word ptr [ebx] - mov [esp], eax - or eax,eax - je @@0917 - add ebx, 2 - mov eax, [esp] - test ah, 80H - jz @@0907 - and eax, 7FFFH - movzx edx, word ptr [ebx] - shl edx, 15 - or eax, edx - mov [esp], eax - add ebx, 2 -@@0907: lea ebp, [esi-1] -@@0908: mov ecx, [ebx] - add ebx, 4 - mov [esp+14H], ecx - mov edi, 1 // edi=CWbit - cmp ebx, [esp+10H] - jnc @@0917 -@@0909: mov ecx, [esp+14H] -@@090A: test ecx, edi - jnz @@0911 - mov al, [ebx] - inc ebx - mov [esi], al - inc esi - cmp ebx, [esp+10H] - lea eax, [esi-3] - jnc @@0917 - cmp eax, ebp - jbe @@0910 - inc ebp - mov eax, [ebp] - mov edx, eax - shr eax, 12 - xor eax, edx - and eax, 0FFFH - mov [esp+eax*4+1CH], ebp -@@0910: add edi, edi - jnz @@090A - jmp @@0908 -@@0911: movzx edx, word ptr [ebx] - add ebx, 2 - mov eax, edx - and edx, 0FH - add edx, 2 - shr eax, 4 - cmp edx,2 - jnz @@0912 - movzx edx, byte ptr [ebx] - inc ebx - add edx, 18 -@@0912: mov eax, [esp+eax*4+1CH] - mov ecx, esi - mov [esp+18H], edx - sub ecx, eax - cmp ecx, edx - jl @@0913 - cmp edx, 32 // inlined optimized move() - ja @large - sub edx, 8 - jg @9_32 - mov ecx, [eax] - mov eax, [eax+4] // always copy 8 bytes for 0..8 - mov [esi], ecx // safe since src_endmatch := src_end-(6+5) - mov [esi+4], eax - jmp @movend -@9_32: fild qword ptr[eax+edx] - fild qword ptr[eax] - cmp edx, 8 - jle @16 - fild qword ptr[eax+8] - cmp edx, 16 - jle @24 - fild qword ptr[eax+16] - fistp qword ptr[esi+16] -@24: fistp qword ptr[esi+8] -@16: fistp qword ptr[esi] - fistp qword ptr[esi+edx] - jmp @movend - nop -@large: push esi - fild qword ptr[eax] - lea eax, [eax+edx-8] - lea edx, [esi+edx-8] - fild qword ptr[eax] - push edx - neg edx - and esi, -8 - lea edx, [edx+esi+8] - pop esi -@lrgnxt:fild qword ptr[eax+edx] - fistp qword ptr[esi+edx] - add edx, 8 - jl @lrgnxt - fistp qword ptr[esi] - pop esi - fistp qword ptr[esi] -@movend:cmp esi, ebp - jbe @@0916 -@@0915: inc ebp - mov edx, [ebp] - mov eax, edx - shr edx, 12 - xor eax, edx - and eax, 0FFFH - mov [esp+eax*4+1CH], ebp - cmp esi, ebp - ja @@0915 -@@0916: add esi, [esp+18H] - cmp ebx, [esp+10H] - jnc @@0917 - add edi, edi - lea ebp, [esi-1] - jz @@0908 - jmp @@0909 -@@0913: push ebx - xor ecx, ecx -@s: dec edx - mov bl, [eax+ecx] - mov [esi+ecx], bl - lea ecx,[ecx+1] - jnz @s - pop ebx - jmp @movend -@@0917: mov eax, [esp] - add esp, 16412 - pop edi - pop esi - pop ebx - pop ebp -{$else CPUX86} -function SynLZdecompress1(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; -var off: TOffsets; -asm // rcx=src, edx=size, r8=dest - {$ifdef win64} // additional registers to preserve - push rsi - push rdi - {$else} // Linux 64-bit ABI - mov r8, rdx - mov rdx, rsi - mov rcx, rdi - {$endif win64} - push rbx - push r12 - push r13 - push r14 - push r15 - movzx eax, word ptr [rcx] // rcx=src eax=result - lea r9, [rcx+rdx] // r9=src_end - test eax, eax - je @35 - add rcx, 2 - mov r10d, eax - and r10d, 8000H - jz @21 - movzx ebx, word ptr [rcx] - shl ebx, 15 - mov r10d, eax - and r10d, 7FFFH - or r10d, ebx - mov eax, r10d - add rcx, 2 -@21: lea r10, [r8-1H] // r10=last_hashed r8=dest -@22: mov edi, dword ptr [rcx] // edi=CW - add rcx, 4 - mov r13d, 1 // r13d=CWBit - cmp rcx, r9 - jnc @35 -@23: test r13d, edi - jnz @25 - mov bl, byte ptr [rcx] - mov byte ptr [r8], bl - add rcx, 1 - lea rbx, [r8-2H] - add r8, 1 - cmp rcx, r9 - jnc @35 - cmp rbx, r10 - jbe @24 - add r10, 1 - mov esi, dword ptr [r10] - mov rbx, rsi - shr esi, 12 - xor ebx, esi - and ebx, 0FFFH - mov qword ptr [off+rbx*8], r10 -@24: shl r13d, 1 - jnz @23 - jmp @22 -@25: movzx r11, word ptr [rcx] // r11=t - add rcx, 2 - mov ebx, r11d // ebx=h - shr ebx, 4 - and r11, 0FH - lea r11, [r11+2H] - jnz @26 - movzx r11, byte ptr [rcx] - add rcx, 1 - lea r11, [r11+12H] -@26: mov r14, qword ptr [off+rbx*8] // r14=o - mov rbx, r8 - xor rsi, rsi - sub rbx, r14 - mov r12, r11 - mov r15, r11 - cmp rbx, r11 - jc @29 - shr r12, 3 - jz @30 -@27: mov rbx, qword ptr [r14+rsi] // inline move by 8 bytes - mov qword ptr [r8+rsi], rbx - add rsi, 8 - dec r12 - jnz @27 - mov rbx, qword ptr [r14+rsi] // 1..7 remaining bytes - and r15, 7 - jz @31 -@28: mov byte ptr [r8+rsi], bl - shr rbx, 8 - inc rsi - dec r15 - jnz @28 - jmp @31 -@29: mov bl, byte ptr [r14+rsi] // overlaping move - mov byte ptr [r8+rsi], bl - inc rsi - dec r12 - jnz @29 - cmp rcx, r9 - jnz @33 - jmp @35 -@30: mov rbx, qword ptr [r14] - mov qword ptr [r8], rbx -@31: cmp rcx, r9 - jz @35 - cmp r10, r8 - jnc @34 -@32: add r10, 1 - mov ebx, dword ptr [r10] - mov rsi, rbx - shr ebx, 12 - xor esi, ebx - and esi, 0FFFH - mov qword ptr [off+rsi*8], r10 -@33: cmp r10, r8 - jc @32 -@34: add r8, r11 - lea r10, [r8-1H] - shl r13d, 1 - jnz @23 - jmp @22 -@35: pop r15 - pop r14 - pop r13 - pop r12 - pop rbx - {$ifdef win64} // additional registers to preserve - pop rdi - pop rsi - {$endif win64} -{$endif CPUX86} -end; -{$endif CPUINTEL} - -// better code generation with sub-functions for raw decoding -procedure SynLZdecompress1passub(src, src_end, dst: PAnsiChar; var offset: TOffsets); -var last_hashed: PAnsiChar; // initial src and dst value - {$ifdef CPU64} - o: PAnsiChar; - {$endif} - CW, CWbit: cardinal; - v, t, h: PtrUInt; -label nextCW; -begin - last_hashed := dst-1; -nextCW: - CW := PCardinal(src)^; - inc(src,4); - CWbit := 1; - if src=src_end then break; - if last_hashed0 then - continue else - goto nextCW; - end else begin - h := PWord(src)^; - inc(src,2); - t := (h and 15)+2; - h := h shr 4; - if t=2 then begin - t := ord(src^)+(16+2); - inc(src); - end; - {$ifdef CPU64} - o := offset[h]; - if PtrUInt(dst-o)8 then // safe since src_endmatch := src_end-(6+5) - move(offset[h]^,dst^,t) else - PInt64(dst)^ := PInt64(offset[h])^; // much faster in practice - {$endif} - if src>=src_end then break; - if last_hashed=dst; - inc(dst,t); - last_hashed := dst-1; - CWbit := CWbit shl 1; - if CWbit<>0 then - continue else - goto nextCW; - end; - until false; -end; - -function SynLZdecompress1pas(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; -var offset: TOffsets; - src_end: PAnsiChar; -begin - src_end := src+size; - result := PWord(src)^; - if result=0 then exit; - inc(src,2); - if result and $8000<>0 then begin - result := (result and $7fff) or (integer(PWord(src)^) shl 15); - inc(src,2); - end; - SynLZdecompress1passub(src, src_end, dst, offset); -end; - -procedure SynLZdecompress1partialsub(src, dst, src_end, dst_end: PAnsiChar; var offset: TOffsets); -var last_hashed: PAnsiChar; // initial src and dst value - CWbit, CW: integer; - v, t, h: PtrUInt; - {$ifdef CPU64} - o: PAnsiChar; - {$endif} -label nextCW; -begin - last_hashed := dst-1; -nextCW: - CW := PCardinal(src)^; - inc(src,4); - CWbit := 1; - if src=src_end) or (dst>=dst_end) then - break; - if last_hashed0 then - continue else - goto nextCW; - end else begin - h := PWord(src)^; - inc(src,2); - t := (h and 15)+2; - h := h shr 4; - if t=2 then begin - t := ord(src^)+(16+2); - inc(src); - end; - if dst+t>=dst_end then begin // avoid buffer overflow by all means - movechars(offset[h],dst,dst_end-dst); - break; - end; - {$ifdef CPU64} - o := offset[h]; - if (t<=8) or (PtrUInt(dst-o)=src_end then - break; - if last_hashed=dst; - inc(dst,t); - last_hashed := dst-1; - CWbit := CWbit shl 1; - if CWbit<>0 then - continue else - goto nextCW; - end; - until false; -end; - -function SynLZdecompress1partial(src: PAnsiChar; size: integer; dst: PAnsiChar; maxDst: integer): integer; -var offset: TOffsets; - src_end: PAnsiChar; -begin - src_end := src+size; - result := PWord(src)^; - if result=0 then exit; - inc(src,2); - if result and $8000<>0 then begin - result := (result and $7fff) or (integer(PWord(src)^) shl 15); - inc(src,2); - end; - if maxDst0 then - SynLZdecompress1partialsub(src, dst, src_end, dst+result, offset); -end; - - -function SynLZcompress2(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; -var dst_beg, // initial dst value - src_end, // real last byte available in src - src_endmatch, // last byte to try for hashing - o: PAnsiChar; - CWbit: byte; - CWpoint: PCardinal; - h, v, cached: integer; - t, tmax, tdiff, i: integer; - offset: TOffsets; // 16KB+16KB=32KB hashing code - cache: array[0..4095] of integer; - label dotdiff; -begin - dst_beg := dst; - // 1. store in_len - if size>=$8000 then begin - PWord(dst)^ := $8000 or (size and $7fff); - PWord(dst+2)^ := size shr 15; - inc(dst,4); - end else begin - PWord(dst)^ := size ; // src<32768 -> stored as word, otherwise as integer - if size=0 then begin - result := 2; - exit; - end; - inc(dst,2); - end; - // 2. compress - src_end := src+size; - src_endmatch := src_end-(6+5); - CWbit := 0; - CWpoint := pointer(dst); - PCardinal(dst)^ := 0; - inc(dst,sizeof(CWpoint^)); - tdiff := 0; - fillchar(offset,sizeof(offset),0); // fast 16KB reset to 0 - // 1. main loop to search using hash[] - if src<=src_endmatch then - repeat - v := PCardinal(src)^; - h := ((v shr 12) xor v) and 4095; - o := offset[h]; - offset[h] := src; - cached := v xor cache[h]; - cache[h] := v; - if (cached and $00ffffff=0) and (o<>nil) and (src-o>2) then begin -// SetBit(CWpoint,CWbit); -// asm movzx eax,byte ptr CWbit; bts [CWpoint],eax; end - if tdiff<>0 then begin - dec(src,tdiff); -dotdiff:v := tdiff; - if v<=8 then begin - if CWBit+v>31 then begin - for i := CWBit to 31 do begin - dst^ := src^; - inc(dst); - inc(src); - end; - CWpoint := pointer(dst); - PCardinal(dst)^ := 0; - inc(dst,4); - CWBit := (CWBit+v) and 31; - for i := 1 to CWBit do begin - dst^ := src^; - inc(dst); - inc(src); - end; - end else begin - inc(CWBit,v); - for i := 1 to v do begin - dst^ := src^; - inc(dst); - inc(src); - end; - end; - end else begin - CWpoint^ := CWpoint^ or (cardinal(1) shl CWbit); - dec(v,9); - if v>15 then begin - v := 15; // v=9..24 -> h=0..15 - dst^ := #$ff; // size=15 -> tdiff - end else - dst^ := ansichar((v shl 4) or 15); // size=15 -> tdiff - inc(dst); - pInt64(dst)^ := pInt64(src)^; - inc(dst,8); - inc(src,8); - for i := 1 to v+1 do begin - dst^ := src^; - inc(dst); - inc(src); - end; - if CWBit<31 then - inc(CWBit) else begin - CWpoint := pointer(dst); - PCardinal(dst)^ := 0; - inc(dst,4); - CWbit := 0; - end; - dec(tdiff,24); - if tdiff>0 then - goto dotdiff; - end; - end; -// assert(PWord(o)^=PWord(src)^); - tdiff := 0; - CWpoint^ := CWpoint^ or (cardinal(1) shl CWbit); - inc(src,2); - inc(o,2); - t := 0; // t=matchlen-2 - tmax := src_end-src; - if tmax>=(255+15) then - tmax := (255+15); - while (o[t]=src[t]) and (t0); - // here we have always t>0 - if t<15 then begin // store t=1..14 -> size=t=1..14 - PWord(dst)^ := integer(t or h); - inc(dst,2); - end else begin // store t=15..255+15 -> size=0, next byte=matchlen-15-2 - dst[2] := ansichar(t-15); - PWord(dst)^ := h; // size=0 - inc(dst,3); - end; - if CWbit<31 then begin - inc(CWbit); - if src<=src_endmatch then continue else break; - end else begin - CWpoint := pointer(dst); - PCardinal(dst)^ := 0; - inc(dst,4); - CWbit := 0; - if src<=src_endmatch then continue else break; - end; - end else begin - inc(src); - inc(tdiff); - if src<=src_endmatch then continue else break; - end; - until false; - // 2. store remaining bytes - dec(src,tdiff); // force store trailing bytes - if src0 then begin - result := (result and $7fff) or (integer(PWord(src)^) shl 15); - inc(src,2); - end; - // 2. decompress - last_hashed := dst-1; -nextCW: - CW := PCardinal(src)^; - inc(src,4); - CWbit := 1; - if src=src_end then break; - if last_hashed0 then - continue else - goto nextCW; - end else begin - case ord(src^) and 15 of // get size - 0: begin // size=0 -> next byte=matchlen-15-2 - h := PWord(src)^ shr 4; - t := ord(src[2])+(15+2); - inc(src,3); - if dst-offset[h] tdiff - inc(src); - dst^ := src^; - inc(dst); - end; - inc(src); - if src>=src_end then break; - while last_hashed0 then - continue else - goto nextCW; - end; - else begin // size=1..14=matchlen-2 - h := PWord(src)^; - inc(src,2); - t := (h and 15)+2; - h := h shr 4; - if dst-offset[h]=dst; - inc(dst,t); - if src>=src_end then break; - last_hashed := dst-1; - CWbit := CWbit shl 1; - if CWbit<>0 then - continue else - goto nextCW; - end; - until false; - {$ifopt C+} - assert(result=dst-dst_beg); - {$endif} -end; - -end. diff --git a/lib/dmustache/SynMustache.pas b/lib/dmustache/SynMustache.pas deleted file mode 100644 index 7e86dcbd..00000000 --- a/lib/dmustache/SynMustache.pas +++ /dev/null @@ -1,1488 +0,0 @@ -/// Logic-less {{mustache}} template rendering -// - this unit is a part of the freeware Synopse mORMot framework, -// licensed under a MPL/GPL/LGPL tri-license; version 1.18 -unit SynMustache; - -{ - This file is part of Synopse mORMot framework. - - Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez - Synopse Informatique - https://synopse.info - - *** BEGIN LICENSE BLOCK ***** - Version: MPL 1.1/GPL 2.0/LGPL 2.1 - - The contents of this file are subject to the Mozilla Public License Version - 1.1 (the "License"); you may not use this file except in compliance with - the License. You may obtain a copy of the License at - http://www.mozilla.org/MPL - - Software distributed under the License is distributed on an "AS IS" basis, - WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License - for the specific language governing rights and limitations under the License. - - The Original Code is Synopse mORMot framework. - - The Initial Developer of the Original Code is Arnaud Bouchez. - - Portions created by the Initial Developer are Copyright (C) 2022 - the Initial Developer. All Rights Reserved. - - Contributor(s): - - shura1990 - - Alternatively, the contents of this file may be used under the terms of - either the GNU General Public License Version 2 or later (the "GPL"), or - the GNU Lesser General Public License Version 2.1 or later (the "LGPL"), - in which case the provisions of the GPL or the LGPL are applicable instead - of those above. If you wish to allow use of your version of this file only - under the terms of either the GPL or the LGPL, and not to allow others to - use your version of this file under the terms of the MPL, indicate your - decision by deleting the provisions above and replace them with the notice - and other provisions required by the GPL or the LGPL. If you do not delete - the provisions above, a recipient may use your version of this file under - the terms of any one of the MPL, the GPL or the LGPL. - - ***** END LICENSE BLOCK ***** - -} - - -{$I Synopse.inc} // define HASINLINE CPU32 CPU64 OWNNORMTOUPPER - -interface - -uses - {$ifdef HASINLINENOTX86} - {$ifdef MSWINDOWS}Windows,{$endif} // for Lock/UnLock inlining - {$endif} - Variants, - SysUtils, - SynCommons, - SynTable; - - -type - /// exception raised during process of a {{mustache}} template - ESynMustache = class(ESynException); - - /// identify the {{mustache}} tag kind - // - mtVariable if the tag is a variable - e.g. {{myValue}} - or an Expression - // Helper - e.g. {{helperName valueName}} - // - mtVariableUnescape, mtVariableUnescapeAmp to unescape the variable HTML - e.g. - // {{{myRawValue}}} or {{& name}} - // - mtSection and mtInvertedSection for sections beginning - e.g. - // {{#person}} or {{^person}} - // - mtSectionEnd for sections ending - e.g. {{/person}} - // - mtComment for comments - e.g. {{! ignore me}} - // - mtPartial for partials - e.g. {{> next_more}} - // - mtSetPartial for setting an internal partial - e.g. - // {{=}} - - // Warning: current implementation only supports two character delimiters - // - mtTranslate for content i18n via a callback - e.g. {{"English text}} - // - mtText for all text that appears outside a symbol - TSynMustacheTagKind = ( - mtVariable, mtVariableUnescape, mtVariableUnescapeAmp, - mtSection, mtInvertedSection, mtSectionEnd, - mtComment, mtPartial, mtSetPartial, mtSetDelimiter, mtTranslate, mtText); - - /// store a {{mustache}} tag - TSynMustacheTag = record - /// the kind of the tag - Kind: TSynMustacheTagKind; - /// points to the mtText buffer start - // - main template's text is not allocated as a separate string during - // parsing, but will rather be copied directly from the template memory - TextStart: PUTF8Char; - /// stores the mtText buffer length - TextLen: integer; - /// the index in Tags[] of the other end of this section - // - either the index of mtSectionEnd for mtSection/mtInvertedSection - // - or the index of mtSection/mtInvertedSection for mtSectionEnd - SectionOppositeIndex: integer; - /// the tag content, excluding trailing {{ }} and corresponding symbol - // - is not set for mtText nor mtSetDelimiter - Value: RawUTF8; - end; - - /// store all {{mustache}} tags of a given template - TSynMustacheTagDynArray = array of TSynMustacheTag; - - /// states the section content according to a given value - // - msNothing for false values or empty lists - // - msSingle for non-false values but not a list - // - msSinglePseudo is for *-first *-last *-odd and helper values - // - msList for non-empty lists - TSynMustacheSectionType = (msNothing,msSingle,msSinglePseudo,msList); - - TSynMustache = class; - - /// callback signature used to process an Expression Helper variable - // - i.e. {{helperName value}} tags - // - returned value will be used to process as replacement of a single {{tag}} - TSynMustacheHelperEvent = procedure(const Value: variant; out result: variant) of object; - - /// used to store a registered Expression Helper implementation - TSynMustacheHelper = record - /// the Expression Helper name - Name: RawUTF8; - /// the corresponding callback to process the tag - Event: TSynMustacheHelperEvent; - end; - - /// used to store all registered Expression Helpers - // - i.e. {{helperName value}} tags - // - use TSynMustache.HelperAdd/HelperDelete class methods to manage the list - // or retrieve standard helpers via TSynMustache.HelpersGetStandardList - TSynMustacheHelpers = array of TSynMustacheHelper; - - /// handle {{mustache}} template rendering context, i.e. all values - // - this abstract class should not be used directly, but rather any - // other overridden class - TSynMustacheContext = class - protected - fContextCount: integer; - fWriter: TTextWriter; - fOwner: TSynMustache; - fEscapeInvert: boolean; - fHelpers: TSynMustacheHelpers; - fOnStringTranslate: TOnStringTranslate; - procedure TranslateBlock(Text: PUTF8Char; TextLen: Integer); virtual; - procedure PopContext; virtual; abstract; - procedure AppendValue(const ValueName: RawUTF8; UnEscape: boolean); - virtual; abstract; - function AppendSection(const ValueName: RawUTF8): TSynMustacheSectionType; - virtual; abstract; - function GotoNextListItem: boolean; - virtual; abstract; - public - /// initialize the rendering context for the given text writer - constructor Create(Owner: TSynMustache; WR: TTextWriter); - /// the registered Expression Helpers, to handle {{helperName value}} tags - // - use TSynMustache.HelperAdd/HelperDelete class methods to manage the list - // or retrieve standard helpers via TSynMustache.HelpersGetStandardList - property Helpers: TSynMustacheHelpers read fHelpers write fHelpers; - /// access to the {{"English text}} translation callback - property OnStringTranslate: TOnStringTranslate - read fOnStringTranslate write fOnStringTranslate; - /// read-only access to the associated text writer instance - property Writer: TTextWriter read fWriter; - /// invert the HTML characters escaping process - // - by default, {{value}} will escape value chars, and {{{value}} won't - // - set this property to true to force {{value}} NOT to escape HTML chars - // and {{{value}} escaping chars (may be useful e.g. for code generation) - property EscapeInvert: boolean read fEscapeInvert write fEscapeInvert; - end; - - /// handle {{mustache}} template rendering context from a custom variant - // - the context is given via a custom variant type implementing - // TSynInvokeableVariantType.Lookup, e.g. TDocVariant or TSMVariant - TSynMustacheContextVariant = class(TSynMustacheContext) - protected - fContext: array of record - Document: TVarData; - DocumentType: TSynInvokeableVariantType; - ListCount: integer; - ListCurrent: integer; - ListCurrentDocument: TVarData; - ListCurrentDocumentType: TSynInvokeableVariantType; - end; - fTempGetValueFromContextHelper: TVariantDynArray; - procedure PushContext(aDoc: TVarData); - procedure PopContext; override; - procedure AppendValue(const ValueName: RawUTF8; UnEscape: boolean); override; - function AppendSection(const ValueName: RawUTF8): TSynMustacheSectionType; override; - function GotoNextListItem: boolean; override; - function GetDocumentType(const aDoc: TVarData): TSynInvokeableVariantType; - function GetValueFromContext(const ValueName: RawUTF8; var Value: TVarData): TSynMustacheSectionType; - function GetValueCopyFromContext(const ValueName: RawUTF8): variant; - procedure AppendVariant(const Value: variant; UnEscape: boolean); - public - /// initialize the context from a custom variant document - // - note that the aDocument instance shall be available during all - // lifetime of this TSynMustacheContextVariant instance - // - you should not use this constructor directly, but the - // corresponding TSynMustache.Render*() methods - constructor Create(Owner: TSynMustache; WR: TTextWriter; SectionMaxCount: integer; - const aDocument: variant); - end; - - /// maintain a list of {{mustache}} partials - // - this list of partials template could be supplied to TSynMustache.Render() - // method, to render {{>partials}} as expected - // - using a dedicated class allows to share the partials between execution - // context, without recurring to non SOLID global variables - // - you may also define "internal" partials, e.g. {{partialName}} template - // - returns the parsed template - function Add(const aName,aTemplate: RawUTF8): TSynMustache; overload; - /// register a {{>partialName}} template - // - returns the parsed template - function Add(const aName: RawUTF8; aTemplateStart,aTemplateEnd: PUTF8Char): TSynMustache; overload; - /// search some text withing the {{mustache}} partial - function FoundInTemplate(const text: RawUTF8): PtrInt; - /// delete the partials - destructor Destroy; override; - /// low-level access to the internal partials list - property List: TRawUTF8List read fList; - end; - - /// stores one {{mustache}} pre-rendered template - // - once parsed, a template will be stored in this class instance, to be - // rendered lated via the Render() method - // - you can use the Parse() class function to maintain a shared cache of - // parsed templates - // - implements all official mustache specifications, and some extensions - // - handles {{.}} pseudo-variable for the current context object (very - // handy when looping through a simple list, for instance) - // - handles {{-index}} pseudo-variable for the current context array index - // (1-based value) so that e.g. - // "My favorite things:\n{{#things}}{{-index}}. {{.}}\n{{/things}}" - // over {things:["Peanut butter", "Pen spinning", "Handstands"]} renders as - // "My favorite things:\n1. Peanut butter\n2. Pen spinning\n3. Handstands\n" - // - you could use {{-index0}} for 0-based index value - // - handles -first -last and -odd pseudo-section keys, e.g. - // "{{#things}}{{^-first}}, {{/-first}}{{.}}{{/things}}" - // over {things:["one", "two", "three"]} renders as 'one, two, three' - // - allows inlined partial templates , to be defined e.g. as - // {{ <= >= <> operators over two values: - // $ {{#if .,"=",123}} {{#if Total,">",1000}} {{#if info,"<>",""}} - // which may be shortened as such: - // $ {{#if .=123}} {{#if Total>1000}} {{#if info<>""}} - class function HelpersGetStandardList: TSynMustacheHelpers; overload; - /// returns a list of most used static Expression Helpers, adding some - // custom callbacks - // - is just a wrapper around HelpersGetStandardList and HelperAdd() - class function HelpersGetStandardList(const aNames: array of RawUTF8; - const aEvents: array of TSynMustacheHelperEvent): TSynMustacheHelpers; overload; - - /// renders the {{mustache}} template into a destination text buffer - // - the context is given via our abstract TSynMustacheContext wrapper - // - the rendering extended in fTags[] is supplied as parameters - // - you can specify a list of partials via TSynMustachePartials.CreateOwned - procedure RenderContext(Context: TSynMustacheContext; TagStart,TagEnd: integer; - Partials: TSynMustachePartials; NeverFreePartials: boolean); - /// renders the {{mustache}} template from a variant defined context - // - the context is given via a custom variant type implementing - // TSynInvokeableVariantType.Lookup, e.g. TDocVariant or TSMVariant - // - you can specify a list of partials via TSynMustachePartials.CreateOwned, - // a list of Expression Helpers, or a custom {{"English text}} callback - // - can be used e.g. via a TDocVariant: - // !var mustache := TSynMustache; - // ! doc: variant; - // ! html: RawUTF8; - // !begin - // ! mustache := TSynMustache.Parse( - // ! 'Hello {{name}}'#13#10'You have just won {{value}} dollars!'); - // ! TDocVariant.New(doc); - // ! doc.name := 'Chris'; - // ! doc.value := 10000; - // ! html := mustache.Render(doc); - // ! // here html='Hello Chris'#13#10'You have just won 10000 dollars!' - // - you can also retrieve the context from an ORM query of mORMot.pas: - // ! dummy := TSynMustache.Parse( - // ! '{{#items}}'#13#10'{{Int}}={{Test}}'#13#10'{{/items}}').Render( - // ! aClient.RetrieveDocVariantArray(TSQLRecordTest,'items','Int,Test')); - // - set EscapeInvert = true to force {{value}} NOT to escape HTML chars - // and {{{value}} escaping chars (may be useful e.g. for code generation) - function Render(const Context: variant; Partials: TSynMustachePartials=nil; - Helpers: TSynMustacheHelpers=nil; OnTranslate: TOnStringTranslate=nil; - EscapeInvert: boolean=false): RawUTF8; - /// renders the {{mustache}} template from JSON defined context - // - the context is given via a JSON object, defined from UTF-8 buffer - // - you can specify a list of partials via TSynMustachePartials.CreateOwned, - // a list of Expression Helpers, or a custom {{"English text}} callback - // - is just a wrapper around Render(_JsonFast()) - // - you can write e.g. with the extended JSON syntax: - // ! html := mustache.RenderJSON('{things:["one", "two", "three"]}'); - // - set EscapeInvert = true to force {{value}} NOT to escape HTML chars - // and {{{value}} escaping chars (may be useful e.g. for code generation) - function RenderJSON(const JSON: RawUTF8; Partials: TSynMustachePartials=nil; - Helpers: TSynMustacheHelpers=nil; OnTranslate: TOnStringTranslate=nil; - EscapeInvert: boolean=false): RawUTF8; overload; - /// renders the {{mustache}} template from JSON defined context - // - the context is given via a JSON object, defined with parameters - // - you can specify a list of partials via TSynMustachePartials.CreateOwned, - // a list of Expression Helpers, or a custom {{"English text}} callback - // - is just a wrapper around Render(_JsonFastFmt()) - // - you can write e.g. with the extended JSON syntax: - // ! html := mustache.RenderJSON('{name:?,value:?}',[],['Chris',10000]); - // - set EscapeInvert = true to force {{value}} NOT to escape HTML chars - // and {{{value}} escaping chars (may be useful e.g. for code generation) - function RenderJSON(const JSON: RawUTF8; const Args,Params: array of const; - Partials: TSynMustachePartials=nil; Helpers: TSynMustacheHelpers=nil; - OnTranslate: TOnStringTranslate=nil; - EscapeInvert: boolean=false): RawUTF8; overload; - /// search some text within the {{mustache}} template text - function FoundInTemplate(const text: RawUTF8): boolean; - - /// read-only access to the raw {{mustache}} template content - property Template: RawUTF8 read fTemplate; - /// the maximum possible number of nested contexts - property SectionMaxCount: Integer read fSectionMaxCount; - end; - - -const - /// this constant can be used to define as JSON a tag value - NULL_OR_TRUE: array[boolean] of RawUTF8 = ('null','true'); - - /// this constant can be used to define as JSON a tag value as separator - NULL_OR_COMMA: array[boolean] of RawUTF8 = ('null','","'); - -implementation - -function KindToText(Kind: TSynMustacheTagKind): PShortString; -begin - result := GetEnumName(TypeInfo(TSynMustacheTagKind),ord(Kind)); -end; - -type - TSynMustacheParser = class - protected - fTagStart, fTagStop: word; - fPos, fPosMin, fPosMax, fPosTagStart: PUTF8Char; - fTagCount: integer; - fTemplate: TSynMustache; - fScanStart, fScanEnd: PUTF8Char; - function Scan(ExpectedTag: Word): boolean; - procedure AddTag(aKind: TSynMustacheTagKind; - aStart: PUTF8Char=nil; aEnd: PUTF8Char=nil); - public - constructor Create(Template: TSynMustache; const DelimiterStart, DelimiterStop: RawUTF8); - procedure Parse(P,PEnd: PUTF8Char); - end; - - TSynMustacheCache = class(TRawUTF8List) - public - function Parse(const aTemplate: RawUTF8): TSynMustache; - function UnParse(const aTemplate: RawUTF8): boolean; - end; - -var - SynMustacheCache: TSynMustacheCache = nil; - - - -{ TSynMustacheParser } - -procedure TSynMustacheParser.AddTag(aKind: TSynMustacheTagKind; - aStart, aEnd: PUTF8Char); -var - P: PUTF8Char; -begin - if (aStart=nil) or (aEnd=nil) then begin - aStart := fScanStart; - aEnd := fScanEnd; - case aKind of - mtComment, mtSection, mtSectionEnd, mtInvertedSection, mtSetDelimiter, mtPartial: begin - // (indented) standalone lines should be removed from the template - if aKind<>mtPartial then - while (fPosTagStart>fPosMin) and (fPosTagStart[-1] in [' ',#9]) do - dec(fPosTagStart); // ignore any indentation chars - if (fPosTagStart=fPosMin) or (fPosTagStart[-1]=#$0A) then - // tag starts on a new line -> check if ends on the same line - if (fPos>fPosMax) or (fPos^=#$0A) or (PWord(fPos)^=$0A0D) then begin - if fPos<=fPosMax then - if fPos^=#$0A then - inc(fPos) else - if PWord(fPos)^=$0A0D then - inc(fPos,2); - if fTagCount>0 then // remove any indentation chars from previous text - with fTemplate.fTags[fTagCount-1] do - if Kind=mtText then - while (TextLen>0) and (TextStart[TextLen-1] in [' ',#9]) do - dec(TextLen); - end; - end; - mtVariable, mtVariableUnescape, mtVariableUnescapeAmp: begin - // handle JSON object/array with nested } e.g. as {{helper [{a:{a:1,b:2}}]}} - P := PosChar(aStart,' '); - if (P<>nil) and (Pnil then begin - aEnd := P; - fPos := P; - if not Scan(fTagStop) then - raise ESynMustache.CreateUTF8('Unfinished {{%',[aStart]); - if (aKind=mtVariableUnescape) and (fTagStop=$7d7d) and (PWord(fPos-1)^=$7d7d) then - inc(fPos); // {{{name}}} -> point after }}} - end; - end; - end; - end; - end; - end; - if aEnd<=aStart then - exit; - if fTagCount>=length(fTemplate.fTags) then - SetLength(fTemplate.fTags,NextGrow(fTagCount)); - with fTemplate.fTags[fTagCount] do begin - Kind := aKind; - SectionOppositeIndex := -1; - case aKind of - mtText, mtComment, mtTranslate: begin - TextStart := aStart; - TextLen := aEnd-aStart; - end; - else begin - TextStart := fPosTagStart; - TextLen := aEnd-fPosTagStart; - // superfluous in-tag whitespace should be ignored - while (aStartaStart) and (aEnd[-1]<=' ') do dec(aEnd); - if aEnd=aStart then - raise ESynMustache.CreateUTF8('Void % identifier',[KindToText(aKind)^]); - FastSetString(Value,aStart,aEnd-aStart); - end; - end; - end; - inc(fTagCount); -end; - -constructor TSynMustacheParser.Create(Template: TSynMustache; - const DelimiterStart, DelimiterStop: RawUTF8); -begin - fTemplate := Template; - if length(DelimiterStart)<>2 then - raise ESynMustache.CreateUTF8('DelimiterStart="%"',[DelimiterStart]); - if length(DelimiterStop)<>2 then - raise ESynMustache.CreateUTF8('DelimiterStop="%"',[DelimiterStop]); - fTagStart := PWord(DelimiterStart)^; - fTagStop := PWord(DelimiterStop)^; -end; - -function GotoNextTag(P,PMax: PUTF8Char; ExpectedTag: Word): PUTF8Char; -begin - if PExpectedTag then begin - inc(P); - if P0) and IdemPropNameU(finish,pointer(start),i-1); - end; -end; - -procedure TSynMustacheParser.Parse(P, PEnd: PUTF8Char); -var Kind: TSynMustacheTagKind; - Symbol: AnsiChar; - i,j,secCount,secLevel: integer; -begin - secCount := 0; - if P=nil then - exit; - fPos := P; - fPosMin := P; - fPosMax := PEnd-1; - repeat - if not Scan(fTagStart) then - break; - fPosTagStart := fScanEnd; - AddTag(mtText); - if fPos>=fPosMax then - break; - Symbol := fPos^; - case Symbol of - '=': Kind := mtSetDelimiter; - '{': Kind := mtVariableUnescape; - '&': Kind := mtVariableUnescapeAmp; - '#': Kind := mtSection; - '^': Kind := mtInvertedSection; - '/': Kind := mtSectionEnd; - '!': Kind := mtComment; - '>': Kind := mtPartial; - '<': Kind := mtSetPartial; - '"': Kind := mtTranslate; - else Kind := mtVariable; - end; - if Kind<>mtVariable then - inc(fPos); - if not Scan(fTagStop) then - raise ESynMustache.CreateUTF8('Unfinished {{tag [%]',[fPos]); - case Kind of - mtSetDelimiter: begin - if (fScanEnd-fScanStart<>6) or (fScanEnd[-1]<>'=') then - raise ESynMustache.Create('mtSetDelimiter syntax is e.g. {{=<% %>=}}'); - fTagStart := PWord(fScanStart)^; - fTagStop := PWord(fScanStart+3)^; - continue; // do not call AddTag(mtSetDelimiter) - end; - mtVariableUnescape: - if (Symbol='{') and (fTagStop=$7d7d) and (PWord(fPos-1)^=$7d7d) then - inc(fPos); // {{{name}}} -> point after }}} - end; - AddTag(Kind); - until false; - AddTag(mtText,fPos,fPosMax+1); - for i := 0 to fTagCount-1 do - with fTemplate.fTags[i] do - case Kind of - mtSection, mtInvertedSection, mtSetPartial: begin - inc(secCount); - if secCount>fTemplate.fSectionMaxCount then - fTemplate.fSectionMaxCount := secCount; - secLevel := 1; - for j := i+1 to fTagCount-1 do - case fTemplate.fTags[j].Kind of - mtSection, mtInvertedSection, mtSetPartial: - inc(secLevel); - mtSectionEnd: begin - dec(secLevel); - if secLevel=0 then - if SectionNameMatch(Value,fTemplate.fTags[j].Value) then begin - fTemplate.fTags[j].SectionOppositeIndex := i; - SectionOppositeIndex := j; - if Kind=mtSetPartial then begin - if fTemplate.fInternalPartials=nil then - fTemplate.fInternalPartials := TSynMustachePartials.Create; - fTemplate.fInternalPartials.Add(Value, - TextStart+TextLen+2,fTemplate.fTags[j].TextStart); - end; - break; - end else - raise ESynMustache.CreateUTF8('Got {{/%}}, expected {{/%}}', - [Value,fTemplate.fTags[j].Value]); - end; - end; - if SectionOppositeIndex<0 then - raise ESynMustache.CreateUTF8('Missing section end {{/%}}',[Value]); - end; - mtSectionEnd: begin - dec(secCount); - if SectionOppositeIndex<0 then - raise ESynMustache.CreateUTF8('Unexpected section end {{/%}}',[Value]); - end; - end; - SetLength(fTemplate.fTags,fTagCount); -end; - - -{ TSynMustacheCache } - -function TSynMustacheCache.Parse(const aTemplate: RawUTF8): TSynMustache; -begin - result := GetObjectFrom(aTemplate); - if result=nil then begin - result := TSynMustache.Create(aTemplate); - AddObjectUnique(aTemplate,@result); - end; -end; - -function TSynMustacheCache.UnParse(const aTemplate: RawUTF8): boolean; -begin - result := Delete(aTemplate)>=0; -end; - - -{ TSynMustache } - -class function TSynMustache.Parse(const aTemplate: RawUTF8): TSynMustache; -begin - if SynMustacheCache=nil then - GarbageCollectorFreeAndNil(SynMustacheCache, - TSynMustacheCache.Create([fObjectsOwned,fNoDuplicate,fCaseSensitive])); - result := SynMustacheCache.Parse(aTemplate); -end; - -class function TSynMustache.UnParse(const aTemplate: RawUTF8): boolean; -begin - result := SynMustacheCache.UnParse(aTemplate); -end; - -class function TSynMustache.TryRenderJson(const aTemplate, aJSON: RawUTF8; - out aContent: RawUTF8): boolean; -var mus: TSynMustache; -begin - if aTemplate<>'' then - try - mus := Parse(aTemplate); - aContent := mus.RenderJSON(aJSON); - result := true; - except - result := false; - end else - result := false; -end; - -constructor TSynMustache.Create(const aTemplate: RawUTF8); -begin - Create(pointer(aTemplate),length(aTemplate)); -end; - -constructor TSynMustache.Create(aTemplate: PUTF8Char; aTemplateLen: integer); -begin - inherited Create; - fTemplate := aTemplate; - with TSynMustacheParser.Create(self,'{{','}}') do - try - Parse(aTemplate,aTemplate+aTemplateLen); - finally - Free; - end; -end; - -type - TSynMustacheProcessSection = procedure of object; - -procedure TSynMustache.RenderContext(Context: TSynMustacheContext; - TagStart,TagEnd: integer; Partials: TSynMustachePartials; NeverFreePartials: boolean); -var partial: TSynMustache; -begin - try - while TagStart<=TagEnd do begin - with fTags[TagStart] do - case Kind of - mtText: - if TextLen<>0 then // may be 0 e.g. for standalone without previous Line - Context.fWriter.AddNoJSONEscape(TextStart,TextLen); - mtVariable: - Context.AppendValue(Value,false); - mtVariableUnescape, mtVariableUnescapeAmp: - Context.AppendValue(Value,true); - mtSection: - case Context.AppendSection(Value) of - msNothing: begin // e.g. for no key, false value, or empty list - TagStart := SectionOppositeIndex; - continue; // ignore whole section - end; - msList: begin - while Context.GotoNextListItem do - RenderContext(Context,TagStart+1,SectionOppositeIndex-1,Partials,true); - TagStart := SectionOppositeIndex; - continue; // ignore whole section since we just rendered it as a list - end; - // msSingle,msSinglePseudo: process the section once with current context - end; - mtInvertedSection: // display section for no key, false value, or empty list - if Context.AppendSection(Value)<>msNothing then begin - TagStart := SectionOppositeIndex; - continue; // ignore whole section - end; - mtSectionEnd: - if (fTags[SectionOppositeIndex].Kind in [mtSection,mtInvertedSection]) and - (Value[1]<>'-') and (PosExChar(' ',fTags[SectionOppositeIndex].Value)=0) then - Context.PopContext; - mtComment: - ; // just ignored - mtPartial: begin - partial := fInternalPartials.GetPartial(Value); - if (partial=nil) and (Context.fOwner<>self) then // recursive call - partial := Context.fOwner.fInternalPartials.GetPartial(Value); - if (partial=nil) and (Partials<>nil) then - partial := Partials.GetPartial(Value); - if partial<>nil then - partial.RenderContext(Context,0,high(partial.fTags),Partials,true); - end; - mtSetPartial: - TagStart := SectionOppositeIndex; // ignore whole internal {{0 then - Context.TranslateBlock(TextStart,TextLen); - else - raise ESynMustache.CreateUTF8('Kind=% not implemented yet', - [KindToText(fTags[TagStart].Kind)^]); - end; - inc(TagStart); - end; - finally - if (Partials<>nil) and (Partials.fOwned) and not NeverFreePartials then - Partials.Free; - end; -end; - -function TSynMustache.Render(const Context: variant; - Partials: TSynMustachePartials; Helpers: TSynMustacheHelpers; - OnTranslate: TOnStringTranslate; EscapeInvert: boolean): RawUTF8; -var W: TTextWriter; - Ctxt: TSynMustacheContext; - tmp: TTextWriterStackBuffer; -begin - W := TTextWriter.CreateOwnedStream(tmp); - try - Ctxt := TSynMustacheContextVariant.Create(self,W,SectionMaxCount,Context); - try - Ctxt.Helpers := Helpers; - Ctxt.OnStringTranslate := OnTranslate; - Ctxt.EscapeInvert := EscapeInvert; - RenderContext(Ctxt,0,high(fTags),Partials,false); - W.SetText(result); - finally - Ctxt.Free; - end; - finally - W.Free; - end; -end; - -function TSynMustache.RenderJSON(const JSON: RawUTF8; - Partials: TSynMustachePartials; Helpers: TSynMustacheHelpers; - OnTranslate: TOnStringTranslate; EscapeInvert: boolean): RawUTF8; -var context: variant; -begin - _Json(JSON,context,JSON_OPTIONS[true]); - result := Render(context,Partials,Helpers,OnTranslate,EscapeInvert); -end; - -function TSynMustache.RenderJSON(const JSON: RawUTF8; const Args, - Params: array of const; Partials: TSynMustachePartials; - Helpers: TSynMustacheHelpers; OnTranslate: TOnStringTranslate; - EscapeInvert: boolean): RawUTF8; -var context: variant; -begin - _Json(FormatUTF8(JSON,Args,Params,true),context,JSON_OPTIONS[true]); - result := Render(context,Partials,Helpers,OnTranslate,EscapeInvert); -end; - -destructor TSynMustache.Destroy; -begin - FreeAndNil(fInternalPartials); - inherited; -end; - -function TSynMustache.FoundInTemplate(const text: RawUTF8): boolean; -begin // internal partials are part of fTemplate - result := (self<>nil) and (text<>'') and (PosEx(text,fTemplate)>0); -end; - -class procedure TSynMustache.HelperAdd(var Helpers: TSynMustacheHelpers; - const aName: RawUTF8; aEvent: TSynMustacheHelperEvent); -var n,i: PtrInt; -begin - n := length(Helpers); - for i := 0 to n-1 do - if IdemPropNameU(Helpers[i].Name,aName) then begin - Helpers[i].Event := aEvent; - exit; - end; - SetLength(Helpers,n+1); - Helpers[n].Name := aName; - Helpers[n].Event := aEvent; -end; - -class procedure TSynMustache.HelperAdd(var Helpers: TSynMustacheHelpers; - const aNames: array of RawUTF8; const aEvents: array of TSynMustacheHelperEvent); -var n,i: PtrInt; -begin - n := length(aNames); - if n=length(aEvents) then - for i := 0 to n-1 do - HelperAdd(Helpers,aNames[i],aEvents[i]); -end; - -class procedure TSynMustache.HelperDelete(var Helpers: TSynMustacheHelpers; - const aName: RawUTF8); -var n,i,j: PtrInt; -begin - n := length(Helpers); - for i := 0 to n-1 do - if IdemPropNameU(Helpers[i].Name,aName) then begin - for j := i to n-2 do - Helpers[j] := Helpers[j+1]; - SetLength(Helpers,n-1); - exit; - end; -end; - -class function TSynMustache.HelperFind(const Helpers: TSynMustacheHelpers; - aName: PUTF8Char; aNameLen: integer): integer; -begin - for result := 0 to length(Helpers)-1 do - if IdemPropNameU(Helpers[result].Name,aName,aNameLen) then - exit; - result := -1; -end; - -var - HelpersStandardList: TSynMustacheHelpers; - -class function TSynMustache.HelpersGetStandardList: TSynMustacheHelpers; -begin - if HelpersStandardList=nil then - HelperAdd(HelpersStandardList, - ['DateTimeToText','DateToText','DateFmt','TimeLogToText','JSONQuote','JSONQuoteURI', - 'ToJSON','MarkdownToHtml','SimpleToHtml','WikiToHtml','BlobToBase64','EnumTrim', - 'EnumTrimRight','PowerOfTwo','Equals','If','NewGUID','ExtractFileName','Lower','Upper'], - [DateTimeToText,DateToText,DateFmt,TimeLogToText,JSONQuote,JSONQuoteURI, - ToJSON,MarkdownToHtml,SimpleToHtml,WikiToHtml,BlobToBase64,EnumTrim,EnumTrimRight, - PowerOfTwo,Equals_,If_,NewGUID,ExtractFileName,Lower,Upper]); - result := HelpersStandardList; -end; - -class function TSynMustache.HelpersGetStandardList(const aNames: array of RawUTF8; - const aEvents: array of TSynMustacheHelperEvent): TSynMustacheHelpers; -begin - result := copy(HelpersGetStandardList); // don't affect global HelpersStandardList - HelperAdd(result,aNames,aEvents); -end; - -class procedure TSynMustache.DateTimeToText(const Value: variant; out result: variant); -var Time: TTimeLogBits; - dt: TDateTime; -begin - if VariantToDateTime(Value,dt) then begin - Time.From(dt,false); - result := Time.i18nText; - end else - SetVariantNull(result); -end; - -class procedure TSynMustache.DateToText(const Value: variant; out result: variant); -var Time: TTimeLogBits; - dt: TDateTime; -begin - if VariantToDateTime(Value,dt) then begin - Time.From(dt,true); - result := Time.i18nText; - end else - SetVariantNull(result); -end; - -class procedure TSynMustache.DateFmt(const Value: variant; out result: variant); -var dt: TDateTime; -begin // {{DateFmt DateValue,"dd/mm/yyy"}} - with _Safe(Value)^ do - if (Kind=dvArray) and (Count=2) and VariantToDateTime(Values[0],dt) then - result := FormatDateTime(Values[1],dt) else - SetVariantNull(result); -end; - -class procedure TSynMustache.TimeLogToText(const Value: variant; out result: variant); -var Time: TTimeLogBits; -begin - if VariantToInt64(Value,Time.Value) then - result := Time.i18nText else - SetVariantNull(result); -end; - -class procedure TSynMustache.ToJSON(const Value: variant; out result: variant); -begin - if not VarIsEmptyOrNull(Value) then - RawUTF8ToVariant(JSONReformat(VariantToUTF8(Value)),result); -end; - -class procedure TSynMustache.JSONQuote(const Value: variant; out result: variant); -var json: RawUTF8; -begin - if not VarIsEmptyOrNull(Value) then // avoid to return "null" - VariantToUTF8(Value,json); - RawUTF8ToVariant(QuotedStrJSON(json),result); -end; - -class procedure TSynMustache.JSONQuoteURI(const Value: variant; out result: variant); -var json: RawUTF8; -begin - if not VarIsEmptyOrNull(Value) then // avoid to return "null" - VariantToUTF8(Value,json); - RawUTF8ToVariant(UrlEncode(QuotedStrJSON(json)),result); -end; - -procedure ToHtml(const Value: variant; var result: variant; fmt: TTextWriterHTMLEscape; - wiki: boolean=false); -var txt: RawUTF8; - d: PDocVariantData; -begin - d := _Safe(Value); // {{{SimpleToHtml content,browserhasnoemoji,nohtmlescape}}} - if (dvoIsArray in d^.Options) and (d^.Count>=2) then begin - if VarIsEmptyOrNull(d^.Values[0]) then - exit; // don't append 'null' text - VariantToUTF8(d^.Values[0],txt); - if not VarIsVoid(d^.Values[1]) then - exclude(fmt,heEmojiToUTF8); - if (d^.Count>=3) and not VarIsVoid(d^.Values[2]) then - exclude(fmt,heHtmlEscape); - end else // {{{MarkdownToHtml content}}} - if VarIsEmptyOrNull(Value) then - exit else - VariantToUTF8(Value,txt); - if txt<>'' then - if wiki then - txt := HtmlEscapeWiki(txt,fmt) else - txt := HtmlEscapeMarkdown(txt,fmt); - RawUTF8ToVariant(txt,result); -end; - -class procedure TSynMustache.WikiToHtml(const Value: variant; out result: variant); -begin - ToHtml(Value,result,[heHtmlEscape,heEmojiToUTF8],{wiki=}true); -end; - -class procedure TSynMustache.MarkdownToHtml(const Value: variant; out result: variant); -begin - ToHtml(Value,result,[heEmojiToUTF8]); // default Markdown is to allow HTML tags -end; - -class procedure TSynMustache.SimpleToHtml(const Value: variant; out result: variant); -begin - ToHtml(Value,result,[heHtmlEscape,heEmojiToUTF8]); -end; - -class procedure TSynMustache.BlobToBase64(const Value: variant; out result: variant); -var tmp: RawUTF8; - wasString: boolean; -begin - VariantToUTF8(Value,tmp,wasString); - if wasString and (pointer(tmp)<>nil) then begin - if PInteger(tmp)^ and $00ffffff=JSON_BASE64_MAGIC then - delete(tmp,1,3); - RawUTF8ToVariant(tmp,result); - end else - result := Value; -end; - -class procedure TSynMustache.EnumTrim(const Value: variant; out result: variant); -var tmp: RawUTF8; - wasString: boolean; - short: PUTF8Char; -begin - VariantToUTF8(Value,tmp,wasString); - if not wasString then - exit; - short := TrimLeftLowerCase(tmp); - RawUTF8ToVariant(short,StrLen(short),result); -end; - -class procedure TSynMustache.EnumTrimRight(const Value: variant; out result: variant); -var tmp: RawUTF8; - wasString: boolean; - i,L: integer; -begin - VariantToUTF8(Value,tmp,wasString); - if not wasString then - exit; - L := length(tmp); - for i := 1 to L do - if not (tmp[i] in ['a'..'z']) then begin - L := i-1; - break; - end; - RawUTF8ToVariant(Pointer(tmp),L,result); -end; - -class procedure TSynMustache.PowerOfTwo(const Value: variant; out result: variant); -var V: Int64; -begin - if TVarData(Value).VType>varNull then - if VariantToInt64(Value,V) then - result := Int64(1) shl V; -end; - -class procedure TSynMustache.Equals_(const Value: variant; out result: variant); -begin // {{#Equals .,12}} - with _Safe(Value)^ do - if (Kind=dvArray) and (Count=2) and - (SortDynArrayVariantComp(TVarData(Values[0]),TVarData(Values[1]),false)=0) then - result := true else - SetVariantNull(result); -end; - -class procedure TSynMustache.If_(const Value: variant; out result: variant); -var cmp: integer; - oper: RawUTF8; - wasString: boolean; -begin // {{#if .<>""}} or {{#if .,"=",123}} - SetVariantNull(result); - with _Safe(Value)^ do - if (Kind=dvArray) and (Count=3) then begin - VariantToUTF8(Values[1],oper,wasString); - if wasString and (oper<>'') then begin - cmp := SortDynArrayVariantComp(TVarData(Values[0]),TVarData(Values[2]),false); - case PWord(oper)^ of - ord('='): if cmp=0 then result := True; - ord('>'): if cmp>0 then result := True; - ord('<'): if cmp<0 then result := True; - ord('>')+ord('=')shl 8: if cmp>=0 then result := True; - ord('<')+ord('=')shl 8: if cmp<=0 then result := True; - ord('<')+ord('>')shl 8: if cmp<>0 then result := True; - end; - end; - end; -end; - -class procedure TSynMustache.NewGUID(const Value: variant; out result: variant); -var g: TGUID; -begin - CreateGUID(g); - RawUTF8ToVariant(GUIDToRawUTF8(g),result); -end; - -class procedure TSynMustache.ExtractFileName(const Value: variant; out result: variant); -begin - result := SysUtils.ExtractFileName(Value); -end; - -class procedure TSynMustache.Lower(const Value: variant; out result: variant); -begin - result := SysUtils.LowerCase(Value); -end; - -class procedure TSynMustache.Upper(const Value: variant; out result: variant); -begin - result := SysUtils.UpperCase(Value); -end; - - -{ TSynMustacheContext } - -constructor TSynMustacheContext.Create(Owner: TSynMustache; WR: TTextWriter); -begin - fOwner := Owner; - fWriter := WR; -end; - -procedure TSynMustacheContext.TranslateBlock(Text: PUTF8Char; TextLen: Integer); -var s: string; -begin - if Assigned(OnStringTranslate) then begin - UTF8DecodeToString(Text,TextLen,s); - OnStringTranslate(s); - fWriter.AddNoJSONEscapeString(s); - end else - fWriter.AddNoJSONEscape(Text,TextLen); -end; - - -{ TSynMustacheContextVariant } - -constructor TSynMustacheContextVariant.Create(Owner: TSynMustache; WR: TTextWriter; - SectionMaxCount: integer; const aDocument: variant); -begin - inherited Create(Owner,WR); - SetLength(fContext,SectionMaxCount+1); - PushContext(TVarData(aDocument)); // weak copy -end; - -function TSynMustacheContextVariant.GetDocumentType( - const aDoc: TVarData): TSynInvokeableVariantType; -begin - result := nil; - if aDoc.VType<=varAny then - exit; - if (fContextCount>0) and (fContext[0].DocumentType<>nil) and - (aDoc.VType=fContext[0].DocumentType.VarType) then - result := fContext[0].DocumentType else - if not (FindCustomVariantType(aDoc.VType,TCustomVariantType(result)) and - result.InheritsFrom(TSynInvokeableVariantType)) then - result := nil; -end; - -procedure TSynMustacheContextVariant.PushContext(aDoc: TVarData); -begin - if fContextCount>=length(fContext) then - SetLength(fContext,fContextCount+32); // roughtly set by SectionMaxCount - with fContext[fContextCount] do begin - Document := aDoc; - DocumentType := GetDocumentType(aDoc); - ListCurrent := -1; - if DocumentType=nil then - ListCount := -1 else - ListCount := DocumentType.IterateCount(aDoc); - end; - inc(fContextCount); -end; - -procedure TSynMustacheContextVariant.PopContext; -begin - if fContextCount>1 then - dec(fContextCount); -end; - -function TSynMustacheContextVariant.GetValueCopyFromContext( - const ValueName: RawUTF8): variant; -var tmp: TVarData; -begin - if (ValueName='') or (ValueName[1] in ['0'..'9','"','{','[']) or - (ValueName='true') or (ValueName='false') or (ValueName='null') then - VariantLoadJSON(result,ValueName,@JSON_OPTIONS[true]) else begin - GetValueFromContext(ValueName,tmp); - SetVariantByValue(variant(tmp),result); // copy value - end; -end; - -function TSynMustacheContextVariant.GetValueFromContext( - const ValueName: RawUTF8; var Value: TVarData): TSynMustacheSectionType; -var i,space,helper: Integer; - - procedure ProcessHelper; - var valnam: RawUTF8; - val: TVarData; - valArr: TDocVariantData absolute val; - valFree: boolean; - names: TRawUTF8DynArray; - res: PVarData; - j,k,n: integer; - begin - valnam := Copy(ValueName,space+1,maxInt); - valFree := false; - if valnam<>'' then begin - if valnam='.' then - GetValueFromContext(valnam,val) else - if ((valnam<>'') and (valnam[1] in ['1'..'9','"','{','['])) or - (valnam='true') or (valnam='false') or (valnam='null') then begin - // {{helper 123}} or {{helper "constant"}} or {{helper [1,2,3]}} - val.VType := varEmpty; - VariantLoadJson(variant(val),pointer(valnam),nil,@JSON_OPTIONS[true]); - valFree := true; - end else begin - for j := 1 to length(valnam) do - case valnam[j] of - ' ': break; // allows {{helper1 helper2 value}} recursive calls - ',': begin // {{helper value,123,"constant"}} - CSVToRawUTF8DynArray(Pointer(valnam),names,',',true); // TODO: handle 123,"a,b,c" - valArr.InitFast; - for k := 0 to High(names) do - valArr.AddItem(GetValueCopyFromContext(names[k])); - valFree := true; - break; - end; - '<','>','=': begin // {{#if .=123}} -> {{#if .,"=",123}} - k := j+1; - if valnam[k] in ['=','>'] then - inc(k); - valArr.InitArray([GetValueCopyFromContext(Copy(valnam,1,j-1)), - Copy(valnam,j,k-j),GetValueCopyFromContext(Copy(valnam,k,maxInt))],JSON_OPTIONS[true]); - valFree := true; - break; - end; - end; - if not valFree then - GetValueFromContext(valnam,val); - end; - end; - n := fContextCount+4; - if length(fTempGetValueFromContextHelper)0 then - Value := ListCurrentDocument else - Value := Document; - exit; - end; - space := PosExChar(' ',ValueName); - if space>1 then begin // {{helper value}} - helper := TSynMustache.HelperFind(Helpers,pointer(ValueName),space-1); - if helper>=0 then begin - ProcessHelper; - exit; - end; // if helper not found, will return the unprocessed value - end; - for i := fContextCount-1 downto 0 do // recursive search of {{value}} - with fContext[i] do - if DocumentType<>nil then - if ListCount<0 then begin // single item context - DocumentType.Lookup(Value,Document,pointer(ValueName)); - if Value.VType>=varNull then - exit; - end else - if IdemPChar(pointer(ValueName),'-INDEX') then begin // {{-index}} - Value.VType := varInteger; - if ValueName[7]='0' then - Value.VInteger := ListCurrent else - Value.VInteger := ListCurrent+1; - exit; - end else - if (ListCurrentnil) then begin - ListCurrentDocumentType.Lookup(Value,ListCurrentDocument,pointer(ValueName)); - if Value.VType>=varNull then - exit; - end; - if space=0 then begin - space := length(ValueName); // {{helper}} - helper := TSynMustache.HelperFind(Helpers,pointer(ValueName),space); - if helper>=0 then - ProcessHelper; - end; -end; - -procedure TSynMustacheContextVariant.AppendValue(const ValueName: RawUTF8; - UnEscape: boolean); -var Value: TVarData; -begin - GetValueFromContext(ValueName,Value); - AppendVariant(variant(Value),UnEscape); -end; - -procedure TSynMustacheContextVariant.AppendVariant(const Value: variant; - UnEscape: boolean); -var ValueText: RawUTF8; - wasString: boolean; -begin - if TVarData(Value).VType>varNull then - if VarIsNumeric(Value) then // avoid RawUTF8 conversion for plain numbers - fWriter.AddVariant(Value,twNone) else begin - if fEscapeInvert then - UnEscape := not UnEscape; - VariantToUTF8(Value,ValueText,wasString); - if UnEscape then - fWriter.AddNoJSONEscape(pointer(ValueText),length(ValueText)) else - fWriter.AddHtmlEscape(pointer(ValueText)); - end; -end; - -function TSynMustacheContextVariant.AppendSection( - const ValueName: RawUTF8): TSynMustacheSectionType; -var Value: TVarData; -begin - result := msNothing; - if (fContextCount>0) and (ValueName[1]='-') then - with fContext[fContextCount-1] do - if ListCount>=0 then begin - if ((ValueName='-first') and (ListCurrent=0)) or - ((ValueName='-last') and (ListCurrent=ListCount-1)) or - ((ValueName='-odd') and (ListCurrent and 1=0)) then - result := msSinglePseudo; - exit; - end; - result := GetValueFromContext(ValueName,Value); - if result<>msNothing then begin - if (Value.VType<=varNull) or - ((Value.VType=varBoolean) and not Value.VBoolean) then - result := msNothing; - exit; - end; - PushContext(Value); - if (Value.VType<=varNull) or - ((Value.VType=varBoolean) and not Value.VBoolean) then - exit; // null or false value will not display the section - with fContext[fContextCount-1] do - if ListCount<0 then - result := msSingle else // single item - if ListCount=0 then // empty list will not display the section - exit else - result := msList; // non-empty list -end; - -function TSynMustacheContextVariant.GotoNextListItem: boolean; -begin - result := false; - if fContextCount>0 then - with fContext[fContextCount-1] do begin - ListCurrentDocument.VType := varEmpty; - ListCurrentDocumentType := nil; - inc(ListCurrent); - if ListCurrent>=ListCount then - exit; - DocumentType.Iterate(ListCurrentDocument,Document,ListCurrent); - ListCurrentDocumentType := GetDocumentType(ListCurrentDocument); - result := true; - end; -end; - - -{ TSynMustachePartials } - -constructor TSynMustachePartials.Create; -begin - fList := TRawUTF8List.Create([fNoDuplicate,fCaseSensitive]); -end; - -constructor TSynMustachePartials.CreateOwned(const NameTemplatePairs: array of RawUTF8); -var A: integer; -begin - Create; - fOwned := true; - for A := 0 to high(NameTemplatePairs) div 2 do - Add(NameTemplatePairs[A*2],NameTemplatePairs[A*2+1]); -end; - -function TSynMustachePartials.Add(const aName, aTemplate: RawUTF8): TSynMustache; -begin - result := TSynMustache.Parse(aTemplate); - if (result<>nil) and (fList.AddObject(aName,result)<0) then - raise ESynMustache.CreateUTF8('%.Add(%) duplicated name',[self,aName]); -end; - -function TSynMustachePartials.Add(const aName: RawUTF8; - aTemplateStart, aTemplateEnd: PUTF8Char): TSynMustache; -var aTemplate: RawUTF8; -begin - FastSetString(aTemplate,aTemplateStart,aTemplateEnd-aTemplateStart); - result := Add(aName,aTemplate); -end; - -function TSynMustachePartials.FoundInTemplate(const text: RawUTF8): PtrInt; -begin - if self<>nil then - result := fList.Contains(text) else - result := -1; -end; - -class function TSynMustachePartials.CreateOwned(const Partials: variant): TSynMustachePartials; -var p: integer; -begin - result := nil; - if DocVariantType.IsOfType(Partials) then - with TDocVariantData(partials) do - if (Kind=dvObject) and (Count>0) then begin - result := TSynMustachePartials.Create; - result.fOwned := true; - for p := 0 to Count-1 do - result.Add(Names[p],VariantToUTF8(Values[p])); - end; -end; - -destructor TSynMustachePartials.Destroy; -begin - FreeAndNil(fList); - inherited; -end; - -function TSynMustachePartials.GetPartial(const PartialName: RawUTF8): TSynMustache; -var i: integer; -begin - if self=nil then begin - result := nil; - exit; - end; - i := fList.IndexOf(PartialName); // using O(1) hashing - if i<0 then - result := nil else - result := TSynMustache(fList.Objects[i]); -end; - -end. diff --git a/lib/dmustache/SynTable.pas b/lib/dmustache/SynTable.pas deleted file mode 100644 index 77797306..00000000 --- a/lib/dmustache/SynTable.pas +++ /dev/null @@ -1,18530 +0,0 @@ -/// filter/database/cache/buffer/security/search/multithread/OS features -// - as a complement to SynCommons, which tended to increase too much -// - licensed under a MPL/GPL/LGPL tri-license; version 1.18 -unit SynTable; - -(* - This file is part of Synopse framework. - - Synopse framework. Copyright (C) 2022 Arnaud Bouchez - Synopse Informatique - https://synopse.info - - *** BEGIN LICENSE BLOCK ***** - Version: MPL 1.1/GPL 2.0/LGPL 2.1 - - The contents of this file are subject to the Mozilla Public License Version - 1.1 (the "License"); you may not use this file except in compliance with - the License. You may obtain a copy of the License at - http://www.mozilla.org/MPL - - Software distributed under the License is distributed on an "AS IS" basis, - WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License - for the specific language governing rights and limitations under the License. - - The Original Code is Synopse framework. - - The Initial Developer of the Original Code is Arnaud Bouchez. - - Portions created by the Initial Developer are Copyright (C) 2022 - the Initial Developer. All Rights Reserved. - - Contributor(s): - - Alternatively, the contents of this file may be used under the terms of - either the GNU General Public License Version 2 or later (the "GPL"), or - the GNU Lesser General Public License Version 2.1 or later (the "LGPL"), - in which case the provisions of the GPL or the LGPL are applicable instead - of those above. If you wish to allow use of your version of this file only - under the terms of either the GPL or the LGPL, and not to allow others to - use your version of this file under the terms of the MPL, indicate your - decision by deleting the provisions above and replace them with the notice - and other provisions required by the GPL or the LGPL. If you do not delete - the provisions above, a recipient may use your version of this file under - the terms of any one of the MPL, the GPL or the LGPL. - - ***** END LICENSE BLOCK ***** - - - A lot of code has moved from SynCommons.pas and mORMot.pas, to reduce the - number of source code lines of those units, and circumvent Delphi 5/6/7 - limitations (e.g. internal error PRO-3006) - -*) - -interface - -{$I Synopse.inc} // define HASINLINE CPU32 CPU64 - -uses - {$ifdef MSWINDOWS} - Windows, - Messages, - {$else} - {$ifdef KYLIX3} - Types, - LibC, - SynKylix, - {$endif KYLIX3} - {$ifdef FPC} - BaseUnix, - Unix, - {$endif FPC} - {$endif MSWINDOWS} - SysUtils, - Classes, - {$ifndef LVCL} - SyncObjs, // for TEvent and TCriticalSection - Contnrs, // for TObjectList - {$endif} - {$ifndef NOVARIANTS} - Variants, - {$endif} - SynCommons; - - - -{ ************ text search and functions ****************** } - -type - PMatch = ^TMatch; - TMatchSearchFunction = function(aMatch: PMatch; aText: PUTF8Char; aTextLen: PtrInt): boolean; - - /// low-level structure used by IsMatch() for actual glob search - // - you can use this object to prepare a given pattern, e.g. in a loop - // - implemented as a fast brute-force state-machine without any heap allocation - // - some common patterns ('exactmatch', 'startwith*', '*endwith', '*contained*') - // are handled with dedicated code, optionally with case-insensitive search - // - consider using TMatchs (or SetMatchs/TMatchDynArray) if you expect to - // search for several patterns, or even TExprParserMatch for expression search - {$ifdef USERECORDWITHMETHODS}TMatch = record - {$else}TMatch = object{$endif} - private - Pattern, Text: PUTF8Char; - P, T, PMax, TMax: PtrInt; - Upper: PNormTable; - State: (sNONE, sABORT, sEND, sLITERAL, sPATTERN, sRANGE, sVALID); - procedure MatchAfterStar; - procedure MatchMain; - public - /// published for proper inlining - Search: TMatchSearchFunction; - /// initialize the internal fields for a given glob search pattern - // - note that the aPattern instance should remain in memory, since it will - // be pointed to by the Pattern private field of this object - procedure Prepare(const aPattern: RawUTF8; aCaseInsensitive, aReuse: boolean); overload; - /// initialize the internal fields for a given glob search pattern - // - note that the aPattern buffer should remain in memory, since it will - // be pointed to by the Pattern private field of this object - procedure Prepare(aPattern: PUTF8Char; aPatternLen: integer; - aCaseInsensitive, aReuse: boolean); overload; - /// initialize low-level internal fields for'*aPattern*' search - // - this method is faster than a regular Prepare('*' + aPattern + '*') - // - warning: the supplied aPattern variable may be modified in-place to be - // filled with some lookup buffer, for length(aPattern) in [2..31] range - procedure PrepareContains(var aPattern: RawUTF8; aCaseInsensitive: boolean); overload; - /// initialize low-level internal fields for a custom search algorithm - procedure PrepareRaw(aPattern: PUTF8Char; aPatternLen: integer; - aSearch: TMatchSearchFunction); - /// returns TRUE if the supplied content matches the prepared glob pattern - // - this method is not thread-safe - function Match(const aText: RawUTF8): boolean; overload; - {$ifdef FPC}inline;{$endif} - /// returns TRUE if the supplied content matches the prepared glob pattern - // - this method is not thread-safe - function Match(aText: PUTF8Char; aTextLen: PtrInt): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - /// returns TRUE if the supplied content matches the prepared glob pattern - // - this method IS thread-safe, and won't lock - function MatchThreadSafe(const aText: RawUTF8): boolean; - /// returns TRUE if the supplied VCL/LCL content matches the prepared glob pattern - // - this method IS thread-safe, will use stack to UTF-8 temporary conversion - // if possible, and won't lock - function MatchString(const aText: string): boolean; - /// returns TRUE if this search pattern matches another - function Equals(const aAnother{$ifndef DELPHI5OROLDER}: TMatch{$endif}): boolean; - {$ifdef HASINLINE}inline;{$endif} - /// access to the pattern length as stored in PMax + 1 - function PatternLength: integer; {$ifdef HASINLINE}inline;{$endif} - /// access to the pattern text as stored in Pattern - function PatternText: PUTF8Char; {$ifdef HASINLINE}inline;{$endif} - end; - /// use SetMatchs() to initialize such an array from a CSV pattern text - TMatchDynArray = array of TMatch; - - /// TMatch descendant owning a copy of the Pattern string to avoid GPF issues - TMatchStore = record - /// access to the research criteria - // - defined as a nested record (and not an object) to circumvent Delphi bug - Pattern: TMatch; - /// Pattern.Pattern PUTF8Char will point to this instance - PatternInstance: RawUTF8; - end; - TMatchStoreDynArray = array of TMatchStore; - - /// stores several TMatch instances, from a set of glob patterns - TMatchs = class(TSynPersistent) - protected - fMatch: TMatchStoreDynArray; - fMatchCount: integer; - public - /// add once some glob patterns to the internal TMach list - // - aPatterns[] follows the IsMatch() syntax - constructor Create(const aPatterns: TRawUTF8DynArray; CaseInsensitive: Boolean); reintroduce; overload; - /// add once some glob patterns to the internal TMach list - // - aPatterns[] follows the IsMatch() syntax - procedure Subscribe(const aPatterns: TRawUTF8DynArray; CaseInsensitive: Boolean); overload; virtual; - /// add once some glob patterns to the internal TMach list - // - each CSV item in aPatterns follows the IsMatch() syntax - procedure Subscribe(const aPatternsCSV: RawUTF8; CaseInsensitive: Boolean); overload; - /// search patterns in the supplied UTF-8 text - // - returns -1 if no filter has been subscribed - // - returns -2 if there is no match on any previous pattern subscription - // - returns fMatch[] index, i.e. >= 0 number on first matching pattern - // - this method is thread-safe - function Match(const aText: RawUTF8): integer; overload; {$ifdef HASINLINE}inline;{$endif} - /// search patterns in the supplied UTF-8 text buffer - function Match(aText: PUTF8Char; aLen: integer): integer; overload; - /// search patterns in the supplied VCL/LCL text - // - could be used on a TFileName for instance - // - will avoid any memory allocation if aText is small enough - function MatchString(const aText: string): integer; - end; - -/// fill the Match[] dynamic array with all glob patterns supplied as CSV -// - returns how many patterns have been set in Match[|] -// - note that the CSVPattern instance should remain in memory, since it will -// be pointed to by the Match[].Pattern private field -function SetMatchs(const CSVPattern: RawUTF8; CaseInsensitive: boolean; - out Match: TMatchDynArray): integer; overload; - -/// fill the Match[0..MatchMax] static array with all glob patterns supplied as CSV -// - note that the CSVPattern instance should remain in memory, since it will -// be pointed to by the Match[].Pattern private field -function SetMatchs(CSVPattern: PUTF8Char; CaseInsensitive: boolean; - Match: PMatch; MatchMax: integer): integer; overload; - -/// search if one TMach is already registered in the Several[] dynamic array -function MatchExists(const One: TMatch; const Several: TMatchDynArray): boolean; - -/// add one TMach if not already registered in the Several[] dynamic array -function MatchAdd(const One: TMatch; var Several: TMatchDynArray): boolean; - -/// returns TRUE if Match=nil or if any Match[].Match(Text) is TRUE -function MatchAny(const Match: TMatchDynArray; const Text: RawUTF8): boolean; - -/// apply the CSV-supplied glob patterns to an array of RawUTF8 -// - any text not maching the pattern will be deleted from the array -procedure FilterMatchs(const CSVPattern: RawUTF8; CaseInsensitive: boolean; - var Values: TRawUTF8DynArray); - -/// return TRUE if the supplied content matchs a glob pattern -// - ? Matches any single characer -// - * Matches any contiguous characters -// - [abc] Matches a or b or c at that position -// - [^abc] Matches anything but a or b or c at that position -// - [!abc] Matches anything but a or b or c at that position -// - [a-e] Matches a through e at that position -// - [abcx-z] Matches a or b or c or x or y or or z, as does [a-cx-z] -// - 'ma?ch.*' would match match.exe, mavch.dat, march.on, etc.. -// - 'this [e-n]s a [!zy]est' would match 'this is a test', but would not -// match 'this as a test' nor 'this is a zest' -// - consider using TMatch or TMatchs if you expect to reuse the pattern -function IsMatch(const Pattern, Text: RawUTF8; CaseInsensitive: boolean=false): boolean; - -/// return TRUE if the supplied content matchs a glob pattern, using VCL strings -// - is a wrapper around IsMatch() with fast UTF-8 conversion -function IsMatchString(const Pattern, Text: string; CaseInsensitive: boolean=false): boolean; - - -type - /// available pronunciations for our fast Soundex implementation - TSynSoundExPronunciation = - (sndxEnglish, sndxFrench, sndxSpanish, sndxNone); - - TSoundExValues = array[0..ord('Z')-ord('B')] of byte; - PSoundExValues = ^TSoundExValues; - - PSynSoundEx = ^TSynSoundEx; - /// fast search of a text value, using the Soundex approximation mechanism - // - Soundex is a phonetic algorithm for indexing names by sound, - // as pronounced in a given language. The goal is for homophones to be - // encoded to the same representation so that they can be matched despite - // minor differences in spelling - // - this implementation is very fast and can be used e.g. to parse and search - // in a huge text buffer - // - this version also handles french and spanish pronunciations on request, - // which differs from default Soundex, i.e. English - TSynSoundEx = object - protected - Search, FirstChar: cardinal; - fValues: PSoundExValues; - public - /// prepare for a Soundex search - // - you can specify another language pronunciation than default english - function Prepare(UpperValue: PAnsiChar; - Lang: TSynSoundExPronunciation=sndxEnglish): boolean; overload; - /// prepare for a custom Soundex search - // - you can specify any language pronunciation from raw TSoundExValues array - function Prepare(UpperValue: PAnsiChar; Lang: PSoundExValues): boolean; overload; - /// return true if prepared value is contained in a text buffer - // (UTF-8 encoded), by using the SoundEx comparison algorithm - // - search prepared value at every word beginning in U^ - function UTF8(U: PUTF8Char): boolean; - /// return true if prepared value is contained in a ANSI text buffer - // by using the SoundEx comparison algorithm - // - search prepared value at every word beginning in A^ - function Ansi(A: PAnsiChar): boolean; - end; - -/// Retrieve the Soundex value of a text word, from Ansi buffer -// - Return the soundex value as an easy to use cardinal value, 0 if the -// incoming string contains no valid word -// - if next is defined, its value is set to the end of the encoded word -// (so that you can call again this function to encode a full sentence) -function SoundExAnsi(A: PAnsiChar; next: PPAnsiChar=nil; - Lang: TSynSoundExPronunciation=sndxEnglish): cardinal; overload; - -/// Retrieve the Soundex value of a text word, from Ansi buffer -// - Return the soundex value as an easy to use cardinal value, 0 if the -// incoming string contains no valid word -// - if next is defined, its value is set to the end of the encoded word -// (so that you can call again this function to encode a full sentence) -function SoundExAnsi(A: PAnsiChar; next: PPAnsiChar; Lang: PSoundExValues): cardinal; overload; - -/// Retrieve the Soundex value of a text word, from UTF-8 buffer -// - Return the soundex value as an easy to use cardinal value, 0 if the -// incoming string contains no valid word -// - if next is defined, its value is set to the end of the encoded word -// (so that you can call again this function to encode a full sentence) -// - very fast: all UTF-8 decoding is handled on the fly -function SoundExUTF8(U: PUTF8Char; next: PPUTF8Char=nil; - Lang: TSynSoundExPronunciation=sndxEnglish): cardinal; - -const - /// number of bits to use for each interresting soundex char - // - default is to use 8 bits, i.e. 4 soundex chars, which is the - // standard approach - // - for a more detailled soundex, use 4 bits resolution, which will - // compute up to 7 soundex chars in a cardinal (that's our choice) - SOUNDEX_BITS = 4; - -var - DoIsValidUTF8: function(source: PUTF8Char): Boolean; - DoIsValidUTF8Len: function(source: PUTF8Char; sourcelen: PtrInt): Boolean; - -/// returns TRUE if the supplied buffer has valid UTF-8 encoding -// - will stop when the buffer contains #0 -// - on Haswell AVX2 Intel/AMD CPUs, will use very efficient ASM -function IsValidUTF8(source: PUTF8Char): Boolean; overload; {$ifdef HASINLINE}inline;{$endif} - -/// returns TRUE if the supplied buffer has valid UTF-8 encoding -// - will also refuse #0 characters within the buffer -// - on Haswell AVX2 Intel/AMD CPUs, will use very efficient ASM -function IsValidUTF8(source: PUTF8Char; sourcelen: PtrInt): Boolean; overload; {$ifdef HASINLINE}inline;{$endif} - -/// returns TRUE if the supplied buffer has valid UTF-8 encoding -// - will also refuse #0 characters within the buffer -// - on Haswell AVX2 Intel/AMD CPUs, will use very efficient ASM -function IsValidUTF8(const source: RawUTF8): Boolean; overload; - - - -{ ************ filtering and validation classes and functions ************** } - -/// convert an IPv4 'x.x.x.x' text into its 32-bit value -// - returns TRUE if the text was a valid IPv4 text, unserialized as 32-bit aValue -// - returns FALSE on parsing error, also setting aValue=0 -// - '' or '127.0.0.1' will also return false -function IPToCardinal(P: PUTF8Char; out aValue: cardinal): boolean; overload; - -/// convert an IPv4 'x.x.x.x' text into its 32-bit value -// - returns TRUE if the text was a valid IPv4 text, unserialized as 32-bit aValue -// - returns FALSE on parsing error, also setting aValue=0 -// - '' or '127.0.0.1' will also return false -function IPToCardinal(const aIP: RawUTF8; out aValue: cardinal): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert an IPv4 'x.x.x.x' text into its 32-bit value, 0 or localhost -// - returns <> 0 value if the text was a valid IPv4 text, 0 on parsing error -// - '' or '127.0.0.1' will also return 0 -function IPToCardinal(const aIP: RawUTF8): cardinal; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// return TRUE if the supplied content is a valid email address -// - follows RFC 822, to validate local-part@domain email format -function IsValidEmail(P: PUTF8Char): boolean; - -/// return TRUE if the supplied content is a valid IP v4 address -function IsValidIP4Address(P: PUTF8Char): boolean; - - -type - TSynFilterOrValidate = class; - - TSynFilterOrValidateObjArray = array of TSynFilterOrValidate; - TSynFilterOrValidateObjArrayArray = array of TSynFilterOrValidateObjArray; - - /// will define a filter (transformation) or a validation process to be - // applied to a database Record content (typicaly a TSQLRecord) - // - the optional associated parameters are to be supplied JSON-encoded - TSynFilterOrValidate = class - protected - fParameters: RawUTF8; - /// children must override this method in order to parse the JSON-encoded - // parameters, and store it in protected field values - procedure SetParameters(const Value: RawUTF8); virtual; - public - /// add the filter or validation process to a list, checking if not present - // - if an instance with the same class type and parameters is already - // registered, will call aInstance.Free and return the exising instance - // - if there is no similar instance, will add it to the list and return it - function AddOnce(var aObjArray: TSynFilterOrValidateObjArray; - aFreeIfAlreadyThere: boolean=true): TSynFilterOrValidate; - public - /// initialize the filter (transformation) or validation instance - // - most of the time, optional parameters may be specified as JSON, - // possibly with the extended MongoDB syntax - constructor Create(const aParameters: RawUTF8=''); overload; virtual; - /// initialize the filter or validation instance - /// - this overloaded constructor will allow to easily set the parameters - constructor CreateUTF8(const Format: RawUTF8; const Args, Params: array of const); overload; - /// the optional associated parameters, supplied as JSON-encoded - property Parameters: RawUTF8 read fParameters write SetParameters; - end; - - /// will define a validation to be applied to a Record (typicaly a TSQLRecord) - // field content - // - a typical usage is to validate an email or IP adress e.g. - // - the optional associated parameters are to be supplied JSON-encoded - TSynValidate = class(TSynFilterOrValidate) - public - /// perform the validation action to the specified value - // - the value is expected by be UTF-8 text, as generated by - // TPropInfo.GetValue e.g. - // - if the validation failed, must return FALSE and put some message in - // ErrorMsg (translated into the current language: you could e.g. use - // a resourcestring and a SysUtils.Format() call for automatic translation - // via the mORMoti18n unit - you can leave ErrorMsg='' to trigger a - // generic error message from clas name ('"Validate email" rule failed' - // for TSynValidateEmail class e.g.) - // - if the validation passed, will return TRUE - function Process(FieldIndex: integer; const Value: RawUTF8; var ErrorMsg: string): boolean; - virtual; abstract; - end; - - /// points to a TSynValidate variable - // - used e.g. as optional parameter to TSQLRecord.Validate/FilterAndValidate - PSynValidate = ^TSynValidate; - - /// IP v4 address validation to be applied to a Record field content - // (typicaly a TSQLRecord) - // - this versions expect no parameter - TSynValidateIPAddress = class(TSynValidate) - protected - public - /// perform the IP Address validation action to the specified value - function Process(aFieldIndex: integer; const Value: RawUTF8; - var ErrorMsg: string): boolean; override; - end; - - /// IP address validation to be applied to a Record field content - // (typicaly a TSQLRecord) - // - optional JSON encoded parameters are "AllowedTLD" or "ForbiddenTLD", - // expecting a CSV lis of Top-Level-Domain (TLD) names, e.g. - // $ '{"AllowedTLD":"com,org,net","ForbiddenTLD":"fr"}' - // $ '{AnyTLD:true,ForbiddenDomains:"mailinator.com,yopmail.com"}' - // - this will process a validation according to RFC 822 (calling the - // IsValidEmail() function) then will check for the TLD to be in one of - // the Top-Level domains ('.com' and such) or a two-char country, and - // then will check the TLD according to AllowedTLD and ForbiddenTLD - TSynValidateEmail = class(TSynValidate) - private - fAllowedTLD: RawUTF8; - fForbiddenTLD: RawUTF8; - fForbiddenDomains: RawUTF8; - fAnyTLD: boolean; - protected - /// decode all published properties from their JSON representation - procedure SetParameters(const Value: RawUTF8); override; - public - /// perform the Email Address validation action to the specified value - // - call IsValidEmail() function and check for the supplied TLD - function Process(aFieldIndex: integer; const Value: RawUTF8; var ErrorMsg: string): boolean; override; - /// allow any TLD to be allowed, even if not a generic TLD (.com,.net ...) - // - this may be mandatory since already over 1,300 new gTLD names or - // "strings" could become available in the next few years: there is a - // growing list of new gTLDs available at - // @http://newgtlds.icann.org/en/program-status/delegated-strings - // - the only restriction is that it should be ascii characters - property AnyTLD: boolean read fAnyTLD write fAnyTLD; - /// a CSV list of allowed TLD - // - if accessed directly, should be set as lower case values - // - e.g. 'com,org,net' - property AllowedTLD: RawUTF8 read fAllowedTLD write fAllowedTLD; - /// a CSV list of forbidden TLD - // - if accessed directly, should be set as lower case values - // - e.g. 'fr' - property ForbiddenTLD: RawUTF8 read fForbiddenTLD write fForbiddenTLD; - /// a CSV list of forbidden domain names - // - if accessed directly, should be set as lower case values - // - not only the TLD, but whole domains like 'cracks.ru,hotmail.com' or such - property ForbiddenDomains: RawUTF8 read fForbiddenDomains write fForbiddenDomains; - end; - - /// glob case-sensitive pattern validation of a Record field content - // - parameter is NOT JSON encoded, but is some basic TMatch glob pattern - // - ? Matches any single characer - // - * Matches any contiguous characters - // - [abc] Matches a or b or c at that position - // - [^abc] Matches anything but a or b or c at that position - // - [!abc] Matches anything but a or b or c at that position - // - [a-e] Matches a through e at that position - // - [abcx-z] Matches a or b or c or x or y or or z, as does [a-cx-z] - // - 'ma?ch.*' would match match.exe, mavch.dat, march.on, etc.. - // - 'this [e-n]s a [!zy]est' would match 'this is a test', but would not - // match 'this as a test' nor 'this is a zest' - // - pattern check IS case sensitive (TSynValidatePatternI is not) - // - this class is not as complete as PCRE regex for example, - // but code overhead is very small, and speed good enough in practice - TSynValidatePattern = class(TSynValidate) - protected - fMatch: TMatch; - procedure SetParameters(const Value: RawUTF8); override; - public - /// perform the pattern validation to the specified value - // - pattern can be e.g. '[0-9][0-9]:[0-9][0-9]:[0-9][0-9]' - // - this method will implement both TSynValidatePattern and - // TSynValidatePatternI, checking the current class - function Process(aFieldIndex: integer; const Value: RawUTF8; - var ErrorMsg: string): boolean; override; - end; - - /// glob case-insensitive pattern validation of a text field content - // (typicaly a TSQLRecord) - // - parameter is NOT JSON encoded, but is some basic TMatch glob pattern - // - same as TSynValidatePattern, but is NOT case sensitive - TSynValidatePatternI = class(TSynValidatePattern); - - /// text validation to ensure that to any text field would not be '' - TSynValidateNonVoidText = class(TSynValidate) - public - /// perform the non void text validation action to the specified value - function Process(aFieldIndex: integer; const Value: RawUTF8; - var ErrorMsg: string): boolean; override; - end; - - TSynValidateTextProps = array[0..15] of cardinal; - -{$M+} // to have existing RTTI for published properties - /// text validation to be applied to any Record field content - // - default MinLength value is 1, MaxLength is maxInt: so a blank - // TSynValidateText.Create('') is the same as TSynValidateNonVoidText - // - MinAlphaCount, MinDigitCount, MinPunctCount, MinLowerCount and - // MinUpperCount allow you to specify the minimal count of respectively - // alphabetical [a-zA-Z], digit [0-9], punctuation [_!;.,/:?%$="#@(){}+-*], - // lower case or upper case characters - // - expects optional JSON parameters of the allowed text length range as - // $ '{"MinLength":5,"MaxLength":10,"MinAlphaCount":1,"MinDigitCount":1, - // $ "MinPunctCount":1,"MinLowerCount":1,"MinUpperCount":1} - TSynValidateText = class(TSynValidate) - private - /// used to store all associated validation properties by index - fProps: TSynValidateTextProps; - fUTF8Length: boolean; - protected - /// use sInvalidTextChar resourcestring to create a translated error message - procedure SetErrorMsg(fPropsIndex, InvalidTextIndex, MainIndex: integer; - var result: string); - /// decode "MinLength", "MaxLength", and other parameters into fProps[] - procedure SetParameters(const Value: RawUTF8); override; - public - /// perform the text length validation action to the specified value - function Process(aFieldIndex: integer; const Value: RawUTF8; - var ErrorMsg: string): boolean; override; - published - /// Minimal length value allowed for the text content - // - the length is calculated with UTF-16 Unicode codepoints, unless - // UTF8Length has been set to TRUE so that the UTF-8 byte count is checked - // - default is 1, i.e. a void text will not pass the validation - property MinLength: cardinal read fProps[0] write fProps[0]; - /// Maximal length value allowed for the text content - // - the length is calculated with UTF-16 Unicode codepoints, unless - // UTF8Length has been set to TRUE so that the UTF-8 byte count is checked - // - default is maxInt, i.e. no maximum length is set - property MaxLength: cardinal read fProps[1] write fProps[1]; - /// Minimal alphabetical character [a-zA-Z] count - // - default is 0, i.e. no minimum set - property MinAlphaCount: cardinal read fProps[2] write fProps[2]; - /// Maximal alphabetical character [a-zA-Z] count - // - default is maxInt, i.e. no Maximum set - property MaxAlphaCount: cardinal read fProps[10] write fProps[10]; - /// Minimal digit character [0-9] count - // - default is 0, i.e. no minimum set - property MinDigitCount: cardinal read fProps[3] write fProps[3]; - /// Maximal digit character [0-9] count - // - default is maxInt, i.e. no Maximum set - property MaxDigitCount: cardinal read fProps[11] write fProps[11]; - /// Minimal punctuation sign [_!;.,/:?%$="#@(){}+-*] count - // - default is 0, i.e. no minimum set - property MinPunctCount: cardinal read fProps[4] write fProps[4]; - /// Maximal punctuation sign [_!;.,/:?%$="#@(){}+-*] count - // - default is maxInt, i.e. no Maximum set - property MaxPunctCount: cardinal read fProps[12] write fProps[12]; - /// Minimal alphabetical lower case character [a-z] count - // - default is 0, i.e. no minimum set - property MinLowerCount: cardinal read fProps[5] write fProps[5]; - /// Maximal alphabetical lower case character [a-z] count - // - default is maxInt, i.e. no Maximum set - property MaxLowerCount: cardinal read fProps[13] write fProps[13]; - /// Minimal alphabetical upper case character [A-Z] count - // - default is 0, i.e. no minimum set - property MinUpperCount: cardinal read fProps[6] write fProps[6]; - /// Maximal alphabetical upper case character [A-Z] count - // - default is maxInt, i.e. no Maximum set - property MaxUpperCount: cardinal read fProps[14] write fProps[14]; - /// Minimal space count inside the value text - // - default is 0, i.e. any space number allowed - property MinSpaceCount: cardinal read fProps[7] write fProps[7]; - /// Maximal space count inside the value text - // - default is maxInt, i.e. any space number allowed - property MaxSpaceCount: cardinal read fProps[15] write fProps[15]; - /// Maximal space count allowed on the Left side - // - default is maxInt, i.e. any Left space allowed - property MaxLeftTrimCount: cardinal read fProps[8] write fProps[8]; - /// Maximal space count allowed on the Right side - // - default is maxInt, i.e. any Right space allowed - property MaxRightTrimCount: cardinal read fProps[9] write fProps[9]; - /// defines if lengths parameters expects UTF-8 or UTF-16 codepoints number - // - with default FALSE, the length is calculated with UTF-16 Unicode - // codepoints - MaxLength may not match the UCS4 glyphs number, in case of - // UTF-16 surrogates - // - you can set this property to TRUE so that the UTF-8 byte count would - // be used for truncation againts the MaxLength parameter - property UTF8Length: boolean read fUTF8Length write fUTF8Length; - end; -{$M-} - - /// strong password validation for a Record field content (typicaly a TSQLRecord) - // - the following parameters are set by default to - // $ '{"MinLength":5,"MaxLength":20,"MinAlphaCount":1,"MinDigitCount":1, - // $ "MinPunctCount":1,"MinLowerCount":1,"MinUpperCount":1,"MaxSpaceCount":0}' - // - you can specify some JSON encoded parameters to change this default - // values, which will validate the text field only if it contains from 5 to 10 - // characters, with at least one digit, one upper case letter, one lower case - // letter, and one ponctuation sign, with no space allowed inside - TSynValidatePassWord = class(TSynValidateText) - protected - /// set password specific parameters - procedure SetParameters(const Value: RawUTF8); override; - end; - - { C++Builder doesn't support array elements as properties (RSP-12595). - For now, simply exclude the relevant classes from C++Builder. } - {$NODEFINE TSynValidateTextProps} - {$NODEFINE TSynValidateText } - {$NODEFINE TSynValidatePassWord } - - /// will define a transformation to be applied to a Record field content - // (typicaly a TSQLRecord) - // - here "filter" means that content would be transformed according to a - // set of defined rules - // - a typical usage is to convert to lower or upper case, or - // trim any time or date value in a TDateTime field - // - the optional associated parameters are to be supplied JSON-encoded - TSynFilter = class(TSynFilterOrValidate) - protected - public - /// perform the transformation to the specified value - // - the value is converted into UTF-8 text, as expected by - // TPropInfo.GetValue / TPropInfo.SetValue e.g. - procedure Process(aFieldIndex: integer; var Value: RawUTF8); virtual; abstract; - end; - - /// class-refrence type (metaclass) for a TSynFilter or a TSynValidate - TSynFilterOrValidateClass = class of TSynFilterOrValidate; - - /// class-reference type (metaclass) of a record filter (transformation) - TSynFilterClass = class of TSynFilter; - - /// convert the value into ASCII Upper Case characters - // - UpperCase conversion is made for ASCII-7 only, i.e. 'a'..'z' characters - // - this version expects no parameter - TSynFilterUpperCase = class(TSynFilter) - public - /// perform the case conversion to the specified value - procedure Process(aFieldIndex: integer; var Value: RawUTF8); override; - end; - - /// convert the value into WinAnsi Upper Case characters - // - UpperCase conversion is made for all latin characters in the WinAnsi - // code page only, e.g. 'e' acute will be converted to 'E' - // - this version expects no parameter - TSynFilterUpperCaseU = class(TSynFilter) - public - /// perform the case conversion to the specified value - procedure Process(aFieldIndex: integer; var Value: RawUTF8); override; - end; - - /// convert the value into ASCII Lower Case characters - // - LowerCase conversion is made for ASCII-7 only, i.e. 'A'..'Z' characters - // - this version expects no parameter - TSynFilterLowerCase = class(TSynFilter) - public - /// perform the case conversion to the specified value - procedure Process(aFieldIndex: integer; var Value: RawUTF8); override; - end; - - /// convert the value into WinAnsi Lower Case characters - // - LowerCase conversion is made for all latin characters in the WinAnsi - // code page only, e.g. 'E' acute will be converted to 'e' - // - this version expects no parameter - TSynFilterLowerCaseU = class(TSynFilter) - public - /// perform the case conversion to the specified value - procedure Process(aFieldIndex: integer; var Value: RawUTF8); override; - end; - - /// trim any space character left or right to the value - // - this versions expect no parameter - TSynFilterTrim = class(TSynFilter) - public - /// perform the space triming conversion to the specified value - procedure Process(aFieldIndex: integer; var Value: RawUTF8); override; - end; - - /// truncate a text above a given maximum length - // - expects optional JSON parameters of the allowed text length range as - // $ '{MaxLength":10} - TSynFilterTruncate = class(TSynFilter) - protected - fMaxLength: cardinal; - fUTF8Length: boolean; - /// decode the MaxLength: and UTF8Length: parameters - procedure SetParameters(const Value: RawUTF8); override; - public - /// perform the length truncation of the specified value - procedure Process(aFieldIndex: integer; var Value: RawUTF8); override; - /// Maximal length value allowed for the text content - // - the length is calculated with UTF-16 Unicode codepoints, unless - // UTF8Length has been set to TRUE so that the UTF-8 byte count is checked - // - default is 0, i.e. no maximum length is forced - property MaxLength: cardinal read fMaxLength write fMaxLength; - /// defines if MaxLength is stored as UTF-8 or UTF-16 codepoints number - // - with default FALSE, the length is calculated with UTF-16 Unicode - // codepoints - MaxLength may not match the UCS4 glyphs number, in case of - // UTF-16 surrogates - // - you can set this property to TRUE so that the UTF-8 byte count would - // be used for truncation againts the MaxLength parameter - property UTF8Length: boolean read fUTF8Length write fUTF8Length; - end; - -resourcestring - sInvalidIPAddress = '"%s" is an invalid IP v4 address'; - sInvalidEmailAddress = '"%s" is an invalid email address'; - sInvalidPattern = '"%s" does not match the expected pattern'; - sCharacter01n = 'character,character,characters'; - sInvalidTextLengthMin = 'Expect at least %d %s'; - sInvalidTextLengthMax = 'Expect up to %d %s'; - sInvalidTextChar = 'Expect at least %d %s %s,Expect up to %d %s %s,'+ - 'alphabetical,digital,punctuation,lowercase,uppercase,space,'+ - 'Too much spaces on the left,Too much spaces on the right'; - sValidationFailed = '"%s" rule failed'; - sValidationFieldVoid = 'An unique key field must not be void'; - sValidationFieldDuplicate = 'Value already used for this unique key field'; - - -{ ************ Database types and classes ************************** } - -type - /// handled field/parameter/column types for abstract database access - // - this will map JSON-compatible low-level database-level access types, not - // high-level Delphi types as TSQLFieldType defined in mORMot.pas - // - it does not map either all potential types as defined in DB.pas (which - // are there for compatibility with old RDBMS, and are not abstract enough) - // - those types can be mapped to standard SQLite3 generic types, i.e. - // NULL, INTEGER, REAL, TEXT, BLOB (with the addition of a ftCurrency and - // ftDate type, for better support of most DB engines) - // see @http://www.sqlite.org/datatype3.html - // - the only string type handled here uses UTF-8 encoding (implemented - // using our RawUTF8 type), for cross-Delphi true Unicode process - TSQLDBFieldType = - (ftUnknown, ftNull, ftInt64, ftDouble, ftCurrency, ftDate, ftUTF8, ftBlob); - - /// set of field/parameter/column types for abstract database access - TSQLDBFieldTypes = set of TSQLDBFieldType; - - /// array of field/parameter/column types for abstract database access - TSQLDBFieldTypeDynArray = array of TSQLDBFieldType; - - /// array of field/parameter/column types for abstract database access - // - this array as a fixed size, ready to handle up to MAX_SQLFIELDS items - TSQLDBFieldTypeArray = array[0..MAX_SQLFIELDS-1] of TSQLDBFieldType; - PSQLDBFieldTypeArray = ^TSQLDBFieldTypeArray; - - /// how TSQLVar may be processed - // - by default, ftDate will use seconds resolution unless svoDateWithMS is set - TSQLVarOption = (svoDateWithMS); - - /// defines how TSQLVar may be processed - TSQLVarOptions = set of TSQLVarOption; - - /// memory structure used for database values by reference storage - // - used mainly by SynDB, mORMot, mORMotDB and mORMotSQLite3 units - // - defines only TSQLDBFieldType data types (similar to those handled by - // SQLite3, with the addition of ftCurrency and ftDate) - // - cleaner/lighter dedicated type than TValue or variant/TVarData, strong - // enough to be marshalled as JSON content - // - variable-length data (e.g. UTF-8 text or binary BLOB) are never stored - // within this record, but VText/VBlob will point to an external (temporary) - // memory buffer - // - date/time is stored as ISO-8601 text (with milliseconds if svoDateWithMS - // option is set and the database supports it), and currency as double or BCD - // in most databases - TSQLVar = record - /// how this value should be processed - Options: TSQLVarOptions; - /// the type of the value stored - case VType: TSQLDBFieldType of - ftInt64: ( - VInt64: Int64); - ftDouble: ( - VDouble: double); - ftDate: ( - VDateTime: TDateTime); - ftCurrency: ( - VCurrency: Currency); - ftUTF8: ( - VText: PUTF8Char); - ftBlob: ( - VBlob: pointer; - VBlobLen: Integer) - end; - - /// dynamic array of database values by reference storage - TSQLVarDynArray = array of TSQLVar; - - /// used to store bit set for all available fields in a Table - // - with current MAX_SQLFIELDS value, 64 bits uses 8 bytes of memory - // - see also IsZero() and IsEqual() functions - // - you can also use ALL_FIELDS as defined in mORMot.pas - TSQLFieldBits = set of 0..MAX_SQLFIELDS-1; - - /// used to store a field index in a Table - // - note that -1 is commonly used for the ID/RowID field so the values should - // be signed - // - even if ShortInt (-128..127) may have been enough, we define a 16 bit - // safe unsigned integer to let the source compile with Delphi 5 - TSQLFieldIndex = SmallInt; // -32768..32767 - - /// used to store field indexes in a Table - // - same as TSQLFieldBits, but allowing to store the proper order - TSQLFieldIndexDynArray = array of TSQLFieldIndex; - - /// points to a bit set used for all available fields in a Table - PSQLFieldBits = ^TSQLFieldBits; - - /// generic parameter types, as recognized by SQLParamContent() and - // ExtractInlineParameters() functions - TSQLParamType = (sptUnknown, sptInteger, sptFloat, sptText, sptBlob, sptDateTime); - - /// array of parameter types, as recognized by SQLParamContent() and - // ExtractInlineParameters() functions - TSQLParamTypeDynArray = array of TSQLParamType; - - /// simple writer to a Stream, specialized for the JSON format and SQL export - // - i.e. define some property/method helpers to export SQL resultset as JSON - // - see mORMot.pas for proper class serialization via TJSONSerializer.WriteObject - TJSONWriter = class(TTextWriterWithEcho) - protected - /// used to store output format - fExpand: boolean; - /// used to store output format for TSQLRecord.GetJSONValues() - fWithID: boolean; - /// used to store field for TSQLRecord.GetJSONValues() - fFields: TSQLFieldIndexDynArray; - /// if not Expanded format, contains the Stream position of the first - // useful Row of data; i.e. ',val11' position in: - // & { "fieldCount":1,"values":["col1","col2",val11,"val12",val21,..] } - fStartDataPosition: integer; - public - /// used internally to store column names and count for AddColumns - ColNames: TRawUTF8DynArray; - /// the data will be written to the specified Stream - // - if no Stream is supplied, a temporary memory stream will be created - // (it's faster to supply one, e.g. any TSQLRest.TempMemoryStream) - constructor Create(aStream: TStream; Expand, withID: boolean; - const Fields: TSQLFieldBits; aBufSize: integer=8192); overload; - /// the data will be written to the specified Stream - // - if no Stream is supplied, a temporary memory stream will be created - // (it's faster to supply one, e.g. any TSQLRest.TempMemoryStream) - constructor Create(aStream: TStream; Expand, withID: boolean; - const Fields: TSQLFieldIndexDynArray=nil; aBufSize: integer=8192; - aStackBuffer: PTextWriterStackBuffer=nil); overload; - /// rewind the Stream position and write void JSON object - procedure CancelAllVoid; - /// write or init field names for appropriate JSON Expand later use - // - ColNames[] must have been initialized before calling this procedure - // - if aKnownRowsCount is not null, a "rowCount":... item will be added - // to the generated JSON stream (for faster unserialization of huge content) - procedure AddColumns(aKnownRowsCount: integer=0); - /// allow to change on the fly an expanded format column layout - // - by definition, a non expanded format will raise a ESynException - // - caller should then set ColNames[] and run AddColumns() - procedure ChangeExpandedFields(aWithID: boolean; const aFields: TSQLFieldIndexDynArray); overload; - /// end the serialized JSON object - // - cancel last ',' - // - close the JSON object ']' or ']}' - // - write non expanded postlog (,"rowcount":...), if needed - // - flush the internal buffer content if aFlushFinal=true - procedure EndJSONObject(aKnownRowsCount,aRowsCount: integer; aFlushFinal: boolean=true); - {$ifdef HASINLINE}inline;{$endif} - /// the first data row is erased from the content - // - only works if the associated storage stream is TMemoryStream - // - expect not Expanded format - procedure TrimFirstRow; - /// is set to TRUE in case of Expanded format - property Expand: boolean read fExpand write fExpand; - /// is set to TRUE if the ID field must be appended to the resulting JSON - // - this field is used only by TSQLRecord.GetJSONValues - // - this field is ignored by TSQLTable.GetJSONValues - property WithID: boolean read fWithID; - /// Read-Only access to the field bits set for each column to be stored - property Fields: TSQLFieldIndexDynArray read fFields; - /// if not Expanded format, contains the Stream position of the first - // useful Row of data; i.e. ',val11' position in: - // & { "fieldCount":1,"values":["col1","col2",val11,"val12",val21,..] } - property StartDataPosition: integer read fStartDataPosition; - end; - -/// returns TRUE if no bit inside this TSQLFieldBits is set -// - is optimized for 64, 128, 192 and 256 max bits count (i.e. MAX_SQLFIELDS) -// - will work also with any other value -function IsZero(const Fields: TSQLFieldBits): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// fast comparison of two TSQLFieldBits values -// - is optimized for 64, 128, 192 and 256 max bits count (i.e. MAX_SQLFIELDS) -// - will work also with any other value -function IsEqual(const A,B: TSQLFieldBits): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// fast initialize a TSQLFieldBits with 0 -// - is optimized for 64, 128, 192 and 256 max bits count (i.e. MAX_SQLFIELDS) -// - will work also with any other value -procedure FillZero(var Fields: TSQLFieldBits); overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert a TSQLFieldBits set of bits into an array of integers -procedure FieldBitsToIndex(const Fields: TSQLFieldBits; - var Index: TSQLFieldIndexDynArray; MaxLength: integer=MAX_SQLFIELDS; - IndexStart: integer=0); overload; - -/// convert a TSQLFieldBits set of bits into an array of integers -function FieldBitsToIndex(const Fields: TSQLFieldBits; - MaxLength: integer=MAX_SQLFIELDS): TSQLFieldIndexDynArray; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// add a field index to an array of field indexes -// - returns the index in Indexes[] of the newly appended Field value -function AddFieldIndex(var Indexes: TSQLFieldIndexDynArray; Field: integer): integer; - -/// convert an array of field indexes into a TSQLFieldBits set of bits -procedure FieldIndexToBits(const Index: TSQLFieldIndexDynArray; var Fields: TSQLFieldBits); overload; - -// search a field index in an array of field indexes -// - returns the index in Indexes[] of the given Field value, -1 if not found -function SearchFieldIndex(var Indexes: TSQLFieldIndexDynArray; Field: integer): integer; - -/// convert an array of field indexes into a TSQLFieldBits set of bits -function FieldIndexToBits(const Index: TSQLFieldIndexDynArray): TSQLFieldBits; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// returns the stored size of a TSQLVar database value -// - only returns VBlobLen / StrLen(VText) size, 0 otherwise -function SQLVarLength(const Value: TSQLVar): integer; - -{$ifndef NOVARIANTS} - -/// convert any Variant into a database value -// - ftBlob kind won't be handled by this function -// - complex variant types would be converted into ftUTF8 JSON object/array -procedure VariantToSQLVar(const Input: variant; var temp: RawByteString; - var Output: TSQLVar); - -/// guess the correct TSQLDBFieldType from a variant type -function VariantVTypeToSQLDBFieldType(VType: cardinal): TSQLDBFieldType; - -/// guess the correct TSQLDBFieldType from a variant value -function VariantTypeToSQLDBFieldType(const V: Variant): TSQLDBFieldType; - {$ifdef HASINLINE}inline;{$endif} - -/// guess the correct TSQLDBFieldType from the UTF-8 representation of a value -function TextToSQLDBFieldType(json: PUTF8Char): TSQLDBFieldType; - -type - /// define a variant published property as a nullable integer - // - either a varNull or a varInt64 value will be stored in the variant - // - either a NULL or an INTEGER value will be stored in the database - // - the property should be defined as such: - // ! property Int: TNullableInteger read fInt write fInt; - TNullableInteger = type variant; - /// define a variant published property as a nullable boolean - // - either a varNull or a varBoolean value will be stored in the variant - // - either a NULL or a 0/1 INTEGER value will be stored in the database - // - the property should be defined as such: - // ! property Bool: TNullableBoolean read fBool write fBool; - TNullableBoolean = type variant; - /// define a variant published property as a nullable floating point value - // - either a varNull or a varDouble value will be stored in the variant - // - either a NULL or a FLOAT value will be stored in the database - // - the property should be defined as such: - // ! property Flt: TNullableFloat read fFlt write fFlt; - TNullableFloat = type variant; - /// define a variant published property as a nullable decimal value - // - either a varNull or a varCurrency value will be stored in the variant - // - either a NULL or a FLOAT value will be stored in the database - // - the property should be defined as such: - // ! property Cur: TNullableCurrency read fCur write fCur; - TNullableCurrency = type variant; - /// define a variant published property as a nullable date/time value - // - either a varNull or a varDate value will be stored in the variant - // - either a NULL or a ISO-8601 TEXT value will be stored in the database - // - the property should be defined as such: - // ! property Dat: TNullableDateTime read fDat write fDat; - TNullableDateTime = type variant; - /// define a variant published property as a nullable timestamp value - // - either a varNull or a varInt64 value will be stored in the variant - // - either a NULL or a TTimeLog INTEGER value will be stored in the database - // - the property should be defined as such: - // ! property Tim: TNullableTimrency read fTim write fTim; - TNullableTimeLog = type variant; - /// define a variant published property as a nullable UTF-8 encoded text - // - either a varNull or varString (RawUTF8) will be stored in the variant - // - either a NULL or a TEXT value will be stored in the database - // - the property should be defined as such: - // ! property Txt: TNullableUTF8Text read fTxt write fTxt; - // or for a fixed-width VARCHAR (in external databases), here of 32 max chars: - // ! property Txt: TNullableUTF8Text index 32 read fTxt write fTxt; - // - warning: prior to Delphi 2009, since the variant will be stored as - // RawUTF8 internally, you should not use directly the field value as a - // VCL string=AnsiString like string(aField) but use VariantToString(aField) - TNullableUTF8Text = type variant; - -var - /// a nullable integer value containing null - NullableIntegerNull: TNullableInteger absolute NullVarData; - /// a nullable boolean value containing null - NullableBooleanNull: TNullableBoolean absolute NullVarData; - /// a nullable float value containing null - NullableFloatNull: TNullableFloat absolute NullVarData; - /// a nullable currency value containing null - NullableCurrencyNull: TNullableCurrency absolute NullVarData; - /// a nullable TDateTime value containing null - NullableDateTimeNull: TNullableDateTime absolute NullVarData; - /// a nullable TTimeLog value containing null - NullableTimeLogNull: TNullableTimeLog absolute NullVarData; - /// a nullable UTF-8 encoded text value containing null - NullableUTF8TextNull: TNullableUTF8Text absolute NullVarData; - -/// creates a nullable integer value from a supplied constant -// - FPC does not allow direct assignment to a TNullableInteger = type variant -// variable: use this function to circumvent it -function NullableInteger(const Value: Int64): TNullableInteger; - {$ifdef HASINLINE}inline;{$endif} - -/// same as VarIsEmpty(V) or VarIsEmpty(V), but faster -// - FPC VarIsNull() seems buggy with varByRef variants, and does not allow -// direct transtyping from a TNullableInteger = type variant variable: use this -// function to circumvent those limitations -function NullableIntegerIsEmptyOrNull(const V: TNullableInteger): Boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// check if a TNullableInteger is null, or return its value -// - returns FALSE if V is null or empty, or TRUE and set the Integer value -function NullableIntegerToValue(const V: TNullableInteger; out Value: Int64): Boolean; - overload; {$ifdef HASINLINE}inline;{$endif} - -/// check if a TNullableInteger is null, or return its value -// - returns 0 if V is null or empty, or the stored Integer value -function NullableIntegerToValue(const V: TNullableInteger): Int64; - overload; {$ifdef HASINLINE}inline;{$endif} - -/// creates a nullable Boolean value from a supplied constant -// - FPC does not allow direct assignment to a TNullableBoolean = type variant -// variable: use this function to circumvent it -function NullableBoolean(Value: boolean): TNullableBoolean; - {$ifdef HASINLINE}inline;{$endif} - -/// same as VarIsEmpty(V) or VarIsEmpty(V), but faster -// - FPC VarIsNull() seems buggy with varByRef variants, and does not allow -// direct transtyping from a TNullableBoolean = type variant variant: use this -// function to circumvent those limitations -function NullableBooleanIsEmptyOrNull(const V: TNullableBoolean): Boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// check if a TNullableBoolean is null, or return its value -// - returns FALSE if V is null or empty, or TRUE and set the Boolean value -function NullableBooleanToValue(const V: TNullableBoolean; out Value: Boolean): Boolean; - overload; {$ifdef HASINLINE}inline;{$endif} - -/// check if a TNullableBoolean is null, or return its value -// - returns false if V is null or empty, or the stored Boolean value -function NullableBooleanToValue(const V: TNullableBoolean): Boolean; - overload; {$ifdef HASINLINE}inline;{$endif} - -/// creates a nullable floating-point value from a supplied constant -// - FPC does not allow direct assignment to a TNullableFloat = type variant -// variable: use this function to circumvent it -function NullableFloat(const Value: double): TNullableFloat; - {$ifdef HASINLINE}inline;{$endif} - -/// same as VarIsEmpty(V) or VarIsEmpty(V), but faster -// - FPC VarIsNull() seems buggy with varByRef variants, and does not allow -// direct transtyping from a TNullableFloat = type variant variable: use this -// function to circumvent those limitations -function NullableFloatIsEmptyOrNull(const V: TNullableFloat): Boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// check if a TNullableFloat is null, or return its value -// - returns FALSE if V is null or empty, or TRUE and set the Float value -function NullableFloatToValue(const V: TNullableFloat; out Value: double): boolean; - overload; {$ifdef HASINLINE}inline;{$endif} - -/// check if a TNullableFloat is null, or return its value -// - returns 0 if V is null or empty, or the stored Float value -function NullableFloatToValue(const V: TNullableFloat): double; - overload; {$ifdef HASINLINE}inline;{$endif} - -/// creates a nullable Currency value from a supplied constant -// - FPC does not allow direct assignment to a TNullableCurrency = type variant -// variable: use this function to circumvent it -function NullableCurrency(const Value: currency): TNullableCurrency; - {$ifdef HASINLINE}inline;{$endif} - -/// same as VarIsEmpty(V) or VarIsEmpty(V), but faster -// - FPC VarIsNull() seems buggy with varByRef variants, and does not allow -// direct transtyping from a TNullableCurrency = type variant variable: use this -// function to circumvent those limitations -function NullableCurrencyIsEmptyOrNull(const V: TNullableCurrency): Boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// check if a TNullableCurrency is null, or return its value -// - returns FALSE if V is null or empty, or TRUE and set the Currency value -function NullableCurrencyToValue(const V: TNullableCurrency; out Value: currency): boolean; - overload; {$ifdef HASINLINE}inline;{$endif} - -/// check if a TNullableCurrency is null, or return its value -// - returns 0 if V is null or empty, or the stored Currency value -function NullableCurrencyToValue(const V: TNullableCurrency): currency; - overload; {$ifdef HASINLINE}inline;{$endif} - -/// creates a nullable TDateTime value from a supplied constant -// - FPC does not allow direct assignment to a TNullableDateTime = type variant -// variable: use this function to circumvent it -function NullableDateTime(const Value: TDateTime): TNullableDateTime; - {$ifdef HASINLINE}inline;{$endif} - -/// same as VarIsEmpty(V) or VarIsEmpty(V), but faster -// - FPC VarIsNull() seems buggy with varByRef variants, and does not allow -// direct transtyping from a TNullableDateTime = type variant variable: use this -// function to circumvent those limitations -function NullableDateTimeIsEmptyOrNull(const V: TNullableDateTime): Boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// check if a TNullableDateTime is null, or return its value -// - returns FALSE if V is null or empty, or TRUE and set the DateTime value -function NullableDateTimeToValue(const V: TNullableDateTime; out Value: TDateTime): boolean; - overload; {$ifdef HASINLINE}inline;{$endif} - -/// check if a TNullableDateTime is null, or return its value -// - returns 0 if V is null or empty, or the stored DateTime value -function NullableDateTimeToValue(const V: TNullableDateTime): TDateTime; - overload; {$ifdef HASINLINE}inline;{$endif} - -/// creates a nullable TTimeLog value from a supplied constant -// - FPC does not allow direct assignment to a TNullableTimeLog = type variant -// variable: use this function to circumvent it -function NullableTimeLog(const Value: TTimeLog): TNullableTimeLog; - {$ifdef HASINLINE}inline;{$endif} - -/// same as VarIsEmpty(V) or VarIsEmpty(V), but faster -// - FPC VarIsNull() seems buggy with varByRef variants, and does not allow -// direct transtyping from a TNullableTimeLog = type variant variable: use this -// function to circumvent those limitations -function NullableTimeLogIsEmptyOrNull(const V: TNullableTimeLog): Boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// check if a TNullableTimeLog is null, or return its value -// - returns FALSE if V is null or empty, or TRUE and set the TimeLog value -function NullableTimeLogToValue(const V: TNullableTimeLog; out Value: TTimeLog): boolean; - overload; {$ifdef HASINLINE}inline;{$endif} - -/// check if a TNullableTimeLog is null, or return its value -// - returns 0 if V is null or empty, or the stored TimeLog value -function NullableTimeLogToValue(const V: TNullableTimeLog): TTimeLog; - overload; {$ifdef HASINLINE}inline;{$endif} - -/// creates a nullable UTF-8 encoded text value from a supplied constant -// - FPC does not allow direct assignment to a TNullableUTF8 = type variant -// variable: use this function to circumvent it -function NullableUTF8Text(const Value: RawUTF8): TNullableUTF8Text; - {$ifdef HASINLINE}inline;{$endif} - -/// same as VarIsEmpty(V) or VarIsEmpty(V), but faster -// - FPC VarIsNull() seems buggy with varByRef variants, and does not allow -// direct transtyping from a TNullableUTF8Text = type variant variable: use this -// function to circumvent those limitations -function NullableUTF8TextIsEmptyOrNull(const V: TNullableUTF8Text): Boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// check if a TNullableUTF8Text is null, or return its value -// - returns FALSE if V is null or empty, or TRUE and set the UTF8Text value -function NullableUTF8TextToValue(const V: TNullableUTF8Text; out Value: RawUTF8): boolean; - overload; {$ifdef HASINLINE}inline;{$endif} - -/// check if a TNullableUTF8Text is null, or return its value -// - returns '' if V is null or empty, or the stored UTF8-encoded text value -function NullableUTF8TextToValue(const V: TNullableUTF8Text): RawUTF8; - overload; {$ifdef HASINLINE}inline;{$endif} - -{$endif NOVARIANTS} - - /// convert a date to a ISO-8601 string format for SQL '?' inlined parameters -// - will return the date encoded as '\uFFF1YYYY-MM-DD' - therefore -// ':("\uFFF12012-05-04"):' pattern will be recognized as a sftDateTime -// inline parameter in SQLParamContent() / ExtractInlineParameters() functions -// (JSON_SQLDATE_MAGIC will be used as prefix to create '\uFFF1...' pattern) -// - to be used e.g. as in: -// ! aRec.CreateAndFillPrepare(Client,'Datum=?',[DateToSQL(EncodeDate(2012,5,4))]); -function DateToSQL(Date: TDateTime): RawUTF8; overload; - -/// convert a date to a ISO-8601 string format for SQL '?' inlined parameters -// - will return the date encoded as '\uFFF1YYYY-MM-DD' - therefore -// ':("\uFFF12012-05-04"):' pattern will be recognized as a sftDateTime -// inline parameter in SQLParamContent() / ExtractInlineParameters() functions -// (JSON_SQLDATE_MAGIC will be used as prefix to create '\uFFF1...' pattern) -// - to be used e.g. as in: -// ! aRec.CreateAndFillPrepare(Client,'Datum=?',[DateToSQL(2012,5,4)]); -function DateToSQL(Year,Month,Day: cardinal): RawUTF8; overload; - -/// convert a date/time to a ISO-8601 string format for SQL '?' inlined parameters -// - if DT=0, returns '' -// - if DT contains only a date, returns the date encoded as '\uFFF1YYYY-MM-DD' -// - if DT contains only a time, returns the time encoded as '\uFFF1Thh:mm:ss' -// - otherwise, returns the ISO-8601 date and time encoded as '\uFFF1YYYY-MM-DDThh:mm:ss' -// (JSON_SQLDATE_MAGIC will be used as prefix to create '\uFFF1...' pattern) -// - if WithMS is TRUE, will append '.sss' for milliseconds resolution -// - to be used e.g. as in: -// ! aRec.CreateAndFillPrepare(Client,'Datum<=?',[DateTimeToSQL(Now)]); -// - see TimeLogToSQL() if you are using TTimeLog/TModTime/TCreateTime values -function DateTimeToSQL(DT: TDateTime; WithMS: boolean=false): RawUTF8; - -/// decode a SQL '?' inlined parameter (i.e. with JSON_SQLDATE_MAGIC prefix) -// - as generated by DateToSQL/DateTimeToSQL/TimeLogToSQL functions -function SQLToDateTime(const ParamValueWithMagic: RawUTF8): TDateTime; - -/// convert a TTimeLog value into a ISO-8601 string format for SQL '?' inlined -// parameters -// - handle TTimeLog bit-encoded Int64 format -// - follows the same pattern as DateToSQL or DateTimeToSQL functions, i.e. -// will return the date or time encoded as '\uFFF1YYYY-MM-DDThh:mm:ss' - -// therefore ':("\uFFF12012-05-04T20:12:13"):' pattern will be recognized as a -// sftDateTime inline parameter in SQLParamContent() / ExtractInlineParameters() -// (JSON_SQLDATE_MAGIC will be used as prefix to create '\uFFF1...' pattern) -// - to be used e.g. as in: -// ! aRec.CreateAndFillPrepare(Client,'Datum<=?',[TimeLogToSQL(TimeLogNow)]); -function TimeLogToSQL(const Timestamp: TTimeLog): RawUTF8; - -/// convert a Iso8601 encoded string into a ISO-8601 string format for SQL -// '?' inlined parameters -// - follows the same pattern as DateToSQL or DateTimeToSQL functions, i.e. -// will return the date or time encoded as '\uFFF1YYYY-MM-DDThh:mm:ss' - -// therefore ':("\uFFF12012-05-04T20:12:13"):' pattern will be recognized as a -// sftDateTime inline parameter in SQLParamContent() / ExtractInlineParameters() -// (JSON_SQLDATE_MAGIC will be used as prefix to create '\uFFF1...' pattern) -// - in practice, just append the JSON_SQLDATE_MAGIC prefix to the supplied text -function Iso8601ToSQL(const S: RawByteString): RawUTF8; - - -/// guess the content type of an UTF-8 SQL value, in :(....): format -// - will be used e.g. by ExtractInlineParameters() to un-inline a SQL statement -// - sftInteger is returned for an INTEGER value, e.g. :(1234): -// - sftFloat is returned for any floating point value (i.e. some digits -// separated by a '.' character), e.g. :(12.34): or :(12E-34): -// - sftUTF8Text is returned for :("text"): or :('text'):, with double quoting -// inside the value -// - sftBlob will be recognized from the ':("\uFFF0base64encodedbinary"):' -// pattern, and return raw binary (for direct blob parameter assignment) -// - sftDateTime will be recognized from ':(\uFFF1"2012-05-04"):' pattern, -// i.e. JSON_SQLDATE_MAGIC-prefixed string as returned by DateToSQL() or -// DateTimeToSQL() functions -// - sftUnknown is returned on invalid content, or if wasNull is set to TRUE -// - if ParamValue is not nil, the pointing RawUTF8 string is set with the -// value inside :(...): without double quoting in case of sftUTF8Text -// - wasNull is set to TRUE if P was ':(null):' and ParamType is sftUnknwown -function SQLParamContent(P: PUTF8Char; out ParamType: TSQLParamType; out ParamValue: RawUTF8; - out wasNull: boolean): PUTF8Char; - -/// this function will extract inlined :(1234): parameters into Types[]/Values[] -// - will return the generic SQL statement with ? place holders for inlined -// parameters and setting Values with SQLParamContent() decoded content -// - will set maxParam=0 in case of no inlined parameters -// - recognized types are sptInteger, sptFloat, sptDateTime ('\uFFF1...'), -// sptUTF8Text and sptBlob ('\uFFF0...') -// - sptUnknown is returned on invalid content -function ExtractInlineParameters(const SQL: RawUTF8; - var Types: TSQLParamTypeDynArray; var Values: TRawUTF8DynArray; - var maxParam: integer; var Nulls: TSQLFieldBits): RawUTF8; - -/// returns a 64-bit value as inlined ':(1234):' text -function InlineParameter(ID: Int64): shortstring; overload; - -/// returns a string value as inlined ':("value"):' text -function InlineParameter(const value: RawUTF8): RawUTF8; overload; - -type - /// SQL Query comparison operators - // - used e.g. by CompareOperator() functions in SynTable.pas or vt_BestIndex() - // in mORMotSQLite3.pas - TCompareOperator = ( - soEqualTo, - soNotEqualTo, - soLessThan, - soLessThanOrEqualTo, - soGreaterThan, - soGreaterThanOrEqualTo, - soBeginWith, - soContains, - soSoundsLikeEnglish, - soSoundsLikeFrench, - soSoundsLikeSpanish); - -const - /// convert identified field types into high-level ORM types - // - as will be implemented in unit mORMot.pas - SQLDBFIELDTYPE_TO_DELPHITYPE: array[TSQLDBFieldType] of RawUTF8 = ( - '???','???', 'Int64', 'Double', 'Currency', 'TDateTime', 'RawUTF8', 'TSQLRawBlob'); - - -{ ************ low-level buffer processing functions ************************* } - -type - /// safe decoding of a TFileBufferWriter content - // - similar to TFileBufferReader, but faster and only for in-memory buffer - // - is also safer, since will check for reaching end of buffer - // - raise a EFastReader exception on decoding error (e.g. if a buffer - // overflow may occur) or call OnErrorOverflow/OnErrorData event handlers - {$ifdef USERECORDWITHMETHODS}TFastReader = record - {$else}TFastReader = object{$endif} - public - /// the current position in the memory - P: PAnsiChar; - /// the last position in the buffer - Last: PAnsiChar; - /// use this event to customize the ErrorOverflow process - OnErrorOverflow: procedure of object; - /// use this event to customize the ErrorData process - OnErrorData: procedure(const fmt: RawUTF8; const args: array of const) of object; - /// some opaque value, which may be a version number to define the binary layout - Tag: PtrInt; - /// initialize the reader from a memory block - procedure Init(Buffer: pointer; Len: integer); overload; - /// initialize the reader from a RawByteString content - procedure Init(const Buffer: RawByteString); overload; - /// raise a EFastReader with an "overflow" error message - procedure ErrorOverflow; - /// raise a EFastReader with an "incorrect data" error message - procedure ErrorData(const fmt: RawUTF8; const args: array of const); - /// read the next 32-bit signed value from the buffer - function VarInt32: integer; {$ifdef HASINLINE}inline;{$endif} - /// read the next 32-bit unsigned value from the buffer - function VarUInt32: cardinal; - /// try to read the next 32-bit signed value from the buffer - // - don't change the current position - function PeekVarInt32(out value: PtrInt): boolean; {$ifdef HASINLINE}inline;{$endif} - /// try to read the next 32-bit unsigned value from the buffer - // - don't change the current position - function PeekVarUInt32(out value: PtrUInt): boolean; - /// read the next 32-bit unsigned value from the buffer - // - this version won't call ErrorOverflow, but return false on error - // - returns true on read success - function VarUInt32Safe(out Value: cardinal): boolean; - /// read the next 64-bit signed value from the buffer - function VarInt64: Int64; {$ifdef HASINLINE}inline;{$endif} - /// read the next 64-bit unsigned value from the buffer - function VarUInt64: QWord; - /// read the next RawUTF8 value from the buffer - function VarUTF8: RawUTF8; overload; - /// read the next RawUTF8 value from the buffer - procedure VarUTF8(out result: RawUTF8); overload; - /// read the next RawUTF8 value from the buffer - // - this version won't call ErrorOverflow, but return false on error - // - returns true on read success - function VarUTF8Safe(out Value: RawUTF8): boolean; - /// read the next RawByteString value from the buffer - function VarString: RawByteString; {$ifdef HASINLINE}inline;{$endif} - /// read the next pointer and length value from the buffer - procedure VarBlob(out result: TValueResult); overload; {$ifdef HASINLINE}inline;{$endif} - /// read the next pointer and length value from the buffer - function VarBlob: TValueResult; overload; {$ifdef HASINLINE}inline;{$endif} - /// read the next ShortString value from the buffer - function VarShortString: shortstring; {$ifdef HASINLINE}inline;{$endif} - /// fast ignore the next VarUInt32/VarInt32/VarUInt64/VarInt64 value - // - don't raise any exception, so caller could check explicitly for any EOF - procedure VarNextInt; overload; {$ifdef HASINLINE}inline;{$endif} - /// fast ignore the next count VarUInt32/VarInt32/VarUInt64/VarInt64 values - // - don't raise any exception, so caller could check explicitly for any EOF - procedure VarNextInt(count: integer); overload; - /// read the next byte from the buffer - function NextByte: byte; {$ifdef HASINLINE}inline;{$endif} - /// read the next byte from the buffer, checking - function NextByteSafe(dest: pointer): boolean; {$ifdef HASINLINE}inline;{$endif} - /// read the next 4 bytes from the buffer as a 32-bit unsigned value - function Next4: cardinal; {$ifdef HASINLINE}inline;{$endif} - /// read the next 8 bytes from the buffer as a 64-bit unsigned value - function Next8: Qword; {$ifdef HASINLINE}inline;{$endif} - /// consumes the next byte from the buffer, if matches a given value - function NextByteEquals(Value: byte): boolean; {$ifdef HASINLINE}inline;{$endif} - /// returns the current position, and move ahead the specified bytes - function Next(DataLen: PtrInt): pointer; {$ifdef HASINLINE}inline;{$endif} - /// returns the current position, and move ahead the specified bytes - function NextSafe(out Data: Pointer; DataLen: PtrInt): boolean; {$ifdef HASINLINE}inline;{$endif} - {$ifndef NOVARIANTS} - /// read the next variant from the buffer - // - is a wrapper around VariantLoad() - procedure NextVariant(var Value: variant; CustomVariantOptions: PDocVariantOptions); - /// read the JSON-serialized TDocVariant from the buffer - // - matches TFileBufferWriter.WriteDocVariantData format - procedure NextDocVariantData(out Value: variant; CustomVariantOptions: PDocVariantOptions); - {$endif NOVARIANTS} - /// copy data from the current position, and move ahead the specified bytes - procedure Copy(out Dest; DataLen: PtrInt); {$ifdef HASINLINE}inline;{$endif} - /// copy data from the current position, and move ahead the specified bytes - // - this version won't call ErrorOverflow, but return false on error - // - returns true on read success - function CopySafe(out Dest; DataLen: PtrInt): boolean; - /// apply TDynArray.LoadFrom on the buffer - // - will unserialize a previously appended dynamic array, e.g. as - // ! aWriter.WriteDynArray(DA); - procedure Read(var DA: TDynArray; NoCheckHash: boolean=false); - /// retrieved cardinal values encoded with TFileBufferWriter.WriteVarUInt32Array - // - only supports wkUInt32, wkVarInt32, wkVarUInt32 kind of encoding - function ReadVarUInt32Array(var Values: TIntegerDynArray): PtrInt; - /// retrieve some TAlgoCompress buffer, appended via Write() - // - BufferOffset could be set to reserve some bytes before the uncompressed buffer - function ReadCompressed(Load: TAlgoCompressLoad=aclNormal; BufferOffset: integer=0): RawByteString; - /// returns TRUE if the current position is the end of the input stream - function EOF: boolean; {$ifdef HASINLINE}inline;{$endif} - /// returns remaining length (difference between Last and P) - function RemainingLength: PtrUInt; {$ifdef HASINLINE}inline;{$endif} - end; - - /// implements a stack-based writable storage of binary content - // - memory allocation is performed via a TSynTempBuffer - TSynTempWriter = object - public - /// the current writable position in tmp.buf - pos: PAnsiChar; - /// initialize a new temporary buffer of a given number of bytes - // - if maxsize is left to its 0 default value, the default stack-allocated - // memory size is used, i.e. 4 KB - procedure Init(maxsize: integer=0); - /// finalize the temporary storage - procedure Done; - /// append some binary to the internal buffer - // - will raise an ESynException in case of potential overflow - procedure wr(const val; len: PtrInt); - /// append some shortstring as binary to the internal buffer - procedure wrss(const str: shortstring); {$ifdef HASINLINE}inline;{$endif} - /// append some string as binary to the internal buffer - procedure wrs(const str: RawByteString); {$ifdef HASINLINE}inline;{$endif} - /// append some 8-bit value as binary to the internal buffer - procedure wrb(b: byte); {$ifdef HASINLINE}inline;{$endif} - /// append some 16-bit value as binary to the internal buffer - procedure wrw(w: word); {$ifdef HASINLINE}inline;{$endif} - /// append some 32-bit value as binary to the internal buffer - procedure wrint(int: integer); {$ifdef HASINLINE}inline;{$endif} - /// append some 32-bit/64-bit pointer value as binary to the internal buffer - procedure wrptr(ptr: pointer); {$ifdef HASINLINE}inline;{$endif} - /// append some 32-bit/64-bit integer as binary to the internal buffer - procedure wrptrint(int: PtrInt); {$ifdef HASINLINE}inline;{$endif} - /// append some fixed-value bytes as binary to the internal buffer - // - returns a pointer to the first byte of the added memory chunk - function wrfillchar(count: integer; value: byte): PAnsiChar; - /// returns the current offset position in the internal buffer - function Position: PtrInt; {$ifdef HASINLINE}inline;{$endif} - /// returns the buffer as a RawByteString instance - function AsBinary: RawByteString; - /// returns the buffer as a RawUTF8 instance - procedure AsUTF8(var result: RawUTF8); - protected - tmp: TSynTempBuffer; - end; - - /// available kind of integer array storage, corresponding to the data layout - // - wkUInt32 will write the content as "plain" 4 bytes binary (this is the - // prefered way if the integers can be negative) - // - wkVarUInt32 will write the content using our 32-bit variable-length integer - // encoding - // - wkVarInt32 will write the content using our 32-bit variable-length integer - // encoding and the by-two complement (0=0,1=1,2=-1,3=2,4=-2...) - // - wkSorted will write an increasing array of integers, handling the special - // case of a difference of similar value (e.g. 1) between two values - note - // that this encoding is efficient only if the difference is main < 253 - // - wkOffsetU and wkOffsetI will write the difference between two successive - // values, handling constant difference (Unsigned or Integer) in an optimized manner - // - wkFakeMarker won't be used by WriteVarUInt32Array, but to notify a - // custom encoding - TFileBufferWriterKind = (wkUInt32, wkVarUInt32, wkVarInt32, wkSorted, - wkOffsetU, wkOffsetI, wkFakeMarker); - - /// this class can be used to speed up writing to a file - // - big speed up if data is written in small blocks - // - also handle optimized storage of any dynamic array of Integer/Int64/RawUTF8 - // - use TFileBufferReader or TFastReader for decoding of the stored binary - TFileBufferWriter = class - private - fPos: PtrInt; - fBufLen: PtrInt; - fStream: TStream; - fTotalWritten: Int64; - fInternalStream: boolean; - fTag: PtrInt; - fBuffer: PByteArray; - fBufInternal: RawByteString; - procedure InternalFlush; - public - /// initialize the buffer, and specify a file handle to use for writing - // - use an internal buffer of the specified size - constructor Create(aFile: THandle; BufLen: integer=65536); overload; - /// initialize the buffer, and specify a TStream to use for writing - // - use an internal buffer of the specified size - constructor Create(aStream: TStream; BufLen: integer=65536); overload; - /// initialize the buffer, and specify a file to use for writing - // - use an internal buffer of the specified size - // - would replace any existing file by default, unless Append is TRUE - constructor Create(const aFileName: TFileName; BufLen: integer=65536; - Append: boolean=false); overload; - /// initialize the buffer, using an internal TStream instance - // - parameter could be e.g. THeapMemoryStream or TRawByteStringStream - // - use Flush then TMemoryStream(Stream) to retrieve its content, or - // TRawByteStringStream(Stream).DataString - constructor Create(aClass: TStreamClass; BufLen: integer=4096); overload; - /// initialize with a specified buffer and TStream class - // - use a specified external buffer (which may be allocated on stack), - // to avoid a memory allocation - constructor Create(aStream: TStream; aTempBuf: pointer; aTempLen: integer); overload; - /// initialize with a specified buffer - // - use a specified external buffer (which may be allocated on stack), - // to avoid a memory allocation - // - aStream parameter could be e.g. THeapMemoryStream or TRawByteStringStream - constructor Create(aClass: TStreamClass; aTempBuf: pointer; aTempLen: integer); overload; - /// release internal TStream (after AssignToHandle call) - // - warning: an explicit call to Flush is needed to write the data pending - // in internal buffer - destructor Destroy; override; - /// append some data at the current position - procedure Write(Data: pointer; DataLen: PtrInt); overload; - /// append 1 byte of data at the current position - procedure Write1(Data: Byte); {$ifdef HASINLINE}inline;{$endif} - /// append 2 bytes of data at the current position - procedure Write2(Data: Word); {$ifdef HASINLINE}inline;{$endif} - /// append 4 bytes of data at the current position - procedure Write4(Data: integer); {$ifdef HASINLINE}inline;{$endif} - /// append 4 bytes of data, encoded as BigEndian, at the current position - procedure Write4BigEndian(Data: integer); {$ifdef HASINLINE}inline;{$endif} - /// append 8 bytes of data at the current position - procedure Write8(const Data8Bytes); {$ifdef HASINLINE}inline;{$endif} - /// append the same byte a given number of occurences at the current position - procedure WriteN(Data: Byte; Count: integer); - /// append some UTF-8 encoded text at the current position - // - will write the string length (as VarUInt32), then the string content, as expected - // by the FromVarString() function - procedure Write(const Text: RawByteString); overload; {$ifdef HASINLINE}inline;{$endif} - /// append some UTF-8 encoded text at the current position - // - will write the string length (as VarUInt32), then the string content - procedure WriteShort(const Text: ShortString); - /// append some content at the current position - // - will write the binary data, without any length prefix - procedure WriteBinary(const Data: RawByteString); - {$ifndef NOVARIANTS} - /// append some variant value at the current position - // - matches FromVarVariant() and VariantSave/VariantLoad format - procedure Write(const Value: variant); overload; - /// append some TDocVariant value at the current position, as JSON string - // - matches TFastReader.NextDocVariantData format - procedure WriteDocVariantData(const Value: variant); - {$endif} - /// append some record at the current position, with binary serialization - // - will use the binary serialization as for: - // ! aWriter.WriteBinary(RecordSave(Rec,RecTypeInfo)); - // but writing directly into the buffer, if possible - procedure WriteRecord(const Rec; RecTypeInfo: pointer); - /// append some dynamic array at the current position - // - will use the binary serialization as for: - // ! aWriter.WriteBinary(DA.SaveTo); - // but writing directly into the buffer, if possible - procedure WriteDynArray(const DA: TDynArray); - /// append "New[0..Len-1] xor Old[0..Len-1]" bytes - // - as used e.g. by ZeroCompressXor/TSynBloomFilterDiff.SaveTo - procedure WriteXor(New,Old: PAnsiChar; Len: PtrInt; crc: PCardinal=nil); - /// append a cardinal value using 32-bit variable-length integer encoding - procedure WriteVarUInt32(Value: PtrUInt); - /// append an integer value using 32-bit variable-length integer encoding of - // the by-two complement of the given value - procedure WriteVarInt32(Value: PtrInt); - /// append an integer value using 64-bit variable-length integer encoding of - // the by-two complement of the given value - procedure WriteVarInt64(Value: Int64); - /// append an unsigned integer value using 64-bit variable-length encoding - procedure WriteVarUInt64(Value: QWord); - /// append cardinal values (NONE must be negative!) using 32-bit - // variable-length integer encoding or other specialized algorithm, - // depending on the data layout - procedure WriteVarUInt32Array(const Values: TIntegerDynArray; ValuesCount: integer; - DataLayout: TFileBufferWriterKind); - /// append cardinal values (NONE must be negative!) using 32-bit - // variable-length integer encoding or other specialized algorithm, - // depending on the data layout - procedure WriteVarUInt32Values(Values: PIntegerArray; ValuesCount: integer; - DataLayout: TFileBufferWriterKind); - /// append UInt64 values using 64-bit variable length integer encoding - // - if Offset is TRUE, then it will store the difference between - // two values using 64-bit variable-length integer encoding (in this case, - // a fixed-sized record storage is also handled separately) - // - could be decoded later on via TFileBufferReader.ReadVarUInt64Array - procedure WriteVarUInt64DynArray(const Values: TInt64DynArray; - ValuesCount: integer; Offset: Boolean); - /// append the RawUTF8 dynamic array - // - handled the fixed size strings array case in a very efficient way - procedure WriteRawUTF8DynArray(const Values: TRawUTF8DynArray; ValuesCount: integer); - /// append a RawUTF8 array of values, from its low-level memory pointer - // - handled the fixed size strings array case in a very efficient way - procedure WriteRawUTF8Array(Values: PPtrUIntArray; ValuesCount: integer); - /// append the RawUTF8List content - // - if StoreObjectsAsVarUInt32 is TRUE, all Objects[] properties will be - // stored as VarUInt32 - procedure WriteRawUTF8List(List: TRawUTF8List; StoreObjectsAsVarUInt32: Boolean=false); - /// append a TStream content - // - is StreamSize is left as -1, the Stream.Size is used - // - the size of the content is stored in the resulting stream - procedure WriteStream(aStream: TCustomMemoryStream; aStreamSize: Integer=-1); - /// allows to write directly to a memory buffer - // - caller should specify the maximum possible number of bytes to be written - // - then write the data to the returned pointer, and call DirectWriteFlush - function DirectWritePrepare(len: PtrInt; out tmp: RawByteString): PAnsiChar; - /// finalize a direct write to a memory buffer - // - by specifying the number of bytes written to the buffer - procedure DirectWriteFlush(len: PtrInt; const tmp: RawByteString); - /// write any pending data in the internal buffer to the file - // - after a Flush, it's possible to call FileSeek64(aFile,....) - // - returns the number of bytes written between two FLush method calls - function Flush: Int64; - /// write any pending data, then call algo.Compress() on the buffer - // - expect the instance to have been created via - // ! TFileBufferWriter.Create(TRawByteStringStream) - // - if algo is left to its default nil, will use global AlgoSynLZ - // - features direct compression from internal buffer, if stream was not used - // - BufferOffset could be set to reserve some bytes before the compressed buffer - function FlushAndCompress(nocompression: boolean=false; algo: TAlgoCompress=nil; - BufferOffset: integer=0): RawByteString; - /// rewind the Stream to the position when Create() was called - // - note that this does not clear the Stream content itself, just - // move back its writing position to its initial place - procedure CancelAll; virtual; - /// the associated writing stream - property Stream: TStream read fStream; - /// get the byte count written since last Flush - property TotalWritten: Int64 read fTotalWritten; - /// simple property used to store some integer content - property Tag: PtrInt read fTag write fTag; - end; - - PFileBufferReader = ^TFileBufferReader; - - /// this structure can be used to speed up reading from a file - // - use internaly memory mapped files for a file up to 2 GB (Windows has - // problems with memory mapped files bigger than this size limit - at least - // with 32-bit executables) - but sometimes, Windows fails to allocate - // more than 512 MB for a memory map, because it does lack of contiguous - // memory space: in this case, we fall back on direct file reading - // - maximum handled file size has no limit (but will use slower direct - // file reading) - // - can handle sophisticated storage layout of TFileBufferWriter for - // dynamic arrays of Integer/Int64/RawUTF8 - // - is defined as an object or as a record, due to a bug - // in Delphi 2009/2010 compiler (at least): this structure is not initialized - // if defined as an object on the stack, but will be as a record :( - TFileBufferReader = object - protected - fCurrentPos: PtrUInt; - fMap: TMemoryMap; - /// get Isize + buffer from current memory map or fBufTemp into (P,PEnd) - procedure ReadChunk(out P, PEnd: PByte; var BufTemp: RawByteString); - public - /// initialize the buffer, and specify a file to use for reading - // - will try to map the whole file content in memory - // - if memory mapping failed, or aFileNotMapped is true, methods - // will use default slower file API - procedure Open(aFile: THandle; aFileNotMapped: boolean=false); - /// initialize the buffer from an already existing memory block - // - may be e.g. a resource or a TMemoryStream - procedure OpenFrom(aBuffer: pointer; aBufferSize: PtrUInt); overload; - /// initialize the buffer from an already existing memory block - procedure OpenFrom(const aBuffer: RawByteString); overload; - /// initialize the buffer from an already existing Stream - // - accept either TFileStream or TCustomMemoryStream kind of stream - function OpenFrom(Stream: TStream): boolean; overload; - /// close all internal mapped files - // - call Open() again to use the Read() methods - procedure Close; - {$ifndef CPU64} - /// change the current reading position, from the beginning of the file - // - returns TRUE if success, or FALSE if Offset is out of range - function Seek(Offset: Int64): boolean; overload; - {$endif} - /// change the current reading position, from the beginning of the file - // - returns TRUE if success, or FALSE if Offset is out of range - function Seek(Offset: PtrInt): boolean; overload; - /// raise an exception in case of invalid content - procedure ErrorInvalidContent; - /// read some bytes from the given reading position - // - returns the number of bytes which was read - // - if Data is nil, it won't read content but will forward reading position - function Read(Data: pointer; DataLen: PtrInt): integer; overload; - /// read some UTF-8 encoded text at the current position - // - returns the resulting text length, in bytes - function Read(out Text: RawUTF8): integer; overload; - /// read some buffer texgt at the current position - // - returns the resulting text length, in bytes - function Read(out Text: RawByteString): integer; overload; - /// read some UTF-8 encoded text at the current position - // - returns the resulting text - function ReadRawUTF8: RawUTF8; {$ifdef HASINLINE}inline;{$endif} - /// read one byte - // - if reached end of file, don't raise any error, but returns 0 - function ReadByte: PtrUInt; {$ifdef HASINLINE}inline;{$endif} - /// read one cardinal, which was written as fixed length - // - if reached end of file, don't raise any error, but returns 0 - function ReadCardinal: cardinal; - /// read one cardinal value encoded using our 32-bit variable-length integer - function ReadVarUInt32: PtrUInt; - /// read one integer value encoded using our 32-bit variable-length integer, - // and the by-two complement - function ReadVarInt32: PtrInt; - /// read one UInt64 value encoded using our 64-bit variable-length integer - function ReadVarUInt64: QWord; - /// read one Int64 value encoded using our 64-bit variable-length integer - function ReadVarInt64: Int64; - /// retrieved cardinal values encoded with TFileBufferWriter.WriteVarUInt32Array - // - returns the number of items read into Values[] (may differ from - // length(Values), which will be resized, so could be void before calling) - // - if the returned integer is negative, it is -Count, and testifies from - // wkFakeMarker and the content should be retrieved by the caller - function ReadVarUInt32Array(var Values: TIntegerDynArray): PtrInt; - /// retrieved Int64 values encoded with TFileBufferWriter.WriteVarUInt64DynArray - // - returns the number of items read into Values[] (may differ from length(Values)) - function ReadVarUInt64Array(var Values: TInt64DynArray): PtrInt; - /// retrieved RawUTF8 values encoded with TFileBufferWriter.WriteRawUTF8DynArray - // - returns the number of items read into Values[] (may differ from length(Values)) - function ReadVarRawUTF8DynArray(var Values: TRawUTF8DynArray): PtrInt; - /// retrieve the RawUTF8List content encoded with TFileBufferWriter.WriteRawUTF8List - // - if StoreObjectsAsVarUInt32 was TRUE, all Objects[] properties will be - // retrieved as VarUInt32 - function ReadRawUTF8List(List: TRawUTF8List): boolean; - /// retrieve a pointer to the current position, for a given data length - // - if the data is available in the current memory mapped file, it - // will just return a pointer to it - // - otherwise (i.e. if the data is split between to 1GB memory map buffers), - // data will be copied into the temporary aTempData buffer before retrieval - function ReadPointer(DataLen: PtrUInt; var aTempData: RawByteString): pointer; - /// create a TMemoryStream instance from the current position - // - the content size is either specified by DataLen>=0, either available at - // the current position, as saved by TFileBufferWriter.WriteStream method - // - if this content fit in the current 1GB memory map buffer, a - // TSynMemoryStream instance is returned, with no data copy (faster) - // - if this content is not already mapped in memory, a separate memory map - // will be created (the returned instance is a TSynMemoryStreamMapped) - function ReadStream(DataLen: PtrInt=-1): TCustomMemoryStream; - /// retrieve the current in-memory pointer - // - if file was not memory-mapped, returns nil - // - if DataLen>0, will increment the current in-memory position - function CurrentMemory(DataLen: PtrUInt=0; PEnd: PPAnsiChar=nil): pointer; - /// retrieve the current in-memory position - // - if file was not memory-mapped, returns -1 - function CurrentPosition: integer; {$ifdef HASINLINE}inline;{$endif} - /// read-only access to the global file size - function FileSize: Int64; {$ifdef HASINLINE}inline;{$endif} - /// read-only access to the global mapped buffer binary - function MappedBuffer: PAnsiChar; {$ifdef HASINLINE}inline;{$endif} - end; - - /// implements a thread-safe Bloom Filter storage - // - a "Bloom Filter" is a space-efficient probabilistic data structure, - // that is used to test whether an element is a member of a set. False positive - // matches are possible, but false negatives are not. Elements can be added to - // the set, but not removed. Typical use cases are to avoid unecessary - // slow disk or network access if possible, when a lot of items are involved. - // - memory use is very low, when compared to storage of all values: fewer - // than 10 bits per element are required for a 1% false positive probability, - // independent of the size or number of elements in the set - for instance, - // storing 10,000,000 items presence with 1% of false positive ratio - // would consume only 11.5 MB of memory, using 7 hash functions - // - use Insert() methods to add an item to the internal bits array, and - // Reset() to clear all bits array, if needed - // - MayExist() function would check if the supplied item was probably set - // - SaveTo() and LoadFrom() methods allow transmission of the bits array, - // for a disk/database storage or transmission over a network - // - internally, several (hardware-accelerated) crc32c hash functions will be - // used, with some random seed values, to simulate several hashing functions - // - Insert/MayExist/Reset methods are thread-safe - TSynBloomFilter = class(TSynPersistentLock) - private - fSize: cardinal; - fFalsePositivePercent: double; - fBits: cardinal; - fHashFunctions: cardinal; - fInserted: cardinal; - fStore: RawByteString; - function GetInserted: cardinal; - public - /// initialize the internal bits storage for a given number of items - // - by default, internal bits array size will be guess from a 1 % false - // positive rate - but you may specify another value, to reduce memory use - // - this constructor would compute and initialize Bits and HashFunctions - // corresponding to the expected false positive ratio - constructor Create(aSize: integer; aFalsePositivePercent: double = 1); reintroduce; overload; - /// initialize the internal bits storage from a SaveTo() binary buffer - // - this constructor will initialize the internal bits array calling LoadFrom() - constructor Create(const aSaved: RawByteString; aMagic: cardinal=$B1003F11); reintroduce; overload; - /// add an item in the internal bits array storage - // - this method is thread-safe - procedure Insert(const aValue: RawByteString); overload; - /// add an item in the internal bits array storage - // - this method is thread-safe - procedure Insert(aValue: pointer; aValueLen: integer); overload; virtual; - /// clear the internal bits array storage - // - you may call this method after some time, if some items may have - // been removed, to reduce false positives - // - this method is thread-safe - procedure Reset; virtual; - /// returns TRUE if the supplied items was probably set via Insert() - // - some false positive may occur, but not much than FalsePositivePercent - // - this method is thread-safe - function MayExist(const aValue: RawByteString): boolean; overload; - /// returns TRUE if the supplied items was probably set via Insert() - // - some false positive may occur, but not much than FalsePositivePercent - // - this method is thread-safe - function MayExist(aValue: pointer; aValueLen: integer): boolean; overload; - /// store the internal bits array into a binary buffer - // - may be used to transmit or store the state of a dataset, avoiding - // to recompute all Insert() at program startup, or to synchronize - // networks nodes information and reduce the number of remote requests - function SaveTo(aMagic: cardinal=$B1003F11): RawByteString; overload; - /// store the internal bits array into a binary buffer - // - may be used to transmit or store the state of a dataset, avoiding - // to recompute all Insert() at program startup, or to synchronize - // networks nodes information and reduce the number of remote requests - procedure SaveTo(aDest: TFileBufferWriter; aMagic: cardinal=$B1003F11); overload; - /// read the internal bits array from a binary buffer - // - as previously serialized by the SaveTo method - // - may be used to transmit or store the state of a dataset - function LoadFrom(const aSaved: RawByteString; aMagic: cardinal=$B1003F11): boolean; overload; - /// read the internal bits array from a binary buffer - // - as previously serialized by the SaveTo method - // - may be used to transmit or store the state of a dataset - function LoadFrom(P: PByte; PLen: integer; aMagic: cardinal=$B1003F11): boolean; overload; virtual; - published - /// maximum number of items which are expected to be inserted - property Size: cardinal read fSize; - /// expected percentage (1..100) of false positive results for MayExists() - property FalsePositivePercent: double read fFalsePositivePercent; - /// number of bits stored in the internal bits array - property Bits: cardinal read fBits; - /// how many hash functions would be applied for each Insert() - property HashFunctions: cardinal read fHashFunctions; - /// how many times the Insert() method has been called - property Inserted: cardinal read GetInserted; - end; - - /// implements a thread-safe differential Bloom Filter storage - // - this inherited class is able to compute incremental serialization of - // its internal bits array, to reduce network use - // - an obfuscated revision counter is used to identify storage history - TSynBloomFilterDiff = class(TSynBloomFilter) - protected - fRevision: Int64; - fSnapShotAfterMinutes: cardinal; - fSnapshotAfterInsertCount: cardinal; - fSnapshotTimestamp: Int64; - fSnapshotInsertCount: cardinal; - fKnownRevision: Int64; - fKnownStore: RawByteString; - public - /// add an item in the internal bits array storage - // - this overloaded thread-safe method would compute fRevision - procedure Insert(aValue: pointer; aValueLen: integer); override; - /// clear the internal bits array storage - // - this overloaded thread-safe method would reset fRevision - procedure Reset; override; - /// store the internal bits array into an incremental binary buffer - // - here the difference from a previous SaveToDiff revision will be computed - // - if aKnownRevision is outdated (e.g. if equals 0), the whole bits array - // would be returned, and around 10 bits per item would be transmitted - // (for 1% false positive ratio) - // - incremental retrieval would then return around 10 bytes per newly added - // item since the last snapshot reference state (with 1% ratio, i.e. 7 hash - // functions) - function SaveToDiff(const aKnownRevision: Int64): RawByteString; - /// use the current internal bits array state as known revision - // - is done the first time SaveToDiff() is called, then after 1/32th of - // the filter size has been inserted (see SnapshotAfterInsertCount property), - // or after SnapShotAfterMinutes property timeout period - procedure DiffSnapshot; - /// retrieve the revision number from an incremental binary buffer - // - returns 0 if the supplied binary buffer does not match this bloom filter - function DiffKnownRevision(const aDiff: RawByteString): Int64; - /// read the internal bits array from an incremental binary buffer - // - as previously serialized by the SaveToDiff() method - // - may be used to transmit or store the state of a dataset - // - returns false if the supplied content is incorrect, e.g. if the known - // revision is deprecated - function LoadFromDiff(const aDiff: RawByteString): boolean; - /// the opaque revision number of this internal storage - // - is in fact the Unix timestamp shifted by 31 bits, and an incremental - // counter: this pattern will allow consistent IDs over several ServPanels - property Revision: Int64 read fRevision; - /// after how many Insert() the internal bits array storage should be - // promoted as known revision - // - equals Size div 32 by default - property SnapshotAfterInsertCount: cardinal read fSnapshotAfterInsertCount - write fSnapshotAfterInsertCount; - /// after how many time the internal bits array storage should be - // promoted as known revision - // - equals 30 minutes by default - property SnapShotAfterMinutes: cardinal read fSnapShotAfterMinutes - write fSnapShotAfterMinutes; - end; - - -/// RLE compression of a memory buffer containing mostly zeros -// - will store the number of consecutive zeros instead of plain zero bytes -// - used for spare bit sets, e.g. TSynBloomFilter serialization -// - will also compute the crc32c of the supplied content -// - use ZeroDecompress() to expand the compressed result -// - resulting content would be at most 14 bytes bigger than the input -// - you may use this function before SynLZ compression -procedure ZeroCompress(P: PAnsiChar; Len: integer; Dest: TFileBufferWriter); - -/// RLE uncompression of a memory buffer containing mostly zeros -// - returns Dest='' if P^ is not a valid ZeroCompress() function result -// - used for spare bit sets, e.g. TSynBloomFilter serialization -// - will also check the crc32c of the supplied content -procedure ZeroDecompress(P: PByte; Len: integer; {$ifdef FPC}var{$else}out{$endif} Dest: RawByteString); - -/// RLE compression of XORed memory buffers resulting in mostly zeros -// - will perform ZeroCompress(Dest^ := New^ xor Old^) without any temporary -// memory allocation -// - is used e.g. by TSynBloomFilterDiff.SaveToDiff() in incremental mode -// - will also compute the crc32c of the supplied content -procedure ZeroCompressXor(New,Old: PAnsiChar; Len: cardinal; Dest: TFileBufferWriter); - -/// RLE uncompression and ORing of a memory buffer containing mostly zeros -// - will perform Dest^ := Dest^ or ZeroDecompress(P^) without any temporary -// memory allocation -// - is used e.g. by TSynBloomFilterDiff.LoadFromDiff() in incremental mode -// - returns false if P^ is not a valid ZeroCompress/ZeroCompressXor() result -// - will also check the crc32c of the supplied content -function ZeroDecompressOr(P,Dest: PAnsiChar; Len,DestLen: integer): boolean; - - -const - /// normal pattern search depth for DeltaCompress() - // - gives good results on most content - DELTA_LEVEL_FAST = 100; - /// brutal pattern search depth for DeltaCompress() - // - may become very slow, with minor benefit, on huge content - DELTA_LEVEL_BEST = 500; - /// 2MB as internal chunks/window default size for DeltaCompress() - // - will use up to 9 MB of RAM during DeltaCompress() - none in DeltaExtract() - DELTA_BUF_DEFAULT = 2 shl 20; - -/// compute difference of two binary buffers -// - returns '=' for equal buffers, or an optimized binary delta -// - DeltaExtract() could be used later on to compute New from Old + Delta -function DeltaCompress(const New, Old: RawByteString; - Level: integer=DELTA_LEVEL_FAST; BufSize: integer=DELTA_BUF_DEFAULT): RawByteString; overload; - -/// compute difference of two binary buffers -// - returns '=' for equal buffers, or an optimized binary delta -// - DeltaExtract() could be used later on to compute New from Old -function DeltaCompress(New, Old: PAnsiChar; NewSize, OldSize: integer; - Level: integer=DELTA_LEVEL_FAST; BufSize: integer=DELTA_BUF_DEFAULT): RawByteString; overload; - -/// compute difference of two binary buffers -// - returns '=' for equal buffers, or an optimized binary delta -// - DeltaExtract() could be used later on to compute New from Old + Delta -// - caller should call Freemem(Delta) once finished with the output buffer -function DeltaCompress(New, Old: PAnsiChar; NewSize, OldSize: integer; - out Delta: PAnsiChar; Level: integer=DELTA_LEVEL_FAST; BufSize: integer=DELTA_BUF_DEFAULT): integer; overload; - -type - /// result of function DeltaExtract() - TDeltaError = ( - dsSuccess, dsCrcCopy, dsCrcComp, dsCrcBegin, dsCrcEnd, dsCrcExtract, dsFlag, dsLen); - -/// returns how many bytes a DeltaCompress() result will expand to -function DeltaExtractSize(const Delta: RawByteString): integer; overload; - -/// returns how many bytes a DeltaCompress() result will expand to -function DeltaExtractSize(Delta: PAnsiChar): integer; overload; - -/// apply the delta binary as computed by DeltaCompress() -// - decompression don't use any RAM, will perform crc32c check, and is very fast -// - return dsSuccess if was uncompressed to aOutUpd as expected -function DeltaExtract(const Delta,Old: RawByteString; out New: RawByteString): TDeltaError; overload; - -/// low-level apply the delta binary as computed by DeltaCompress() -// - New should already be allocated with DeltaExtractSize(Delta) bytes -// - as such, expect Delta, Old and New to be <> nil, and Delta <> '=' -// - return dsSuccess if was uncompressed to aOutUpd as expected -function DeltaExtract(Delta,Old,New: PAnsiChar): TDeltaError; overload; - -function ToText(err: TDeltaError): PShortString; overload; - - -{ ************ high-level storage classes ************************* } - -type - /// implement a cache of some key/value pairs, e.g. to improve reading speed - // - used e.g. by TSQLDataBase for caching the SELECT statements results in an - // internal JSON format (which is faster than a query to the SQLite3 engine) - // - internally make use of an efficient hashing algorithm for fast response - // (i.e. TSynNameValue will use the TDynArrayHashed wrapper mechanism) - // - this class is thread-safe if you use properly the associated Safe lock - TSynCache = class(TSynPersistentLock) - protected - fFindLastKey: RawUTF8; - fNameValue: TSynNameValue; - fRamUsed: cardinal; - fMaxRamUsed: cardinal; - fTimeoutSeconds: cardinal; - fTimeoutTix: cardinal; - procedure ResetIfNeeded; - public - /// initialize the internal storage - // - aMaxCacheRamUsed can set the maximum RAM to be used for values, in bytes - // (default is 16 MB), after which the cache is flushed - // - by default, key search is done case-insensitively, but you can specify - // another option here - // - by default, there is no timeout period, but you may specify a number of - // seconds of inactivity (i.e. no Add call) after which the cache is flushed - constructor Create(aMaxCacheRamUsed: cardinal=16 shl 20; - aCaseSensitive: boolean=false; aTimeoutSeconds: cardinal=0); reintroduce; - /// find a Key in the cache entries - // - return '' if nothing found: you may call Add() just after to insert - // the expected value in the cache - // - return the associated Value otherwise, and the associated integer tag - // if aResultTag address is supplied - // - this method is not thread-safe, unless you call Safe.Lock before - // calling Find(), and Safe.Unlock after calling Add() - function Find(const aKey: RawUTF8; aResultTag: PPtrInt=nil): RawUTF8; - /// add a Key and its associated value (and tag) to the cache entries - // - you MUST always call Find() with the associated Key first - // - this method is not thread-safe, unless you call Safe.Lock before - // calling Find(), and Safe.Unlock after calling Add() - procedure Add(const aValue: RawUTF8; aTag: PtrInt); - /// add a Key/Value pair in the cache entries - // - returns true if aKey was not existing yet, and aValue has been stored - // - returns false if aKey did already exist in the internal cache, and - // its entry has been updated with the supplied aValue/aTag - // - this method is thread-safe, using the Safe locker of this instance - function AddOrUpdate(const aKey, aValue: RawUTF8; aTag: PtrInt): boolean; - /// called after a write access to the database to flush the cache - // - set Count to 0 - // - release all cache memory - // - returns TRUE if was flushed, i.e. if there was something in cache - // - this method is thread-safe, using the Safe locker of this instance - function Reset: boolean; - /// number of entries in the cache - function Count: integer; - /// access to the internal locker, for thread-safe process - // - Find/Add methods calls should be protected as such: - // ! cache.Safe.Lock; - // ! try - // ! ... cache.Find/cache.Add ... - // ! finally - // ! cache.Safe.Unlock; - // ! end; - property Safe: PSynLocker read fSafe; - /// the current global size of Values in RAM cache, in bytes - property RamUsed: cardinal read fRamUsed; - /// the maximum RAM to be used for values, in bytes - // - the cache is flushed when ValueSize reaches this limit - // - default is 16 MB (16 shl 20) - property MaxRamUsed: cardinal read fMaxRamUsed; - /// after how many seconds betwen Add() calls the cache should be flushed - // - equals 0 by default, meaning no time out - property TimeoutSeconds: cardinal read fTimeoutSeconds; - end; - - /// thread-safe FIFO (First-In-First-Out) in-order queue of records - // - uses internally a dynamic array storage, with a sliding algorithm - // (more efficient than the FPC or Delphi TQueue) - TSynQueue = class(TSynPersistentLock) - protected - fValues: TDynArray; - fValueVar: pointer; - fCount, fFirst, fLast: integer; - fWaitPopFlags: set of (wpfDestroying); - fWaitPopCounter: integer; - procedure InternalGrow; - function InternalDestroying(incPopCounter: integer): boolean; - function InternalWaitDone(endtix: Int64; const idle: TThreadMethod): boolean; - public - /// initialize the queue storage - // - aTypeInfo should be a dynamic array TypeInfo() RTTI pointer, which - // would store the values within this TSynQueue instance - constructor Create(aTypeInfo: pointer); reintroduce; virtual; - /// finalize the storage - // - would release all internal stored values, and call WaitPopFinalize - destructor Destroy; override; - /// store one item into the queue - // - this method is thread-safe, since it will lock the instance - procedure Push(const aValue); - /// extract one item from the queue, as FIFO (First-In-First-Out) - // - returns true if aValue has been filled with a pending item, which - // is removed from the queue (use Peek if you don't want to remove it) - // - returns false if the queue is empty - // - this method is thread-safe, since it will lock the instance - function Pop(out aValue): boolean; - /// extract one matching item from the queue, as FIFO (First-In-First-Out) - // - the current pending item is compared with aAnother value - function PopEquals(aAnother: pointer; aCompare: TDynArraySortCompare; out aValue): boolean; - /// lookup one item from the queue, as FIFO (First-In-First-Out) - // - returns true if aValue has been filled with a pending item, without - // removing it from the queue (as Pop method does) - // - returns false if the queue is empty - // - this method is thread-safe, since it will lock the instance - function Peek(out aValue): boolean; - /// waiting extract of one item from the queue, as FIFO (First-In-First-Out) - // - returns true if aValue has been filled with a pending item within the - // specified aTimeoutMS time - // - returns false if nothing was pushed into the queue in time, or if - // WaitPopFinalize has been called - // - aWhenIdle could be assigned e.g. to VCL/LCL Application.ProcessMessages - // - you can optionally compare the pending item before returning it (could - // be used e.g. when several threads are putting items into the queue) - // - this method is thread-safe, but will lock the instance only if needed - function WaitPop(aTimeoutMS: integer; const aWhenIdle: TThreadMethod; out aValue; - aCompared: pointer=nil; aCompare: TDynArraySortCompare=nil): boolean; - /// waiting lookup of one item from the queue, as FIFO (First-In-First-Out) - // - returns a pointer to a pending item within the specified aTimeoutMS - // time - the Safe.Lock is still there, so that caller could check its content, - // then call Pop() if it is the expected one, and eventually always call Safe.Unlock - // - returns nil if nothing was pushed into the queue in time - // - this method is thread-safe, but will lock the instance only if needed - function WaitPeekLocked(aTimeoutMS: integer; const aWhenIdle: TThreadMethod): pointer; - /// ensure any pending or future WaitPop() returns immediately as false - // - is always called by Destroy destructor - // - could be also called e.g. from an UI OnClose event to avoid any lock - // - this method is thread-safe, but will lock the instance only if needed - procedure WaitPopFinalize(aTimeoutMS: integer=100); - /// delete all items currently stored in this queue, and void its capacity - // - this method is thread-safe, since it will lock the instance - procedure Clear; - /// initialize a dynamic array with the stored queue items - // - aDynArrayValues should be a variable defined as aTypeInfo from Create - // - you can retrieve an optional TDynArray wrapper, e.g. for binary or JSON - // persistence - // - this method is thread-safe, and will make a copy of the queue data - procedure Save(out aDynArrayValues; aDynArray: PDynArray=nil); - /// returns how many items are currently stored in this queue - // - this method is thread-safe - function Count: Integer; - /// returns how much slots is currently reserved in memory - // - the queue has an optimized auto-sizing algorithm, you can use this - // method to return its current capacity - // - this method is thread-safe - function Capacity: integer; - /// returns true if there are some items currently pending in the queue - // - slightly faster than checking Count=0, and much faster than Pop or Peek - function Pending: boolean; - end; - - /// maintain a thread-safe sorted list of TSynPersistentLock objects - // - will use fast O(log(n)) binary search for efficient search - it is - // a lighter alternative to TObjectListHashedAbstract/TObjectListPropertyHashed - // if hashing has a performance cost (e.g. if there are a few items, or - // deletion occurs regularly) - // - in practice, insertion becomes slower after around 100,000 items stored - // - expect to store only TSynPersistentLock inherited items, so that - // the process is explicitly thread-safe - // - inherited classes should override the Compare and NewItem abstract methods - TObjectListSorted = class(TSynPersistentLock) - protected - fCount: integer; - fObjArray: TSynPersistentLockDynArray; - function FastLocate(const Value; out Index: Integer): boolean; - procedure InsertNew(Item: TSynPersistentLock; Index: integer); - // override those methods for actual implementation - function Compare(Item: TSynPersistentLock; const Value): integer; virtual; abstract; - function NewItem(const Value): TSynPersistentLock; virtual; abstract; - public - /// finalize the list - destructor Destroy; override; - /// search a given TSynPersistentLock instance from a value - // - if returns not nil, caller should make result.Safe.UnLock once finished - // - will use the TObjectListSortedCompare function for the search - function FindLocked(const Value): pointer; - /// search or add a given TSynPersistentLock instance from a value - // - if returns not nil, caller should make result.Safe.UnLock once finished - // - added is TRUE if a new void item has just been created - // - will use the TObjectListSortedCompare function for the search - function FindOrAddLocked(const Value; out added: boolean): pointer; - /// remove a given TSynPersistentLock instance from a value - function Delete(const Value): boolean; - /// how many items are actually stored - property Count: Integer read fCount; - /// low-level access to the stored items - // - warning: use should be protected by Lock.Enter/Lock.Leave - property ObjArray: TSynPersistentLockDynArray read fObjArray; - end; - - /// abstract high-level handling of (SynLZ-)compressed persisted storage - // - LoadFromReader/SaveToWriter abstract methods should be overriden - // with proper binary persistence implementation - TSynPersistentStore = class(TSynPersistentLock) - protected - fName: RawUTF8; - fReader: TFastReader; - fReaderTemp: PRawByteString; - fLoadFromLastUncompressed, fSaveToLastUncompressed: integer; - fLoadFromLastAlgo: TAlgoCompress; - /// low-level virtual methods implementing the persistence - procedure LoadFromReader; virtual; - procedure SaveToWriter(aWriter: TFileBufferWriter); virtual; - public - /// initialize a void storage with the supplied name - constructor Create(const aName: RawUTF8); reintroduce; overload; virtual; - /// initialize a storage from a SaveTo persisted buffer - // - raise a EFastReader exception on decoding error - constructor CreateFrom(const aBuffer: RawByteString; - aLoad: TAlgoCompressLoad = aclNormal); - /// initialize a storage from a SaveTo persisted buffer - // - raise a EFastReader exception on decoding error - constructor CreateFromBuffer(aBuffer: pointer; aBufferLen: integer; - aLoad: TAlgoCompressLoad = aclNormal); - /// initialize a storage from a SaveTo persisted buffer - // - raise a EFastReader exception on decoding error - constructor CreateFromFile(const aFileName: TFileName; - aLoad: TAlgoCompressLoad = aclNormal); - /// fill the storage from a SaveTo persisted buffer - // - actually call the LoadFromReader() virtual method for persistence - // - raise a EFastReader exception on decoding error - procedure LoadFrom(const aBuffer: RawByteString; - aLoad: TAlgoCompressLoad = aclNormal); overload; - /// initialize the storage from a SaveTo persisted buffer - // - actually call the LoadFromReader() virtual method for persistence - // - raise a EFastReader exception on decoding error - procedure LoadFrom(aBuffer: pointer; aBufferLen: integer; - aLoad: TAlgoCompressLoad = aclNormal); overload; virtual; - /// initialize the storage from a SaveToFile content - // - actually call the LoadFromReader() virtual method for persistence - // - returns false if the file is not found, true if the file was loaded - // without any problem, or raise a EFastReader exception on decoding error - function LoadFromFile(const aFileName: TFileName; - aLoad: TAlgoCompressLoad = aclNormal): boolean; - /// persist the content as a SynLZ-compressed binary blob - // - to be retrieved later on via LoadFrom method - // - actually call the SaveToWriter() protected virtual method for persistence - // - you can specify ForcedAlgo if you want to override the default AlgoSynLZ - // - BufferOffset could be set to reserve some bytes before the compressed buffer - procedure SaveTo(out aBuffer: RawByteString; nocompression: boolean=false; - BufLen: integer=65536; ForcedAlgo: TAlgoCompress=nil; BufferOffset: integer=0); overload; virtual; - /// persist the content as a SynLZ-compressed binary blob - // - just an overloaded wrapper - function SaveTo(nocompression: boolean=false; BufLen: integer=65536; - ForcedAlgo: TAlgoCompress=nil; BufferOffset: integer=0): RawByteString; overload; - {$ifdef HASINLINE}inline;{$endif} - /// persist the content as a SynLZ-compressed binary file - // - to be retrieved later on via LoadFromFile method - // - returns the number of bytes of the resulting file - // - actually call the SaveTo method for persistence - function SaveToFile(const aFileName: TFileName; nocompression: boolean=false; - BufLen: integer=65536; ForcedAlgo: TAlgoCompress=nil): PtrUInt; - /// one optional text associated with this storage - // - you can define this field as published to serialize its value in log/JSON - property Name: RawUTF8 read fName; - /// after a LoadFrom(), contains the uncompressed data size read - property LoadFromLastUncompressed: integer read fLoadFromLastUncompressed; - /// after a SaveTo(), contains the uncompressed data size written - property SaveToLastUncompressed: integer read fSaveToLastUncompressed; - end; - - /// implement binary persistence and JSON serialization (not deserialization) - TSynPersistentStoreJson = class(TSynPersistentStore) - protected - // append "name" -> inherited should add properties to the JSON object - procedure AddJSON(W: TTextWriter); virtual; - public - /// serialize this instance as a JSON object - function SaveToJSON(reformat: TTextWriterJSONFormat = jsonCompact): RawUTF8; - end; - - -type - /// item as stored in a TRawByteStringGroup instance - TRawByteStringGroupValue = record - Position: integer; - Value: RawByteString; - end; - PRawByteStringGroupValue = ^TRawByteStringGroupValue; - /// items as stored in a TRawByteStringGroup instance - TRawByteStringGroupValueDynArray = array of TRawByteStringGroupValue; - - /// store several RawByteString content with optional concatenation - {$ifdef USERECORDWITHMETHODS}TRawByteStringGroup = record - {$else}TRawByteStringGroup = object{$endif} - public - /// actual list storing the data - Values: TRawByteStringGroupValueDynArray; - /// how many items are currently stored in Values[] - Count: integer; - /// the current size of data stored in Values[] - Position: integer; - /// naive but efficient cache for Find() - LastFind: integer; - /// add a new item to Values[] - procedure Add(const aItem: RawByteString); overload; - /// add a new item to Values[] - procedure Add(aItem: pointer; aItemLen: integer); overload; - {$ifndef DELPHI5OROLDER} - /// add another TRawByteStringGroup to Values[] - procedure Add(const aAnother: TRawByteStringGroup); overload; - /// low-level method to abort the latest Add() call - // - warning: will work only once, if an Add() has actually been just called: - // otherwise, the behavior is unexpected, and may wrongly truncate data - procedure RemoveLastAdd; - /// compare two TRawByteStringGroup instance stored text - function Equals(const aAnother: TRawByteStringGroup): boolean; - {$endif DELPHI5OROLDER} - /// clear any stored information - procedure Clear; - /// append stored information into another RawByteString, and clear content - procedure AppendTextAndClear(var aDest: RawByteString); - // compact the Values[] array into a single item - // - is also used by AsText to compute a single RawByteString - procedure Compact; - /// return all content as a single RawByteString - // - will also compact the Values[] array into a single item (which is returned) - function AsText: RawByteString; - /// return all content as a single TByteDynArray - function AsBytes: TByteDynArray; - /// save all content into a TTextWriter instance - procedure Write(W: TTextWriter; Escape: TTextWriterKind=twJSONEscape); overload; - /// save all content into a TFileBufferWriter instance - procedure WriteBinary(W: TFileBufferWriter); overload; - /// save all content as a string into a TFileBufferWriter instance - // - storing the length as WriteVarUInt32() prefix - procedure WriteString(W: TFileBufferWriter); - /// add another TRawByteStringGroup previously serialized via WriteString() - procedure AddFromReader(var aReader: TFastReader); - /// returns a pointer to Values[] containing a given position - // - returns nil if not found - function Find(aPosition: integer): PRawByteStringGroupValue; overload; - /// returns a pointer to Values[].Value containing a given position and length - // - returns nil if not found - function Find(aPosition, aLength: integer): pointer; overload; - /// returns the text at a given position in Values[] - // - text should be in a single Values[] entry - procedure FindAsText(aPosition, aLength: integer; out aText: RawByteString); overload; - {$ifdef HASINLINE}inline;{$endif} - /// returns the text at a given position in Values[] - // - text should be in a single Values[] entry - function FindAsText(aPosition, aLength: integer): RawByteString; overload; - {$ifdef HASINLINE}inline;{$endif} - {$ifndef NOVARIANTS} - /// returns the text at a given position in Values[] - // - text should be in a single Values[] entry - // - explicitly returns null if the supplied text was not found - procedure FindAsVariant(aPosition, aLength: integer; out aDest: variant); - {$ifdef HASINLINE}inline;{$endif} - {$endif} - /// append the text at a given position in Values[], JSON escaped by default - // - text should be in a single Values[] entry - procedure FindWrite(aPosition, aLength: integer; W: TTextWriter; - Escape: TTextWriterKind=twJSONEscape; TrailingCharsToIgnore: integer=0); - {$ifdef HASINLINE}inline;{$endif} - /// append the blob at a given position in Values[], base-64 encoded - // - text should be in a single Values[] entry - procedure FindWriteBase64(aPosition, aLength: integer; W: TTextWriter; - withMagic: boolean); {$ifdef HASINLINE}inline;{$endif} - /// copy the text at a given position in Values[] - // - text should be in a single Values[] entry - procedure FindMove(aPosition, aLength: integer; aDest: pointer); - end; - /// pointer reference to a TRawByteStringGroup - PRawByteStringGroup = ^TRawByteStringGroup; - - /// simple stack-allocated type for handling a non-void type names list - // - Delphi "object" is buggy on stack -> also defined as record with methods - {$ifdef USERECORDWITHMETHODS}TPropNameList = record - {$else}TPropNameList = object{$endif} - public - /// the actual names storage - Values: TRawUTF8DynArray; - /// how many items are currently in Values[] - Count: Integer; - /// initialize the list - // - set Count := 0 - procedure Init; {$ifdef HASINLINE}inline;{$endif} - /// search for a Value within Values[0..Count-1] using IdemPropNameU() - function FindPropName(const Value: RawUTF8): Integer; {$ifdef HASINLINE}inline;{$endif} - /// if Value is in Values[0..Count-1] using IdemPropNameU() returns FALSE - // - otherwise, returns TRUE and add Value to Values[] - // - any Value='' is rejected - function AddPropName(const Value: RawUTF8): Boolean; - end; - - -{ ************ Security and Identifier classes ************************** } - -type - /// 64-bit integer unique identifier, as computed by TSynUniqueIdentifierGenerator - // - they are increasing over time (so are much easier to store/shard/balance - // than UUID/GUID), and contain generation time and a 16-bit process ID - // - mapped by TSynUniqueIdentifierBits memory structure - // - may be used on client side for something similar to a MongoDB ObjectID, - // but compatible with TSQLRecord.ID: TID properties - TSynUniqueIdentifier = type Int64; - - /// 16-bit unique process identifier, used to compute TSynUniqueIdentifier - // - each TSynUniqueIdentifierGenerator instance is expected to have - // its own unique process identifier, stored as a 16 bit integer 1..65535 value - TSynUniqueIdentifierProcess = type word; - - {$A-} - /// map 64-bit integer unique identifier internal memory structure - // - as stored in TSynUniqueIdentifier = Int64 values, and computed by - // TSynUniqueIdentifierGenerator - // - bits 0..14 map a 15-bit increasing counter (collision-free) - // - bits 15..30 map a 16-bit process identifier - // - bits 31..63 map a 33-bit UTC time, encoded as seconds since Unix epoch - {$ifdef USERECORDWITHMETHODS}TSynUniqueIdentifierBits = record - {$else}TSynUniqueIdentifierBits = object{$endif} - public - /// the actual 64-bit storage value - // - in practice, only first 63 bits are used - Value: TSynUniqueIdentifier; - /// 15-bit counter (0..32767), starting with a random value - function Counter: word; - {$ifdef HASINLINE}inline;{$endif} - /// 16-bit unique process identifier - // - as specified to TSynUniqueIdentifierGenerator constructor - function ProcessID: TSynUniqueIdentifierProcess; - {$ifdef HASINLINE}inline;{$endif} - /// low-endian 4-byte value representing the seconds since the Unix epoch - // - time is expressed in Coordinated Universal Time (UTC), not local time - // - it uses in fact a 33-bit resolution, so is "Year 2038" bug-free - function CreateTimeUnix: TUnixTime; - {$ifdef HASINLINE}inline;{$endif} - /// fill this unique identifier structure from its TSynUniqueIdentifier value - // - is just a wrapper around PInt64(@self)^ - procedure From(const AID: TSynUniqueIdentifier); - {$ifdef HASINLINE}inline;{$endif} - {$ifndef NOVARIANTS} - /// convert this identifier as an explicit TDocVariant JSON object - // - returns e.g. - // ! {"Created":"2016-04-19T15:27:58","Identifier":1,"Counter":1, - // ! "Value":3137644716930138113,"Hex":"2B8B273F00008001"} - function AsVariant: variant; {$ifdef HASINLINE}inline;{$endif} - /// convert this identifier to an explicit TDocVariant JSON object - // - returns e.g. - // ! {"Created":"2016-04-19T15:27:58","Identifier":1,"Counter":1, - // ! "Value":3137644716930138113,"Hex":"2B8B273F00008001"} - procedure ToVariant(out result: variant); - {$endif NOVARIANTS} - /// extract the UTC generation timestamp from the identifier as TDateTime - // - time is expressed in Coordinated Universal Time (UTC), not local time - function CreateDateTime: TDateTime; - {$ifdef HASINLINE}inline;{$endif} - /// extract the UTC generation timestamp from the identifier - // - time is expressed in Coordinated Universal Time (UTC), not local time - function CreateTimeLog: TTimeLog; - {$ifndef DELPHI5OROLDER} - /// compare two Identifiers - function Equal(const Another: TSynUniqueIdentifierBits): boolean; - {$ifdef HASINLINE}inline;{$endif} - {$endif DELPHI5OROLDER} - /// convert the identifier into a 16 chars hexadecimal string - function ToHexa: RawUTF8; - {$ifdef HASINLINE}inline;{$endif} - /// fill this unique identifier back from a 16 chars hexadecimal string - // - returns TRUE if the supplied hexadecimal is on the expected format - // - returns FALSE if the supplied text is invalid - function FromHexa(const hexa: RawUTF8): boolean; - /// fill this unique identifier with a fake value corresponding to a given - // timestamp - // - may be used e.g. to limit database queries on a particular time range - // - bits 0..30 would be 0, i.e. would set Counter = 0 and ProcessID = 0 - procedure FromDateTime(const aDateTime: TDateTime); - /// fill this unique identifier with a fake value corresponding to a given - // timestamp - // - may be used e.g. to limit database queries on a particular time range - // - bits 0..30 would be 0, i.e. would set Counter = 0 and ProcessID = 0 - procedure FromUnixTime(const aUnixTime: TUnixTime); - end; - {$A+} - - /// points to a 64-bit integer identifier, as computed by TSynUniqueIdentifierGenerator - // - may be used to access the identifier internals, from its stored - // Int64 or TSynUniqueIdentifier value - PSynUniqueIdentifierBits = ^TSynUniqueIdentifierBits; - - /// a 24 chars cyphered hexadecimal string, mapping a TSynUniqueIdentifier - // - has handled by TSynUniqueIdentifierGenerator.ToObfuscated/FromObfuscated - TSynUniqueIdentifierObfuscated = type RawUTF8; - - /// thread-safe 64-bit integer unique identifier computation - // - may be used on client side for something similar to a MongoDB ObjectID, - // but compatible with TSQLRecord.ID: TID properties, since it will contain - // a 63-bit unsigned integer, following our ORM expectations - // - each identifier would contain a 16-bit process identifier, which is - // supplied by the application, and should be unique for this process at a - // given time - // - identifiers may be obfuscated as hexadecimal text, using both encryption - // and digital signature - TSynUniqueIdentifierGenerator = class(TSynPersistent) - protected - fUnixCreateTime: cardinal; - fLatestCounterOverflowUnixCreateTime: cardinal; - fIdentifier: TSynUniqueIdentifierProcess; - fIdentifierShifted: cardinal; - fLastCounter: cardinal; - fCrypto: array[0..7] of cardinal; // only fCrypto[6..7] are used in practice - fCryptoCRC: cardinal; - fSafe: TSynLocker; - function GetComputedCount: Int64; - public - /// initialize the generator for the given 16-bit process identifier - // - you can supply an obfuscation key, which should be shared for the - // whole system, so that you may use FromObfuscated/ToObfuscated methods - constructor Create(aIdentifier: TSynUniqueIdentifierProcess; - const aSharedObfuscationKey: RawUTF8=''); reintroduce; - /// finalize the generator structure - destructor Destroy; override; - /// return a new unique ID - // - this method is very optimized, and would use very little CPU - procedure ComputeNew(out result: TSynUniqueIdentifierBits); overload; - /// return a new unique ID, type-casted to an Int64 - function ComputeNew: Int64; overload; - {$ifdef HASINLINE}inline;{$endif} - /// return an unique ID matching this generator pattern, at a given timestamp - // - may be used e.g. to limit database queries on a particular time range - procedure ComputeFromDateTime(const aDateTime: TDateTime; out result: TSynUniqueIdentifierBits); - /// return an unique ID matching this generator pattern, at a given timestamp - // - may be used e.g. to limit database queries on a particular time range - procedure ComputeFromUnixTime(const aUnixTime: TUnixTime; out result: TSynUniqueIdentifierBits); - /// map a TSynUniqueIdentifier as 24 chars cyphered hexadecimal text - // - cyphering includes simple key-based encryption and a CRC-32 digital signature - function ToObfuscated(const aIdentifier: TSynUniqueIdentifier): TSynUniqueIdentifierObfuscated; - /// retrieve a TSynUniqueIdentifier from 24 chars cyphered hexadecimal text - // - any file extension (e.g. '.jpeg') would be first deleted from the - // supplied obfuscated text - // - returns true if the supplied obfuscated text has the expected layout - // and a valid digital signature - // - returns false if the supplied obfuscated text is invalid - function FromObfuscated(const aObfuscated: TSynUniqueIdentifierObfuscated; - out aIdentifier: TSynUniqueIdentifier): boolean; - /// some 32-bit value, derivated from aSharedObfuscationKey as supplied - // to the class constructor - // - FromObfuscated and ToObfuscated methods will validate their hexadecimal - // content with this value to secure the associated CRC - // - may be used e.g. as system-depending salt - property CryptoCRC: cardinal read fCryptoCRC; - /// direct access to the associated mutex - property Safe: TSynLocker read fSafe; - published - /// the process identifier, associated with this generator - property Identifier: TSynUniqueIdentifierProcess read fIdentifier; - /// how many times ComputeNew method has been called - property ComputedCount: Int64 read GetComputedCount; - end; - -type - /// abstract TSynPersistent class allowing safe storage of a password - // - the associated Password, e.g. for storage or transmission encryption - // will be persisted encrypted with a private key (which can be customized) - // - if default simple symmetric encryption is not enough, you may define - // a custom TSynPersistentWithPasswordUserCrypt callback, e.g. to - // SynCrypto's CryptDataForCurrentUser, for hardened password storage - // - a published property should be defined as such in inherited class: - // ! property PasswordPropertyName: RawUTF8 read fPassword write fPassword; - // - use the PassWordPlain property to access to its uncyphered value - TSynPersistentWithPassword = class(TSynPersistent) - protected - fPassWord: RawUTF8; - fKey: cardinal; - function GetKey: cardinal; {$ifdef HASINLINE}inline;{$endif} - function GetPassWordPlain: RawUTF8; - function GetPassWordPlainInternal(AppSecret: RawUTF8): RawUTF8; - procedure SetPassWordPlain(const Value: RawUTF8); - public - /// finalize the instance - destructor Destroy; override; - /// this class method could be used to compute the encrypted password, - // ready to be stored as JSON, according to a given private key - class function ComputePassword(const PlainPassword: RawUTF8; - CustomKey: cardinal=0): RawUTF8; overload; - /// this class method could be used to compute the encrypted password from - // a binary digest, ready to be stored as JSON, according to a given private key - // - just a wrapper around ComputePassword(BinToBase64URI()) - class function ComputePassword(PlainPassword: pointer; PlainPasswordLen: integer; - CustomKey: cardinal=0): RawUTF8; overload; - /// this class method could be used to decrypt a password, stored as JSON, - // according to a given private key - // - may trigger a ESynException if the password was stored using a custom - // TSynPersistentWithPasswordUserCrypt callback, and the current user - // doesn't match the expected user stored in the field - class function ComputePlainPassword(const CypheredPassword: RawUTF8; - CustomKey: cardinal=0; const AppSecret: RawUTF8=''): RawUTF8; - /// low-level function used to identify if a given field is a Password - // - this method is used e.g. by TJSONSerializer.WriteObject to identify the - // password field, since its published name is set by the inherited classes - function GetPasswordFieldAddress: pointer; {$ifdef HASINLINE}inline;{$endif} - /// the private key used to cypher the password storage on serialization - // - application can override the default 0 value at runtime - property Key: cardinal read GetKey write fKey; - /// access to the associated unencrypted Password value - // - read may trigger a ESynException if the password was stored using a - // custom TSynPersistentWithPasswordUserCrypt callback, and the current user - // doesn't match the expected user stored in the field - property PasswordPlain: RawUTF8 read GetPassWordPlain write SetPassWordPlain; - end; - -var - /// function prototype to customize TSynPersistent class password storage - // - is called when 'user1:base64pass1,user2:base64pass2' layout is found, - // and the current user logged on the system is user1 or user2 - // - you should not call this low-level method, but assign e.g. from SynCrypto: - // $ TSynPersistentWithPasswordUserCrypt := CryptDataForCurrentUser; - TSynPersistentWithPasswordUserCrypt: - function(const Data,AppServer: RawByteString; Encrypt: boolean): RawByteString; - -type - /// could be used to store a credential pair, as user name and password - // - password will be stored with TSynPersistentWithPassword encryption - TSynUserPassword = class(TSynPersistentWithPassword) - protected - fUserName: RawUTF8; - published - /// the associated user name - property UserName: RawUTF8 read FUserName write FUserName; - /// the associated encrypted password - // - use the PasswordPlain public property to access to the uncrypted password - property Password: RawUTF8 read FPassword write FPassword; - end; - - /// handle safe storage of any connection properties - // - would be used by SynDB.pas to serialize TSQLDBConnectionProperties, or - // by mORMot.pas to serialize TSQLRest instances - // - the password will be stored as Base64, after a simple encryption as - // defined by TSynPersistentWithPassword - // - typical content could be: - // $ { - // $ "Kind": "TSQLDBSQLite3ConnectionProperties", - // $ "ServerName": "server", - // $ "DatabaseName": "", - // $ "User": "", - // $ "Password": "PtvlPA==" - // $ } - // - the "Kind" value will be used to let the corresponding TSQLRest or - // TSQLDBConnectionProperties NewInstance*() class methods create the - // actual instance, from its class name - TSynConnectionDefinition = class(TSynPersistentWithPassword) - protected - fKind: string; - fServerName: RawUTF8; - fDatabaseName: RawUTF8; - fUser: RawUTF8; - public - /// unserialize the database definition from JSON - // - as previously serialized with the SaveToJSON method - // - you can specify a custom Key used for password encryption, if the - // default value is not safe enough for you - // - this method won't use JSONToObject() so avoid any dependency to mORMot.pas - constructor CreateFromJSON(const JSON: RawUTF8; Key: cardinal=0); virtual; - /// serialize the database definition as JSON - // - this method won't use ObjectToJSON() so avoid any dependency to mORMot.pas - function SaveToJSON: RawUTF8; virtual; - published - /// the class name implementing the connection or TSQLRest instance - // - will be used to instantiate the expected class type - property Kind: string read fKind write fKind; - /// the associated server name (or file, for SQLite3) to be connected to - property ServerName: RawUTF8 read fServerName write fServerName; - /// the associated database name (if any), or additional options - property DatabaseName: RawUTF8 read fDatabaseName write fDatabaseName; - /// the associated User Identifier (if any) - property User: RawUTF8 read fUser write fUser; - /// the associated Password, e.g. for storage or transmission encryption - // - will be persisted encrypted with a private key - // - use the PassWordPlain property to access to its uncyphered value - property Password: RawUTF8 read fPassword write fPassword; - end; - - -type - /// class-reference type (metaclass) of an authentication class - TSynAuthenticationClass = class of TSynAuthenticationAbstract; - - /// abstract authentication class, implementing safe token/challenge security - // and a list of active sessions - // - do not use this class, but plain TSynAuthentication - TSynAuthenticationAbstract = class - protected - fSessions: TIntegerDynArray; - fSessionsCount: Integer; - fSessionGenerator: integer; - fTokenSeed: Int64; - fSafe: TSynLocker; - function ComputeCredential(previous: boolean; const UserName,PassWord: RawUTF8): cardinal; virtual; - function GetPassword(const UserName: RawUTF8; out Password: RawUTF8): boolean; virtual; abstract; - function GetUsersCount: integer; virtual; abstract; - // check the given Hash challenge, against stored credentials - function CheckCredentials(const UserName: RaWUTF8; Hash: cardinal): boolean; virtual; - public - /// initialize the authentication scheme - constructor Create; - /// finalize the authentation - destructor Destroy; override; - /// register one credential for a given user - // - this abstract method will raise an exception: inherited classes should - // implement them as expected - procedure AuthenticateUser(const aName, aPassword: RawUTF8); virtual; - /// unregister one credential for a given user - // - this abstract method will raise an exception: inherited classes should - // implement them as expected - procedure DisauthenticateUser(const aName: RawUTF8); virtual; - /// create a new session - // - should return 0 on authentication error, or an integer session ID - // - this method will check the User name and password, and create a new session - function CreateSession(const User: RawUTF8; Hash: cardinal): integer; virtual; - /// check if the session exists in the internal list - function SessionExists(aID: integer): boolean; - /// delete a session - procedure RemoveSession(aID: integer); - /// returns the current identification token - // - to be sent to the client for its authentication challenge - function CurrentToken: Int64; - /// the number of current opened sessions - property SessionsCount: integer read fSessionsCount; - /// the number of registered users - property UsersCount: integer read GetUsersCount; - /// to be used to compute a Hash on the client sude, for a given Token - // - the token should have been retrieved from the server, and the client - // should compute and return this hash value, to perform the authentication - // challenge and create the session - // - internal algorithm is not cryptographic secure, but fast and safe - class function ComputeHash(Token: Int64; const UserName,PassWord: RawUTF8): cardinal; virtual; - end; - - /// simple authentication class, implementing safe token/challenge security - // - maintain a list of user / name credential pairs, and a list of sessions - // - is not meant to handle authorization, just plain user access validation - // - used e.g. by TSQLDBConnection.RemoteProcessMessage (on server side) and - // TSQLDBProxyConnectionPropertiesAbstract (on client side) in SynDB.pas - TSynAuthentication = class(TSynAuthenticationAbstract) - protected - fCredentials: TSynNameValue; // store user/password pairs - function GetPassword(const UserName: RawUTF8; out Password: RawUTF8): boolean; override; - function GetUsersCount: integer; override; - public - /// initialize the authentication scheme - // - you can optionally register one user credential - constructor Create(const aUserName: RawUTF8=''; const aPassword: RawUTF8=''); reintroduce; - /// register one credential for a given user - procedure AuthenticateUser(const aName, aPassword: RawUTF8); override; - /// unregister one credential for a given user - procedure DisauthenticateUser(const aName: RawUTF8); override; - end; - -type - /// optimized thread-safe storage of a list of IP v4 adresses - // - can be used e.g. as white-list or black-list of clients - // - will maintain internally a sorted list of 32-bit integers for fast lookup - // - with optional binary persistence - TIPBan = class(TSynPersistentStore) - protected - fIP4: TIntegerDynArray; - fCount: integer; - procedure LoadFromReader; override; - procedure SaveToWriter(aWriter: TFileBufferWriter); override; - public - /// register one IP to the list - function Add(const aIP: RawUTF8): boolean; - /// unregister one IP to the list - function Delete(const aIP: RawUTF8): boolean; - /// returns true if the IP is in the list - function Exists(const aIP: RawUTF8): boolean; - /// creates a TDynArray wrapper around the stored list of values - // - could be used e.g. for binary persistence - // - warning: caller should make Safe.Unlock when finished - function DynArrayLocked: TDynArray; - /// low-level access to the internal IPv4 list - // - 32-bit unsigned values are sorted, for fast O(log(n)) binary search - property IP4: TIntegerDynArray read fIP4; - published - /// how many IPs are currently banned - property Count: integer read fCount; - end; - - -{ ************ Expression Search Engine ************************** } - -type - /// exception type used by TExprParser - EExprParser = class(ESynException); - - /// identify an expression search engine node type, as used by TExprParser - TExprNodeType = (entWord, entNot, entOr, entAnd); - - /// results returned by TExprParserAbstract.Parse method - TExprParserResult = ( - eprSuccess, eprNoExpression, - eprMissingParenthesis, eprTooManyParenthesis, eprMissingFinalWord, - eprInvalidExpression, eprUnknownVariable, eprUnsupportedOperator, - eprInvalidConstantOrVariable); - - TParserAbstract = class; - - /// stores an expression search engine node, as used by TExprParser - TExprNode = class(TSynPersistent) - protected - fNext: TExprNode; - fNodeType: TExprNodeType; - function Append(node: TExprNode): boolean; - public - /// initialize a node for the search engine - constructor Create(nodeType: TExprNodeType); reintroduce; - /// recursively destroys the linked list of nodes (i.e. Next) - destructor Destroy; override; - /// browse all nodes until Next = nil - function Last: TExprNode; - /// points to the next node in the parsed tree - property Next: TExprNode read fNext; - /// what is actually stored in this node - property NodeType: TExprNodeType read fNodeType; - end; - - /// abstract class to handle word search, as used by TExprParser - TExprNodeWordAbstract = class(TExprNode) - protected - fOwner: TParserAbstract; - fWord: RawUTF8; - /// should be set from actual data before TExprParser.Found is called - fFound: boolean; - function ParseWord: TExprParserResult; virtual; abstract; - public - /// you should override this virtual constructor for proper initialization - constructor Create(aOwner: TParserAbstract; const aWord: RawUTF8); reintroduce; virtual; - end; - - /// class-reference type (metaclass) for a TExprNode - // - allow to customize the actual searching process for entWord - TExprNodeWordClass = class of TExprNodeWordAbstract; - - /// parent class of TExprParserAbstract - TParserAbstract = class(TSynPersistent) - protected - fExpression, fCurrentWord, fAndWord, fOrWord, fNotWord: RawUTF8; - fCurrent: PUTF8Char; - fCurrentError: TExprParserResult; - fFirstNode: TExprNode; - fWordClass: TExprNodeWordClass; - fWords: array of TExprNodeWordAbstract; - fWordCount: integer; - fNoWordIsAnd: boolean; - fFoundStack: array[byte] of boolean; // simple stack-based virtual machine - procedure ParseNextCurrentWord; virtual; abstract; - function ParseExpr: TExprNode; - function ParseFactor: TExprNode; - function ParseTerm: TExprNode; - procedure Clear; virtual; - // override this method to initialize fWordClass and fAnd/Or/NotWord - procedure Initialize; virtual; abstract; - /// perform the expression search over TExprNodeWord.fFound flags - // - warning: caller should check that fFirstNode<>nil (e.g. WordCount>0) - function Execute: boolean; {$ifdef HASINLINE}inline;{$endif} - public - /// initialize an expression parser - constructor Create; override; - /// finalize the expression parser - destructor Destroy; override; - /// initialize the parser from a given text expression - function Parse(const aExpression: RawUTF8): TExprParserResult; - /// try this parser class on a given text expression - // - returns '' on success, or an explicit error message (e.g. - // 'Missing parenthesis') - class function ParseError(const aExpression: RawUTF8): RawUTF8; - /// the associated text expression used to define the search - property Expression: RawUTF8 read fExpression; - /// how many words did appear in the search expression - property WordCount: integer read fWordCount; - end; - - /// abstract class to parse a text expression into nodes - // - you should inherit this class to provide actual text search - // - searched expressions can use parenthesis and &=AND -=WITHOUT +=OR operators, - // e.g. '((w1 & w2) - w3) + w4' means ((w1 and w2) without w3) or w4 - // - no operator is handled like a AND, e.g. 'w1 w2' = 'w1 & w2' - TExprParserAbstract = class(TParserAbstract) - protected - procedure ParseNextCurrentWord; override; - // may be overriden to provide custom words escaping (e.g. handle quotes) - procedure ParseNextWord; virtual; - procedure Initialize; override; - end; - - /// search expression engine using TMatch for the actual word searches - TExprParserMatch = class(TExprParserAbstract) - protected - fCaseSensitive: boolean; - fMatchedLastSet: integer; - procedure Initialize; override; - public - /// initialize the search engine - constructor Create(aCaseSensitive: boolean = true); reintroduce; - /// returns TRUE if the expression is within the text buffer - function Search(aText: PUTF8Char; aTextLen: PtrInt): boolean; overload; - /// returns TRUE if the expression is within the text buffer - function Search(const aText: RawUTF8): boolean; overload; {$ifdef HASINLINE}inline;{$endif} - end; - -const - /// may be used when overriding TExprParserAbstract.ParseNextWord method - PARSER_STOPCHAR = ['&', '+', '-', '(', ')']; - -function ToText(r: TExprParserResult): PShortString; overload; -function ToUTF8(r: TExprParserResult): RawUTF8; overload; - - -{ ************ Multi-Threading classes ************************** } - -type - /// internal item definition, used by TPendingTaskList storage - TPendingTaskListItem = packed record - /// the task should be executed when TPendingTaskList.GetTimestamp reaches - // this value - Timestamp: Int64; - /// the associated task, stored by representation as raw binary - Task: RawByteString; - end; - /// internal list definition, used by TPendingTaskList storage - TPendingTaskListItemDynArray = array of TPendingTaskListItem; - - /// handle a list of tasks, stored as RawByteString, with a time stamp - // - internal time stamps would be GetTickCount64 by default, so have a - // resolution of about 16 ms under Windows - // - you can add tasks to the internal list, to be executed after a given - // delay, using a post/peek like algorithm - // - execution delays are not expected to be accurate, but are best guess, - // according to NextTask call - // - this implementation is thread-safe, thanks to the Safe internal locker - TPendingTaskList = class(TSynPersistentLock) - protected - fCount: Integer; - fTask: TPendingTaskListItemDynArray; - fTasks: TDynArray; - function GetCount: integer; - function GetTimestamp: Int64; virtual; - public - /// initialize the list memory and resources - constructor Create; override; - /// append a task, specifying a delay in milliseconds from current time - procedure AddTask(aMilliSecondsDelayFromNow: integer; const aTask: RawByteString); virtual; - /// append several tasks, specifying a delay in milliseconds between tasks - // - first supplied delay would be computed from the current time, then - // it would specify how much time to wait between the next supplied task - procedure AddTasks(const aMilliSecondsDelays: array of integer; - const aTasks: array of RawByteString); - /// retrieve the next pending task - // - returns '' if there is no scheduled task available at the current time - // - returns the next stack as defined corresponding to its specified delay - function NextPendingTask: RawByteString; virtual; - /// flush all pending tasks - procedure Clear; virtual; - /// access to the internal TPendingTaskListItem.Timestamp stored value - // - corresponding to the current time - // - default implementation is to return GetTickCount64, with a 16 ms - // typical resolution under Windows - property Timestamp: Int64 read GetTimestamp; - /// how many pending tasks are currently defined - property Count: integer read GetCount; - /// direct low-level access to the internal task list - // - warning: this dynamic array length is the list capacity: use Count - // property to retrieve the exact number of stored items - // - use Safe.Lock/TryLock with a try ... finally Safe.Unlock block for - // thread-safe access to this array - // - items are stored in increasing Timestamp, i.e. the first item is - // the next one which would be returned by the NextPendingTask method - property Task: TPendingTaskListItemDynArray read fTask; - end; - -{$ifndef LVCL} // LVCL does not implement TEvent - -type - {$M+} - TSynBackgroundThreadAbstract = class; - TSynBackgroundThreadEvent = class; - {$M-} - - /// idle method called by TSynBackgroundThreadAbstract in the caller thread - // during remote blocking process in a background thread - // - typical use is to run Application.ProcessMessages, e.g. for - // TSQLRestClientURI.URI() to provide a responsive UI even in case of slow - // blocking remote access - // - provide the time elapsed (in milliseconds) from the request start (can be - // used e.g. to popup a temporary message to wait) - // - is call once with ElapsedMS=0 at request start - // - is call once with ElapsedMS=-1 at request ending - // - see TLoginForm.OnIdleProcess and OnIdleProcessForm in mORMotUILogin.pas - TOnIdleSynBackgroundThread = procedure(Sender: TSynBackgroundThreadAbstract; - ElapsedMS: Integer) of object; - - /// event prototype used e.g. by TSynBackgroundThreadAbstract callbacks - // - a similar signature is defined in SynCrtSock and LVCL.Classes - TNotifyThreadEvent = procedure(Sender: TThread) of object; - - /// abstract TThread with its own execution content - // - you should not use this class directly, but use either - // TSynBackgroundThreadMethodAbstract / TSynBackgroundThreadEvent / - // TSynBackgroundThreadMethod and provide a much more convenient callback - TSynBackgroundThreadAbstract = class(TThread) - protected - fProcessEvent: TEvent; - fOnBeforeExecute: TNotifyThreadEvent; - fOnAfterExecute: TNotifyThreadEvent; - fThreadName: RawUTF8; - fExecute: (exCreated,exRun,exFinished); - fExecuteLoopPause: boolean; - procedure SetExecuteLoopPause(dopause: boolean); - /// where the main process takes place - procedure Execute; override; - procedure ExecuteLoop; virtual; abstract; - public - /// initialize the thread - // - you could define some callbacks to nest the thread execution, e.g. - // assigned to TSQLRestServer.BeginCurrentThread/EndCurrentThread, or - // at least set OnAfterExecute to TSynLogFamily.OnThreadEnded - constructor Create(const aThreadName: RawUTF8; OnBeforeExecute: TNotifyThreadEvent=nil; - OnAfterExecute: TNotifyThreadEvent=nil; CreateSuspended: boolean=false); reintroduce; - /// release used resources - destructor Destroy; override; - {$ifndef HASTTHREADSTART} - /// method to be called to start the thread - // - Resume is deprecated in the newest RTL, since some OS - e.g. Linux - - // do not implement this pause/resume feature; we define here this method - // for older versions of Delphi - procedure Start; - {$endif} - {$ifdef HASTTHREADTERMINATESET} - /// properly terminate the thread - // - called by TThread.Terminate - procedure TerminatedSet; override; - {$else} - /// properly terminate the thread - // - called by reintroduced Terminate - procedure TerminatedSet; virtual; - /// reintroduced to call TeminatedSet - procedure Terminate; reintroduce; - {$endif} - /// wait for Execute/ExecuteLoop to be ended (i.e. fExecute<>exRun) - procedure WaitForNotExecuting(maxMS: integer=500); - /// temporary stop the execution of ExecuteLoop, until set back to false - // - may be used e.g. by TSynBackgroundTimer to delay the process of - // background tasks - property Pause: boolean read fExecuteLoopPause write SetExecuteLoopPause; - /// access to the low-level associated event used to notify task execution - // to the background thread - // - you may call ProcessEvent.SetEvent to trigger the internal process loop - property ProcessEvent: TEvent read fProcessEvent; - /// defined as public since may be used to terminate the processing methods - property Terminated; - end; - - /// state machine status of the TSynBackgroundThreadAbstract process - TSynBackgroundThreadProcessStep = ( - flagIdle, flagStarted, flagFinished, flagDestroying); - - /// state machine statuses of the TSynBackgroundThreadAbstract process - TSynBackgroundThreadProcessSteps = set of TSynBackgroundThreadProcessStep; - - /// abstract TThread able to run a method in its own execution content - // - typical use is a background thread for processing data or remote access, - // while the UI will be still responsive by running OnIdle event in loop: see - // e.g. how TSQLRestClientURI.OnIdle handle this in mORMot.pas unit - // - you should not use this class directly, but inherit from it and override - // the Process method, or use either TSynBackgroundThreadEvent / - // TSynBackgroundThreadMethod and provide a much more convenient callback - TSynBackgroundThreadMethodAbstract = class(TSynBackgroundThreadAbstract) - protected - fCallerEvent: TEvent; - fParam: pointer; - fCallerThreadID: TThreadID; - fBackgroundException: Exception; - fOnIdle: TOnIdleSynBackgroundThread; - fOnBeforeProcess: TNotifyThreadEvent; - fOnAfterProcess: TNotifyThreadEvent; - fPendingProcessFlag: TSynBackgroundThreadProcessStep; - fPendingProcessLock: TSynLocker; - procedure ExecuteLoop; override; - function OnIdleProcessNotify(start: Int64): integer; - function GetOnIdleBackgroundThreadActive: boolean; - function GetPendingProcess: TSynBackgroundThreadProcessStep; - procedure SetPendingProcess(State: TSynBackgroundThreadProcessStep); - // returns flagIdle if acquired, flagDestroying if terminated - function AcquireThread: TSynBackgroundThreadProcessStep; - procedure WaitForFinished(start: Int64; const onmainthreadidle: TNotifyEvent); - /// called by Execute method when fProcessParams<>nil and fEvent is notified - procedure Process; virtual; abstract; - public - /// initialize the thread - // - if aOnIdle is not set (i.e. equals nil), it will simply wait for - // the background process to finish until RunAndWait() will return - // - you could define some callbacks to nest the thread execution, e.g. - // assigned to TSQLRestServer.BeginCurrentThread/EndCurrentThread - constructor Create(aOnIdle: TOnIdleSynBackgroundThread; - const aThreadName: RawUTF8; OnBeforeExecute: TNotifyThreadEvent=nil; - OnAfterExecute: TNotifyThreadEvent=nil); reintroduce; - /// finalize the thread - destructor Destroy; override; - /// launch Process abstract method asynchronously in the background thread - // - wait until process is finished, calling OnIdle() callback in - // the meanwhile - // - any exception raised in background thread will be translated in the - // caller thread - // - returns false if self is not set, or if called from the same thread - // as it is currently processing (to avoid race condition from OnIdle() - // callback) - // - returns true when the background process is finished - // - OpaqueParam will be used to specify a thread-safe content for the - // background process - // - this method is thread-safe, that is it will wait for any started process - // already launch by another thread: you may call this method from any - // thread, even if its main purpose is to be called from the main UI thread - function RunAndWait(OpaqueParam: pointer): boolean; - /// set a callback event to be executed in loop during remote blocking - // process, e.g. to refresh the UI during a somewhat long request - // - you can assign a callback to this property, calling for instance - // Application.ProcessMessages, to execute the remote request in a - // background thread, but let the UI still be reactive: the - // TLoginForm.OnIdleProcess and OnIdleProcessForm methods of - // mORMotUILogin.pas will match this property expectations - // - if OnIdle is not set (i.e. equals nil), it will simply wait for - // the background process to finish until RunAndWait() will return - property OnIdle: TOnIdleSynBackgroundThread read fOnIdle write fOnIdle; - /// TRUE if the background thread is active, and OnIdle event is called - // during process - // - to be used e.g. to ensure no re-entrance from User Interface messages - property OnIdleBackgroundThreadActive: Boolean read GetOnIdleBackgroundThreadActive; - /// optional callback event triggered in Execute before each Process - property OnBeforeProcess: TNotifyThreadEvent read fOnBeforeProcess write fOnBeforeProcess; - /// optional callback event triggered in Execute after each Process - property OnAfterProcess: TNotifyThreadEvent read fOnAfterProcess write fOnAfterProcess; - end; - - /// background process method called by TSynBackgroundThreadEvent - // - will supply the OpaqueParam parameter as provided to RunAndWait() - // method when the Process virtual method will be executed - TOnProcessSynBackgroundThread = procedure(Sender: TSynBackgroundThreadEvent; - ProcessOpaqueParam: pointer) of object; - - /// allow background thread process of a method callback - TSynBackgroundThreadEvent = class(TSynBackgroundThreadMethodAbstract) - protected - fOnProcess: TOnProcessSynBackgroundThread; - /// just call the OnProcess handler - procedure Process; override; - public - /// initialize the thread - // - if aOnIdle is not set (i.e. equals nil), it will simply wait for - // the background process to finish until RunAndWait() will return - constructor Create(aOnProcess: TOnProcessSynBackgroundThread; - aOnIdle: TOnIdleSynBackgroundThread; const aThreadName: RawUTF8); reintroduce; - /// provide a method handler to be execute in the background thread - // - triggered by RunAndWait() method - which will wait until finished - // - the OpaqueParam as specified to RunAndWait() will be supplied here - property OnProcess: TOnProcessSynBackgroundThread read fOnProcess write fOnProcess; - end; - - /// allow background thread process of a variable TThreadMethod callback - TSynBackgroundThreadMethod = class(TSynBackgroundThreadMethodAbstract) - protected - /// just call the TThreadMethod, as supplied to RunAndWait() - procedure Process; override; - public - /// run once the supplied TThreadMethod callback - // - use this method, and not the inherited RunAndWait() - procedure RunAndWait(Method: TThreadMethod); reintroduce; - end; - - /// background process procedure called by TSynBackgroundThreadProcedure - // - will supply the OpaqueParam parameter as provided to RunAndWait() - // method when the Process virtual method will be executed - TOnProcessSynBackgroundThreadProc = procedure(ProcessOpaqueParam: pointer); - - /// allow background thread process of a procedure callback - TSynBackgroundThreadProcedure = class(TSynBackgroundThreadMethodAbstract) - protected - fOnProcess: TOnProcessSynBackgroundThreadProc; - /// just call the OnProcess handler - procedure Process; override; - public - /// initialize the thread - // - if aOnIdle is not set (i.e. equals nil), it will simply wait for - // the background process to finish until RunAndWait() will return - constructor Create(aOnProcess: TOnProcessSynBackgroundThreadProc; - aOnIdle: TOnIdleSynBackgroundThread; const aThreadName: RawUTF8); reintroduce; - /// provide a procedure handler to be execute in the background thread - // - triggered by RunAndWait() method - which will wait until finished - // - the OpaqueParam as specified to RunAndWait() will be supplied here - property OnProcess: TOnProcessSynBackgroundThreadProc read fOnProcess write fOnProcess; - end; - - /// an exception which would be raised by TSynParallelProcess - ESynParallelProcess = class(ESynException); - - /// callback implementing some parallelized process for TSynParallelProcess - // - if 0<=IndexStart<=IndexStop, it should execute some process - TSynParallelProcessMethod = procedure(IndexStart, IndexStop: integer) of object; - - /// thread executing process for TSynParallelProcess - TSynParallelProcessThread = class(TSynBackgroundThreadMethodAbstract) - protected - fMethod: TSynParallelProcessMethod; - fIndexStart, fIndexStop: integer; - procedure Start(Method: TSynParallelProcessMethod; IndexStart,IndexStop: integer); - /// executes fMethod(fIndexStart,fIndexStop) - procedure Process; override; - public - end; - - /// allow parallel execution of an index-based process in a thread pool - // - will create its own thread pool, then execute any method by spliting the - // work into each thread - TSynParallelProcess = class(TSynPersistentLock) - protected - fThreadName: RawUTF8; - fPool: array of TSynParallelProcessThread; - fThreadPoolCount: integer; - fParallelRunCount: integer; - public - /// initialize the thread pool - // - you could define some callbacks to nest the thread execution, e.g. - // assigned to TSQLRestServer.BeginCurrentThread/EndCurrentThread - // - up to MaxThreadPoolCount=32 threads could be setup (you may allow a - // bigger value, but interrest of this thread pool is to have its process - // saturating each CPU core) - // - if ThreadPoolCount is 0, no thread would be created, and process - // would take place in the current thread - constructor Create(ThreadPoolCount: integer; const ThreadName: RawUTF8; - OnBeforeExecute: TNotifyThreadEvent=nil; OnAfterExecute: TNotifyThreadEvent=nil; - MaxThreadPoolCount: integer = 32); reintroduce; virtual; - /// finalize the thread pool - destructor Destroy; override; - /// run a method in parallel, and wait for the execution to finish - // - will split Method[0..MethodCount-1] execution over the threads - // - in case of any exception during process, an ESynParallelProcess - // exception would be raised by this method - // - if OnMainThreadIdle is set, the current thread (which is expected to be - // e.g. the main UI thread) won't process anything, but call this event - // during waiting for the background threads - procedure ParallelRunAndWait(const Method: TSynParallelProcessMethod; - MethodCount: integer; const OnMainThreadIdle: TNotifyEvent = nil); - published - /// how many threads have been activated - property ParallelRunCount: integer read fParallelRunCount; - /// how many threads are currently in this instance thread pool - property ThreadPoolCount: integer read fThreadPoolCount; - /// some text identifier, used to distinguish each owned thread - property ThreadName: RawUTF8 read fThreadName; - end; - - TSynBackgroundThreadProcess = class; - - /// event callback executed periodically by TSynBackgroundThreadProcess - // - Event is wrTimeout after the OnProcessMS waiting period - // - Event is wrSignaled if ProcessEvent.SetEvent has been called - TOnSynBackgroundThreadProcess = procedure(Sender: TSynBackgroundThreadProcess; - Event: TWaitResult) of object; - - /// TThread able to run a method at a given periodic pace - TSynBackgroundThreadProcess = class(TSynBackgroundThreadAbstract) - protected - fOnProcess: TOnSynBackgroundThreadProcess; - fOnException: TNotifyEvent; - fOnProcessMS: cardinal; - fStats: TSynMonitor; - procedure ExecuteLoop; override; - public - /// initialize the thread for a periodic task processing - // - aOnProcess would be called when ProcessEvent.SetEvent is called or - // aOnProcessMS milliseconds period was elapse since last process - // - if aOnProcessMS is 0, will wait until ProcessEvent.SetEvent is called - // - you could define some callbacks to nest the thread execution, e.g. - // assigned to TSQLRestServer.BeginCurrentThread/EndCurrentThread - constructor Create(const aThreadName: RawUTF8; - aOnProcess: TOnSynBackgroundThreadProcess; aOnProcessMS: cardinal; - aOnBeforeExecute: TNotifyThreadEvent=nil; - aOnAfterExecute: TNotifyThreadEvent=nil; - aStats: TSynMonitorClass=nil; CreateSuspended: boolean=false); reintroduce; virtual; - /// finalize the thread - destructor Destroy; override; - /// access to the implementation event of the periodic task - property OnProcess: TOnSynBackgroundThreadProcess read fOnProcess; - /// event callback executed when OnProcess did raise an exception - // - supplied Sender parameter is the raised Exception instance - property OnException: TNotifyEvent read fOnException write fOnException; - published - /// access to the delay, in milliseconds, of the periodic task processing - property OnProcessMS: cardinal read fOnProcessMS write fOnProcessMS; - /// processing statistics - // - may be nil if aStats was nil in the class constructor - property Stats: TSynMonitor read fStats; - end; - - TSynBackgroundTimer = class; - - /// event callback executed periodically by TSynBackgroundThreadProcess - // - Event is wrTimeout after the OnProcessMS waiting period - // - Event is wrSignaled if ProcessEvent.SetEvent has been called - // - Msg is '' if there is no pending message in this task FIFO - // - Msg is set for each pending message in this task FIFO - TOnSynBackgroundTimerProcess = procedure(Sender: TSynBackgroundTimer; - Event: TWaitResult; const Msg: RawUTF8) of object; - - /// used by TSynBackgroundTimer internal registration list - TSynBackgroundTimerTask = record - OnProcess: TOnSynBackgroundTimerProcess; - Secs: cardinal; - NextTix: Int64; - FIFO: TRawUTF8DynArray; - end; - /// stores TSynBackgroundTimer internal registration list - TSynBackgroundTimerTaskDynArray = array of TSynBackgroundTimerTask; - - /// TThread able to run one or several tasks at a periodic pace in a - // background thread - // - as used e.g. by TSQLRest.TimerEnable/TimerDisable methods, via the - // inherited TSQLRestBackgroundTimer - // - each process can have its own FIFO of text messages - // - if you expect to update some GUI, you should rather use a TTimer - // component (with a period of e.g. 200ms), since TSynBackgroundTimer will - // use its own separated thread - TSynBackgroundTimer = class(TSynBackgroundThreadProcess) - protected - fTask: TSynBackgroundTimerTaskDynArray; - fTasks: TDynArray; - fTaskLock: TSynLocker; - procedure EverySecond(Sender: TSynBackgroundThreadProcess; Event: TWaitResult); - function Find(const aProcess: TMethod): integer; - function Add(aOnProcess: TOnSynBackgroundTimerProcess; - const aMsg: RawUTF8; aExecuteNow: boolean): boolean; - public - /// initialize the thread for a periodic task processing - // - you could define some callbacks to nest the thread execution, e.g. - // assigned to TSQLRestServer.BeginCurrentThread/EndCurrentThread, as - // made by TSQLRestBackgroundTimer.Create - constructor Create(const aThreadName: RawUTF8; - aOnBeforeExecute: TNotifyThreadEvent=nil; aOnAfterExecute: TNotifyThreadEvent=nil; - aStats: TSynMonitorClass=nil); reintroduce; virtual; - /// finalize the thread - destructor Destroy; override; - /// define a process method for a task running on a periodic number of seconds - // - for background process on a mORMot service, consider using TSQLRest - // TimerEnable/TimerDisable methods, and its associated BackgroundTimer thread - procedure Enable(aOnProcess: TOnSynBackgroundTimerProcess; aOnProcessSecs: cardinal); - /// undefine a task running on a periodic number of seconds - // - aOnProcess should have been registered by a previous call to Enable() method - // - returns true on success, false if the supplied task was not registered - // - for background process on a mORMot service, consider using TSQLRestServer - // TimerEnable/TimerDisable methods, and their TSynBackgroundTimer thread - function Disable(aOnProcess: TOnSynBackgroundTimerProcess): boolean; - /// add a message to be processed during the next execution of a task - // - supplied message will be added to the internal FIFO list associated - // with aOnProcess, then supplied to as aMsg parameter for each call - // - if aExecuteNow is true, won't wait for the next aOnProcessSecs occurence - // - aOnProcess should have been registered by a previous call to Enable() method - // - returns true on success, false if the supplied task was not registered - function EnQueue(aOnProcess: TOnSynBackgroundTimerProcess; - const aMsg: RawUTF8; aExecuteNow: boolean=false): boolean; overload; - /// add a message to be processed during the next execution of a task - // - supplied message will be added to the internal FIFO list associated - // with aOnProcess, then supplied to as aMsg parameter for each call - // - if aExecuteNow is true, won't wait for the next aOnProcessSecs occurence - // - aOnProcess should have been registered by a previous call to Enable() method - // - returns true on success, false if the supplied task was not registered - function EnQueue(aOnProcess: TOnSynBackgroundTimerProcess; - const aMsgFmt: RawUTF8; const Args: array of const; aExecuteNow: boolean=false): boolean; overload; - /// remove a message from the processing list - // - supplied message will be searched in the internal FIFO list associated - // with aOnProcess, then removed from the list if found - // - aOnProcess should have been registered by a previous call to Enable() method - // - returns true on success, false if the supplied message was not registered - function DeQueue(aOnProcess: TOnSynBackgroundTimerProcess; const aMsg: RawUTF8): boolean; - /// execute a task without waiting for the next aOnProcessSecs occurence - // - aOnProcess should have been registered by a previous call to Enable() method - // - returns true on success, false if the supplied task was not registered - function ExecuteNow(aOnProcess: TOnSynBackgroundTimerProcess): boolean; - /// returns true if there is currenly one task processed - function Processing: boolean; - /// wait until no background task is processed - procedure WaitUntilNotProcessing(timeoutsecs: integer=10); - /// low-level access to the internal task list - property Task: TSynBackgroundTimerTaskDynArray read fTask; - /// low-level access to the internal task mutex - property TaskLock: TSynLocker read fTaskLock; - end; - - /// the current state of a TBlockingProcess instance - TBlockingEvent = (evNone,evWaiting,evTimeOut,evRaised); - - {$M+} - /// a semaphore used to wait for some process to be finished - // - used e.g. by TBlockingCallback in mORMot.pas - // - once created, process would block via a WaitFor call, which would be - // released when NotifyFinished is called by the process background thread - TBlockingProcess = class(TEvent) - protected - fTimeOutMs: integer; - fEvent: TBlockingEvent; - fSafe: PSynLocker; - fOwnedSafe: boolean; - procedure ResetInternal; virtual; // override to reset associated params - public - /// initialize the semaphore instance - // - specify a time out millliseconds period after which blocking execution - // should be handled as failure (if 0 is set, default 3000 would be used) - // - an associated mutex shall be supplied - constructor Create(aTimeOutMs: integer; aSafe: PSynLocker); reintroduce; overload; virtual; - /// initialize the semaphore instance - // - specify a time out millliseconds period after which blocking execution - // should be handled as failure (if 0 is set, default 3000 would be used) - // - an associated mutex would be created and owned by this instance - constructor Create(aTimeOutMs: integer); reintroduce; overload; virtual; - /// finalize the instance - destructor Destroy; override; - /// called to wait for NotifyFinished() to be called, or trigger timeout - // - returns the final state of the process, i.e. evRaised or evTimeOut - function WaitFor: TBlockingEvent; reintroduce; overload; virtual; - /// called to wait for NotifyFinished() to be called, or trigger timeout - // - returns the final state of the process, i.e. evRaised or evTimeOut - function WaitFor(TimeOutMS: integer): TBlockingEvent; reintroduce; overload; - /// should be called by the background process when it is finished - // - the caller would then let its WaitFor method return - // - returns TRUE on success (i.e. status was not evRaised or evTimeout) - // - if the instance is already locked (e.g. when retrieved from - // TBlockingProcessPool.FromCallLocked), you may set alreadyLocked=TRUE - function NotifyFinished(alreadyLocked: boolean=false): boolean; virtual; - /// just a wrapper to reset the internal Event state to evNone - // - may be used to re-use the same TBlockingProcess instance, after - // a successfull WaitFor/NotifyFinished process - // - returns TRUE on success (i.e. status was not evWaiting), setting - // the current state to evNone, and the Call property to 0 - // - if there is a WaitFor currently in progress, returns FALSE - function Reset: boolean; virtual; - /// just a wrapper around fSafe^.Lock - procedure Lock; - /// just a wrapper around fSafe^.Unlock - procedure Unlock; - published - /// the current state of process - // - use Reset method to re-use this instance after a WaitFor process - property Event: TBlockingEvent read fEvent; - /// the time out period, in ms, as defined at constructor level - property TimeOutMs: integer read fTimeOutMS; - end; - {$M-} - - /// used to identify each TBlockingProcessPool call - // - allow to match a given TBlockingProcessPoolItem semaphore - TBlockingProcessPoolCall = type integer; - - /// a semaphore used in the TBlockingProcessPool - // - such semaphore have a Call field to identify each execution - TBlockingProcessPoolItem = class(TBlockingProcess) - protected - fCall: TBlockingProcessPoolCall; - procedure ResetInternal; override; - published - /// an unique identifier, when owned by a TBlockingProcessPool - // - Reset would restore this field to its 0 default value - property Call: TBlockingProcessPoolCall read fCall; - end; - - /// class-reference type (metaclass) of a TBlockingProcess - TBlockingProcessPoolItemClass = class of TBlockingProcessPoolItem; - - /// manage a pool of TBlockingProcessPoolItem instances - // - each call will be identified via a TBlockingProcessPoolCall unique value - // - to be used to emulate e.g. blocking execution from an asynchronous - // event-driven DDD process - // - it would also allow to re-use TEvent system resources - TBlockingProcessPool = class(TSynPersistent) - protected - fClass: TBlockingProcessPoolItemClass; - fPool: TSynObjectListLocked; - fCallCounter: TBlockingProcessPoolCall; // set TBlockingProcessPoolItem.Call - public - /// initialize the pool, for a given implementation class - constructor Create(aClass: TBlockingProcessPoolItemClass=nil); reintroduce; - /// finalize the pool - // - would also force all pending WaitFor to trigger a evTimeOut - destructor Destroy; override; - /// book a TBlockingProcess from the internal pool - // - returns nil on error (e.g. the instance is destroying) - // - or returns the blocking process instance corresponding to this call; - // its Call property would identify the call for the asynchronous callback, - // then after WaitFor, the Reset method should be run to release the mutex - // for the pool - function NewProcess(aTimeOutMs: integer): TBlockingProcessPoolItem; virtual; - /// retrieve a TBlockingProcess from its call identifier - // - may be used e.g. from the callback of the asynchronous process - // to set some additional parameters to the inherited TBlockingProcess, - // then call NotifyFinished to release the caller WaitFor - // - if leavelocked is TRUE, the returned instance would be locked: caller - // should execute result.Unlock or NotifyFinished(true) after use - function FromCall(call: TBlockingProcessPoolCall; - locked: boolean=false): TBlockingProcessPoolItem; virtual; - end; - -/// allow to fix TEvent.WaitFor() method for Kylix -// - under Windows or with FPC, will call original TEvent.WaitFor() method -function FixedWaitFor(Event: TEvent; Timeout: LongWord): TWaitResult; - -/// allow to fix TEvent.WaitFor(Event,INFINITE) method for Kylix -// - under Windows or with FPC, will call original TEvent.WaitFor() method -procedure FixedWaitForever(Event: TEvent); - -{$endif LVCL} // LVCL does not implement TEvent - - -{ ************ Operating System types and classes ************************** } - -type - /// store CPU and RAM usage for a given process - // - as used by TSystemUse class - TSystemUseData = packed record - /// when the data has been sampled - Timestamp: TDateTime; - /// percent of current Kernel-space CPU usage for this process - Kernel: single; - /// percent of current User-space CPU usage for this process - User: single; - /// how many KB of working memory are used by this process - WorkKB: cardinal; - /// how many KB of virtual memory are used by this process - VirtualKB: cardinal; - end; - /// store CPU and RAM usage history for a given process - // - as returned by TSystemUse.History - TSystemUseDataDynArray = array of TSystemUseData; - - /// low-level structure used to compute process memory and CPU usage - {$ifdef USERECORDWITHMETHODS}TProcessInfo = record - {$else}TProcessInfo = object {$endif} - private - {$ifdef MSWINDOWS} - fSysPrevIdle, fSysPrevKernel, fSysPrevUser, - fDiffIdle, fDiffKernel, fDiffUser, fDiffTotal: Int64; - {$endif} - public - /// initialize the system/process resource tracking - function Init: boolean; - /// to be called before PerSystem() or PerProcess() iteration - function Start: boolean; - /// percent of current Idle/Kernel/User CPU usage for all processes - function PerSystem(out Idle,Kernel,User: currency): boolean; - /// retrieve CPU and RAM usage for a given process - function PerProcess(PID: cardinal; Now: PDateTime; out Data: TSystemUseData; - var PrevKernel, PrevUser: Int64): boolean; - end; - - /// event handler which may be executed by TSystemUse.BackgroundExecute - // - called just after the measurement of each process CPU and RAM consumption - // - run from the background thread, so should not directly make VCL calls, - // unless BackgroundExecute is run from a VCL timer - TOnSystemUseMeasured = procedure(ProcessID: integer; const Data: TSystemUseData) of object; - - /// internal storage of CPU and RAM usage for one process - TSystemUseProcess = record - ID: integer; - Data: TSystemUseDataDynArray; - PrevKernel: Int64; - PrevUser: Int64; - end; - /// internal storage of CPU and RAM usage for a set of processes - TSystemUseProcessDynArray = array of TSystemUseProcess; - - /// monitor CPU and RAM usage of one or several processes - // - you should execute BackgroundExecute on a regular pace (e.g. every second) - // to gather low-level CPU and RAM information for the given set of processes - // - is able to keep an history of latest sample values - // - use Current class function to access a process-wide instance - TSystemUse = class(TSynPersistentLock) - protected - fProcess: TSystemUseProcessDynArray; - fProcesses: TDynArray; - fDataIndex: integer; - fProcessInfo: TProcessInfo; - fHistoryDepth: integer; - fOnMeasured: TOnSystemUseMeasured; - fTimer: TSynBackgroundTimer; - fUnsubscribeProcessOnAccessError: boolean; - function ProcessIndex(aProcessID: integer): integer; - public - /// a TSynBackgroundThreadProcess compatible event - // - matches TOnSynBackgroundTimerProcess callback signature - // - to be supplied e.g. to a TSynBackgroundTimer.Enable method so that it - // will run every few seconds and retrieve the CPU and RAM use - procedure BackgroundExecute(Sender: TSynBackgroundTimer; - Event: TWaitResult; const Msg: RawUTF8); - /// a VCL's TTimer.OnTimer compatible event - // - to be run every few seconds and retrieve the CPU and RAM use: - // ! tmrSystemUse.Interval := 10000; // every 10 seconds - // ! tmrSystemUse.OnTimer := TSystemUse.Current.OnTimerExecute; - procedure OnTimerExecute(Sender: TObject); - /// track the CPU and RAM usage of the supplied set of Process ID - // - any aProcessID[]=0 will be replaced by the current process ID - // - you can specify the number of sample values for the History() method - // - you should then execute the BackgroundExecute method of this instance - // in a VCL timer or from a TSynBackgroundTimer.Enable() registration - constructor Create(const aProcessID: array of integer; - aHistoryDepth: integer=60); reintroduce; overload; virtual; - /// track the CPU and RAM usage of the current process - // - you can specify the number of sample values for the History() method - // - you should then execute the BackgroundExecute method of this instance - // in a VCL timer or from a TSynBackgroundTimer.Enable() registration - constructor Create(aHistoryDepth: integer=60); reintroduce; overload; virtual; - /// add a Process ID to the internal tracking list - procedure Subscribe(aProcessID: integer); - /// remove a Process ID from the internal tracking list - function Unsubscribe(aProcessID: integer): boolean; - /// returns the total (Kernel+User) CPU usage percent of the supplied process - // - aProcessID=0 will return information from the current process - // - returns -1 if the Process ID was not registered via Create/Subscribe - function Percent(aProcessID: integer=0): single; overload; - /// returns the Kernel-space CPU usage percent of the supplied process - // - aProcessID=0 will return information from the current process - // - returns -1 if the Process ID was not registered via Create/Subscribe - function PercentKernel(aProcessID: integer=0): single; overload; - /// returns the User-space CPU usage percent of the supplied process - // - aProcessID=0 will return information from the current process - // - returns -1 if the Process ID was not registered via Create/Subscribe - function PercentUser(aProcessID: integer=0): single; overload; - /// returns the total (Work+Paged) RAM use of the supplied process, in KB - // - aProcessID=0 will return information from the current process - // - returns 0 if the Process ID was not registered via Create/Subscribe - function KB(aProcessID: integer=0): cardinal; overload; - /// percent of current Idle/Kernel/User CPU usage for all processes - function PercentSystem(out Idle,Kernel,User: currency): boolean; - /// returns the detailed CPU and RAM usage percent of the supplied process - // - aProcessID=0 will return information from the current process - // - returns -1 if the Process ID was not registered via Create/Subscribe - function Data(out aData: TSystemUseData; aProcessID: integer=0): boolean; overload; - /// returns the detailed CPU and RAM usage percent of the supplied process - // - aProcessID=0 will return information from the current process - // - returns Timestamp=0 if the Process ID was not registered via Create/Subscribe - function Data(aProcessID: integer=0): TSystemUseData; overload; - /// returns total (Kernel+User) CPU usage percent history of the supplied process - // - aProcessID=0 will return information from the current process - // - returns nil if the Process ID was not registered via Create/Subscribe - // - returns the sample values as an array, starting from the last to the oldest - // - you can customize the maximum depth, with aDepth < HistoryDepth - function History(aProcessID: integer=0; aDepth: integer=0): TSingleDynArray; overload; - /// returns total (Kernel+User) CPU usage percent history of the supplied - // process, as a string of two digits values - // - aProcessID=0 will return information from the current process - // - returns '' if the Process ID was not registered via Create/Subscribe - // - you can customize the maximum depth, with aDepth < HistoryDepth - // - the memory history (in MB) can be optionally returned in aDestMemoryMB - function HistoryText(aProcessID: integer=0; aDepth: integer=0; - aDestMemoryMB: PRawUTF8=nil): RawUTF8; - {$ifndef NOVARIANTS} - /// returns total (Kernel+User) CPU usage percent history of the supplied process - // - aProcessID=0 will return information from the current process - // - returns null if the Process ID was not registered via Create/Subscribe - // - returns the sample values as a TDocVariant array, starting from the - // last to the oldest, with two digits precision (as currency values) - // - you can customize the maximum depth, with aDepth < HistoryDepth - function HistoryVariant(aProcessID: integer=0; aDepth: integer=0): variant; - {$endif} - /// access to a global instance, corresponding to the current process - // - its HistoryDepth will be of 60 items - class function Current(aCreateIfNone: boolean=true): TSystemUse; - /// returns detailed CPU and RAM usage history of the supplied process - // - aProcessID=0 will return information from the current process - // - returns nil if the Process ID was not registered via Create/Subscribe - // - returns the sample values as an array, starting from the last to the oldest - // - you can customize the maximum depth, with aDepth < HistoryDepth - function HistoryData(aProcessID: integer=0; aDepth: integer=0): TSystemUseDataDynArray; overload; - /// if any unexisting (e.g. closed/killed) process should be unregistered - // - e.g. if OpenProcess() API call fails - property UnsubscribeProcessOnAccessError: boolean - read fUnsubscribeProcessOnAccessError write fUnsubscribeProcessOnAccessError; - /// how many items are stored internally, and returned by the History() method - property HistoryDepth: integer read fHistoryDepth; - /// executed when TSystemUse.BackgroundExecute finished its measurement - property OnMeasured: TOnSystemUseMeasured read fOnMeasured write fOnMeasured; - /// low-level access to the associated timer running BackgroundExecute - // - equals nil if has been associated to no timer - property Timer: TSynBackgroundTimer read fTimer write fTimer; - end; - - /// stores information about a disk partition - TDiskPartition = packed record - /// the name of this partition - // - is the Volume name under Windows, or the Device name under POSIX - name: RawUTF8; - /// where this partition has been mounted - // - e.g. 'C:' or '/home' - // - you can use GetDiskInfo(mounted) to retrieve current space information - mounted: TFileName; - /// total size (in bytes) of this partition - size: QWord; - end; - /// stores information about several disk partitions - TDiskPartitions = array of TDiskPartition; - - /// value object able to gather information about the current system memory - TSynMonitorMemory = class(TSynPersistent) - protected - FAllocatedUsed: TSynMonitorOneSize; - FAllocatedReserved: TSynMonitorOneSize; - FMemoryLoadPercent: integer; - FPhysicalMemoryFree: TSynMonitorOneSize; - FVirtualMemoryFree: TSynMonitorOneSize; - FPagingFileTotal: TSynMonitorOneSize; - FPhysicalMemoryTotal: TSynMonitorOneSize; - FVirtualMemoryTotal: TSynMonitorOneSize; - FPagingFileFree: TSynMonitorOneSize; - fLastMemoryInfoRetrievedTix: cardinal; - procedure RetrieveMemoryInfo; virtual; - function GetAllocatedUsed: TSynMonitorOneSize; - function GetAllocatedReserved: TSynMonitorOneSize; - function GetMemoryLoadPercent: integer; - function GetPagingFileFree: TSynMonitorOneSize; - function GetPagingFileTotal: TSynMonitorOneSize; - function GetPhysicalMemoryFree: TSynMonitorOneSize; - function GetPhysicalMemoryTotal: TSynMonitorOneSize; - function GetVirtualMemoryFree: TSynMonitorOneSize; - function GetVirtualMemoryTotal: TSynMonitorOneSize; - public - /// initialize the class, and its nested TSynMonitorOneSize instances - constructor Create(aTextNoSpace: boolean); reintroduce; - /// finalize the class, and its nested TSynMonitorOneSize instances - destructor Destroy; override; - /// some text corresponding to current 'free/total' memory information - // - returns e.g. '10.3 GB / 15.6 GB' - class function FreeAsText(nospace: boolean=false): ShortString; - /// how many physical memory is currently installed, as text (e.g. '32 GB'); - class function PhysicalAsText(nospace: boolean=false): TShort16; - /// returns a JSON object with the current system memory information - // - numbers would be given in KB (Bytes shl 10) - class function ToJSON: RawUTF8; - {$ifndef NOVARIANTS} - /// fill a TDocVariant with the current system memory information - // - numbers would be given in KB (Bytes shl 10) - class function ToVariant: variant; - {$endif} - published - /// Total of allocated memory used by the program - property AllocatedUsed: TSynMonitorOneSize read GetAllocatedUsed; - /// Total of allocated memory reserved by the program - property AllocatedReserved: TSynMonitorOneSize read GetAllocatedReserved; - /// Percent of memory in use for the system - property MemoryLoadPercent: integer read GetMemoryLoadPercent; - /// Total of physical memory for the system - property PhysicalMemoryTotal: TSynMonitorOneSize read GetPhysicalMemoryTotal; - /// Free of physical memory for the system - property PhysicalMemoryFree: TSynMonitorOneSize read GetPhysicalMemoryFree; - /// Total of paging file for the system - property PagingFileTotal: TSynMonitorOneSize read GetPagingFileTotal; - /// Free of paging file for the system - property PagingFileFree: TSynMonitorOneSize read GetPagingFileFree; - {$ifdef MSWINDOWS} - /// Total of virtual memory for the system - // - property not defined under Linux, since not applying to this OS - property VirtualMemoryTotal: TSynMonitorOneSize read GetVirtualMemoryTotal; - /// Free of virtual memory for the system - // - property not defined under Linux, since not applying to this OS - property VirtualMemoryFree: TSynMonitorOneSize read GetVirtualMemoryFree; - {$endif} - end; - - /// value object able to gather information about a system drive - TSynMonitorDisk = class(TSynPersistent) - protected - fName: TFileName; - {$ifdef MSWINDOWS} - fVolumeName: TFileName; - {$endif} - fAvailableSize: TSynMonitorOneSize; - fFreeSize: TSynMonitorOneSize; - fTotalSize: TSynMonitorOneSize; - fLastDiskInfoRetrievedTix: cardinal; - procedure RetrieveDiskInfo; virtual; - function GetName: TFileName; - function GetAvailable: TSynMonitorOneSize; - function GetFree: TSynMonitorOneSize; - function GetTotal: TSynMonitorOneSize; - public - /// initialize the class, and its nested TSynMonitorOneSize instances - constructor Create; override; - /// finalize the class, and its nested TSynMonitorOneSize instances - destructor Destroy; override; - /// some text corresponding to current 'free/total' disk information - // - could return e.g. 'D: 64.4 GB / 213.4 GB' - class function FreeAsText: RawUTF8; - published - /// the disk name - property Name: TFileName read GetName; - {$ifdef MSWINDOWS} - /// the volume name (only available on Windows) - property VolumeName: TFileName read fVolumeName write fVolumeName; - /// space currently available on this disk for the current user - // - may be less then FreeSize, if user quotas are specified (only taken - // into account under Windows) - property AvailableSize: TSynMonitorOneSize read GetAvailable; - {$endif MSWINDOWS} - /// free space currently available on this disk - property FreeSize: TSynMonitorOneSize read GetFree; - /// total space - property TotalSize: TSynMonitorOneSize read GetTotal; - end; - - /// hold low-level information about current memory usage - // - as filled by GetMemoryInfo() - TMemoryInfo = record - memtotal, memfree, filetotal, filefree, vmtotal, vmfree, - allocreserved, allocused: QWord; - percent: integer; - end; - -type - {$A-} - /// used to store Time Zone bias in TSynTimeZone - // - map how low-level information is stored in the Windows Registry - TTimeZoneInfo = record - Bias: integer; - bias_std: integer; - bias_dlt: integer; - change_time_std: TSynSystemTime; - change_time_dlt: TSynSystemTime; - end; - PTimeZoneInfo = ^TTimeZoneInfo; - - /// text identifier of a Time Zone, following Microsoft Windows naming - TTimeZoneID = type RawUTF8; - - /// used to store Time Zone information for a single area in TSynTimeZone - // - Delphi "object" is buggy on stack -> also defined as record with methods - {$ifdef USERECORDWITHMETHODS}TTimeZoneData = record - {$else}TTimeZoneData = object{$endif} - public - id: TTimeZoneID; - display: RawUTF8; - tzi: TTimeZoneInfo; - dyn: array of packed record - year: integer; - tzi: TTimeZoneInfo; - end; - function GetTziFor(year: integer): PTimeZoneInfo; - end; - /// used to store the Time Zone information of a TSynTimeZone class - TTimeZoneDataDynArray = array of TTimeZoneData; - {$A+} - - /// handle cross-platform time conversions, following Microsoft time zones - // - is able to retrieve accurate information from the Windows registry, - // or from a binary compressed file on other platforms (which should have been - // saved from a Windows system first) - // - each time zone will be idendified by its TzId string, as defined by - // Microsoft for its Windows Operating system - TSynTimeZone = class - protected - fZone: TTimeZoneDataDynArray; - fZones: TDynArrayHashed; - fLastZone: TTimeZoneID; - fLastIndex: integer; - fIds: TStringList; - fDisplays: TStringList; - public - /// will retrieve the default shared TSynTimeZone instance - // - locally created via the CreateDefault constructor - // - this is the usual entry point for time zone process, calling e.g. - // $ aLocalTime := TSynTimeZone.Default.NowToLocal(aTimeZoneID); - class function Default: TSynTimeZone; - /// initialize the internal storage - // - but no data is available, until Load* methods are called - constructor Create; - /// retrieve the time zones from Windows registry, or from a local file - // - under Linux, the file should be located with the executable, renamed - // with a .tz extension - may have been created via SaveToFile(''), or - // from a 'TSynTimeZone' bound resource - // "dummy" parameter exists only to disambiguate constructors for C++ - constructor CreateDefault(dummy: integer=0); - /// finalize the instance - destructor Destroy; override; - {$ifdef MSWINDOWS} - /// read time zone information from the Windows registry - procedure LoadFromRegistry; - {$endif MSWINDOWS} - /// read time zone information from a compressed file - // - if no file name is supplied, a ExecutableName.tz file would be used - procedure LoadFromFile(const FileName: TFileName=''); - /// read time zone information from a compressed memory buffer - procedure LoadFromBuffer(const Buffer: RawByteString); - /// read time zone information from a 'TSynTimeZone' resource - // - the resource should contain the SaveToBuffer compressed binary content - // - is no resource matching the TSynTimeZone class name and ResType=10 - // do exist, nothing would be loaded - // - the resource could be created as such, from a Windows system: - // ! TSynTimeZone.Default.SaveToFile('TSynTimeZone.data'); - // then compile the resource as expected, with a brcc32 .rc entry: - // ! TSynTimeZone 10 "TSynTimeZone.data" - // - you can specify a library (dll) resource instance handle, if needed - procedure LoadFromResource(Instance: THandle=0); - /// write then time zone information into a compressed file - // - if no file name is supplied, a ExecutableName.tz file would be created - procedure SaveToFile(const FileName: TFileName); - /// write then time zone information into a compressed memory buffer - function SaveToBuffer: RawByteString; - /// retrieve the time bias (in minutes) for a given date/time on a TzId - function GetBiasForDateTime(const Value: TDateTime; const TzId: TTimeZoneID; - out Bias: integer; out HaveDaylight: boolean; DateIsUTC: boolean=false): boolean; - /// retrieve the display text corresponding to a TzId - // - returns '' if the supplied TzId is not recognized - function GetDisplay(const TzId: TTimeZoneID): RawUTF8; - /// compute the UTC date/time corrected for a given TzId - function UtcToLocal(const UtcDateTime: TDateTime; const TzId: TTimeZoneID): TDateTime; - /// compute the current date/time corrected for a given TzId - function NowToLocal(const TzId: TTimeZoneID): TDateTime; - /// compute the UTC date/time for a given local TzId value - // - by definition, a local time may correspond to two UTC times, during the - // time biais period, so the returned value is informative only, and any - // stored value should be following UTC - function LocalToUtc(const LocalDateTime: TDateTime; const TzID: TTimeZoneID): TDateTime; - /// direct access to the low-level time zone information - property Zone: TTimeZoneDataDynArray read fZone; - /// direct access to the wrapper over the time zone information array - property Zones: TDynArrayHashed read fZones; - /// returns a TStringList of all TzID values - // - could be used to fill any VCL component to select the time zone - // - order in Ids[] array follows the Zone[].id information - function Ids: TStrings; - /// returns a TStringList of all Display text values - // - could be used to fill any VCL component to select the time zone - // - order in Displays[] array follows the Zone[].display information - function Displays: TStrings; - end; - - -/// retrieve low-level information about all mounted disk partitions of the system -// - returned partitions array is sorted by "mounted" ascending order -function GetDiskPartitions: TDiskPartitions; - -/// retrieve low-level information about all mounted disk partitions as text -// - returns e.g. under Linux -// '/ /dev/sda3 (19 GB), /boot /dev/sda2 (486.8 MB), /home /dev/sda4 (0.9 TB)' -// or under Windows 'C:\ System (115 GB), D:\ Data (99.3 GB)' -// - uses internally a cache unless nocache is true -// - includes the free space if withfreespace is true - e.g. '(80 GB / 115 GB)' -function GetDiskPartitionsText(nocache: boolean=false; - withfreespace: boolean=false; nospace: boolean=false): RawUTF8; - -/// returns a JSON object containing basic information about the computer -// - including Host, User, CPU, OS, freemem, freedisk... -function SystemInfoJson: RawUTF8; - -{$ifdef MSWINDOWS} - -/// a wrapper around EnumProcesses() PsAPI call -function EnumAllProcesses(out Count: Cardinal): TCardinalDynArray; - -/// a wrapper around QueryFullProcessImageNameW/GetModuleFileNameEx PsAPI call -function EnumProcessName(PID: Cardinal): RawUTF8; - -{$endif MSWINDOWS} - - -/// retrieve low-level information about current memory usage -// - as used by TSynMonitorMemory -// - under BSD, only memtotal/memfree/percent are properly returned -// - allocreserved and allocused are set only if withalloc is TRUE -function GetMemoryInfo(out info: TMemoryInfo; withalloc: boolean): boolean; - -/// retrieve low-level information about a given disk partition -// - as used by TSynMonitorDisk and GetDiskPartitionsText() -// - only under Windows the Quotas are applied separately to aAvailableBytes -// in respect to global aFreeBytes -function GetDiskInfo(var aDriveFolderOrFile: TFileName; - out aAvailableBytes, aFreeBytes, aTotalBytes: QWord - {$ifdef MSWINDOWS}; aVolumeName: PFileName = nil{$endif}): boolean; - - -{ ************ Markup (e.g. HTML or Emoji) process ******************** } - -type - /// tune AddHtmlEscapeWiki/AddHtmlEscapeMarkdown wrapper functions process - // - heHtmlEscape will escape any HTML special chars, e.g. & into & - // - heEmojiToUTF8 will convert any Emoji text into UTF-8 Unicode character, - // recognizing e.g. :joy: or :) in the text - TTextWriterHTMLEscape = set of ( - heHtmlEscape, heEmojiToUTF8); - -/// convert some wiki-like text into proper HTML -// - convert all #13#10 into

...

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

...

, *..* into .., **..** into -// .., `...` into ..., backslash espaces \\ -// \* \_ and so on, [title](http://...) and detect plain http:// as -// -// - create unordered lists from trailing * + - chars, blockquotes from -// trailing > char, and code line from 4 initial spaces -// - as with default Markdown, won't escape HTML special chars (i.e. you can -// write plain HTML in the supplied text) unless esc is set otherwise -// - only inline-style links and images are supported yet (not reference-style); -// tables aren't supported either -procedure AddHtmlEscapeMarkdown(W: TTextWriter; P: PUTF8Char; - esc: TTextWriterHTMLEscape=[heEmojiToUTF8]); - -/// escape some wiki-marked text into HTML -// - just a wrapper around AddHtmlEscapeWiki() process -function HtmlEscapeWiki(const wiki: RawUTF8; esc: TTextWriterHTMLEscape=[heHtmlEscape,heEmojiToUTF8]): RawUTF8; - -/// escape some Markdown-marked text into HTML -// - just a wrapper around AddHtmlEscapeMarkdown() process -function HtmlEscapeMarkdown(const md: RawUTF8; esc: TTextWriterHTMLEscape=[heEmojiToUTF8]): RawUTF8; - - -type - /// map the first Unicode page of Emojis, from U+1F600 to U+1F64F - // - naming comes from github/Markdown :identifiers: - TEmoji = (eNone, - eGrinning, eGrin, eJoy, eSmiley, eSmile, eSweat_smile, - eLaughing, eInnocent, eSmiling_imp, eWink, eBlush, eYum, eRelieved, - eHeart_eyes, eSunglasses, eSmirk, eNeutral_face, eExpressionless, - eUnamused, eSweat, ePensive,eConfused, eConfounded, eKissing, - eKissing_heart, eKissing_smiling_eyes, eKissing_closed_eyes, - eStuck_out_tongue, eStuck_out_tongue_winking_eye, - eStuck_out_tongue_closed_eyes, eDisappointed, eWorried, eAngry, - ePout, eCry, ePersevere, eTriumph, eDisappointed_relieved, eFrowning, - eAnguished, eFearful, eWeary, eSleepy, eTired_face, eGrimacing, eSob, - eOpen_mouth, eHushed, eCold_sweat, eScream, eAstonished, eFlushed, - eSleeping, eDizzy_face, eNo_mouth, eMask, eSmile_cat, eJoy_cat, eSmiley_cat, - eHeart_eyes_cat, eSmirk_cat, eKissing_cat, ePouting_cat, eCrying_cat_face, - eScream_cat, eSlightly_frowning_face, eSlightly_smiling_face, - eUpside_down_face, eRoll_eyes, eNo_good, oOk_woman, eBow, eSee_no_evil, - eHear_no_evil, eSpeak_no_evil, eRaising_hand, eRaised_hands, - eFrowning_woman, ePerson_with_pouting_face, ePray); - -var - /// github/Markdown compatible text of Emojis - // - e.g. 'grinning' or 'person_with_pouting_face' - EMOJI_TEXT: array[TEmoji] of RawUTF8; - /// github/Markdown compatible tag of Emojis, including trailing and ending : - // - e.g. ':grinning:' or ':person_with_pouting_face:' - EMOJI_TAG: array[TEmoji] of RawUTF8; - /// the Unicode character matching a given Emoji, after UTF-8 encoding - EMOJI_UTF8: array[TEmoji] of RawUTF8; - /// low-level access to TEmoji RTTI - used when inlining EmojiFromText() - EMOJI_RTTI: PShortString; - /// to recognize simple :) :( :| :/ :D :o :p :s characters as smilleys - EMOJI_AFTERDOTS: array['('..'|'] of TEmoji; - -/// recognize github/Markdown compatible text of Emojis -// - for instance 'sunglasses' text buffer will return eSunglasses -// - returns eNone if no case-insensitive match was found -function EmojiFromText(P: PUTF8Char; len: PtrInt): TEmoji; - {$ifdef HASINLINE}inline;{$endif} - -/// low-level parser of github/Markdown compatible text of Emojis -// - supplied P^ should point to ':' -// - will append the recognized UTF-8 Emoji if P contains e.g. :joy: or :) -// - will append ':' if no Emoji text is recognized, and return eNone -// - will try both EMOJI_AFTERDOTS[] and EMOJI_RTTI[] reference set -// - if W is nil, won't append anything, but just return the recognized TEmoji -function EmojiParseDots(var P: PUTF8Char; W: TTextWriter=nil): TEmoji; - -/// low-level conversion of UTF-8 Emoji sequences into github/Markdown :identifiers: -procedure EmojiToDots(P: PUTF8Char; W: TTextWriter); overload; - -/// conversion of UTF-8 Emoji sequences into github/Markdown :identifiers: -function EmojiToDots(const text: RawUTF8): RawUTF8; overload; - -/// low-level conversion of github/Markdown :identifiers: into UTF-8 Emoji sequences -procedure EmojiFromDots(P: PUTF8Char; W: TTextWriter); overload; - -/// conversion of github/Markdown :identifiers: into UTF-8 Emoji sequences -function EmojiFromDots(const text: RawUTF8): RawUTF8; overload; - - -{ ************ Command Line and Console process ************************** } - -type - /// available console colors (under Windows at least) - TConsoleColor = ( - ccBlack, ccBlue, ccGreen, ccCyan, ccRed, ccMagenta, ccBrown, ccLightGray, - ccDarkGray, ccLightBlue, ccLightGreen, ccLightCyan, ccLightRed, ccLightMagenta, - ccYellow, ccWhite); - -{$ifdef FPC}{$ifdef Linux} -var - stdoutIsTTY: boolean; -{$endif}{$endif} - -/// change the console text writing color -// - you should call this procedure to initialize StdOut global variable, if -// you manually initialized the Windows console, e.g. via the following code: -// ! AllocConsole; -// ! TextColor(ccLightGray); // initialize internal console context -procedure TextColor(Color: TConsoleColor); - -/// write some text to the console using a given color -procedure ConsoleWrite(const Text: RawUTF8; Color: TConsoleColor=ccLightGray; - NoLineFeed: boolean=false; NoColor: boolean=false); overload; - -/// write some text to the console using a given color -procedure ConsoleWrite(const Fmt: RawUTF8; const Args: array of const; - Color: TConsoleColor=ccLightGray; NoLineFeed: boolean=false); overload; - -/// change the console text background color -procedure TextBackground(Color: TConsoleColor); - -/// will wait for the ENTER key to be pressed, processing Synchronize() pending -// notifications, and the internal Windows Message loop (on this OS) -// - to be used e.g. for proper work of console applications with interface-based -// service implemented as optExecInMainThread -procedure ConsoleWaitForEnterKey; - -/// read all available content from stdin -// - could be used to retrieve some file piped to the command line -// - the content is not converted, so will follow the encoding used for storage -function ConsoleReadBody: RawByteString; - -{$ifdef MSWINDOWS} -/// low-level access to the keyboard state of a given key -function ConsoleKeyPressed(ExpectedKey: Word): Boolean; -{$endif} - -/// direct conversion of a UTF-8 encoded string into a console OEM-encoded String -// - under Windows, will use the CP_OEMCP encoding -// - under Linux, will expect the console to be defined with UTF-8 encoding -function Utf8ToConsole(const S: RawUTF8): RawByteString; - {$ifndef MSWINDOWS}{$ifdef HASINLINE}inline;{$endif}{$endif} - -/// direct conversion of a VCL string into a console OEM-encoded String -// - under Windows, will use the CP_OEMCP encoding -// - under Linux, will expect the console to be defined with UTF-8 encoding -function StringToConsole(const S: string): RawByteString; - {$ifndef MSWINDOWS}{$ifdef HASINLINE}inline;{$endif}{$endif} - -/// could be used in the main program block of a console application to -// handle unexpected fatal exceptions -// - typical use may be: -// !begin -// ! try -// ! ... // main console process -// ! except -// ! on E: Exception do -// ! ConsoleShowFatalException(E); -// ! end; -// !end. -procedure ConsoleShowFatalException(E: Exception; WaitForEnterKey: boolean=true); - -var - /// low-level handle used for console writing - // - may be overriden when console is redirected - // - is initialized when TextColor() is called - StdOut: THandle; - - -{$ifndef NOVARIANTS} -type - /// an interface to process the command line switches over a console - // - as implemented e.g. by TCommandLine class - // - can implement any process, optionally with console interactivity - ICommandLine = interface - ['{77AB427C-1025-488B-8E04-3E62C8100E62}'] - /// returns a command line switch value as UTF-8 text - // - you can specify a prompt text, when asking for any missing switch - function AsUTF8(const Switch, Default: RawUTF8; const Prompt: string): RawUTF8; - /// returns a command line switch value as VCL string text - // - you can specify a prompt text, when asking for any missing switch - function AsString(const Switch: RawUTF8; const Default, Prompt: string): string; - /// returns a command line switch value as integer - // - you can specify a prompt text, when asking for any missing switch - function AsInt(const Switch: RawUTF8; Default: Int64; const Prompt: string): Int64; - /// returns a command line switch ISO-8601 value as date value - // - here dates are expected to be encoded with ISO-8601, i.e. YYYY-MM-DD - // - you can specify a prompt text, when asking for any missing switch - function AsDate(const Switch: RawUTF8; Default: TDateTime; const Prompt: string): TDateTime; - /// returns a command line switch value as enumeration ordinal - // - RTTI will be used to check for the enumeration text, or plain integer - // value will be returned as ordinal value - // - you can specify a prompt text, when asking for any missing switch - function AsEnum(const Switch, Default: RawUTF8; TypeInfo: pointer; - const Prompt: string): integer; - /// returns all command line values as an array of UTF-8 text - // - i.e. won't interpret the various switches in the input parameters - // - as created e.g. by TCommandLine.CreateAsArray constructor - function AsArray: TRawUTF8DynArray; - /// serialize all recognized switches as UTF-8 JSON text - function AsJSON(Format: TTextWriterJSONFormat): RawUTF8; - /// equals TRUE if the -noprompt switch has been supplied - // - may be used to force pure execution without console interaction, - // e.g. when run from another process - function NoPrompt: boolean; - /// change the console text color - // - do nothing if NoPrompt is TRUE - procedure TextColor(Color: TConsoleColor); - /// write some console text, with an optional color - // - will output the text even if NoPrompt is TRUE - procedure Text(const Fmt: RawUTF8; const Args: array of const; - Color: TConsoleColor=ccLightGray); - end; - - /// a class to process the command line switches, with console interactivity - // - is able to redirect all Text() output to an internal UTF-8 storage, - // in addition or instead of the console (to be used e.g. from a GUI) - // - implements ICommandLine interface - TCommandLine = class(TInterfacedObjectWithCustomCreate, ICommandLine) - private - fValues: TDocVariantData; - fNoPrompt: boolean; - fNoConsole: boolean; - fLines: TRawUTF8DynArray; - procedure SetNoConsole(value: boolean); - public - /// initialize the internal storage from the command line - // - will parse "-switch1 value1 -switch2 value2" layout - // - stand-alone "-switch1 -switch2 value2" will a create switch1=true value - constructor Create; overload; override; - /// initialize the internal storage from the command line - // - will set paramstr(firstParam)..paramstr(paramcount) in fValues as array - // - may be used e.g. for "val1 val2 val3" command line layout - constructor CreateAsArray(firstParam: integer); - /// initialize the internal storage with some ready-to-use switches - // - will also set the NoPrompt option, and set the supplied NoConsole value - // - may be used e.g. from a graphical interface instead of console mode - constructor Create(const switches: variant; - aNoConsole: boolean=true); reintroduce; overload; - /// initialize the internal storage with some ready-to-use name/value pairs - // - will also set the NoPrompt option, and set the supplied NoConsole value - // - may be used e.g. from a graphical interface instead of console mode - constructor Create(const NameValuePairs: array of const; - aNoConsole: boolean=true); reintroduce; overload; - /// returns a command line switch value as UTF-8 text - // - you can specify a prompt text, when asking for any missing switch - function AsUTF8(const Switch, Default: RawUTF8; const Prompt: string): RawUTF8; - /// returns a command line switch value as VCL string text - // - you can specify a prompt text, when asking for any missing switch - function AsString(const Switch: RawUTF8; const Default, Prompt: string): string; - /// returns a command line switch value as integer - // - you can specify a prompt text, when asking for any missing switch - function AsInt(const Switch: RawUTF8; Default: Int64; const Prompt: string): Int64; - /// returns a command line switch ISO-8601 value as date value - // - here dates are expected to be encoded with ISO-8601, i.e. YYYY-MM-DD - // - you can specify a prompt text, when asking for any missing switch - function AsDate(const Switch: RawUTF8; Default: TDateTime; const Prompt: string): TDateTime; - /// returns a command line switch value as enumeration ordinal - // - RTTI will be used to check for the enumeration text, or plain integer - // value will be returned as ordinal value - // - you can specify a prompt text, when asking for any missing switch - function AsEnum(const Switch, Default: RawUTF8; TypeInfo: pointer; - const Prompt: string): integer; - /// returns all command line values as an array of UTF-8 text - // - i.e. won't interpret the various switches in the input parameters - // - as created e.g. by TCommandLine.CreateAsArray constructor - function AsArray: TRawUTF8DynArray; - /// serialize all recognized switches as UTF-8 JSON text - function AsJSON(Format: TTextWriterJSONFormat): RawUTF8; - /// equals TRUE if the -noprompt switch has been supplied - // - may be used to force pure execution without console interaction, - // e.g. when run from another process - function NoPrompt: boolean; - /// change the console text color - // - do nothing if NoPrompt is TRUE - procedure TextColor(Color: TConsoleColor); - /// write some console text, with an optional color - // - will output the text even if NoPrompt=TRUE, but not if NoConsole=TRUE - // - will append the text to the internal storage, available from ConsoleText - procedure Text(const Fmt: RawUTF8; const Args: array of const; - Color: TConsoleColor=ccLightGray); - /// low-level access to the internal switches storage - property Values: TDocVariantData read fValues; - /// if Text() should be redirected to ConsoleText internal storage - // - and don't write anything to the console - // - should be associated with NoProperty = TRUE property - property NoConsole: boolean read fNoConsole write SetNoConsole; - /// low-level access to the internal UTF-8 console lines storage - property ConsoleLines: TRawUTF8DynArray read fLines; - /// returns the UTF-8 text as inserted by Text() calls - // - line feeds will be included to the ConsoleLines[] values - function ConsoleText(const LineFeed: RawUTF8=sLineBreak): RawUTF8; - end; -{$endif NOVARIANTS} - -{ ************ TSynTable types and classes ************************** } - -{$define SORTCOMPAREMETHOD} -{ if defined, the field content comparison will use a method instead of fixed - functions - could be mandatory for tftArray field kind } - -type - /// exception raised by all TSynTable related code - ETableDataException = class(ESynException); - - /// the available types for any TSynTable field property - // - this is used in our so-called SBF compact binary format - // (similar to BSON or Protocol Buffers) - // - those types are used for both storage and JSON conversion - // - basic types are similar to SQLite3, i.e. Int64/Double/UTF-8/Blob - // - storage can be of fixed size, or of variable length - // - you can specify to use WinAnsi encoding instead of UTF-8 for string storage - // (it can use less space on disk than UTF-8 encoding) - // - BLOB fields can be either internal (i.e. handled by TSynTable like a - // RawByteString text storage), either external (i.e. must be stored in a dedicated - // storage structure - e.g. another TSynBigTable instance) - TSynTableFieldType = - (// unknown or not defined field type - tftUnknown, - // some fixed-size field value - tftBoolean, tftUInt8, tftUInt16, tftUInt24, tftInt32, tftInt64, - tftCurrency, tftDouble, - // some variable-size field value - tftVarUInt32, tftVarInt32, tftVarUInt64, - // text storage - tftWinAnsi, tftUTF8, - // BLOB fields - tftBlobInternal, tftBlobExternal, - // other variable-size field value - tftVarInt64); - - /// set of available field types for TSynTable - TSynTableFieldTypes = set of TSynTableFieldType; - - /// available option types for a field property - // - tfoIndex is set if an index must be created for this field - // - tfoUnique is set if field values must be unique (if set, the tfoIndex - // will be always forced) - // - tfoCaseInsensitive can be set to make no difference between 'a' and 'A' - // (by default, comparison is case-sensitive) - this option has an effect - // not only if tfoIndex or tfoUnique is set, but also for iterating search - TSynTableFieldOption = ( - tfoIndex, tfoUnique, tfoCaseInsensitive); - - /// set of option types for a field - TSynTableFieldOptions = set of TSynTableFieldOption; - - /// used to store bit set for all available fiels in a Table - // - with current format, maximum field count is 64 - TSynTableFieldBits = set of 0..63; - - /// an custom RawByteString type used to store internaly a data in - // our SBF compact binary format - TSBFString = type RawByteString; - - /// function prototype used to retrieve the index of a specified property name - // - 'ID' is handled separately: here must be available only the custom fields - TSynTableFieldIndex = function(const PropName: RawUTF8): integer of object; - - /// the recognized operators for a TSynTableStatement where clause - TSynTableStatementOperator = ( - opEqualTo, - opNotEqualTo, - opLessThan, - opLessThanOrEqualTo, - opGreaterThan, - opGreaterThanOrEqualTo, - opIn, - opIsNull, - opIsNotNull, - opLike, - opContains, - opFunction); - - TSynTableFieldProperties = class; - - /// one recognized SELECT expression for TSynTableStatement - TSynTableStatementSelect = record - /// the column SELECTed for the SQL statement, in the expected order - // - contains 0 for ID/RowID, or the RTTI field index + 1 - Field: integer; - /// an optional integer to be added - // - recognized from .. +123 .. -123 patterns in the select - ToBeAdded: integer; - /// the optional column alias, e.g. 'MaxID' for 'max(id) as MaxID' - Alias: RawUTF8; - /// the optional function applied to the SELECTed column - // - e.g. Max(RowID) would store 'Max' and SelectField[0]=0 - // - but Count( * ) would store 'Count' and SelectField[0]=0, and - // set FunctionIsCountStart = TRUE - FunctionName: RawUTF8; - /// if the function needs a special process - // - e.g. funcCountStar for the special Count( * ) expression or - // funcDistinct, funcMax for distinct(...)/max(...) aggregation - FunctionKnown: (funcNone, funcCountStar, funcDistinct, funcMax); - /// MongoDB-like sub field e.g. 'mainfield.subfield1.subfield2' - // - still identifying 'mainfield' in Field index, and setting - // SubField='.subfield1.subfield2' - SubField: RawUTF8; - end; - - /// the recognized SELECT expressions for TSynTableStatement - TSynTableStatementSelectDynArray = array of TSynTableStatementSelect; - - /// one recognized WHERE expression for TSynTableStatement - TSynTableStatementWhere = record - /// any '(' before the actual expression - ParenthesisBefore: RawUTF8; - /// any ')' after the actual expression - ParenthesisAfter: RawUTF8; - /// expressions are evaluated as AND unless this field is set to TRUE - JoinedOR: boolean; - /// if this expression is preceded by a NOT modifier - NotClause: boolean; - /// the index of the field used for the WHERE expression - // - WhereField=0 for ID, 1 for field # 0, 2 for field #1, - // and so on... (i.e. WhereField = RTTI field index +1) - Field: integer; - /// MongoDB-like sub field e.g. 'mainfield.subfield1.subfield2' - // - still identifying 'mainfield' in Field index, and setting - // SubField='.subfield1.subfield2' - SubField: RawUTF8; - /// the operator of the WHERE expression - Operator: TSynTableStatementOperator; - /// the SQL function name associated to a Field and Value - // - e.g. 'INTEGERDYNARRAYCONTAINS' and Field=0 for - // IntegerDynArrayContains(RowID,10) and ValueInteger=10 - // - Value does not contain anything - FunctionName: RawUTF8; - /// the value used for the WHERE expression - Value: RawUTF8; - /// the raw value SQL buffer used for the WHERE expression - ValueSQL: PUTF8Char; - /// the raw value SQL buffer length used for the WHERE expression - ValueSQLLen: integer; - /// an integer representation of WhereValue (used for ID check e.g.) - ValueInteger: integer; - /// used to fast compare with SBF binary compact formatted data - ValueSBF: TSBFString; - {$ifndef NOVARIANTS} - /// the value used for the WHERE expression, encoded as Variant - // - may be a TDocVariant for the IN operator - ValueVariant: variant; - {$endif} - end; - - /// the recognized WHERE expressions for TSynTableStatement - TSynTableStatementWhereDynArray = array of TSynTableStatementWhere; - - /// used to parse a SELECT SQL statement, following the SQlite3 syntax - // - handle basic REST commands, i.e. a SELECT over a single table (no JOIN) - // with its WHERE clause, and result column aliases - // - handle also aggregate functions like "SELECT Count( * ) FROM TableName" - // - will also parse any LIMIT, OFFSET, ORDER BY, GROUP BY statement clause - TSynTableStatement = class - protected - fSQLStatement: RawUTF8; - fSelect: TSynTableStatementSelectDynArray; - fSelectFunctionCount: integer; - fTableName: RawUTF8; - fWhere: TSynTableStatementWhereDynArray; - fOrderByField: TSQLFieldIndexDynArray; - fGroupByField: TSQLFieldIndexDynArray; - fWhereHasParenthesis, fHasSelectSubFields, fWhereHasSubFields: boolean; - fOrderByDesc: boolean; - fLimit: integer; - fOffset: integer; - fWriter: TJSONWriter; - public - /// parse the given SELECT SQL statement and retrieve the corresponding - // parameters into this class read-only properties - // - the supplied GetFieldIndex() method is used to populate the - // SelectedFields and Where[].Field properties - // - SimpleFieldsBits is used for '*' field names - // - SQLStatement is left '' if the SQL statement is not correct - // - if SQLStatement is set, the caller must check for TableName to match - // the expected value, then use the Where[] to retrieve the content - // - if FieldProp is set, then the Where[].ValueSBF property is initialized - // with the SBF equivalence of the Where[].Value - constructor Create(const SQL: RawUTF8; GetFieldIndex: TSynTableFieldIndex; - SimpleFieldsBits: TSQLFieldBits=[0..MAX_SQLFIELDS-1]; - FieldProp: TSynTableFieldProperties=nil); - /// compute the SELECT column bits from the SelectFields array - // - optionally set Select[].SubField into SubFields[Select[].Field] - // (e.g. to include specific fields from MongoDB embedded document) - procedure SelectFieldBits(var Fields: TSQLFieldBits; var withID: boolean; - SubFields: PRawUTF8Array=nil); - - /// the SELECT SQL statement parsed - // - equals '' if the parsing failed - property SQLStatement: RawUTF8 read fSQLStatement; - /// the column SELECTed for the SQL statement, in the expected order - property Select: TSynTableStatementSelectDynArray read fSelect; - /// if the SELECTed expression of this SQL statement have any function defined - property SelectFunctionCount: integer read fSelectFunctionCount; - /// the retrieved table name - property TableName: RawUTF8 read fTableName; - /// if any Select[].SubField was actually set - property HasSelectSubFields: boolean read fHasSelectSubFields; - /// the WHERE clause of this SQL statement - property Where: TSynTableStatementWhereDynArray read fWhere; - /// if the WHERE clause contains any ( ) parenthesis expression - property WhereHasParenthesis: boolean read fWhereHasParenthesis; - /// if the WHERE clause contains any Where[].SubField - property WhereHasSubFields: boolean read fWhereHasSubFields; - /// recognize an GROUP BY clause with one or several fields - // - here 0 = ID, otherwise RTTI field index +1 - property GroupByField: TSQLFieldIndexDynArray read fGroupByField; - /// recognize an ORDER BY clause with one or several fields - // - here 0 = ID, otherwise RTTI field index +1 - property OrderByField: TSQLFieldIndexDynArray read fOrderByField; - /// false for default ASC order, true for DESC attribute - property OrderByDesc: boolean read fOrderByDesc; - /// the number specified by the optional LIMIT ... clause - // - set to 0 by default (meaning no LIMIT clause) - property Limit: integer read fLimit; - /// the number specified by the optional OFFSET ... clause - // - set to 0 by default (meaning no OFFSET clause) - property Offset: integer read fOffset; - /// optional associated writer - property Writer: TJSONWriter read fWriter write fWriter; - end; - - /// function prototype used to retrieve the RECORD data of a specified Index - // - the index is not the per-ID index, but the "physical" index, i.e. the - // index value used to retrieve data from low-level (and faster) method - // - should return nil if Index is out of range - // - caller must provide a temporary storage buffer to be used optionally - TSynTableGetRecordData = function( - Index: integer; var aTempData: RawByteString): pointer of object; - - TSynTable = class; - - {$ifdef SORTCOMPAREMETHOD} - /// internal value used by TSynTableFieldProperties.SortCompare() method to - // avoid stack allocation - TSortCompareTmp = record - PB1, PB2: PByte; - L1,L2: integer; - end; - {$endif} - - /// store the type properties of a given field / database column - TSynTableFieldProperties = class - protected - /// used during OrderedIndexSort to prevent stack usage - SortPivot: pointer; - {$ifdef SORTCOMPAREMETHOD} - /// internal value used by SortCompare() method to avoid stack allocation - SortCompareTmp: TSortCompareTmp; - {$endif} - /// these two temporary buffers are used to call TSynTableGetRecordData - DataTemp1, DataTemp2: RawByteString; - /// the associated table which own this field property - Owner: TSynTable; - /// the global size of a default field value, as encoded - // in our SBF compact binary format - fDefaultFieldLength: integer; - /// a default field data, as encoded in our SBF compact binary format - fDefaultFieldData: TSBFString; - /// last >=0 value returned by the last OrderedIndexFindAdd() call - fOrderedIndexFindAdd: integer; - /// used for internal QuickSort of OrderedIndex[] - // - call SortCompare() for sorting the items - procedure OrderedIndexSort(L,R: PtrInt); - /// retrieve an index from OrderedIndex[] of the given value - // - call SortCompare() to compare to the reference value - function OrderedIndexFind(Value: pointer): PtrInt; - /// retrieve an index where a Value must be added into OrderedIndex[] - // - call SortCompare() to compare to the reference value - // - returns -1 if Value is there, or the index where to insert - // - the returned value (if >= 0) will be stored in fOrderedIndexFindAdd - function OrderedIndexFindAdd(Value: pointer): PtrInt; - /// set OrderedIndexReverse[OrderedIndex[aOrderedIndex]] := aOrderedIndex; - procedure OrderedIndexReverseSet(aOrderedIndex: integer); - public - /// the field name - Name: RawUTF8; - /// kind of field (defines both value type and storage to be used) - FieldType: TSynTableFieldType; - /// the fixed-length size, or -1 for a varInt, -2 for a variable string - FieldSize: integer; - /// options of this field - Options: TSynTableFieldOptions; - /// contains the offset of this field, in case of fixed-length field - // - normally, fixed-length fields are stored in the beginning of the record - // storage: in this case, a value >= 0 will point to the position of the - // field value of this field - // - if the value is < 0, its absolute will be the field number to be counted - // after TSynTable.fFieldVariableOffset (-1 for first item) - Offset: integer; - /// number of the field in the table (starting at 0) - FieldNumber: integer; - /// if allocated, contains the storage indexes of every item, in sorted order - // - only available if tfoIndex is in Options - // - the index is not the per-ID index, but the "physical" index, i.e. the - // index value used to retrieve data from low-level (and faster) method - OrderedIndex: TIntegerDynArray; - /// if allocated, contains the reverse storage index of OrderedIndex - // - i.e. OrderedIndexReverse[OrderedIndex[i]] := i; - // - used to speed up the record update procedure with huge number of - // records - OrderedIndexReverse: TIntegerDynArray; - /// number of items in OrderedIndex[] - // - is set to 0 when the content has been modified (mark force recreate) - OrderedIndexCount: integer; - /// if set to TRUE after an OrderedIndex[] refresh but with not sorting - // - OrderedIndexSort(0,OrderedIndexCount-1) must be called before using - // the OrderedIndex[] array - // - you should call OrderedIndexRefresh method to ensure it is sorted - OrderedIndexNotSorted: boolean; - /// all TSynValidate instances registered per each field - Filters: TSynObjectList; - /// all TSynValidate instances registered per each field - Validates: TSynObjectList; - /// low-level binary comparison used by IDSort and TSynTable.IterateJSONValues - // - P1 and P2 must point to the values encoded in our SBF compact binary format - {$ifdef SORTCOMPAREMETHOD} - function SortCompare(P1,P2: PUTF8Char): PtrInt; - {$else} - SortCompare: TUTF8Compare; - {$endif} - - /// read entry from a specified file reader - constructor CreateFrom(var RD: TFileBufferReader); - /// release associated memory and objects - destructor Destroy; override; - /// save entry to a specified file writer - procedure SaveTo(WR: TFileBufferWriter); - /// decode the value from our SBF compact binary format into UTF-8 JSON - // - returns the next FieldBuffer value - function GetJSON(FieldBuffer: pointer; W: TTextWriter): pointer; - /// decode the value from our SBF compact binary format into UTF-8 text - // - this method does not check for FieldBuffer to be not nil -> caller - // should check this explicitely - function GetValue(FieldBuffer: pointer): RawUTF8; - /// decode the value from a record buffer into an Boolean - // - will call Owner.GetData to retrieve then decode the field SBF content - function GetBoolean(RecordBuffer: pointer): Boolean; - {$ifdef HASINLINE}inline;{$endif} - /// decode the value from a record buffer into an integer - // - will call Owner.GetData to retrieve then decode the field SBF content - function GetInteger(RecordBuffer: pointer): Integer; - /// decode the value from a record buffer into an Int64 - // - will call Owner.GetData to retrieve then decode the field SBF content - function GetInt64(RecordBuffer: pointer): Int64; - /// decode the value from a record buffer into an floating-point value - // - will call Owner.GetData to retrieve then decode the field SBF content - function GetDouble(RecordBuffer: pointer): Double; - /// decode the value from a record buffer into an currency value - // - will call Owner.GetData to retrieve then decode the field SBF content - function GetCurrency(RecordBuffer: pointer): Currency; - /// decode the value from a record buffer into a RawUTF8 string - // - will call Owner.GetData to retrieve then decode the field SBF content - function GetRawUTF8(RecordBuffer: pointer): RawUTF8; - {$ifndef NOVARIANTS} - /// decode the value from our SBF compact binary format into a Variant - function GetVariant(FieldBuffer: pointer): Variant; overload; - {$ifdef HASINLINE}inline;{$endif} - /// decode the value from our SBF compact binary format into a Variant - procedure GetVariant(FieldBuffer: pointer; var result: Variant); overload; - {$endif} - /// retrieve the binary length (in bytes) of some SBF compact binary format - function GetLength(FieldBuffer: pointer): Integer; - {$ifdef HASINLINE}inline;{$endif} - /// create some SBF compact binary format from a Delphi binary value - // - will return '' if the field type doesn't match a boolean - function SBF(const Value: Boolean): TSBFString; overload; - /// create some SBF compact binary format from a Delphi binary value - // - will encode any byte, word, integer, cardinal, Int64 value - // - will return '' if the field type doesn't match an integer - function SBF(const Value: Int64): TSBFString; overload; - /// create some SBF compact binary format from a Delphi binary value - // - will encode any byte, word, integer, cardinal value - // - will return '' if the field type doesn't match an integer - function SBF(const Value: Integer): TSBFString; overload; - /// create some SBF compact binary format from a Delphi binary value - // - will return '' if the field type doesn't match a currency - // - we can't use SBF() method name because of Currency/Double ambiguity - function SBFCurr(const Value: Currency): TSBFString; - /// create some SBF compact binary format from a Delphi binary value - // - will return '' if the field type doesn't match a floating-point - // - we can't use SBF() method name because of Currency/Double ambiguity - function SBFFloat(const Value: Double): TSBFString; - /// create some SBF compact binary format from a Delphi binary value - // - expect a RawUTF8 string: will be converted to WinAnsiString - // before storage, for tftWinAnsi - // - will return '' if the field type doesn't match a string - function SBF(const Value: RawUTF8): TSBFString; overload; - /// create some SBF compact binary format from a BLOB memory buffer - // - will return '' if the field type doesn't match tftBlobInternal - function SBF(Value: pointer; ValueLen: integer): TSBFString; overload; - /// convert any UTF-8 encoded value into our SBF compact binary format - // - can be used e.g. from a WHERE clause, for fast comparison in - // TSynTableStatement.WhereValue content using OrderedIndex[] - // - is the reverse of GetValue/GetRawUTF8 methods above - function SBFFromRawUTF8(const aValue: RawUTF8): TSBFString; - {$ifndef NOVARIANTS} - /// create some SBF compact binary format from a Variant value - function SBF(const Value: Variant): TSBFString; overload; - {$endif} - - /// will update then sort the array of indexes used for the field index - // - the OrderedIndex[] array is first refreshed according to the - // aOldIndex, aNewIndex parameters: aOldIndex=-1 for Add, aNewIndex=-1 for - // Delete, or both >= 0 for update - // - call with both indexes = -1 will sort the existing OrderedIndex[] array - // - GetData property must have been set with a method returning a pointer - // to the field data for a given index (this index is not the per-ID index, - // but the "physical" index, i.e. the index value used to retrieve data - // from low-level (and fast) GetData method) - // - aOldRecordData and aNewRecordData can be specified in order to guess - // if the field data has really been modified (speed up the update a lot - // to only sort indexed fields if its content has been really modified) - // - returns FALSE if any parameter is invalid - function OrderedIndexUpdate(aOldIndex, aNewIndex: integer; - aOldRecordData, aNewRecordData: pointer): boolean; - /// retrieve one or more "physical" indexes matching a WHERE Statement - // - is faster than O(1) GetIteraring(), because will use O(log(n)) binary - // search using the OrderedIndex[] array - // - returns the resulting indexes as a a sorted list in MatchIndex/MatchIndexCount - // - if the indexes are already present in the list, won't duplicate them - // - WhereSBFValue must be a valid SBF formated field buffer content - // - the Limit parameter is similar to the SQL LIMIT clause: if greater than 0, - // an upper bound on the number of rows returned is placed (e.g. set Limit=1 - // to only retrieve the first match) - // - GetData property must have been set with a method returning a pointer - // to the field data for a given index (this index is not the per-ID index, - // but the "physical" index, i.e. the index value used to retrieve data - // from low-level (and fast) GetData method) - // - in this method, indexes are not the per-ID indexes, but the "physical" - // indexes, i.e. each index value used to retrieve data from low-level - // (and fast) GetData method - function OrderedIndexMatch(WhereSBFValue: pointer; - var MatchIndex: TIntegerDynArray; var MatchIndexCount: integer; - Limit: Integer=0): Boolean; - /// will force refresh the OrderedIndex[] array - // - to be called e.g. if OrderedIndexNotSorted = TRUE, if you want to - // access to the OrderedIndex[] array - procedure OrderedIndexRefresh; - /// register a custom filter or validation rule to the class for this field - // - this will be used by Filter() and Validate() methods - // - will return the specified associated TSynFilterOrValidate instance - // - a TSynValidateTableUniqueField is always added by - // TSynTable.AfterFieldModif if tfoUnique is set in Options - function AddFilterOrValidate(aFilter: TSynFilterOrValidate): TSynFilterOrValidate; - /// check the registered constraints - // - returns '' on success - // - returns an error message e.g. if a tftUnique constraint failed - // - RecordIndex=-1 in case of adding, or the physical index of the updated record - function Validate(RecordBuffer: pointer; RecordIndex: integer): string; - /// some default SBF compact binary format content - property SBFDefault: TSBFString read fDefaultFieldData; - end; - - -{$ifndef DELPHI5OROLDER} - - /// a pointer to structure used to store a TSynTable record - PSynTableData = ^TSynTableData; - - {$A-} { packet object not allowed since Delphi 2009 :( } - /// used to store a TSynTable record using our SBF compact binary format - // - this object can be created on the stack - // - it is mapped into a variant TVarData, to be retrieved by the - // TSynTable.Data method - but direct allocation of a TSynTableData on the - // stack is faster (due to the Variant overhead) - // - is defined either as an object either as a record, due to a bug - // in Delphi 2009/2010 compiler (at least): this structure is not initialized - // if defined as an object on the stack, but will be as a record :( - {$ifdef USERECORDWITHMETHODS}TSynTableData = record - {$else}TSynTableData = object {$endif UNICODE} - private - VType: cardinal; // defined as cardinal not as word for proper aligment - VID: integer; - VTable: TSynTable; - VValue: TSBFString; - {$ifndef NOVARIANTS} - function GetFieldVarData(FieldName: PUTF8Char; FieldNameLen: PtrInt; var Value: TVarData): boolean; - procedure GetFieldVariant(const FieldName: RawUTF8; var result: Variant); - function GetField(const FieldName: RawUTF8): Variant; - procedure SetField(const FieldName: RawUTF8; const Value: Variant); - {$endif} - /// raise an exception if VTable=nil - procedure CheckVTableInitialized; - {$ifdef HASINLINE}inline;{$endif} - public - /// initialize a record data content for a specified table - // - a void content is set - procedure Init(aTable: TSynTable; aID: Integer=0); overload; {$ifdef HASINLINE}inline;{$endif} - /// initialize a record data content for a specified table - // - the specified SBF content is store inside this TSynTableData - procedure Init(aTable: TSynTable; aID: Integer; RecordBuffer: pointer; - RecordBufferLen: integer); overload; - /// the associated record ID - property ID: integer read VID write VID; - /// the associated TSynTable instance - property Table: TSynTable read VTable write VTable; - /// the record content, SBF compact binary format encoded - property SBF: TSBFString read VValue; - {$ifndef NOVARIANTS} - /// set or retrieve a field value from a variant data - property Field[const FieldName: RawUTF8]: Variant read GetField write SetField; - /// get a field value for a specified field - // - this method is faster than Field[], because it won't look for the field name - function GetFieldValue(aField: TSynTableFieldProperties): Variant; - /// set a field value for a specified field - // - this method is faster than Field[], because it won't look for the field name - procedure SetFieldValue(aField: TSynTableFieldProperties; const Value: Variant); - {$ifdef HASINLINE}inline;{$endif} - {$endif} - /// set a field value for a specified field, from SBF-encoded data - // - this method is faster than the other, because it won't look for the field - // name nor make any variant conversion - procedure SetFieldSBFValue(aField: TSynTableFieldProperties; const Value: TSBFString); - /// get a field value for a specified field, into SBF-encoded data - // - this method is faster than the other, because it won't look for the field - // name nor make any variant conversion - function GetFieldSBFValue(aField: TSynTableFieldProperties): TSBFString; - /// filter the SBF buffer record content with all registered filters - // - all field values are filtered in-place, following our SBF compact - // binary format encoding for this record - procedure FilterSBFValue; {$ifdef HASINLINE}inline;{$endif} - /// check the registered constraints according to a record SBF buffer - // - returns '' on success - // - returns an error message e.g. if a tftUnique constraint failed - // - RecordIndex=-1 in case of adding, or the physical index of the updated record - function ValidateSBFValue(RecordIndex: integer): string; - end; - {$A+} { packet object not allowed since Delphi 2009 :( } -{$endif DELPHI5OROLDER} - - PUpdateFieldEvent = ^TUpdateFieldEvent; - - /// an opaque structure used for TSynTable.UpdateFieldEvent method - TUpdateFieldEvent = record - /// the number of record added - Count: integer; - /// the list of IDs added - // - this list is already in increasing order, because GetIterating was - // called with the ioID order - IDs: TIntegerDynArray; - /// the offset of every record added - // - follows the IDs[] order - Offsets64: TInt64DynArray; - /// previous indexes: NewIndexs[oldIndex] := newIndex - NewIndexs: TIntegerDynArray; - /// the list of existing field in the previous data - AvailableFields: TSQLFieldBits; - /// where to write the updated data - WR: TFileBufferWriter; - end; - - /// will define a validation to be applied to a TSynTableFieldProperties field - // - a typical usage is to validate a value to be unique in the table - // (implemented in the TSynValidateTableUniqueField class) - // - the optional associated parameters are to be supplied JSON-encoded - // - ProcessField and ProcessRecordIndex properties will be filled before - // Process method call by TSynTableFieldProperties.Validate() - TSynValidateTable = class(TSynValidate) - protected - fProcessField: TSynTableFieldProperties; - fProcessRecordIndex: integer; - public - /// the associated TSQLRest instance - // - this value is filled by TSynTableFieldProperties.Validate with its - // self value to be used for the validation - // - it can be used in the overridden Process method - property ProcessField: TSynTableFieldProperties read fProcessField write fProcessField; - /// the associated record index (in case of update) - // - is set to -1 in case of adding, or the physical index of the updated record - // - this value is filled by TSynTableFieldProperties.Validate - // - it can be used in the overridden Process method - property ProcessRecordIndex: integer read fProcessRecordIndex write fProcessRecordIndex; - end; - - /// will define a validation for a TSynTableFieldProperties Unique field - // - implement constraints check e.g. if tfoUnique is set in Options - // - it will check that the field value is not void - // - it will check that the field value is not a duplicate - TSynValidateTableUniqueField = class(TSynValidateTable) - public - /// perform the unique field validation action to the specified value - // - duplication value check will use the ProcessField and - // ProcessRecordIndex properties, which will be filled before call by - // TSynTableFieldProperties.Validate() - // - aFieldIndex parameter is not used here, since we have already the - // ProcessField property set - // - here the Value is expected to be UTF-8 text, as converted from our SBF - // compact binary format via e.g. TSynTableFieldProperties.GetValue / - // GetRawUTF8: this is mandatory to have the validation rule fit with other - // TSynValidateTable classes - function Process(aFieldIndex: integer; const Value: RawUTF8; var ErrorMsg: string): boolean; override; - end; - - /// store the description of a table with records, to implement a Database - // - can be used with several storage engines, for instance TSynBigTableRecord - // - each record can have up to 64 fields - // - a mandatory ID field must be handled by the storage engine itself - // - will handle the storage of records into our SBF compact binary format, in - // which fixed-length fields are stored leftmost side, then variable-length - // fields follow - TSynTable = class - protected - fTableName: RawUTF8; - /// list of TSynTableFieldProperties instances - fField: TObjectList; - /// offset of the first variable length value field - fFieldVariableOffset: PtrUInt; - /// index of the first variable length value field - // - equals -1 if no variable length field exists - fFieldVariableIndex: integer; - /// bit is set for a tftWinAnsi, tftUTF8 or tftBlobInternal kind of field - // - these kind of field are encoded as a VarInt length, then the data - fFieldIsVarString: TSynTableFieldBits; - /// bit is set for a tftBlobExternal kind of field e.g. - fFieldIsExternal: TSynTableFieldBits; - /// event used for proper data retrieval of a given record buffer - fGetRecordData: TSynTableGetRecordData; - /// the global size of a default value, as encoded in our SBF compact binary format - fDefaultRecordLength: integer; - /// a default record data, as encoded in our SBF compact binary format - fDefaultRecordData: TSBFString; - /// list of TSynTableFieldProperties added via all AddField() call - fAddedField: TList; - /// true if any field has a tfoUnique option set - fFieldHasUniqueIndexes: boolean; - function GetFieldType(Index: integer): TSynTableFieldProperties; - function GetFieldCount: integer; - function GetFieldFromName(const aName: RawUTF8): TSynTableFieldProperties; - function GetFieldFromNameLen(aName: PUTF8Char; aNameLen: integer): TSynTableFieldProperties; - /// following method matchs the TSynTableFieldIndex event type - function GetFieldIndexFromName(const aName: RawUTF8): integer; overload; - function GetFieldIndexFromNameLen(aName: PUTF8Char; aNameLen: integer): integer; overload; - /// refresh Offset,FieldNumber,FieldSize and fFieldVariableIndex,fFieldVariableOffset - procedure AfterFieldModif; - public - /// create a table definition instance - constructor Create(const aTableName: RawUTF8); - /// create a table definition instance from a specified file reader - procedure LoadFrom(var RD: TFileBufferReader); - /// release used memory - destructor Destroy; override; - /// save field properties to a specified file writer - procedure SaveTo(WR: TFileBufferWriter); - - /// retrieve to the corresponding data address of a given field - function GetData(RecordBuffer: PUTF8Char; Field: TSynTableFieldProperties): pointer; - /// add a field description to the table - // - warning: the class responsible of the storage itself must process the - // data already stored when a field is created, e.g. in - // TSynBigTableRecord.AddFieldUpdate method - // - physical order does not necessary follow the AddField() call order: - // for better performance, it will try to store fixed-sized record first, - // multiple of 4 bytes first (access is faster if dat is 4 byte aligned), - // then variable-length after fixed-sized fields; in all case, a field - // indexed will be put first - function AddField(const aName: RawUTF8; aType: TSynTableFieldType; - aOptions: TSynTableFieldOptions=[]): TSynTableFieldProperties; - /// update a record content - // - return the updated record data, in our SBF compact binary format - // - if NewFieldData is not specified, a default 0 or '' value is appended - // - if NewFieldData is set, it must match the field value kind - // - warning: this method will update result in-place, so RecordBuffer MUST - // be <> pointer(result) or data corruption may occur - procedure UpdateFieldData(RecordBuffer: PUTF8Char; RecordBufferLen, - FieldIndex: integer; var result: TSBFString; const NewFieldData: TSBFString=''); - /// update a record content after any AddfieldUpdate, to refresh the data - // - AvailableFields must contain the list of existing fields in the previous data - function UpdateFieldRecord(RecordBuffer: PUTF8Char; var AvailableFields: TSQLFieldBits): TSBFString; - /// this Event is to be called for all data records (via a GetIterating method) - // after any AddfieldUpdate, to refresh the data - // - Opaque is in fact a pointer to a TUpdateFieldEvent record, and will contain - // all parameters set by TSynBigTableRecord.AddFieldUpdate, including a - // TFileBufferWriter instance to use to write the recreated data - // - it will work with either any newly added field, handly also field data - // order change in SBF record (e.g. when a fixed-sized field has been added - // on a record containing variable-length fields) - function UpdateFieldEvent(Sender: TObject; Opaque: pointer; ID, Index: integer; - Data: pointer; DataLen: integer): boolean; - /// event which must be called by the storage engine when some values are modified - // - if aOldIndex and aNewIndex are both >= 0, the corresponding aOldIndex - // will be replaced by aNewIndex value (i.e. called in case of a data Update) - // - if aOldIndex is -1 and aNewIndex is >= 0, aNewIndex refers to a just - // created item (i.e. called in case of a data Add) - // - if aOldIndex is >= 0 and aNewIndex is -1, aNewIndex refers to a just - // deleted item (i.e. called in case of a data Delete) - // - will update then sort all existing TSynTableFieldProperties.OrderedIndex - // values - // - the GetDataBuffer protected virtual method must have been overridden to - // properly return the record data for a given "physical/stored" index - // - aOldRecordData and aNewRecordData can be specified in order to guess - // if the field data has really been modified (speed up the update a lot - // to only sort indexed fields if its content has been really modified) - procedure FieldIndexModify(aOldIndex, aNewIndex: integer; - aOldRecordData, aNewRecordData: pointer); - /// return the total length of the given record buffer, encoded in our SBF - // compact binary format - function DataLength(RecordBuffer: pointer): integer; - {$ifndef NOVARIANTS} - /// create a Variant able to access any field content via late binding - // - i.e. you can use Var.Name to access the 'Name' field of record Var - // - if you leave ID and RecordBuffer void, a void record is created - function Data(aID: integer=0; RecordBuffer: pointer=nil; - RecordBufferLen: Integer=0): Variant; overload; - {$endif NOVARIANTS} - /// return a default content for ALL record fields - // - uses our SBF compact binary format - property DefaultRecordData: TSBFString read fDefaultRecordData; - /// list of TSynTableFieldProperties added via all AddField() call - // - this list will allow TSynBigTableRecord.AddFieldUpdate to refresh - // the data on disk according to the new field configuration - property AddedField: TList read fAddedField write fAddedField; - /// offset of the first variable length value field - property FieldVariableOffset: PtrUInt read fFieldVariableOffset; - public - {$ifndef DELPHI5OROLDER} - /// create a TJSONWriter, ready to be filled with GetJSONValues(W) below - // - will initialize all TJSONWriter.ColNames[] values according to the - // specified Fields index list, and initialize the JSON content - function CreateJSONWriter(JSON: TStream; Expand, withID: boolean; - const Fields: TSQLFieldIndexDynArray): TJSONWriter; overload; - /// create a TJSONWriter, ready to be filled with GetJSONValues(W) below - // - will initialize all TJSONWriter.ColNames[] values according to the - // specified Fields bit set, and initialize the JSON content - function CreateJSONWriter(JSON: TStream; Expand, withID: boolean; - const Fields: TSQLFieldBits): TJSONWriter; overload; - /// return the UTF-8 encoded JSON objects for the values contained - // in the specified RecordBuffer encoded in our SBF compact binary format, - // according to the Expand/WithID/Fields parameters of W - // - if W.Expand is true, JSON data is an object, for direct use with any Ajax or .NET client: - // ! {"col1":val11,"col2":"val12"} - //- if W.Expand is false, JSON data is serialized (as used in TSQLTableJSON) - // ! { "fieldCount":1,"values":["col1","col2",val11,"val12",val21,..] } - // - only fields with a bit set in W.Fields will be appended - // - if W.WithID is true, then the first ID field value is included - procedure GetJSONValues(aID: integer; RecordBuffer: PUTF8Char; W: TJSONWriter); - /// can be used to retrieve all values matching a preparated TSynTableStatement - // - this method matchs the TSynBigTableIterateEvent callback definition - // - Sender will be the TSynBigTable instance, and Opaque will point to a - // TSynTableStatement instance (with all fields initialized, including Writer) - function IterateJSONValues(Sender: TObject; Opaque: pointer; ID: integer; - Data: pointer; DataLen: integer): boolean; - {$endif DELPHI5OROLDER} - /// check the registered constraints according to a record SBF buffer - // - returns '' on success - // - returns an error message e.g. if a tftUnique constraint failed - // - RecordIndex=-1 in case of adding, or the physical index of the updated record - function Validate(RecordBuffer: pointer; RecordIndex: integer): string; - /// filter the SBF buffer record content with all registered filters - // - all field values are filtered in-place, following our SBF compact - // binary format encoding for this record - procedure Filter(var RecordBuffer: TSBFString); - - /// event used for proper data retrieval of a given record buffer, according - // to the physical/storage index value (not per-ID index) - // - if not set, field indexes won't work - // - will be mapped e.g. to TSynBigTable.GetPointerFromPhysicalIndex - property GetRecordData: TSynTableGetRecordData read fGetRecordData write fGetRecordData; - public - /// the internal Table name used to identify it (e.g. from JSON or SQL) - // - similar to the SQL Table name - property TableName: RawUTF8 read fTableName write fTableName; - /// number of fields in this table - property FieldCount: integer read GetFieldCount; - /// retrieve the properties of a given field - // - returns nil if the specified Index is out of range - property Field[Index: integer]: TSynTableFieldProperties read GetFieldType; - /// retrieve the properties of a given field - // - returns nil if the specified Index is out of range - property FieldFromName[const aName: RawUTF8]: TSynTableFieldProperties read GetFieldFromName; default; - /// retrieve the index of a given field - // - returns -1 if the specified Index is out of range - property FieldIndexFromName[const aName: RawUTF8]: integer read GetFieldIndexFromName; - /// read-only access to the Field list - property FieldList: TObjectList read fField; - /// true if any field has a tfoUnique option set - property HasUniqueIndexes: boolean read fFieldHasUniqueIndexes; - end; - -{$ifndef NOVARIANTS} - /// a custom variant type used to have direct access to a record content - // - use TSynTable.Data method to retrieve such a Variant - // - this variant will store internaly a SBF compact binary format - // representation of the record content - // - uses internally a TSynTableData object - TSynTableVariantType = class(TSynInvokeableVariantType) - protected - function IntGet(var Dest: TVarData; const Instance: TVarData; Name: PAnsiChar; NameLen: PtrInt): boolean; override; - function IntSet(const Instance, Value: TVarData; Name: PAnsiChar; NameLen: PtrInt): boolean; override; - public - /// retrieve the SBF compact binary format representation of a record content - class function ToSBF(const V: Variant): TSBFString; - /// retrieve the ID value associated to a record content - class function ToID(const V: Variant): integer; - /// retrieve the TSynTable instance associated to a record content - class function ToTable(const V: Variant): TSynTable; - /// clear the content - procedure Clear(var V: TVarData); override; - /// copy two record content - procedure Copy(var Dest: TVarData; const Source: TVarData; - const Indirect: Boolean); override; - end; - -/// initialize TSynTableVariantType if needed, and return the correspongind VType -function SynTableVariantVarType: cardinal; - -{$endif NOVARIANTS} - -const - /// used by TSynTableStatement.WhereField for "SELECT .. FROM TableName WHERE ID=?" - SYNTABLESTATEMENTWHEREID = 0; - - -/// low-level integer comparison according to a specified operator -// - SBF must point to the values encoded in our SBF compact binary format -// - Value must contain the plain integer value -// - Value can be a Currency accessed via a PInt64 -// - will work only for tftBoolean, tftUInt8, tftUInt16, tftUInt24, -// tftInt32, tftInt64 and tftCurrency field types -// - will handle only soEqualTo...soGreaterThanOrEqualTo operators -// - if SBFEnd is not nil, it will test for all values until SBF>=SBFEnd -// (can be used for tftArray) -// - returns true if both values match, or false otherwise -function CompareOperator(FieldType: TSynTableFieldType; SBF, SBFEnd: PUTF8Char; - Value: Int64; Oper: TCompareOperator): boolean; overload; - -/// low-level floating-point comparison according to a specified operator -// - SBF must point to the values encoded in our SBF compact binary format -// - Value must contain the plain floating-point value -// - will work only for tftDouble field type -// - will handle only soEqualTo...soGreaterThanOrEqualTo operators -// - if SBFEnd is not nil, it will test for all values until SBF>=SBFEnd -// (can be used for tftArray) -// - returns true if both values match, or false otherwise -function CompareOperator(SBF, SBFEnd: PUTF8Char; - Value: double; Oper: TCompareOperator): boolean; overload; - -/// low-level text comparison according to a specified operator -// - SBF must point to the values encoded in our SBF compact binary format -// - Value must contain the plain text value, in the same encoding (either -// WinAnsi either UTF-8, as FieldType defined for the SBF value) -// - will work only for tftWinAnsi and tftUTF8 field types -// - will handle all kind of operators - including soBeginWith, soContains and -// soSoundsLike* - but soSoundsLike* won't make use of the CaseSensitive parameter -// - for soSoundsLikeEnglish, soSoundsLikeFrench and soSoundsLikeSpanish -// operators, Value is not a real PUTF8Char but a prepared PSynSoundEx -// - if SBFEnd is not nil, it will test for all values until SBF>=SBFEnd -// (can be used for tftArray) -// - returns true if both values match, or false otherwise -function CompareOperator(FieldType: TSynTableFieldType; SBF, SBFEnd: PUTF8Char; - Value: PUTF8Char; ValueLen: integer; Oper: TCompareOperator; - CaseSensitive: boolean): boolean; overload; - -/// convert any AnsiString content into our SBF compact binary format storage -procedure ToSBFStr(const Value: RawByteString; out Result: TSBFString); - - -implementation - -{$ifdef WITH_FASTMM4STATS} -uses - FastMM4; // override OS information by actual FastMM4 status -{$endif WITH_FASTMM4STATS} - -{$ifdef FPCLINUX} -uses - termio, - {$ifdef BSD} - ctypes, - sysctl, - {$else} - Linux, - {$endif BSD} - SynFPCLinux; -{$endif FPCLINUX} - - -{ ************ TSynTable generic types and classes ************************** } - -{$ifndef NOVARIANTS} - -{ TSynTableVariantType } - -var - SynTableVariantType: TCustomVariantType = nil; - -function SynTableVariantVarType: cardinal; -begin - if SynTableVariantType=nil then - SynTableVariantType := SynRegisterCustomVariantType(TSynTableVariantType); - result := SynTableVariantType.VarType; -end; - -procedure TSynTableVariantType.Clear(var V: TVarData); -begin - //Assert(V.VType=SynTableVariantType.VarType); - TSynTableData(V).VValue := ''; // clean memory release - PPtrUInt(@V)^ := 0; // will set V.VType := varEmpty -end; - -procedure TSynTableVariantType.Copy(var Dest: TVarData; - const Source: TVarData; const Indirect: Boolean); -begin - //Assert(Source.VType=SynTableVariantType.VarType); - inherited Copy(Dest,Source,Indirect); // copy VType+VID+VTable - if not Indirect then - with TSynTableData(Dest) do begin - PtrInt(VValue) := 0; // avoid GPF - VValue := TSynTableData(Source).VValue; // copy by reference - end; -end; - -function TSynTableVariantType.IntGet(var Dest: TVarData; const Instance: TVarData; - Name: PAnsiChar; NameLen: PtrInt): boolean; -begin - result:= TSynTableData(Instance).GetFieldVarData(pointer(Name),NameLen,Dest); -end; - -function TSynTableVariantType.IntSet(const Instance, Value: TVarData; - Name: PAnsiChar; NameLen: PtrInt): boolean; -var aName: RawUTF8; -begin - FastSetString(aName,Name,NameLen); - TSynTableData(Instance).SetField(aName,Variant(Value)); - result := true; -end; - -class function TSynTableVariantType.ToID(const V: Variant): integer; -var Data: TSynTableData absolute V; -begin - if Data.VType<>SynTableVariantType.VarType then - result := 0 else - result := Data.VID; -end; - -class function TSynTableVariantType.ToSBF(const V: Variant): TSBFString; -var Data: TSynTableData absolute V; -begin - if Data.VType<>SynTableVariantType.VarType then - result := '' else - result := Data.VValue; -end; - -class function TSynTableVariantType.ToTable(const V: Variant): TSynTable; -var Data: TSynTableData absolute V; -begin - if Data.VType<>SynTableVariantType.VarType then - result := nil else - result := Data.VTable; -end; - -{$endif NOVARIANTS} - - -{ TSynTable } - -{$ifdef CPUX86} -function SortQWord(const A,B: QWord): integer; {$ifdef FPC} nostackframe; assembler; {$endif} -asm // Delphi x86 compiler is not efficient, and oldest even incorrect - mov ecx, [eax] - mov eax, [eax + 4] - cmp eax, [edx + 4] - jnz @nz - cmp ecx, [edx] - jz @0 -@nz: jnb @p - or eax, -1 - ret -@0: xor eax, eax - ret -@p: mov eax, 1 -end; - -function SortInt64(const A,B: Int64): integer; {$ifdef FPC} nostackframe; assembler; {$endif} -asm // Delphi x86 compiler is not efficient at compiling below code - mov ecx, [eax] - mov eax, [eax + 4] - cmp eax, [edx + 4] - jnz @nz - cmp ecx, [edx] - jz @0 - jnb @p -@n: or eax, -1 - ret -@0: xor eax, eax - ret -@nz: jl @n -@p: mov eax, 1 -end; -{$endif} - -{$ifndef SORTCOMPAREMETHOD} - -function SortU8(P1,P2: PUTF8Char): PtrInt; -begin - if P1<>P2 then - if P1<>nil then - if P2<>nil then begin - result := PByte(P1)^-PByte(P2)^; - exit; - end else - result := 1 else // P2=nil - result := -1 else // P1=nil - result := 0; // P1=P2 -end; - -function SortU16(P1,P2: PUTF8Char): PtrInt; -begin - if P1<>P2 then - if P1<>nil then - if P2<>nil then begin - result := PWord(P1)^-PWord(P2)^; - exit; - end else - result := 1 else // P2=nil - result := -1 else // P1=nil - result := 0; // P1=P2 -end; - -function SortI32(P1,P2: PUTF8Char): PtrInt; -begin - if P1<>P2 then - if P1<>nil then - if P2<>nil then begin - result := PInteger(P1)^-PInteger(P2)^; - exit; - end else - result := 1 else // P2=nil - result := -1 else // P1=nil - result := 0; // P1=P2 -end; - -function SortDouble(P1,P2: PUTF8Char): PtrInt; -var V: Double; -begin - if P1<>P2 then - if P1<>nil then - if P2<>nil then begin - V := unaligned(PDouble(P1)^)-unaligned(PDouble(P2)^); - if V<0 then - result := -1 else - if V=0 then - result := 0 else - result := 1; - end else - result := 1 else // P2=nil - result := -1 else // P1=nil - result := 0; // P1=P2 -end; - -function SortU24(P1,P2: PUTF8Char): PtrInt; -begin - if P1<>P2 then - if P1<>nil then - if P2<>nil then begin - result := PtrInt(PWord(P1)^)+PtrInt(P1[2])shl 16 - -PtrInt(PWord(P2)^)-PtrInt(P2[2]) shl 16; - exit; - end else - result := 1 else // P2=nil - result := -1 else // P1=nil - result := 0; // P1=P2 -end; - -function SortVarUInt32(P1,P2: PUTF8Char): PtrInt; -begin - if P1<>P2 then - if P1<>nil then - if P2<>nil then begin - result := FromVarUInt32(PByte(P1))-FromVarUInt32(PByte(P2)); - exit; - end else - result := 1 else // P2=nil - result := -1 else // P1=nil - result := 0; // P1=P2 -end; - -function SortVarInt32(P1,P2: PUTF8Char): PtrInt; -begin - if P1<>P2 then - if P1<>nil then - if P2<>nil then begin - result := FromVarInt32(PByte(P1))-FromVarInt32(PByte(P2)); - exit; - end else - result := 1 else // P2=nil - result := -1 else // P1=nil - result := 0; // P1=P2 -end; - -{$ifdef CPU64} // PtrInt = Int64 -> so direct substraction works - -function SortI64(P1,P2: PUTF8Char): PtrInt; -begin - if P1<>P2 then - if P1<>nil then - if P2<>nil then - result := PInt64(P1)^-PInt64(P2)^ else - result := 1 else // P2=nil - result := -1 else // P1=nil - result := 0; // P1=P2 -end; - -function SortVarUInt64(P1,P2: PUTF8Char): PtrInt; -begin - if P1<>P2 then - if P1<>nil then - if P2<>nil then - result := FromVarUInt64(PByte(P1))-FromVarUInt64(PByte(P2)) else - result := 1 else // P2=nil - result := -1 else // P1=nil - result := 0; // P1=P2 -end; - -function SortVarInt64(P1,P2: PUTF8Char): PtrInt; -begin - if P1<>P2 then - if P1<>nil then - if P2<>nil then - result := FromVarInt64(PByte(P1))-FromVarInt64(PByte(P2)) else - result := 1 else // P2=nil - result := -1 else // P1=nil - result := 0; // P1=P2 -end; - -{$else} - -{$ifdef CPUX86} // circumvent comparison slowness (and QWord bug) - -function SortI64(P1,P2: PUTF8Char): PtrInt; -begin - if P1<>P2 then - if P1<>nil then - if P2<>nil then - result := SortInt64(PInt64(P1)^,PInt64(P2)^) else - result := 1 else // P2=nil - result := -1 else // P1=nil - result := 0; // P1=P2 -end; - -function SortVarUInt64(P1,P2: PUTF8Char): PtrInt; -begin - if P1<>P2 then - if P1<>nil then - if P2<>nil then - result := SortQWord(FromVarUInt64(PByte(P1)),FromVarUInt64(PByte(P2))) else - result := 1 else // P2=nil - result := -1 else // P1=nil - result := 0; // P1=P2 -end; - -function SortVarInt64(P1,P2: PUTF8Char): PtrInt; -begin - if P1<>P2 then - if P1<>nil then - if P2<>nil then - result := SortInt64(FromVarInt64(PByte(P1)),FromVarInt64(PByte(P2))) else - result := 1 else // P2=nil - result := -1 else // P1=nil - result := 0; // P1=P2 -end; - -{$else} - -function SortI64(P1,P2: PUTF8Char): PtrInt; -var V: Int64; -begin - if P1<>P2 then - if P1<>nil then - if P2<>nil then begin - V := PInt64(P1)^-PInt64(P2)^; - if V<0 then - result := -1 else - if V>0 then - result := 1 else - result := 0; - end else - result := 1 else // P2=nil - result := -1 else // P1=nil - result := 0; // P1=P2 -end; - -function SortVarUInt64(P1,P2: PUTF8Char): PtrInt; -var V1,V2: QWord; -begin - if P1<>P2 then - if P1<>nil then - if P2<>nil then begin - V1 := FromVarUInt64(PByte(P1)); - V2 := FromVarUInt64(PByte(P2)); - if V1>V2 then - result := 1 else - if V1=V2 then - result := 0 else - result := -1; - end else - result := 1 else // P2=nil - result := -1 else // P1=nil - result := 0; // P1=P2 -end; - -function SortVarInt64(P1,P2: PUTF8Char): PtrInt; -var V1,V2: Int64; -begin - if P1<>P2 then - if P1<>nil then - if P2<>nil then begin - V1 := FromVarInt64(PByte(P1)); - V2 := FromVarInt64(PByte(P2)); - if V1>V2 then - result := 1 else - if V1=V2 then - result := 0 else - result := -1; - end else - result := 1 else // P2=nil - result := -1 else // P1=nil - result := 0; // P1=P2 -end; - -{$endif CPUX86} - -{$endif CPU64} - -function SortStr(P1,P2: PUTF8Char): PtrInt; -var L1, L2, L, i: PtrInt; - PB1, PB2: PByte; -begin - if P1<>P2 then - if P1<>nil then - if P2<>nil then begin - if PtrInt(P1^)<=$7F then begin - L1 := PtrInt(P1^); - inc(P1); - end else begin - PB1 := pointer(P1); - L1 := FromVarUInt32High(PB1); - P1 := pointer(PB1); - end; - if PtrInt(P2^)<=$7F then begin - L2 := PtrInt(P2^); - inc(P2); - end else begin - PB2 := pointer(P2); - L2 := FromVarUInt32High(PB2); - P2 := pointer(PB2); - end; - L := L1; - if L2>L then - L := L2; - for i := 0 to L-1 do begin - result := PtrInt(P1[i])-PtrInt(P2[i]); - if Result<>0 then - exit; - end; - result := L1-L2; - end else - result := 1 else // P2=nil - result := -1 else // P1=nil - result := 0; // P1=P2 -end; - -function SortIStr(P1,P2: PUTF8Char): PtrInt; -var L1, L2, L, i: PtrInt; - PB1, PB2: PByte; -begin - if P1<>P2 then - if P1<>nil then - if P2<>nil then begin - if PtrInt(P1^)<=$7F then begin - L1 := PtrInt(P1^); - inc(P1); - end else begin - PB1 := pointer(P1); - L1 := FromVarUInt32High(PB1); - P1 := pointer(PB1); - end; - if PtrInt(P2^)<=$7F then begin - L2 := PtrInt(P2^); - inc(P2); - end else begin - PB2 := pointer(P2); - L2 := FromVarUInt32High(PB2); - P2 := pointer(PB2); - end; - if L2>L1 then - L := L2 else - L := L1; - for i := 0 to L-1 do // NormToUpperAnsi7 works for both WinAnsi & UTF-8 - if NormToUpperAnsi7[P1[i]]<>NormToUpperAnsi7[P2[i]] then begin - result := PtrInt(P1[i])-PtrInt(P2[i]); - exit; - end; - result := L1-L2; - end else - result := 1 else // P2=nil - result := -1 else // P1=nil - result := 0; // P1=P2 -end; - -const - FIELD_SORT: array[TSynTableFieldType] of TUTF8Compare = ( - nil, // tftUnknown, - SortU8, SortU8, SortU16, SortU24, SortI32, SortI64, - // tftBoolean,tftUInt8,tftUInt16,tftUInt24,tftInt32,tftInt64, - SortI64, SortDouble, SortVarUInt32,SortVarInt32,SortVarUInt64, - // tftCurrency,tftDouble, tftVarUInt32, tftVarInt32,tftVarUInt64, - SortStr, SortStr, SortStr, nil, SortVarInt64); - // tftWinAnsi,tftUTF8, tftBlobInternal,tftBlobExternal,tftVarInt64); - -{$endif SORTCOMPAREMETHOD} - -const - FIELD_FIXEDSIZE: array[TSynTableFieldType] of Integer = ( - 0, // tftUnknown, - 1, 1, 2, 3, 4, 8, 8, 8, - // tftBoolean, tftUInt8, tftUInt16, tftUInt24, tftInt32, tftInt64, tftCurrency, tftDouble - -1, -1, -1, // tftVarUInt32, tftVarInt32, tftVarUInt64 have -1 as size - -2, -2, -2, // tftWinAnsi, tftUTF8, tftBlobInternal have -2 as size - -3, // tftBlobExternal has -3 as size - -1); //tftVarInt64 - - // note: boolean is not in this set, because it can be 'true' or 'false' - FIELD_INTEGER: TSynTableFieldTypes = [ - tftUInt8, tftUInt16, tftUInt24, tftInt32, tftInt64, - tftVarUInt32, tftVarInt32, tftVarUInt64, tftVarInt64]; - -function TSynTable.AddField(const aName: RawUTF8; - aType: TSynTableFieldType; aOptions: TSynTableFieldOptions): TSynTableFieldProperties; -var aSize: Integer; -begin - result := nil; - aSize := FIELD_FIXEDSIZE[aType]; - if (self=nil) or (aSize=0) or IsRowID(pointer(aName)) or - not PropNameValid(pointer(aName)) or (GetFieldFromName(aName)<>nil) then - exit; - result := TSynTableFieldProperties.Create; - if fAddedField=nil then - fAddedField := TList.Create; - fAddedField.Add(result); - result.Name := aName; - result.FieldType := aType; - if tfoUnique in aOptions then - Include(aOptions,tfoIndex); // create an index for faster Unique field - if aSize=-3 then // external field has no index available - aOptions := aOptions-[tfoIndex,tfoUnique]; - result.Options := aOptions; - if aSize>0 then begin - // fixed-size field should be inserted left-side of the stream - if (tfoIndex in aOptions) or (aSize and 3=0) then begin - // indexed field or size is alignment friendly: put left side - if not ((tfoIndex in aOptions) and (aSize and 3=0)) then - // indexed+aligned field -> set first, otherwise at variable or not indexed - while result.FieldNumber=0 then - result.FieldNumber := fFieldVariableIndex else - result.FieldNumber := fField.Count; - fField.Insert(result.FieldNumber,result); - end else begin - if (tfoIndex in aOptions) and (fFieldVariableIndex>=0) then begin - // indexed field should be added left side (faster access for sort) - result.FieldNumber := fFieldVariableIndex; - while result.FieldNumbernil) and ((RecordBuffer=nil) or (RecordBufferLen=0)) then begin - // no data yet -> use default - RecordBuffer := pointer(fDefaultRecordData); - RecordBufferLen := fDefaultRecordLength; - end; - if RecordBuffer=pointer(result) then - // update content code below will fail -> please correct calling code - raise ETableDataException.CreateUTF8('In-place call of %.UpdateFieldData',[self]); - if (self=nil) or (cardinal(FieldIndex)>=cardinal(fField.Count)) then begin - SetString(result,PAnsiChar(RecordBuffer),RecordBufferLen); - exit; - end; - F := TSynTableFieldProperties(fField.List[FieldIndex]); - NewSize := length(NewFieldData); - if NewSize=0 then begin - // no NewFieldData specified -> use default field data to be inserted - NewData := pointer(F.fDefaultFieldData); - NewSize := F.fDefaultFieldLength; - end else - NewData := pointer(NewFieldData); - Dest := GetData(RecordBuffer,F); - DestOffset := Dest-RecordBuffer; - // update content - OldSize := F.GetLength(Dest); - dec(RecordBufferLen,OldSize); - SetString(Result,nil,RecordBufferLen+NewSize); - MoveFast(RecordBuffer^,PByteArray(result)[0],DestOffset); - MoveFast(NewData^,PByteArray(result)[DestOffset],NewSize); - MoveFast(Dest[OldSize],PByteArray(result)[DestOffset+NewSize],RecordBufferLen-DestOffset); -end; - -constructor TSynTable.Create(const aTableName: RawUTF8); -begin - if not PropNameValid(pointer(aTableName)) then - raise ETableDataException.CreateUTF8('Invalid %.Create(%)',[self,aTableName]); - fTableName := aTableName; - fField := TObjectList.Create; - fFieldVariableIndex := -1; -end; - -procedure TSynTable.LoadFrom(var RD: TFileBufferReader); -var n, i: integer; - aTableName: RawUTF8; -begin - fField.Clear; - RD.Read(aTableName); - if not PropNameValid(pointer(aTableName)) then - RD.ErrorInvalidContent; - fTableName := aTableName; - n := RD.ReadVarUInt32; - if cardinal(n)>=MAX_SQLFIELDS then - RD.ErrorInvalidContent; - for i := 0 to n-1 do - fField.Add(TSynTableFieldProperties.CreateFrom(RD)); - AfterFieldModif; -end; - -destructor TSynTable.Destroy; -begin - fField.Free; - fAddedField.Free; - inherited; -end; - -function TSynTable.GetFieldCount: integer; -begin - if self=nil then - result := 0 else - result := fField.Count; -end; - -function TSynTable.GetFieldFromName(const aName: RawUTF8): TSynTableFieldProperties; -begin - result := GetFieldFromNameLen(pointer(aName),length(aName)); -end; - -function TSynTable.GetFieldFromNameLen(aName: PUTF8Char; aNameLen: integer): TSynTableFieldProperties; -var p: ^TSynTableFieldProperties; - i: integer; -begin - if self<>nil then begin - p := pointer(fField.List); - for i := 1 to fField.Count do - if IdemPropNameU(p^.Name,aName,aNameLen) then begin - result := p^; - exit; - end else - inc(p); - end; - result := nil; -end; - -function TSynTable.GetFieldIndexFromName(const aName: RawUTF8): integer; -begin - result := GetFieldIndexFromNameLen(pointer(aName),length(aName)); -end; - -function TSynTable.GetFieldIndexFromNameLen(aName: PUTF8Char; aNameLen: integer): integer; -var p: ^TSynTableFieldProperties; -begin - if self<>nil then begin - p := pointer(fField.List); - for result := 0 to fField.Count-1 do - if IdemPropNameU(p^.Name,aName,aNameLen) then - exit else - inc(p); - end; - result := -1; -end; - -function TSynTable.GetFieldType(Index: integer): TSynTableFieldProperties; -begin - if (self=nil) or (cardinal(Index)>=cardinal(fField.Count)) then - result := nil else // avoid GPF - result := fField.List[Index]; -end; - -{$ifndef DELPHI5OROLDER} - -function TSynTable.CreateJSONWriter(JSON: TStream; Expand, withID: boolean; - const Fields: TSQLFieldBits): TJSONWriter; -begin - result := CreateJSONWriter(JSON,Expand,withID,FieldBitsToIndex(Fields,fField.Count)); -end; - -function TSynTable.CreateJSONWriter(JSON: TStream; Expand, withID: boolean; - const Fields: TSQLFieldIndexDynArray): TJSONWriter; -var i,nf,n: integer; -begin - if (self=nil) or ((Fields=nil) and not withID) then begin - result := nil; // no data to retrieve - exit; - end; - result := TJSONWriter.Create(JSON,Expand,withID,Fields); - // set col names - if withID then - n := 1 else - n := 0; - nf := length(Fields); - SetLength(result.ColNames,nf+n); - if withID then - result.ColNames[0] := 'ID'; - for i := 0 to nf-1 do - result.ColNames[i+n] := TSynTableFieldProperties(fField.List[Fields[i]]).Name; - result.AddColumns; // write or init field names for appropriate JSON Expand -end; - -procedure TSynTable.GetJSONValues(aID: integer; RecordBuffer: PUTF8Char; - W: TJSONWriter); -var i,n: integer; - buf: array[0..MAX_SQLFIELDS-1] of PUTF8Char; -begin - if (self=nil) or (RecordBuffer=nil) or (W=nil) then - exit; // avoid GPF - if W.Expand then begin - W.Add('{'); - if W.WithID then - W.AddString(W.ColNames[0]); - end; - if W.WithID then begin - W.Add(aID); - W.Add(','); - n := 1; - end else - n := 0; - for i := 0 to fField.Count-1 do begin - buf[i] := RecordBuffer; - inc(RecordBuffer,TSynTableFieldProperties(fField.List[i]).GetLength(RecordBuffer)); - end; - for i := 0 to length(W.Fields)-1 do begin - if W.Expand then begin - W.AddString(W.ColNames[n]); // '"'+ColNames[]+'":' - inc(n); - end; - TSynTableFieldProperties(fField.List[W.Fields[i]]).GetJSON(buf[i],W); - W.Add(','); - end; - W.CancelLastComma; // cancel last ',' - if W.Expand then - W.Add('}'); -end; - -function TSynTable.IterateJSONValues(Sender: TObject; Opaque: pointer; - ID: integer; Data: pointer; DataLen: integer): boolean; -var Statement: TSynTableStatement absolute Opaque; - F: TSynTableFieldProperties; - nWhere,fIndex: cardinal; -begin // note: we should have handled -2 (=COUNT) case already - nWhere := length(Statement.Where); - if (self=nil) or (Statement=nil) or (Data=nil) or - (Statement.Select=nil) or (nWhere>1) or - ((nWhere=1)and(Statement.Where[0].ValueSBF='')) then begin - result := false; - exit; - end; - result := true; - if nWhere=1 then begin // Where=nil -> all rows - fIndex := Statement.Where[0].Field; - if fIndex=SYNTABLESTATEMENTWHEREID then begin - if ID<>Statement.Where[0].ValueInteger then - exit; - end else begin - dec(fIndex); // 0 is ID, 1 for field # 0, 2 for field #1, and so on... - if fIndex0 then - exit; - end; - end; - end; - GetJSONValues(ID,Data,Statement.Writer); -end; - -{$endif DELPHI5OROLDER} - -function TSynTable.GetData(RecordBuffer: PUTF8Char; Field: TSynTableFieldProperties): pointer; -var i: integer; - PB: PByte; -begin - if Field.Offset>=0 then - result := RecordBuffer+Field.Offset else begin - result := RecordBuffer+fFieldVariableOffset; - for i := fFieldVariableIndex to Field.FieldNumber-1 do - if i in fFieldIsVarString then begin - // inlined result := GotoNextVarString(result); - if PByte(result)^<=$7f then - inc(PByte(result),PByte(result)^+1) else begin - PB := result; - inc(PByte(result),FromVarUInt32High(PB)+PtrUInt(PB)-PtrUInt(result)); - end; - end else - if not (i in fFieldIsExternal) then begin - // inlined result := GotoNextVarInt(result) - while PByte(result)^>$7f do inc(PByte(result)); - inc(PByte(result)); - end; - end; -end; - -procedure TSynTable.SaveTo(WR: TFileBufferWriter); -var i: Integer; -begin - WR.Write(fTableName); - WR.WriteVarUInt32(fField.Count); - for i := 0 to fField.Count-1 do - TSynTableFieldProperties(fField.List[i]).SaveTo(WR); -end; - -procedure TSynTable.AfterFieldModif; -var i, Offs: integer; -begin - PInt64(@fFieldIsVarString)^ := 0; - PInt64(@fFieldIsExternal)^ := 0; - fFieldVariableIndex := -1; - fDefaultRecordLength := 0; - fFieldHasUniqueIndexes := false; - Offs := 0; - for i := 0 to fField.Count-1 do - with TSynTableFieldProperties(fField.List[i]) do begin - FieldNumber := i; - {$ifndef SORTCOMPAREMETHOD} - SortCompare := FIELD_SORT[FieldType]; - {$endif} - Owner := self; - FieldSize := FIELD_FIXEDSIZE[FieldType]; - if FieldSize>=0 then begin - //assert(Offs>=0); - Offset := Offs; - inc(Offs,FieldSize); - inc(fDefaultRecordLength,FieldSize); - fDefaultFieldLength := FieldSize; - end else begin - if FieldSize=-3 then - Include(fFieldIsExternal,i) else begin - fDefaultFieldLength := 1; - inc(fDefaultRecordLength); - if FieldSize=-2 then - Include(fFieldIsVarString,i); - {$ifndef SORTCOMPAREMETHOD} - if (FieldType in [tftWinAnsi,tftUTF8]) and - (tfoCaseInsensitive in Options) then - SortCompare := SortIStr; // works for both WinAnsi and UTF-8 encodings - {$endif} - end; - // we need the Offset even for tftBlobExternal (FieldSize=-3) - if fFieldVariableIndex<0 then begin - fFieldVariableIndex := i; - fFieldVariableOffset := Offs; - Offs := -1; - end; - Offset := Offs; - dec(Offs); - end; - SetLength(fDefaultFieldData,fDefaultFieldLength); - FillcharFast(pointer(fDefaultFieldData)^,fDefaultFieldLength,0); - end; - SetLength(fDefaultRecordData,fDefaultRecordLength); - FillcharFast(pointer(fDefaultRecordData)^,fDefaultRecordLength,0); -end; - -procedure TSynTable.FieldIndexModify(aOldIndex, aNewIndex: integer; - aOldRecordData, aNewRecordData: pointer); -var F: integer; -begin - for F := 0 to fField.Count-1 do - with TSynTableFieldProperties(fField.List[F]) do - if tfoIndex in Options then - OrderedIndexUpdate(aOldIndex,aNewIndex,aOldRecordData,aNewRecordData); -end; - -procedure TSynTable.Filter(var RecordBuffer: TSBFString); -var Old, New: RawUTF8; - NewRecord: TSBFString; // UpdateFieldData update result in-place - F, i: integer; -begin - for F := 0 to fField.Count-1 do - with TSynTableFieldProperties(fField.List[F]) do - if Filters<>nil then begin - Old := GetRawUTF8(pointer(RecordBuffer)); - New := Old; - for i := 0 to Filters.Count-1 do - TSynFilter(Filters.List[i]).Process(F,New); - if Old<>New then begin - // value was changed -> store modified - UpdateFieldData(pointer(RecordBuffer),length(RecordBuffer),F, - NewRecord,SBFFromRawUTF8(New)); - RecordBuffer := NewRecord; - end; - end; -end; - -{$ifndef NOVARIANTS} -function TSynTable.Data(aID: integer; RecordBuffer: pointer; RecordBufferLen: Integer): Variant; -var data: TSynTableData absolute result; -begin - VarClear(result); - data.VType := SynTableVariantVarType; - data.VID := aID; - data.VTable := self; - pointer(data.VValue) := nil; // avoid GPF - if RecordBuffer=nil then - data.VValue := DefaultRecordData else begin - if RecordBufferLen=0 then - RecordBufferLen := DataLength(RecordBuffer); - SetString(data.VValue,PAnsiChar(RecordBuffer),RecordBufferLen); - end; -end; -{$endif NOVARIANTS} - -function TSynTable.DataLength(RecordBuffer: pointer): integer; -var F: Integer; - PC: PUTF8Char; -begin - if (Self<>nil) and (RecordBuffer<>nil) then begin - PC := RecordBuffer; - for F := 0 to fField.Count-1 do - inc(PC,TSynTableFieldProperties(fField.List[F]).GetLength(PC)); - result := PC-RecordBuffer; - end else - result := 0; -end; - -function TSynTable.UpdateFieldEvent(Sender: TObject; Opaque: pointer; - ID, Index: integer; Data: pointer; DataLen: integer): boolean; -var Added: PUpdateFieldEvent absolute Opaque; - F, aSize: integer; -begin // in practice, this data processing is very fast (thanks to WR speed) - with Added^ do begin - result := Count1 shl 30 then - raise ETableDataException.CreateUTF8('%: File size too big (>1GB)',[self]) else - Offsets64[Count] := WR.TotalWritten; - IDs[Count] := ID; - NewIndexs[Index] := Count; - inc(Count); - end; -end; - -function TSynTable.UpdateFieldRecord(RecordBuffer: PUTF8Char; - var AvailableFields: TSQLFieldBits): TSBFString; -var Lens: array[0..MAX_SQLFIELDS-1] of Integer; - F, Len, TotalLen: integer; - P: PUTF8Char; - Dest: PByte; -begin - // retrieve all field buffer lengths, to speed up record content creation - TotalLen := 0; - P := RecordBuffer; - for F := 0 to fField.Count-1 do - with TSynTableFieldProperties(fField.List[F]) do - if F in AvailableFields then begin - Len := GetLength(P); - inc(P,Len); - inc(TotalLen,Len); - Lens[F] := Len; - end else - inc(TotalLen,fDefaultFieldLength); - // create new record content - P := RecordBuffer; - SetString(Result,nil,TotalLen); - Dest := pointer(Result); - for F := 0 to fField.Count-1 do - with TSynTableFieldProperties(fField.List[F]) do - if F in AvailableFields then begin - Len := Lens[F]; - MoveFast(P^,Dest^,Len); - inc(P,Len); - inc(Dest,Len); - end else begin - FillcharFast(Dest^,fDefaultFieldLength,0); - inc(Dest,fDefaultFieldLength); - end; - //Assert(PtrUInt(Dest)-PtrUInt(result)=PtrUInt(TotalLen)); -end; - -function TSynTable.Validate(RecordBuffer: pointer; RecordIndex: integer): string; -var F: integer; -begin - result := ''; - for F := 0 to fField.Count-1 do - with TSynTableFieldProperties(fField.List[F]) do - if Validates<>nil then begin - result := Validate(RecordBuffer,RecordIndex); - if result<>'' then - exit; - end; -end; - - -{ TSynTableFieldProperties } - -constructor TSynTableFieldProperties.CreateFrom(var RD: TFileBufferReader); -begin - fOrderedIndexFindAdd := -1; - RD.Read(Name); - if not PropNameValid(pointer(Name)) then - RD.ErrorInvalidContent; - RD.Read(@FieldType,SizeOf(FieldType)); - RD.Read(@Options,SizeOf(Options)); - if (FieldType>high(FieldType)) then - RD.ErrorInvalidContent; - OrderedIndexCount := RD.ReadVarUInt32Array(OrderedIndex); - if OrderedIndexCount>0 then begin - if tfoIndex in Options then begin - //assert(OrderedIndexReverse=nil); - OrderedIndexReverseSet(-1); // compute whole OrderedIndexReverse[] array - end else - RD.ErrorInvalidContent; - end; - // we allow a void OrderedIndex[] array from disk -end; - -destructor TSynTableFieldProperties.Destroy; -begin - Filters.Free; - Validates.Free; - inherited; -end; - -function TSynTableFieldProperties.GetJSON(FieldBuffer: pointer; - W: TTextWriter): pointer; -var len: integer; - tmp: RawUTF8; -begin - case FieldType of - // fixed-sized field value - tftBoolean: - W.Add(PBoolean(FieldBuffer)^); - tftUInt8: - W.Add(PByte(FieldBuffer)^); - tftUInt16: - W.Add(PWord(FieldBuffer)^); - tftUInt24: - // PInteger()^ and $ffffff -> possible GPF on Memory Mapped file - W.Add(PWord(FieldBuffer)^+integer(PByteArray(FieldBuffer)^[2])shl 16); - tftInt32: - W.Add(PInteger(FieldBuffer)^); - tftInt64: - W.Add(PInt64(FieldBuffer)^); - tftCurrency: - W.AddCurr64(PInt64(FieldBuffer)^); - tftDouble: - W.AddDouble(unaligned(PDouble(FieldBuffer)^)); - // some variable-size field value - tftVarUInt32: - W.Add(FromVarUInt32(PByte(FieldBuffer))); - tftVarInt32: - W.Add(FromVarInt32(PByte(FieldBuffer))); - tftVarUInt64: - W.AddQ(FromVarUInt64(PByte(FieldBuffer))); - tftVarInt64: - W.Add(FromVarInt64(PByte(FieldBuffer))); - // text storage - WinAnsi could use less space than UTF-8 - tftWinAnsi, tftUTF8: begin - W.Add('"'); - len := FromVarUInt32(PByte(FieldBuffer)); - if len>0 then - if FieldType=tftUTF8 then - W.AddJSONEscape(PAnsiChar(FieldBuffer),len) else begin - SetLength(tmp,len*3); // in-place decoding and appending - W.AddJSONEscape(pointer(tmp),WinAnsiBufferToUtf8(pointer(tmp),PAnsiChar(FieldBuffer),len)-pointer(tmp)); - end; - W.Add('"'); - result := PAnsiChar(FieldBuffer)+len; - exit; - end; - tftBlobInternal: begin - W.AddShort('"X'''); - len := FromVarUInt32(PByte(FieldBuffer)); - W.AddBinToHex(PByte(FieldBuffer),len); - W.Add('''','"'); - end; - tftBlobExternal: - ; // BLOB fields are not handled here, but must be directly accessed - end; - result := PAnsiChar(FieldBuffer)+FieldSize; // // tftWinAnsi,tftUTF8 already done -end; - -function TSynTableFieldProperties.GetLength(FieldBuffer: pointer): Integer; -var PB: PByte; -begin - if FieldSize>=0 then - result := FieldSize else - case FieldSize of - -1: begin // variable-length data - result := 0; - while PByteArray(FieldBuffer)^[result]>$7f do inc(result); - inc(result); - end; - -2: begin // tftWinAnsi, tftUTF8, tftBlobInternal records - result := PByte(FieldBuffer)^; - if result<=$7F then - inc(Result) else begin - PB := FieldBuffer; - result := FromVarUInt32High(PB)+PtrUInt(PB)-PtrUInt(FieldBuffer); - end; - end; - else - result := 0; // tftBlobExternal is not stored in FieldBuffer - end; -end; - -{$ifndef NOVARIANTS} -function TSynTableFieldProperties.GetVariant(FieldBuffer: pointer): Variant; -begin - GetVariant(FieldBuffer,result); -end; - -procedure TSynTableFieldProperties.GetVariant(FieldBuffer: pointer; var result: Variant); -var len: integer; - PB: PByte absolute FieldBuffer; - PA: PAnsiChar absolute FieldBuffer; - PU: PUTF8Char absolute FieldBuffer; - tmp: RawByteString; - {$ifndef HASVARUSTRING} - WS: SynUnicode; - {$endif} -begin - case FieldType of - // fixed-sized field value - tftBoolean: - result := PBoolean(FieldBuffer)^; - tftUInt8: - result := PB^; - tftUInt16: - result := PWord(FieldBuffer)^; - tftUInt24: - // PInteger()^ and $ffffff -> possible GPF on Memory Mapped file - result := PWord(FieldBuffer)^+integer(PByteArray(FieldBuffer)^[2])shl 16; - tftInt32: - result := PInteger(FieldBuffer)^; - tftInt64: - result := PInt64(FieldBuffer)^; - tftCurrency: - result := PCurrency(FieldBuffer)^; - tftDouble: - result := unaligned(PDouble(FieldBuffer)^); - // some variable-size field value - tftVarUInt32: - result := FromVarUInt32(PB); - tftVarInt32: - result := FromVarInt32(PB); - tftVarUInt64: - result := FromVarUInt64(PB); - tftVarInt64: - result := FromVarInt64(PB); - // text storage - WinAnsi could use less space than UTF-8 - tftWinAnsi: begin - len := FromVarUInt32(PB); - if len>0 then - {$ifdef HASVARUSTRING} - result := WinAnsiToUnicodeString(PA,len) - {$else} - result := CurrentAnsiConvert.AnsiToAnsi(WinAnsiConvert,PA,len) - {$endif} else - result := ''; - end; - tftUTF8: begin - len := FromVarUInt32(PB); - if len>0 then - {$ifdef HASVARUSTRING} - result := UTF8DecodeToUnicodeString(PU,len) - {$else} begin - UTF8ToSynUnicode(PU,len,WS); - result := WS; - end - {$endif} else - result := ''; - end; - tftBlobInternal: begin - len := FromVarUInt32(PB); - SetString(tmp,PA,len); - result := tmp; // return internal BLOB content as string - end - else - result := ''; // tftBlobExternal fields e.g. must be directly accessed - end; -end; -{$endif} - -{$ifdef ISDELPHI20062007} - {$WARNINGS OFF} // circument Delphi 2007 false positive warning -{$endif} - -function TSynTableFieldProperties.GetValue(FieldBuffer: pointer): RawUTF8; -var len: integer; - PB: PByte absolute FieldBuffer; - PC: PAnsiChar absolute FieldBuffer; -begin - result := ''; - case FieldType of - // fixed-sized field value - tftBoolean: - result := BOOL_UTF8[PBoolean(FieldBuffer)^]; - tftUInt8: - UInt32ToUtf8(PB^,result); - tftUInt16: - UInt32ToUtf8(PWord(FieldBuffer)^,result); - tftUInt24: - // PInteger()^ and $ffffff -> possible GPF on Memory Mapped file - UInt32ToUtf8(PWord(FieldBuffer)^+integer(PByteArray(FieldBuffer)^[2])shl 16,result); - tftInt32: - Int32ToUtf8(PInteger(FieldBuffer)^,result); - tftInt64: - Int64ToUtf8(PInt64(FieldBuffer)^,result); - tftCurrency: - Curr64ToStr(PInt64(FieldBuffer)^,result); - tftDouble: - DoubleToStr(unaligned(PDouble(FieldBuffer)^),result); - // some variable-size field value - tftVarUInt32: - UInt32ToUtf8(FromVarUInt32(PB),result); - tftVarInt32: - Int32ToUtf8(FromVarInt32(PB),result); - tftVarUInt64: - UInt64ToUtf8(FromVarUInt64(PB),result); - tftVarInt64: - Int64ToUtf8(FromVarInt64(PB),result); - // text storage - WinAnsi could use less space than UTF-8 - tftWinAnsi, tftUTF8, tftBlobInternal: begin - len := FromVarUInt32(PB); - if len>0 then - if FieldType<>tftWinAnsi then - SetString(result,PC,len) else - result := WinAnsiConvert.AnsiBufferToRawUTF8(PC,len); - end; - // tftBlobExternal fields e.g. must be directly accessed - end; -end; - -{$ifdef ISDELPHI20062007} - {$WARNINGS ON} // circument Delphi 2007 false positive warning -{$endif} - -procedure TSynTableFieldProperties.OrderedIndexReverseSet(aOrderedIndex: integer); -var nrev, ndx, n: PtrInt; -begin - n := length(OrderedIndex); - nrev := length(OrderedIndexReverse); - if nrev=0 then - if n=0 then - exit else begin - // void OrderedIndexReverse[] - nrev := MaxInteger(OrderedIndex,OrderedIndexCount,n)+1; - SetLength(OrderedIndexReverse,nrev); - FillcharFast(OrderedIndexReverse[0],nrev*4,255); // all to -1 - Reverse(OrderedIndex,OrderedIndexCount,pointer(OrderedIndexReverse)); - end; - if PtrUInt(aOrderedIndex)>=PtrUInt(OrderedIndexCount) then - exit; // e.g. CreateFrom() will call OrderedIndexReverseSet(-1) - if nrev=nrev then - SetLength(OrderedIndexReverse,ndx+256) else - OrderedIndexReverse[ndx] := aOrderedIndex; -end; - -procedure TSynTableFieldProperties.OrderedIndexSort(L, R: PtrInt); -var I, J, P: PtrInt; - TmpI, TmpJ: integer; -begin - if (L0 do dec(J); - end; - if I <= J then begin - if I < J then begin - TmpJ := OrderedIndex[J]; - TmpI := OrderedIndex[I]; - OrderedIndex[J] := TmpI; - OrderedIndex[I] := TmpJ; - // keep OrderedIndexReverse[OrderedIndex[i]]=i - OrderedIndexReverse[TmpJ] := I; - OrderedIndexReverse[TmpI] := J; - end; - if P = I then P := J else if P = J then P := I; - inc(I); dec(J); - end; - until I > J; - if J - L < R - I then begin // use recursion only for smaller range - if L < J then - OrderedIndexSort(L, J); - L := I; - end else begin - if I < R then - OrderedIndexSort(I, R); - R := J; - end; - until L >= R; -end; - -procedure TSynTableFieldProperties.OrderedIndexRefresh; -begin - if (self=nil) or not OrderedIndexNotSorted then - exit; // already sorted - OrderedIndexSort(0,OrderedIndexCount-1); - OrderedIndexNotSorted := false; -end; - -function TSynTableFieldProperties.OrderedIndexFind(Value: pointer): PtrInt; -var L,R: PtrInt; - cmp: PtrInt; -begin - if OrderedIndexNotSorted then - OrderedIndexRefresh; - L := 0; - R := OrderedIndexCount-1; - with Owner do - if (R>=0) and Assigned(GetRecordData) then - repeat - result := (L + R) shr 1; - cmp := SortCompare(GetData(GetRecordData(OrderedIndex[result],DataTemp1),self),Value); - if cmp=0 then - exit; - if cmp<0 then - L := result + 1 else - R := result - 1; - until (L > R); - result := -1 -end; - -function TSynTableFieldProperties.OrderedIndexFindAdd(Value: pointer): PtrInt; -var L,R,i: PtrInt; - cmp: PtrInt; -begin - if OrderedIndexNotSorted then - OrderedIndexRefresh; - R := OrderedIndexCount-1; - if R<0 then - result := 0 else - with Owner do begin - fOrderedIndexFindAdd := -1; - L := 0; - result := -1; // return -1 if found - repeat - i := (L + R) shr 1; - cmp := SortCompare(GetData(GetRecordData(OrderedIndex[i],DataTemp1),self),Value); - if cmp=0 then - exit; - if cmp<0 then - L := i + 1 else - R := i - 1; - until (L > R); - while (i>=0) and - (SortCompare(GetData(GetRecordData(OrderedIndex[i],DataTemp1),self),Value)>=0) do - dec(i); - result := i+1; // return the index where to insert - end; - fOrderedIndexFindAdd := result; // store inserting index for OrderedIndexUpdate -end; - -function TSynTableFieldProperties.OrderedIndexMatch(WhereSBFValue: pointer; - var MatchIndex: TIntegerDynArray; var MatchIndexCount: integer; Limit: Integer=0): Boolean; -var i, L,R: PtrInt; -begin - result := false; - if (self=nil) or (WhereSBFValue=nil) or not Assigned(Owner.GetRecordData) or - (OrderedIndex=nil) or not (tfoIndex in Options) then - exit; - i := OrderedIndexFind(WhereSBFValue); - if i<0 then - exit; // WHERE value not found - if (tfoUnique in Options) or (Limit=1) then begin - // unique index: direct fastest O(log(n)) binary search - AddSortedInteger(MatchIndex,MatchIndexCount,OrderedIndex[i]); - // AddSortedInteger() will fail if OrderedIndex[i] already exists - end else - with Owner do begin - // multiple index matches possible: add matching range - L := i; - repeat - dec(L); - until (L<0) or (SortCompare(GetData(GetRecordData( - OrderedIndex[L],DataTemp1),self),WhereSBFValue)<>0); - R := i; - repeat - inc(R); - until (R>=OrderedIndexCount) or - (SortCompare(GetData(GetRecordData(OrderedIndex[R],DataTemp1),self),WhereSBFValue)<>0); - if Limit=0 then - Limit := MaxInt; // no LIMIT set -> retrieve all rows - for i := L+1 to R-1 do begin - AddSortedInteger(MatchIndex,MatchIndexCount,OrderedIndex[i]); - dec(Limit); - if Limit=0 then - Break; // reach LIMIT upperbound result count - end; - end; - result := true; -end; - -function TSynTableFieldProperties.OrderedIndexUpdate(aOldIndex, aNewIndex: integer; - aOldRecordData, aNewRecordData: pointer): boolean; -var aOldIndexIndex: integer; -begin - result := false; - if (self=nil) or not Assigned(Owner.GetRecordData) then - exit; // avoid GPF - // update content - if aOldIndex<0 then - if aNewIndex<0 then begin - // both indexes equal -1 -> force sort - OrderedIndexSort(0,OrderedIndexCount-1); - OrderedIndexNotSorted := false; - end else begin - // added record - if tfoUnique in Options then begin - if fOrderedIndexFindAdd<0 then - raise ETableDataException.CreateUTF8( - '%.CheckConstraint call needed before %.OrderedIndexUpdate',[self,Name]); - OrderedIndexReverseSet(InsertInteger(OrderedIndex,OrderedIndexCount, - aNewIndex,fOrderedIndexFindAdd)); - end else begin - AddInteger(OrderedIndex,OrderedIndexCount,aNewIndex); - OrderedIndexReverseSet(OrderedIndexCount-1); - OrderedIndexNotSorted := true; // -> OrderedIndexSort() call on purpose - end; - end else begin - // aOldIndex>=0: update a value - // retrieve position in OrderedIndex[] to be deleted/updated - if OrderedIndexReverse=nil then - OrderedIndexReverseSet(0) else // do OrderedIndexReverse[OrderedIndex[i]] := i - {assert(aOldIndexnil) or (aOldIndex<>aNewIndex) then // not in-place update - with Owner do begin - if aOldRecordData=nil then - aOldRecordData := GetRecordData(aOldIndex,DataTemp1); - if aNewRecordData=nil then - aNewRecordData := GetRecordData(aNewIndex,DataTemp2); - if SortCompare(GetData(aOldRecordData,self),GetData(aNewRecordData,self))=0 then begin - // only sort if field content was modified -> MUCH faster in most case - result := true; - exit; - end; - end; - if tfoUnique in Options then begin - if fOrderedIndexFindAdd>=0 then begin - // we know which OrderedIndex[] has to be changed -> manual update - // - this is still a bottleneck in the current implementation, but - // I was not able to find out how to make it faster, and still - // being able to check unique field constraints without changing the - // OrderedIndex[] content from a simple list into e.g. a red-black - // tree: such a structure performs better, but uses much more memory - // and is to be implemented - // - it's still fast, faster than any DB AFAIK, around 500 updates - // per second with 1,000,000 records on a Core i7 - // - it's still faster to refresh OrderedIndex[] than iterating - // through all items to validate the unique constraint - DeleteInteger(OrderedIndex,OrderedIndexCount,aOldIndexIndex); - if fOrderedIndexFindAdd>aOldIndexIndex then - dec(fOrderedIndexFindAdd); - InsertInteger(OrderedIndex,OrderedIndexCount,aNewIndex,fOrderedIndexFindAdd); - Reverse(OrderedIndex,OrderedIndexCount,pointer(OrderedIndexReverse)); - end else - // slow full sort - with 1,000,000 items it's about 100 times slower - // (never called with common usage in SynBigTable unit) - OrderedIndexSort(0,OrderedIndexCount-1); - end else - OrderedIndexNotSorted := true; // will call OrderedIndexSort() on purpose - end; - end; - fOrderedIndexFindAdd := -1; // consume this value - result := true; -end; - -procedure TSynTableFieldProperties.SaveTo(WR: TFileBufferWriter); -begin - WR.Write(Name); - WR.Write(@FieldType,SizeOf(FieldType)); - WR.Write(@Options,SizeOf(Options)); - WR.WriteVarUInt32Array(OrderedIndex,OrderedIndexCount,wkVarUInt32); -end; - -function TSynTableFieldProperties.SBF(const Value: Int64): TSBFString; -var tmp: array[0..15] of AnsiChar; -begin - case FieldType of - tftInt32: begin // special version for handling negative values - PInteger(@tmp)^ := Value; - SetString(Result,tmp,SizeOf(Integer)); - end; - tftUInt8, tftUInt16, tftUInt24, tftInt64: - SetString(Result,PAnsiChar(@Value),FieldSize); - tftVarUInt32: - SetString(Result,tmp,PAnsiChar(ToVarUInt32(Value,@tmp))-tmp); - tftVarInt32: - SetString(Result,tmp,PAnsiChar(ToVarInt32(Value,@tmp))-tmp); - tftVarUInt64: - SetString(Result,tmp,PAnsiChar(ToVarUInt64(Value,@tmp))-tmp); - tftVarInt64: - SetString(Result,tmp,PAnsiChar(ToVarInt64(Value,@tmp))-tmp); - else - result := ''; - end; -end; - -function TSynTableFieldProperties.SBF(const Value: Integer): TSBFString; -var tmp: array[0..15] of AnsiChar; -begin - case FieldType of - tftUInt8, tftUInt16, tftUInt24, tftInt32: - SetString(Result,PAnsiChar(@Value),FieldSize); - tftInt64: begin // special version for handling negative values - PInt64(@tmp)^ := Value; - SetString(Result,tmp,SizeOf(Int64)); - end; - tftVarUInt32: - if Value<0 then // expect an unsigned integer - result := '' else - SetString(Result,tmp,PAnsiChar(ToVarUInt32(Value,@tmp))-tmp); - tftVarInt32: - SetString(Result,tmp,PAnsiChar(ToVarInt32(Value,@tmp))-tmp); - tftVarUInt64: - if cardinal(Value)>cardinal(maxInt) then - result := '' else // expect a 32 bit integer - SetString(Result,tmp,PAnsiChar(ToVarUInt64(Value,@tmp))-tmp); - tftVarInt64: - SetString(Result,tmp,PAnsiChar(ToVarInt64(Value,@tmp))-tmp); - else - result := ''; - end; -end; - -const - SBF_BOOL: array[boolean] of TSBFString = - (#0,#1); - -{$ifndef NOVARIANTS} -function TSynTableFieldProperties.SBF(const Value: Variant): TSBFString; -var V64: Int64; - VC: Currency absolute V64; - VD: Double absolute V64; -begin // VarIsOrdinal/VarIsFloat/VarIsStr are buggy -> use field type - case FieldType of - tftBoolean: - result := SBF_BOOL[boolean(Value)]; - tftUInt8, tftUInt16, tftUInt24, tftInt32, tftInt64, - tftVarUInt32, tftVarInt32, tftVarUInt64, tftVarInt64: begin - if not VariantToInt64(Value,V64) then - V64 := 0; - result := SBF(V64); - end; - tftCurrency: begin - VC := Value; - SetString(result,PAnsiChar(@VC),SizeOf(VC)); - end; - tftDouble: begin - VD := Value; - SetString(result,PAnsiChar(@VD),SizeOf(VD)); - end; - tftWinAnsi: - ToSBFStr(WinAnsiConvert.UTF8ToAnsi(VariantToUTF8(Value)),result); - tftUTF8: - ToSBFStr(VariantToUTF8(Value),result); - else - result := ''; - end; - if result='' then - result := SBFDefault; -end; -{$endif} - -function TSynTableFieldProperties.SBF(const Value: Boolean): TSBFString; -begin - if FieldType<>tftBoolean then - result := '' else - result := SBF_BOOL[Value]; -end; - -function TSynTableFieldProperties.SBFCurr(const Value: Currency): TSBFString; -begin - if FieldType<>tftCurrency then - result := '' else - SetString(Result,PAnsiChar(@Value),SizeOf(Value)); -end; - -procedure ToSBFStr(const Value: RawByteString; out Result: TSBFString); -var tmp: array[0..15] of AnsiChar; - Len, Head: integer; -begin - if PtrUInt(Value)=0 then - Result := #0 else begin - Len := {$ifdef FPC}length(Value){$else}PInteger(PtrUInt(Value)-SizeOf(integer))^{$endif}; - Head := PAnsiChar(ToVarUInt32(Len,@tmp))-tmp; - SetLength(Result,Len+Head); - MoveFast(tmp,PByteArray(Result)[0],Head); - MoveFast(pointer(Value)^,PByteArray(Result)[Head],Len); - end; -end; - -function TSynTableFieldProperties.SBF(const Value: RawUTF8): TSBFString; -begin - case FieldType of - tftUTF8: - ToSBFStr(Value,Result); - tftWinAnsi: - ToSBFStr(Utf8ToWinAnsi(Value),Result); - else - result := ''; - end; -end; - -function TSynTableFieldProperties.SBF(Value: pointer; ValueLen: integer): TSBFString; -var tmp: array[0..15] of AnsiChar; - Head: integer; -begin - if FieldType<>tftBlobInternal then - result := '' else - if (Value=nil) or (ValueLen=0) then - result := #0 else begin // inlined ToSBFStr() code - Head := PAnsiChar(ToVarUInt32(ValueLen,@tmp))-tmp; - SetString(Result,nil,ValueLen+Head); - MoveFast(tmp,PByteArray(Result)[0],Head); - MoveFast(Value^,PByteArray(Result)[Head],ValueLen); - end; -end; - -function TSynTableFieldProperties.SBFFloat(const Value: Double): TSBFString; -begin - if FieldType<>tftDouble then - result := '' else - SetString(Result,PAnsiChar(@Value),SizeOf(Value)); -end; - -function TSynTableFieldProperties.SBFFromRawUTF8(const aValue: RawUTF8): TSBFString; -var Curr: Currency; -begin - case FieldType of - tftBoolean: - if (SynCommons.GetInteger(pointer(aValue))<>0) or IdemPropNameU(aValue,'true') then - result := #1 else - result := #0; // store false by default - tftUInt8, tftUInt16, tftUInt24, tftInt32, tftVarInt32: - result := SBF(SynCommons.GetInteger(pointer(aValue))); - tftVarUInt32, tftInt64, tftVarUInt64, tftVarInt64: - result := SBF(SynCommons.GetInt64(pointer(aValue))); - tftCurrency: begin - PInt64(@Curr)^ := StrToCurr64(pointer(aValue)); - result := SBFCurr(Curr); - end; - tftDouble: - result := SBFFloat(GetExtended(pointer(aValue))); - // text storage - WinAnsi could use less space than UTF-8 - tftUTF8, tftWinAnsi: - result := SBF(aValue); - else - result := ''; // tftBlob* fields e.g. must be handled directly - end; -end; - -function TSynTableFieldProperties.GetInteger(RecordBuffer: pointer): Integer; -begin - if (self=nil) or (RecordBuffer=nil) or (Owner=nil) then - result := 0 else begin - RecordBuffer := Owner.GetData(RecordBuffer,self); - case FieldType of - tftBoolean, tftUInt8: - result := PByte(RecordBuffer)^; - tftUInt16: - result := PWord(RecordBuffer)^; - tftUInt24: - // PInteger()^ and $ffffff -> possible GPF on Memory Mapped file - result := PWord(RecordBuffer)^+integer(PByteArray(RecordBuffer)^[2])shl 16; - tftInt32: - result := PInteger(RecordBuffer)^; - tftInt64: - result := PInt64(RecordBuffer)^; - // some variable-size field value - tftVarUInt32: - result := FromVarUInt32(PByte(RecordBuffer)); - tftVarInt32: - result := FromVarInt32(PByte(RecordBuffer)); - tftVarUInt64: - result := FromVarUInt64(PByte(RecordBuffer)); - tftVarInt64: - result := FromVarInt64(PByte(RecordBuffer)); - else - result := 0; - end; - end; -end; - -function TSynTableFieldProperties.GetInt64(RecordBuffer: pointer): Int64; -var PB: PByte; -begin - if (self=nil) or (RecordBuffer=nil) or (Owner=nil) then - result := 0 else begin - PB := Owner.GetData(RecordBuffer,self); - case FieldType of - tftInt64: - result := PInt64(PB)^; - tftVarUInt64: - result := FromVarUInt64(PB); - tftVarInt64: - result := FromVarInt64(PB); - else - result := GetInteger(RecordBuffer); - end; - end; -end; - -function TSynTableFieldProperties.GetBoolean(RecordBuffer: pointer): Boolean; -begin - result := boolean(GetInteger(RecordBuffer)); -end; - -function TSynTableFieldProperties.GetCurrency(RecordBuffer: pointer): Currency; -begin - if (self=nil) or (RecordBuffer=nil) or (Owner=nil) then - result := 0 else - case FieldType of - tftCurrency: - result := PCurrency(Owner.GetData(RecordBuffer,self))^; - else - result := GetInt64(RecordBuffer); - end; -end; - -function TSynTableFieldProperties.GetDouble(RecordBuffer: pointer): Double; -begin - if (self=nil) or (RecordBuffer=nil) or (Owner=nil) then - result := 0 else - case FieldType of - tftDouble: - result := unaligned(PDouble(Owner.GetData(RecordBuffer,self))^); - else - result := GetInt64(RecordBuffer); - end; -end; - -function TSynTableFieldProperties.GetRawUTF8(RecordBuffer: pointer): RawUTF8; -begin - if (self=nil) or (RecordBuffer=nil) or (Owner=nil) then - result := '' else begin - RecordBuffer := Owner.GetData(RecordBuffer,self); - if RecordBuffer<>nil then - result := GetValue(RecordBuffer) else // will do conversion to text - result := ''; - end; -end; - -function TSynTableFieldProperties.AddFilterOrValidate(aFilter: TSynFilterOrValidate): TSynFilterOrValidate; - procedure Add(var List: TSynObjectList); - begin - if List=nil then - List := TSynObjectList.Create; - List.Add(result); - end; -begin - result := aFilter; - if (self=nil) or (result=nil) then - result := nil else - if aFilter.InheritsFrom(TSynFilter) then - Add(Filters) else - if aFilter.InheritsFrom(TSynValidate) then - Add(Validates) else - result := nil; -end; - -function TSynTableFieldProperties.Validate(RecordBuffer: pointer; - RecordIndex: integer): string; -var i: integer; - Value: RawUTF8; - aValidate: TSynValidate; - aValidateTable: TSynValidateTable absolute aValidate; -begin - result := ''; - if (self=nil) or (Validates=nil) then - exit; - Value := GetRawUTF8(RecordBuffer); // TSynTableValidate needs RawUTF8 text - for i := 0 to Validates.Count-1 do begin - aValidate := Validates.List[i]; - if aValidate.InheritsFrom(TSynValidateTable) then begin - aValidateTable.ProcessField := self; - aValidateTable.ProcessRecordIndex := RecordIndex; - end; - if not aValidate.Process(FieldNumber,Value,result) then begin - if result='' then - // no custom message -> show a default message - result := format(sValidationFailed,[ - GetCaptionFromClass(aValidate.ClassType)]); - break; - end; - end; -end; - -{$ifdef SORTCOMPAREMETHOD} -function TSynTableFieldProperties.SortCompare(P1, P2: PUTF8Char): PtrInt; -var i, L: integer; -label minus,plus,zer; -begin - if P1<>P2 then - if P1<>nil then - if P2<>nil then - case FieldType of - tftBoolean, tftUInt8: - result := PByte(P1)^-PByte(P2)^; - tftUInt16: - result := PWord(P1)^-PWord(P2)^; - tftUInt24: - result := PtrInt(PWord(P1)^)+PtrInt(P1[2])shl 16 - -PtrInt(PWord(P2)^)-PtrInt(P2[2]) shl 16; - tftInt32: - result := PInteger(P1)^-PInteger(P2)^; - tftDouble: begin - unaligned(PDouble(@SortCompareTmp)^) := unaligned(PDouble(P1)^)-unaligned(PDouble(P2)^); - if unaligned(PDouble(@SortCompareTmp)^)<0 then - goto minus else - if unaligned(PDouble(@SortCompareTmp)^)>0 then - goto plus else - goto zer; - end; - tftVarUInt32: - with SortCompareTmp do begin - PB1 := Pointer(P1); - PB2 := Pointer(P2); - result := FromVarUInt32(PB1)-FromVarUInt32(PB2); - end; - tftVarInt32: - with SortCompareTmp do begin - PB1 := Pointer(P1); - PB2 := Pointer(P2); - result := FromVarInt32(PB1)-FromVarInt32(PB2); - end; - {$ifdef CPUX86} // circumvent comparison slowness (and QWord bug) - tftInt64, tftCurrency: - result := SortInt64(PInt64(P1)^,PInt64(P2)^); - tftVarUInt64: - with SortCompareTmp do begin - PB1 := Pointer(P1); - PB2 := Pointer(P2); - result := SortQWord(FromVarUInt64(PB1),FromVarUInt64(PB2)); - end; - tftVarInt64: - with SortCompareTmp do begin - PB1 := Pointer(P1); - PB2 := Pointer(P2); - result := SortInt64(FromVarInt64(PB1),FromVarInt64(PB2)); - end; - {$else} - {$ifdef CPU64} // PtrInt = Int64 - tftInt64, tftCurrency: - result := PInt64(P1)^-PInt64(P2)^; - tftVarUInt64: - with SortCompareTmp do begin - PB1 := Pointer(P1); - PB2 := Pointer(P2); - result := FromVarUInt64(PB1)-FromVarUInt64(PB2); - end; - tftVarInt64: - with SortCompareTmp do begin - PB1 := Pointer(P1); - PB2 := Pointer(P2); - result := FromVarInt64(PB1)-FromVarInt64(PB2); - end; - {$else} - tftInt64, tftCurrency: begin - PInt64(@SortCompareTmp)^ := PInt64(P1)^-PInt64(P2)^; - if PInt64(@SortCompareTmp)^<0 then - goto minus else - if PInt64(@SortCompareTmp)^>0 then - goto plus else - goto zer; - end; - tftVarUInt64: - with SortCompareTmp do begin - PB1 := Pointer(P1); - PB2 := Pointer(P2); - PInt64(@SortCompareTmp)^ := FromVarUInt64(PB1)-FromVarUInt64(PB2); - if PInt64(@SortCompareTmp)^<0 then - goto minus else - if PInt64(@SortCompareTmp)^>0 then - goto plus else - goto zer; - end; - tftVarInt64: - with SortCompareTmp do begin - PB1 := Pointer(P1); - PB2 := Pointer(P2); - PInt64(@SortCompareTmp)^ := FromVarInt64(PB1)-FromVarInt64(PB2); - if PInt64(@SortCompareTmp)^<0 then - goto minus else - if PInt64(@SortCompareTmp)^>0 then - goto plus else - goto zer; - end; - {$endif} - {$endif} - tftWinAnsi, tftUTF8, tftBlobInternal: - begin - with SortCompareTmp do begin - if PtrInt(P1^)<=$7F then begin - L1 := PtrInt(P1^); - inc(P1); - end else begin - PB1 := pointer(P1); - L1 := FromVarUInt32High(PB1); - P1 := pointer(PB1); - end; - if PtrInt(P2^)<=$7F then begin - L2 := PtrInt(P2^); - inc(P2); - end else begin - PB2 := pointer(P2); - L2 := FromVarUInt32High(PB2); - P2 := pointer(PB2); - end; - end; - with SortCompareTmp do begin - L := L1; - if L2>L then - L := L2; - end; - if tfoCaseInsensitive in Options then begin - i := 0; - while i0 then - exit else - inc(i); - end; - end else begin - i := 0; - while i0 then - exit else - inc(i); - end; - end; - with SortCompareTmp do - result := L1-L2; - end; - else - goto zer; - end else -plus: result := 1 else // P2=nil -minus:result := -1 else // P1=nil -zer:result := 0; // P1=P2 -end; -{$endif} - -function CompareOperator(FieldType: TSynTableFieldType; SBF, SBFEnd: PUTF8Char; - Value: Int64; Oper: TCompareOperator): boolean; -var V: Int64; - PB: PByte absolute SBF; -begin - result := true; - if PB<>nil then - repeat - case FieldType of - tftBoolean, tftUInt8: - V := PB^; - tftUInt16: - V := PWord(PB)^; - tftUInt24: - // PInteger()^ and $ffffff -> possible GPF on Memory Mapped file - V := PWord(PB)^+integer(PByteArray(PB)^[2])shl 16; - tftInt32: - V := PInteger(PB)^; - tftInt64: - V := PInt64(PB)^; - // some variable-size field value - tftVarUInt32: - V := FromVarUInt32(PB); - tftVarInt32: - V := FromVarInt32(PB); - tftVarUInt64: - V := FromVarUInt64(PB); - tftVarInt64: - V := FromVarInt64(PB); - else V := 0; // makes compiler happy - end; - case Oper of - soEqualTo: if V=Value then exit; - soNotEqualTo: if V<>Value then exit; - soLessThan: if VValue then exit; - soGreaterThanOrEqualTo: if V>=Value then exit; - else break; - end; - // not found: go to next value - if SBFEnd=nil then - break; // only one value to be checked - if FIELD_FIXEDSIZE[FieldType]>0 then - inc(SBF,FIELD_FIXEDSIZE[FieldType]); // FromVar*() already updated PB/SBF - until SBF>=SBFEnd; - result := false; // not found -end; - -function CompareOperator(SBF, SBFEnd: PUTF8Char; - Value: double; Oper: TCompareOperator): boolean; -begin - result := true; - if SBF<>nil then - repeat - case Oper of - soEqualTo: if unaligned(PDouble(SBF)^)=Value then exit; - soNotEqualTo: if unaligned(PDouble(SBF)^)<>Value then exit; - soLessThan: if unaligned(PDouble(SBF)^)Value then exit; - soGreaterThanOrEqualTo: if unaligned(PDouble(SBF)^)>=Value then exit; - else break; - end; - // not found: go to next value - if SBFEnd=nil then - break; // only one value to be checked - inc(SBF,SizeOf(Value)); - until SBF>=SBFEnd; - result := false; // not found -end; - -function CompareOperator(FieldType: TSynTableFieldType; SBF, SBFEnd: PUTF8Char; - Value: PUTF8Char; ValueLen: integer; Oper: TCompareOperator; - CaseSensitive: boolean): boolean; overload; -var L, Cmp: PtrInt; - PB: PByte; - tmp: array[byte] of AnsiChar; -begin - result := true; - if SBF<>nil then - repeat - // get length of text in the SBF encoded buffer - if integer(SBF^)<=$7f then begin - L := integer(SBF^); - inc(SBF); - end else begin - PB := Pointer(SBF); - L := FromVarUInt32(PB); - SBF := pointer(PB); - end; - // perform comparison: returns nil on match - case Oper of - soEqualTo..soGreaterThanOrEqualTo: begin - Cmp := L-ValueLen; - if Cmp<0 then - L := ValueLen; - if CaseSensitive then - Cmp := StrCompL(SBF,Value,L,Cmp) else - Cmp := StrCompIL(SBF,Value,L,Cmp); - case Oper of - soEqualTo: if Cmp=0 then exit; - soNotEqualTo: if Cmp<>0 then exit; - soLessThan: if Cmp<0 then exit; - soLessThanOrEqualTo: if Cmp<=0 then exit; - soGreaterThan: if Cmp>0 then exit; - soGreaterThanOrEqualTo: if Cmp>=0 then exit; - end; - end; - soBeginWith: - if ValueLen>=L then - if CaseSensitive then begin - if StrCompL(SBF,Value,ValueLen,0)=0 then - exit; - end else - if StrCompIL(SBF,Value,ValueLen,0)=0 then - exit; - soContains: begin - dec(L,ValueLen); - while L>=0 do begin - while (L>=0) and not(tcWord in TEXT_CHARS[SBF^]) do begin - dec(L); - inc(SBF); - end; // begin of next word reached - if L<0 then - Break; // not enough chars to contain the Value - if CaseSensitive then begin - if StrCompL(SBF,Value,ValueLen,0)=0 then - exit; - end else - if StrCompIL(SBF,Value,ValueLen,0)=0 then - exit; - while (L>=0) and (tcWord in TEXT_CHARS[SBF^]) do begin - dec(L); - inc(SBF); - end; // end of word reached - end; - if SBFEnd=nil then - break; // only one value to be checked - inc(SBF,ValueLen); // custom inc(SBF,L); - if SBFhigh(tmp) then - Cmp := high(tmp) else - Cmp := L; - tmp[Cmp] := #0; // TSynSoundEx expect the buffer to be #0 terminated - MoveFast(SBF^,tmp,Cmp); - case FieldType of - tftWinAnsi: - if PSynSoundEx(Value)^.Ansi(tmp) then - exit; - tftUTF8: - if PSynSoundEx(Value)^.UTF8(tmp) then - exit; - else break; - end; - end; - else break; - end; - // no match -> go to the end of the SBF buffer - if SBFEnd=nil then - exit; // only one value to be checked - inc(SBF,L); - if SBF>=SBFEnd then - break; - until false; -end; - - -{ TSynValidateTableUniqueField } - -function TSynValidateTableUniqueField.Process(aFieldIndex: integer; - const Value: RawUTF8; var ErrorMsg: string): boolean; -var S: TSBFString; -begin - result := false; - if (self=nil) or (Value='') or (ProcessField=nil) then - exit; // void field can't be unique - if not (tfoIndex in ProcessField.Options) then - exit; // index should be always created by TSynTable.AfterFieldModif - S := ProcessField.SBFFromRawUTF8(Value); - if S='' then - exit; // void field can't be unique - if ProcessField.OrderedIndexFindAdd(Pointer(S))>=0 then - // there is some place to insert the Value -> not existing yet -> OK - result := true else begin - // RecordIndex=-1 in case of adding, or the physical index of the updated record - if (ProcessRecordIndex>=0) and - (ProcessField.OrderedIndex[ProcessField.OrderedIndexFind(Pointer(S))]= - ProcessRecordIndex) then - // allow update of the record - result := true else - // found a dupplicated value - ErrorMsg := sValidationFieldDuplicate; - end; -end; - - -{ TSynTableStatement } - -const - NULL_UPP = ord('N')+ord('U')shl 8+ord('L')shl 16+ord('L')shl 24; - -constructor TSynTableStatement.Create(const SQL: RawUTF8; - GetFieldIndex: TSynTableFieldIndex; SimpleFieldsBits: TSQLFieldBits; - FieldProp: TSynTableFieldProperties); -var Prop, whereBefore: RawUTF8; - P, B: PUTF8Char; - ndx,err,len,selectCount,whereCount: integer; - whereWithOR,whereNotClause: boolean; - -function GetPropIndex: integer; -begin - if not GetNextFieldProp(P,Prop) then - result := -1 else - if IsRowID(pointer(Prop)) then - result := 0 else begin // 0 = ID field - result := GetFieldIndex(Prop); - if result>=0 then // -1 = no valid field name - inc(result); // otherwise: PropertyIndex+1 - end; -end; -function SetFields: boolean; -var select: TSynTableStatementSelect; - B: PUTF8Char; -begin - result := false; - FillcharFast(select,SizeOf(select),0); - select.Field := GetPropIndex; // 0 = ID, otherwise PropertyIndex+1 - if select.Field<0 then begin - if P^<>'(' then // Field not found -> try function(field) - exit; - P := GotoNextNotSpace(P+1); - select.FunctionName := Prop; - inc(fSelectFunctionCount); - if IdemPropNameU(Prop,'COUNT') and (P^='*') then begin - select.Field := 0; // count( * ) -> count(ID) - select.FunctionKnown := funcCountStar; - P := GotoNextNotSpace(P+1); - end else begin - if IdemPropNameU(Prop,'DISTINCT') then - select.FunctionKnown := funcDistinct else - if IdemPropNameU(Prop,'MAX') then - select.FunctionKnown := funcMax; - select.Field := GetPropIndex; - if select.Field<0 then - exit; - end; - if P^<>')' then - exit; - P := GotoNextNotSpace(P+1); - end else - if P^='.' then begin // MongoDB-like field.subfield1.subfield2 - B := P; - repeat - inc(P); - until not (jcJsonIdentifier in JSON_CHARS[P^]); - FastSetString(select.SubField,B,P-B); - fHasSelectSubFields := true; - end; - if P^ in ['+','-'] then begin - select.ToBeAdded := GetNextItemInteger(P,' '); - if select.ToBeAdded=0 then - exit; - P := GotoNextNotSpace(P); - end; - if IdemPChar(P,'AS ') then begin - inc(P,3); - if not GetNextFieldProp(P,select.Alias) then - exit; - end; - SetLength(fSelect,selectCount+1); - fSelect[selectCount] := select; - inc(selectCount); - result := true; -end; -function GetWhereValue(var Where: TSynTableStatementWhere): boolean; -var B: PUTF8Char; -begin - result := false; - P := GotoNextNotSpace(P); - Where.ValueSQL := P; - if PWord(P)^=ord(':')+ord('(') shl 8 then - inc(P,2); // ignore :(...): parameter (no prepared statements here) - if P^ in ['''','"'] then begin - // SQL String statement - P := UnQuoteSQLStringVar(P,Where.Value); - if P=nil then - exit; // end of string before end quote -> incorrect - {$ifndef NOVARIANTS} - RawUTF8ToVariant(Where.Value,Where.ValueVariant); - {$endif} - if FieldProp<>nil then - // create a SBF formatted version of the WHERE value - Where.ValueSBF := FieldProp.SBFFromRawUTF8(Where.Value); - end else - if (PInteger(P)^ and $DFDFDFDF=NULL_UPP) and (P[4] in [#0..' ',';']) then begin - // NULL statement - Where.Value := NULL_STR_VAR; // not void - {$ifndef NOVARIANTS} - SetVariantNull(Where.ValueVariant); - {$endif} - inc(P,4); - end else begin - // numeric statement or 'true' or 'false' (OK for NormalizeValue) - B := P; - repeat - inc(P); - until P^ in [#0..' ',';',')',',']; - SetString(Where.Value,B,P-B); - {$ifndef NOVARIANTS} - Where.ValueVariant := VariantLoadJSON(Where.Value); - {$endif} - Where.ValueInteger := GetInteger(pointer(Where.Value),err); - if FieldProp<>nil then - if Where.Value<>'?' then - if (FieldProp.FieldType in FIELD_INTEGER) and (err<>0) then - // we expect a true INTEGER value here - Where.Value := '' else - // create a SBF formatted version of the WHERE value - Where.ValueSBF := FieldProp.SBFFromRawUTF8(Where.Value); - end; - if PWord(P)^=ord(')')+ord(':')shl 8 then - inc(P,2); // ignore :(...): parameter - Where.ValueSQLLen := P-Where.ValueSQL; - P := GotoNextNotSpace(P); - if (P^=')') and (Where.FunctionName='') then begin - B := P; - repeat - inc(P); - until not (P^ in [#1..' ',')']); - while P[-1]=' ' do dec(P); // trim right space - SetString(Where.ParenthesisAfter,B,P-B); - P := GotoNextNotSpace(P); - end; - result := true; -end; -{$ifndef NOVARIANTS} -function GetWhereValues(var Where: TSynTableStatementWhere): boolean; -var v: TSynTableStatementWhereDynArray; - n, w: integer; - tmp: RawUTF8; -begin - result := false; - if Where.ValueSQLLen<=2 then - exit; - SetString(tmp,PAnsiChar(Where.ValueSQL)+1,Where.ValueSQLLen-2); - P := pointer(tmp); // parse again the IN (...,...,... ) expression - n := 0; - try - repeat - if n=length(v) then - SetLength(v,NextGrow(n)); - if not GetWhereValue(v[n]) then - exit; - inc(n); - if P^=#0 then - break; - if P^<>',' then - exit; - inc(P); - until false; - finally - P := Where.ValueSQL+Where.ValueSQLLen; // continue parsing as usual - end; - with TDocVariantData(Where.ValueVariant) do begin - InitFast(n,dvArray); - for w := 0 to n-1 do - AddItem(v[w].ValueVariant); - Where.Value := ToJSON; - end; - result := true; -end; -{$endif} -function GetWhereExpression(FieldIndex: integer; var Where: TSynTableStatementWhere): boolean; -var B: PUTF8Char; -begin - result := false; - Where.ParenthesisBefore := whereBefore; - Where.JoinedOR := whereWithOR; - Where.NotClause := whereNotClause; - Where.Field := FieldIndex; // 0 = ID, otherwise PropertyIndex+1 - if P^='.' then begin // MongoDB-like field.subfield1.subfield2 - B := P; - repeat - inc(P); - until not (jcJsonIdentifier in JSON_CHARS[P^]); - FastSetString(Where.SubField,B,P-B); - fWhereHasSubFields := true; - P := GotoNextNotSpace(P); - end; - case P^ of - '=': Where.Operator := opEqualTo; - '>': if P[1]='=' then begin - inc(P); - Where.Operator := opGreaterThanOrEqualTo; - end else - Where.Operator := opGreaterThan; - '<': case P[1] of - '=': begin - inc(P); - Where.Operator := opLessThanOrEqualTo; - end; - '>': begin - inc(P); - Where.Operator := opNotEqualTo; - end; - else - Where.Operator := opLessThan; - end; - 'i','I': - case P[1] of - 's','S': begin - P := GotoNextNotSpace(P+2); - if IdemPChar(P,'NULL') then begin - Where.Value := NULL_STR_VAR; - Where.Operator := opIsNull; - Where.ValueSQL := P; - Where.ValueSQLLen := 4; - {$ifndef NOVARIANTS} - TVarData(Where.ValueVariant).VType := varNull; - {$endif} - inc(P,4); - result := true; - end else - if IdemPChar(P,'NOT NULL') then begin - Where.Value := 'not null'; - Where.Operator := opIsNotNull; - Where.ValueSQL := P; - Where.ValueSQLLen := 8; - {$ifndef NOVARIANTS} - TVarData(Where.ValueVariant).VType := varNull; - {$endif} - inc(P,8); - result := true; // leave ValueVariant=unassigned - end; - exit; - end; - {$ifndef NOVARIANTS} - 'n','N': begin - Where.Operator := opIn; - P := GotoNextNotSpace(P+2); - if P^<>'(' then - exit; // incorrect SQL statement - B := P; // get the IN() clause as JSON - inc(P); - while (P^<>')') or (P[1]=':') do // handle :(...): within the clause - if P^=#0 then - exit else - inc(P); - inc(P); - SetString(Where.Value,PAnsiChar(B),P-B); - Where.ValueSQL := B; - Where.ValueSQLLen := P-B; - result := GetWhereValues(Where); - exit; - end; - {$endif} - end; // 'i','I': - 'l','L': - if IdemPChar(P+1,'IKE') then begin - inc(P,3); - Where.Operator := opLike; - end else - exit; - else exit; // unknown operator - end; - // we got 'WHERE FieldName operator ' -> handle value - inc(P); - result := GetWhereValue(Where); -end; - -label lim,lim2; -begin - P := pointer(SQL); - if (P=nil) or (self=nil) then - exit; // avoid GPF - P := GotoNextNotSpace(P); // trim left - if not IdemPChar(P,'SELECT ') then - exit else // handle only SELECT statement - inc(P,7); - // 1. get SELECT clause: set bits in Fields from CSV field IDs in SQL - selectCount := 0; - P := GotoNextNotSpace(P); // trim left - if P^=#0 then - exit; // no SQL statement - if P^='*' then begin // all simple (not TSQLRawBlob/TSQLRecordMany) fields - inc(P); - len := GetBitsCount(SimpleFieldsBits,MAX_SQLFIELDS)+1; - SetLength(fSelect,len); - selectCount := 1; // Select[0].Field := 0 -> ID - for ndx := 0 to MAX_SQLFIELDS-1 do - if ndx in SimpleFieldsBits then begin - fSelect[selectCount].Field := ndx+1; - inc(selectCount); - if selectCount=len then - break; - end; - GetNextFieldProp(P,Prop); - end else - if not SetFields then - exit else // we need at least one field name - if P^<>',' then - GetNextFieldProp(P,Prop) else - repeat - while P^ in [',',#1..' '] do inc(P); // trim left - until not SetFields; // add other CSV field names - // 2. get FROM clause - if not IdemPropNameU(Prop,'FROM') then exit; // incorrect SQL statement - GetNextFieldProp(P,Prop); - fTableName := Prop; - // 3. get WHERE clause - whereCount := 0; - whereWithOR := false; - whereNotClause := false; - whereBefore := ''; - GetNextFieldProp(P,Prop); - if IdemPropNameU(Prop,'WHERE') then begin - repeat - B := P; - if P^='(' then begin - fWhereHasParenthesis := true; - repeat - inc(P); - until not (P^ in [#1..' ','(']); - while P[-1]=' ' do dec(P); // trim right space - SetString(whereBefore,B,P-B); - B := P; - end; - ndx := GetPropIndex; - if ndx<0 then begin - if IdemPropNameU(Prop,'NOT') then begin - whereNotClause := true; - continue; - end; - if P^='(' then begin - inc(P); - SetLength(fWhere,whereCount+1); - with fWhere[whereCount] do begin - ParenthesisBefore := whereBefore; - JoinedOR := whereWithOR; - NotClause := whereNotClause; - FunctionName := UpperCase(Prop); - // Byte/Word/Integer/Cardinal/Int64/CurrencyDynArrayContains(BlobField,I64) - len := length(Prop); - if (len>16) and - IdemPropName('DynArrayContains',PUTF8Char(@PByteArray(Prop)[len-16]),16) then - Operator := opContains else - Operator := opFunction; - B := P; - Field := GetPropIndex; - if Field<0 then - P := B else - if P^<>',' then - break else - P := GotoNextNotSpace(P+1); - if (P^=')') or - (GetWhereValue(fWhere[whereCount]) and (P^=')')) then begin - inc(P); - break; - end; - end; - end; - P := B; - break; - end; - SetLength(fWhere,whereCount+1); - if not GetWhereExpression(ndx,fWhere[whereCount]) then - exit; // invalid SQL statement - inc(whereCount); - GetNextFieldProp(P,Prop); - if IdemPropNameU(Prop,'OR') then - whereWithOR := true else - if IdemPropNameU(Prop,'AND') then - whereWithOR := false else - goto lim2; - whereNotClause := false; - whereBefore := ''; - until false; - // 4. get optional LIMIT/OFFSET/ORDER clause -lim:P := GotoNextNotSpace(P); - while (P<>nil) and not(P^ in [#0,';']) do begin - GetNextFieldProp(P,Prop); -lim2: if IdemPropNameU(Prop,'LIMIT') then - fLimit := GetNextItemCardinal(P,' ') else - if IdemPropNameU(Prop,'OFFSET') then - fOffset := GetNextItemCardinal(P,' ') else - if IdemPropNameU(Prop,'ORDER') then begin - GetNextFieldProp(P,Prop); - if IdemPropNameU(Prop,'BY') then begin - repeat - ndx := GetPropIndex; // 0 = ID, otherwise PropertyIndex+1 - if ndx<0 then - exit; // incorrect SQL statement - AddFieldIndex(fOrderByField,ndx); - if P^<>',' then begin // check ORDER BY ... ASC/DESC - B := P; - if GetNextFieldProp(P,Prop) then - if IdemPropNameU(Prop,'DESC') then - fOrderByDesc := true else - if not IdemPropNameU(Prop,'ASC') then - P := B; - break; - end; - P := GotoNextNotSpace(P+1); - until P^ in [#0,';']; - end else - exit; // incorrect SQL statement - end else - if IdemPropNameU(Prop,'GROUP') then begin - GetNextFieldProp(P,Prop); - if IdemPropNameU(Prop,'BY') then begin - repeat - ndx := GetPropIndex; // 0 = ID, otherwise PropertyIndex+1 - if ndx<0 then - exit; // incorrect SQL statement - AddFieldIndex(fGroupByField,ndx); - if P^<>',' then - break; - P := GotoNextNotSpace(P+1); - until P^ in [#0,';']; - end else - exit; // incorrect SQL statement - end else - if (Prop<>'') or not(GotoNextNotSpace(P)^ in [#0, ';']) then - exit else // incorrect SQL statement - break; // reached the end of the statement - end; - end else - if Prop<>'' then - goto lim2; // handle LIMIT OFFSET ORDER - fSQLStatement := SQL; // make a private copy e.g. for Where[].ValueSQL -end; - -procedure TSynTableStatement.SelectFieldBits(var Fields: TSQLFieldBits; - var withID: boolean; SubFields: PRawUTF8Array); -var i: integer; - f: ^TSynTableStatementSelect; -begin - FillcharFast(Fields,SizeOf(Fields),0); - withID := false; - f := pointer(Select); - for i := 1 to Length(Select) do begin - if f^.Field=0 then - withID := true else - include(Fields,f^.Field-1); - if (SubFields<>nil) and fHasSelectSubFields then - SubFields^[f^.Field] := f^.SubField; - inc(f); - end; -end; - - -{$ifndef DELPHI5OROLDER} - -{ TSynTableData } - -procedure TSynTableData.CheckVTableInitialized; -begin - if VTable=nil then - raise ETableDataException.Create('TSynTableData non initialized'); -end; - -{$ifndef NOVARIANTS} - -function TSynTableData.GetField(const FieldName: RawUTF8): Variant; -begin - GetFieldVariant(FieldName,result); -end; - -function TSynTableData.GetFieldVarData(FieldName: PUTF8Char; FieldNameLen: PtrInt; - var Value: TVarData): boolean; -var aField: TSynTableFieldProperties; -begin - if IsRowID(FieldName,FieldNameLen) then begin - PVariant(@Value)^ := VID; - result := true; - end else begin - CheckVTableInitialized; - aField := VTable.GetFieldFromNameLen(FieldName,FieldNameLen); - if aField<>nil then begin - aField.GetVariant(VTable.GetData(pointer(VValue),aField),PVariant(@Value)^); - result := true; - end else - result := false; - end; -end; - -procedure TSynTableData.GetFieldVariant(const FieldName: RawUTF8; var result: Variant); -var aField: TSynTableFieldProperties; -begin - if IsRowID(Pointer(FieldName)) then - result := VID else begin - CheckVTableInitialized; - aField := VTable.FieldFromName[FieldName]; - if aField=nil then - raise ETableDataException.CreateUTF8('Unknown % property',[FieldName]) else - aField.GetVariant(VTable.GetData(pointer(VValue),aField),result); - end; -end; - -function TSynTableData.GetFieldValue(aField: TSynTableFieldProperties): Variant; -begin - CheckVTableInitialized; - aField.GetVariant(VTable.GetData(pointer(VValue),aField),result); -end; - -{$endif NOVARIANTS} - -procedure TSynTableData.FilterSBFValue; -begin - CheckVTableInitialized; - VTable.Filter(VValue); -end; - -function TSynTableData.GetFieldSBFValue(aField: TSynTableFieldProperties): TSBFString; -var FieldBuffer: PAnsiChar; -begin - CheckVTableInitialized; - FieldBuffer := VTable.GetData(pointer(VValue),aField); - SetString(Result,FieldBuffer,aField.GetLength(FieldBuffer)); -end; - -procedure TSynTableData.Init(aTable: TSynTable; aID: Integer); -begin - VType := SynTableVariantVarType; - VID := aID; - VTable := aTable; - VValue := VTable.DefaultRecordData; -end; - -procedure TSynTableData.Init(aTable: TSynTable; aID: Integer; - RecordBuffer: pointer; RecordBufferLen: integer); -begin - VType := SynTableVariantVarType; - VTable := aTable; - if (RecordBufferLen=0) or (RecordBuffer=nil) then begin - VID := 0; - VValue := VTable.DefaultRecordData; - end else begin - VID := aID; - SetString(VValue,PAnsiChar(RecordBuffer),RecordBufferLen); - end; -end; - -{$ifndef NOVARIANTS} -procedure TSynTableData.SetField(const FieldName: RawUTF8; - const Value: Variant); -var F: TSynTableFieldProperties; -begin - CheckVTableInitialized; - if IsRowID(Pointer(FieldName)) then - VID := Value else begin - F := VTable.FieldFromName[FieldName]; - if F=nil then - raise ETableDataException.CreateUTF8('Unknown % property',[FieldName]) else - SetFieldValue(F,Value); - end; -end; - -procedure TSynTableData.SetFieldValue(aField: TSynTableFieldProperties; const Value: Variant); -begin - SetFieldSBFValue(aField,aField.SBF(Value)); -end; -{$endif} - -procedure TSynTableData.SetFieldSBFValue(aField: TSynTableFieldProperties; - const Value: TSBFString); -var NewValue: TSBFString; -begin - CheckVTableInitialized; - if (aField.FieldSize>0) and (VValue<>'') then begin - // fixed size content: fast in-place update - MoveFast(pointer(Value)^,VValue[aField.Offset+1],aField.FieldSize) - // VValue[F.Offset+1] above will call UniqueString(VValue), even under FPC - end else begin - // variable-length update - VTable.UpdateFieldData(pointer(VValue),length(VValue), - aField.FieldNumber,NewValue,Value); - VValue := NewValue; - end; -end; - -function TSynTableData.ValidateSBFValue(RecordIndex: integer): string; -begin - CheckVTableInitialized; - Result := VTable.Validate(Pointer(VValue),RecordIndex); -end; - -{$endif DELPHI5OROLDER} - - -{ ************ text search and functions ****************** } - -// code below adapted from ZMatchPattern.pas - http://www.zeoslib.sourceforge.net - -procedure TMatch.MatchMain; -var RangeStart, RangeEnd: PtrInt; - c: AnsiChar; - flags: set of(Invert, MemberMatch); -begin - while ((State = sNONE) and (P <= PMax)) do begin - c := Upper[Pattern[P]]; - if T > TMax then begin - if (c = '*') and (P + 1 > PMax) then - State := sVALID else - State := sABORT; - exit; - end else - case c of - '?': ; - '*': - MatchAfterStar; - '[': begin - inc(P); - byte(flags) := 0; - if Pattern[P] in ['!','^'] then begin - include(flags, Invert); - inc(P); - end; - if (Pattern[P] = ']') then begin - State := sPATTERN; - exit; - end; - c := Upper[Text[T]]; - while Pattern[P] <> ']' do begin - RangeStart := P; - RangeEnd := P; - inc(P); - if P > PMax then begin - State := sPATTERN; - exit; - end; - if Pattern[P] = '-' then begin - inc(P); - RangeEnd := P; - if (P > PMax) or (Pattern[RangeEnd] = ']') then begin - State := sPATTERN; - exit; - end; - inc(P); - end; - if P > PMax then begin - State := sPATTERN; - exit; - end; - if RangeStart < RangeEnd then begin - if (c >= Upper[Pattern[RangeStart]]) and (c <= Upper[Pattern[RangeEnd]]) then begin - include(flags, MemberMatch); - break; - end; - end - else - if (c >= Upper[Pattern[RangeEnd]]) and (c <= Upper[Pattern[RangeStart]]) then begin - include(flags, MemberMatch); - break; - end; - end; - if ((Invert in flags) and (MemberMatch in flags)) or - not ((Invert in flags) or (MemberMatch in flags)) then begin - State := sRANGE; - exit; - end; - if MemberMatch in flags then - while (P <= PMax) and (Pattern[P] <> ']') do - inc(P); - if P > PMax then begin - State := sPATTERN; - exit; - end; - end; - else - if c <> Upper[Text[T]] then - State := sLITERAL; - end; - inc(P); - inc(T); - end; - if State = sNONE then - if T <= TMax then - State := sEND else - State := sVALID; -end; - -procedure TMatch.MatchAfterStar; -var retryT, retryP: PtrInt; -begin - if (TMax = 1) or (P = PMax) then begin - State := sVALID; - exit; - end else - if (PMax = 0) or (TMax = 0) then begin - State := sABORT; - exit; - end; - while ((T <= TMax) and (P < PMax)) and (Pattern[P] in ['?', '*']) do begin - if Pattern[P] = '?' then - inc(T); - inc(P); - end; - if T >= TMax then begin - State := sABORT; - exit; - end else - if P >= PMax then begin - State := sVALID; - exit; - end; - repeat - if (Upper[Pattern[P]] = Upper[Text[T]]) or (Pattern[P] = '[') then begin - retryT := T; - retryP := P; - MatchMain; - if State = sVALID then - break; - State := sNONE; // retry until end of Text, (check below) or State valid - T := retryT; - P := retryP; - end; - inc(T); - if (T > TMax) or (P > PMax) then begin - State := sABORT; - exit; - end; - until State <> sNONE; -end; - -function SearchAny(aMatch: PMatch; aText: PUTF8Char; aTextLen: PtrInt): boolean; -begin - aMatch.State := sNONE; - aMatch.P := 0; - aMatch.T := 0; - aMatch.Text := aText; - aMatch.TMax := aTextLen - 1; - aMatch.MatchMain; - result := aMatch.State = sVALID; -end; - -// faster alternative (without recursion) for only * ? (but not [...]) - -function SearchNoRange(aMatch: PMatch; aText: PUTF8Char; aTextLen: PtrInt): boolean; -{$ifdef CPUX86} -var - c: AnsiChar; - pat, txt: PtrInt; // use local registers -begin - aMatch.T := 0; // aMatch.P/T are used for retry positions after * - aMatch.Text := aText; - aMatch.TMax := aTextLen - 1; - pat := 0; - txt := 0; - repeat - if pat <= aMatch.PMax then begin - c := aMatch.Pattern[pat]; - case c of - '?': - if txt <= aMatch.TMax then begin - inc(pat); - inc(txt); - continue; - end; - '*': begin - aMatch.P := pat; - aMatch.T := txt + 1; - inc(pat); - continue; - end; - else if (txt <= aMatch.TMax) and (c = aMatch.Text[txt]) then begin - inc(pat); - inc(txt); - continue; - end; - end; - end - else if txt > aMatch.TMax then - break; - txt := aMatch.T; - if (txt > 0) and (txt <= aMatch.TMax + 1) then begin - inc(aMatch.T); - pat := aMatch.P+1; - continue; - end; - result := false; - exit; - until false; - result := true; -end; -{$else} // optimized for x86_64/ARM with more registers -var - c: AnsiChar; - pat, patend, txtend, txtretry, patretry: PUTF8Char; -label - fin; -begin - pat := pointer(aMatch.Pattern); - if pat = nil then - goto fin; - patend := pat + aMatch.PMax; - patretry := nil; - txtend := aText + aTextLen - 1; - txtretry := nil; - repeat - if pat <= patend then begin - c := pat^; - if c <> '*' then - if c <> '?' then begin - if (aText <= txtend) and (c = aText^) then begin - inc(pat); - inc(aText); - continue; - end; - end - else begin // '?' - if aText <= txtend then begin - inc(pat); - inc(aText); - continue; - end; - end - else begin // '*' - inc(pat); - txtretry := aText + 1; - patretry := pat; - continue; - end; - end - else if aText > txtend then - break; - if (PtrInt(PtrUInt(txtretry)) > 0) and (txtretry <= txtend + 1) then begin - aText := txtretry; - inc(txtretry); - pat := patretry; - continue; - end; -fin:result := false; - exit; - until false; - result := true; -end; -{$endif CPUX86} - -function SearchNoRangeU(aMatch: PMatch; aText: PUTF8Char; aTextLen: PtrInt): boolean; -var - c: AnsiChar; - pat, txt: PtrInt; -begin - aMatch.T := 0; - aMatch.Text := aText; - aMatch.TMax := aTextLen - 1; - pat := 0; - txt := 0; - repeat - if pat <= aMatch.PMax then begin - c := aMatch.Pattern[pat]; - case c of - '?': - if txt <= aMatch.TMax then begin - inc(pat); - inc(txt); - continue; - end; - '*': begin - aMatch.P := pat; - aMatch.T := txt + 1; - inc(pat); - continue; - end; - else if (txt <= aMatch.TMax) and - (aMatch.Upper[c] = aMatch.Upper[aMatch.Text[txt]]) then begin - inc(pat); - inc(txt); - continue; - end; - end; - end - else if txt > aMatch.TMax then - break; - txt := aMatch.T; - if (txt > 0) and (txt <= aMatch.TMax + 1) then begin - inc(aMatch.T); - pat := aMatch.P+1; - continue; - end; - result := false; - exit; - until false; - result := true; -end; - -function SimpleContainsU(t, tend, p: PUTF8Char; pmax: PtrInt; up: PNormTable): boolean; - {$ifdef HASINLINE}inline;{$endif} -// brute force case-insensitive search p[0..pmax] in t..tend-1 -var first: AnsiChar; - i: PtrInt; -label next; -begin - first := up[p^]; - repeat - if up[t^] <> first then begin -next: inc(t); - if t < tend then - continue else - break; - end; - for i := 1 to pmax do - if up[t[i]] <> up[p[i]] then - goto next; - result := true; - exit; - until false; - result := false; -end; - -{$ifdef CPU64} // naive but very efficient code generation on FPC x86-64 -function SimpleContains8(t, tend, p: PUTF8Char; pmax: PtrInt): boolean; inline; -label next; -var i, first: PtrInt; -begin - first := PPtrInt(p)^; - repeat - if PPtrInt(t)^ <> first then begin -next: inc(t); - if t < tend then - continue else - break; - end; - for i := 8 to pmax do - if t[i] <> p[i] then - goto next; - result := true; - exit; - until false; - result := false; -end; -{$endif CPU64} - -function SimpleContains4(t, tend, p: PUTF8Char; pmax: PtrInt): boolean; - {$ifdef HASINLINE}inline;{$endif} -label next; -var i: PtrInt; -{$ifdef CPUX86} // circumvent lack of registers for this CPU -begin - repeat - if PCardinal(t)^ <> PCardinal(p)^ then begin -{$else} - first: cardinal; -begin - first := PCardinal(p)^; - repeat - if PCardinal(t)^ <> first then begin -{$endif} -next: inc(t); - if t < tend then - continue else - break; - end; - for i := 4 to pmax do - if t[i] <> p[i] then - goto next; - result := true; - exit; - until false; - result := false; -end; - -function SimpleContains1(t, tend, p: PUTF8Char; pmax: PtrInt): boolean; - {$ifdef HASINLINE}inline;{$endif} -label next; -var i: PtrInt; -{$ifdef CPUX86} -begin - repeat - if t^ <> p^ then begin -{$else} - first: AnsiChar; -begin - first := p^; - repeat - if t^ <> first then begin -{$endif} -next: inc(t); - if t < tend then - continue else - break; - end; - for i := 1 to pmax do - if t[i] <> p[i] then - goto next; - result := true; - exit; - until false; - result := false; -end; - -function CompareMemU(P1, P2: PUTF8Char; len: PtrInt; U: PNormTable): Boolean; - {$ifdef FPC}inline;{$endif} -begin // here we know that len>0 - result := false; - repeat - dec(len); - if U[P1[len]] <> U[P2[len]] then - exit; - until len = 0; - result := true; -end; - -function SearchVoid(aMatch: PMatch; aText: PUTF8Char; aTextLen: PtrInt): boolean; -begin - result := aTextLen = 0; -end; - -function SearchNoPattern(aMatch: PMatch; aText: PUTF8Char; aTextLen: PtrInt): boolean; -begin - result := (aMatch.PMax + 1 = aTextlen) and CompareMem(aText, aMatch.Pattern, aTextLen); -end; - -function SearchNoPatternU(aMatch: PMatch; aText: PUTF8Char; aTextLen: PtrInt): boolean; -begin - result := (aMatch.PMax + 1 = aTextlen) and CompareMemU(aText, aMatch.Pattern, aTextLen, aMatch.Upper); -end; - -function SearchContainsValid(aMatch: PMatch; aText: PUTF8Char; aTextLen: PtrInt): boolean; -begin - result := true; -end; - -function SearchContainsU(aMatch: PMatch; aText: PUTF8Char; aTextLen: PtrInt): boolean; -begin - dec(aTextLen, aMatch.PMax); - if aTextLen > 0 then - result := SimpleContainsU(aText, aText + aTextLen, aMatch.Pattern, aMatch.PMax, aMatch.Upper) - else - result := false; -end; - -function SearchContains1(aMatch: PMatch; aText: PUTF8Char; aTextLen: PtrInt): boolean; -begin - dec(aTextLen, aMatch.PMax); - if aTextLen > 0 then - result := SimpleContains1(aText, aText + aTextLen, aMatch.Pattern, aMatch.PMax) - else - result := false; -end; - -function SearchContains4(aMatch: PMatch; aText: PUTF8Char; aTextLen: PtrInt): boolean; -begin - dec(aTextLen, aMatch.PMax); - if aTextLen > 0 then - result := SimpleContains4(aText, aText + aTextLen, aMatch.Pattern, aMatch.PMax) - else - result := false; -end; - -{$ifdef CPU64} -function SearchContains8(aMatch: PMatch; aText: PUTF8Char; aTextLen: PtrInt): boolean; -begin // optimized e.g. to search an IP address as '*12.34.56.78*' in logs - dec(aTextLen, aMatch.PMax); - if aTextLen > 0 then - result := SimpleContains8(aText, aText + aTextLen, aMatch.Pattern, aMatch.PMax) - else - result := false; -end; -{$endif CPU64} - -function SearchStartWith(aMatch: PMatch; aText: PUTF8Char; aTextLen: PtrInt): boolean; -begin - result := (aMatch.PMax < aTextlen) and CompareMem(aText, aMatch.Pattern, aMatch.PMax + 1); -end; - -function SearchStartWithU(aMatch: PMatch; aText: PUTF8Char; aTextLen: PtrInt): boolean; -begin - result := (aMatch.PMax < aTextlen) and CompareMemU(aText, aMatch.Pattern, aMatch.PMax + 1, aMatch.Upper); -end; - -function SearchEndWith(aMatch: PMatch; aText: PUTF8Char; aTextLen: PtrInt): boolean; -begin - dec(aTextLen, aMatch.PMax); - result := (aTextlen >= 0) and CompareMem(aText + aTextLen, aMatch.Pattern, aMatch.PMax); -end; - -function SearchEndWithU(aMatch: PMatch; aText: PUTF8Char; aTextLen: PtrInt): boolean; -begin - dec(aTextLen, aMatch.PMax); - result := (aTextlen >= 0) and CompareMemU(aText + aTextLen, aMatch.Pattern, aMatch.PMax, aMatch.Upper); -end; - -procedure TMatch.Prepare(const aPattern: RawUTF8; aCaseInsensitive, aReuse: boolean); -begin - Prepare(pointer(aPattern), length(aPattern), aCaseInsensitive, aReuse); -end; - -procedure TMatch.Prepare(aPattern: PUTF8Char; aPatternLen: integer; - aCaseInsensitive, aReuse: boolean); -const SPECIALS: PUTF8Char = '*?['; -begin - Pattern := aPattern; - PMax := aPatternLen - 1; // search in Pattern[0..PMax] - if Pattern = nil then begin - Search := SearchVoid; - exit; - end; - if aCaseInsensitive and not IsCaseSensitive(aPattern,aPatternLen) then - aCaseInsensitive := false; // don't slow down e.g. number or IP search - if aCaseInsensitive then - Upper := @NormToUpperAnsi7 else - Upper := @NormToNorm; - Search := nil; - if aReuse then - if strcspn(Pattern, SPECIALS) > PMax then - if aCaseInsensitive then - Search := SearchNoPatternU - else - Search := SearchNoPattern - else if PMax > 0 then begin - if Pattern[PMax] = '*' then begin - if strcspn(Pattern + 1, SPECIALS) = PMax - 1 then - case Pattern[0] of - '*': begin // *something* - inc(Pattern); - dec(PMax, 2); // trim trailing and ending * - if PMax < 0 then - Search := SearchContainsValid - else if aCaseInsensitive then - Search := SearchContainsU - {$ifdef CPU64} - else if PMax >= 7 then - Search := SearchContains8 - {$endif} - else if PMax >= 3 then - Search := SearchContains4 - else - Search := SearchContains1; - end; - '?': // ?something* - if aCaseInsensitive then - Search := SearchNoRangeU - else - Search := SearchNoRange; - '[': - Search := SearchAny; - else begin - dec(PMax); // trim trailing * - if aCaseInsensitive then - Search := SearchStartWithU - else - Search := SearchStartWith; - end; - end; - end - else if (Pattern[0] = '*') and (strcspn(Pattern + 1, SPECIALS) >= PMax) then begin - inc(Pattern); // jump leading * - if aCaseInsensitive then - Search := SearchEndWithU - else - Search := SearchEndWith; - end; - end else - if Pattern[0] in ['*','?'] then - Search := SearchContainsValid; - if not Assigned(Search) then begin - aPattern := PosChar(Pattern, '['); - if (aPattern = nil) or (aPattern - Pattern > PMax) then - if aCaseInsensitive then - Search := SearchNoRangeU - else - Search := SearchNoRange - else - Search := SearchAny; - end; -end; - -type // Holub and Durian (2005) SBNDM2 algorithm - // see http://www.cri.haifa.ac.il/events/2005/string/presentations/Holub.pdf - TSBNDMQ2Mask = array[AnsiChar] of cardinal; - PSBNDMQ2Mask = ^TSBNDMQ2Mask; - -function SearchSBNDMQ2ComputeMask(const Pattern: RawUTF8; u: PNormTable): RawByteString; -var - i: PtrInt; - p: PAnsiChar absolute Pattern; - m: PSBNDMQ2Mask absolute result; - c: PCardinal; -begin - SetString(result, nil, SizeOf(m^)); - FillCharFast(m^, SizeOf(m^), 0); - for i := 0 to length(Pattern) - 1 do begin - c := @m^[u[p[i]]]; // for FPC code generation - c^ := c^ or (1 shl i); - end; -end; - -function SearchSBNDMQ2(aMatch: PMatch; aText: PUTF8Char; aTextLen: PtrInt): boolean; -var - mask: PSBNDMQ2Mask; - max, i, j: PtrInt; - state: cardinal; -begin - mask := pointer(aMatch^.Pattern); // was filled by SearchSBNDMQ2ComputeMask() - max := aMatch^.PMax; - i := max - 1; - dec(aTextLen); - if i < aTextLen then begin - repeat - state := mask[aText[i+1]] shr 1; // in two steps for better FPC codegen - state := state and mask[aText[i]]; - if state = 0 then begin - inc(i, max); // fast skip - if i >= aTextLen then - break; - continue; - end; - j := i - max; - repeat - dec(i); - if i < 0 then - break; - state := (state shr 1) and mask[aText[i]]; - until state = 0; - if i = j then begin - result := true; - exit; - end; - inc(i, max); - if i >= aTextLen then - break; - until false; - end; - result := false; -end; - -function SearchSBNDMQ2U(aMatch: PMatch; aText: PUTF8Char; aTextLen: PtrInt): boolean; -var - u: PNormTable; - mask: PSBNDMQ2Mask; - max, i, j: PtrInt; - state: cardinal; -begin - mask := pointer(aMatch^.Pattern); - max := aMatch^.PMax; - u := aMatch^.Upper; - i := max - 1; - dec(aTextLen); - if i < aTextLen then begin - repeat - state := mask[u[aText[i+1]]] shr 1; - state := state and mask[u[aText[i]]]; - if state = 0 then begin - inc(i, max); - if i >= aTextLen then - break; - continue; - end; - j := i - max; - repeat - dec(i); - if i < 0 then - break; - state := (state shr 1) and mask[u[aText[i]]]; - until state = 0; - if i = j then begin - result := true; - exit; - end; - inc(i, max); - if i >= aTextLen then - break; - until false; - end; - result := false; -end; - -procedure TMatch.PrepareContains(var aPattern: RawUTF8; - aCaseInsensitive: boolean); -begin - PMax := length(aPattern) - 1; - if aCaseInsensitive and not IsCaseSensitive(pointer(aPattern), PMax + 1) then - aCaseInsensitive := false; - if aCaseInsensitive then - Upper := @NormToUpperAnsi7 - else - Upper := @NormToNorm; - if PMax < 0 then - Search := SearchContainsValid - else if PMax > 30 then - if aCaseInsensitive then - Search := SearchContainsU - else - Search := {$ifdef CPU64}SearchContains8{$else}SearchContains4{$endif} - else if PMax >= 1 then begin // len in [2..31] = PMax in [1..30] - aPattern := SearchSBNDMQ2ComputeMask(aPattern, Upper); // lookup table - if aCaseInsensitive then - Search := SearchSBNDMQ2U - else - Search := SearchSBNDMQ2; - end - else if aCaseInsensitive then - Search := SearchContainsU - else - Search := SearchContains1; // todo: use IndexByte() on FPC? - Pattern := pointer(aPattern); -end; - -procedure TMatch.PrepareRaw(aPattern: PUTF8Char; aPatternLen: integer; - aSearch: TMatchSearchFunction); -begin - Pattern := aPattern; - PMax := aPatternLen - 1; // search in Pattern[0..PMax] - Search := aSearch; -end; - -function TMatch.Match(const aText: RawUTF8): boolean; -begin - if aText <> '' then - result := Search(@self, pointer(aText), length(aText)) - else - result := PMax < 0; -end; - -function TMatch.Match(aText: PUTF8Char; aTextLen: PtrInt): boolean; -begin - if (aText <> nil) and (aTextLen > 0) then - result := Search(@self, aText, aTextLen) - else - result := PMax < 0; -end; - -function TMatch.MatchThreadSafe(const aText: RawUTF8): boolean; -var local: TMatch; // thread-safe with no lock! -begin - local := self; - if aText <> '' then - result := local.Search(@local, pointer(aText), length(aText)) - else - result := local.PMax < 0; -end; - -function TMatch.MatchString(const aText: string): boolean; -var - local: TMatch; // thread-safe with no lock! - temp: TSynTempBuffer; - len: integer; -begin - if aText = '' then begin - result := PMax < 0; - exit; - end; - len := length(aText); - temp.Init(len * 3); - {$ifdef UNICODE} - len := RawUnicodeToUtf8(temp.buf, temp.len + 1, pointer(aText), len, [ccfNoTrailingZero]); - {$else} - len := CurrentAnsiConvert.AnsiBufferToUTF8(temp.buf, pointer(aText), len) - temp.buf; - {$endif} - local := self; - result := local.Search(@local, temp.buf, len); - temp.Done; -end; - -function TMatch.Equals(const aAnother{$ifndef DELPHI5OROLDER}: TMatch{$endif}): boolean; -begin - result := (PMax = TMatch(aAnother).PMax) and (Upper = TMatch(aAnother).Upper) and - CompareMem(Pattern, TMatch(aAnother).Pattern, PMax + 1); -end; - -function TMatch.PatternLength: integer; -begin - result := PMax + 1; -end; - -function TMatch.PatternText: PUTF8Char; -begin - result := Pattern; -end; - -function IsMatch(const Pattern, Text: RawUTF8; CaseInsensitive: boolean): boolean; -var match: TMatch; -begin - match.Prepare(Pattern, CaseInsensitive, {reuse=}false); - result := match.Match(Text); -end; - -function IsMatchString(const Pattern, Text: string; CaseInsensitive: boolean): boolean; -var match: TMatch; - pat, txt: RawUTF8; -begin - StringToUTF8(Pattern, pat); // local variable is mandatory for FPC - StringToUTF8(Text, txt); - match.Prepare(pat, CaseInsensitive, {reuse=}false); - result := match.Match(txt); -end; - -function SetMatchs(const CSVPattern: RawUTF8; CaseInsensitive: boolean; - out Match: TMatchDynArray): integer; -var P, S: PUTF8Char; -begin - result := 0; - P := pointer(CSVPattern); - if P <> nil then - repeat - S := P; - while not (P^ in [#0, ',']) do - inc(P); - if P <> S then begin - SetLength(Match, result + 1); - Match[result].Prepare(S, P - S, CaseInsensitive, {reuse=}true); - inc(result); - end; - if P^ = #0 then - break; - inc(P); - until false; -end; - -function SetMatchs(CSVPattern: PUTF8Char; CaseInsensitive: boolean; - Match: PMatch; MatchMax: integer): integer; -var S: PUTF8Char; -begin - result := 0; - if (CSVPattern <> nil) and (MatchMax >= 0) then - repeat - S := CSVPattern; - while not (CSVPattern^ in [#0, ',']) do - inc(CSVPattern); - if CSVPattern <> S then begin - Match^.Prepare(S, CSVPattern - S, CaseInsensitive, {reuse=}true); - inc(result); - if result > MatchMax then - break; - inc(Match); - end; - if CSVPattern^ = #0 then - break; - inc(CSVPattern); - until false; -end; - -function MatchExists(const One: TMatch; const Several: TMatchDynArray): boolean; -var - i: integer; -begin - result := true; - for i := 0 to high(Several) do - if Several[i].Equals(One) then - exit; - result := false; -end; - -function MatchAdd(const One: TMatch; var Several: TMatchDynArray): boolean; -var - n: integer; -begin - result := not MatchExists(One, Several); - if result then begin - n := length(Several); - SetLength(Several, n + 1); - Several[n] := One; - end; -end; - -function MatchAny(const Match: TMatchDynArray; const Text: RawUTF8): boolean; -var - m: PMatch; - i: integer; -begin - result := true; - if Match = nil then - exit; - m := pointer(Match); - for i := 1 to length(Match) do - if m^.Match(Text) then - exit - else - inc(m); - result := false; -end; - -procedure FilterMatchs(const CSVPattern: RawUTF8; CaseInsensitive: boolean; - var Values: TRawUTF8DynArray); -var - match: TMatchDynArray; - m, n, i: integer; -begin - if SetMatchs(CSVPattern, CaseInsensitive, match) = 0 then - exit; - n := 0; - for i := 0 to high(Values) do - for m := 0 to high(match) do - if match[m].Match(Values[i]) then begin - if i <> n then - Values[n] := Values[i]; - inc(n); - break; - end; - if n <> length(Values) then - SetLength(Values, n); -end; - - -{ TMatchs } - -constructor TMatchs.Create(const aPatterns: TRawUTF8DynArray; CaseInsensitive: Boolean); -begin - inherited Create; - Subscribe(aPatterns, CaseInsensitive); -end; - -function TMatchs.Match(const aText: RawUTF8): integer; -begin - result := Match(pointer(aText), length(aText)); -end; - -function TMatchs.Match(aText: PUTF8Char; aLen: integer): integer; -var - one: ^TMatchStore; - local: TMatch; // thread-safe with no lock! -begin - if (self = nil) or (fMatch = nil) then - result := -1 // no filter by name -> allow e.g. to process everything - else begin - one := pointer(fMatch); - if aLen <> 0 then begin - for result := 0 to fMatchCount - 1 do begin - local := one^.Pattern; - if local.Search(@local, aText, aLen) then - exit; - inc(one); - end; - end - else - for result := 0 to fMatchCount - 1 do - if one^.Pattern.PMax < 0 then - exit - else - inc(one); - result := -2; - end; -end; - -function TMatchs.MatchString(const aText: string): integer; -var - temp: TSynTempBuffer; - len: integer; -begin - len := length(aText); - temp.Init(len * 3); - {$ifdef UNICODE} - len := RawUnicodeToUtf8(temp.buf, temp.len + 1, pointer(aText), len, [ccfNoTrailingZero]); - {$else} - len := CurrentAnsiConvert.AnsiBufferToUTF8(temp.buf, pointer(aText), len, true) - temp.buf; - {$endif} - result := Match(temp.buf, len); - temp.Done; -end; - -procedure TMatchs.Subscribe(const aPatternsCSV: RawUTF8; CaseInsensitive: Boolean); -var - patterns: TRawUTF8DynArray; -begin - CSVToRawUTF8DynArray(pointer(aPatternsCSV), patterns); - Subscribe(patterns, CaseInsensitive); -end; - -procedure TMatchs.Subscribe(const aPatterns: TRawUTF8DynArray; CaseInsensitive: Boolean); -var - i, j, m, n: integer; - found: ^TMatchStore; - pat: PRawUTF8; -begin - m := length(aPatterns); - if m = 0 then - exit; - n := fMatchCount; - SetLength(fMatch, n + m); - pat := pointer(aPatterns); - for i := 1 to m do begin - found := pointer(fMatch); - for j := 1 to n do - if StrComp(pointer(found^.PatternInstance), pointer(pat^)) = 0 then begin - found := nil; - break; - end - else - inc(found); - if found <> nil then - with fMatch[n] do begin - PatternInstance := pat^; // avoid GPF if aPatterns[] is released - Pattern.Prepare(PatternInstance, CaseInsensitive, {reuse=}true); - inc(n); - end; - inc(pat); - end; - fMatchCount := n; - if n <> length(fMatch) then - SetLength(fMatch, n); -end; - - -procedure SoundExComputeAnsi(var p: PAnsiChar; var result: cardinal; Values: PSoundExValues); -var n,v,old: PtrUInt; -begin - n := 0; - old := 0; - if Values<>nil then - repeat - {$ifdef USENORMTOUPPER} - v := NormToUpperByte[ord(p^)]; // also handle 8 bit WinAnsi (1252 accents) - {$else} - v := NormToUpperAnsi7Byte[ord(p^)]; // 7 bit char uppercase - {$endif} - if not (tcWord in TEXT_BYTES[v]) then break; - inc(p); - dec(v,ord('B')); - if v>high(TSoundExValues) then continue; - v := Values[v]; // get soundex value - if (v=0) or (v=old) then continue; // invalid or dopple value - old := v; - result := result shl SOUNDEX_BITS; - inc(result,v); - inc(n); - if n=((32-8)div SOUNDEX_BITS) then // first char use up to 8 bits - break; // result up to a cardinal size - until false; -end; - -function SoundExComputeFirstCharAnsi(var p: PAnsiChar): cardinal; -label Err; -begin - if p=nil then begin -Err:result := 0; - exit; - end; - repeat - {$ifdef USENORMTOUPPER} - result := NormToUpperByte[ord(p^)]; // also handle 8 bit WinAnsi (CP 1252) - {$else} - result := NormToUpperAnsi7Byte[ord(p^)]; // 7 bit char uppercase - {$endif} - if result=0 then - goto Err; // end of input text, without a word - inc(p); - // trim initial spaces or 'H' - until AnsiChar(result) in ['A'..'G','I'..'Z']; -end; - -procedure SoundExComputeUTF8(var U: PUTF8Char; var result: cardinal; Values: PSoundExValues); -var n,v,old: cardinal; -begin - n := 0; - old := 0; - if Values<>nil then - repeat - v := GetNextUTF8Upper(U); - if not (tcWord in TEXT_BYTES[v]) then break; - dec(v,ord('B')); - if v>high(TSoundExValues) then continue; - v := Values[v]; // get soundex value - if (v=0) or (v=old) then continue; // invalid or dopple value - old := v; - result := result shl SOUNDEX_BITS; - inc(result,v); - inc(n); - if n=((32-8)div SOUNDEX_BITS) then // first char use up to 8 bits - break; // result up to a cardinal size - until false; -end; - -function SoundExComputeFirstCharUTF8(var U: PUTF8Char): cardinal; -label Err; -begin - if U=nil then begin -Err:result := 0; - exit; - end; - repeat - result := GetNextUTF8Upper(U); - if result=0 then - goto Err; // end of input text, without a word - // trim initial spaces or 'H' - until AnsiChar(result) in ['A'..'G','I'..'Z']; -end; - - -{ TSynSoundEx } - -const - /// english Soundex pronunciation scores - // - defines the default values used for the SoundEx() function below - // (used if Values parameter is nil) - ValueEnglish: TSoundExValues = - // B C D E F G H I J K L M N O P Q R S T U V W X Y Z - (1,2,3,0,1,2,0,0,2,2,4,5,5,0,1,2,6,2,3,0,1,0,2,0,2); - - /// french Soundex pronunciation scores - // - can be used to override default values used for the SoundEx() - // function below - ValueFrench: TSoundExValues = - // B C D E F G H I J K L M N O P Q R S T U V W X Y Z - (1,2,3,0,9,7,0,0,7,2,4,5,5,0,1,2,6,8,3,0,9,0,8,0,8); - - /// spanish Soundex pronunciation scores - // - can be used to override default values used for the SoundEx() - // function below - ValueSpanish: TSoundExValues = - // B C D E F G H I J K L M N O P Q R S T U V W X Y Z - (1,2,3,0,1,2,0,0,0,2,0,5,5,0,1,2,6,2,3,0,1,0,2,0,2); - - SOUNDEXVALUES: array[TSynSoundExPronunciation] of PSoundExValues = - (@ValueEnglish,@ValueFrench,@ValueSpanish,@ValueEnglish); - -function TSynSoundEx.Ansi(A: PAnsiChar): boolean; -var Value, c: cardinal; -begin - result := false; - if A=nil then exit; - repeat - // test beginning of word - c := SoundExComputeFirstCharAnsi(A); - if c=0 then exit else - if c=FirstChar then begin - // here we had the first char match -> check if word match UpperValue - Value := c-(ord('A')-1); - SoundExComputeAnsi(A,Value,fValues); - if Value=search then begin - result := true; // UpperValue found! - exit; - end; - end else - repeat - if A^=#0 then exit else -{$ifdef USENORMTOUPPER} - if not(tcWord in TEXT_CHARS[NormToUpper[A^]]) then break else inc(A); -{$else} if not(tcWord in TEXT_CHARS[A^]) then break else inc(A); {$endif} - until false; - // find beginning of next word - repeat - if A^=#0 then exit else -{$ifdef USENORMTOUPPER} - if tcWord in TEXT_CHARS[NormToUpper[A^]] then break else inc(A); -{$else} if tcWord in TEXT_CHARS[A^] then break else inc(A); {$endif} - until false; - until false; -end; - -function TSynSoundEx.UTF8(U: PUTF8Char): boolean; -var Value, c: cardinal; - V: PUTF8Char; -begin - result := false; - if U=nil then exit; - repeat - // find beginning of word - c := SoundExComputeFirstCharUTF8(U); - if c=0 then exit else - if c=FirstChar then begin - // here we had the first char match -> check if word match UpperValue - Value := c-(ord('A')-1); - SoundExComputeUTF8(U,Value,fValues); - if Value=search then begin - result := true; // UpperValue found! - exit; - end; - end else - repeat - c := GetNextUTF8Upper(U); - if c=0 then - exit; - until not(tcWord in TEXT_BYTES[c]); - // find beginning of next word - repeat - if U=nil then exit; - V := U; - c := GetNextUTF8Upper(U); - if c=0 then - exit; - until tcWord in TEXT_BYTES[c]; - U := V; - until U=nil; -end; - -function TSynSoundEx.Prepare(UpperValue: PAnsiChar; Lang: PSoundExValues): boolean; -begin - fValues := Lang; - Search := SoundExAnsi(UpperValue,nil,Lang); - if Search=0 then - result := false else begin - FirstChar := SoundExComputeFirstCharAnsi(UpperValue); - result := true; - end; -end; - -function TSynSoundEx.Prepare(UpperValue: PAnsiChar; Lang: TSynSoundExPronunciation): boolean; -begin - result := Prepare(UpperValue,SOUNDEXVALUES[Lang]); -end; - -function SoundExAnsi(A: PAnsiChar; next: PPAnsiChar; - Lang: PSoundExValues): cardinal; -begin - result := SoundExComputeFirstCharAnsi(A); - if result<>0 then begin - dec(result,ord('A')-1); // first Soundex char is first char - SoundExComputeAnsi(A,result,Lang); - end; - if next<>nil then begin - {$ifdef USENORMTOUPPER} - while tcWord in TEXT_CHARS[NormToUpper[A^]] do inc(A); // go to end of word - {$else} - while tcWord in TEXT_CHARS[A^] do inc(A); // go to end of word - {$endif} - next^ := A; - end; -end; - -function SoundExAnsi(A: PAnsiChar; next: PPAnsiChar; - Lang: TSynSoundExPronunciation): cardinal; -begin - result := SoundExAnsi(A,next,SOUNDEXVALUES[Lang]); -end; - -function SoundExUTF8(U: PUTF8Char; next: PPUTF8Char; - Lang: TSynSoundExPronunciation): cardinal; -begin - result := SoundExComputeFirstCharUTF8(U); - if result<>0 then begin - dec(result,ord('A')-1); // first Soundex char is first char - SoundExComputeUTF8(U,result,SOUNDEXVALUES[Lang]); - end; - if next<>nil then - next^ := FindNextUTF8WordBegin(U); -end; - -{$ifdef ASMX64AVX} // AVX2 ASM not available on Delphi yet -// adapted from https://github.com/simdjson/simdjson - Apache License 2.0 -function IsValidUtf8LenAvx2(source: PUtf8Char; sourcelen: PtrInt): boolean; - {$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC} - test source, source - jz @ok - test sourcelen, sourcelen - jle @ok - {$ifdef win64} // this ABI doesn't consider rsi/rdi as volatile - push rsi - push rdi - {$endif} - push rbp - mov r8, source - mov rdx, sourcelen - mov rsi, r8 - mov ecx, 64 - mov rax, rsi - mov rdi, rdx - mov rbp, rsp - and rsp, 0FFFFFFFFFFFFFFE0H // align stack at 32 bytes - sub rsp, 160 - cmp rdx, 64 - cmovnc rcx, rdx - sub rcx, 64 - je @small - vpxor xmm3, xmm3, xmm3 - vmovdqa ymm7, ymmword ptr [rip + @0f] - vmovdqa ymm15, ymmword ptr [rip + @_6] - xor esi, esi - vmovdqa ymm14, ymmword ptr [rip + @_7] - vmovdqa ymm13, ymmword ptr [rip + @_8] - vmovdqa ymm5, ymm3 - vmovdqa ymm2, ymm3 - // main processing loop, 64 bytes per iteration - align 16 -@loop: vmovdqu xmm6, xmmword ptr [rax + rsi] - vinserti128 ymm0, ymm6, xmmword ptr [rax + rsi + 10H], 01H - vmovdqu xmm6, xmmword ptr [rax + rsi + 20H] - vinserti128 ymm1, ymm6, xmmword ptr [rax + rsi + 30H], 01H - add rsi, 64 - vpor ymm4, ymm1, ymm0 - vpmovmskb rdx, ymm4 // check set MSB of each 64 bytes - test edx, edx - jne @check - vpor ymm2, ymm5, ymm2 - vmovdqa ymm4, ymm2 - cmp rcx, rsi - ja @loop - // process trailing 0..63 bytes -@trail: sub rdi, rsi - jz @ended - add rsi, rax - vmovdqa xmm0, xmmword ptr [rip + @20] - lea rdx, qword ptr [rsp + 60H] // copy on stack with space padding - sub rsi, rdx - vmovdqa xmmword ptr [rdx], xmm0 - vmovdqa xmmword ptr [rdx + 10H], xmm0 - vmovdqa xmmword ptr [rdx + 20H], xmm0 - vmovdqa xmmword ptr [rdx + 30H], xmm0 -@by8: sub rdi, 8 - jb @by1 - mov rax, qword ptr [rsi + rdx] - mov qword ptr [rdx], rax - add rdx, 8 // in-order copy to preserve UTF-8 encoding - jmp @by8 -@by1: add rdi, 8 - jz @0 -@sml: mov al, byte ptr [rsi + rdx] - mov byte ptr [rdx], al - add rdx, 1 - sub rdi, 1 - jnz @sml -@0: vmovdqa ymm1, ymmword ptr [rsp + 60H] - vmovdqa ymm2, ymmword ptr [rsp + 80H] - vpor ymm0, ymm1, ymm2 - vpmovmskb rax, ymm0 // check any set MSB - test eax, eax - jne @last -@ended: vpor ymm5, ymm5, ymm4 -@final: vptest ymm5, ymm5 - sete al - vzeroupper - leave // mov rsp,rbp + pop rbp - {$ifdef win64} - pop rdi - pop rsi - {$endif} - ret -@ok: mov al, 1 - ret -@small: vpxor xmm4, xmm4, xmm4 - xor esi, esi - vmovdqa ymm3, ymm4 - vmovdqa ymm5, ymm4 - jmp @trail - // validate UTF-8 extra bytes from main loop - align 8 -@check: vpsrlw ymm9, ymm0, 4 - vpsrlw ymm12, ymm1, 4 - vperm2i128 ymm3, ymm3, ymm0, 21H - vpalignr ymm5, ymm0, ymm3, 0FH - vpalignr ymm11, ymm0, ymm3, 0EH - vpsubusb ymm11, ymm11, ymmword ptr [rip + @_9] - vpalignr ymm3, ymm0, ymm3, 0DH - vperm2i128 ymm0, ymm0, ymm1, 21H - vpsubusb ymm3, ymm3, ymmword ptr [rip + @_10] - vpalignr ymm8, ymm1, ymm0, 0FH - vpsrlw ymm10, ymm5, 4 - vpand ymm5, ymm7, ymm5 - vpsrlw ymm6, ymm8, 4 - vpalignr ymm4, ymm1, ymm0, 0EH - vpsubusb ymm4, ymm4, ymmword ptr [rip + @_9] - vpalignr ymm0, ymm1, ymm0, 0DH - vpsubusb ymm0, ymm0, ymmword ptr [rip + @_10] - vpand ymm10, ymm10, ymm7 - vpand ymm6, ymm6, ymm7 - vpand ymm8, ymm7, ymm8 - vpor ymm3, ymm3, ymm11 - vpor ymm0, ymm4, ymm0 - vpxor xmm11, xmm11, xmm11 - vpshufb ymm10, ymm15, ymm10 - vpshufb ymm5, ymm14, ymm5 - vpand ymm9, ymm9, ymm7 - vpshufb ymm6, ymm15, ymm6 - vpshufb ymm8, ymm14, ymm8 - vpand ymm12, ymm12, ymm7 - vpand ymm5, ymm5, ymm10 - vpcmpgtb ymm3, ymm3, ymm11 - vpcmpgtb ymm0, ymm0, ymm11 - vpshufb ymm9, ymm13, ymm9 - vpand ymm3, ymm3, ymmword ptr [rip + @_11] - vpand ymm0, ymm0, ymmword ptr [rip + @_11] - vpshufb ymm12, ymm13, ymm12 - vpand ymm6, ymm6, ymm8 - vpand ymm9, ymm5, ymm9 - vpsubusb ymm5, ymm1, ymmword ptr [rip + @_12] - vpand ymm12, ymm6, ymm12 - vpxor ymm9, ymm3, ymm9 - vmovdqa ymm3, ymm1 - vpxor ymm12, ymm0, ymm12 - vpor ymm9, ymm9, ymm12 - vpor ymm2, ymm9, ymm2 - vmovdqa ymm4, ymm2 - cmp rcx, rsi - ja @loop - jmp @trail - // validate UTF-8 extra bytes from input ending - align 8 -@last: vmovdqa ymm5, ymmword ptr [rip + @0f] - vperm2i128 ymm3, ymm3, ymm1, 21H - vmovdqa ymm9, ymmword ptr [rip + @_7] - vpsrlw ymm11, ymm1, 4 - vpalignr ymm0, ymm1, ymm3, 0FH - vmovdqa ymm13, ymmword ptr [rip + @_10] - vmovdqa ymm14, ymmword ptr [rip + @_9] - vpsrlw ymm6, ymm0, 4 - vpand ymm0, ymm5, ymm0 - vpand ymm11, ymm11, ymm5 - vmovdqa ymm7, ymmword ptr [rip + @_6] - vpshufb ymm10, ymm9, ymm0 - vpalignr ymm0, ymm1, ymm3, 0EH - vpand ymm6, ymm6, ymm5 - vmovdqa ymm8, ymmword ptr [rip + @_8] - vpalignr ymm3, ymm1, ymm3, 0DH - vperm2i128 ymm1, ymm1, ymm2, 21H - vpsubusb ymm0, ymm0, ymm14 - vpsubusb ymm12, ymm3, ymm13 - vpalignr ymm3, ymm2, ymm1, 0FH - vpshufb ymm6, ymm7, ymm6 - vpsrlw ymm15, ymm3, 4 - vpand ymm3, ymm5, ymm3 - vpor ymm0, ymm0, ymm12 - vpshufb ymm9, ymm9, ymm3 - vpsrlw ymm3, ymm2, 4 - vpand ymm15, ymm15, ymm5 - vpand ymm5, ymm3, ymm5 - vpalignr ymm3, ymm2, ymm1, 0EH - vpxor xmm12, xmm12, xmm12 - vpalignr ymm1, ymm2, ymm1, 0DH - vpsubusb ymm3, ymm3, ymm14 - vpshufb ymm11, ymm8, ymm11 - vpsubusb ymm1, ymm1, ymm13 - vpcmpgtb ymm0, ymm0, ymm12 - vpshufb ymm7, ymm7, ymm15 - vpor ymm1, ymm3, ymm1 - vpshufb ymm8, ymm8, ymm5 - vpsubusb ymm5, ymm2, ymmword ptr [rip + @_12] - vmovdqa ymm2, ymmword ptr [rip + @_11] - vpcmpgtb ymm1, ymm1, ymm12 - vpand ymm6, ymm6, ymm10 - vpand ymm7, ymm7, ymm9 - vpand ymm0, ymm0, ymm2 - vpand ymm11, ymm6, ymm11 - vpand ymm8, ymm7, ymm8 - vpxor ymm0, ymm0, ymm11 - vpor ymm5, ymm4, ymm5 - vpand ymm1, ymm1, ymm2 - vpxor ymm1, ymm1, ymm8 - vpor ymm0, ymm0, ymm1 - vpor ymm5, ymm0, ymm5 - jmp @final - align 16 -@20: dq 2020202020202020H - dq 2020202020202020H - align 32 -@0f: dq 0F0F0F0F0F0F0F0FH - dq 0F0F0F0F0F0F0F0FH - dq 0F0F0F0F0F0F0F0FH - dq 0F0F0F0F0F0F0F0FH -@_6: dq 0202020202020202H - dq 4915012180808080H - dq 0202020202020202H - dq 4915012180808080H -@_7: dq 0CBCBCB8B8383A3E7H - dq 0CBCBDBCBCBCBCBCBH - dq 0CBCBCB8B8383A3E7H - dq 0CBCBDBCBCBCBCBCBH -@_8: dq 0101010101010101H - dq 01010101BABAAEE6H - dq 0101010101010101H - dq 01010101BABAAEE6H -@_9: dq 0DFDFDFDFDFDFDFDFH - dq 0DFDFDFDFDFDFDFDFH - dq 0DFDFDFDFDFDFDFDFH - dq 0DFDFDFDFDFDFDFDFH -@_10: dq 0EFEFEFEFEFEFEFEFH - dq 0EFEFEFEFEFEFEFEFH - dq 0EFEFEFEFEFEFEFEFH - dq 0EFEFEFEFEFEFEFEFH -@_11: dq 8080808080808080H - dq 8080808080808080H - dq 8080808080808080H - dq 8080808080808080H -@_12: db 0FFH, 0FFH, 0FFH, 0FFH, 0FFH, 0FFH, 0FFH, 0FFH - db 0FFH, 0FFH, 0FFH, 0FFH, 0FFH, 0FFH, 0FFH, 0FFH - db 0FFH, 0FFH, 0FFH, 0FFH, 0FFH, 0FFH, 0FFH, 0FFH - db 0FFH, 0FFH, 0FFH, 0FFH, 0FFH, 0EFH, 0DFH, 0BFH -end; - -function IsValidUTF8Avx2(source: PUTF8Char): Boolean; -begin - result := IsValidUTF8LenAvx2(source,StrLen(source)); -end; -{$endif ASMX64AVX} - -function IsValidUTF8Pas(source: PUTF8Char): Boolean; -var extra, i: integer; - c: cardinal; -begin - result := false; - if source<>nil then - repeat - c := byte(source^); - inc(source); - if c=0 then break else - if c and $80<>0 then begin - extra := UTF8_EXTRABYTES[c]; - if extra=0 then exit else // invalid leading byte - for i := 1 to extra do - if byte(source^) and $c0<>$80 then - exit else - inc(source); // check valid UTF-8 content - end; - until false; - result := true; -end; - -function IsValidUTF8LenPas(source: PUTF8Char; sourcelen: PtrInt): Boolean; -var extra, i: integer; - c: cardinal; -begin - result := false; - inc(sourcelen,PtrInt(source)); - if source<>nil then - while PtrInt(PtrUInt(source))0 then begin - extra := UTF8_EXTRABYTES[c]; - if extra=0 then exit else // invalid leading byte - for i := 1 to extra do - if (PtrInt(PtrUInt(source))>=sourcelen) or (byte(source^) and $c0<>$80) then - exit else - inc(source); // check valid UTF-8 content - end; - end; - result := true; -end; - -function IsValidUTF8(source: PUTF8Char): Boolean; -begin - result := DoIsValidUTF8(source); -end; - -function IsValidUTF8(source: PUTF8Char; sourcelen: PtrInt): Boolean; -begin - result := DoIsValidUTF8Len(source,sourcelen); -end; - -function IsValidUTF8(const source: RawUTF8): Boolean; -begin - result := DoIsValidUTF8Len(pointer(Source),length(Source)); -end; - - -{ ************ filtering and validation classes and functions *************** } - -function IPToCardinal(P: PUTF8Char; out aValue: cardinal): boolean; -var i,c: cardinal; - b: array[0..3] of byte; -begin - aValue := 0; - result := false; - if (P=nil) or (IdemPChar(P,'127.0.0.1') and (P[9]=#0)) then - exit; - for i := 0 to 3 do begin - c := GetNextItemCardinal(P,'.'); - if (c>255) or ((P=nil) and (i<3)) then - exit; - b[i] := c; - end; - if PCardinal(@b)^<>$0100007f then begin - aValue := PCardinal(@b)^; - result := true; - end; -end; - -function IPToCardinal(const aIP: RawUTF8; out aValue: cardinal): boolean; -begin - result := IPToCardinal(pointer(aIP),aValue); -end; - -function IPToCardinal(const aIP: RawUTF8): cardinal; -begin - IPToCardinal(pointer(aIP),result); -end; - -function IsValidIP4Address(P: PUTF8Char): boolean; -var ndot: PtrInt; - V: PtrUInt; -begin - result := false; - if (P=nil) or not (P^ in ['0'..'9']) then - exit; - V := 0; - ndot := 0; - repeat - case P^ of - #0: break; - '.': if (P[-1]='.') or (V>255) then - exit else begin - inc(ndot); - V := 0; - end; - '0'..'9': V := (V*10)+ord(P^)-48; - else exit; - end; - inc(P); - until false; - if (ndot=3) and (V<=255) and (P[-1]<>'.') then - result := true; -end; - -function IsValidEmail(P: PUTF8Char): boolean; -// Initial Author: Ernesto D'Spirito - UTF-8 version by AB -// http://www.howtodothings.com/computers/a1169-validating-email-addresses-in-delphi.html -const - // Valid characters in an "atom" - atom_chars: TSynAnsicharSet = [#33..#255] - - ['(', ')', '<', '>', '@', ',', ';', ':', '\', '/', '"', '.', '[', ']', #127]; - // Valid characters in a "quoted-string" - quoted_string_chars: TSynAnsicharSet = [#0..#255] - ['"', #13, '\']; - // Valid characters in a subdomain - letters_digits: TSynAnsicharSet = ['0'..'9', 'A'..'Z', 'a'..'z']; -type - States = (STATE_BEGIN, STATE_ATOM, STATE_QTEXT, STATE_QCHAR, - STATE_QUOTE, STATE_LOCAL_PERIOD, STATE_EXPECTING_SUBDOMAIN, - STATE_SUBDOMAIN, STATE_HYPHEN); -var - State: States; - subdomains: integer; - c: AnsiChar; - ch: PtrInt; -begin - State := STATE_BEGIN; - subdomains := 1; - if P<>nil then - repeat - ch := ord(P^); - if ch and $80=0 then - inc(P) else - ch := GetHighUTF8UCS4(P); - if (ch<=255) and (WinAnsiConvert.AnsiToWide[ch]<=255) then - // convert into WinAnsi char - c := AnsiChar(ch) else - // invalid char - c := #127; - case State of - STATE_BEGIN: - if c in atom_chars then - State := STATE_ATOM else - if c='"' then - State := STATE_QTEXT else - break; - STATE_ATOM: - if c='@' then - State := STATE_EXPECTING_SUBDOMAIN else - if c='.' then - State := STATE_LOCAL_PERIOD else - if not (c in atom_chars) then - break; - STATE_QTEXT: - if c='\' then - State := STATE_QCHAR else - if c='"' then - State := STATE_QUOTE else - if not (c in quoted_string_chars) then - break; - STATE_QCHAR: - State := STATE_QTEXT; - STATE_QUOTE: - if c='@' then - State := STATE_EXPECTING_SUBDOMAIN else - if c='.' then - State := STATE_LOCAL_PERIOD else - break; - STATE_LOCAL_PERIOD: - if c in atom_chars then - State := STATE_ATOM else - if c='"' then - State := STATE_QTEXT else - break; - STATE_EXPECTING_SUBDOMAIN: - if c in letters_digits then - State := STATE_SUBDOMAIN else - break; - STATE_SUBDOMAIN: - if c='.' then begin - inc(subdomains); - State := STATE_EXPECTING_SUBDOMAIN - end else - if c='-' then - State := STATE_HYPHEN else - if not (c in letters_digits) then - break; - STATE_HYPHEN: - if c in letters_digits then - State := STATE_SUBDOMAIN else - if c<>'-' then - break; - end; - if P^=#0 then begin - P := nil; - break; - end; - until false; - result := (State = STATE_SUBDOMAIN) and (subdomains >= 2); -end; - - -{ TSynFilterOrValidate } - -constructor TSynFilterOrValidate.Create(const aParameters: RawUTF8); -begin - inherited Create; - SetParameters(aParameters); // should parse the JSON-encoded parameters -end; - -constructor TSynFilterOrValidate.CreateUTF8(const Format: RawUTF8; - const Args, Params: array of const); -begin - Create(FormatUTF8(Format,Args,Params,true)); -end; - -procedure TSynFilterOrValidate.SetParameters(const value: RawUTF8); -begin - fParameters := value; -end; - -function TSynFilterOrValidate.AddOnce(var aObjArray: TSynFilterOrValidateObjArray; - aFreeIfAlreadyThere: boolean): TSynFilterOrValidate; -var i: integer; -begin - if self<>nil then begin - for i := 0 to length(aObjArray)-1 do - if (PPointer(aObjArray[i])^=PPointer(self)^) and - (aObjArray[i].fParameters=fParameters) then begin - if aFreeIfAlreadyThere then - Free; - result := aObjArray[i]; - exit; - end; - ObjArrayAdd(aObjArray,self); - end; - result := self; -end; - - -{ TSynFilterUpperCase } - -procedure TSynFilterUpperCase.Process(aFieldIndex: integer; var value: RawUTF8); -begin - value := SynCommons.UpperCase(value); -end; - - -{ TSynFilterUpperCaseU } - -procedure TSynFilterUpperCaseU.Process(aFieldIndex: integer; var value: RawUTF8); -begin - value := UpperCaseU(value); -end; - - -{ TSynFilterLowerCase } - -procedure TSynFilterLowerCase.Process(aFieldIndex: integer; var value: RawUTF8); -begin - value := LowerCase(value); -end; - - -{ TSynFilterLowerCaseU } - -procedure TSynFilterLowerCaseU.Process(aFieldIndex: integer; var value: RawUTF8); -begin - value := LowerCaseU(value); -end; - - -{ TSynFilterTrim } - -procedure TSynFilterTrim.Process(aFieldIndex: integer; var value: RawUTF8); -begin - value := Trim(value); -end; - - -{ TSynFilterTruncate} - -procedure TSynFilterTruncate.SetParameters(const value: RawUTF8); -var V: array[0..1] of TValuePUTF8Char; - tmp: TSynTempBuffer; -begin - tmp.Init(value); - JSONDecode(tmp.buf,['MaxLength','UTF8Length'],@V); - fMaxLength := GetCardinalDef(V[0].Value,0); - fUTF8Length := V[1].Idem('1') or V[1].Idem('true'); - tmp.Done; -end; - -procedure TSynFilterTruncate.Process(aFieldIndex: integer; var value: RawUTF8); -begin - if fMaxLength-163 then - break; // exceeded 63-character limit of a DNS name - if (ForbiddenDomains<>'') and (FindCSVIndex(pointer(ForbiddenDomains),DOM)>=0) then - break; - i := length(value); - while (i>0) and (value[i]<>'.') do dec(i); - TLD := lowercase(copy(value,i+1,100)); - if (AllowedTLD<>'') and (FindCSVIndex(pointer(AllowedTLD),TLD)<0) then - break; - if (ForbiddenTLD<>'') and (FindCSVIndex(pointer(ForbiddenTLD),TLD)>=0) then - break; - if not fAnyTLD then - if FastFindPUTF8CharSorted(@TopLevelTLD,high(TopLevelTLD),pointer(TLD))<0 then - if length(TLD)<>2 then - break; // assume a two chars string is a ISO 3166-1 alpha-2 code - result := true; - exit; - until true; - ErrorMsg := Format(sInvalidEmailAddress,[UTF8ToString(value)]); - result := false; -end; - -procedure TSynValidateEmail.SetParameters(const value: RawUTF8); -var V: array[0..3] of TValuePUTF8Char; - tmp: TSynTempBuffer; -begin - inherited; - tmp.Init(value); - JSONDecode(tmp.buf,['AllowedTLD','ForbiddenTLD','ForbiddenDomains','AnyTLD'],@V); - LowerCaseCopy(V[0].Value,V[0].ValueLen,fAllowedTLD); - LowerCaseCopy(V[1].Value,V[1].ValueLen,fForbiddenTLD); - LowerCaseCopy(V[2].Value,V[2].ValueLen,fForbiddenDomains); - AnyTLD := V[3].Idem('1') or V[3].Idem('true'); - tmp.Done; -end; - - -{ TSynValidatePattern } - -procedure TSynValidatePattern.SetParameters(const Value: RawUTF8); -begin - inherited SetParameters(Value); - fMatch.Prepare(Value, ClassType=TSynValidatePatternI, {reuse=}true); -end; - -function TSynValidatePattern.Process(aFieldIndex: integer; const value: RawUTF8; - var ErrorMsg: string): boolean; - procedure SetErrorMsg; - begin - ErrorMsg := Format(sInvalidPattern,[UTF8ToString(value)]); - end; -begin - result := fMatch.Match(value); - if not result then - SetErrorMsg; -end; - - -{ TSynValidateNonVoidText } - -function Character01n(n: integer): string; -begin - if n<0 then - n := 0 else - if n>1 then - n := 2; - result := GetCSVItemString(pointer(string(sCharacter01n)),n); -end; - -procedure InvalidTextLengthMin(min: integer; var result: string); -begin - result := Format(sInvalidTextLengthMin,[min,Character01n(min)]); -end; - -function TSynValidateNonVoidText.Process(aFieldIndex: integer; const value: RawUTF8; - var ErrorMsg: string): boolean; -begin - if value='' then begin - InvalidTextLengthMin(1,ErrorMsg); - result := false; - end else - result := true; -end; - - -{ TSynValidateText } - -procedure TSynValidateText.SetErrorMsg(fPropsIndex, InvalidTextIndex, - MainIndex: integer; var result: string); -var P: PChar; -begin - P := pointer(string(sInvalidTextChar)); - result := GetCSVItemString(P,MainIndex); - if fPropsIndex>0 then - result := Format(result, - [fProps[fPropsIndex],GetCSVItemString(P,InvalidTextIndex), - Character01n(fProps[fPropsIndex])]); -end; - -function TSynValidateText.Process(aFieldIndex: integer; const value: RawUTF8; - var ErrorMsg: string): boolean; -var i, L: cardinal; - Min: array[2..7] of cardinal; -begin - result := false; - if fUTF8Length then - L := length(value) else - L := Utf8ToUnicodeLength(pointer(value)); - if LMaxLength then - ErrorMsg := Format(sInvalidTextLengthMax,[MaxLength,Character01n(MaxLength)]) else begin - FillCharFast(Min,SizeOf(Min),0); - L := length(value); - for i := 1 to L do - case value[i] of - ' ': - inc(Min[7]); - 'a'..'z': begin - inc(Min[2]); - inc(Min[5]); - end; - 'A'..'Z': begin - inc(Min[2]); - inc(Min[6]); - end; - '0'..'9': - inc(Min[3]); - '_','!',';','.',',','/',':','?','%','$','=','"','#','@','(',')','{','}', - '+','''','-','*': - inc(Min[4]); - end; - for i := 2 to 7 do - if Min[i]fProps[i+8] then begin - SetErrorMsg(i+8,i,1,ErrorMsg); - exit; - end; - if value<>'' then begin - if MaxLeftTrimCountMaxLeftTrimCount then begin - SetErrorMsg(0,0,8,ErrorMsg); - exit; - end; - end; - if MaxRightTrimCountMaxRightTrimCount then begin - SetErrorMsg(0,0,9,ErrorMsg); - exit; - end; - end; - end; - result := true; - end; -end; - -procedure TSynValidateText.SetParameters(const value: RawUTF8); -var V: array[0..high(TSynValidateTextProps)+1] of TValuePUTF8Char; - i: integer; - tmp: TSynTempBuffer; -const DEFAULT: TSynValidateTextProps = ( - 1,maxInt,0,0,0,0,0,0,maxInt,maxInt,maxInt,maxInt,maxInt,maxInt,maxInt,maxInt); -begin - if (MinLength=0) and (MaxLength=0) then // if not previously set - fProps := DEFAULT; - inherited SetParameters(value); - if value='' then - exit; - tmp.Init(value); - try - JSONDecode(tmp.buf,['MinLength','MaxLength', - 'MinAlphaCount','MinDigitCount','MinPunctCount', - 'MinLowerCount','MinUpperCount','MinSpaceCount', - 'MaxLeftTrimCount','MaxRightTrimCount', - 'MaxAlphaCount','MaxDigitCount','MaxPunctCount', - 'MaxLowerCount','MaxUpperCount','MaxSpaceCount', - 'UTF8Length'],@V); - for i := 0 to high(fProps) do - fProps[i] := GetCardinalDef(V[i].Value,fProps[i]); - with V[high(V)] do - fUTF8Length := Idem('1') or Idem('true'); - finally - tmp.Done; - end; -end; - - -{ TSynValidatePassWord } - -procedure TSynValidatePassWord.SetParameters(const value: RawUTF8); -const DEFAULT: TSynValidateTextProps = ( - 5,20,1,1,1,1,1,0,maxInt,maxInt,maxInt,maxInt,maxInt,maxInt,maxInt,0); -begin - // set default values for validating a strong password - fProps := DEFAULT; - // read custom parameters - inherited; -end; - - -{ ************ low-level buffer processing functions************************* } - -{ TSynBloomFilter } - -const - BLOOM_VERSION = 0; - BLOOM_MAXHASH = 32; // only 7 is needed for 1% false positive ratio - -constructor TSynBloomFilter.Create(aSize: integer; aFalsePositivePercent: double); -const LN2 = 0.69314718056; -begin - inherited Create; - if aSize < 0 then - fSize := 1000 else - fSize := aSize; - if aFalsePositivePercent<=0 then - fFalsePositivePercent := 1 else - if aFalsePositivePercent>100 then - fFalsePositivePercent := 100 else - fFalsePositivePercent := aFalsePositivePercent; - // see http://stackoverflow.com/a/22467497 - fBits := Round(-ln(fFalsePositivePercent/100)*aSize/(LN2*LN2)); - fHashFunctions := Round(fBits/fSize*LN2); - if fHashFunctions=0 then - fHashFunctions := 1 else - if fHashFunctions>BLOOM_MAXHASH then - fHashFunctions := BLOOM_MAXHASH; - Reset; -end; - -constructor TSynBloomFilter.Create(const aSaved: RawByteString; aMagic: cardinal); -begin - inherited Create; - if not LoadFrom(aSaved,aMagic) then - raise ESynException.CreateUTF8('%.Create with invalid aSaved content',[self]); -end; - -procedure TSynBloomFilter.Insert(const aValue: RawByteString); -begin - Insert(pointer(aValue),length(aValue)); -end; - -procedure TSynBloomFilter.Insert(aValue: pointer; aValueLen: integer); -var h: integer; - h1,h2: cardinal; // https://goo.gl/Pls5wi -begin - if (self=nil) or (aValueLen<=0) or (fBits=0) then - exit; - h1 := crc32c(0,aValue,aValueLen); - if fHashFunctions=1 then - h2 := 0 else - h2 := crc32c(h1,aValue,aValueLen); - Safe.Lock; - try - for h := 0 to fHashFunctions-1 do begin - SetBitPtr(pointer(fStore),h1 mod fBits); - inc(h1,h2); - end; - inc(fInserted); - finally - Safe.UnLock; - end; -end; - -function TSynBloomFilter.GetInserted: cardinal; -begin - Safe.Lock; - try - result := fInserted; // Delphi 5 does not support LockedInt64[] - finally - Safe.UnLock; - end; -end; - -function TSynBloomFilter.MayExist(const aValue: RawByteString): boolean; -begin - result := MayExist(pointer(aValue),length(aValue)); -end; - -function TSynBloomFilter.MayExist(aValue: pointer; aValueLen: integer): boolean; -var h: integer; - h1,h2: cardinal; // https://goo.gl/Pls5wi -begin - result := false; - if (self=nil) or (aValueLen<=0) or (fBits=0) then - exit; - h1 := crc32c(0,aValue,aValueLen); - if fHashFunctions=1 then - h2 := 0 else - h2 := crc32c(h1,aValue,aValueLen); - Safe.Lock; - try - for h := 0 to fHashFunctions-1 do - if GetBitPtr(pointer(fStore),h1 mod fBits) then - inc(h1,h2) else - exit; - finally - Safe.UnLock; - end; - result := true; -end; - -procedure TSynBloomFilter.Reset; -begin - Safe.Lock; - try - if fStore='' then - SetLength(fStore,(fBits shr 3)+1); - FillcharFast(pointer(fStore)^,length(fStore),0); - fInserted := 0; - finally - Safe.UnLock; - end; -end; - -function TSynBloomFilter.SaveTo(aMagic: cardinal): RawByteString; -var W: TFileBufferWriter; - BufLen: integer; - temp: array[word] of byte; -begin - BufLen := length(fStore)+100; - if BufLen<=SizeOf(temp) then - W := TFileBufferWriter.Create(TRawByteStringStream,@temp,SizeOf(temp)) else - W := TFileBufferWriter.Create(TRawByteStringStream,BufLen); - try - SaveTo(W,aMagic); - W.Flush; - result := TRawByteStringStream(W.Stream).DataString; - finally - W.Free; - end; -end; - -procedure TSynBloomFilter.SaveTo(aDest: TFileBufferWriter; aMagic: cardinal=$B1003F11); -begin - aDest.Write4(aMagic); - aDest.Write1(BLOOM_VERSION); - Safe.Lock; - try - aDest.Write8(fFalsePositivePercent); - aDest.Write4(fSize); - aDest.Write4(fBits); - aDest.Write1(fHashFunctions); - aDest.Write4(fInserted); - ZeroCompress(pointer(fStore),Length(fStore),aDest); - finally - Safe.UnLock; - end; -end; - -function TSynBloomFilter.LoadFrom(const aSaved: RawByteString; aMagic: cardinal): boolean; -begin - result := LoadFrom(pointer(aSaved),length(aSaved)); -end; - -function TSynBloomFilter.LoadFrom(P: PByte; PLen: integer; aMagic: cardinal): boolean; -var start: PByte; - version: integer; -begin - result := false; - start := P; - if (P=nil) or (PLen<32) or (PCardinal(P)^<>aMagic) then - exit; - inc(P,4); - version := P^; inc(P); - if version>BLOOM_VERSION then - exit; - Safe.Lock; - try - fFalsePositivePercent := unaligned(PDouble(P)^); inc(P,8); - if (fFalsePositivePercent<=0) or (fFalsePositivePercent>100) then - exit; - fSize := PCardinal(P)^; inc(P,4); - fBits := PCardinal(P)^; inc(P,4); - if fBits=BLOOM_MAXHASH then - exit; - Reset; - fInserted := PCardinal(P)^; inc(P,4); - ZeroDecompress(P,PLen-(PAnsiChar(P)-PAnsiChar(start)),fStore); - result := length(fStore)=integer(fBits shr 3)+1; - finally - Safe.UnLock; - end; -end; - - -{ TSynBloomFilterDiff } - -type - TBloomDiffHeader = packed record - kind: (bdDiff,bdFull,bdUpToDate); - size: cardinal; - inserted: cardinal; - revision: Int64; - crc: cardinal; - end; - -procedure TSynBloomFilterDiff.Insert(aValue: pointer; aValueLen: integer); -begin - Safe.Lock; - try - inherited Insert(aValue,aValueLen); - inc(fRevision); - inc(fSnapshotInsertCount); - finally - Safe.UnLock; - end; -end; - -procedure TSynBloomFilterDiff.Reset; -begin - Safe.Lock; - try - inherited Reset; - fSnapshotAfterInsertCount := fSize shr 5; - fSnapShotAfterMinutes := 30; - fSnapshotTimestamp := 0; - fSnapshotInsertCount := 0; - fRevision := UnixTimeUTC shl 31; - fKnownRevision := 0; - fKnownStore := ''; - finally - Safe.UnLock; - end; -end; - -procedure TSynBloomFilterDiff.DiffSnapshot; -begin - Safe.Lock; - try - fKnownRevision := fRevision; - fSnapshotInsertCount := 0; - SetString(fKnownStore,PAnsiChar(pointer(fStore)),length(fStore)); - if fSnapShotAfterMinutes=0 then - fSnapshotTimestamp := 0 else - fSnapshotTimestamp := GetTickCount64+fSnapShotAfterMinutes*60000; - finally - Safe.UnLock; - end; -end; - -function TSynBloomFilterDiff.SaveToDiff(const aKnownRevision: Int64): RawByteString; -var head: TBloomDiffHeader; - W: TFileBufferWriter; - temp: array[word] of byte; -begin - Safe.Lock; - try - if aKnownRevision=fRevision then - head.kind := bdUpToDate else - if (fKnownRevision=0) or - (fSnapshotInsertCount>fSnapshotAfterInsertCount) or - ((fSnapshotInsertCount>0) and (fSnapshotTimestamp<>0) and - (GetTickCount64>fSnapshotTimestamp)) then begin - DiffSnapshot; - head.kind := bdFull; - end else - if (aKnownRevisionfRevision) then - head.kind := bdFull else - head.kind := bdDiff; - head.size := length(fStore); - head.inserted := fInserted; - head.revision := fRevision; - head.crc := crc32c(0,@head,SizeOf(head)-SizeOf(head.crc)); - if head.kind=bdUpToDate then begin - SetString(result,PAnsiChar(@head),SizeOf(head)); - exit; - end; - if head.size+100<=SizeOf(temp) then - W := TFileBufferWriter.Create(TRawByteStringStream,@temp,SizeOf(temp)) else - W := TFileBufferWriter.Create(TRawByteStringStream,head.size+100); - try - W.Write(@head,SizeOf(head)); - case head.kind of - bdFull: - SaveTo(W); - bdDiff: - ZeroCompressXor(pointer(fStore),pointer(fKnownStore),head.size,W); - end; - W.Flush; - result := TRawByteStringStream(W.Stream).DataString; - finally - W.Free; - end; - finally - Safe.UnLock; - end; -end; - -function TSynBloomFilterDiff.DiffKnownRevision(const aDiff: RawByteString): Int64; -var head: ^TBloomDiffHeader absolute aDiff; -begin - if (length(aDiff)high(head.kind)) or - (head.size<>cardinal(length(fStore))) or - (head.crc<>crc32c(0,pointer(head),SizeOf(head^)-SizeOf(head.crc))) then - result := 0 else - result := head.Revision; -end; - -function TSynBloomFilterDiff.LoadFromDiff(const aDiff: RawByteString): boolean; -var head: ^TBloomDiffHeader absolute aDiff; - P: PByte; - PLen: integer; -begin - result := false; - P := pointer(aDiff); - PLen := length(aDiff); - if (PLenhigh(head.kind)) or - (head.crc<>crc32c(0,pointer(head),SizeOf(head^)-SizeOf(head.crc))) then - exit; - if (fStore<>'') and (head.size<>cardinal(length(fStore))) then - exit; - inc(P,SizeOf(head^)); - dec(PLen,SizeOf(head^)); - Safe.Lock; - try - case head.kind of - bdFull: - result := LoadFrom(P,PLen); - bdDiff: - if fStore<>'' then - result := ZeroDecompressOr(pointer(P),Pointer(fStore),PLen,head.size); - bdUpToDate: - result := true; - end; - if result then begin - fRevision := head.revision; - fInserted := head.inserted; - end; - finally - Safe.UnLock; - end; -end; - -procedure ZeroCompress(P: PAnsiChar; Len: integer; Dest: TFileBufferWriter); -var PEnd,beg,zero: PAnsiChar; - crc: cardinal; -begin - Dest.WriteVarUInt32(Len); - PEnd := P+Len; - beg := P; - crc := 0; - while P#0) and (P3 then begin - Len := zero-beg; - crc := crc32c(crc,beg,Len); - Dest.WriteVarUInt32(Len); - Dest.Write(beg,Len); - Len := P-zero; - crc := crc32c(crc,@Len,SizeOf(Len)); - Dest.WriteVarUInt32(Len-3); - beg := P; - end; - end; - Len := P-beg; - if Len>0 then begin - crc := crc32c(crc,beg,Len); - Dest.WriteVarUInt32(Len); - Dest.Write(beg,Len); - end; - Dest.Write4(crc); -end; - -procedure ZeroCompressXor(New,Old: PAnsiChar; Len: cardinal; Dest: TFileBufferWriter); -var beg,same,index,crc,L: cardinal; -begin - Dest.WriteVarUInt32(Len); - beg := 0; - index := 0; - crc := 0; - while indexOld[index]) and (index3 then begin - Dest.WriteVarUInt32(same-beg); - Dest.WriteXor(New+beg,Old+beg,same-beg,@crc); - crc := crc32c(crc,@L,SizeOf(L)); - Dest.WriteVarUInt32(L-3); - beg := index; - end; - end; - L := index-beg; - if L>0 then begin - Dest.WriteVarUInt32(L); - Dest.WriteXor(New+beg,Old+beg,L,@crc); - end; - Dest.Write4(crc); -end; - -procedure ZeroDecompress(P: PByte; Len: integer; {$ifdef FPC}var{$else}out{$endif} Dest: RawByteString); -var PEnd,D,DEnd: PAnsiChar; - DestLen,crc: cardinal; -begin - PEnd := PAnsiChar(P)+Len-4; - DestLen := FromVarUInt32(P); - SetString(Dest,nil,DestLen); // FPC uses var - D := pointer(Dest); - DEnd := D+DestLen; - crc := 0; - while PAnsiChar(P)DEnd then - break; - MoveFast(P^,D^,Len); - crc := crc32c(crc,D,Len); - inc(P,Len); - inc(D,Len); - if PAnsiChar(P)>=PEnd then - break; - Len := FromVarUInt32(P)+3; - if D+Len>DEnd then - break; - FillCharFast(D^,Len,0); - crc := crc32c(crc,@Len,SizeOf(Len)); - inc(D,Len); - end; - if crc<>PCardinal(P)^ then - Dest := ''; -end; - -function ZeroDecompressOr(P,Dest: PAnsiChar; Len,DestLen: integer): boolean; -var PEnd,DEnd: PAnsiChar; - crc: cardinal; -begin - PEnd := P+Len-4; - if cardinal(DestLen)<>FromVarUInt32(PByte(P)) then begin - result := false; - exit; - end; - DEnd := Dest+DestLen; - crc := 0; - while (PDEnd then - break; - crc := crc32c(crc,P,Len); - OrMemory(pointer(Dest),pointer(P),Len); - inc(P,Len); - inc(Dest,Len); - if P>=PEnd then - break; - Len := FromVarUInt32(PByte(P))+3; - crc := crc32c(crc,@Len,SizeOf(Len)); - inc(Dest,Len); - end; - result := crc=PCardinal(P)^; -end; - - -function Max(a,b: PtrInt): PtrInt; {$ifdef HASINLINE}inline;{$endif} -begin - if a > b then - result := a else - result := b; -end; - -function Min(a,b: PtrInt): PtrInt; {$ifdef HASINLINE}inline;{$endif} -begin - if a < b then - result := a else - result := b; -end; - -function Comp(a,b: PAnsiChar; len: PtrInt): PtrInt; -{$ifdef HASINLINE} inline; -var lenptr: PtrInt; -begin - result := 0; - lenptr := len-SizeOf(PtrInt); - if lenptr>=0 then - repeat - if PPtrInt(a+result)^<>PPtrInt(b+result)^ then - break; - inc(result,SizeOf(PtrInt)); - until result>lenptr; - if resultb[result] then - exit; - inc(result); - until result=len; -end; -{$else} // eax = a, edx = b, ecx = len -asm // the 'rep cmpsb' version is slower on Intel Core CPU (not AMD) - or ecx,ecx - push ebx - push ecx - jz @ok -@1: mov bx,[eax] - lea eax,[eax+2] - cmp bl,[edx] - jne @ok - dec ecx - jz @ok - cmp bh,[edx+1] - lea edx,[edx+2] - jne @ok - dec ecx - jnz @1 -@ok: pop eax - sub eax,ecx - pop ebx -end; -{$endif} - -function CompReverse(a,b: pointer; len: PtrInt): PtrInt; -begin - result := 0; - if len>0 then - repeat - if PByteArray(a)[-result]<>PByteArray(b)[-result] then - exit; - inc(result); - until result=len; -end; - -procedure movechars(s,d: PAnsiChar; t: PtrUInt); - {$ifdef HASINLINE}inline;{$endif} -// this code is sometimes used rather than MoveFast() for overlapping copy -begin - dec(PtrUInt(s), PtrUInt(d)); - inc(t, PtrUInt(d)); - repeat - d^ := s[PtrUInt(d)]; - inc(d); - until PtrUInt(d)=t; -end; - -function WriteCurOfs(curofs,curlen,curofssize: integer; sp: PAnsiChar): PAnsiChar; -begin - if curlen=0 then begin - sp^ := #0; - inc(sp); - end else begin - sp := Pointer(ToVarUInt32(curlen,PByte(sp))); - PInteger(sp)^ := curofs; - inc(sp,curofssize); - end; - result := sp; -end; - -{$ifdef CPUINTEL} // crc32c SSE4.2 hardware accellerated dword hash -function crc32csse42(buf: pointer): cardinal; -{$ifdef CPUX86} {$ifdef FPC} nostackframe; assembler; {$endif} -asm - mov edx, eax - xor eax, eax - {$ifdef ISDELPHI2010} - crc32 eax, dword ptr[edx] - {$else} - db $F2, $0F, $38, $F1, $02 - {$endif} -end; -{$else} {$ifdef FPC}nostackframe; assembler; asm {$else} -asm // ecx=buf (Linux: edi=buf) - .noframe -{$endif FPC} - xor eax, eax - crc32 eax, dword ptr[buf] -end; -{$endif CPUX86} -{$endif CPUINTEL} - -function hash32prime(buf: pointer): cardinal; -begin // xxhash32-inspired - and won't pollute L1 cache with lookup tables - result := PCardinal(buf)^; - result := result xor (result shr 15); - result := result * 2246822519; - result := result xor (result shr 13); - result := result * 3266489917; - result := result xor (result shr 16); -end; - -const - HTabBits = 18; // fits well with DeltaCompress(..,BufSize=2MB) - HTabMask = (1 shl HTabBits)-1; // =$3ffff - HListMask = $ffffff; // HTab[]=($ff,$ff,$ff) - -type - PHTab = ^THTab; // HTabBits=18 -> SizeOf=767KB - THTab = packed array[0..HTabMask] of array[0..2] of byte; - -function DeltaCompute(NewBuf, OldBuf, OutBuf, WorkBuf: PAnsiChar; - NewBufSize, OldBufSize, MaxLevel: PtrInt; HList, HTab: PHTab): PAnsiChar; -var i, curofs, curlen, curlevel, match, curofssize, h, oldh: PtrInt; - sp, pInBuf, pOut: PAnsiChar; - ofs: cardinal; - spb: PByte absolute sp; - hash: function(buf: pointer): cardinal; -begin - // 1. fill HTab[] with hashes for all old data - {$ifdef CPUINTEL} - if cfSSE42 in CpuFeatures then - hash := @crc32csse42 else - {$endif} - hash := @hash32prime; - FillCharFast(HTab^,SizeOf(HTab^),$ff); // HTab[]=HListMask by default - pInBuf := OldBuf; - oldh := -1; // force calculate first hash - sp := pointer(HList); - for i := 0 to OldBufSize-3 do begin - h := hash(pInBuf) and HTabMask; - inc(pInBuf); - if h=oldh then - continue; - oldh := h; - h := PtrInt(@HTab^[h]); // fast 24-bit data process - PCardinal(sp)^ := PCardinal(h)^; - PCardinal(h)^ := cardinal(i) or (PCardinal(h)^ and $ff000000); - inc(sp,3); - end; - // 2. compression init - if OldBufSize<=$ffff then - curofssize := 2 else - curofssize := 3; - curlen := -1; - curofs := 0; - pOut := OutBuf+7; - sp := WorkBuf; - // 3. handle identical leading bytes - match := Comp(OldBuf,NewBuf,Min(OldBufSize,NewBufSize)); - if match>2 then begin - sp := WriteCurOfs(0,match,curofssize,sp); - sp^ := #0; inc(sp); - inc(NewBuf,match); - dec(NewBufSize,match); - end; - pInBuf := NewBuf; - // 4. main loop: identify longest sequences using hash, and store reference - if NewBufSize>=8 then - repeat - // hash 4 next bytes from NewBuf, and find longest match in OldBuf - ofs := PCardinal(@HTab^[hash(NewBuf) and HTabMask])^ and HListMask; - if ofs<>HListMask then begin // brute force search loop of best hash match - curlevel := MaxLevel; - repeat - with PHash128Rec(OldBuf+ofs)^ do - {$ifdef CPU64} // test 8 bytes - if PHash128Rec(NewBuf)^.Lo=Lo then begin - {$else} - if (PHash128Rec(NewBuf)^.c0=c0) and (PHash128Rec(NewBuf)^.c1=c1) then begin - {$endif} - match := Comp(@PHash128Rec(NewBuf)^.c2,@c2,Min(PtrUInt(OldBufSize)-ofs,NewBufSize)-8); - if match>curlen then begin // found a longer sequence - curlen := match; - curofs := ofs; - end; - end; - dec(curlevel); - ofs := PCardinal(@HList^[ofs])^ and HListMask; - until (ofs=HListMask) or (curlevel=0); - end; - // curlen = longest sequence length - if curlen<0 then begin // no sequence found -> copy one byte - dec(NewBufSize); - pOut^ := NewBuf^; - inc(NewBuf); - inc(pOut); - if NewBufSize>8 then // >=8 may overflow - continue else - break; - end; - inc(curlen,8); - sp := WriteCurOfs(curofs,curlen,curofssize,sp); - spb := ToVarUInt32(NewBuf-pInBuf,spb); - inc(NewBuf,curlen); // continue to search after the sequence - dec(NewBufSize,curlen); - curlen := -1; - pInBuf := NewBuf; - if NewBufSize>8 then // >=8 may overflow - continue else - break; - until false; - // 5. write remaining bytes - if NewBufSize>0 then begin - MoveFast(NewBuf^,pOut^,NewBufSize); - inc(pOut,NewBufSize); - inc(newBuf,NewBufSize); - end; - sp^ := #0; inc(sp); - spb := ToVarUInt32(NewBuf-pInBuf,spb); - // 6. write header - PInteger(OutBuf)^ := pOut-OutBuf-7; - h := sp-WorkBuf; - PInteger(OutBuf+3)^ := h; - OutBuf[6] := AnsiChar(curofssize); - // 7. copy commands - MoveFast(WorkBuf^,pOut^,h); - result := pOut+h; -end; - -function ExtractBuf(GoodCRC: cardinal; p: PAnsiChar; var aUpd, Delta: PAnsiChar; - Old: PAnsiChar): TDeltaError; -var pEnd, buf, upd, src: PAnsiChar; - bufsize, datasize, leading, srclen: PtrUInt; - curofssize: byte; -begin - // 1. decompression init - upd := aUpd; - bufsize := PCardinal(p)^ and $00ffffff; inc(p,3); - datasize := PCardinal(p)^ and $00ffffff; inc(p,3); - curofssize := ord(p^); inc(p); - buf := p; inc(p,bufsize); - pEnd := p+datasize; - src := nil; - // 2. main loop - while p0 then - if curofssize=2 then begin - src := Old+PWord(p)^; - inc(p,2); - end else begin - src := Old+PCardinal(p)^ and $00ffffff; - inc(p,3); - end; - // copy leading bytes - leading := FromVarUInt32(PByte(P)); - if leading<>0 then begin - MoveFast(buf^,upd^,leading); - inc(buf,leading); - inc(upd,leading); - end; - // copy sequence - if srclen<>0 then begin - if PtrUInt(upd-src) direct copy of whole block - CreateCopied; - exit; - end; - // 2. compression init - bigfile := OldSize>BufSize; - if BufSize>NewSize then - BufSize := NewSize; - if BufSize>$ffffff then - BufSize := $ffffff; // we store offsets with 2..3 bytes -> max 16MB chunk - Trailing := 0; - Getmem(workbuf,BufSize); // compression temporary buffers - Getmem(HList,BufSize*SizeOf(HList[0])); - Getmem(HTab,SizeOf(HTab^)); - Getmem(Delta,Max(NewSize,OldSize)+4096); // Delta size max evalulation - try - d := Delta; - db := ToVarUInt32(NewSize,db); // Destination Size - // 3. handle leading and trailing identical bytes (for biggest files) - if bigfile then begin - BufRead := Comp(New,Old,Min(NewSize,OldSize)); // test 1st same chars - if BufRead>9 then begin // it happens very often - db := ToVarUInt32(BufRead,db); // blockSize = Size BufIdem - WriteByte(d,FLAG_BEGIN); - WriteInt(d,crc32c(0,New,BufRead)); - inc(New,BufRead); - dec(NewSize,BufRead); - inc(Old,BufRead); - dec(OldSize,BufRead); - end; // test last same chars - BufRead := CompReverse(New+NewSize-1,Old+OldSize-1,Min(NewSize,OldSize)); - if BufRead>5 then begin - if NewSize=BufRead then - dec(BufRead); // avoid block overflow - dec(OldSize,BufRead); - dec(NewSize,BufRead); - Trailing := BufRead; - end; - end; - // 4. main loop - repeat - BufRead := Min(BufSize,NewSize); - dec(NewSize,BufRead); - if (BufRead=0) and (Trailing>0) then begin - db := ToVarUInt32(Trailing,db); - WriteByte(d,FLAG_END); // block idem end flag -> BufRead := 0 not necessary - WriteInt(d,crc32c(0,New,Trailing)); - break; - end; - OldRead := Min(BufSize,OldSize); - dec(OldSize,OldRead); - db := ToVarUInt32(OldRead,db); - If (BufRead<4) or (OldRead<4) or (BufRead div 4>OldRead) then begin - WriteByte(d,FLAG_COPIED); // block copied flag - db := ToVarUInt32(BufRead,db); - if BufRead=0 then - break; - WriteInt(d,crc32c(0,New,BufRead)); - MoveFast(New^,d^,BufRead); - inc(New,BufRead); - inc(d,BufRead); - end else begin - WriteByte(d,FLAG_COMPRESS); // block compressed flag - WriteInt(d,crc32c(0,New,BufRead)); - WriteInt(d,crc32c(0,Old,OldRead)); - d := DeltaCompute(New,Old,d,workbuf,BufRead,OldRead,Level,HList,HTab); - inc(New,BufRead); - inc(Old,OldRead); - end; - until false; - // 5. release temp memory - finally - result := d-Delta; - Freemem(HTab); - Freemem(HList); - Freemem(workbuf); - end; - if result>=NewSizeSave+17 then begin - // Delta didn't compress well -> store it (with 17 bytes overhead) - Freemem(Delta); - CreateCopied; - end; -end; - -function DeltaCompress(const New, Old: RawByteString; - Level, BufSize: integer): RawByteString; -begin - result := DeltaCompress(pointer(New),pointer(Old), - length(New),length(Old),Level,BufSize); -end; - -function DeltaCompress(New, Old: PAnsiChar; NewSize, OldSize: integer; - Level, BufSize: integer): RawByteString; -var Delta: PAnsiChar; - DeltaLen: integer; -begin - DeltaLen := DeltaCompress(New,Old,Newsize,OldSize,Delta,Level,BufSize); - SetString(result,Delta,DeltaLen); - Freemem(Delta); -end; - -function DeltaExtract(Delta,Old,New: PAnsiChar): TDeltaError; -var BufCRC: Cardinal; - Code: Byte; - Len, BufRead, OldRead: PtrInt; - db: PByte absolute Delta; - Upd: PAnsiChar; -begin - Result := dsSuccess; - Len := FromVarUInt32(db); - Upd := New; - repeat - OldRead := FromVarUInt32(db); - Code := db^; inc(db); - Case Code of - FLAG_COPIED: begin // block copied flag - copy new from Delta - BufRead := FromVarUInt32(db); - If BufRead=0 then - break; - If crc32c(0,Delta+4,BufRead)<>PCardinal(Delta)^ then begin - result := dsCrcCopy; - exit; - end; - inc(Delta,4); - MoveFast(Delta^,New^,BufRead); - if BufRead>=Len then - exit; // if Old=nil -> only copy new - inc(Delta,BufRead); - inc(New,BufRead); - end; - FLAG_COMPRESS: begin // block compressed flag - extract Delta from Old - BufCRC := PCardinal(Delta)^; inc(Delta,4); - if crc32c(0,Old,OldRead)<>PCardinal(Delta)^ then begin - result := dsCrcComp; - exit; - end; - inc(Delta,4); - result := ExtractBuf(BufCRC,Delta,New,Delta,Old); - if result<>dsSuccess then - exit; - end; - FLAG_BEGIN: begin // block idem begin flag - if crc32c(0,Old,OldRead)<>PCardinal(Delta)^ then begin - result := dsCrcBegin; - exit; - end; - inc(Delta,4); - MoveFast(Old^,New^,OldRead); - inc(New,OldRead); - end; - FLAG_END: begin // block idem end flag - if crc32c(0,Old,OldRead)<>PCardinal(Delta)^ then - Result := dsCrcEnd; - MoveFast(Old^,New^,OldRead); - inc(New,OldRead); - break; - end; - else begin - result := dsFlag; - exit; - end; - end; // Case Code of - inc(Old,OldRead); - until false; - if New-Upd<>Len then - result := dsLen; -end; - -function DeltaExtract(const Delta,Old: RawByteString; out New: RawByteString): TDeltaError; -begin - if (Delta='') or (Delta='=') then begin - New := Old; - result := dsSuccess; - end else begin - SetLength(New,DeltaExtractSize(pointer(Delta))); - result := DeltaExtract(pointer(Delta),pointer(Old),pointer(New)); - end; -end; - -function DeltaExtractSize(const Delta: RawByteString): integer; -begin - result := DeltaExtractSize(pointer(Delta)); -end; - -function DeltaExtractSize(Delta: PAnsiChar): integer; -begin - if Delta=nil then - result := 0 else - result := FromVarUInt32(PByte(Delta)); -end; - -function ToText(err: TDeltaError): PShortString; -begin - result := GetEnumName(TypeInfo(TDeltaError),ord(err)); -end; - - -{ TFastReader } - -procedure TFastReader.Init(Buffer: pointer; Len: integer); -begin - P := Buffer; - Last := P+Len; - OnErrorOverflow := nil; - OnErrorData := nil; - Tag := 0; -end; - -procedure TFastReader.Init(const Buffer: RawByteString); -begin - Init(pointer(Buffer),length(Buffer)); -end; - -procedure TFastReader.ErrorOverflow; -begin - if Assigned(OnErrorOverflow) then - OnErrorOverflow else - raise EFastReader.Create('Reached End of Input'); -end; - -procedure TFastReader.ErrorData(const fmt: RawUTF8; const args: array of const); -begin - if Assigned(OnErrorData) then - OnErrorData(fmt,args) else - raise EFastReader.CreateUTF8('Incorrect Data: '+fmt,args); -end; - -function TFastReader.EOF: boolean; -begin - result := P>=Last; -end; - -function TFastReader.RemainingLength: PtrUInt; -begin - result := PtrUInt(Last)-PtrUInt(P); -end; - -function TFastReader.NextByte: byte; -begin - if P>=Last then - ErrorOverflow; - result := ord(P^); - inc(P); -end; - -function TFastReader.NextByteSafe(dest: pointer): boolean; -begin - if P>=Last then - result := false - else begin - PAnsiChar(dest)^ := P^; - inc(P); - result := true; - end; -end; - -function TFastReader.Next4: cardinal; -begin - if P+3>=Last then - ErrorOverflow; - result := PCardinal(P)^; - inc(P,4); -end; - -function TFastReader.Next8: QWord; -begin - if P+7>=Last then - ErrorOverflow; - result := PQWord(P)^; - inc(P,8); -end; - -function TFastReader.NextByteEquals(Value: byte): boolean; -begin - if P>=Last then - ErrorOverflow; - if ord(P^) = Value then begin - inc(P); - result := true; - end else - result := false; -end; - -function TFastReader.Next(DataLen: PtrInt): pointer; -begin - if P+DataLen>Last then - ErrorOverflow; - result := P; - inc(P,DataLen); -end; - -function TFastReader.NextSafe(out Data: Pointer; DataLen: PtrInt): boolean; -begin - if P+DataLen>Last then - result := false else begin - Data := P; - inc(P,DataLen); - result := true; - end; -end; - -procedure TFastReader.Copy(out Dest; DataLen: PtrInt); -begin - if P+DataLen>Last then - ErrorOverflow; - MoveFast(P^,Dest,DataLen); - inc(P,DataLen); -end; - -function TFastReader.CopySafe(out Dest; DataLen: PtrInt): boolean; -begin - if P+DataLen>Last then - result := false else begin - MoveFast(P^,Dest,DataLen); - inc(P,DataLen); - result := true; - end; -end; - -procedure TFastReader.VarBlob(out result: TValueResult); -begin - result.Len := VarUInt32; - if P+result.Len>Last then - ErrorOverflow; - result.Ptr := P; - inc(P,result.Len); -end; - -function TFastReader.VarBlob: TValueResult; -begin - result.Len := VarUInt32; - if P+result.Len>Last then - ErrorOverflow; - result.Ptr := P; - inc(P,result.Len); -end; - -{$ifndef NOVARIANTS} -procedure TFastReader.NextVariant(var Value: variant; - CustomVariantOptions: PDocVariantOptions); -begin - P := VariantLoad(Value,P,CustomVariantOptions,Last); - if P=nil then - ErrorData('VariantLoad=nil',[]) else - if P>Last then - ErrorOverFlow; -end; - -procedure TFastReader.NextDocVariantData(out Value: variant; - CustomVariantOptions: PDocVariantOptions); -var json: TValueResult; - temp: TSynTempBuffer; -begin - VarBlob(json); - if json.Len<=0 then - exit; - temp.Init(json.Ptr,json.Len); // parsing will modify input buffer in-place - try - if CustomVariantOptions=nil then - CustomVariantOptions := @JSON_OPTIONS[true]; - TDocVariantData(Value).InitJSONInPlace(temp.buf,CustomVariantOptions^); - finally - temp.Done; - end; -end; -{$endif NOVARIANTS} - -function TFastReader.VarInt32: integer; -begin - result := VarUInt32; - if result and 1<>0 then - // 1->1, 3->2.. - result := result shr 1+1 else - // 0->0, 2->-1, 4->-2.. - result := -(result shr 1); -end; - -function TFastReader.VarInt64: Int64; -begin - result := VarUInt64; - if result and 1<>0 then - // 1->1, 3->2.. - result := result shr 1+1 else - // 0->0, 2->-1, 4->-2.. - result := -(result shr 1); -end; - -function TFastReader.VarUInt32: cardinal; -var c: cardinal; -{$ifdef CPUX86} // not enough CPU registers -label err; -begin - result := ord(P^); - if P>=Last then - goto err; - inc(P); - if result<=$7f then - exit; - if P>=Last then - goto err; - c := ord(P^) shl 7; - inc(P); - result := result and $7F or c; - if c<=$7f shl 7 then - exit; // Values between 128 and 16256 - if P>=Last then - goto err; - c := ord(P^) shl 14; - inc(P); - result := result and $3FFF or c; - if c<=$7f shl 14 then - exit; // Values between 16257 and 2080768 - if P>=Last then - goto err; - c := ord(P^) shl 21; - inc(P); - result := result and $1FFFFF or c; - if c<=$7f shl 21 then - exit; // Values between 2080769 and 266338304 - if P>=Last then -err:ErrorOverflow; - c := ord(P^) shl 28; - inc(P); - result := result and $FFFFFFF or c; -{$else} - s,l: PByte; -label err,fin; -begin - s := pointer(P); - l := pointer(Last); - result := s^; - if PAnsiChar(s)>=PAnsiChar(l) then - goto err; - inc(s); - if result<=$7f then - goto fin; - if PAnsiChar(s)>=PAnsiChar(l) then - goto err; - c := s^ shl 7; - inc(s); - result := result and $7F or c; - if c<=$7f shl 7 then - goto fin; // Values between 128 and 16256 - if PAnsiChar(s)>=PAnsiChar(l) then - goto err; - c := s^ shl 14; - inc(s); - result := result and $3FFF or c; - if c<=$7f shl 14 then - goto fin; // Values between 16257 and 2080768 - if PAnsiChar(s)>=PAnsiChar(l) then - goto err; - c := s^ shl 21; - inc(s); - result := result and $1FFFFF or c; - if c<=$7f shl 21 then - goto fin; // Values between 2080769 and 266338304 - if PAnsiChar(s)>=PAnsiChar(l) then -err:ErrorOverflow; - c := s^ shl 28; - inc(s); - result := result and $FFFFFFF or c; -fin: - P := pointer(s); -{$endif} -end; - -procedure TFastReader.VarNextInt; -{$ifdef CPUX86} // not enough CPU registers -begin - repeat - if P>=Last then - break; // reached end of input - if P^<=#$7f then - break; // reached end of VarUInt32/VarUInt64 - inc(P); - until false; - inc(P); -{$else} -var s: PAnsiChar; -begin - s := P; - repeat - if s>=Last then - break; // reached end of input - if s^<=#$7f then - break; // reached end of VarUInt32/VarUInt64 - inc(s); - until false; - P := s+1; -{$endif CPUX86} -end; - -procedure TFastReader.VarNextInt(count: integer); -{$ifdef CPUX86} // not enough CPU registers -begin - if count=0 then - exit; - repeat - if P>=Last then - break; // reached end of input - if P^>#$7f then begin - inc(P); - continue; // didn't reach end of VarUInt32/VarUInt64 - end; - inc(P); - dec(count); - if count=0 then - break; - until false; -{$else} -var s, max: PAnsiChar; -begin - if count=0 then - exit; - s := P; - max := Last; - repeat - if s>=max then - break; // reached end of input - if s^>#$7f then begin - inc(s); - continue; // didn't reach end of VarUInt32/VarUInt64 - end; - inc(s); - dec(count); - if count=0 then - break; - until false; - P := s; -{$endif CPUX86} -end; - -function TFastReader.PeekVarInt32(out value: PtrInt): boolean; -begin - result := PeekVarUInt32(PtrUInt(value)); - if result then - if value and 1<>0 then - // 1->1, 3->2.. - value := value shr 1+1 else - // 0->0, 2->-1, 4->-2.. - value := -(value shr 1); -end; - -function TFastReader.PeekVarUInt32(out value: PtrUInt): boolean; -var s: PAnsiChar; -begin - result := false; - s := P; - repeat - if s>=Last then - exit; // reached end of input -> returns false - if s^<=#$7f then - break; // reached end of VarUInt32 - inc(s); - until false; - s := P; - value := VarUInt32; // fast value decode - P := s; // rewind - result := true; -end; - -function TFastReader.VarUInt32Safe(out Value: cardinal): boolean; -var c, n, v: cardinal; -begin - result := false; - if P>=Last then - exit; - v := ord(P^); - inc(P); - if v>$7f then begin - n := 0; - v := v and $7F; - repeat - if P>=Last then - exit; - c := ord(P^); - inc(P); - inc(n,7); - if c<=$7f then break; - v := v or ((c and $7f) shl n); - until false; - v := v or (c shl n); - end; - Value := v; - result := true; // success -end; - -function TFastReader.VarUInt64: QWord; -label err; -var c, n: PtrUInt; -begin - if P>=Last then -err: ErrorOverflow; - c := ord(P^); - inc(P); - if c>$7f then begin - result := c and $7F; - n := 0; - repeat - if P>=Last then - goto err; - c := ord(P^); - inc(P); - inc(n,7); - if c<=$7f then break; - result := result or (QWord(c and $7f) shl n); - until false; - result := result or (QWord(c) shl n); - end else - result := c; -end; - -function TFastReader.VarString: RawByteString; -begin - with VarBlob do - SetString(result,Ptr,Len); -end; - -procedure TFastReader.VarUTF8(out result: RawUTF8); -begin - with VarBlob do - FastSetString(result,Ptr,Len); -end; - -function TFastReader.VarUTF8: RawUTF8; -begin - with VarBlob do - FastSetString(result,Ptr,Len); -end; - -function TFastReader.VarShortString: shortstring; -begin - with VarBlob do - SetString(result,Ptr,Len); -end; - -function TFastReader.VarUTF8Safe(out Value: RawUTF8): boolean; -var len: cardinal; -begin - if VarUInt32Safe(len) then - if len=0 then - result := true else - if P+len<=Last then begin - FastSetString(Value,P,len); - inc(P,len); - result := true; - end else - result := false else - result := false; -end; - -procedure TFastReader.Read(var DA: TDynArray; NoCheckHash: boolean); -begin - P := DA.LoadFrom(P,nil,NoCheckHash,Last); - if P=nil then - ErrorData('TDynArray.LoadFrom %',[DA.ArrayTypeShort^]); -end; - -function TFastReader.ReadVarUInt32Array(var Values: TIntegerDynArray): PtrInt; -var i: integer; - k: TFileBufferWriterKind; -begin - result := VarUInt32; - SetLength(Values,result); - Copy(k,1); - if k=wkUInt32 then begin - Copy(Values[0],result*4); - exit; - end; - Next(4); // format: Isize+varUInt32s - case k of - wkVarInt32: for i := 0 to result-1 do Values[i] := VarInt32; - wkVarUInt32: for i := 0 to result-1 do Values[i] := VarUInt32; - else ErrorData('ReadVarUInt32Array: unhandled kind=%', [ord(k)]); - end; -end; - -function TFastReader.ReadCompressed(Load: TAlgoCompressLoad; BufferOffset: integer): RawByteString; -var comp: PAnsiChar; - complen: PtrUInt; -begin - complen := VarUInt32; - comp := Next(complen); - TAlgoCompress.Algo(comp,complen).Decompress(comp,complen,result,Load,BufferOffset); -end; - - -{ TSynTempWriter } - -procedure TSynTempWriter.Init(maxsize: integer); -begin - if maxsize<=0 then - pos := tmp.InitOnStack else - pos := tmp.Init(maxsize); -end; - -procedure TSynTempWriter.Done; -begin - tmp.Done; -end; - -function TSynTempWriter.AsBinary: RawByteString; -begin - FastSetStringCP(result,tmp.buf,pos-PAnsiChar(tmp.buf),CP_RAWBYTESTRING); -end; - -procedure TSynTempWriter.AsUTF8(var result: RawUTF8); -begin - FastSetString(result,tmp.buf,pos-PAnsiChar(tmp.buf)); -end; - -function TSynTempWriter.Position: PtrInt; -begin - result := pos-PAnsiChar(tmp.buf); -end; - -procedure TSynTempWriter.wr(const val; len: PtrInt); -begin - if len<=0 then - exit; - if pos-PAnsiChar(tmp.buf)+len>tmp.len then - raise ESynException.CreateUTF8('TSynTempWriter(%) overflow',[tmp.len]); - MoveSmall(@val,pos,len); - inc(pos,len); -end; - -procedure TSynTempWriter.wrb(b: byte); -begin - wr(b,1); -end; - -procedure TSynTempWriter.wrint(int: integer); -begin - wr(int,4); -end; - -procedure TSynTempWriter.wrptrint(int: PtrInt); -begin - wr(int,SizeOf(int)); -end; - -procedure TSynTempWriter.wrptr(ptr: pointer); -begin - wr(ptr,SizeOf(ptr)); -end; - -procedure TSynTempWriter.wrss(const str: shortstring); -begin - wr(str,ord(str[0])+1); -end; - -procedure TSynTempWriter.wrs(const str: RawByteString); -begin - if str<>'' then - wr(pointer(str),length(str)); -end; - -procedure TSynTempWriter.wrw(w: word); -begin - wr(w,2); -end; - -function TSynTempWriter.wrfillchar(count: integer; value: byte): PAnsiChar; -begin - if pos-PAnsiChar(tmp.buf)+count>tmp.len then - raise ESynException.CreateUTF8('TSynTempWriter(%) overflow',[tmp.len]); - FillCharFast(pos^,count,value); - result := pos; - inc(pos,count); -end; - - - -{ TFileBufferWriter } - -constructor TFileBufferWriter.Create(aFile: THandle; BufLen: integer); -begin - Create(THandleStream.Create(aFile),BufLen); - fInternalStream := true; -end; - -constructor TFileBufferWriter.Create(const aFileName: TFileName; BufLen: integer; - Append: boolean); -var s: TStream; -begin - if Append and FileExists(aFileName) then begin - s := TFileStream.Create(aFileName,fmOpenWrite); - s.Seek(0,soEnd); - end else - s := TFileStream.Create(aFileName,fmCreate); - Create(s,BufLen); - fInternalStream := true; -end; - -constructor TFileBufferWriter.Create(aStream: TStream; BufLen: integer); -begin - if BufLen>1 shl 22 then - fBufLen := 1 shl 22 else // 4 MB sounds right enough - if BufLen<32 then - fBufLen := 32; - fBufLen := BufLen; - fStream := aStream; - SetLength(fBufInternal,fBufLen); - fBuffer := pointer(fBufInternal); -end; - -constructor TFileBufferWriter.Create(aClass: TStreamClass; BufLen: integer); -begin - Create(aClass.Create,BufLen); - fInternalStream := true; -end; - -constructor TFileBufferWriter.Create(aStream: TStream; aTempBuf: pointer; aTempLen: integer); -begin - fBufLen := aTempLen; - fBuffer := aTempBuf; - fStream := aStream; -end; - -constructor TFileBufferWriter.Create(aClass: TStreamClass; aTempBuf: pointer; aTempLen: integer); -begin - Create(aClass.Create,aTempBuf,aTempLen); - fInternalStream := true; -end; - -destructor TFileBufferWriter.Destroy; -begin - if fInternalStream then - fStream.Free; - inherited; -end; - -procedure TFileBufferWriter.InternalFlush; -begin - fStream.WriteBuffer(fBuffer^,fPos); - fPos := 0; -end; - -function TFileBufferWriter.Flush: Int64; -begin - if fPos>0 then - InternalFlush; - result := fTotalWritten; - fTotalWritten := 0; -end; - -procedure TFileBufferWriter.CancelAll; -begin - fTotalWritten := 0; - fPos := 0; - if fStream.ClassType = TRawByteStringStream then - TRawByteStringStream(fStream).Size := 0 else - fStream.Seek(0,soBeginning); -end; - -procedure TFileBufferWriter.Write(Data: pointer; DataLen: PtrInt); -begin - if (DataLen<=0) or (Data=nil) then - exit; - inc(fTotalWritten,DataLen); - if fPos+DataLen>fBufLen then begin - if fPos>0 then - InternalFlush; - if DataLen>fBufLen then begin - fStream.WriteBuffer(Data^,DataLen); - exit; - end; - end; - MoveFast(Data^,fBuffer^[fPos],DataLen); - inc(fPos,DataLen); -end; - -procedure TFileBufferWriter.WriteN(Data: Byte; Count: integer); -var len: integer; -begin - inc(fTotalWritten,Count); - while Count>0 do begin - if Count>fBufLen then - len := fBufLen else - len := Count; - if fPos+len>fBufLen then - InternalFlush; - FillCharFast(fBuffer^[fPos],len,Data); - inc(fPos,len); - dec(Count,len); - end; -end; - -procedure TFileBufferWriter.Write1(Data: Byte); -begin - if fPos+1>fBufLen then - InternalFlush; - fBuffer^[fPos] := Data; - inc(fPos); - inc(fTotalWritten); -end; - -procedure TFileBufferWriter.Write2(Data: Word); -begin - if fPos+2>fBufLen then - InternalFlush; - PWord(@fBuffer^[fPos])^ := Data; - inc(fPos,SizeOf(Word)); - inc(fTotalWritten,SizeOf(Word)); -end; - -procedure TFileBufferWriter.Write4(Data: integer); -begin - if fPos+4>fBufLen then - InternalFlush; - PInteger(@fBuffer^[fPos])^ := Data; - inc(fPos,SizeOf(integer)); - inc(fTotalWritten,SizeOf(integer)); -end; - -procedure TFileBufferWriter.Write4BigEndian(Data: integer); -begin - Write4(bswap32(Data)); -end; - -procedure TFileBufferWriter.Write8(const Data8Bytes); -begin - if fPos+8>fBufLen then - InternalFlush; - PInt64(@fBuffer^[fPos])^ := PInt64(@Data8Bytes)^; - inc(fPos,SizeOf(Int64)); - inc(fTotalWritten,SizeOf(Int64)); -end; - -procedure TFileBufferWriter.Write(const Text: RawByteString); -var L: integer; -begin - L := length(Text); - if L=0 then - Write1(0) else begin - WriteVarUInt32(L); - Write(pointer(Text),L); - end; -end; - -procedure TFileBufferWriter.WriteShort(const Text: ShortString); -var L: integer; -begin - L := ord(Text[0]); - if L<$80 then - Write(@Text[0],L+1) else begin - WriteVarUInt32(L); - Write(@Text[1],L); - end; -end; - -procedure TFileBufferWriter.WriteBinary(const Data: RawByteString); -begin - Write(pointer(Data),Length(Data)); -end; - -function TFileBufferWriter.DirectWritePrepare(len: PtrInt; out tmp: RawByteString): PAnsiChar; -begin - if (len<=fBufLen) and (fPos+len>fBufLen) then - InternalFlush; - if fPos+len>fBufLen then begin - SetLength(tmp,len); - result := pointer(tmp); - end else - result := @fBuffer^[fPos]; // write directly into the buffer -end; - -procedure TFileBufferWriter.DirectWriteFlush(len: PtrInt; const tmp: RawByteString); -begin - if tmp='' then begin - inc(fPos,len); - inc(fTotalWritten,len); - end else - Write(pointer(tmp),len); -end; - -procedure TFileBufferWriter.WriteRecord(const Rec; RecTypeInfo: pointer); -var len: integer; - tmp: RawByteString; - P: PAnsiChar; -begin - len := RecordSaveLength(Rec,RecTypeInfo); - P := DirectWritePrepare(len,tmp); - if RecordSave(Rec,P,RecTypeInfo)-P<>len then - raise ESynException.CreateUTF8('%.WriteRecord: RecordSave?',[self]); - DirectWriteFlush(len,tmp); -end; - -procedure TFileBufferWriter.WriteDynArray(const DA: TDynArray); -var len: integer; - tmp: RawByteString; - P: PAnsiChar; -begin - len := DA.SaveToLength; - P := DirectWritePrepare(len,tmp); - if DA.SaveTo(P)-P<>len then - raise ESynException.CreateUTF8('%.WriteDynArray: DA.SaveTo?',[self]); - DirectWriteFlush(len,tmp); -end; - -{$ifndef NOVARIANTS} -procedure TFileBufferWriter.Write(const Value: variant); -var buf: PAnsiChar; - vt,len: integer; - tmp: RawByteString; -begin - vt := TVarData(Value).VType; - if vt>varAny then begin // avoid VariantSaveLength() call - Write(@TVarData(Value).VType,SizeOf(TVarData(Value).VType)); - tmp := VariantSaveJSON(Value); - Write(tmp); - exit; - end; - len := VariantSaveLength(Value); - if len=0 then - raise ESynException.CreateUTF8('%.Write(VType=%) VariantSaveLength=0',[self,vt]); - buf := DirectWritePrepare(len,tmp); - if VariantSave(Value,buf)=nil then - raise ESynException.CreateUTF8('%.Write(VType=%) VariantSave=nil',[self,vt]); - DirectWriteFlush(len,tmp); -end; - -procedure TFileBufferWriter.WriteDocVariantData(const Value: variant); -begin - with _Safe(Value)^ do - if Count=0 then - Write1(0) else - Write(ToJSON); -end; - -{$endif NOVARIANTS} - -procedure TFileBufferWriter.WriteXor(New,Old: PAnsiChar; Len: PtrInt; crc: PCardinal); -var L: integer; - Dest: PAnsiChar; -begin - if (New=nil) or (Old=nil) then - exit; - inc(fTotalWritten,Len); - while Len>0 do begin - Dest := pointer(fBuffer); - if fPos+Len>fBufLen then - InternalFlush else - inc(Dest,fPos); - if Len>fBufLen then - L := fBufLen else - L := Len; - XorMemory(pointer(Dest),pointer(New),pointer(Old),L); - if crc<>nil then - crc^ := crc32c(crc^,Dest,L); - inc(Old,L); - inc(New,L); - dec(Len,L); - inc(fPos,L); - end; -end; - -procedure TFileBufferWriter.WriteRawUTF8DynArray(const Values: TRawUTF8DynArray; - ValuesCount: integer); -begin - WriteRawUTF8Array(pointer(Values),ValuesCount); -end; - -procedure TFileBufferWriter.WriteRawUTF8Array(Values: PPtrUIntArray; ValuesCount: integer); -var n, i: integer; - fixedsize, len: PtrUInt; - P, PEnd: PByte; - PBeg: PAnsiChar; -begin - WriteVarUInt32(ValuesCount); - if ValuesCount=0 then - exit; - fixedsize := Values^[0]; - if fixedsize<>0 then begin - fixedsize := PStrLen(fixedsize-_STRLEN)^; - for i := 1 to ValuesCount-1 do - if (Values^[i]=0) or (PStrLen(Values^[i]-_STRLEN)^<>TStrLen(fixedsize)) then begin - fixedsize := 0; - break; - end; - end; - WriteVarUInt32(fixedsize); - repeat - P := @fBuffer^[fPos]; - PEnd := @fBuffer^[fBufLen-8]; - if PtrUInt(P)=PtrUInt(PEnd) then begin - n := i+1; - break; // avoid buffer overflow - end; - end else begin - len := PStrLen(Values^[i]-_STRLEN)^; - if PtrUInt(PEnd)-PtrUInt(P)<=len then begin - n := i; - break; // avoid buffer overflow - end; - P := ToVarUInt32(len,P); - MoveFast(pointer(Values^[i])^,P^,len); // here len>0 - inc(P,len); - end else // fixedsize<>0: - for i := 0 to ValuesCount-1 do begin - if PtrUInt(PEnd)-PtrUInt(P)<=fixedsize then begin - n := i; - break; // avoid buffer overflow - end; - MoveFast(pointer(Values^[i])^,P^,fixedsize); - inc(P,fixedsize); - end; - len := PAnsiChar(P)-PBeg; // format: Isize+varUInt32s*strings - PInteger(PBeg)^ := len-4; - inc(fTotalWritten,len); - inc(fPos,len); - inc(PByte(Values),n*SizeOf(PtrInt)); - dec(ValuesCount,n); - if ValuesCount=0 then - break; - end; - InternalFlush; - until false; -end; - -procedure TFileBufferWriter.WriteRawUTF8List(List: TRawUTF8List; - StoreObjectsAsVarUInt32: Boolean); -var i: integer; - o: PPointerArray; -begin - if List=nil then - WriteVarUInt32(0) else begin - List.Safe.Lock; - try - WriteRawUTF8Array(pointer(List.TextPtr),List.Count); - o := List.ObjectPtr; - if o=nil then - StoreObjectsAsVarUInt32 := false; // no Objects[] values - Write(@StoreObjectsAsVarUInt32,1); - if StoreObjectsAsVarUInt32 then - for i := 0 to List.Count-1 do - WriteVarUInt32(PtrUInt(o[i])); - finally - List.Safe.UnLock; - end; - end; -end; - -procedure TFileBufferWriter.WriteStream(aStream: TCustomMemoryStream; - aStreamSize: Integer); -begin - if aStreamSize<0 then - if aStream=nil then - aStreamSize := 0 else - aStreamSize := aStream.Size; - WriteVarUInt32(aStreamSize); - if aStreamSize>0 then - Write(aStream.Memory,aStreamSize); -end; - -procedure TFileBufferWriter.WriteVarInt32(Value: PtrInt); -begin - if Value<=0 then - // 0->0, -1->2, -2->4.. - Value := (-Value) shl 1 else - // 1->1, 2->3.. - Value := (Value shl 1)-1; - WriteVarUInt32(Value); -end; - -procedure TFileBufferWriter.WriteVarUInt32(Value: PtrUInt); -var pos: integer; -begin - if fPos+16>fBufLen then - InternalFlush; - pos := fPos; - fPos := PtrUInt(ToVarUInt32(Value,@fBuffer^[fPos]))-PtrUInt(fBuffer); - inc(fTotalWritten,PtrUInt(fPos-Pos)); -end; - -procedure TFileBufferWriter.WriteVarInt64(Value: Int64); -var pos: integer; -begin - if fPos+48>fBufLen then - InternalFlush; - pos := fPos; - fPos := PtrUInt(ToVarInt64(Value,@fBuffer^[fPos]))-PtrUInt(fBuffer); - inc(fTotalWritten,PtrUInt(fPos-Pos)); -end; - -procedure TFileBufferWriter.WriteVarUInt64(Value: QWord); -var pos: integer; -begin - if fPos+48>fBufLen then - InternalFlush; - pos := fPos; - fPos := PtrUInt(ToVarUInt64(Value,@fBuffer^[fPos]))-PtrUInt(fBuffer); - inc(fTotalWritten,PtrUInt(fPos-Pos)); -end; - -function CleverStoreInteger(p: PInteger; V, VEnd: PAnsiChar; pCount: integer; - var StoredCount: integer): PAnsiChar; -// Clever = store Values[i+1]-Values[i] (with special diff=1 count) -// format: Integer: firstValue, then: -// B:0 W:difference with previous -// B:1..253 = difference with previous -// B:254 W:byOne -// B:255 B:byOne -var i, d, byOne: integer; -begin - StoredCount := pCount; - if pCount<=0 then begin - result := V; - exit; - end; - i := p^; - PInteger(V)^ := p^; - inc(V,4); - dec(pCount); - inc(p); - byOne := 0; - if pCount>0 then - repeat - d := p^-i; - i := p^; - inc(p); - if d=1 then begin - dec(pCount); - inc(byOne); - if pCount>0 then continue; - end else - if d<0 then begin - result:= nil; - exit; - end; - if byOne<>0 then begin - case byOne of - 1: begin V^ := #1; inc(V); end; // B:1..253 = difference with previous - 2: begin PWord(V)^ := $0101; inc(V,2); end; // B:1..253 = difference - else - if byOne>255 then begin - while byOne>65535 do begin - PInteger(V)^ := $fffffe; inc(V,3); // store as many len=$ffff as necessary - dec(byOne,$ffff); - end; - PInteger(V)^ := byOne shl 8+$fe; inc(V,3); // B:254 W:byOne - end else begin - PWord(V)^ := byOne shl 8+$ff; inc(V,2); // B:255 B:byOne - end; - end; // case byOne of - if pCount=0 then break; - byOne := 0; - end; - if (d=0) or (d>253) then begin - while cardinal(d)>65535 do begin - PInteger(V)^ := $ffff00; inc(V,3); // store as many len=$ffff as necessary - dec(cardinal(d),$ffff); - end; - dec(pCount); - PInteger(V)^ := d shl 8; inc(V,3); // B:0 W:difference with previous - if (V0) then continue else break; - end else begin - dec(pCount); - V^ := AnsiChar(d); inc(V); // B:1..253 = difference with previous - if (V0) then continue else break; - end; - if V>=VEnd then - break; // avoid GPF - until false; - dec(StoredCount,pCount); - result := V; -end; - -procedure TFileBufferWriter.WriteVarUInt32Array(const Values: TIntegerDynArray; - ValuesCount: integer; DataLayout: TFileBufferWriterKind); -begin - WriteVarUInt32Values(pointer(Values),ValuesCount,DataLayout); -end; - -procedure TFileBufferWriter.WriteVarUInt32Values(Values: PIntegerArray; - ValuesCount: integer; DataLayout: TFileBufferWriterKind); -var n, i, pos, diff: integer; - P: PByte; - PBeg, PEnd: PAnsiChar; -begin - WriteVarUInt32(ValuesCount); - if ValuesCount=0 then - exit; - fBuffer^[fPos] := ord(DataLayout); - inc(fPos); - inc(fTotalWritten); - if DataLayout in [wkOffsetU, wkOffsetI] then begin - pos := fPos; - fPos := PtrUInt(ToVarUInt32(Values^[0],@fBuffer^[fPos]))-PtrUInt(fBuffer); - diff := Values^[1]-Values^[0]; - inc(PInteger(Values)); - dec(ValuesCount); - if ValuesCount=0 then begin - inc(fTotalWritten,PtrUInt(fPos-pos)); - exit; - end; - if diff>0 then begin - for i := 1 to ValuesCount-1 do - if Values^[i]-Values^[i-1]<>diff then begin - diff := 0; // not always the same offset - break; - end; - end else - diff := 0; - fPos := PtrUInt(ToVarUInt32(diff,@fBuffer^[fPos]))-PtrUInt(fBuffer); - inc(fTotalWritten,PtrUInt(fPos-pos)); - if diff<>0 then - exit; // same offset for all items (fixed sized records) -> quit now - end; - repeat - P := @fBuffer^[fPos]; - PEnd := @fBuffer^[fBufLen-32]; - if PtrUInt(P)=PtrUInt(PEnd) then begin - n := i+1; - break; // avoid buffer overflow - end; - end; - wkVarUInt32: - for i := 0 to ValuesCount-1 do begin - P := ToVarUInt32(Values^[i],P); - if PtrUInt(P)>=PtrUInt(PEnd) then begin - n := i+1; - break; // avoid buffer overflow - end; - end; - wkOffsetU: - for i := 0 to ValuesCount-1 do begin - P := ToVarUInt32(Values^[i]-Values^[i-1],P); - if PtrUInt(P)>=PtrUInt(PEnd) then begin - n := i+1; - break; // avoid buffer overflow - end; - end; - wkOffsetI: - for i := 0 to ValuesCount-1 do begin - P := ToVarInt32(Values^[i]-Values^[i-1],P); - if PtrUInt(P)>=PtrUInt(PEnd) then begin - n := i+1; - break; // avoid buffer overflow - end; - end; - end; - PInteger(PBeg)^ := PAnsiChar(P)-PBeg-4; // format: Isize+varUInt32s - end; - wkSorted: begin - PBeg := PAnsiChar(P)+4; // leave space for chunk size - P := PByte(CleverStoreInteger(pointer(Values),PBeg,PEnd,ValuesCount,n)); - if P=nil then - raise ESynException.CreateUTF8('%.WriteVarUInt32Array: data not sorted',[self]); - PInteger(PBeg-4)^ := PAnsiChar(P)-PBeg; // format: Isize+cleverStorage - end; - end; - inc(PByte(Values),n*4); - fPos := PtrUInt(P)-PtrUInt(fBuffer); - inc(fTotalWritten,PtrUInt(fPos-pos)); - dec(ValuesCount,n); - if ValuesCount=0 then - break; - end; - InternalFlush; - until false; -end; - -procedure TFileBufferWriter.WriteVarUInt64DynArray( - const Values: TInt64DynArray; ValuesCount: integer; Offset: Boolean); -var n, i, pos: integer; - diff: Int64; - P, PEnd: PByte; - PI: PInt64Array; - PBeg: PAnsiChar; -begin - WriteVarUInt32(ValuesCount); - if ValuesCount=0 then - exit; - PI := pointer(Values); - pos := fPos; - if Offset then begin - fBuffer^[fPos] := 1; - fPos := PtrUInt(ToVarUInt64(PI^[0],@fBuffer^[fPos+1]))-PtrUInt(fBuffer); - diff := PI^[1]-PI^[0]; - inc(PByte(PI),8); - dec(ValuesCount); - if ValuesCount=0 then begin - inc(fTotalWritten,PtrUInt(fPos-pos)); - exit; - end; - if (diff>0) and (diffdiff then begin - diff := 0; // not always the same offset - break; - end; - end else - diff := 0; - fPos := PtrUInt(ToVarUInt32(diff,@fBuffer^[fPos]))-PtrUInt(fBuffer); - if diff<>0 then begin - inc(fTotalWritten,PtrUInt(fPos-Pos)); - exit; // same offset for all items (fixed sized records) -> quit now - end; - end else begin - fBuffer^[fPos] := 0; - inc(fPos); - end; - inc(fTotalWritten,PtrUInt(fPos-Pos)); - repeat - P := @fBuffer^[fPos]; - PEnd := @fBuffer^[fBufLen-32]; - if PtrUInt(P)=PtrUInt(PEnd) then begin - n := i+1; - break; // avoid buffer overflow - end; - end - else - for i := 0 to ValuesCount-1 do begin - P := ToVarUInt64(PI^[i],P); - if PtrUInt(P)>=PtrUInt(PEnd) then begin - n := i+1; - break; // avoid buffer overflow - end; - end; - PInteger(PBeg)^ := PAnsiChar(P)-PBeg-4; // format: Isize+varUInt32/64s - inc(PByte(PI),n*8); - fPos := PtrUInt(P)-PtrUInt(fBuffer); - inc(fTotalWritten,PtrUInt(fPos-Pos)); - dec(ValuesCount,n); - if ValuesCount=0 then - break; - end; - InternalFlush; - until false; -end; - -function TFileBufferWriter.FlushAndCompress(nocompression: boolean; algo: TAlgoCompress; - BufferOffset: integer): RawByteString; -var trig: integer; -begin - if algo=nil then - algo := AlgoSynLZ; - trig := SYNLZTRIG[nocompression]; - if fStream.Position=0 then // direct compression from internal buffer - result := algo.Compress(PAnsiChar(fBuffer),fPos,trig,false,BufferOffset) else begin - Flush; - result := algo.Compress((fStream as TRawByteStringStream).DataString,trig,false,BufferOffset); - end; -end; - - -{ TFileBufferReader } - -procedure TFileBufferReader.Close; -begin - fMap.UnMap; -end; - -procedure TFileBufferReader.ErrorInvalidContent; -begin - raise ESynException.Create('TFileBufferReader: invalid content'); -end; - -procedure TFileBufferReader.OpenFrom(aBuffer: pointer; aBufferSize: PtrUInt); -begin - fCurrentPos := 0; - fMap.Map(aBuffer,aBufferSize); -end; - -procedure TFileBufferReader.OpenFrom(const aBuffer: RawByteString); -begin - OpenFrom(pointer(aBuffer),length(aBuffer)); -end; - -function TFileBufferReader.OpenFrom(Stream: TStream): boolean; -begin - result := false; - if Stream=nil then - exit; - if Stream.InheritsFrom(TFileStream) then - Open(TFileStream(Stream).Handle) else - if Stream.InheritsFrom(TCustomMemoryStream) then - with TCustomMemoryStream(Stream) do - OpenFrom(Memory,Size) else - exit; - result := true -end; - -procedure TFileBufferReader.Open(aFile: THandle; aFileNotMapped: boolean); -begin - fCurrentPos := 0; - if aFileNotMapped then - FillcharFast(fMap,SizeOf(fMap),0) else - fMap.Map(aFile) - // if Windows failed to find a contiguous VA space -> fall back on direct read -end; - -function TFileBufferReader.Read(Data: pointer; DataLen: PtrInt): integer; -var len: PtrInt; -begin - if DataLen>0 then - if fMap.Buffer<>nil then begin - // file up to 2 GB: use fast memory map - len := fMap.Size-fCurrentPos; - if len>DataLen then - len := DataLen; - if Data<>nil then - MoveFast(fMap.Buffer[fCurrentPos],Data^,len); - inc(fCurrentPos,len); - result := len; - end else - // file bigger than 2 GB: slower but accurate reading from file - if Data=nil then begin - FileSeek64(fMap.FileHandle,DataLen,soFromCurrent); - result := DataLen; - end else - result := FileRead(fMap.FileHandle,Data^,DataLen) else - // DataLen=0 - result := 0; -end; - -function TFileBufferReader.Read(out Text: RawByteString): integer; -begin - result := ReadVarUInt32; - if result=0 then - exit; - SetLength(Text,result); - if Read(pointer(Text),result)<>result then - ErrorInvalidContent; -end; - -function TFileBufferReader.Read(out Text: RawUTF8): integer; -begin - result := ReadVarUInt32; - if result=0 then - exit; - SetLength(Text,result); - if Read(pointer(Text),result)<>result then - ErrorInvalidContent; -end; - -function TFileBufferReader.ReadRawUTF8: RawUTF8; -begin - Read(result); -end; - -procedure TFileBufferReader.ReadChunk(out P, PEnd: PByte; var BufTemp: RawByteString); -var len: integer; -begin // read Isize + buffer in P,PEnd - if (Read(@len,4)<>4) or (len<0) then - ErrorInvalidContent; - P := ReadPointer(len,BufTemp); - if P=nil then - ErrorInvalidContent; - PEnd := pointer(PtrUInt(P)+PtrUInt(len)); -end; - -function TFileBufferReader.CurrentMemory(DataLen: PtrUInt; PEnd: PPAnsiChar): pointer; -begin - if (fMap.Buffer=nil) or (fCurrentPos+DataLen>=fMap.Size) then - result := nil else begin - result := @fMap.Buffer[fCurrentPos]; - if PEnd<>nil then - PEnd^ := @fMap.Buffer[fMap.Size]; - inc(fCurrentPos,DataLen); - end; -end; - -function TFileBufferReader.CurrentPosition: integer; -begin - if (fMap.Buffer=nil) or (fCurrentPos>=fMap.Size) then - result := -1 else - result := fCurrentPos; -end; - -function TFileBufferReader.FileSize: Int64; -begin - result := fMap.FileSize; -end; - -function TFileBufferReader.MappedBuffer: PAnsiChar; -begin - result := fMap.Buffer; -end; - -function TFileBufferReader.ReadPointer(DataLen: PtrUInt; - var aTempData: RawByteString): pointer; -begin - if fMap.Buffer=nil then begin - // read from file - if DataLen>PtrUInt(Length(aTempData)) then begin - aTempData := ''; // so no move() call in SetLength() below - SetLength(aTempData,DataLen); - end; - if PtrUInt(FileRead(fMap.FileHandle,pointer(aTempData)^,DataLen))<>DataLen then - result := nil else // invalid content - result := pointer(aTempData); - end else - if DataLen+fCurrentPos>fMap.Size then - // invalid request - result := nil else begin - // get pointer to data from current memory map (no data copy) - result := @fMap.Buffer[fCurrentPos]; - inc(fCurrentPos,DataLen); - end; -end; - -function TFileBufferReader.ReadStream(DataLen: PtrInt): TCustomMemoryStream; -var FileCurrentPos: Int64; -begin - if DataLen<0 then - DataLen := ReadVarUInt32; - if DataLen<>0 then - if fMap.Buffer=nil then begin - FileCurrentPos := FileSeek64(fMap.FileHandle,0,soFromCurrent); - if FileCurrentPos+DataLen>fMap.Size then - // invalid content - result := nil else begin - // create a temporary memory map buffer stream - result := TSynMemoryStreamMapped.Create(fMap.FileHandle,DataLen,FileCurrentPos); - FileSeek64(fMap.FileHandle,DataLen,soFromCurrent); - end; - end else - if PtrUInt(DataLen)+fCurrentPos>fMap.Size then - // invalid content - result := nil else begin - // get pointer to data from current memory map (no data copy) - result := TSynMemoryStream.Create(@fMap.Buffer[fCurrentPos],DataLen); - inc(fCurrentPos,DataLen); - end else - // DataLen=0 -> invalid content - result := nil; -end; - -function TFileBufferReader.ReadByte: PtrUInt; -begin - if fMap.Buffer<>nil then - if fCurrentPos>=fMap.Size then - // invalid request - result := 0 else begin - // read 8-bit from current memory map - result := ord(fMap.Buffer[fCurrentPos]); - inc(fCurrentPos); - end else begin - // read from file if >= 2 GB (slow, but works) - result := 0; - if FileRead(fMap.FileHandle,result,1)<>1 then - result := 0; - end; -end; - -function TFileBufferReader.ReadCardinal: cardinal; -begin - if fMap.Buffer<>nil then - if fCurrentPos+3>=fMap.Size then - // invalid request - result := 0 else begin - // read 32-bit from current memory map - result := PCardinal(fMap.Buffer+fCurrentPos)^; - inc(fCurrentPos,4); - end else begin - // read from file if >= 2 GB (slow, but works) - result := 0; - if FileRead(fMap.FileHandle,result,4)<>4 then - result := 0; - end; -end; - -function TFileBufferReader.ReadVarUInt32: PtrUInt; -var c, n: PtrUInt; -begin - result := ReadByte; - if result>$7f then begin - n := 0; - result := result and $7F; - repeat - c := ReadByte; - inc(n,7); - if c<=$7f then break; - result := result or ((c and $7f) shl n); - until false; - result := result or (c shl n); - end; -end; - -function TFileBufferReader.ReadVarInt32: PtrInt; -begin - result := ReadVarUInt32; - if result and 1<>0 then - // 1->1, 3->2.. - result := result shr 1+1 else - // 0->0, 2->-1, 4->-2.. - result := -(result shr 1); -end; - -function TFileBufferReader.ReadVarUInt64: QWord; -var c, n: PtrUInt; -begin - result := ReadByte; - if result>$7f then begin - n := 0; - result := result and $7F; - repeat - c := ReadByte; - inc(n,7); - if c<=$7f then break; - result := result or (QWord(c and $7f) shl n); - until false; - result := result or (QWord(c) shl n); - end; -end; - -function TFileBufferReader.ReadVarInt64: Int64; -begin - result := ReadVarUInt64; - if result<>0 then - if result and 1<>0 then - // 1->1, 3->2.. - result := result shr 1+1 else - // 0->0, 2->-1, 4->-2.. - result := -(result shr 1); -end; - -function CleverReadInteger(p, pEnd: PAnsiChar; V: PInteger): PtrUInt; -// Clever = decode Values[i+1]-Values[i] storage (with special diff=1 count) -var i, n: PtrUInt; -begin - result := PtrUInt(V); - i := PInteger(p)^; inc(p,4); // Integer: firstValue - V^ := i; inc(V); - if PtrUInt(p)length(Values) then // only set length is not big enough - SetLength(Values,count); - PI := pointer(Values); - if DataLayout in [wkOffsetU, wkOffsetI] then begin - PI^ := ReadVarUInt32; - dec(count); - if count=0 then - exit; - diff := ReadVarUInt32; - if diff<>0 then begin - for i := 0 to count-1 do - PIA^[i+1] := PIA^[i]+diff; - exit; - end; - end; - if DataLayout=wkUInt32 then - Read(@Values[0],count*4) else begin - repeat - ReadChunk(P,PEnd,BufTemp); // raise ErrorInvalidContent on error - case DataLayout of - wkVarInt32: - while (count>0) and (PtrUInt(P)0) and (PtrUInt(P)0) and (PtrUInt(P)0) and (PtrUInt(P)@Values[result] then - ErrorInvalidContent; - end; -end; - -function TFileBufferReader.ReadVarUInt64Array(var Values: TInt64DynArray): PtrInt; -var count, i: integer; - P, PEnd: PByte; - v: PQWordArray; - diff: QWord; - BufTemp: RawByteString; -begin - result := ReadVarUInt32; - if result=0 then - exit; - count := result; - if count>length(Values) then // only set length if not big enough - SetLength(Values,count); - v := pointer(Values); - if boolean(ReadByte) then begin // values were stored as offsets - v^[0] := ReadVarUInt64; // read first value - dec(count); - diff := ReadVarUInt32; - if diff=0 then begin - // read all offsets, and compute (not fixed sized records) - repeat - ReadChunk(P,PEnd,BufTemp); // raise ErrorInvalidContent on error - while (count>0) and (PtrUInt(P)nil) and (List<>nil) then begin - List.BeginUpdate; - try - List.Clear; - n := ReadVarRawUTF8DynArray(v); - result := true; - if n=0 then - exit; - Read(@StoreObjectsAsVarUInt32,1); - if StoreObjectsAsVarUInt32 then begin - List.Flags := List.Flags-[fObjectsOwned]; // Int32 here, not instances - SetLength(o,length(v)); - for i := 0 to n-1 do - o[i] := TObject(ReadVarUInt32); - end; - List.SetFrom(v,o); // fast assignment using refcnt - finally - List.EndUpdate; - end; - end else - result := false; -end; - -function TFileBufferReader.ReadVarRawUTF8DynArray(var Values: TRawUTF8DynArray): PtrInt; -var count, len, fixedsize: integer; - P, PEnd: PByte; - PI: PRawUTF8; - BufTemp: RawByteString; -begin - result := ReadVarUInt32; - if result=0 then - exit; - count := result; - if count>length(Values) then // change Values[] length only if not big enough - SetLength(Values,count); - PI := pointer(Values); - fixedsize := ReadVarUInt32; - repeat - ReadChunk(P,PEnd,BufTemp); // raise ErrorInvalidContent on error - if fixedsize=0 then - while (count>0) and (PtrUInt(P)0 then begin - FastSetString(PI^,P,len); - inc(P,len); - end else - if PI^<>'' then - PI^ := ''; - dec(count); - inc(PI); - end else - // fixed size strings case - while (count>0) and (PtrUInt(P)@Values[result] then - ErrorInvalidContent; -end; - -{$ifndef CPU64} -function TFileBufferReader.Seek(Offset: Int64): boolean; -begin - if (Offset<0) or (Offset>fMap.Size) then - result := False else - if fMap.Buffer=nil then - result := FileSeek64(fMap.FileHandle,Offset,soFromBeginning)=Offset else begin - fCurrentPos := PCardinal(@Offset)^; - result := true; - end; -end; -{$endif CPU64} - -function TFileBufferReader.Seek(Offset: PtrInt): boolean; -begin - // we don't need to handle fMap=0 here - if fMap.Buffer=nil then - Result := FileSeek(fMap.FileHandle,Offset,0)=Offset else - if (fMap.Buffer<>nil) and (PtrUInt(Offset)fMaxRamUsed then - Reset; - if fTimeoutSeconds>0 then begin - tix := {$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64 shr 10; - if fTimeoutTix>tix then - Reset; - fTimeoutTix := tix+fTimeoutSeconds; - end; -end; - -procedure TSynCache.Add(const aValue: RawUTF8; aTag: PtrInt); -begin - if (self=nil) or (fFindLastKey='') then - exit; - ResetIfNeeded; - inc(fRamUsed,length(aValue)); - fNameValue.Add(fFindLastKey,aValue,aTag); - fFindLastKey := ''; -end; - -function TSynCache.Find(const aKey: RawUTF8; aResultTag: PPtrInt): RawUTF8; -var ndx: integer; -begin - result := ''; - if self=nil then - exit; - fFindLastKey := aKey; - if aKey='' then - exit; - ndx := fNameValue.Find(aKey); - if ndx<0 then - exit; - with fNameValue.List[ndx] do begin - result := Value; - if aResultTag<>nil then - aResultTag^ := Tag; - end; -end; - -function TSynCache.AddOrUpdate(const aKey, aValue: RawUTF8; aTag: PtrInt): boolean; -var ndx: integer; -begin - result := false; - if self=nil then - exit; // avoid GPF - fSafe.Lock; - try - ResetIfNeeded; - ndx := fNameValue.DynArray.FindHashedForAdding(aKey,result); - with fNameValue.List[ndx] do begin - Name := aKey; - dec(fRamUsed,length(Value)); - Value := aValue; - inc(fRamUsed,length(Value)); - Tag := aTag; - end; - finally - fSafe.Unlock; - end; -end; - -function TSynCache.Reset: boolean; -begin - result := false; - if self=nil then - exit; // avoid GPF - fSafe.Lock; - try - if Count<>0 then begin - fNameValue.DynArray.Clear; - fNameValue.DynArray.ReHash; - result := true; // mark something was flushed - end; - fRamUsed := 0; - fTimeoutTix := 0; - finally - fSafe.Unlock; - end; -end; - -function TSynCache.Count: integer; -begin - if self=nil then begin - result := 0; - exit; - end; - fSafe.Lock; - try - result := fNameValue.Count; - finally - fSafe.Unlock; - end; -end; - - -{ TSynQueue } - -constructor TSynQueue.Create(aTypeInfo: pointer); -begin - inherited Create; - fFirst := -1; - fLast := -2; - fValues.Init(aTypeInfo,fValueVar,@fCount); -end; - -destructor TSynQueue.Destroy; -begin - WaitPopFinalize; - fValues.Clear; - inherited Destroy; -end; - -procedure TSynQueue.Clear; -begin - fSafe.Lock; - try - fValues.Clear; - fFirst := -1; - fLast := -2; - finally - fSafe.UnLock; - end; -end; - -function TSynQueue.Count: Integer; -begin - if self=nil then - result := 0 else begin - fSafe.Lock; - try - if fFirst<0 then - result := 0 else - if fFirst<=fLast then - result := fLast-fFirst+1 else - result := fCount-fFirst+fLast+1; - finally - fSafe.UnLock; - end; - end; -end; - -function TSynQueue.Capacity: integer; -begin - if self=nil then - result := 0 else begin - fSafe.Lock; - try - result := fValues.Capacity; - finally - fSafe.UnLock; - end; - end; -end; - -function TSynQueue.Pending: boolean; -begin // allow some false positive: fSafe.Lock not used here - result := (self<>nil) and (fFirst>=0); -end; - -procedure TSynQueue.Push(const aValue); -begin - fSafe.Lock; - try - if fFirst<0 then begin - fFirst := 0; // start from the bottom of the void queue - fLast := 0; - if fCount=0 then - fValues.Count := 64; - end else - if fFirst<=fLast then begin // stored in-order - inc(fLast); - if fLast=fCount then - InternalGrow; - end else begin - inc(fLast); - if fLast=fFirst then begin // collision -> arrange - fValues.AddArray(fValueVar,0,fLast); // move 0..fLast to the end - fLast := fCount; - InternalGrow; - end; - end; - fValues.ElemCopyFrom(aValue,fLast); - finally - fSafe.UnLock; - end; -end; - -procedure TSynQueue.InternalGrow; -var cap: integer; -begin - cap := fValues.Capacity; - if fFirst>cap-fCount then // use leading space if worth it - fLast := 0 else // append at the end - if fCount=cap then // reallocation needed - fValues.Count := cap+cap shr 3+64 else - fCount := cap; // fill trailing memory as much as possible -end; - -function TSynQueue.Peek(out aValue): boolean; -begin - fSafe.Lock; - try - result := fFirst>=0; - if result then - fValues.ElemCopyAt(fFirst,aValue); - finally - fSafe.UnLock; - end; -end; - -function TSynQueue.Pop(out aValue): boolean; -begin - fSafe.Lock; - try - result := fFirst>=0; - if result then begin - fValues.ElemMoveTo(fFirst,aValue); - if fFirst=fLast then begin - fFirst := -1; // reset whole store (keeping current capacity) - fLast := -2; - end else begin - inc(fFirst); - if fFirst=fCount then - fFirst := 0; // will retrieve from leading items - end; - end; - finally - fSafe.UnLock; - end; -end; - -function TSynQueue.PopEquals(aAnother: pointer; aCompare: TDynArraySortCompare; - out aValue): boolean; -begin - fSafe.Lock; - try - result := (fFirst>=0) and Assigned(aCompare) and Assigned(aAnother) and - (aCompare(fValues.ElemPtr(fFirst)^,aAnother^)=0) and Pop(aValue); - finally - fSafe.UnLock; - end; -end; - -function TSynQueue.InternalDestroying(incPopCounter: integer): boolean; -begin - fSafe.Lock; - try - result := wpfDestroying in fWaitPopFlags; - inc(fWaitPopCounter,incPopCounter); - finally - fSafe.UnLock; - end; -end; - -function TSynQueue.InternalWaitDone(endtix: Int64; const idle: TThreadMethod): boolean; -begin - SleepHiRes(1); - if Assigned(idle) then - idle; // e.g. Application.ProcessMessages - result := InternalDestroying(0) or (GetTickCount64>endtix); -end; - -function TSynQueue.WaitPop(aTimeoutMS: integer; const aWhenIdle: TThreadMethod; - out aValue; aCompared: pointer; aCompare: TDynArraySortCompare): boolean; -var endtix: Int64; -begin - result := false; - if not InternalDestroying(+1) then - try - endtix := GetTickCount64+aTimeoutMS; - repeat - if Assigned(aCompared) and Assigned(aCompare) then - result := PopEquals(aCompared,aCompare,aValue) else - result := Pop(aValue); - until result or InternalWaitDone(endtix,aWhenIdle); - finally - InternalDestroying(-1); - end; -end; - -function TSynQueue.WaitPeekLocked(aTimeoutMS: integer; const aWhenIdle: TThreadMethod): pointer; -var endtix: Int64; -begin - result := nil; - if not InternalDestroying(+1) then - try - endtix := GetTickCount64+aTimeoutMS; - repeat - fSafe.Lock; - try - if fFirst>=0 then - result := fValues.ElemPtr(fFirst); - finally - if result=nil then - fSafe.UnLock; // caller should always Unlock once done - end; - until (result<>nil) or InternalWaitDone(endtix,aWhenIdle); - finally - InternalDestroying(-1); - end; -end; - -procedure TSynQueue.WaitPopFinalize(aTimeoutMS: integer); -var endtix: Int64; // never wait forever -begin - fSafe.Lock; - try - include(fWaitPopFlags,wpfDestroying); - if fWaitPopCounter=0 then - exit; - finally - fSafe.UnLock; - end; - endtix := GetTickCount64+aTimeoutMS; - repeat - SleepHiRes(1); // ensure WaitPos() is actually finished - until (fWaitPopCounter=0) or (GetTickCount64>endtix); -end; - -procedure TSynQueue.Save(out aDynArrayValues; aDynArray: PDynArray); -var n: integer; - DA: TDynArray; -begin - DA.Init(fValues.ArrayType,aDynArrayValues,@n); - fSafe.Lock; - try - DA.Capacity := Count; // pre-allocate whole array, and set its length - if fFirst>=0 then - if fFirst<=fLast then - DA.AddArray(fValueVar,fFirst,fLast-fFirst+1) else begin - DA.AddArray(fValueVar,fFirst,fCount-fFirst); - DA.AddArray(fValueVar,0,fLast+1); - end; - finally - fSafe.UnLock; - end; - if aDynArray<>nil then - aDynArray^.Init(fValues.ArrayType,aDynArrayValues); -end; - - -{ TObjectListSorted } - -destructor TObjectListSorted.Destroy; -var i: integer; -begin - for i := 0 to fCount-1 do - fObjArray[i].Free; - inherited; -end; - -function TObjectListSorted.FastLocate(const Value; out Index: Integer): boolean; -var n, i, cmp: integer; -begin - result := False; - n := Count; - if n=0 then // a void array is always sorted - Index := 0 else begin - dec(n); - if Compare(fObjArray[n],Value)<0 then begin // already sorted - Index := n+1; // returns false + last position index to insert - exit; - end; - Index := 0; - while Index<=n do begin // O(log(n)) binary search of the sorted position - i := (Index+n) shr 1; - cmp := Compare(fObjArray[i],Value); - if cmp=0 then begin - Index := i; // index of existing Elem - result := True; - exit; - end else - if cmp<0 then - Index := i+1 else - n := i-1; - end; - // Elem not found: returns false + the index where to insert - end; -end; - -procedure TObjectListSorted.InsertNew(Item: TSynPersistentLock; - Index: integer); -begin - if fCount=length(fObjArray) then - SetLength(fObjArray,NextGrow(fCount)); - if cardinal(Index)i then - MoveFast(fObjArray[i+1],fObjArray[i],(fCount-i)*SizeOf(TObject)); - result := true; - end; - finally - fSafe.UnLock; - end; -end; - -function TObjectListSorted.FindLocked(const Value): pointer; -var i: integer; -begin - result := nil; - fSafe.Lock; - try - if FastLocate(Value,i) then begin - result := fObjArray[i]; - TSynPersistentLock(result).Safe.Lock; - end; - finally - fSafe.UnLock; - end; -end; - -function TObjectListSorted.FindOrAddLocked(const Value; out added: boolean): pointer; -var i: integer; -begin - added := false; - fSafe.Lock; - try - if not FastLocate(Value,i) then begin - InsertNew(NewItem(Value),i); - added := true; - end; - result := fObjArray[i]; - TSynPersistentLock(result).Safe.Lock; - finally - fSafe.UnLock; - end; -end; - - - -{ TSynPersistentStore } - -constructor TSynPersistentStore.Create(const aName: RawUTF8); -begin - Create; - fName := aName; -end; - -constructor TSynPersistentStore.CreateFrom(const aBuffer: RawByteString; - aLoad: TAlgoCompressLoad); -begin - CreateFromBuffer(pointer(aBuffer),length(aBuffer),aLoad); -end; - -constructor TSynPersistentStore.CreateFromBuffer( - aBuffer: pointer; aBufferLen: integer; aLoad: TAlgoCompressLoad); -begin - Create(''); - LoadFrom(aBuffer,aBufferLen,aLoad); -end; - -constructor TSynPersistentStore.CreateFromFile(const aFileName: TFileName; - aLoad: TAlgoCompressLoad); -begin - Create(''); - LoadFromFile(aFileName,aLoad); -end; - -procedure TSynPersistentStore.LoadFromReader; -begin - fReader.VarUTF8(fName); -end; - -procedure TSynPersistentStore.SaveToWriter(aWriter: TFileBufferWriter); -begin - aWriter.Write(fName); -end; - -procedure TSynPersistentStore.LoadFrom(const aBuffer: RawByteString; - aLoad: TAlgoCompressLoad); -begin - if aBuffer <> '' then - LoadFrom(pointer(aBuffer),length(aBuffer),aLoad); -end; - -procedure TSynPersistentStore.LoadFrom(aBuffer: pointer; aBufferLen: integer; - aLoad: TAlgoCompressLoad); -var localtemp: RawByteString; - p: pointer; - temp: PRawByteString; -begin - if (aBuffer=nil) or (aBufferLen<=0) then - exit; // nothing to load - fLoadFromLastAlgo := TAlgoCompress.Algo(aBuffer,aBufferLen); - if fLoadFromLastAlgo = nil then - fReader.ErrorData('%.LoadFrom unknown TAlgoCompress AlgoID=%', - [self,PByteArray(aBuffer)[4]]); - temp := fReaderTemp; - if temp=nil then - temp := @localtemp; - p := fLoadFromLastAlgo.Decompress(aBuffer,aBufferLen,fLoadFromLastUncompressed,temp^,aLoad); - if p=nil then - fReader.ErrorData('%.LoadFrom %.Decompress failed',[self,fLoadFromLastAlgo]); - fReader.Init(p,fLoadFromLastUncompressed); - LoadFromReader; -end; - -function TSynPersistentStore.LoadFromFile(const aFileName: TFileName; - aLoad: TAlgoCompressLoad): boolean; -var temp: RawByteString; -begin - temp := StringFromFile(aFileName); - result := temp<>''; - if result then - LoadFrom(temp,aLoad); -end; - -procedure TSynPersistentStore.SaveTo(out aBuffer: RawByteString; nocompression: boolean; - BufLen: integer; ForcedAlgo: TAlgoCompress; BufferOffset: integer); -var writer: TFileBufferWriter; - temp: array[word] of byte; -begin - if BufLen<=SizeOf(temp) then - writer := TFileBufferWriter.Create(TRawByteStringStream,@temp,SizeOf(temp)) else - writer := TFileBufferWriter.Create(TRawByteStringStream,BufLen); - try - SaveToWriter(writer); - fSaveToLastUncompressed := writer.TotalWritten; - aBuffer := writer.FlushAndCompress(nocompression,ForcedAlgo,BufferOffset); - finally - writer.Free; - end; -end; - -function TSynPersistentStore.SaveTo(nocompression: boolean; BufLen: integer; - ForcedAlgo: TAlgoCompress; BufferOffset: integer): RawByteString; -begin - SaveTo(result,nocompression,BufLen,ForcedAlgo,BufferOffset); -end; - -function TSynPersistentStore.SaveToFile(const aFileName: TFileName; - nocompression: boolean; BufLen: integer; ForcedAlgo: TAlgoCompress): PtrUInt; -var temp: RawByteString; -begin - SaveTo(temp,nocompression,BufLen,ForcedAlgo); - if FileFromString(temp,aFileName) then - result := length(temp) else - result := 0; -end; - - -{ TSynPersistentStoreJson } - -procedure TSynPersistentStoreJson.AddJSON(W: TTextWriter); -begin - W.AddPropJSONString('name', fName); -end; - -function TSynPersistentStoreJson.SaveToJSON(reformat: TTextWriterJSONFormat): RawUTF8; -var - W: TTextWriter; -begin - W := DefaultTextWriterSerializer.CreateOwnedStream(65536); - try - W.Add('{'); - AddJSON(W); - W.CancelLastComma; - W.Add('}'); - W.SetText(result, reformat); - finally - W.Free; - end; -end; - - -{ TRawByteStringGroup } - -procedure TRawByteStringGroup.Add(const aItem: RawByteString); -begin - if Values=nil then - Clear; // ensure all fields are initialized, even if on stack - if Count=Length(Values) then - SetLength(Values,NextGrow(Count)); - with Values[Count] do begin - Position := self.Position; - Value := aItem; - end; - LastFind := Count; - inc(Count); - inc(Position,Length(aItem)); -end; - -procedure TRawByteStringGroup.Add(aItem: pointer; aItemLen: integer); -var tmp: RawByteString; -begin - SetString(tmp,PAnsiChar(aItem),aItemLen); - Add(tmp); -end; - -{$ifndef DELPHI5OROLDER} // circumvent Delphi 5 compiler bug - -procedure TRawByteStringGroup.Add(const aAnother: TRawByteStringGroup); -var i: integer; - s,d: PRawByteStringGroupValue; -begin - if aAnother.Values=nil then - exit; - if Values=nil then - Clear; // ensure all fields are initialized, even if on stack - if Count+aAnother.Count>Length(Values) then - SetLength(Values,Count+aAnother.Count); - s := pointer(aAnother.Values); - d := @Values[Count]; - for i := 1 to aAnother.Count do begin - d^.Position := Position; - d^.Value := s^.Value; - inc(Position,length(s^.Value)); - inc(s); - inc(d); - end; - inc(Count,aAnother.Count); - LastFind := Count-1; -end; - -procedure TRawByteStringGroup.RemoveLastAdd; -begin - if Count>0 then begin - dec(Count); - dec(Position,Length(Values[Count].Value)); - Values[Count].Value := ''; // release memory - LastFind := Count-1; - end; -end; - -function TRawByteStringGroup.Equals(const aAnother: TRawByteStringGroup): boolean; -begin - if ((Values=nil) and (aAnother.Values<>nil)) or ((Values<>nil) and (aAnother.Values=nil)) or - (Position<>aAnother.Position) then - result := false else - if (Count<>1) or (aAnother.Count<>1) or (Values[0].Value<>aAnother.Values[0].Value) then - result := AsText=aAnother.AsText else - result := true; -end; - -{$endif DELPHI5OROLDER} - -procedure TRawByteStringGroup.Clear; -begin - Values := nil; - Position := 0; - Count := 0; - LastFind := 0; -end; - -procedure TRawByteStringGroup.AppendTextAndClear(var aDest: RawByteString); -var d,i: integer; - v: PRawByteStringGroupValue; -begin - d := length(aDest); - SetLength(aDest,d+Position); - v := pointer(Values); - for i := 1 to Count do begin - MoveFast(pointer(v^.Value)^,PByteArray(aDest)[d+v^.Position],length(v^.Value)); - inc(v); - end; - Clear; -end; - -function TRawByteStringGroup.AsText: RawByteString; -begin - if Values=nil then - result := '' else begin - if Count>1 then - Compact; - result := Values[0].Value; - end; -end; - -procedure TRawByteStringGroup.Compact; -var i: integer; - v: PRawByteStringGroupValue; - tmp: RawByteString; -begin - if (Values<>nil) and (Count>1) then begin - SetString(tmp,nil,Position); - v := pointer(Values); - for i := 1 to Count do begin - MoveFast(pointer(v^.Value)^,PByteArray(tmp)[v^.Position],length(v^.Value)); - {$ifdef FPC}Finalize(v^.Value){$else}v^.Value := ''{$endif}; // free chunks - inc(v); - end; - Values[0].Value := tmp; // use result for absolute compaction ;) - if Count>128 then - SetLength(Values,128); - Count := 1; - LastFind := 0; - end; -end; - -function TRawByteStringGroup.AsBytes: TByteDynArray; -var i: integer; -begin - result := nil; - if Values=nil then - exit; - SetLength(result,Position); - for i := 0 to Count-1 do - with Values[i] do - MoveFast(pointer(Value)^,PByteArray(result)[Position],length(Value)); -end; - -procedure TRawByteStringGroup.Write(W: TTextWriter; Escape: TTextWriterKind); -var i: integer; -begin - if Values<>nil then - for i := 0 to Count-1 do - with Values[i] do - W.Add(PUTF8Char(pointer(Value)),length(Value),Escape); -end; - -procedure TRawByteStringGroup.WriteBinary(W: TFileBufferWriter); -var i: integer; -begin - if Values<>nil then - for i := 0 to Count-1 do - W.WriteBinary(Values[i].Value); -end; - -procedure TRawByteStringGroup.WriteString(W: TFileBufferWriter); -begin - if Values=nil then begin - W.Write1(0); - exit; - end; - W.WriteVarUInt32(Position); - WriteBinary(W); -end; - -procedure TRawByteStringGroup.AddFromReader(var aReader: TFastReader); -var complexsize: integer; -begin - complexsize := aReader.VarUInt32; - if complexsize>0 then // directly create a RawByteString from aReader buffer - Add(aReader.Next(complexsize),complexsize); -end; - -function TRawByteStringGroup.Find(aPosition: integer): PRawByteStringGroupValue; -var i: integer; -begin - if (pointer(Values)<>nil) and (cardinal(aPosition)=result^.Position) and (aPositionaPosition then begin - dec(result); - LastFind := i; - exit; - end else - inc(result); - dec(result); - LastFind := Count-1; - end - else - result := nil; -end; - -function TRawByteStringGroup.Find(aPosition, aLength: integer): pointer; -var P: PRawByteStringGroupValue; - i: integer; -label found; -begin - if (pointer(Values)<>nil) and (cardinal(aPosition)=0) and (i+aLengthaPosition then begin - LastFind := i; -found: dec(P); - dec(aPosition,P^.Position); - if aLength-aPosition<=length(P^.Value) then - result := @PByteArray(P^.Value)[aPosition] else - result := nil; - exit; - end else - inc(P); - LastFind := Count-1; - goto found; - end - else - result := nil; -end; - -procedure TRawByteStringGroup.FindAsText(aPosition, aLength: integer; out aText: RawByteString); -var P: PRawByteStringGroupValue; -begin - P := Find(aPosition); - if P=nil then - exit; - dec(aPosition,P^.Position); - if (aPosition=0) and (length(P^.Value)=aLength) then - aText := P^.Value else // direct return if not yet compacted - if aLength-aPosition<=length(P^.Value) then - SetString(aText,PAnsiChar(@PByteArray(P^.Value)[aPosition]),aLength); -end; - -function TRawByteStringGroup.FindAsText(aPosition, aLength: integer): RawByteString; -begin - FindAsText(aPosition,aLength,result); -end; - -{$ifndef NOVARIANTS} -procedure TRawByteStringGroup.FindAsVariant(aPosition, aLength: integer; out aDest: variant); -var tmp: RawByteString; -begin - tmp := FindAsText(aPosition,aLength); - if tmp <> '' then - RawUTF8ToVariant(tmp,aDest); -end; -{$endif NOVARIANTS} - -procedure TRawByteStringGroup.FindWrite(aPosition, aLength: integer; - W: TTextWriter; Escape: TTextWriterKind; TrailingCharsToIgnore: integer); -var P: pointer; -begin - P := Find(aPosition,aLength); - if P<>nil then - W.Add(PUTF8Char(P)+TrailingCharsToIgnore,aLength-TrailingCharsToIgnore,Escape); -end; - -procedure TRawByteStringGroup.FindWriteBase64(aPosition, aLength: integer; - W: TTextWriter; withMagic: boolean); -var P: pointer; -begin - P := Find(aPosition,aLength); - if P<>nil then - W.WrBase64(P,aLength,withMagic); -end; - -procedure TRawByteStringGroup.FindMove(aPosition, aLength: integer; aDest: pointer); -var P: pointer; -begin - P := Find(aPosition,aLength); - if P<>nil then - MoveFast(P^,aDest^,aLength); -end; - - -{ TPropNameList } - -procedure TPropNameList.Init; -begin - Count := 0; -end; - -function TPropNameList.FindPropName(const Value: RawUTF8): Integer; -begin - result := SynCommons.FindPropName(Pointer(Values),Value,Count); -end; - -function TPropNameList.AddPropName(const Value: RawUTF8): Boolean; -begin - if (Value<>'') and (SynCommons.FindPropName(pointer(Values),Value,Count)<0) then begin - if Count=length(Values) then - SetLength(Values,NextGrow(Count)); - Values[Count] := Value; - inc(Count); - result := true; - end else - result := false; -end; - - -{ ************ Security and Identifiers classes ************************** } - -{ TSynUniqueIdentifierBits } - -function TSynUniqueIdentifierBits.Counter: word; -begin - result := PWord(@Value)^ and $7fff; -end; - -function TSynUniqueIdentifierBits.ProcessID: TSynUniqueIdentifierProcess; -begin - result := (PCardinal(@Value)^ shr 15) and $ffff; -end; - -function TSynUniqueIdentifierBits.CreateTimeUnix: TUnixTime; -begin - result := Value shr 31; -end; - -{$ifndef NOVARIANTS} -function TSynUniqueIdentifierBits.AsVariant: variant; -begin - ToVariant(result); -end; - -procedure TSynUniqueIdentifierBits.ToVariant(out result: variant); -begin - TDocVariantData(result).InitObject(['Created',DateTimeToIso8601Text(CreateDateTime), - 'Identifier',ProcessID,'Counter',Counter,'Value',Value, - 'Hex',Int64ToHex(Value)],JSON_OPTIONS_FAST); -end; -{$endif NOVARIANTS} - -{$ifndef DELPHI5OROLDER} -function TSynUniqueIdentifierBits.Equal(const Another: TSynUniqueIdentifierBits): boolean; -begin - result := Value=Another.Value; -end; -{$endif} - -procedure TSynUniqueIdentifierBits.From(const AID: TSynUniqueIdentifier); -begin - Value := AID; -end; - -function TSynUniqueIdentifierBits.CreateTimeLog: TTimeLog; -begin - PTimeLogBits(@result)^.From(UnixTimeToDateTime(Value shr 31)); -end; - -function TSynUniqueIdentifierBits.CreateDateTime: TDateTime; -begin - result := UnixTimeToDateTime(Value shr 31); -end; - -function TSynUniqueIdentifierBits.ToHexa: RawUTF8; -begin - Int64ToHex(Value,result); -end; - -function TSynUniqueIdentifierBits.FromHexa(const hexa: RawUTF8): boolean; -begin - result := (Length(hexa)=16) and HexDisplayToBin(pointer(hexa),@Value,SizeOf(Value)); -end; - -procedure TSynUniqueIdentifierBits.FromDateTime(const aDateTime: TDateTime); -begin - Value := DateTimeToUnixTime(aDateTime) shl 31; -end; - -procedure TSynUniqueIdentifierBits.FromUnixTime(const aUnixTime: TUnixTime); -begin - Value := aUnixTime shl 31; -end; - - -{ TSynUniqueIdentifierGenerator } - -const // fSafe.Padding[] slots - SYNUNIQUEGEN_COMPUTECOUNT = 0; - -procedure TSynUniqueIdentifierGenerator.ComputeNew( - out result: TSynUniqueIdentifierBits); -var currentTime: cardinal; -begin - currentTime := UnixTimeUTC; // under Windows faster than GetTickCount64 - fSafe.Lock; - try - if currentTime>fUnixCreateTime then begin - fUnixCreateTime := currentTime; - fLastCounter := 0; // reset - end; - if fLastCounter=$7fff then begin // collision (unlikely) -> cheat on timestamp - inc(fUnixCreateTime); - fLastCounter := 0; - end else - inc(fLastCounter); - result.Value := Int64(fLastCounter or fIdentifierShifted) or - (Int64(fUnixCreateTime) shl 31); - inc(fSafe.Padding[SYNUNIQUEGEN_COMPUTECOUNT].VInt64); - finally - fSafe.UnLock; - end; -end; - -function TSynUniqueIdentifierGenerator.ComputeNew: Int64; -begin - ComputeNew(PSynUniqueIdentifierBits(@result)^); -end; - -function TSynUniqueIdentifierGenerator.GetComputedCount: Int64; -begin - {$ifdef NOVARIANTS} - fSafe.Lock; - result := fSafe.Padding[SYNUNIQUEGEN_COMPUTECOUNT].VInt64; - fSafe.Unlock; - {$else} - result := fSafe.LockedInt64[SYNUNIQUEGEN_COMPUTECOUNT]; - {$endif} -end; - -procedure TSynUniqueIdentifierGenerator.ComputeFromDateTime(const aDateTime: TDateTime; - out result: TSynUniqueIdentifierBits); -begin // assume fLastCounter=0 - ComputeFromUnixTime(DateTimeToUnixTime(aDateTime),result); -end; - -procedure TSynUniqueIdentifierGenerator.ComputeFromUnixTime(const aUnixTime: TUnixTime; - out result: TSynUniqueIdentifierBits); -begin // assume fLastCounter=0 - result.Value := aUnixTime shl 31; - if self<>nil then - result.Value := result.Value or fIdentifierShifted; -end; - -constructor TSynUniqueIdentifierGenerator.Create(aIdentifier: TSynUniqueIdentifierProcess; - const aSharedObfuscationKey: RawUTF8); -var i, len: integer; - crc: cardinal; -begin - fIdentifier := aIdentifier; - fIdentifierShifted := aIdentifier shl 15; - fSafe.Init; - fSafe.Padding[SYNUNIQUEGEN_COMPUTECOUNT].VType := varInt64; // reset to 0 - // compute obfuscation key using hash diffusion of the supplied text - len := length(aSharedObfuscationKey); - crc := crc32ctab[0,len and 1023]; - for i := 0 to high(fCrypto)+1 do begin - crc := crc32ctab[0,crc and 1023] xor crc32ctab[3,i] xor - kr32(crc,pointer(aSharedObfuscationKey),len) xor - crc32c(crc,pointer(aSharedObfuscationKey),len) xor - fnv32(crc,pointer(aSharedObfuscationKey),len); - // do not modify those hashes above or you will break obfuscation pattern! - if i<=high(fCrypto) then - fCrypto[i] := crc else - fCryptoCRC := crc; - end; - // due to the weakness of the hash algorithms used, this approach is a bit - // naive and would be broken easily with brute force - but point here is to - // hide/obfuscate public values at end-user level (e.g. when publishing URIs), - // not implement strong security, so it sounds good enough for our purpose -end; - -destructor TSynUniqueIdentifierGenerator.Destroy; -begin - fSafe.Done; - FillCharFast(fCrypto,SizeOf(fCrypto),0); - fCryptoCRC := 0; - inherited Destroy; -end; - -type // compute a 24 hexadecimal chars (96 bits) obfuscated pseudo file name - TSynUniqueIdentifierObfuscatedBits = packed record - crc: cardinal; - id: TSynUniqueIdentifierBits; - end; - -function TSynUniqueIdentifierGenerator.ToObfuscated( - const aIdentifier: TSynUniqueIdentifier): TSynUniqueIdentifierObfuscated; -var bits: TSynUniqueIdentifierObfuscatedBits; - key: cardinal; -begin - result := ''; - if aIdentifier=0 then - exit; - bits.id.Value := aIdentifier; - if self=nil then - key := 0 else - key := crc32ctab[0,bits.id.ProcessID and 1023] xor fCryptoCRC; - bits.crc := crc32c(bits.id.ProcessID,@bits.id,SizeOf(bits.id)) xor key; - if self<>nil then - bits.id.Value := bits.id.Value xor PInt64(@fCrypto[high(fCrypto)-1])^; - result := BinToHex(@bits,SizeOf(bits)); -end; - -function TSynUniqueIdentifierGenerator.FromObfuscated( - const aObfuscated: TSynUniqueIdentifierObfuscated; - out aIdentifier: TSynUniqueIdentifier): boolean; -var bits: TSynUniqueIdentifierObfuscatedBits; - len: integer; - key: cardinal; -begin - result := false; - len := PosExChar('.',aObfuscated); - if len=0 then - len := Length(aObfuscated) else - dec(len); // trim right '.jpg' - if (len<>SizeOf(bits)*2) or - not SynCommons.HexToBin(pointer(aObfuscated),@bits,SizeOf(bits)) then - exit; - if self=nil then - key := 0 else begin - bits.id.Value := bits.id.Value xor PInt64(@fCrypto[high(fCrypto)-1])^; - key := crc32ctab[0,bits.id.ProcessID and 1023] xor fCryptoCRC; - end; - if crc32c(bits.id.ProcessID,@bits.id,SizeOf(bits.id)) xor key=bits.crc then begin - aIdentifier := bits.id.Value; - result := true; - end; -end; - - -{ TSynPersistentWithPassword } - -destructor TSynPersistentWithPassword.Destroy; -begin - UniqueRawUTF8(fPassword); - FillZero(fPassword); - inherited Destroy; -end; - -class function TSynPersistentWithPassword.ComputePassword(const PlainPassword: RawUTF8; - CustomKey: cardinal): RawUTF8; -var instance: TSynPersistentWithPassword; -begin - instance := TSynPersistentWithPassword.Create; - try - instance.Key := CustomKey; - instance.SetPassWordPlain(PlainPassword); - result := instance.fPassWord; - finally - instance.Free; - end; -end; - -class function TSynPersistentWithPassword.ComputePassword(PlainPassword: pointer; - PlainPasswordLen: integer; CustomKey: cardinal): RawUTF8; -begin - result := ComputePassword(BinToBase64uri(PlainPassword,PlainPasswordLen)); -end; - -class function TSynPersistentWithPassword.ComputePlainPassword(const CypheredPassword: RawUTF8; - CustomKey: cardinal; const AppSecret: RawUTF8): RawUTF8; -var instance: TSynPersistentWithPassword; -begin - instance := TSynPersistentWithPassword.Create; - try - instance.Key := CustomKey; - instance.fPassWord := CypheredPassword; - result := instance.GetPassWordPlainInternal(AppSecret); - finally - instance.Free; - end; -end; - -function TSynPersistentWithPassword.GetPasswordFieldAddress: pointer; -begin - result := @fPassword; -end; - -function TSynPersistentWithPassword.GetKey: cardinal; -begin - if self=nil then - result := 0 else - result := fKey xor $A5abba5A; -end; - -function TSynPersistentWithPassword.GetPassWordPlain: RawUTF8; -begin - result := GetPassWordPlainInternal(''); -end; - -function TSynPersistentWithPassword.GetPassWordPlainInternal(AppSecret: RawUTF8): RawUTF8; -var value,pass: RawByteString; - usr: RawUTF8; - i,j: integer; -begin - result := ''; - if (self=nil) or (fPassWord='') then - exit; - if Assigned(TSynPersistentWithPasswordUserCrypt) then begin - if AppSecret='' then - ToText(ClassType,AppSecret); - usr := ExeVersion.User+':'; - i := PosEx(usr,fPassword); - if (i=1) or ((i>0) and (fPassword[i-1]=',')) then begin - inc(i,length(usr)); - j := PosEx(',',fPassword,i); - if j=0 then - j := length(fPassword)+1; - Base64ToBin(@fPassword[i],j-i,pass); - if pass<>'' then - result := TSynPersistentWithPasswordUserCrypt(pass,AppSecret,false); - end else begin - i := PosExChar(':',fPassword); - if i>0 then - raise ESynException.CreateUTF8('%.GetPassWordPlain unable to retrieve the '+ - 'stored value: current user is [%], but password in % was encoded for [%]', - [self,ExeVersion.User,AppSecret,copy(fPassword,1,i-1)]); - end; - end; - if result='' then begin - value := Base64ToBin(fPassWord); - SymmetricEncrypt(GetKey,value); - result := value; - end; -end; - -procedure TSynPersistentWithPassword.SetPassWordPlain(const value: RawUTF8); -var tmp: RawByteString; -begin - if self=nil then - exit; - if value='' then begin - fPassWord := ''; - exit; - end; - SetString(tmp,PAnsiChar(pointer(value)),Length(value)); // private copy - SymmetricEncrypt(GetKey,tmp); - fPassWord := BinToBase64(tmp); -end; - - -{ TSynConnectionDefinition } - -constructor TSynConnectionDefinition.CreateFromJSON(const JSON: RawUTF8; - Key: cardinal); -var privateCopy: RawUTF8; - values: array[0..4] of TValuePUTF8Char; -begin - fKey := Key; - privateCopy := JSON; - JSONDecode(privateCopy,['Kind','ServerName','DatabaseName','User','Password'],@values); - fKind := values[0].ToString; - values[1].ToUTF8(fServerName); - values[2].ToUTF8(fDatabaseName); - values[3].ToUTF8(fUser); - values[4].ToUTF8(fPassWord); -end; - -function TSynConnectionDefinition.SaveToJSON: RawUTF8; -begin - result := JSONEncode(['Kind',fKind,'ServerName',fServerName, - 'DatabaseName',fDatabaseName,'User',fUser,'Password',fPassword]); -end; - - -{ TSynAuthenticationAbstract } - -constructor TSynAuthenticationAbstract.Create; -begin - fSafe.Init; - fTokenSeed := Random32gsl; - fSessionGenerator := abs(fTokenSeed*PPtrInt(self)^); - fTokenSeed := abs(fTokenSeed*Random32gsl); -end; - -destructor TSynAuthenticationAbstract.Destroy; -begin - fSafe.Done; - inherited; -end; - -class function TSynAuthenticationAbstract.ComputeHash(Token: Int64; - const UserName,PassWord: RawUTF8): cardinal; -begin // rough authentication - xxHash32 is less reversible than crc32c - result := xxHash32(xxHash32(xxHash32(Token,@Token,SizeOf(Token)), - pointer(UserName),length(UserName)),pointer(Password),length(PassWord)); -end; - -function TSynAuthenticationAbstract.ComputeCredential(previous: boolean; - const UserName,PassWord: RawUTF8): cardinal; -var tok: Int64; -begin - tok := GetTickCount64 div 10000; - if previous then - dec(tok); - result := ComputeHash(tok xor fTokenSeed,UserName,PassWord); -end; - -function TSynAuthenticationAbstract.CurrentToken: Int64; -begin - result := (GetTickCount64 div 10000) xor fTokenSeed; -end; - -procedure TSynAuthenticationAbstract.AuthenticateUser(const aName, aPassword: RawUTF8); -begin - raise ESynException.CreateUTF8('%.AuthenticateUser() is not implemented',[self]); -end; - -procedure TSynAuthenticationAbstract.DisauthenticateUser(const aName: RawUTF8); -begin - raise ESynException.CreateUTF8('%.DisauthenticateUser() is not implemented',[self]); -end; - -function TSynAuthenticationAbstract.CheckCredentials(const UserName: RaWUTF8; - Hash: cardinal): boolean; -var password: RawUTF8; -begin - result := GetPassword(UserName,password) and - ((ComputeCredential(false,UserName,password)=Hash) or - (ComputeCredential(true,UserName,password)=Hash)); -end; - -function TSynAuthenticationAbstract.CreateSession(const User: RawUTF8; - Hash: cardinal): integer; -begin - result := 0; - fSafe.Lock; - try - if not CheckCredentials(User,Hash) then - exit; - repeat - result := fSessionGenerator; - inc(fSessionGenerator); - until result<>0; - AddSortedInteger(fSessions,fSessionsCount,result); - finally - fSafe.UnLock; - end; -end; - -function TSynAuthenticationAbstract.SessionExists(aID: integer): boolean; -begin - fSafe.Lock; - try - result := FastFindIntegerSorted(pointer(fSessions),fSessionsCount-1,aID)>=0; - finally - fSafe.UnLock; - end; -end; - -procedure TSynAuthenticationAbstract.RemoveSession(aID: integer); -var i: integer; -begin - fSafe.Lock; - try - i := FastFindIntegerSorted(pointer(fSessions),fSessionsCount-1,aID); - if i>=0 then - DeleteInteger(fSessions,fSessionsCount,i); - finally - fSafe.UnLock; - end; -end; - - -{ TSynAuthentication } - -constructor TSynAuthentication.Create(const aUserName,aPassword: RawUTF8); -begin - inherited Create; - fCredentials.Init(true); - if aUserName<>'' then - AuthenticateUser(aUserName,aPassword); -end; - -function TSynAuthentication.GetPassword(const UserName: RawUTF8; - out Password: RawUTF8): boolean; -var i: integer; -begin // caller did protect this method via fSafe.Lock - i := fCredentials.Find(UserName); - if i<0 then begin - result := false; - exit; - end; - password := fCredentials.List[i].Value; - result := true; -end; - -function TSynAuthentication.GetUsersCount: integer; -begin - fSafe.Lock; - try - result := fCredentials.Count; - finally - fSafe.UnLock; - end; -end; - -procedure TSynAuthentication.AuthenticateUser(const aName, aPassword: RawUTF8); -begin - fSafe.Lock; - try - fCredentials.Add(aName,aPassword); - finally - fSafe.UnLock; - end; -end; - -procedure TSynAuthentication.DisauthenticateUser(const aName: RawUTF8); -begin - fSafe.Lock; - try - fCredentials.Delete(aName); - finally - fSafe.UnLock; - end; -end; - - -{ TIPBan } - -procedure TIPBan.LoadFromReader; -begin - inherited; - fReader.ReadVarUInt32Array(fIP4); - fCount := length(fIP4); -end; - -procedure TIPBan.SaveToWriter(aWriter: TFileBufferWriter); -begin // wkSorted not efficient: too big diffs between IPs - aWriter.WriteVarUInt32Array(fIP4, fCount, wkUInt32); -end; - -function TIPBan.Add(const aIP: RawUTF8): boolean; -var ip4: cardinal; -begin - result := false; - if (self=nil) or not IPToCardinal(aIP,ip4) then - exit; - fSafe.Lock; - try - AddSortedInteger(fIP4,fCount,ip4); - result := true; - finally - fSafe.UnLock; - end; -end; - -function TIPBan.Delete(const aIP: RawUTF8): boolean; -var ip4: cardinal; - i: integer; -begin - result := false; - if (self=nil) or not IPToCardinal(aIP,ip4) then - exit; - fSafe.Lock; - try - i := FastFindIntegerSorted(pointer(fIP4),fCount-1,ip4); - if i<0 then - exit; - DeleteInteger(fIP4,fCount,i); - result := true; - finally - fSafe.UnLock; - end; -end; - -function TIPBan.Exists(const aIP: RawUTF8): boolean; -var ip4: cardinal; -begin - result := false; - if (self=nil) or (fCount=0) or not IPToCardinal(aIP,ip4) then - exit; - fSafe.Lock; - try - if FastFindIntegerSorted(pointer(fIP4),fCount-1,ip4)>=0 then - result := true; - finally - fSafe.UnLock; - end; -end; - -function TIPBan.DynArrayLocked: TDynArray; -begin - fSafe.Lock; - result.InitSpecific(TypeInfo(TCardinalDynArray),fIP4,djCardinal,@fCount); -end; - - -{ ************ Database types and classes ************************** } - -{$ifdef FPC}{$push}{$endif} -{$WARNINGS OFF} // yes, we know there will be dead code below: we rely on it ;) - -function IsZero(const Fields: TSQLFieldBits): boolean; -var f: TPtrIntArray absolute Fields; -begin - {$ifdef CPU64} - if MAX_SQLFIELDS=64 then - result := (f[0]=0) else - if MAX_SQLFields=128 then - result := (f[0]=0) and (f[1]=0) else - if MAX_SQLFields=192 then - result := (f[0]=0) and (f[1]=0) and (f[2]=0) else - if MAX_SQLFields=256 then - result := (f[0]=0) and (f[1]=0) and (f[2]=0) and (f[3]=0) else - {$else} - if MAX_SQLFIELDS=64 then - result := (f[0]=0) and (f[1]=0) else - if MAX_SQLFields=128 then - result := (f[0]=0) and (f[1]=0) and (f[2]=0) and (f[3]=0) else - if MAX_SQLFields=192 then - result := (f[0]=0) and (f[1]=0) and (f[2]=0) and (f[3]=0) - and (f[4]=0) and (f[5]=0) else - if MAX_SQLFields=256 then - result := (f[0]=0) and (f[1]=0) and (f[2]=0) and (f[3]=0) - and (f[4]=0) and (f[5]=0) and (f[6]=0) and (f[7]=0) else - {$endif} - result := IsZero(@Fields,SizeOf(Fields)) -end; - -function IsEqual(const A,B: TSQLFieldBits): boolean; -var a_: TPtrIntArray absolute A; - b_: TPtrIntArray absolute B; -begin - {$ifdef CPU64} - if MAX_SQLFIELDS=64 then - result := (a_[0]=b_[0]) else - if MAX_SQLFields=128 then - result := (a_[0]=b_[0]) and (a_[1]=b_[1]) else - if MAX_SQLFields=192 then - result := (a_[0]=b_[0]) and (a_[1]=b_[1]) and (a_[2]=b_[2]) else - if MAX_SQLFields=256 then - result := (a_[0]=b_[0]) and (a_[1]=b_[1]) and (a_[2]=b_[2]) and (a_[3]=b_[3]) else - {$else} - if MAX_SQLFIELDS=64 then - result := (a_[0]=b_[0]) and (a_[1]=b_[1]) else - if MAX_SQLFields=128 then - result := (a_[0]=b_[0]) and (a_[1]=b_[1]) and (a_[2]=b_[2]) and (a_[3]=b_[3]) else - if MAX_SQLFields=192 then - result := (a_[0]=b_[0]) and (a_[1]=b_[1]) and (a_[2]=b_[2]) and (a_[3]=b_[3]) - and (a_[4]=b_[4]) and (a_[5]=b_[5]) else - if MAX_SQLFields=256 then - result := (a_[0]=b_[0]) and (a_[1]=b_[1]) and (a_[2]=b_[2]) and (a_[3]=b_[3]) - and (a_[4]=b_[4]) and (a_[5]=b_[5]) and (a_[6]=b_[6]) and (a_[7]=b_[7]) else - {$endif} - result := CompareMemFixed(@A,@B,SizeOf(TSQLFieldBits)) -end; - -procedure FillZero(var Fields: TSQLFieldBits); -begin - if MAX_SQLFIELDS=64 then - PInt64(@Fields)^ := 0 else - if MAX_SQLFields=128 then begin - PInt64Array(@Fields)^[0] := 0; - PInt64Array(@Fields)^[1] := 0; - end else - if MAX_SQLFields=192 then begin - PInt64Array(@Fields)^[0] := 0; - PInt64Array(@Fields)^[1] := 0; - PInt64Array(@Fields)^[2] := 0; - end else - if MAX_SQLFields=256 then begin - PInt64Array(@Fields)^[0] := 0; - PInt64Array(@Fields)^[1] := 0; - PInt64Array(@Fields)^[2] := 0; - PInt64Array(@Fields)^[3] := 0; - end else - FillCharFast(Fields,SizeOf(Fields),0); -end; - -{$ifdef FPC}{$pop}{$else}{$WARNINGS ON}{$endif} - -procedure FieldBitsToIndex(const Fields: TSQLFieldBits; var Index: TSQLFieldIndexDynArray; - MaxLength,IndexStart: integer); -var i,n: integer; - sets: array[0..MAX_SQLFIELDS-1] of TSQLFieldIndex; // to avoid memory reallocation -begin - n := 0; - for i := 0 to MaxLength-1 do - if i in Fields then begin - sets[n] := i; - inc(n); - end; - SetLength(Index,IndexStart+n); - for i := 0 to n-1 do - Index[IndexStart+i] := sets[i]; -end; - -function FieldBitsToIndex(const Fields: TSQLFieldBits; - MaxLength: integer): TSQLFieldIndexDynArray; -begin - FieldBitsToIndex(Fields,result,MaxLength); -end; - -function AddFieldIndex(var Indexes: TSQLFieldIndexDynArray; Field: integer): integer; -begin - result := length(Indexes); - SetLength(Indexes,result+1); - Indexes[result] := Field; -end; - -function SearchFieldIndex(var Indexes: TSQLFieldIndexDynArray; Field: integer): integer; -begin - for result := 0 to length(Indexes)-1 do - if Indexes[result]=Field then - exit; - result := -1; -end; - -procedure FieldIndexToBits(const Index: TSQLFieldIndexDynArray; var Fields: TSQLFieldBits); -var i: integer; -begin - FillCharFast(Fields,SizeOf(Fields),0); - for i := 0 to Length(Index)-1 do - if Index[i]>=0 then - include(Fields,Index[i]); -end; - -function FieldIndexToBits(const Index: TSQLFieldIndexDynArray): TSQLFieldBits; -begin - FieldIndexToBits(Index,result); -end; - -function DateToSQL(Date: TDateTime): RawUTF8; -begin - result := ''; - if Date<=0 then - exit; - FastSetString(result,nil,13); - PCardinal(pointer(result))^ := JSON_SQLDATE_MAGIC; - DateToIso8601PChar(Date,PUTF8Char(pointer(result))+3,True); -end; - -function DateToSQL(Year,Month,Day: Cardinal): RawUTF8; -begin - result := ''; - if (Year=0) or (Month-1>11) or (Day-1>30) then - exit; - FastSetString(result,nil,13); - PCardinal(pointer(result))^ := JSON_SQLDATE_MAGIC; - DateToIso8601PChar(PUTF8Char(pointer(result))+3,True,Year,Month,Day); -end; - -var - JSON_SQLDATE_MAGIC_TEXT: RawUTF8; - -function DateTimeToSQL(DT: TDateTime; WithMS: boolean): RawUTF8; -begin - if DT<=0 then - result := '' else begin - if frac(DT)=0 then - result := JSON_SQLDATE_MAGIC_TEXT+DateToIso8601(DT,true) else - if trunc(DT)=0 then - result := JSON_SQLDATE_MAGIC_TEXT+TimeToIso8601(DT,true,'T',WithMS) else - result := JSON_SQLDATE_MAGIC_TEXT+DateTimeToIso8601(DT,true,'T',WithMS); - end; -end; - -function TimeLogToSQL(const Timestamp: TTimeLog): RawUTF8; -begin - if Timestamp=0 then - result := '' else - result := JSON_SQLDATE_MAGIC_TEXT+PTimeLogBits(@Timestamp)^.Text(true); -end; - -function Iso8601ToSQL(const S: RawByteString): RawUTF8; -begin - if IsIso8601(pointer(S),length(S)) then - result := JSON_SQLDATE_MAGIC_TEXT+S else - result := ''; -end; - -function SQLToDateTime(const ParamValueWithMagic: RawUTF8): TDateTime; -begin - result := Iso8601ToDateTimePUTF8Char(PUTF8Char(pointer(ParamValueWithMagic))+3, - length(ParamValueWithMagic)-3); -end; - -const - NULL_LOW = ord('n')+ord('u')shl 8+ord('l')shl 16+ord('l')shl 24; - -function SQLParamContent(P: PUTF8Char; out ParamType: TSQLParamType; out ParamValue: RawUTF8; - out wasNull: boolean): PUTF8Char; -var PBeg: PAnsiChar; - L: integer; - c: cardinal; -begin - ParamType := sptUnknown; - wasNull := false; - result := nil; - if P=nil then - exit; - while (P^<=' ') and (P^<>#0) do inc(P); - case P^ of - '''','"': begin - P := UnQuoteSQLStringVar(P,ParamValue); - if P=nil then - exit; // not a valid quoted string (e.g. unexpected end in middle of it) - ParamType := sptText; - L := length(ParamValue)-3; - if L>0 then begin - c := PInteger(ParamValue)^ and $00ffffff; - if c=JSON_BASE64_MAGIC then begin - // ':("\uFFF0base64encodedbinary"):' format -> decode - Base64MagicDecode(ParamValue); // wrapper function to avoid temp. string - ParamType := sptBlob; - end else - if (c=JSON_SQLDATE_MAGIC) and // handle ':("\uFFF112012-05-04"):' format - IsIso8601(PUTF8Char(pointer(ParamValue))+3,L) then begin - Delete(ParamValue,1,3); // return only ISO-8601 text - ParamType := sptDateTime; // identified as Date/Time - end; - end; - end; - '-','+','0'..'9': begin // allow 0 or + in SQL - // check if P^ is a true numerical value - PBeg := pointer(P); - ParamType := sptInteger; - repeat inc(P) until not (P^ in ['0'..'9']); // check digits - if P^='.' then begin - inc(P); - if P^ in ['0'..'9'] then begin - ParamType := sptFloat; - repeat inc(P) until not (P^ in ['0'..'9']); // check fractional digits - end else begin - ParamType := sptUnknown; // invalid '23023.' value - exit; - end; - end; - if byte(P^) and $DF=ord('E') then begin - ParamType := sptFloat; - inc(P); - if P^='+' then inc(P) else - if P^='-' then inc(P); - while P^ in ['0'..'9'] do inc(P); - end; - FastSetString(ParamValue,PBeg,P-PBeg); - end; - 'n': - if PInteger(P)^=NULL_LOW then begin - inc(P,4); - wasNull := true; - end else - exit; // invalid content (only :(null): expected) - else - exit; // invalid content - end; - while (P^<=' ') and (P^<>#0) do inc(P); - if PWord(P)^<>Ord(')')+Ord(':')shl 8 then - // we expect finishing with P^ pointing at '):' - ParamType := sptUnknown else - // result<>nil only if value content in P^ - result := P+2; -end; - -function ExtractInlineParameters(const SQL: RawUTF8; - var Types: TSQLParamTypeDynArray; var Values: TRawUTF8DynArray; - var maxParam: integer; var Nulls: TSQLFieldBits): RawUTF8; -var ppBeg: integer; - P, Gen: PUTF8Char; - wasNull: boolean; -begin - maxParam := 0; - FillCharFast(Nulls,SizeOf(Nulls),0); - ppBeg := PosEx(RawUTF8(':('),SQL,1); - if (ppBeg=0) or (PosEx(RawUTF8('):'),SQL,ppBeg+2)=0) then begin - // SQL code with no valid :(...): internal parameters -> leave maxParam=0 - result := SQL; - exit; - end; - // compute GenericSQL from SQL, converting :(...): into ? - FastSetString(result,pointer(SQL),length(SQL)); // private copy for unescape - P := pointer(result); // in-place string unescape (keep SQL untouched) - Gen := P+ppBeg-1; // Gen^ just before :( - inc(P,ppBeg+1); // P^ just after :( - repeat - Gen^ := '?'; // replace :(...): by ? - inc(Gen); - if length(Values)<=maxParam then - SetLength(Values,maxParam+16); - if length(Types)<=maxParam then - SetLength(Types,maxParam+64); - P := SQLParamContent(P,Types[maxParam],Values[maxParam],wasNull); - if P=nil then begin - maxParam := 0; - result := SQL; - exit; // any invalid parameter -> try direct SQL - end; - if wasNull then - include(Nulls,maxParam); - while (P^<>#0) and (PWord(P)^<>Ord(':')+Ord('(')shl 8) do begin - Gen^ := P^; - inc(Gen); - inc(P); - end; - if P^=#0 then - Break; - inc(P,2); - inc(maxParam); - until false; - // return generic SQL statement, with ? place-holders and params in Values[] - SetLength(result,Gen-pointer(result)); - inc(maxParam); -end; - -function InlineParameter(ID: Int64): shortstring; -begin - FormatShort(':(%):',[ID],result); -end; - -function InlineParameter(const value: RawUTF8): RawUTF8; -begin - QuotedStrJSON(value,result,':(','):'); -end; - -function SQLVarLength(const Value: TSQLVar): integer; -begin - case Value.VType of - ftBlob: - result := Value.VBlobLen; - ftUTF8: - result := StrLen(Value.VText); // fast enough for our purpose - else - result := 0; // simple/ordinal values, or ftNull - end; -end; - -{$ifndef NOVARIANTS} - -procedure VariantToSQLVar(const Input: variant; var temp: RawByteString; - var Output: TSQLVar); -var wasString: boolean; -begin - Output.Options := []; - with TVarData(Input) do - if VType=varVariant or varByRef then - VariantToSQLVar(PVariant(VPointer)^,temp,Output) else - case VType of - varEmpty, varNull: - Output.VType := ftNull; - varByte: begin - Output.VType := ftInt64; - Output.VInt64 := VByte; - end; - varInteger: begin - Output.VType := ftInt64; - Output.VInt64 := VInteger; - end; - {$ifndef DELPHI5OROLDER} - varLongWord: begin - Output.VType := ftInt64; - Output.VInt64 := VLongWord; - end; - {$endif} - varWord64, varInt64: begin - Output.VType := ftInt64; - Output.VInt64 := VInt64; - end; - varSingle: begin - Output.VType := ftDouble; - Output.VDouble := VSingle; - end; - varDouble: begin // varDate would be converted into ISO8601 by VariantToUTF8() - Output.VType := ftDouble; - Output.VDouble := VDouble; - end; - varCurrency: begin - Output.VType := ftCurrency; - Output.VInt64 := VInt64; - end; - varString: begin // assume RawUTF8 - Output.VType := ftUTF8; - Output.VText := VPointer; - end; - else // handle less current cases - if VariantToInt64(Input,Output.VInt64) then - Output.VType := ftInt64 else begin - VariantToUTF8(Input,RawUTF8(temp),wasString); - if wasString then begin - Output.VType := ftUTF8; - Output.VText := pointer(temp); - end else - Output.VType := ftNull; - end; - end; -end; - -function VariantVTypeToSQLDBFieldType(VType: cardinal): TSQLDBFieldType; -begin - case VType of - varNull: - result := ftNull; - {$ifndef DELPHI5OROLDER}varShortInt, varWord, varLongWord,{$endif} - varSmallInt, varByte, varBoolean, varInteger, varInt64, varWord64: - result := ftInt64; - varSingle,varDouble: - result := ftDouble; - varDate: - result := ftDate; - varCurrency: - result := ftCurrency; - varString: - result := ftUTF8; - else - result := ftUnknown; // includes varEmpty - end; -end; - -function VariantTypeToSQLDBFieldType(const V: Variant): TSQLDBFieldType; -var VD: TVarData absolute V; - tmp: TVarData; -begin - result := VariantVTypeToSQLDBFieldType(VD.VType); - case result of - ftUnknown: - if VD.VType=varEmpty then - result := ftUnknown else - if SetVariantUnRefSimpleValue(V,tmp) then - result := VariantTypeToSQLDBFieldType(variant(tmp)) else - result := ftUTF8; - ftUTF8: - if (VD.VString<>nil) and (PCardinal(VD.VString)^ and $ffffff=JSON_BASE64_MAGIC) then - result := ftBlob; - end; -end; - -function TextToSQLDBFieldType(json: PUTF8Char): TSQLDBFieldType; -begin - if json=nil then - result := ftNull else - result := VariantVTypeToSQLDBFieldType(TextToVariantNumberType(json)); -end; - -function NullableInteger(const Value: Int64): TNullableInteger; -begin - PVariant(@result)^ := Value; -end; - -function NullableIntegerIsEmptyOrNull(const V: TNullableInteger): Boolean; -begin - result := VarDataIsEmptyOrNull(@V); -end; - -function NullableIntegerToValue(const V: TNullableInteger; out Value: Int64): Boolean; -begin - Value := 0; - result := not VarDataIsEmptyOrNull(@V) and VariantToInt64(PVariant(@V)^,Value); -end; - -function NullableIntegerToValue(const V: TNullableInteger): Int64; -begin - VariantToInt64(PVariant(@V)^,result); -end; - -function NullableBoolean(Value: boolean): TNullableBoolean; -begin - PVariant(@result)^ := Value; -end; - -function NullableBooleanIsEmptyOrNull(const V: TNullableBoolean): Boolean; -begin - result := VarDataIsEmptyOrNull(@V); -end; - -function NullableBooleanToValue(const V: TNullableBoolean; out Value: Boolean): Boolean; -begin - Value := false; - result := not VarDataIsEmptyOrNull(@V) and VariantToBoolean(PVariant(@V)^,Value); -end; - -function NullableBooleanToValue(const V: TNullableBoolean): Boolean; -begin - VariantToBoolean(PVariant(@V)^,result); -end; - - -function NullableFloat(const Value: double): TNullableFloat; -begin - PVariant(@result)^ := Value; -end; - -function NullableFloatIsEmptyOrNull(const V: TNullableFloat): Boolean; -begin - result := VarDataIsEmptyOrNull(@V); -end; - -function NullableFloatToValue(const V: TNullableFloat; out Value: Double): Boolean; -begin - Value := 0; - result := not VarDataIsEmptyOrNull(@V) and VariantToDouble(PVariant(@V)^,Value); -end; - -function NullableFloatToValue(const V: TNullableFloat): Double; -begin - VariantToDouble(PVariant(@V)^,result); -end; - - -function NullableCurrency(const Value: currency): TNullableCurrency; -begin - PVariant(@result)^ := Value; -end; - -function NullableCurrencyIsEmptyOrNull(const V: TNullableCurrency): Boolean; -begin - result := VarDataIsEmptyOrNull(@V); -end; - -function NullableCurrencyToValue(const V: TNullableCurrency; out Value: currency): Boolean; -begin - Value := 0; - result := not VarDataIsEmptyOrNull(@V) and VariantToCurrency(PVariant(@V)^,Value); -end; - -function NullableCurrencyToValue(const V: TNullableCurrency): currency; -begin - VariantToCurrency(PVariant(@V)^,result); -end; - - -function NullableDateTime(const Value: TDateTime): TNullableDateTime; -begin - PVariant(@result)^ := Value; -end; - -function NullableDateTimeIsEmptyOrNull(const V: TNullableDateTime): Boolean; -begin - result := VarDataIsEmptyOrNull(@V); -end; - -function NullableDateTimeToValue(const V: TNullableDateTime; out Value: TDateTime): Boolean; -begin - Value := 0; - result := not VarDataIsEmptyOrNull(@V) and VariantToDouble(PVariant(@V)^,Double(Value)); -end; - -function NullableDateTimeToValue(const V: TNullableDateTime): TDateTime; -begin - VariantToDouble(PVariant(@V)^,Double(result)); -end; - - -function NullableTimeLog(const Value: TTimeLog): TNullableTimeLog; -begin - PVariant(@result)^ := Value; -end; - -function NullableTimeLogIsEmptyOrNull(const V: TNullableTimeLog): Boolean; -begin - result := VarDataIsEmptyOrNull(@V); -end; - -function NullableTimeLogToValue(const V: TNullableTimeLog; out Value: TTimeLog): Boolean; -begin - Value := 0; - result := not VarDataIsEmptyOrNull(@V) and VariantToInt64(PVariant(@V)^,PInt64(@Value)^); -end; - -function NullableTimeLogToValue(const V: TNullableTimeLog): TTimeLog; -begin - VariantToInt64(PVariant(@V)^,PInt64(@result)^); -end; - - -function NullableUTF8Text(const Value: RawUTF8): TNullableUTF8Text; -begin - VarClear(PVariant(@result)^); - TVarData(result).VType := varString; - TVarData(result).VAny := nil; // avoid GPF below - RawUTF8(TVarData(result).VAny) := Value; -end; - -function NullableUTF8TextIsEmptyOrNull(const V: TNullableUTF8Text): Boolean; -begin - result := VarDataIsEmptyOrNull(@V); -end; - -function NullableUTF8TextToValue(const V: TNullableUTF8Text; out Value: RawUTF8): boolean; -begin - result := not VarDataIsEmptyOrNull(@V) and VariantToUTF8(PVariant(@V)^,Value); -end; - -function NullableUTF8TextToValue(const V: TNullableUTF8Text): RawUTF8; -var dummy: boolean; -begin - if VarDataIsEmptyOrNull(@V) then // VariantToUTF8() will return 'null' - result := '' else - VariantToUTF8(PVariant(@V)^,result,dummy); -end; - - -{$endif NOVARIANTS} - -{ TJSONWriter } - -procedure TJSONWriter.CancelAllVoid; -const VOIDARRAY: PAnsiChar = '[]'#10; - VOIDFIELD: PAnsiChar = '{"FieldCount":0}'; -begin - CancelAll; // rewind JSON - if fExpand then // same as sqlite3_get_table() - inc(fTotalFileSize,fStream.Write(VOIDARRAY^,3)) else - inc(fTotalFileSize,fStream.Write(VOIDFIELD^,16)); -end; - -constructor TJSONWriter.Create(aStream: TStream; Expand, withID: boolean; - const Fields: TSQLFieldBits; aBufSize: integer); -begin - Create(aStream,Expand,withID,FieldBitsToIndex(Fields),aBufSize); -end; - -constructor TJSONWriter.Create(aStream: TStream; Expand, withID: boolean; - const Fields: TSQLFieldIndexDynArray; aBufSize: integer; - aStackBuffer: PTextWriterStackBuffer); -begin - if aStream=nil then - if aStackBuffer<>nil then - CreateOwnedStream(aStackBuffer^) else - CreateOwnedStream(aBufSize) else - if aStackBuffer<>nil then - inherited Create(aStream,aStackBuffer,SizeOf(aStackBuffer^)) else - inherited Create(aStream,aBufSize); - fExpand := Expand; - fWithID := withID; - fFields := Fields; -end; - -procedure TJSONWriter.AddColumns(aKnownRowsCount: integer); -var i: integer; -begin - if fExpand then begin - if twoForceJSONExtended in CustomOptions then - for i := 0 to High(ColNames) do - ColNames[i] := ColNames[i]+':' else - for i := 0 to High(ColNames) do - ColNames[i] := '"'+ColNames[i]+'":'; - end else begin - AddShort('{"fieldCount":'); - Add(length(ColNames)); - if aKnownRowsCount>0 then begin - AddShort(',"rowCount":'); - Add(aKnownRowsCount); - end; - AddShort(',"values":["'); - // first row is FieldNames - for i := 0 to High(ColNames) do begin - AddString(ColNames[i]); - AddNoJSONEscape(PAnsiChar('","'),3); - end; - CancelLastChar('"'); - fStartDataPosition := fStream.Position+(B-fTempBuf); - // B := buf-1 at startup -> need ',val11' position in - // "values":["col1","col2",val11,' i.e. current pos without the ',' - end; -end; - -procedure TJSONWriter.ChangeExpandedFields(aWithID: boolean; - const aFields: TSQLFieldIndexDynArray); -begin - if not Expand then - raise ESynException.CreateUTF8( - '%.ChangeExpandedFields() called with Expanded=false',[self]); - fWithID := aWithID; - fFields := aFields; -end; - -procedure TJSONWriter.EndJSONObject(aKnownRowsCount,aRowsCount: integer; - aFlushFinal: boolean); -begin - CancelLastComma; // cancel last ',' - Add(']'); - if not fExpand then begin - if aKnownRowsCount=0 then begin - AddShort(',"rowCount":'); - Add(aRowsCount); - end; - Add('}'); - end; - Add(#10); - if aFlushFinal then - FlushFinal; -end; - -procedure TJSONWriter.TrimFirstRow; -var P, PBegin, PEnd: PUTF8Char; -begin - if (self=nil) or not fStream.InheritsFrom(TMemoryStream) or - fExpand or (fStartDataPosition=0) then - exit; - // go to begin of first row - FlushToStream; // we need the data to be in fStream memory - // PBegin^=val11 in { "fieldCount":1,"values":["col1","col2",val11,"val12",val21,..] } - PBegin := TMemoryStream(fStream).Memory; - PEnd := PBegin+fStream.Position; - PEnd^ := #0; // mark end of current values - inc(PBegin,fStartDataPosition+1); // +1 to include ',' of ',val11' - // jump to end of first row - P := GotoNextJSONItem(PBegin,length(ColNames)); - if P=nil then exit; // unexpected end - // trim first row data - if P^<>#0 then - MoveFast(P^,PBegin^,PEnd-P); // erase content - fStream.Seek(PBegin-P,soCurrent); // adjust current stream position -end; - - -{ ************ Expression Search Engine ************************** } - -function ToText(r: TExprParserResult): PShortString; -begin - result := GetEnumName(TypeInfo(TExprParserResult), ord(r)); -end; - -function ToUTF8(r: TExprParserResult): RawUTF8; -begin - result := UnCamelCase(TrimLeftLowerCaseShort(ToText(r))); -end; - - -{ TExprNode } - -function TExprNode.Append(node: TExprNode): boolean; -begin - result := node <> nil; - if result then - Last.fNext := node; -end; - -constructor TExprNode.Create(nodeType: TExprNodeType); -begin - inherited Create; - fNodeType := nodeType; -end; - -destructor TExprNode.Destroy; -begin - fNext.Free; - inherited Destroy; -end; - -function TExprNode.Last: TExprNode; -begin - result := self; - while result.Next <> nil do - result := result.Next; -end; - - -{ TParserAbstract } - -constructor TParserAbstract.Create; -begin - inherited Create; - Initialize; -end; - -destructor TParserAbstract.Destroy; -begin - Clear; - inherited Destroy; -end; - -procedure TParserAbstract.Clear; -begin - fWordCount := 0; - fWords := nil; - fExpression := ''; - FreeAndNil(fFirstNode); -end; - -function TParserAbstract.ParseExpr: TExprNode; -begin - result := ParseFactor; - ParseNextCurrentWord; - if (fCurrentWord = '') or (fCurrentWord = ')') then - exit; - if IdemPropNameU(fCurrentWord, fAndWord) then begin // w1 & w2 = w1 AND w2 - ParseNextCurrentWord; - if result.Append(ParseExpr) then - result.Append(TExprNode.Create(entAnd)); - exit; - end - else if IdemPropNameU(fCurrentWord, fOrWord) then begin // w1 + w2 = w1 OR w2 - ParseNextCurrentWord; - if result.Append(ParseExpr) then - result.Append(TExprNode.Create(entOr)); - exit; - end - else if fNoWordIsAnd and result.Append(ParseExpr) then // 'w1 w2' = 'w1 & w2' - result.Append(TExprNode.Create(entAnd)); -end; - -function TParserAbstract.ParseFactor: TExprNode; -begin - if fCurrentError <> eprSuccess then - result := nil - else if IdemPropNameU(fCurrentWord, fNotWord) then begin - ParseNextCurrentWord; - result := ParseFactor; - if fCurrentError <> eprSuccess then - exit; - result.Append(TExprNode.Create(entNot)); - end - else - result := ParseTerm; -end; - -function TParserAbstract.ParseTerm: TExprNode; -begin - result := nil; - if fCurrentError <> eprSuccess then - exit; - if fCurrentWord = '(' then begin - ParseNextCurrentWord; - result := ParseExpr; - if fCurrentError <> eprSuccess then - exit; - if fCurrentWord <> ')' then begin - FreeAndNil(result); - fCurrentError := eprMissingParenthesis; - end; - end - else if fCurrentWord = '' then begin - result := nil; - fCurrentError := eprMissingFinalWord; - end - else - try // calls meta-class overriden constructor - result := fWordClass.Create(self, fCurrentWord); - fCurrentError := TExprNodeWordAbstract(result).ParseWord; - if fCurrentError <> eprSuccess then begin - FreeAndNil(result); - exit; - end; - SetLength(fWords, fWordCount + 1); - fWords[fWordCount] := TExprNodeWordAbstract(result); - inc(fWordCount); - except - FreeAndNil(result); - fCurrentError := eprInvalidExpression; - end; -end; - -function TParserAbstract.Parse(const aExpression: RawUTF8): TExprParserResult; -var - depth: integer; - n: TExprNode; -begin - Clear; - fCurrentError := eprSuccess; - fCurrent := pointer(aExpression); - ParseNextCurrentWord; - if fCurrentWord = '' then begin - result := eprNoExpression; - exit; - end; - fFirstNode := ParseExpr; - result := fCurrentError; - if result = eprSuccess then begin - depth := 0; - n := fFirstNode; - while n <> nil do begin - case n.NodeType of - entWord: begin - inc(depth); - if depth > high(fFoundStack) then begin - result := eprTooManyParenthesis; - break; - end; - end; - entOr, entAnd: - dec(depth); - end; - n := n.Next; - end; - end; - if result = eprSuccess then - fExpression := aExpression - else - Clear; - fCurrent := nil; -end; - -class function TParserAbstract.ParseError(const aExpression: RawUTF8): RawUTF8; -var - parser: TParserAbstract; - res: TExprParserResult; -begin - parser := Create; - try - res := parser.Parse(aExpression); - if res = eprSuccess then - result := '' - else - result := ToUTF8(res); - finally - parser.Free; - end; -end; - -function TParserAbstract.Execute: boolean; -var - n: TExprNode; - st: PBoolean; -begin // code below compiles very efficiently on FPC/x86-64 - st := @fFoundStack; - n := fFirstNode; - repeat - case n.NodeType of - entWord: begin - st^ := TExprNodeWordAbstract(n).fFound; - inc(st); // see eprTooManyParenthesis above to avoid buffer overflow - end; - entNot: - PAnsiChar(st)[-1] := AnsiChar(ord(PAnsiChar(st)[-1]) xor 1); - entOr: begin - dec(st); - PAnsiChar(st)[-1] := AnsiChar(st^ or boolean(PAnsiChar(st)[-1])); - end; { TODO : optimize TExprParser OR when left member is already TRUE } - entAnd: begin - dec(st); - PAnsiChar(st)[-1] := AnsiChar(st^ and boolean(PAnsiChar(st)[-1])); - end; - end; - n := n.Next; - until n = nil; - result := boolean(PAnsiChar(st)[-1]); -end; - - -{ TExprParserAbstract } - -procedure TExprParserAbstract.Initialize; -begin - fAndWord := '&'; - fOrWord := '+'; - fNotWord := '-'; - fNoWordIsAnd := true; -end; - -procedure TExprParserAbstract.ParseNextCurrentWord; -var - P: PUTF8Char; -begin - fCurrentWord := ''; - P := fCurrent; - if P = nil then - exit; - while P^ in [#1..' '] do - inc(P); - if P^ = #0 then - exit; - if P^ in PARSER_STOPCHAR then begin - FastSetString(fCurrentWord, P, 1); - fCurrent := P + 1; - end - else begin - fCurrent := P; - ParseNextWord; - end; -end; - -procedure TExprParserAbstract.ParseNextWord; -const - STOPCHAR = PARSER_STOPCHAR + [#0, ' ']; -var - P: PUTF8Char; -begin - P := fCurrent; - while not(P^ in STOPCHAR) do - inc(P); - FastSetString(fCurrentWord, fCurrent, P - fCurrent); - fCurrent := P; -end; - - -{ TExprNodeWordAbstract } - -constructor TExprNodeWordAbstract.Create(aOwner: TParserAbstract; const aWord: RawUTF8); -begin - inherited Create(entWord); - fWord := aWord; - fOwner := aOwner; -end; - - -{ TExprParserMatchNode } - -type - TExprParserMatchNode = class(TExprNodeWordAbstract) - protected - fMatch: TMatch; - function ParseWord: TExprParserResult; override; - end; - PExprParserMatchNode = ^TExprParserMatchNode; - -function TExprParserMatchNode.ParseWord: TExprParserResult; -begin - fMatch.Prepare(fWord, (fOwner as TExprParserMatch).fCaseSensitive, {reuse=}true); - result := eprSuccess; -end; - - -{ TExprParserMatch } - -constructor TExprParserMatch.Create(aCaseSensitive: boolean); -begin - inherited Create; - fCaseSensitive := aCaseSensitive; -end; - -procedure TExprParserMatch.Initialize; -begin - inherited Initialize; - fWordClass := TExprParserMatchNode; -end; - -function TExprParserMatch.Search(const aText: RawUTF8): boolean; -begin - result := Search(pointer(aText), length(aText)); -end; - -function TExprParserMatch.Search(aText: PUTF8Char; aTextLen: PtrInt): boolean; -const // rough estimation of UTF-8 characters - IS_UTF8_WORD = ['0' .. '9', 'A' .. 'Z', 'a' .. 'z', #$80 ..#$ff]; -var - P, PEnd: PUTF8Char; - n: PtrInt; -begin - P := aText; - if (P = nil) or (fWords = nil) then begin - result := false; - exit; - end; - if fMatchedLastSet > 0 then begin - n := fWordCount; - repeat - dec(n); - fWords[n].fFound := false; - until n = 0; - fMatchedLastSet := 0; - end; - PEnd := P + aTextLen; - while (P < PEnd) and (fMatchedLastSet < fWordCount) do begin - while not(P^ in IS_UTF8_WORD) do begin - inc(P); - if P = PEnd then - break; - end; - if P = PEnd then - break; - aText := P; - repeat - inc(P); - until (P = PEnd) or not(P^ in IS_UTF8_WORD); - aTextLen := P - aText; // now aText/aTextLen point to a word - n := fWordCount; - repeat - dec(n); - with TExprParserMatchNode(fWords[n]) do - if not fFound and fMatch.Match(aText, aTextLen) then begin - fFound := true; - inc(fMatchedLastSet); - end; - until n = 0; - end; - result := Execute; -end; - -{ ************ Multi-Threading classes ************************** } - -{ TPendingTaskList } - -constructor TPendingTaskList.Create; -begin - inherited Create; - fTasks.InitSpecific(TypeInfo(TPendingTaskListItemDynArray),fTask,djInt64,@fCount); -end; - -function TPendingTaskList.GetTimestamp: Int64; -begin - result := {$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64; -end; - -procedure TPendingTaskList.AddTask(aMilliSecondsDelayFromNow: integer; - const aTask: RawByteString); -var item: TPendingTaskListItem; - ndx: integer; -begin - item.Timestamp := GetTimestamp+aMilliSecondsDelayFromNow; - item.Task := aTask; - fSafe.Lock; - try - if fTasks.FastLocateSorted(item,ndx) then - inc(ndx); // always insert just after any existing timestamp - fTasks.FastAddSorted(ndx,item); - finally - fSafe.UnLock; - end; -end; - -procedure TPendingTaskList.AddTasks( - const aMilliSecondsDelays: array of integer; - const aTasks: array of RawByteString); -var item: TPendingTaskListItem; - i,ndx: integer; -begin - if length(aTasks)<>length(aMilliSecondsDelays) then - exit; - item.Timestamp := GetTimestamp; - fSafe.Lock; - try - for i := 0 to High(aTasks) do begin - inc(item.Timestamp,aMilliSecondsDelays[i]); - item.Task := aTasks[i]; - if fTasks.FastLocateSorted(item,ndx) then - inc(ndx); // always insert just after any existing timestamp - fTasks.FastAddSorted(ndx,item); - end; - finally - fSafe.UnLock; - end; -end; - -function TPendingTaskList.GetCount: integer; -begin - if self=nil then - result := 0 else begin - fSafe.Lock; - try - result := fCount; - finally - fSafe.UnLock; - end; - end; -end; - -function TPendingTaskList.NextPendingTask: RawByteString; -begin - result := ''; - if (self=nil) or (fCount=0) then - exit; - fSafe.Lock; - try - if fCount>0 then - if GetTimestamp>=fTask[0].Timestamp then begin - result := fTask[0].Task; - fTasks.FastDeleteSorted(0); - end; - finally - fSafe.UnLock; - end; -end; - -procedure TPendingTaskList.Clear; -begin - if (self=nil) or (fCount=0) then - exit; - fSafe.Lock; - try - fTasks.Clear; - finally - fSafe.UnLock; - end; -end; - - -{$ifndef LVCL} // LVCL does not implement TEvent - -{ TSynBackgroundThreadAbstract } - -constructor TSynBackgroundThreadAbstract.Create(const aThreadName: RawUTF8; - OnBeforeExecute,OnAfterExecute: TNotifyThreadEvent; CreateSuspended: boolean); -begin - fProcessEvent := TEvent.Create(nil,false,false,''); - fThreadName := aThreadName; - fOnBeforeExecute := OnBeforeExecute; - fOnAfterExecute := OnAfterExecute; - inherited Create(CreateSuspended{$ifdef FPC},512*1024{$endif}); // DefaultStackSize=512KB -end; - -{$ifndef HASTTHREADSTART} -procedure TSynBackgroundThreadAbstract.Start; -begin - Resume; -end; -{$endif} - -{$ifndef HASTTHREADTERMINATESET} -procedure TSynBackgroundThreadAbstract.Terminate; -begin - inherited Terminate; // FTerminated := True - TerminatedSet; -end; -{$endif} - -procedure TSynBackgroundThreadAbstract.TerminatedSet; -begin - fProcessEvent.SetEvent; // ExecuteLoop should handle Terminated flag -end; - -procedure TSynBackgroundThreadAbstract.WaitForNotExecuting(maxMS: integer); -var endtix: Int64; -begin - if fExecute=exRun then begin - endtix := SynCommons.GetTickCount64+maxMS; - repeat - SleepHiRes(1); // wait for Execute to finish - until (fExecute<>exRun) or (SynCommons.GetTickCount64>=endtix); - end; -end; - -destructor TSynBackgroundThreadAbstract.Destroy; -begin - if fExecute=exRun then begin - Terminate; - WaitForNotExecuting(100); - end; - inherited Destroy; - FreeAndNil(fProcessEvent); -end; - -procedure TSynBackgroundThreadAbstract.SetExecuteLoopPause(dopause: boolean); -begin - if Terminated or (dopause=fExecuteLoopPause) or (fExecute=exFinished) then - exit; - fExecuteLoopPause := dopause; - fProcessEvent.SetEvent; // notify Execute main loop -end; - -procedure TSynBackgroundThreadAbstract.Execute; -begin - try - if fThreadName='' then - SetCurrentThreadName('%(%)',[self,pointer(self)]) else - SetCurrentThreadName('%',[fThreadName]); - if Assigned(fOnBeforeExecute) then - fOnBeforeExecute(self); - try - fExecute := exRun; - while not Terminated do - if fExecuteLoopPause then - FixedWaitFor(fProcessEvent,100) else - ExecuteLoop; - finally - if Assigned(fOnAfterExecute) then - fOnAfterExecute(self); - end; - finally - fExecute := exFinished; - end; -end; - -{ TSynBackgroundThreadMethodAbstract } - -constructor TSynBackgroundThreadMethodAbstract.Create(aOnIdle: TOnIdleSynBackgroundThread; - const aThreadName: RawUTF8; OnBeforeExecute,OnAfterExecute: TNotifyThreadEvent); -begin - fOnIdle := aOnIdle; // cross-platform may run Execute as soon as Create is called - fCallerEvent := TEvent.Create(nil,false,false,''); - fPendingProcessLock.Init; - inherited Create(aThreadName,OnBeforeExecute,OnAfterExecute); -end; - -destructor TSynBackgroundThreadMethodAbstract.Destroy; -begin - SetPendingProcess(flagDestroying); - fProcessEvent.SetEvent; // notify terminated - FixedWaitForever(fCallerEvent); // wait for actual termination - FreeAndNil(fCallerEvent); - inherited Destroy; - fPendingProcessLock.Done; -end; - -function TSynBackgroundThreadMethodAbstract.GetPendingProcess: TSynBackgroundThreadProcessStep; -begin - fPendingProcessLock.Lock; - result := fPendingProcessFlag; - fPendingProcessLock.UnLock; -end; - -procedure TSynBackgroundThreadMethodAbstract.SetPendingProcess(State: TSynBackgroundThreadProcessStep); -begin - fPendingProcessLock.Lock; - fPendingProcessFlag := State; - fPendingProcessLock.UnLock; -end; - -procedure TSynBackgroundThreadMethodAbstract.ExecuteLoop; -{$ifndef DELPHI5OROLDER} -var E: TObject; -{$endif} -begin - case FixedWaitFor(fProcessEvent,INFINITE) of - wrSignaled: - case GetPendingProcess of - flagDestroying: begin - fCallerEvent.SetEvent; // abort caller thread process - Terminate; // forces Execute loop ending - exit; - end; - flagStarted: - if not Terminated then - if fExecuteLoopPause then // pause -> try again later - fProcessEvent.SetEvent else - try - fBackgroundException := nil; - try - if Assigned(fOnBeforeProcess) then - fOnBeforeProcess(self); - try - Process; - finally - if Assigned(fOnAfterProcess) then - fOnAfterProcess(self); - end; - except - {$ifdef DELPHI5OROLDER} - on E: Exception do - fBackgroundException := ESynException.CreateUTF8( - 'Redirected % [%]',[E,E.Message]); - {$else} - E := AcquireExceptionObject; - if E.InheritsFrom(Exception) then - fBackgroundException := Exception(E); - {$endif} - end; - finally - SetPendingProcess(flagFinished); - fCallerEvent.SetEvent; - end; - end; - end; -end; - -function TSynBackgroundThreadMethodAbstract.AcquireThread: TSynBackgroundThreadProcessStep; -begin - fPendingProcessLock.Lock; - try - result := fPendingProcessFlag; - if result=flagIdle then begin // we just acquired the thread! congrats! - fPendingProcessFlag := flagStarted; // atomic set "started" flag - fCallerThreadID := ThreadID; - end; - finally - fPendingProcessLock.UnLock; - end; -end; - -function TSynBackgroundThreadMethodAbstract.OnIdleProcessNotify(start: Int64): integer; -begin - result := {$ifdef FPCLINUX}SynFPCLinux.{$else}SynCommons.{$endif}GetTickCount64-start; - if result<0 then - result := MaxInt; // should happen only under XP -> ignore - if Assigned(fOnIdle) then - fOnIdle(self,result) ; -end; - -procedure TSynBackgroundThreadMethodAbstract.WaitForFinished(start: Int64; - const onmainthreadidle: TNotifyEvent); -var E: Exception; -begin - if (self=nil) or not(fPendingProcessFlag in [flagStarted, flagFinished]) then - exit; // nothing to wait for - try - if Assigned(onmainthreadidle) then begin - while FixedWaitFor(fCallerEvent,100)=wrTimeout do - onmainthreadidle(self); - end else - {$ifdef MSWINDOWS} // do process the OnIdle only if UI - if Assigned(fOnIdle) then begin - while FixedWaitFor(fCallerEvent,100)=wrTimeout do - OnIdleProcessNotify(start); - end else - {$endif} - FixedWaitForever(fCallerEvent); - if fPendingProcessFlag<>flagFinished then - ESynException.CreateUTF8('%.WaitForFinished: flagFinished?',[self]); - if fBackgroundException<>nil then begin - E := fBackgroundException; - fBackgroundException := nil; - raise E; // raise background exception in the calling scope - end; - finally - fParam := nil; - fCallerThreadID := 0; - FreeAndNil(fBackgroundException); - SetPendingProcess(flagIdle); - if Assigned(fOnIdle) then - fOnIdle(self,-1); // notify finished - end; -end; - -function TSynBackgroundThreadMethodAbstract.RunAndWait(OpaqueParam: pointer): boolean; -var start: Int64; - ThreadID: TThreadID; -begin - result := false; - ThreadID := GetCurrentThreadId; - if (self=nil) or (ThreadID=fCallerThreadID) then - // avoid endless loop when waiting in same thread (e.g. UI + OnIdle) - exit; - // 1. wait for any previous request to be finished (should not happen often) - if Assigned(fOnIdle) then - fOnIdle(self,0); // notify started - start := {$ifdef FPCLINUX}SynFPCLinux.{$else}SynCommons.{$endif}GetTickCount64; - repeat - case AcquireThread of - flagDestroying: - exit; - flagIdle: - break; // we acquired the background thread - end; - case OnIdleProcessNotify(start) of // Windows.GetTickCount64 res is 10-16 ms - 0..20: SleepHiRes(0); // 10 microsec delay on POSIX - 21..100: SleepHiRes(1); - 101..900: SleepHiRes(5); - else SleepHiRes(50); - end; - until false; - // 2. process execution in the background thread - fParam := OpaqueParam; - fProcessEvent.SetEvent; // notify background thread for Call pending process - WaitForFinished(start,nil); // wait for flagFinished, then set flagIdle - result := true; -end; - -function TSynBackgroundThreadMethodAbstract.GetOnIdleBackgroundThreadActive: boolean; -begin - result := (self<>nil) and Assigned(fOnIdle) and (GetPendingProcess<>flagIdle); -end; - - -{ TSynBackgroundThreadEvent } - -constructor TSynBackgroundThreadEvent.Create(aOnProcess: TOnProcessSynBackgroundThread; - aOnIdle: TOnIdleSynBackgroundThread; const aThreadName: RawUTF8); -begin - inherited Create(aOnIdle,aThreadName); - fOnProcess := aOnProcess; -end; - -procedure TSynBackgroundThreadEvent.Process; -begin - if not Assigned(fOnProcess) then - raise ESynException.CreateUTF8('Invalid %.RunAndWait() call',[self]); - fOnProcess(self,fParam); -end; - - -{ TSynBackgroundThreadMethod } - -procedure TSynBackgroundThreadMethod.Process; -var Method: ^TThreadMethod; -begin - if fParam=nil then - raise ESynException.CreateUTF8('Invalid %.RunAndWait() call',[self]); - Method := fParam; - Method^(); -end; - -procedure TSynBackgroundThreadMethod.RunAndWait(Method: TThreadMethod); -var Met: TMethod absolute Method; -begin - inherited RunAndWait(@Met); -end; - - -{ TSynBackgroundThreadProcedure } - -constructor TSynBackgroundThreadProcedure.Create(aOnProcess: TOnProcessSynBackgroundThreadProc; - aOnIdle: TOnIdleSynBackgroundThread; const aThreadName: RawUTF8); -begin - inherited Create(aOnIdle,aThreadName); - fOnProcess := aOnProcess; -end; - -procedure TSynBackgroundThreadProcedure.Process; -begin - if not Assigned(fOnProcess) then - raise ESynException.CreateUTF8('Invalid %.RunAndWait() call',[self]); - fOnProcess(fParam); -end; - - -{ TSynParallelProcessThread } - -procedure TSynParallelProcessThread.Process; -begin - if not Assigned(fMethod) then - exit; - fMethod(fIndexStart,fIndexStop); - fMethod := nil; -end; - -procedure TSynParallelProcessThread.Start( - Method: TSynParallelProcessMethod; IndexStart, IndexStop: integer); -begin - fMethod := Method; - fIndexStart := IndexStart; - fIndexStop := IndexStop; - fProcessEvent.SetEvent; // notify execution -end; - - -{ TSynBackgroundThreadProcess } - -constructor TSynBackgroundThreadProcess.Create(const aThreadName: RawUTF8; - aOnProcess: TOnSynBackgroundThreadProcess; aOnProcessMS: cardinal; - aOnBeforeExecute, aOnAfterExecute: TNotifyThreadEvent; - aStats: TSynMonitorClass; CreateSuspended: boolean); -begin - if not Assigned(aOnProcess) then - raise ESynException.CreateUTF8('%.Create(aOnProcess=nil)',[self]); - if aStats<>nil then - fStats := aStats.Create(aThreadName); - fOnProcess := aOnProcess; - fOnProcessMS := aOnProcessMS; - if fOnProcessMS=0 then - fOnProcessMS := INFINITE; // wait until ProcessEvent.SetEvent or Terminated - inherited Create(aThreadName,aOnBeforeExecute,aOnAfterExecute,CreateSuspended); -end; - -destructor TSynBackgroundThreadProcess.Destroy; -begin - if fExecute=exRun then begin - Terminate; - WaitForNotExecuting(10000); // expect the background task to be finished - end; - inherited Destroy; - fStats.Free; -end; - -procedure TSynBackgroundThreadProcess.ExecuteLoop; -var wait: TWaitResult; -begin - wait := FixedWaitFor(fProcessEvent,fOnProcessMS); - if not Terminated and (wait in [wrSignaled,wrTimeout]) then - if fExecuteLoopPause then // pause -> try again later - fProcessEvent.SetEvent else - try - if fStats<>nil then - fStats.ProcessStartTask; - try - fOnProcess(self,wait); - finally - if fStats<>nil then - fStats.ProcessEnd; - end; - except - on E: Exception do begin - if fStats<>nil then - fStats.ProcessErrorRaised(E); - if Assigned(fOnException) then - fOnException(E); - end; - end; -end; - - -{ TSynBackgroundTimer } - -var - ProcessSystemUse: TSystemUse; - -constructor TSynBackgroundTimer.Create(const aThreadName: RawUTF8; - aOnBeforeExecute, aOnAfterExecute: TNotifyThreadEvent; aStats: TSynMonitorClass); -begin - fTasks.Init(TypeInfo(TSynBackgroundTimerTaskDynArray),fTask); - fTaskLock.Init; - {$ifndef NOVARIANTS} - fTaskLock.LockedBool[0] := false; - {$endif} - inherited Create(aThreadName,EverySecond,1000,aOnBeforeExecute,aOnAfterExecute,aStats); -end; - -destructor TSynBackgroundTimer.Destroy; -begin - if (ProcessSystemUse<>nil) and (ProcessSystemUse.fTimer=self) then - ProcessSystemUse.fTimer := nil; // allows processing by another background timer - inherited Destroy; - fTaskLock.Done; -end; - -const - TIXPRECISION = 32; // GetTickCount64 resolution (for aOnProcessSecs=1) - -procedure TSynBackgroundTimer.EverySecond( - Sender: TSynBackgroundThreadProcess; Event: TWaitResult); -var tix: Int64; - i,f,n: integer; - t: ^TSynBackgroundTimerTask; - todo: TSynBackgroundTimerTaskDynArray; // avoid lock contention -begin - if (fTask=nil) or Terminated then - exit; - tix := {$ifdef FPCLINUX}SynFPCLinux.{$else}SynCommons.{$endif}GetTickCount64; - n := 0; - fTaskLock.Lock; - try - variant(fTaskLock.Padding[0]) := true; // = fTaskLock.LockedBool[0] - try - for i := 0 to length(fTask)-1 do begin - t := @fTask[i]; - if tix>=t^.NextTix then begin - SetLength(todo,n+1); - todo[n] := t^; - inc(n); - t^.FIFO := nil; // now owned by todo[n].FIFO - t^.NextTix := tix+((t^.Secs*1000)-TIXPRECISION); - end; - end; - finally - fTaskLock.UnLock; - end; - for i := 0 to n-1 do - with todo[i] do - if FIFO<>nil then - for f := 0 to length(FIFO)-1 do - try - OnProcess(self,Event,FIFO[f]); - except - end - else - try - OnProcess(self,Event,''); - except - end; - finally - {$ifdef NOVARIANTS} - fTaskLock.Lock; - variant(fTaskLock.Padding[0]) := false; - fTaskLock.UnLock; - {$else} - fTaskLock.LockedBool[0] := false; - {$endif} - end; -end; - -function TSynBackgroundTimer.Find(const aProcess: TMethod): integer; -begin // caller should have made fTaskLock.Lock; - for result := length(fTask)-1 downto 0 do - with TMethod(fTask[result].OnProcess) do - if (Code=aProcess.Code) and (Data=aProcess.Data) then - exit; - result := -1; -end; - -procedure TSynBackgroundTimer.Enable( - aOnProcess: TOnSynBackgroundTimerProcess; aOnProcessSecs: cardinal); -var task: TSynBackgroundTimerTask; - found: integer; -begin - if (self=nil) or Terminated or not Assigned(aOnProcess) then - exit; - if aOnProcessSecs=0 then begin - Disable(aOnProcess); - exit; - end; - task.OnProcess := aOnProcess; - task.Secs := aOnProcessSecs; - task.NextTix := {$ifdef FPCLINUX}SynFPCLinux.{$else}SynCommons.{$endif}GetTickCount64+ - (aOnProcessSecs*1000-TIXPRECISION); - fTaskLock.Lock; - try - found := Find(TMethod(aOnProcess)); - if found>=0 then - fTask[found] := task else - fTasks.Add(task); - finally - fTaskLock.UnLock; - end; -end; - -function TSynBackgroundTimer.Processing: boolean; -begin - {$ifdef NOVARIANTS} - with fTaskLock.Padding[0] do - result := (VType=varBoolean) and VBoolean; - {$else} - result := fTaskLock.LockedBool[0]; - {$endif} -end; - -procedure TSynBackgroundTimer.WaitUntilNotProcessing(timeoutsecs: integer); -var timeout: Int64; -begin - if not Processing then - exit; - timeout := {$ifdef FPCLINUX}SynFPCLinux.{$else}SynCommons.{$endif}GetTickCount64+timeoutsecs*1000; - repeat - SleepHiRes(1); - until not Processing or - ({$ifdef FPCLINUX}SynFPCLinux.{$else}SynCommons.{$endif}GetTickcount64>timeout); -end; - -function TSynBackgroundTimer.ExecuteNow(aOnProcess: TOnSynBackgroundTimerProcess): boolean; -begin - result := Add(aOnProcess,#0,true); -end; - -function TSynBackgroundTimer.EnQueue(aOnProcess: TOnSynBackgroundTimerProcess; - const aMsg: RawUTF8; aExecuteNow: boolean): boolean; -begin - result := Add(aOnProcess,aMsg,aExecuteNow); -end; - -function TSynBackgroundTimer.EnQueue(aOnProcess: TOnSynBackgroundTimerProcess; - const aMsgFmt: RawUTF8; const Args: array of const; aExecuteNow: boolean): boolean; -var msg: RawUTF8; -begin - FormatUTF8(aMsgFmt,Args,msg); - result := Add(aOnProcess,msg,aExecuteNow); -end; - -function TSynBackgroundTimer.Add(aOnProcess: TOnSynBackgroundTimerProcess; - const aMsg: RawUTF8; aExecuteNow: boolean): boolean; -var found: integer; -begin - result := false; - if (self=nil) or Terminated or not Assigned(aOnProcess) then - exit; - fTaskLock.Lock; - try - found := Find(TMethod(aOnProcess)); - if found>=0 then begin - with fTask[found] do begin - if aExecuteNow then - NextTix := 0; - if aMsg<>#0 then - AddRawUTF8(FIFO,aMsg); - end; - if aExecuteNow then - ProcessEvent.SetEvent; - result := true; - end; - finally - fTaskLock.UnLock; - end; -end; - -function TSynBackgroundTimer.DeQueue(aOnProcess: TOnSynBackgroundTimerProcess; - const aMsg: RawUTF8): boolean; -var found: integer; -begin - result := false; - if (self=nil) or Terminated or not Assigned(aOnProcess) then - exit; - fTaskLock.Lock; - try - found := Find(TMethod(aOnProcess)); - if found>=0 then - with fTask[found] do - result := DeleteRawUTF8(FIFO,FindRawUTF8(FIFO,aMsg)); - finally - fTaskLock.UnLock; - end; -end; - -function TSynBackgroundTimer.Disable(aOnProcess: TOnSynBackgroundTimerProcess): boolean; -var found: integer; -begin - result := false; - if (self=nil) or Terminated or not Assigned(aOnProcess) then - exit; - fTaskLock.Lock; - try - found := Find(TMethod(aOnProcess)); - if found>=0 then begin - fTasks.Delete(found); - result := true; - end; - finally - fTaskLock.UnLock; - end; -end; - -{ TSynParallelProcess } - -constructor TSynParallelProcess.Create(ThreadPoolCount: integer; const ThreadName: RawUTF8; - OnBeforeExecute, OnAfterExecute: TNotifyThreadEvent; - MaxThreadPoolCount: integer); -var i: integer; -begin - inherited Create; - if ThreadPoolCount<0 then - raise ESynParallelProcess.CreateUTF8('%.Create(%,%)',[Self,ThreadPoolCount,ThreadName]); - if ThreadPoolCount>MaxThreadPoolCount then - ThreadPoolCount := MaxThreadPoolCount; - fThreadPoolCount := ThreadPoolCount; - fThreadName := ThreadName; - SetLength(fPool,fThreadPoolCount); - for i := 0 to fThreadPoolCount-1 do - fPool[i] := TSynParallelProcessThread.Create(nil,FormatUTF8('%#%/%', - [fThreadName,i+1,fThreadPoolCount]),OnBeforeExecute,OnAfterExecute); -end; - -destructor TSynParallelProcess.Destroy; -begin - ObjArrayClear(fPool); - inherited; -end; - -procedure TSynParallelProcess.ParallelRunAndWait(const Method: TSynParallelProcessMethod; - MethodCount: integer; const OnMainThreadIdle: TNotifyEvent); -var use,t,n,perthread: integer; - error: RawUTF8; -begin - if (MethodCount<=0) or not Assigned(Method) then - exit; - if not Assigned(OnMainThreadIdle) then - if (self=nil) or (MethodCount=1) or (fThreadPoolCount=0) then begin - Method(0,MethodCount-1); // no need (or impossible) to use background thread - exit; - end; - use := MethodCount; - t := fThreadPoolCount; - if not Assigned(OnMainThreadIdle) then - inc(t); // include current thread - if use>t then - use := t; - try - // start secondary threads - perthread := MethodCount div use; - if perthread=0 then - use := 1; - n := 0; - for t := 0 to use-2 do begin - repeat - case fPool[t].AcquireThread of - flagDestroying: // should not happen - raise ESynParallelProcess.CreateUTF8( - '%.ParallelRunAndWait [%] destroying',[self,fPool[t].fThreadName]); - flagIdle: - break; // acquired (should always be the case) - end; - SleepHiRes(1); - if Assigned(OnMainThreadIdle) then - OnMainThreadIdle(self); - until false; - fPool[t].Start(Method,n,n+perthread-1); - inc(n,perthread); - inc(fParallelRunCount); - end; - // run remaining items in the current/last thread - if n'' then - raise ESynParallelProcess.CreateUTF8('%.ParallelRunAndWait: %',[self,error]); - end; -end; - - -{ TBlockingProcess } - -constructor TBlockingProcess.Create(aTimeOutMs: integer; aSafe: PSynLocker); -begin - inherited Create(nil,false,false,''); - if aTimeOutMs<=0 then - fTimeOutMs := 3000 else // never wait for ever - fTimeOutMs := aTimeOutMs; - fSafe := aSafe; -end; - -constructor TBlockingProcess.Create(aTimeOutMs: integer); -begin - fOwnedSafe := true; - Create(aTimeOutMS,NewSynLocker); -end; - -destructor TBlockingProcess.Destroy; -begin - inherited Destroy; - if fOwnedSafe then - fSafe^.DoneAndFreeMem; -end; - -function TBlockingProcess.WaitFor: TBlockingEvent; -begin - fSafe^.Lock; - try - result := fEvent; - if fEvent in [evRaised,evTimeOut] then - exit; - fEvent := evWaiting; - finally - fSafe^.UnLock; - end; - FixedWaitFor(self,fTimeOutMs); - fSafe^.Lock; - try - if fEvent<>evRaised then - fEvent := evTimeOut; - result := fEvent; - finally - fSafe^.UnLock; - end; -end; - -function TBlockingProcess.WaitFor(TimeOutMS: integer): TBlockingEvent; -begin - if TimeOutMS <= 0 then - fTimeOutMs := 3000 // never wait for ever - else - fTimeOutMs := TimeOutMS; - result := WaitFor; -end; - -function TBlockingProcess.NotifyFinished(alreadyLocked: boolean): boolean; -begin - result := false; - if not alreadyLocked then - fSafe^.Lock; - try - if fEvent in [evRaised,evTimeOut] then - exit; // ignore if already notified - fEvent := evRaised; - SetEvent; // notify caller to unlock "WaitFor" method - result := true; - finally - fSafe^.UnLock; - end; -end; - -procedure TBlockingProcess.ResetInternal; -begin - ResetEvent; - fEvent := evNone; -end; - -function TBlockingProcess.Reset: boolean; -begin - fSafe^.Lock; - try - result := fEvent<>evWaiting; - if result then - ResetInternal; - finally - fSafe^.UnLock; - end; -end; - -procedure TBlockingProcess.Lock; -begin - fSafe^.Lock; -end; - -procedure TBlockingProcess.Unlock; -begin - fSafe^.Unlock; -end; - - -{ TBlockingProcessPoolItem } - -procedure TBlockingProcessPoolItem.ResetInternal; -begin - inherited ResetInternal; // set fEvent := evNone - fCall := 0; -end; - - -{ TBlockingProcessPool } - -constructor TBlockingProcessPool.Create(aClass: TBlockingProcessPoolItemClass); -begin - inherited Create; - if aClass=nil then - fClass := TBlockingProcessPoolItem else - fClass := aClass; - fPool := TSynObjectListLocked.Create; -end; - -const - CALL_DESTROYING = -1; - -destructor TBlockingProcessPool.Destroy; -var i: integer; - someWaiting: boolean; -begin - fCallCounter := CALL_DESTROYING; - someWaiting := false; - for i := 0 to fPool.Count-1 do - with TBlockingProcessPoolItem(fPool.List[i]) do - if Event=evWaiting then begin - SetEvent; // release WaitFor (with evTimeOut) - someWaiting := true; - end; - if someWaiting then - SleepHiRes(10); // propagate the pending evTimeOut to the WaitFor threads - fPool.Free; - inherited; -end; - -function TBlockingProcessPool.NewProcess(aTimeOutMs: integer): TBlockingProcessPoolItem; -var i: integer; - p: ^TBlockingProcessPoolItem; -begin - result := nil; - if fCallCounter=CALL_DESTROYING then - exit; - if aTimeOutMs<=0 then - aTimeOutMs := 3000; // never wait for ever - fPool.Safe.Lock; - try - p := pointer(fPool.List); - for i := 1 to fPool.Count do - if p^.Call=0 then begin - result := p^; // found a non-used entry - result.fTimeOutMs := aTimeOutMS; - break; - end else - inc(p); - if result=nil then begin - result := fClass.Create(aTimeOutMS); - fPool.Add(result); - end; - inc(fCallCounter); // 1,2,3,... - result.fCall := fCallCounter; - finally - fPool.Safe.UnLock; - end; -end; - -function TBlockingProcessPool.FromCall(call: TBlockingProcessPoolCall; - locked: boolean): TBlockingProcessPoolItem; -var i: integer; - p: ^TBlockingProcessPoolItem; -begin - result := nil; - if (fCallCounter=CALL_DESTROYING) or (call<=0) then - exit; - fPool.Safe.Lock; - try - p := pointer(fPool.List); - for i := 1 to fPool.Count do - if p^.Call=call then begin - result := p^; - if locked then - result.Lock; - exit; - end else - inc(p); - finally - fPool.Safe.UnLock; - end; -end; - -{$ifdef KYLIX3} -type - // see http://stackoverflow.com/a/3085509 about this known Kylix bug - TEventHack = class(THandleObject) // should match EXACTLY SyncObjs.pas source! - private - FEvent: TSemaphore; - FManualReset: Boolean; - end; - -function FixedWaitFor(Event: TEvent; Timeout: LongWord): TWaitResult; -var E: TEventHack absolute Event; - procedure SetResult(res: integer); - begin - if res=0 then - result := wrSignaled else - if errno in [EAGAIN,ETIMEDOUT] then - result := wrTimeOut else begin - write(TimeOut,':',errno,' '); - result := wrError; - end; - end; -{.$define USESEMTRYWAIT} -// sem_timedwait() is slower than sem_trywait(), but consuming much less CPU -{$ifdef USESEMTRYWAIT} -var time: timespec; -{$else} -var start,current: Int64; - elapsed: LongWord; -{$endif} -begin - if Timeout=INFINITE then begin - SetResult(sem_wait(E.FEvent)); - exit; - end; - if TimeOut=0 then begin - SetResult(sem_trywait(E.FEvent)); - exit; - end; - {$ifdef USESEMTRYWAIT} - clock_gettime(CLOCK_REALTIME,time); - inc(time.tv_sec,TimeOut div 1000); - inc(time.tv_nsec,(TimeOut mod 1000)*1000000); - while time.tv_nsec>1000000000 do begin - inc(time.tv_sec); - dec(time.tv_nsec,1000000000); - end; - SetResult(sem_timedwait(E.FEvent,time)); - {$else} - start := GetTickCount64; - repeat - if sem_trywait(E.FEvent)=0 then begin - result := wrSignaled; - break; - end; - current := GetTickCount64; - elapsed := current-start; - if elapsed=0 then - usleep(1) else - if elapsed>TimeOut then begin - result := wrTimeOut; - break; - end else - if elapsed<5 then - usleep(50) else - usleep(1000); - until false; - {$endif} - if E.FManualReset then begin - repeat until sem_trywait(E.FEvent)<>0; // reset semaphore state - sem_post(E.FEvent); - end; -end; - -{$else KYLIX3} // original FPC or Windows implementation is OK - -function FixedWaitFor(Event: TEvent; Timeout: LongWord): TWaitResult; -begin - result := Event.WaitFor(TimeOut); -end; - -{$endif KYLIX3} - -procedure FixedWaitForever(Event: TEvent); -begin - FixedWaitFor(Event,INFINITE); -end; - -{$endif LVCL} // LVCL does not implement TEvent - - -{ ************ System Analysis types and classes ************************** } - - -function SystemInfoJson: RawUTF8; -var cpu,mem: RawUTF8; -begin - cpu := TSystemUse.Current(false).HistoryText(0,15,@mem); - with SystemInfo do - result := JSONEncode([ - 'host',ExeVersion.Host,'user',ExeVersion.User,'os',OSVersionText, - 'cpu',CpuInfoText,'bios',BiosInfoText, - {$ifdef MSWINDOWS}{$ifndef CPU64}'wow64',IsWow64,{$endif}{$endif MSWINDOWS} - {$ifdef CPUINTEL}'cpufeatures', LowerCase(ToText(CpuFeatures, ' ')),{$endif} - 'processcpu',cpu,'processmem',mem, - 'freemem',TSynMonitorMemory.FreeAsText, - 'disk',GetDiskPartitionsText(false,true)]); -end; - - -{ TProcessInfo } - -{$ifdef MSWINDOWS} -type - TProcessMemoryCounters = record - cb: DWORD; - PageFaultCount: DWORD; - PeakWorkingSetSize: PtrUInt; - WorkingSetSize: PtrUInt; - QuotaPeakPagedPoolUsage: PtrUInt; - QuotaPagedPoolUsage: PtrUInt; - QuotaPeakNonPagedPoolUsage: PtrUInt; - QuotaNonPagedPoolUsage: PtrUInt; - PagefileUsage: PtrUInt; - PeakPagefileUsage: PtrUInt; - end; -const - PROCESS_QUERY_LIMITED_INFORMATION = $1000; -var - // PROCESS_QUERY_INFORMATION or PROCESS_QUERY_LIMITED_INFORMATION - OpenProcessAccess: DWORD; - // late-binding of Windows version specific API entries - GetSystemTimes: function(var lpIdleTime, lpKernelTime, lpUserTime: TFileTime): BOOL; stdcall; - GetProcessTimes: function(hProcess: THandle; - var lpCreationTime, lpExitTime, lpKernelTime, lpUserTime: TFileTime): BOOL; stdcall; - GetProcessMemoryInfo: function(Process: THandle; - var ppsmemCounters: TProcessMemoryCounters; cb: DWORD): BOOL; stdcall; - EnumProcessModules: function (hProcess: THandle; var lphModule: HMODULE; cb: DWORD; - var lpcbNeeded: DWORD): BOOL; stdcall; - EnumProcesses: function(lpidProcess: PDWORD; cb: DWORD; var cbNeeded: DWORD): BOOL; stdcall; - GetModuleFileNameExW: function(hProcess: THandle; hModule: HMODULE; - lpBaseName: PWideChar; nSize: DWORD): DWORD; stdcall; - // Vista+/WS2008+ (use GetModuleFileNameEx on XP) - QueryFullProcessImageNameW: function(hProcess: THandle; dwFlags: DWORD; - lpExeName: PWideChar; lpdwSize: PDWORD): BOOL; stdcall; - -procedure InitWindowsAPI; -var Kernel, Psapi: THandle; -begin - if OSVersion>=wVista then - OpenProcessAccess := PROCESS_QUERY_LIMITED_INFORMATION else - OpenProcessAccess := PROCESS_QUERY_INFORMATION or PROCESS_VM_READ; - Kernel := GetModuleHandle(kernel32); - @GetSystemTimes := GetProcAddress(Kernel,'GetSystemTimes'); - @GetProcessTimes := GetProcAddress(Kernel,'GetProcessTimes'); - @QueryFullProcessImageNameW := GetProcAddress(Kernel,'QueryFullProcessImageNameW'); - Psapi := LoadLibrary('Psapi.dll'); - if Psapi>=32 then begin - @EnumProcesses := GetProcAddress(Psapi,'EnumProcesses'); - @GetModuleFileNameExW := GetProcAddress(Psapi,'GetModuleFileNameExW'); - @EnumProcessModules := GetProcAddress(Psapi, 'EnumProcessModules'); - @GetProcessMemoryInfo := GetProcAddress(Psapi,'GetProcessMemoryInfo'); - end; -end; - -function EnumAllProcesses(out Count: Cardinal): TCardinalDynArray; -var n: cardinal; -begin - result := nil; - n := 2048; - repeat - SetLength(result, n); - if EnumProcesses(pointer(result), n * 4, Count) then - Count := Count shr 2 else - Count := 0; - if Count < n then begin - if Count = 0 then - result := nil; - exit; - end; - inc(n, 1024); // (very unlikely) too small buffer - until n>8192; -end; - -function EnumProcessName(PID: Cardinal): RawUTF8; -var h: THandle; - len: DWORD; - name: array[0..4095] of WideChar; -begin - result := ''; - if PID = 0 then - exit; - h := OpenProcess(OpenProcessAccess, false, PID); - if h <> 0 then - try - if Assigned(QueryFullProcessImageNameW) then begin - len := high(name); - if QueryFullProcessImageNameW(h, 0, name, @len) then - RawUnicodeToUtf8(name, len, result); - end else - if GetModuleFileNameExW(h,0,name,high(name))<>0 then - RawUnicodeToUtf8(name, StrLenW(name), result); - finally - CloseHandle(h); - end; -end; - -function TProcessInfo.Init: boolean; -begin - FillCharFast(self,SizeOf(self),0); - result := Assigned(GetSystemTimes) and Assigned(GetProcessTimes) and - Assigned(GetProcessMemoryInfo); // no monitoring API under oldest Windows -end; - -function TProcessInfo.Start: boolean; -var ftidl,ftkrn,ftusr: TFileTime; - sidl,skrn,susr: Int64; -begin - result := Assigned(GetSystemTimes) and GetSystemTimes(ftidl,ftkrn,ftusr); - if not result then - exit; - FileTimeToInt64(ftidl,sidl); - FileTimeToInt64(ftkrn,skrn); - FileTimeToInt64(ftusr,susr); - fDiffIdle := sidl-fSysPrevIdle; - fDiffKernel := skrn-fSysPrevKernel; - fDiffUser := susr-fSysPrevUser; - fDiffTotal := fDiffKernel+fDiffUser; // kernel time also includes idle time - dec(fDiffKernel, fDiffIdle); - fSysPrevIdle := sidl; - fSysPrevKernel := skrn; - fSysPrevUser := susr; -end; - -function TProcessInfo.PerProcess(PID: cardinal; Now: PDateTime; - out Data: TSystemUseData; var PrevKernel, PrevUser: Int64): boolean; -var - h: THandle; - ftkrn,ftusr,ftp,fte: TFileTime; - pkrn,pusr: Int64; - mem: TProcessMemoryCounters; -begin - result := false; - FillCharFast(Data,SizeOf(Data),0); - h := OpenProcess(OpenProcessAccess,false,PID); - if h<>0 then - try - if GetProcessTimes(h,ftp,fte,ftkrn,ftusr) then begin - if Now<>nil then - Data.Timestamp := Now^; - FileTimeToInt64(ftkrn,pkrn); - FileTimeToInt64(ftusr,pusr); - if (PrevKernel<>0) and (fDiffTotal>0) then begin - Data.Kernel := ((pkrn-PrevKernel)*100)/fDiffTotal; - Data.User := ((pusr-PrevUser)*100)/fDiffTotal; - end; - PrevKernel := pkrn; - PrevUser := pusr; - FillCharFast(mem,SizeOf(mem),0); - mem.cb := SizeOf(mem); - if GetProcessMemoryInfo(h,mem,SizeOf(mem)) then begin - Data.WorkKB := mem.WorkingSetSize shr 10; - Data.VirtualKB := mem.PagefileUsage shr 10; - end; - result := true; - end; - finally - CloseHandle(h); - end; -end; - -function TProcessInfo.PerSystem(out Idle,Kernel,User: currency): boolean; -begin - if fDiffTotal<=0 then begin - Idle := 0; - Kernel := 0; - User := 0; - result := false; - end else begin - Kernel := SimpleRoundTo2Digits((fDiffKernel*100)/fDiffTotal); - User := SimpleRoundTo2Digits((fDiffUser*100)/fDiffTotal); - Idle := 100-Kernel-User; // ensure sum is always 100% - result := true; - end; -end; -{$else} // not implemented yet (use /proc ?) -function TProcessInfo.Init: boolean; -begin - FillCharFast(self,SizeOf(self),0); - result := false; -end; - -function TProcessInfo.Start: boolean; -begin - result := false; -end; - -function TProcessInfo.PerProcess(PID: cardinal; Now: PDateTime; - out Data: TSystemUseData; var PrevKernel, PrevUser: Int64): boolean; -begin - result := false; -end; - -function TProcessInfo.PerSystem(out Idle,Kernel,User: currency): boolean; -var P: PUTF8Char; - U, K, I, S: cardinal; -begin // see http://www.linuxhowtos.org/System/procstat.htm - result := false; - P := pointer(StringFromFile('/proc/stat', {nosize=}true)); - if P=nil then - exit; - U := GetNextItemCardinal(P,' '){=user}+GetNextItemCardinal(P,' '){=nice}; - K := GetNextItemCardinal(P,' '){=system}; - I := GetNextItemCardinal(P,' '){=idle}; - S := U+K+I; - Kernel := SimpleRoundTo2Digits((K*100)/S); - User := SimpleRoundTo2Digits((U*100)/S); - Idle := 100-Kernel-User; // ensure sum is always 100% - result := S<>0; -end; { TODO : use a diff approach for TProcessInfo.PerSystem on Linux } -{$endif MSWINDOWS} - - -{ TSystemUse } - -procedure TSystemUse.BackgroundExecute(Sender: TSynBackgroundTimer; - Event: TWaitResult; const Msg: RawUTF8); -var i: integer; - now: TDateTime; -begin - if (fProcess=nil) or (fHistoryDepth=0) or not fProcessInfo.Start then - exit; - fTimer := Sender; - now := NowUTC; - fSafe.Lock; - try - inc(fDataIndex); - if fDataIndex>=fHistoryDepth then - fDataIndex := 0; - for i := high(fProcess) downto 0 do // backwards for fProcesses.Delete(i) - with fProcess[i] do - if fProcessInfo.PerProcess(ID,@now,Data[fDataIndex],PrevKernel,PrevUser) then begin - if Assigned(fOnMeasured) then - fOnMeasured(ID,Data[fDataIndex]); - end else - if UnsubscribeProcessOnAccessError then - // if GetLastError=ERROR_INVALID_PARAMETER then - fProcesses.Delete(i); - finally - fSafe.UnLock; - end; -end; - -procedure TSystemUse.OnTimerExecute(Sender: TObject); -begin - BackgroundExecute(nil,wrSignaled,''); -end; - -constructor TSystemUse.Create(const aProcessID: array of integer; - aHistoryDepth: integer); -var i: integer; -begin - inherited Create; - fProcesses.Init(TypeInfo(TSystemUseProcessDynArray),fProcess); - {$ifdef MSWINDOWS} - if not Assigned(GetSystemTimes) or not Assigned(GetProcessTimes) or - not Assigned(GetProcessMemoryInfo) then - exit; // no system monitoring API under oldest Windows - {$else} - exit; // not implemented yet - {$endif} - if aHistoryDepth<=0 then - aHistoryDepth := 1; - fHistoryDepth := aHistoryDepth; - SetLength(fProcess,length(aProcessID)); - for i := 0 to high(aProcessID) do begin - {$ifdef MSWINDOWS} - if aProcessID[i]=0 then - fProcess[i].ID := GetCurrentProcessID else - {$endif} - fProcess[i].ID := aProcessID[i]; - SetLength(fProcess[i].Data,fHistoryDepth); - end; -end; - -constructor TSystemUse.Create(aHistoryDepth: integer); -begin - Create([0],aHistoryDepth); -end; - -procedure TSystemUse.Subscribe(aProcessID: integer); -var i,n: integer; -begin - if self=nil then - exit; - {$ifdef MSWINDOWS} - if aProcessID=0 then - aProcessID := GetCurrentProcessID; - {$endif} - fSafe.Lock; - try - n := length(fProcess); - for i := 0 to n-1 do - if fProcess[i].ID=aProcessID then - exit; // already subscribed - SetLength(fProcess,n+1); - fProcess[n].ID := aProcessID; - SetLength(fProcess[n].Data,fHistoryDepth); - finally - fSafe.UnLock; - end; -end; - -function TSystemUse.Unsubscribe(aProcessID: integer): boolean; -var i: integer; -begin - result := false; - if self=nil then - exit; - fSafe.Lock; - try - i := ProcessIndex(aProcessID); - if i>=0 then begin - fProcesses.Delete(i); - result := true; - end; - finally - fSafe.UnLock; - end; -end; - -function TSystemUse.ProcessIndex(aProcessID: integer): integer; -begin // caller should have made fSafe.Enter - {$ifdef MSWINDOWS} - if aProcessID=0 then - aProcessID := GetCurrentProcessID; - {$endif} - if self<>nil then - for result := 0 to high(fProcess) do - if fProcess[result].ID=aProcessID then - exit; - result := -1; -end; - -function TSystemUse.Data(out aData: TSystemUseData; aProcessID: integer=0): boolean; -var i: integer; -begin - result := false; - if self<>nil then begin - fSafe.Lock; - try - i := ProcessIndex(aProcessID); - if i>=0 then begin - with fProcess[i] do - aData := Data[fDataIndex]; - result := aData.Timestamp<>0; - if result then - exit; - end; - finally - fSafe.UnLock; - end; - end; - FillCharFast(aData,SizeOf(aData),0); -end; - -function TSystemUse.Data(aProcessID: integer): TSystemUseData; -begin - Data(result,aProcessID); -end; - -function TSystemUse.KB(aProcessID: integer=0): cardinal; -begin - with Data(aProcessID) do - result := WorkKB+VirtualKB; -end; - -function TSystemUse.Percent(aProcessID: integer): single; -begin - with Data(aProcessID) do - result := Kernel+User; -end; - -function TSystemUse.PercentKernel(aProcessID: integer): single; -begin - result := Data(aProcessID).Kernel; -end; - -function TSystemUse.PercentUser(aProcessID: integer): single; -begin - result := Data(aProcessID).User; -end; - -function TSystemUse.PercentSystem(out Idle,Kernel,User: currency): boolean; -begin - result := fProcessInfo.PerSystem(Idle,Kernel,User); -end; - -function TSystemUse.HistoryData(aProcessID,aDepth: integer): TSystemUseDataDynArray; -var i,n,last: integer; -begin - result := nil; - if self=nil then - exit; - fSafe.Lock; - try - i := ProcessIndex(aProcessID); - if i>=0 then - with fProcess[i] do begin - n := length(Data); - last := n-1; - if (aDepth>0) and (n>aDepth) then - n := aDepth; - SetLength(result,n); // make ordered copy - for i := 0 to n-1 do begin - if i<=fDataIndex then - result[i] := Data[fDataIndex-i] else begin - result[i] := Data[last]; - dec(last); - end; - if PInt64(@result[i].Timestamp)^=0 then begin - SetLength(result,i); // truncate to latest available sample - break; - end; - end; - end; - finally - fSafe.UnLock; - end; -end; - -function TSystemUse.History(aProcessID,aDepth: integer): TSingleDynArray; -var i,n: integer; - data: TSystemUseDataDynArray; -begin - result := nil; - data := HistoryData(aProcessID,aDepth); - n := length(data); - SetLength(result,n); - for i := 0 to n-1 do - result[i] := data[i].Kernel+data[i].User; -end; - -class function TSystemUse.Current(aCreateIfNone: boolean): TSystemUse; -begin - if (ProcessSystemUse=nil) and aCreateIfNone then - GarbageCollectorFreeAndNil(ProcessSystemUse,TSystemUse.Create(60)); - result := ProcessSystemUse; -end; - -function TSystemUse.HistoryText(aProcessID,aDepth: integer; - aDestMemoryMB: PRawUTF8): RawUTF8; -var data: TSystemUseDataDynArray; - mem: RawUTF8; - i: integer; -begin - result := ''; - data := HistoryData(aProcessID,aDepth); - {$ifdef LINUXNOTBSD} // bsd: see VM_LOADAVG - // https://www.retro11.de/ouxr/211bsd/usr/src/lib/libc/gen/getloadavg.c.html - if data = nil then - result := StringFromFile('/proc/loadavg',{HasNoSize=}true) else - {$endif LINUXNOTBSD} - for i := 0 to high(data) do - with data[i] do begin - result := FormatUTF8('%% ',[result,TruncTo2Digits(Kernel+User)]); - if aDestMemoryMB<>nil then - mem := FormatUTF8('%% ',[mem,TruncTo2Digits(WorkKB/1024)]); - end; - result := trim(result); - if aDestMemoryMB<>nil then - aDestMemoryMB^ := trim(mem); -end; - -{$ifndef NOVARIANTS} - -function TSystemUse.HistoryVariant(aProcessID,aDepth: integer): variant; -var res: TDocVariantData absolute result; - data: TSystemUseDataDynArray; - i: integer; -begin - VarClear(result); - data := HistoryData(aProcessID,aDepth); - res.InitFast(length(data),dvArray); - for i := 0 to high(data) do - res.AddItem(TruncTo2Digits(data[i].Kernel+data[i].User)); -end; - -{$endif NOVARIANTS} - -function SortDynArrayDiskPartitions(const A,B): integer; -begin - result := SortDynArrayString(TDiskPartition(A).mounted,TDiskPartition(B).mounted); -end; - -function GetDiskPartitions: TDiskPartitions; -{$ifdef MSWINDOWS} // DeviceIoControl(IOCTL_DISK_GET_PARTITION_INFO) requires root -var drives, drive, m, n: integer; - fn, volume: TFileName; -{$else} -var mounts, fs, mnt, typ: RawUTF8; - p: PUTF8Char; - fn: TFileName; - n: integer; -{$endif} - av, fr, tot: QWord; -begin - result := nil; - n := 0; -{$ifdef MSWINDOWS} - fn := '#:\'; - drives := GetLogicalDrives; - m := 1 shl 2; - for drive := 3 to 26 do begin // retrieve partitions mounted as C..Z drives - if drives and m <> 0 then begin - fn[1] := char(64+drive); - if GetDiskInfo(fn,av,fr,tot,@volume) then begin - SetLength(result,n+1); - StringToUTF8(volume,result[n].name); - volume := ''; - result[n].mounted := fn; - result[n].size := tot; - inc(n); - end; - end; - m := m shl 1; - end; -{$else} // see https://github.com/gagern/gnulib/blob/master/lib/mountlist.c - mounts := StringFromFile({$ifdef BSD}'/etc/mtab'{$else}'/proc/self/mounts'{$endif}, - {hasnosize=}true); - p := pointer(mounts); - repeat - fs := ''; - mnt := ''; - typ := ''; - ScanUTF8(GetNextLine(p,p),'%S %S %S',[@fs,@mnt,@typ]); - if (fs<>'') and (fs<>'rootfs') and (IdemPCharArray(pointer(fs),['/DEV/LOOP'])<0) and - (mnt<>'') and (mnt<>'/mnt') and (typ<>'') and - (IdemPCharArray(pointer(mnt),['/PROC/','/SYS/','/RUN/'])<0) and - (FindPropName(['autofs','proc','subfs','debugfs','devpts','fusectl','mqueue', - 'rpc-pipefs','sysfs','devfs','kernfs','ignore','none','tmpfs','securityfs', - 'ramfs','rootfs','devtmpfs','hugetlbfs','iso9660'],typ)<0) then begin - fn := UTF8ToString(mnt); - if GetDiskInfo(fn,av,fr,tot) and (tot>1 shl 20) then begin - //writeln('fs=',fs,' mnt=',mnt,' typ=',typ, ' av=',KB(av),' fr=',KB(fr),' tot=',KB(tot)); - SetLength(result,n+1); - result[n].name := fs; - result[n].mounted := fn; - result[n].size := tot; - inc(n); - end; - end; - until p=nil; - DynArray(TypeInfo(TDiskPartitions),result).Sort(SortDynArrayDiskPartitions); - {$endif} -end; - -var - _DiskPartitions: TDiskPartitions; - -function GetDiskPartitionsText(nocache, withfreespace, nospace: boolean): RawUTF8; -const F: array[boolean] of RawUTF8 = ({$ifdef MSWINDOWS}'%: % (% / %)', '%: % (%/%)' - {$else}'% % (% / %)', '% % (%/%)'{$endif}); -var i: integer; - parts: TDiskPartitions; - function GetInfo(var p: TDiskPartition): shortstring; - var av, fr, tot: QWord; - begin - if not withfreespace or not GetDiskInfo(p.mounted,av,fr,tot) then - {$ifdef MSWINDOWS} - FormatShort('%: % (%)',[p.mounted[1],p.name,KB(p.size,nospace)],result) else - FormatShort(F[nospace],[p.mounted[1],p.name,KB(fr,nospace),KB(tot,nospace)],result); - {$else} - FormatShort('% % (%)',[p.mounted,p.name,KB(p.size,nospace)],result) else - FormatShort(F[nospace],[p.mounted,p.name,KB(fr,nospace),KB(tot,nospace)],result); - {$endif} - end; -begin - if (_DiskPartitions=nil) or nocache then - _DiskPartitions := GetDiskPartitions; - parts := _DiskPartitions; - if parts=nil then - result := '' else - ShortStringToAnsi7String(GetInfo(parts[0]),result); - for i := 1 to high(parts) do - result := FormatUTF8('%, %',[result,GetInfo(parts[i])]); -end; - -{ TSynMonitorMemory } - -constructor TSynMonitorMemory.Create(aTextNoSpace: boolean); -begin - FAllocatedUsed := TSynMonitorOneSize.Create(aTextNoSpace); - FAllocatedReserved := TSynMonitorOneSize.Create(aTextNoSpace); - FPhysicalMemoryFree := TSynMonitorOneSize.Create(aTextNoSpace); - FVirtualMemoryFree := TSynMonitorOneSize.Create(aTextNoSpace); - FPagingFileTotal := TSynMonitorOneSize.Create(aTextNoSpace); - FPhysicalMemoryTotal := TSynMonitorOneSize.Create(aTextNoSpace); - FVirtualMemoryTotal := TSynMonitorOneSize.Create(aTextNoSpace); - FPagingFileFree := TSynMonitorOneSize.Create(aTextNoSpace); -end; - -destructor TSynMonitorMemory.Destroy; -begin - FAllocatedReserved.Free; - FAllocatedUsed.Free; - FPhysicalMemoryFree.Free; - FVirtualMemoryFree.Free; - FPagingFileTotal.Free; - FPhysicalMemoryTotal.Free; - FVirtualMemoryTotal.Free; - FPagingFileFree.Free; - inherited Destroy; -end; - -class function TSynMonitorMemory.FreeAsText(nospace: boolean): ShortString; -const F: array[boolean] of RawUTF8 = ('% / %', '%/%'); -begin - with TSynMonitorMemory.Create(nospace) do - try - RetrieveMemoryInfo; - FormatShort(F[nospace],[fPhysicalMemoryFree.Text,fPhysicalMemoryTotal.Text],result); - finally - Free; - end; -end; - -var - PhysicalAsTextCache: TShort16; // this value doesn't change usually - -class function TSynMonitorMemory.PhysicalAsText(nospace: boolean): TShort16; -begin - if PhysicalAsTextCache='' then - with TSynMonitorMemory.Create(nospace) do - try - PhysicalAsTextCache := PhysicalMemoryTotal.Text; - finally - Free; - end; - result := PhysicalAsTextCache; -end; - -class function TSynMonitorMemory.ToJSON: RawUTF8; -begin - with TSynMonitorMemory.Create(false) do - try - RetrieveMemoryInfo; - FormatUTF8('{Allocated:{reserved:%,used:%},Physical:{total:%,free:%,percent:%},'+ - {$ifdef MSWINDOWS}'Virtual:{total:%,free:%},'+{$endif}'Paged:{total:%,free:%}}', - [fAllocatedReserved.Bytes shr 10,fAllocatedUsed.Bytes shr 10, - fPhysicalMemoryTotal.Bytes shr 10,fPhysicalMemoryFree.Bytes shr 10, fMemoryLoadPercent, - {$ifdef MSWINDOWS}fVirtualMemoryTotal.Bytes shr 10,fVirtualMemoryFree.Bytes shr 10,{$endif} - fPagingFileTotal.Bytes shr 10,fPagingFileFree.Bytes shr 10],result); - finally - Free; - end; -end; - -{$ifndef NOVARIANTS} -class function TSynMonitorMemory.ToVariant: variant; -begin - result := _JsonFast(ToJSON); -end; -{$endif} - -function TSynMonitorMemory.GetAllocatedUsed: TSynMonitorOneSize; -begin - RetrieveMemoryInfo; - result := FAllocatedUsed; -end; - -function TSynMonitorMemory.GetAllocatedReserved: TSynMonitorOneSize; -begin - RetrieveMemoryInfo; - result := FAllocatedReserved; -end; - -function TSynMonitorMemory.GetMemoryLoadPercent: integer; -begin - RetrieveMemoryInfo; - result := FMemoryLoadPercent; -end; - -function TSynMonitorMemory.GetPagingFileFree: TSynMonitorOneSize; -begin - RetrieveMemoryInfo; - result := FPagingFileFree; -end; - -function TSynMonitorMemory.GetPagingFileTotal: TSynMonitorOneSize; -begin - RetrieveMemoryInfo; - result := FPagingFileTotal; -end; - -function TSynMonitorMemory.GetPhysicalMemoryFree: TSynMonitorOneSize; -begin - RetrieveMemoryInfo; - result := FPhysicalMemoryFree; -end; - -function TSynMonitorMemory.GetPhysicalMemoryTotal: TSynMonitorOneSize; -begin - RetrieveMemoryInfo; - result := FPhysicalMemoryTotal; -end; - -function TSynMonitorMemory.GetVirtualMemoryFree: TSynMonitorOneSize; -begin - RetrieveMemoryInfo; - result := FVirtualMemoryFree; -end; - -function TSynMonitorMemory.GetVirtualMemoryTotal: TSynMonitorOneSize; -begin - RetrieveMemoryInfo; - result := FVirtualMemoryTotal; -end; - -{$ifdef MSWINDOWS} -{$ifndef UNICODE} // missing API for oldest Delphi -type - DWORDLONG = Int64; - TMemoryStatusEx = record - dwLength: DWORD; - dwMemoryLoad: DWORD; - ullTotalPhys: DWORDLONG; - ullAvailPhys: DWORDLONG; - ullTotalPageFile: DWORDLONG; - ullAvailPageFile: DWORDLONG; - ullTotalVirtual: DWORDLONG; - ullAvailVirtual: DWORDLONG; - ullAvailExtendedVirtual: DWORDLONG; - end; - -// information about the system's current usage of both physical and virtual memory -function GlobalMemoryStatusEx(var lpBuffer: TMemoryStatusEx): BOOL; - stdcall; external kernel32; -{$endif} -{$endif} - -function GetMemoryInfo(out info: TMemoryInfo; withalloc: boolean): boolean; -{$ifdef WITH_FASTMM4STATS} -var Heap: TMemoryManagerState; - sb: integer; -{$endif} -{$ifdef MSWINDOWS} -var global: TMemoryStatusEx; - {$ifdef FPC}mem: TProcessMemoryCounters;{$endif} -begin - FillCharFast(global,SizeOf(global),0); - global.dwLength := SizeOf(global); - result := GlobalMemoryStatusEx(global); - info.percent := global.dwMemoryLoad; - info.memtotal := global.ullTotalPhys; - info.memfree := global.ullAvailPhys; - info.filetotal := global.ullTotalPageFile; - info.filefree := global.ullAvailPageFile; - info.vmtotal := global.ullTotalVirtual; - info.vmfree := global.ullAvailVirtual; - {$ifdef FPC} // GetHeapStatus is only about current thread -> use WinAPI - if withalloc and Assigned(GetProcessMemoryInfo) then begin - FillcharFast(mem,SizeOf(mem),0); - mem.cb := SizeOf(mem); - GetProcessMemoryInfo(GetCurrentProcess,mem,SizeOf(mem)); - info.allocreserved := mem.PeakWorkingSetSize; - info.allocused := mem.WorkingSetSize; - end; - {$endif FPC} -{$else} -{$ifdef BSD} -begin - FillCharFast(info,SizeOf(info),0); - info.memtotal := fpsysctlhwint({$ifdef DARWIN}HW_MEMSIZE{$else}HW_PHYSMEM{$endif}); - info.memfree := info.memtotal-fpsysctlhwint(HW_USERMEM); - if info.memtotal<>0 then // avoid div per 0 exception - info.percent := ((info.memtotal-info.memfree)*100)div info.memtotal; -{$else} -var si: TSysInfo; // Linuxism - P: PUTF8Char; - {$ifdef FPC}mu: cardinal{$else}const mu=1{$endif}; -begin - FillCharFast(info,SizeOf(info),0); - {$ifdef FPC} - result := SysInfo(@si)=0; - mu := si.mem_unit; - {$else} - result := SysInfo(si)=0; // some missing fields in Kylix' Libc - {$endif} - if si.totalram<>0 then // avoid div per 0 exception - info.percent := ((si.totalram-si.freeram)*100)div si.totalram; - info.memtotal := si.totalram*mu; - info.memfree := si.freeram*mu; - info.filetotal := si.totalswap*mu; - info.filefree := si.freeswap*mu; - if withalloc then begin - // virtual memory information is not available under Linux - P := pointer(StringFromFile('/proc/self/statm',{hasnosize=}true)); - info.allocreserved := GetNextItemCardinal(P,' ')*SystemInfo.dwPageSize; // VmSize - info.allocused := GetNextItemCardinal(P,' ')*SystemInfo.dwPageSize; // VmRSS - end; - // GetHeapStatus is only about current thread -> use /proc/[pid]/statm -{$endif BSD} -{$endif MSWINDOWS} -{$ifdef WITH_FASTMM4STATS} // override OS information by actual FastMM4 - if withalloc then begin - GetMemoryManagerState(Heap); // direct raw FastMM4 access - info.allocused := Heap.TotalAllocatedMediumBlockSize+Heap.TotalAllocatedLargeBlockSize; - info.allocreserved := Heap.ReservedMediumBlockAddressSpace+Heap.ReservedLargeBlockAddressSpace; - for sb := 0 to high(Heap.SmallBlockTypeStates) do - with Heap.SmallBlockTypeStates[sb] do begin - inc(info.allocused,UseableBlockSize*AllocatedBlockCount); - inc(info.allocreserved,ReservedAddressSpace); - end; - end; -{$endif WITH_FASTMM4STATS} -end; - -procedure TSynMonitorMemory.RetrieveMemoryInfo; -var tix: cardinal; - info: TMemoryInfo; -begin - tix := GetTickCount64 shr 7; // allow 128 ms resolution for updates - if fLastMemoryInfoRetrievedTix<>tix then begin - fLastMemoryInfoRetrievedTix := tix; - if not GetMemoryInfo(info,{withalloc=}true) then - exit; - FMemoryLoadPercent := info.percent; - FPhysicalMemoryTotal.Bytes := info.memtotal; - FPhysicalMemoryFree.Bytes := info.memfree; - FPagingFileTotal.Bytes := info.filetotal; - FPagingFileFree.Bytes := info.filefree; - FVirtualMemoryTotal.Bytes := info.vmtotal; - FVirtualMemoryFree.Bytes := info.vmfree; - FAllocatedReserved.Bytes := info.allocreserved; - FAllocatedUsed.Bytes := info.allocused; - end; -end; - - -{ TSynMonitorDisk } - -constructor TSynMonitorDisk.Create; -begin - fAvailableSize := TSynMonitorOneSize.Create({nospace=}false); - fFreeSize := TSynMonitorOneSize.Create({nospace=}false); - fTotalSize := TSynMonitorOneSize.Create({nospace=}false); -end; - -destructor TSynMonitorDisk.Destroy; -begin - fAvailableSize.Free; - fFreeSize.Free; - fTotalSize.Free; - inherited; -end; - -function TSynMonitorDisk.GetName: TFileName; -begin - RetrieveDiskInfo; - result := fName; -end; - -function TSynMonitorDisk.GetAvailable: TSynMonitorOneSize; -begin - RetrieveDiskInfo; - result := fAvailableSize; -end; - -function TSynMonitorDisk.GetFree: TSynMonitorOneSize; -begin - RetrieveDiskInfo; - result := fFreeSize; -end; - -function TSynMonitorDisk.GetTotal: TSynMonitorOneSize; -begin - RetrieveDiskInfo; - result := fTotalSize; -end; - -class function TSynMonitorDisk.FreeAsText: RawUTF8; -var name: TFileName; - avail,free,total: QWord; -begin - GetDiskInfo(name,avail,free,total); - FormatUTF8('% % / %',[name, KB(free),KB(total)],result); -end; - -{$ifdef MSWINDOWS} -function GetDiskFreeSpaceExA(lpDirectoryName: PAnsiChar; - var lpFreeBytesAvailableToCaller, lpTotalNumberOfBytes, - lpTotalNumberOfFreeBytes: QWord): LongBool; stdcall; external kernel32; -function GetDiskFreeSpaceExW(lpDirectoryName: PWideChar; - var lpFreeBytesAvailableToCaller, lpTotalNumberOfBytes, - lpTotalNumberOfFreeBytes: QWord): LongBool; stdcall; external kernel32; -function DeviceIoControl(hDevice: THandle; dwIoControlCode: DWORD; lpInBuffer: Pointer; - nInBufferSize: DWORD; lpOutBuffer: Pointer; nOutBufferSize: DWORD; - var lpBytesReturned: DWORD; lpOverlapped: POverlapped): BOOL; stdcall; external kernel32; -{$endif} - -function GetDiskInfo(var aDriveFolderOrFile: TFileName; - out aAvailableBytes, aFreeBytes, aTotalBytes: QWord - {$ifdef MSWINDOWS}; aVolumeName: PFileName = nil{$endif}): boolean; -{$ifdef MSWINDOWS} -var tmp: array[0..MAX_PATH-1] of Char; - dummy,flags: DWORD; - dn: TFileName; -begin - if aDriveFolderOrFile='' then - aDriveFolderOrFile := SysUtils.UpperCase(ExtractFileDrive(ExeVersion.ProgramFilePath)); - dn := aDriveFolderOrFile; - if (dn<>'') and (dn[2]=':') and (dn[3]=#0) then - dn := dn+'\'; - if (aVolumeName<>nil) and (aVolumeName^='') then begin - tmp[0] := #0; - GetVolumeInformation(pointer(dn),tmp,MAX_PATH,nil,dummy,flags,nil,0); - aVolumeName^ := tmp; - end; - result := {$ifdef UNICODE}GetDiskFreeSpaceExW{$else}GetDiskFreeSpaceExA{$endif}( - pointer(dn),aAvailableBytes,aTotalBytes,aFreeBytes); -{$else} -{$ifdef KYLIX3} -var fs: TStatFs64; - h: THandle; -begin - if aDriveFolderOrFile='' then - aDriveFolderOrFile := '.'; - h := FileOpen(aDriveFolderOrFile,fmShareDenyNone); - result := fstatfs64(h,fs)=0; - FileClose(h); - aAvailableBytes := fs.f_bavail*fs.f_bsize; - aFreeBytes := aAvailableBytes; - aTotalBytes := fs.f_blocks*fs.f_bsize; -{$endif} -{$ifdef FPC} -var fs: tstatfs; -begin - if aDriveFolderOrFile='' then - aDriveFolderOrFile := '.'; - result := fpStatFS(aDriveFolderOrFile,@fs)=0; - aAvailableBytes := QWord(fs.bavail)*QWord(fs.bsize); - aFreeBytes := aAvailableBytes; // no user Quota involved here - aTotalBytes := QWord(fs.blocks)*QWord(fs.bsize); -{$endif FPC} -{$endif MSWINDOWS} -end; - -procedure TSynMonitorDisk.RetrieveDiskInfo; -var tix: cardinal; -begin - tix := GetTickCount64 shr 7; // allow 128 ms resolution for updates - if fLastDiskInfoRetrievedTix<>tix then begin - fLastDiskInfoRetrievedTix := tix; - GetDiskInfo(fName,PQWord(@fAvailableSize.Bytes)^,PQWord(@fFreeSize.Bytes)^, - PQWord(@fTotalSize.Bytes)^{$ifdef MSWINDOWS},@fVolumeName{$endif}); - end; -end; - - -{ TTimeZoneData } - -function TTimeZoneData.GetTziFor(year: integer): PTimeZoneInfo; -var i,last: PtrInt; -begin - if dyn=nil then - result := @tzi else - if year<=dyn[0].year then - result := @dyn[0].tzi else begin - last := high(dyn); - if year>=dyn[last].year then - result := @dyn[last].tzi else begin - for i := 1 to last do - if year'' then - LoadFromBuffer(buf); -end; - -{$ifdef MSWINDOWS} -procedure TSynTimeZone.LoadFromRegistry; -const REGKEY = 'Software\Microsoft\Windows NT\CurrentVersion\Time Zones\'; -var reg: TWinRegistry; - keys: TRawUTF8DynArray; - i,first,last,year,n: integer; - itemsize: DWORD; - item: TTimeZoneData; -begin - fZones.Clear; - if reg.ReadOpen(HKEY_LOCAL_MACHINE,REGKEY) then - keys := reg.ReadEnumEntries else - keys := nil; // make Delphi 6 happy - n := length(keys); - fZones.Capacity := n; - for i := 0 to n-1 do begin - Finalize(item); - FillcharFast(item.tzi,SizeOf(item.tzi),0); - if reg.ReadOpen(HKEY_LOCAL_MACHINE,REGKEY+keys[i],true) then begin - item.id := keys[i]; - item.Display := reg.ReadString('Display'); - itemsize := SizeOf(item.tzi); - RegQueryValueExW(reg.key,'TZI',nil,nil,@item.tzi,@itemsize); - if reg.ReadOpen(HKEY_LOCAL_MACHINE,REGKEY+keys[i]+'\Dynamic DST',true) then begin - // warning: never defined on XP/2003, and not for all entries - first := reg.ReadDword('FirstEntry'); - last := reg.ReadDword('LastEntry'); - if (first>0) and (last>=first) then begin - n := 0; - SetLength(item.dyn,last-first+1); - for year := first to last do begin - itemsize := SizeOf(TTimeZoneInfo); - if RegQueryValueExA(reg.key,pointer(UInt32ToUTF8(year)),nil,nil, - @item.dyn[n].tzi,@itemsize)=0 then begin - item.dyn[n].year := year; - inc(n); - end; - end; - SetLength(item.dyn,n); - end; - end; - fZones.Add(item); - end; - end; - reg.Close; - fZones.ReHash; - FreeAndNil(fIds); - FreeAndNil(fDisplays); -end; -{$endif MSWINDOWS} - -function TSynTimeZone.GetDisplay(const TzId: TTimeZoneID): RawUTF8; -var ndx: integer; -begin - if self=nil then - ndx := -1 else - ndx := fZones.FindHashed(TzID); - if ndx<0 then - if TzID='UTC' then // e.g. on XP - result := TzID else - result := '' else - result := fZone[ndx].display; -end; - -function TSynTimeZone.GetBiasForDateTime(const Value: TDateTime; - const TzId: TTimeZoneID; out Bias: integer; out HaveDaylight: boolean; - DateIsUTC: boolean): boolean; -var ndx: integer; - d: TSynSystemTime; - tzi: PTimeZoneInfo; - std,dlt: TDateTime; -begin - if (self=nil) or (TzId='') then - ndx := -1 else - if TzID=fLastZone then - ndx := fLastIndex else begin - ndx := fZones.FindHashed(TzID); - fLastZone := TzID; - flastIndex := ndx; - end; - if ndx<0 then begin - Bias := 0; - HaveDayLight := false; - result := TzID='UTC'; // e.g. on XP - exit; - end; - d.FromDate(Value); // faster than DecodeDate - tzi := fZone[ndx].GetTziFor(d.Year); - if tzi.change_time_std.IsZero then begin - HaveDaylight := false; - Bias := tzi.Bias+tzi.bias_std; - end else begin - HaveDaylight := true; - std := tzi.change_time_std.EncodeForTimeChange(d.Year); - dlt := tzi.change_time_dlt.EncodeForTimeChange(d.Year); - if DateIsUTC then begin // std shifts by the DST bias, dst by STD - std := ((std*MinsPerDay)+tzi.Bias+tzi.bias_dlt)/MinsPerDay; - dlt := ((dlt*MinsPerDay)+tzi.Bias+tzi.bias_std)/MinsPerDay; - end; - if std' ' do inc(P); - W.AddShort(''); - W.AddHtmlEscape(B,P-B); - W.AddShort(''); -end; - -function TTextWriterEscape.ProcessLink: boolean; -begin - inc(P); - B2 := P; - while not (P^ in [#0,']']) do inc(P); - P2 := P; - if PWord(P)^=ord(']')+ord('(')shl 8 then begin - inc(P,2); - B := P; - while not (P^ in [#0,')']) do inc(P); - if P^=')' then begin // [GitHub](https://github.com) - result := true; - exit; - end; - end; - P := B2; // rollback - result := false; -end; - -procedure TTextWriterEscape.ProcessEmoji; -begin - if heEmojiToUTF8 in esc then - EmojiParseDots(P,W) else begin - W.Add(':'); - inc(P); - end; -end; - -procedure TTextWriterEscape.Toggle(style: TTextWriterEscapeStyle); -const HTML: array[tweBold..tweCode] of string[7] = ('strong>','em>','code>'); -begin - W.Add('<'); - if style in st then begin - W.Add('/'); - exclude(st,style); - end else - include(st,style); - W.AddShort(HTML[style]); -end; - -procedure TTextWriterEscape.EndOfParagraph; -begin - if tweBold in st then - Toggle(tweBold); - if tweItalic in st then - Toggle(tweItalic); - if P<>nil then - if PWord(P)^=$0a0d then - inc(P,2) else - inc(P); -end; - -procedure TTextWriterEscape.SetLine(style: TTextWriterEscapeLineStyle); -const HTML: array[twlParagraph..twlCode3] of string[5] = ('p>','li>','li>','p>','code>','code>'); - HTML2: array[twlOrderedList..twlCode3] of string[11] = ('ol>','ul>','blockquote>','pre>','pre>'); -begin - if lst>=low(HTML) then begin - if (lststyle) then begin - W.Add('<','/'); - W.AddShort(HTML[lst]); - end; - if (lst>=low(HTML2)) and (lst<>style) then begin - W.Add('<','/'); - W.AddShort(HTML2[lst]); - end; - end; - if style>=low(HTML) then begin - if (style>=low(HTML2)) and (lst<>style) then begin - W.Add('<'); - W.AddShort(HTML2[style]); - end; - if (stylestyle) then begin - W.Add('<'); - W.AddShort(HTML[style]); - end; - end; - lst := style; -end; - -procedure TTextWriterEscape.NewMarkdownLine; -label none; -var c: cardinal; -begin - if P=nil then - exit; - c := PCardinal(P)^; - if c and $ffffff=ord('`')+ord('`')shl 8+ord('`')shl 16 then begin - inc(P,3); - if lst=twlCode3 then begin - lst := twlCode4; // to close - NewMarkdownLine; - exit; - end; - SetLine(twlCode3); - end; - if lst=twlCode3 then - exit; // no prefix process within ``` code blocks - if c=$20202020 then begin - SetLine(twlCode4); - inc(P,4); - exit; - end; - P := GotoNextNotSpaceSameLine(P); // don't implement nested levels yet - case P^ of - '*','+','-': - if P[1]=' ' then - SetLine(twlUnorderedList) else - goto none; - '1'..'9': begin // first should be 1. then any ##. number to continue - B := P; - repeat inc(P) until not (P^ in ['0'..'9']); - if (P^='.') and ((lst=twlOrderedList) or (PWord(B)^=ord('1')+ord('.')shl 8)) then - SetLine(twlOrderedList) else begin - P := B; -none: if lst=twlParagraph then begin - c := PWord(P)^; // detect blank line to separate paragraphs - if c=$0a0d then - inc(P,2) else - if c and $ff=$0a then - inc(P) else begin - W.AddOnce(' '); - exit; - end; - end; - SetLine(twlParagraph); - exit; - end; - end; - '>': - if P[1]=' ' then - SetLine(twlBlockquote) else - goto none; - else - goto none; - end; - P := GotoNextNotSpaceSameLine(P+1); -end; - -procedure TTextWriterEscape.AddHtmlEscapeWiki(dest: TTextWriter; src: PUTF8Char; - escape: TTextWriterHTMLEscape); -begin - Start(dest,src,escape); - SetLine(twlParagraph); - repeat - case ProcessText([0,10,13,ord('*'),ord('+'),ord('`'),ord('\'),ord(':')]) of - #0: break; - #10,#13: begin - EndOfParagraph; - SetLine(twlParagraph); - continue; - end; - '\': if P[1] in ['\','`','*','+'] then begin - inc(P); - W.Add(P^); - end else - W.Add('\'); - '*': - Toggle(tweItalic); - '+': - Toggle(tweBold); - '`': - Toggle(tweCode); - 'h': begin - ProcessHRef; - continue; - end; - ':': begin - ProcessEmoji; - continue; - end; - end; - inc(P); - until false; - EndOfParagraph; - SetLine(twlNone); -end; - -procedure TTextWriterEscape.AddHtmlEscapeMarkdown(dest: TTextWriter; - src: PUTF8Char; escape: TTextWriterHTMLEscape); -begin - Start(dest,src,escape); - NewMarkDownLine; - repeat - if lst>=twlCode4 then // no Markdown tags within code blocks - if ProcessText([0,10,13])=#0 then - break else begin - if PWord(P)^=$0a0d then - inc(P,2) else - inc(P); - W.AddCR; // keep LF within 
-        NewMarkdownLine;
-        continue;
-      end else
-    case ProcessText([0,10,13,ord('*'),ord('_'),ord('`'),ord('\'),ord('['),ord('!'),ord(':')]) of
-    #0: break;
-    #10,#13: begin
-      EndOfParagraph;
-      NewMarkdownLine;
-      continue;
-    end;
-    '\': if P[1] in ['\','`','*','_','[',']','{','}','(',')','#','+','-','.','!'] then begin
-      inc(P);
-      W.Add(P^); // backslash escape
-    end else
-      W.Add('\');
-    '*','_':
-      if P[1]=P[0] then begin
-        inc(P); // **This text will be bold** or __This text will be bold__
-        Toggle(tweBold);
-      end else  // *This text will be italic* or _This text will be italic_
-        Toggle(tweItalic);
-    '`':
-      Toggle(tweCode);  // `This text will be code`
-    '[':
-       if ProcessLink then begin // [GitHub](https://github.com)
-         W.AddShort('') else
-           W.Add('"','>');
-         W.AddHtmlEscape(B2,P2-B2,fmt);
-         W.AddShort(''); // no continune -> need inc(P) over ending )
-       end else
-         W.Add('['); // not a true link -> just append
-    '!': begin
-      if P[1]='[' then begin
-       inc(P);
-       if ProcessLink then begin
-         W.AddShort('');
-         W.AddHtmlEscape(B2,P2-B2,hfWithinAttributes);
-         W.AddShort('');
-         inc(P);
-         continue;
-       end;
-       dec(P);
-      end;
-      W.Add('!'); // not a true image
-    end;
-    'h': begin
-      ProcessHRef;
-      continue;
-    end;
-    ':': begin
-      ProcessEmoji;
-      continue;
-    end;
-    end;
-    inc(P);
-  until false;
-  EndOfParagraph;
-  SetLine(twlNone);
-end;
-
-function HtmlEscapeWiki(const wiki: RawUTF8; esc: TTextWriterHTMLEscape): RawUTF8;
-var temp: TTextWriterStackBuffer;
-    W: TTextWriter;
-begin
-  W := TTextWriter.CreateOwnedStream(temp);
-  try
-    AddHtmlEscapeWiki(W,pointer(wiki),esc);
-    W.SetText(result);
-  finally
-    W.Free;
-  end;
-end;
-
-function HtmlEscapeMarkdown(const md: RawUTF8; esc: TTextWriterHTMLEscape): RawUTF8;
-var temp: TTextWriterStackBuffer;
-    W: TTextWriter;
-begin
-  W := TTextWriter.CreateOwnedStream(temp);
-  try
-    AddHtmlEscapeMarkdown(W,pointer(md),esc);
-    W.SetText(result);
-  finally
-    W.Free;
-  end;
-end;
-
-procedure AddHtmlEscapeWiki(W: TTextWriter; P: PUTF8Char; esc: TTextWriterHTMLEscape);
-var doesc: TTextWriterEscape;
-begin
-  doesc.AddHtmlEscapeWiki(W,P,esc);
-end;
-
-procedure AddHtmlEscapeMarkdown(W: TTextWriter; P: PUTF8Char; esc: TTextWriterHTMLEscape);
-var doesc: TTextWriterEscape;
-begin
-  doesc.AddHtmlEscapeMarkdown(W,P,esc);
-end;
-
-
-function EmojiFromText(P: PUTF8Char; len: PtrInt): TEmoji;
-begin // RTTI has shortstrings in adjacent L1 cache lines -> faster than EMOJI_TEXT[]
-  result := TEmoji(FindShortStringListTrimLowerCase(EMOJI_RTTI,ord(high(TEmoji))-1,P,len)+1);
-end;
-
-function EmojiParseDots(var P: PUTF8Char; W: TTextWriter): TEmoji;
-var c: PUTF8Char;
-begin
-  result := eNone;
-  inc(P); // ignore trailing ':'
-  c := P;
-  if c[-2]<=' ' then begin
-    if (c[1]<=' ') and (c^ in ['('..'|']) then
-      result := EMOJI_AFTERDOTS[c^]; // e.g. :)
-    if result=eNone then begin
-      while c^ in ['a'..'z','A'..'Z','_'] do
-        inc(c);
-      if (c^=':') and (c[1]<=' ') then // try e.g. :joy_cat:
-        result := EmojiFromText(P,c-P);
-    end;
-    if result<>eNone then begin
-      P := c+1; // continue parsing after the Emoji text
-      if W<>nil then
-        W.AddNoJSONEscape(pointer(EMOJI_UTF8[result]),4);
-      exit;
-    end;
-  end;
-  if W<>nil then
-    W.Add(':');
-end;
-
-procedure EmojiToDots(P: PUTF8Char; W: TTextWriter);
-var B: PUTF8Char;
-    c: cardinal;
-begin
-  if (P<>nil) and (W<>nil) then
-    repeat
-      B := P;
-      while (P^<>#0) and (PWord(P)^<>$9ff0) do
-        inc(P);
-      W.AddNoJSONEscape(B,P-B);
-      if P^=#0 then
-        break;
-      B := P;
-      c := NextUTF8UCS4(P)-$1f5ff;
-      if c<=cardinal(high(TEmoji)) then
-        W.AddNoJSONEscapeUTF8(EMOJI_TAG[TEmoji(c)]) else
-        W.AddNoJSONEscape(B,P-B);
-    until P^=#0;
-end;
-
-function EmojiToDots(const text: RawUTF8): RawUTF8;
-var W: TTextWriter;
-    tmp: TTextWriterStackBuffer;
-begin
-  if PosExChar(#$f0,text)=0 then begin
-    result := text; // no UTF-8 smiley for sure
-    exit;
-  end;
-  W := TTextWriter.CreateOwnedStream(tmp);
-  try
-    EmojiToDots(pointer(text),W);
-    W.SetText(result);
-  finally
-    W.Free;
-  end;
-end;
-
-procedure EmojiFromDots(P: PUTF8Char; W: TTextWriter);
-var B: PUTF8Char;
-begin
-  if (P<>nil) and (W<>nil) then
-    repeat
-      B := P;
-      while not(P^ in [#0,':']) do
-        inc(P);
-      W.AddNoJSONEscape(B,P-B);
-      if P^=#0 then
-        break;
-      EmojiParseDots(P,W);
-    until P^=#0;
-end;
-
-function EmojiFromDots(const text: RawUTF8): RawUTF8;
-var W: TTextWriter;
-    tmp: TTextWriterStackBuffer;
-begin
-  W := TTextWriter.CreateOwnedStream(tmp);
-  try
-    EmojiFromDots(pointer(text),W);
-    W.SetText(result);
-  finally
-    W.Free;
-  end;
-end;
-
-
-{ ************ Command Line and Console process ************************** }
-
-var
-  TextAttr: integer = ord(ccDarkGray);
-
-{$I-}
-{$ifdef MSWINDOWS}
-
-procedure InitConsole;
-begin
- StdOut := GetStdHandle(STD_OUTPUT_HANDLE);
- if StdOut=INVALID_HANDLE_VALUE then
-   StdOut := 0;
-end;
-
-procedure TextColor(Color: TConsoleColor);
-var oldAttr: integer;
-begin
-  if StdOut=0 then
-    InitConsole;
-  oldAttr := TextAttr;
-  TextAttr := (TextAttr and $F0) or ord(Color);
-  if TextAttr<>oldAttr then
-    SetConsoleTextAttribute(StdOut,TextAttr);
-end;
-
-procedure TextBackground(Color: TConsoleColor);
-var oldAttr: integer;
-begin
-  if StdOut=0 then
-    InitConsole;
-  oldAttr := TextAttr;
-  TextAttr := (TextAttr and $0F) or (ord(Color) shl 4);
-  if TextAttr<>oldAttr then
-    SetConsoleTextAttribute(StdOut,TextAttr);
-end;
-
-function ConsoleKeyPressed(ExpectedKey: Word): Boolean;
-var lpNumberOfEvents: DWORD;
-    lpBuffer: TInputRecord;
-    lpNumberOfEventsRead : DWORD;
-    nStdHandle: THandle;
-begin
-  result := false;
-  nStdHandle := GetStdHandle(STD_INPUT_HANDLE);
-  lpNumberOfEvents := 0;
-  GetNumberOfConsoleInputEvents(nStdHandle,lpNumberOfEvents);
-  if lpNumberOfEvents<>0 then begin
-    PeekConsoleInput(nStdHandle,lpBuffer,1,lpNumberOfEventsRead);
-    if lpNumberOfEventsRead<>0 then
-      if lpBuffer.EventType=KEY_EVENT then
-        if lpBuffer.Event.KeyEvent.bKeyDown and
-           ((ExpectedKey=0) or (lpBuffer.Event.KeyEvent.wVirtualKeyCode=ExpectedKey)) then
-          result := true else
-          FlushConsoleInputBuffer(nStdHandle) else
-        FlushConsoleInputBuffer(nStdHandle);
-  end;
-end;
-
-procedure ConsoleWaitForEnterKey;
-{$ifdef DELPHI5OROLDER}
-begin
-  readln;
-end;
-{$else}
-var msg: TMsg;
-begin
-  while not ConsoleKeyPressed(VK_RETURN) do begin
-    {$ifndef LVCL}
-    if GetCurrentThreadID=MainThreadID then
-      CheckSynchronize{$ifdef WITHUXTHEME}(1000){$endif}  else
-    {$endif}
-      WaitMessage;
-    while PeekMessage(msg,0,0,0,PM_REMOVE) do
-      if Msg.Message=WM_QUIT then
-        exit else begin
-        TranslateMessage(Msg);
-        DispatchMessage(Msg);
-      end;
-  end;
-end;
-{$endif DELPHI5OROLDER}
-
-function Utf8ToConsole(const S: RawUTF8): RawByteString;
-begin
-  result := TSynAnsiConvert.Engine(CP_OEMCP).UTF8ToAnsi(S);
-end;
-
-{$else MSWINDOWS}
-
-// we bypass crt.pp since this unit cancels the SIGINT signal
-
-procedure TextColor(Color: TConsoleColor);
-const AnsiTbl : string[8]='04261537';
-begin
-{$ifdef FPC}{$ifdef Linux}
-  if not stdoutIsTTY then
-    exit;
-{$endif}{$endif}
-  if ord(color)=TextAttr then
-    exit;
-  TextAttr := ord(color);
-  if ord(color)>=8 then
-    write(#27'[1;3',AnsiTbl[(ord(color) and 7)+1],'m') else
-    write(#27'[0;3',AnsiTbl[(ord(color) and 7)+1],'m');
-  ioresult;
-end;
-
-procedure TextBackground(Color: TConsoleColor);
-begin // not implemented yet - but not needed either
-end;
-
-procedure ConsoleWaitForEnterKey;
-var c: AnsiChar;
-begin
-  {$ifdef FPC}
-  if IsMultiThread and (GetCurrentThreadID=MainThreadID) then
-    repeat
-      CheckSynchronize(100);
-      if UnixKeyPending then
-        repeat
-          c := #0;
-          if FpRead(StdInputHandle,c,1)<>1 then
-            break;
-          if c in [#10,#13] then
-            exit;
-        until false;
-    until false else
-  {$endif FPC}
-    ReadLn;
-end;
-
-function Utf8ToConsole(const S: RawUTF8): RawByteString;
-begin
-  result := S; // expect a UTF-8 console under Linux/BSD
-end;
-
-{$endif MSWINDOWS}
-
-function ConsoleReadBody: RawByteString;
-var len, n: integer;
-    P: PByte;
-    {$ifndef FPC}StdInputHandle: THandle;{$endif}
-begin
-  result := '';
-  {$ifdef MSWINDOWS}
-  {$ifndef FPC}StdInputHandle := GetStdHandle(STD_INPUT_HANDLE);{$endif}
-  if not PeekNamedPipe(StdInputHandle,nil,0,nil,@len,nil) then
-  {$else}
-  if fpioctl(StdInputHandle,FIONREAD,@len)<0 then
-  {$endif}
-    len := 0;
-  SetLength(result,len);
-  P := pointer(result);
-  while len>0 do begin
-    n := FileRead(StdInputHandle,P^,len);
-    if n<=0 then begin
-      result := ''; // read error
-      break;
-    end;
-    dec(len,n);
-    inc(P,n);
-  end;
-end;
-
-function StringToConsole(const S: string): RawByteString;
-begin
-  result := Utf8ToConsole(StringToUTF8(S));
-end;
-
-procedure ConsoleWrite(const Text: RawUTF8; Color: TConsoleColor; NoLineFeed, NoColor: boolean);
-begin
-  if not NoColor then
-    TextColor(Color);
-  write(Utf8ToConsole(Text));
-  if not NoLineFeed then
-    writeln;
-  ioresult;
-end;
-
-procedure ConsoleWrite(const Fmt: RawUTF8; const Args: array of const;
-  Color: TConsoleColor; NoLineFeed: boolean);
-var tmp: RawUTF8;
-begin
-  FormatUTF8(Fmt,Args,tmp);
-  ConsoleWrite(tmp,Color,NoLineFeed);
-end;
-
-procedure ConsoleShowFatalException(E: Exception; WaitForEnterKey: boolean);
-begin
-  ConsoleWrite(#13#10'Fatal exception ',cclightRed,true);
-  ConsoleWrite('%',[E.ClassName],ccWhite,true);
-  ConsoleWrite(' raised with message ',ccLightRed,true);
-  ConsoleWrite('%',[E.Message],ccLightMagenta);
-  TextColor(ccLightGray);
-  if WaitForEnterKey then begin
-    writeln(#13#10'Program will now abort');
-    {$ifndef LINUX}
-    writeln('Press [Enter] to quit');
-    if ioresult=0 then
-      Readln;
-    {$endif}
-  end;
-  ioresult;
-end;
-{$I+}
-
-
-{$ifndef NOVARIANTS}
-
-{ TCommandLine }
-
-constructor TCommandLine.Create;
-var i: integer;
-    p, sw: RawUTF8;
-begin
-  inherited Create;
-  fValues.InitFast(ParamCount shr 1,dvObject);
-  for i := 1 to ParamCount do begin
-    p := StringToUTF8(ParamStr(i));
-    if p<>'' then
-      if p[1] in ['-','/'] then begin
-        if sw<>'' then
-          fValues.AddValue(sw,true); // -flag -switch value -> flag=true
-        sw := LowerCase(copy(p,2,100));
-        if sw='noprompt' then begin
-          fNoPrompt := true;
-          sw := '';
-        end;
-      end else
-        if sw<>'' then begin
-          fValues.AddValueFromText(sw,p,true);
-          sw := '';
-        end;
-  end;
-  if sw<>'' then
-    fValues.AddValue(sw,true); // trailing -flag
-end;
-
-constructor TCommandLine.Create(const switches: variant; aNoConsole: boolean);
-begin
-  inherited Create;
-  fValues.InitCopy(switches,JSON_OPTIONS_FAST);
-  fNoPrompt := true;
-  fNoConsole := aNoConsole;
-end;
-
-constructor TCommandLine.Create(const NameValuePairs: array of const; aNoConsole: boolean);
-begin
-  inherited Create;
-  fValues.InitObject(NameValuePairs,JSON_OPTIONS_FAST);
-  fNoPrompt := true;
-  fNoConsole := aNoConsole;
-end;
-
-constructor TCommandLine.CreateAsArray(firstParam: integer);
-var i: integer;
-begin
-  inherited Create;
-  fValues.InitFast(ParamCount,dvArray);
-  for i := firstParam to ParamCount do
-    fValues.AddItem(ParamStr(i));
-end;
-
-function TCommandLine.NoPrompt: boolean;
-begin
-  result := fNoPrompt;
-end;
-
-function TCommandLine.ConsoleText(const LineFeed: RawUTF8): RawUTF8;
-begin
-  result := RawUTF8ArrayToCSV(fLines,LineFeed);
-end;
-
-procedure TCommandLine.SetNoConsole(value: boolean);
-begin
-  if value=fNoConsole then
-    exit;
-  if value then
-    fNoPrompt := true;
-  fNoConsole := false;
-end;
-
-procedure TCommandLine.TextColor(Color: TConsoleColor);
-begin
-  if not fNoPrompt then
-    SynTable.TextColor(Color);
-end;
-
-procedure TCommandLine.Text(const Fmt: RawUTF8; const Args: array of const;
-  Color: TConsoleColor);
-var msg: RawUTF8;
-begin
-  FormatUTF8(Fmt,Args,msg);
-  {$I-}
-  if msg<>'' then begin
-    TextColor(Color);
-    AddRawUTF8(fLines,msg);
-    if not fNoConsole then
-      write(Utf8ToConsole(msg));
-  end;
-  if not fNoConsole then begin
-    writeln;
-    ioresult;
-  end;
-  {$I+}
-end;
-
-function TCommandLine.AsUTF8(const Switch, Default: RawUTF8;
-  const Prompt: string): RawUTF8;
-var i: integer;
-begin
-  i := fValues.GetValueIndex(Switch);
-  if i>=0 then begin // found
-    VariantToUTF8(fValues.Values[i],result);
-    fValues.Delete(i);
-    exit;
-  end;
-  result := Default;
-  if fNoPrompt or (Prompt='') then
-    exit;
-  TextColor(ccLightGray);
-  {$I-}
-  writeln(Prompt);
-  if ioresult<>0 then
-    exit; // no console -> no prompt
-  TextColor(ccCyan);
-  write(Switch);
-  if Default<>'' then
-    write(' [',Default,'] ');
-  write(': ');
-  TextColor(ccWhite);
-  readln(result);
-  writeln;
-  ioresult;
-  {$I+}
-  TextColor(ccLightGray);
-  result := trim(result);
-  if result='' then
-    result := Default;
-end;
-
-function TCommandLine.AsInt(const Switch: RawUTF8; Default: Int64;
-  const Prompt: string): Int64;
-var res: RawUTF8;
-begin
-  res := AsUTF8(Switch, Int64ToUtf8(Default), Prompt);
-  result := GetInt64Def(pointer(res),Default);
-end;
-
-function TCommandLine.AsDate(const Switch: RawUTF8; Default: TDateTime;
-  const Prompt: string): TDateTime;
-var res: RawUTF8;
-begin
-  res := AsUTF8(Switch, DateTimeToIso8601Text(Default), Prompt);
-  if res='0' then begin
-    result := 0;
-    exit;
-  end;
-  result := Iso8601ToDateTime(res);
-  if result=0 then
-    result := Default;
-end;
-
-function TCommandLine.AsEnum(const Switch, Default: RawUTF8; TypeInfo: pointer;
-  const Prompt: string): integer;
-var res: RawUTF8;
-begin
-  res := AsUTF8(Switch, Default, Prompt);
-  if not ToInteger(res,result) then
-    result := GetEnumNameValue(TypeInfo,pointer(res),length(res),true);
-end;
-
-function TCommandLine.AsArray: TRawUTF8DynArray;
-begin
-  fValues.ToRawUTF8DynArray(result);
-end;
-
-function TCommandLine.AsJSON(Format: TTextWriterJSONFormat): RawUTF8;
-begin
-  result := fValues.ToJSON('','',Format);
-end;
-
-function TCommandLine.AsString(const Switch: RawUTF8; const Default, Prompt: string): string;
-begin
-  result := UTF8ToString(AsUTF8(Switch,StringToUTF8(Default),Prompt));
-end;
-
-{$endif NOVARIANTS}
-
-procedure InitInternalTables;
-var e: TEmoji;
-begin
-  {$ifdef MSWINDOWS}
-  InitWindowsAPI;
-  {$else}
-  stdoutIsTTY := IsATTY(StdOutputHandle)=1;
-  {$endif MSWINDOWS}
-  SetLength(JSON_SQLDATE_MAGIC_TEXT,3);
-  PCardinal(pointer(JSON_SQLDATE_MAGIC_TEXT))^ := JSON_SQLDATE_MAGIC;
-  Assert(ord(high(TEmoji))=$4f+1);
-  EMOJI_RTTI := GetEnumName(TypeInfo(TEmoji),1); // ignore eNone=0
-  GetEnumTrimmedNames(TypeInfo(TEmoji),@EMOJI_TEXT);
-  EMOJI_TEXT[eNone] := '';
-  for e := succ(low(e)) to high(e) do begin
-    LowerCaseSelf(EMOJI_TEXT[e]);
-    EMOJI_TAG[e] := ':'+EMOJI_TEXT[e]+':';
-    SetLength(EMOJI_UTF8[e],4);
-    UCS4ToUTF8(ord(e)+$1f5ff,pointer(EMOJI_UTF8[e]));
-  end;
-  EMOJI_AFTERDOTS[')'] := eSmiley;
-  EMOJI_AFTERDOTS['('] := eFrowning;
-  EMOJI_AFTERDOTS['|'] := eExpressionless;
-  EMOJI_AFTERDOTS['/'] := eConfused;
-  EMOJI_AFTERDOTS['D'] := eLaughing;
-  EMOJI_AFTERDOTS['o'] := eOpen_mouth;
-  EMOJI_AFTERDOTS['O'] := eOpen_mouth;
-  EMOJI_AFTERDOTS['p'] := eYum;
-  EMOJI_AFTERDOTS['P'] := eYum;
-  EMOJI_AFTERDOTS['s'] := eScream;
-  EMOJI_AFTERDOTS['S'] := eScream;
-  DoIsValidUTF8 := IsValidUTF8Pas;
-  DoIsValidUTF8Len := IsValidUTF8LenPas;
-  {$ifdef ASMX64AVX}
-  if CpuFeatures * [cfAVX2, cfSSE42, cfBMI1, cfBMI2, cfCLMUL] =
-                   [cfAVX2, cfSSE42, cfBMI1, cfBMI2, cfCLMUL] then begin
-    // Haswell CPUs can use simdjson AVX2 asm for IsValidUtf8()
-    DoIsValidUTF8 := IsValidUTF8Avx2;
-    DoIsValidUTF8Len := IsValidUTF8LenAvx2;
-  end;
-  {$endif ASMX64AVX}
-end;
-
-
-initialization
-  Assert(SizeOf(TSynTableFieldType)=1); // as expected by TSynTableFieldProperties
-  Assert(SizeOf(TSynTableFieldOptions)=1);
-  {$ifndef NOVARIANTS}
-  Assert(SizeOf(TSynTableData)=SizeOf(TVarData));
-  {$endif NOVARIANTS}
-  Assert(SizeOf(THTab)=$40000*3); // 786,432 bytes
-  Assert(SizeOf(TSynUniqueIdentifierBits)=SizeOf(TSynUniqueIdentifier));
-  InitInternalTables;
-  TTextWriter.RegisterCustomJSONSerializerFromText([
-    TypeInfo(TDiskPartitions),
-     'name:RawUTF8 mounted:string size:QWord',
-    TypeInfo(TSystemUseDataDynArray),
-     'Timestamp:TDateTime Kernel,User:single WorkDB,VirtualKB:cardinal']);
-end.
-
diff --git a/lib/dmustache/Synopse.inc b/lib/dmustache/Synopse.inc
deleted file mode 100644
index 626b7321..00000000
--- a/lib/dmustache/Synopse.inc
+++ /dev/null
@@ -1,736 +0,0 @@
-{
-    This file is part of Synopse framework.
-
-    Synopse framework. Copyright (C) 2022 Arnaud Bouchez
-      Synopse Informatique - https://synopse.info
-
-  *** BEGIN LICENSE BLOCK *****
-  Version: MPL 1.1/GPL 2.0/LGPL 2.1
-
-  The contents of this file are subject to the Mozilla Public License Version
-  1.1 (the "License"); you may not use this file except in compliance with
-  the License. You may obtain a copy of the License at
-  http://www.mozilla.org/MPL
-
-  Software distributed under the License is distributed on an "AS IS" basis,
-  WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
-  for the specific language governing rights and limitations under the License.
-
-  The Original Code is Synopse framework.
-
-  The Initial Developer of the Original Code is Arnaud Bouchez.
-
-  Portions created by the Initial Developer are Copyright (C) 2022
-  the Initial Developer. All Rights Reserved.
-
-  Contributor(s):
-   Alfred Glaenzer (alf)
-
-  Alternatively, the contents of this file may be used under the terms of
-  either the GNU General Public License Version 2 or later (the "GPL"), or
-  the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
-  in which case the provisions of the GPL or the LGPL are applicable instead
-  of those above. If you wish to allow use of your version of this file only
-  under the terms of either the GPL or the LGPL, and not to allow others to
-  use your version of this file under the terms of the MPL, indicate your
-  decision by deleting the provisions above and replace them with the notice
-  and other provisions required by the GPL or the LGPL. If you do not delete
-  the provisions above, a recipient may use your version of this file under
-  the terms of any one of the MPL, the GPL or the LGPL.
-
-  ***** END LICENSE BLOCK *****
-}
-
-
-(********************** User-Trigerred Conditionals **********************)
-
-{  Those conditionals below can be enabled in your project Options,
-   to tune the compilation depending your setup or your project expectations. }
-
-{.$define PUREPASCAL}
-// define this if your compiler doesn't support Delphi's x86 asm
-// - is set automaticaly in case of a 64 bits compiler (only FPC exists now)
-
-{$define USENORMTOUPPER}
-// if defined, text functions will use the NormToUpper[] array, as defined
-// in our custom SysUtils.pas (not the LVCL version) -> when using LVCL,
-// define the global LVCL compiler directive, and this unit will initialize
-// its own NormToUpper[] array
-// -> define ENHANCEDRTL conditional below if our Enhanced RTL IS installed
-// -> in practice, this conditional is ALWAYS DEFINED, since needed by SQLite3
-
-{.$define ENHANCEDRTL}
-// define this if you DID install our Enhanced Runtime library or the LVCL:
-// - it's better to define this conditional globaly in the Project/Options window
-// - we need to hack the "legacy" LoadResString() procedure and add a
-//   LoadResStringTranslate() function, for on the fly resourcestring i18n
-// - it will also define the TwoDigitLookup[] array and some very fast x86 asm
-//   IntToStr() and other functions, available in our Enhanced Runtime library
-//   (and our LVCL library)
-// - it will be unset automaticaly (see below) for Delphi 2009 and up
-// - this conditional must be defined in both SQLite3Commons and SQLite3i18n units,
-//   or (even better) globally in the Project options
-
-{.$define USEPACKAGES}
-// define this if you compile the unit within a Delphi package
-// - it will avoid error like "[DCC Error] E2201 Need imported data reference ($G)
-//   to access 'VarCopyProc' from unit 'SynCommons'"
-// - shall be set at the package options level, and left untouched by default
-// - note: you should probably also set "Generate DCUs only" in Project Options
-// -> Delphi Compiler -> Output C/C++ -> C/C++ output file generation
-
-{.$define DOPATCHTRTL}
-// if defined, some low-level patches are applied to Delphi or FPC RTL
-// - you should better use it, but we have unset it by default
-
-{.$define NEWRTTINOTUSED}
-// if defined, the new RTTI (available since Delphi 2010) won't be linked to
-// the executable: resulting file size will be much smaller, and mORMot won't
-// be affected (unless you use the enhanced RTTI for record/dynamic array JSON
-// serialization) - left undefined by default to ensure minimal impact
-
-{.$define NOSETTHREADNAME}
-// if defined, SetThreadName() would not raise the exception used to set the
-// thread name: to be defined if you have issues when debugging your application
-
-{.$define NOEXCEPTIONINTERCEPT}
-// if defined, exceptions shall not be intercepted and logged
-
-{.$define USELOCKERDEBUG}
-// by default, some IAutoLocker instances would use TAutoLocker, unless this
-// conditional is defined to use more verbose TAutoLockerDebug
-// (may be used for race condition debugging, in multi-threaded apps)
-
-{.$define OLDTEXTWRITERFORMAT}
-// force TTextWriter.Add(Format) to handle the alternate deprecated $ % tags
-
-{.$define FORCE_STRSSE42}
-// sse4.2 string instructions may read up to 16 bytes after the actual end buffer
-// -> define this if you want StrLen/StrComp/strspn/strcspn to use SSE4.2 opcodes
-// but you would eventually experiment weird random GPF in your project, raising
-// unexpected SIGABRT/SIGSEGV under POSIX system: so is disabled below for our
-// LINUX conditional - and use at your own risk under Windows!
-
-{.$define DISABLE_SSE42}
-// if defined, no SSE4.2 nor AES-NI instruction will be used, i.e. disable
-// FORCE_STRSSE42 and all crc32c opcodes - is set for FPC DARWIN target
-
-{.$define WITH_ERMS}
-// you may define this to enable REP MOVSB/STOSB for Fillchar/Move if cfERMS
-// flag is available in Intel's CpuFeatures
-// -> disabled by default, since in practice it is (much) slower for small blocks
-
-{.$define NOXPOWEREDNAME}
-// define this to avoid sending "X-Powered-By: Synopse mORMot" HTTP header
-
-{.$define SQLVIRTUALLOGS}
-// enable low-level logging of SQlite3 virtual table query planner costs
-// -> to be defined only for internal debugging
-
-{.$define NOSYNDBZEOS}
-// made SynDBZeos.pas a "void" unit - defined for FPC/Lazarus packages only
-
-{.$define DDDNOSYNDB}
-// SynDB / external SQL DB won't be linked to the executable by dddInfraSettings
-{.$define DDDNOMONGODB}
-// Mongo DB client won't be linked to the executable by dddInfraSettings
-
-
-{$ifdef FPC}
-
-(********************** FPC Conditionals **********************)
-
-{ Free Pascal adaptation notes:
-  - we use the Delphi compatibility mode
-  - from system.pp use these constants (Win32/64 values listed):
-      LineEnding = #13#10;
-      DirectorySeparator = '\';
-  - for Cross-Platform and all CPU:
-      integer is NOT CPU-dependent (thanks to objpas), i.e. always 32 bits
-      cardinal is NOT CPU-dependent (thanks to objpas), i.e. always 32 bits
-      PtrUInt is an unsigned integer type of same size as a pointer / register
-        -> must be used for pointer arithmetic
-        -> may be used in loops
-      PtrInt is a signed integer type of same size as a pointer / register
-        -> must be used for pointer arithmetic
-        -> may be used in loops
-      all 32 bits x86 asm code is replaced by a pascal only version, if the
-      conditional PUREPASCAL is defined (e.g. for CPUX64)
-}
-
-  {$ifndef FPC_DELPHI}
-    {$MODE DELPHI} // e.g. for asm syntax - disabled for FPC 2.6 compatibility
-  {$endif}
-
-  {$INLINE ON}
-  {$MINENUMSIZE 1}
-  {$PACKRECORDS DEFAULT} // force normal alignment
-  {$PACKSET 1}
-  {$PACKENUM 1}
-  {$CODEPAGE UTF8} // otherwise unexpected behavior occurs in most cases
-
-  {$undef ENHANCEDRTL}    // there is no version of our Enhanced RTL for FPC
-  {$define HASINLINE}
-  {$define HASUINT64}
-  {$define HASINLINENOTX86}
-  {$define NODELPHIASM}   // ignore low-level System.@LStrFromPCharLen calls
-  {$define HASTTHREADSTART}
-  {$define HASINTERFACEASTOBJECT}
-  {$define EXTENDEDTOSHORT_USESTR} // FloatToText uses str() in FPC
-  {$define DOUBLETOSHORT_USEGRISU} // fast double to text
-  {$define DELPHI5ORFPC}
-  {$define FPC_OR_PUREPASCAL}
-  {$define FPC_OR_KYLIX}
-  {$define FPC_OR_UNICODE}
-  {$define USERECORDWITHMETHODS}
-  {$define FPC_OR_DELPHIXE}
-  {$define FPC_OR_DELPHIXE4}
-  {$define FPC_ENUMHASINNER}
-  {$define USE_VTYPE_STATIC} // in our inlined VarClear()
-
-  // $if FPC_FULLVERSION>20700 breaks Delphi 6-7 and SynProject :(
-  {$ifdef VER2_7}
-    {$define ISFPC27}
-  {$endif}
-  {$ifdef VER3_0}
-    {$define ISFPC27}
-    {$define ISFPC30}
-    {$define HASDIRECTTYPEINFO}
-    // PTypeInfo would be stored with no pointer de-reference
-    // => Delphi and newer FPC uses a pointer reference to ease exe linking
-  {$endif}
-  {$ifdef VER3_1} // trunk before 3.2
-    {$define ISFPC27}
-    {$define ISFPC30}
-    {.$define HASDIRECTTYPEINFO}
-    // define this for trunk revisions older than June 2016 - see
-    // http://wiki.freepascal.org/User_Changes_Trunk#RTTI_Binary_format_change
-  {$endif}
-  {$ifdef VER3_1_1} // if FPC_FULLVERSION>30100 ... ifend is not Delphi 5 compatible :(
-    {$define ISFPC32}
-  {$endif}
-  {$ifdef VER3_2}
-    {$define ISFPC27}
-    {$define ISFPC30}
-    {$define ISFPC32}
-    {$ifdef VER3_2_2}
-      {$define HASTTHREADTERMINATESET} // introduced TThread.TerminateSet
-    {$endif VER3_2_2}
-  {$endif}
-  {$ifdef VER3_3} // trunk before 3.4
-    {$define ISFPC27}
-    {$define ISFPC30}
-    {$define ISFPC32}
-    {$define HASTTHREADTERMINATESET} // introduced TThread.TerminateSet
-  {$endif}
-  {$ifdef VER3_4}
-    {$define ISFPC27}
-    {$define ISFPC30}
-    {$define ISFPC32}
-    {$define ISFPC34}
-    {$define FPC_PROVIDE_ATTR_TABLE} // introducing TTypeData.AttributeTable
-    {$define STRCNT32} // 32-bit TAnsiRec.RefCnt even on 64-bit CPU
-    {$define HASTTHREADTERMINATESET} // introduced TThread.TerminateSet
-  {$endif}
-  {$if not defined(VER3_0) and not defined(VER3_2) and not defined(VER2)}
-    {.$define FPC_PROVIDE_ATTR_TABLE} // to be defined since SVN 42356-42411
-    // on compilation error in SynFPCTypInfo, undefine the above conditional
-    // see https://lists.freepascal.org/pipermail/fpc-announce/2019-July/000612.html
-    {$define STRCNT32} // 32-bit TAnsiRec.RefCnt even on 64-bit CPU
-    // see https://gitlab.com/freepascal.org/fpc/source/-/issues/38018
-  {$ifend}
-
-  {$ifdef ANDROID}
-    {$define LINUX} // a Linux-based system
-  {$endif}
-
-  // define FPCSQLITE3STATIC to enable static-linked SQLite3 engine for FPC
-  // -> expect *.o files download from https://synopse.info/files/sqlite3fpc.7z
-  // -> could be disabled to force external .so/.dll linking
-  {$ifdef MSWINDOWS}
-  {$ifdef CPUX86}
-    {$define FPCSQLITE3STATIC}   // use static\i386-win32\sqlite3.o
-  {$else}
-    {$define FPCSQLITE3STATIC}   // use static\x86_64-win64\sqlite3.o
-  {$endif}
-  {$endif}
-  {$ifdef LINUX}
-    {$ifdef CPUX86}
-      {$define FPCSQLITE3STATIC} // use static/i386-linux\sqlite3.o
-    {$endif}
-    {$ifdef CPUX64}
-      {$define FPCSQLITE3STATIC} // use static/x86_64-linux\sqlite3.o
-    {$endif}
-    {$ifdef CPUARM}
-      {$define FPCSQLITE3STATIC} // use static/arm-linux\sqlite3.o
-    {$endif}
-    {$ifdef CPUAARCH64}
-      {$define FPCSQLITE3STATIC} // use:static/aarch64-linux\sqlite3.o
-    {$endif}
-  {$endif}
-
-  {$ifdef BSD}
-    // LINUX conditional includes Darwin and BSD family like FreeBSD
-    {$define LINUX} // not true, but a POSIX/BSD system - see LINUXNOTBSD
-    {$undef FORCE_STRSSE42}  // fails otherwise for sure
-    {$define ABSOLUTEPASCAL} // NO asm nor redirection (until stabilized)
-    {$ifdef DARWIN}
-      {$define FPCSQLITE3STATIC} // we supply Darwin static libs
-      {$ifdef CPUINTEL}
-        {$define FPC_PIC} // may have not be defined by the compiler options
-      {$endif}
-    {$else}
-      {$define BSDNOTDARWIN}   // OSX has some non-standard API calls
-    {$endif}
-    {$ifdef FREEBSD}
-      {$ifdef CPUX86}
-        {$define FPCSQLITE3STATIC} // we supply i386 static libs
-      {$endif CPUX86}
-      {$ifdef CPUX64}
-        {$define FPCSQLITE3STATIC} // we supply x64 static libs
-      {$endif CPUX64}
-    {$endif}
-    {$ifdef OPENBSD}
-      {$ifdef CPUX86}
-        {$define FPCSQLITE3STATIC} // we supply i386 static libs
-      {$endif CPUX86}
-      {$ifdef CPUX64}
-        {$define FPCSQLITE3STATIC} // we supply x64 static libs
-      {$endif CPUX64}
-    {$endif}
-  {$else}
-    {$ifdef LINUX}
-      {$define LINUXNOTBSD} // e.g. to disable epoll API
-      {$define FPCLINUXNOTBSD}
-    {$endif}
-  {$endif}
-
-  {$ifdef LINUX}
-     {$undef FORCE_STRSSE42}  // avoid fatal SIGABRT/SIGSEGV on POSIX systems
-     {$define FPCLINUX}
-     {$ifdef CPUX64}
-       {$define CPUX64LINUX}  // e.g. for tuned server-side asm
-     {$endif CPUX64}
-  {$endif}
-  {$ifdef FPC_PIC}
-    {$define PUREPASCAL} // most asm code is not PIC-safe with global constants
-  {$endif}
-
-  {$ifdef MSWINDOWS}
-    {$ifdef FPC_X64MM}
-      {$ifndef FPC_X64MM_WIN} // SynFPCx64MM not yet fully validated on Windows
-         {$undef FPC_X64MM}
-      {$endif FPC_X64MM_WIN}
-    {$endif FPC_X64MM}
-  {$endif MSWINDOWS}
-
-  {$ifdef CPU64}
-    {$define FPC_64}
-    {$define PUREPASCAL} // e.g. x64, AARCH64
-    {$ifdef CPUX64}
-      {$define CPUINTEL}
-      {$define FPC_CPUINTEL}
-      {$ifndef BSD}
-        {$define CPUX64ASM} // Delphi XE4 or Darwin asm are buggy :(
-        {$define ASMX64AVX} // only FPC supports AVX/AVX2/AVX512
-        {$define HASAESNI}  // SynCrypto rejected by Darwin asm
-      {$endif BSD}
-      {$define FPC_X64}   // supports AVX/AVX2/AVX512 - which Delphi doesn't
-      {$ASMMODE INTEL}    // to share asm code with Delphi
-    {$endif CPUX64}
-    {$ifdef CPUAARCH64}
-      {$define CPUARM3264}
-    {$endif CPUAARCH64}
-  {$else}
-    {$define FPC_32}
-    {$define STRCNT32} // 32-bit TAnsiRec.RefCnt on 32-bit CPU
-    {$define DACNT32}  // 32-bit dynarray refcnt on 32-bit CPU
-    {$ifdef CPUARM}
-      {$define PUREPASCAL} // ARM32
-      {$define CPUARM3264}
-    {$endif CPUARM}
-    {$ifdef CPUX86}
-      {$define CPUINTEL}
-      {$define FPC_CPUINTEL}
-      {$define FPC_X86}
-      {$define TSYNEXTENDED80} // only 32-bit has a true x87 extended type
-      {$ASMMODE INTEL}   // as Delphi expects
-      {$define HASAESNI} // should be commented to test project with valgrind
-      {$ifndef FPC_PIC}
-        {$define CPUX86NOTPIC} // use "absolute" instead of local register
-      {$endif FPC_PIC}
-      {$ifndef OPENBSD}
-        {$define FPC_X86ASM} // if assembler knows popcnt/crc32c opcodes
-      {$endif OPENBSD}
-    {$endif CPUX86}
-  {$endif CPU64}
-
-  {$ifdef CPUARM3264}
-    {$ifdef BSD}
-      {$undef USE_VTYPE_STATIC} // circumvent bug in VarClear() on BSD + ARM
-    {$endif BSD}
-  {$endif CPUARM3264}
-
-  {$ifdef ISFPC30}
-    {$ifndef MSWINDOWS}
-      // define FPCUSEVERSIONINFO to link low-level executable file information
-      // units in SynCommons.pas
-      // => disabled by default, to reduce the executable overhead
-      {.$define FPCUSEVERSIONINFO}
-    {$endif MSWINDOWS}
-  {$endif ISFPC30}
-
-  {$ifdef ISFPC32}
-    // FPC has its own RTTI layout only since late 3.x
-    {$define FPC_NEWRTTI}
-    // when http://bugs.freepascal.org/view.php?id=26774 has been fixed
-    {$ifdef CPUINTEL}
-      {$define HASINTERFACERTTI}
-    {$endif}
-    {$ifdef CPUARM3264}
-      {$define HASINTERFACERTTI}
-    {$endif}
-  {$endif}
-
-  {$ifdef FPC_NEWRTTI}
-    {$define ISDELPHI2010_OR_FPC_NEWRTTI}
-  {$else}
-    {$define DELPHI_OR_FPC_OLDRTTI}
-    {$define FPC_OLDRTTI}
-  {$endif}
-  {$define ISDELPHI2010_OR_FPC} // eltype2 field
-
-  {$ifdef FPC_HAS_CPSTRING}
-    // see http://wiki.freepascal.org/FPC_Unicode_support
-    {$define HASCODEPAGE} // UNICODE means {$mode delphiunicode}
-  {$endif}
-  {$ifdef ISFPC27}
-    {$define ISFPC271}
-    {$define HASVARUSTRING}
-    {$define HASVARUSTRARG}
-    // defined if the http://mantis.freepascal.org/view.php?id=26773 bug is fixed
-    // you should use 2.7.1/trunk branch in revision 28995 from 2014-11-05T22:17:54
-    // => this will change the TInvokeableVariantType.SetProperty() signature
-    {$define FPC_VARIANTSETVAR}
-  {$endif ISFPC27}
-  {$ifdef FPC_PROVIDE_ATTR_TABLE}
-    {$define HASALIGNTYPEDATA} // to ignore attributes RTTI table
-  {$endif FPC_PROVIDE_ATTR_TABLE}
-  {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
-    {$define FPC_ENUMHASINNER}
-    {$define HASALIGNTYPEDATA} // to ensure proper RTTI alignment
-  {$endif FPC_REQUIRES_PROPER_ALIGNMENT}
-
-
-{$else FPC}
-
-(********************** Delphi Conditionals **********************)
-
-  {$define DELPHI_OR_FPC_OLDRTTI}
-  {$define USE_VTYPE_STATIC} // "and VTYPE_STATIC" test before VarClear()
-  {$define STRCNT32} // always 32-bit TAnsiRec.RefCnt on Delphi
-  {$define DACNT32}  // always 32-bit dynarray refcnt on Delphi
-  {$undef FPC_X64MM} // this is a FPC-specific memory manager
-
-  {$A+} // force normal alignment
-
-  {$ifdef LVCL}
-    {$define OWNNORMTOUPPER} // NormToUpper[] exists only in our enhanced RTL
-    {$define NOVARIANTS} // LVCL does not support variants
-    {$define EXTENDEDTOSHORT_USESTR} // no FloatToText implemented in LVCL
-  {$endif LVCL}
-
-  {$ifdef UNICODE}
-    {$undef ENHANCEDRTL} // Delphi 2009 and up don't have our Enhanced Runtime library
-    {$define HASVARUSTRING}
-    {$define HASCODEPAGE}
-    {$define FPC_OR_UNICODE}
-    {$define USERECORDWITHMETHODS}
-    { due to a bug in Delphi 2009+, we need to fake inheritance of record,
-      since TDynArrayHashed = object(TDynArray) fails to initialize
-      http://blog.synopse.info/post/2011/01/29/record-and-object-issue-in-Delphi-2010 }
-    {$define UNDIRECTDYNARRAY}
-  {$endif UNICODE}
-
-  {$ifndef PUREPASCAL}
-    {$define CPUINTEL} // Delphi only for Intel by now
-  {$endif}
-  {$ifdef CPUX64}
-    {$define CPU64} // Delphi compiler for 64 bit CPU
-    {$define CPU64DELPHI}
-    {$undef CPU32}
-    {$define PUREPASCAL}   // no x86 32 bit asm to be used
-    {$define EXTENDEDTOSHORT_USESTR} // FloatToText() much slower in x64 mode
-    {$define DOUBLETOSHORT_USEGRISU} // fast double to text
-  {$else CPUX64}
-    {$define CPU32} // Delphi compiler for 32 bit CPU
-    {$define CPU32DELPHI}
-    {$undef CPU64}
-    {$define CPUX86} // for compatibility with older versions of Delphi
-    {$define CPUX86NOTPIC} // use "absolute" instead of local register
-    {$define TSYNEXTENDED80} // only 32-bit has a true x87 extended type
-  {$endif CPUX64}
-
-  {$IFDEF CONDITIONALEXPRESSIONS}  // Delphi 6 or newer
-    {$define HASINTERFACERTTI} // interface RTTI (not FPC)
-    {$ifdef LINUX}
-      {$if RTLVersion = 14.5}
-        {$define KYLIX3}
-        {$define FPC_OR_KYLIX}
-        // Kylix 3 will be handled just like Delphi 7
-        {$undef ENHANCEDRTL}   // Enhanced Runtime library not fully tested yet
-        {$define EXTENDEDTOSHORT_USESTR}
-        {$define DOPATCHTRTL}  // nice speed up for server apps
-        {$define NOVARCOPYPROC}
-        {$define NOSQLITE3STATIC} // Kylix will use external sqlite3.so
-        {$define LINUXNOTBSD}     // e.g. to disable epoll API
-      {$else}
-      Kylix1/2 or Delphi Tokyo/ARC are unsupported
-      {$ifend}
-    {$else}
-      {$ifdef VER140}
-        {$define ISDELPHI6ANDUP} // Delphi 6 or newer
-        {$define DELPHI6OROLDER}
-        {$define NOVARCOPYPROC}
-        {$undef ENHANCEDRTL} // Delphi 6 doesn't have our Enhanced Runtime library
-        {$define EXTENDEDTOSHORT_USESTR} // no TFormatSettings before Delphi 7
-      {$else}
-        {$define ISDELPHI7ANDUP} // Delphi 7 or newer
-        {$define WITHUXTHEME}   // VCL handle UI theming
-        {$define HASUINT64}
-        {$warn UNSAFE_CODE OFF} // Delphi for .Net does not exist any more!
-        {$warn UNSAFE_TYPE OFF}
-        {$warn UNSAFE_CAST OFF}
-        {$warn DUPLICATE_CTOR_DTOR OFF} // avoid W1029 unneeded hints
-      {$endif}
-      {$ifdef USEPACKAGES}
-        {$undef DOPATCHTRTL}
-      {$endif}
-    {$endif LINUX}
-    {$if CompilerVersion >= 17}
-      {$define ISDELPHI2005ANDUP} // Delphi 2005 or newer
-      {$if CompilerVersion >= 18}
-        {$define ISDELPHI2006ANDUP} // Delphi 2006 or newer
-        {$define HASNEWFILEAGE}
-        {$define HASINLINE}
-        {$define HASINLINEDELPHI}
-        {$define HASINLINENOTX86}
-        {$define HASREGION}
-        {$define HASFASTMM4}
-        // try to define this so that GetMemoryInfo/TSynMonitorMemory returns
-        // low-level FastMM4 information
-        {.$define WITH_FASTMM4STATS}
-      {$ifend}
-      {$ifdef VER180}
-        {$define ISDELPHI20062007} // to circumvent some specific bugs
-      {$endif}
-      {$ifdef VER185}
-        {$define ISDELPHI20062007}
-      {$endif}
-      {$if CompilerVersion > 18}
-        {$define ISDELPHI2007ANDUP} // Delphi 2007 or newer
-      {$ifend}
-      {$if CompilerVersion = 20}
-        {$define ISDELPHI20092010} // specific compilation issues
-      {$ifend}
-      {$if CompilerVersion = 21}
-        {$define ISDELPHI20092010} //specific compilation issues
-      {$ifend}
-      {$if CompilerVersion >= 21.0}
-        {$define ISDELPHI2010}
-        {$define ISDELPHI2010_OR_FPC} // eltype2 field
-        {$define ISDELPHI2010_OR_FPC_NEWRTTI}
-        {$define HASTTHREADSTART}
-        {$define HASINTERFACEASTOBJECT}
-        {$ifdef NEWRTTINOTUSED} // option reduce EXE size by disabling much RTTI
-          {$WEAKLINKRTTI ON}
-          {$RTTI EXPLICIT METHODS([]) PROPERTIES([]) FIELDS([])}
-        {$endif NEWRTTINOTUSED}
-      {$ifend}
-      {$if CompilerVersion >= 22.0}
-        {$define FPC_OR_DELPHIXE} // Delphi 2007/2009/2010 inlining bugs
-        {$define ISDELPHIXE}
-      {$ifend}
-      {$if CompilerVersion >= 23.0}
-        // Delphi XE2 has some cross-platform features
-        // e.g. {$ifdef ISDELPHIXE2}VCL.Graphics{$else}Graphics{$endif}
-        {$define ISDELPHIXE2}
-        {$define HASVARUSTRARG}
-        {$define HASTTHREADTERMINATESET} // introduced TThread.TerminateSet
-      {$ifend}
-      {$if CompilerVersion >= 24.0}
-        {$define ISDELPHIXE3}
-      {$ifend}
-      {$if CompilerVersion >= 25.0}
-        {$define ISDELPHIXE4}
-        {$define FPC_OR_DELPHIXE4} // circumvent Internal Error: C2130 on XE3
-        {$define HASAESNI}
-      {$ifend}
-      {$if CompilerVersion >= 26.0}
-        {$define ISDELPHIXE5}
-        {$define PUBLISHRECORD}
-        // if defined, will handle RTTI available only since Delphi XE5 for
-        // record published properties
-      {$ifend}
-      {$if CompilerVersion >= 27.0}
-        {$define ISDELPHIXE6}
-      {$ifend}
-      {$if CompilerVersion >= 28.0}
-        {$define ISDELPHIXE7}
-        {$ifdef CPU64}
-          {$define CPUX64ASM} // e.g. Delphi XE4 SSE asm is buggy :(
-        {$endif}
-      {$ifend}
-      {$if CompilerVersion >= 29.0}
-        {$define ISDELPHIXE8}
-      {$ifend}
-      {$if CompilerVersion >= 30.0}
-        {$define ISDELPHI10}
-      {$ifend}
-      {$if CompilerVersion >= 31.0}
-        {$define ISDELPHI101}
-      {$ifend}
-      {$if CompilerVersion >= 32.0}
-        {$define ISDELPHI102}
-        {$ifdef CPUX64}
-        {$ifdef VER320withoutAprilUpdate}
-          // circumvent early Delphi 10.2 Tokyo Win64 compiler bug
-          {$undef HASINLINE}
-          {$define HASINLINENOTX86}
-        {$endif}
-        {$endif}
-      {$ifend}
-      {$if CompilerVersion >= 33.0}
-        {$define ISDELPHI103}
-      {$ifend}
-      {$if CompilerVersion >= 34.0}
-        {$define ISDELPHI104}
-      {$ifend}
-      {$if CompilerVersion >= 35.0}
-        {$define ISDELPHI11}
-      {$ifend}
-    {$ifend CompilerVersion >= 17}
-    {$ifopt O-} // if we don't expect fast code, don't optimize the framework
-      {$undef ENHANCEDRTL}
-      {$undef DOPATCHTRTL}
-    {$endif}
-  {$ELSE}
-    // Delphi 5 or older
-    {$define DELPHI6OROLDER}
-    {$define DELPHI5OROLDER}
-    {$define DELPHI5ORFPC}
-    {$define MSWINDOWS}
-    {$define NOVARIANTS}
-    {$define NOVARCOPYPROC}
-    {$undef ENHANCEDRTL} // Delphi 5 doesn't have our Enhanced Runtime library
-    {$define EXTENDEDTOSHORT_USESTR} // no TFormatSettings before Delphi 7
-    {$undef DOPATCHTRTL}
-  {$ENDIF CONDITIONALEXPRESSIONS}
-
-{$endif FPC}
-
-
-(********************** Shared Conditionals **********************)
-
-{$ifdef PUREPASCAL}
-  {$define NODELPHIASM}
-  {$define FPC_OR_PUREPASCAL}
-{$else}
-{$endif PUREPASCAL}
-
-{$H+} // we use long strings
-{$R-} // disable Range checking in our code
-{$S-} // disable Stack checking in our code
-{$X+} // expect extended syntax
-{$W-} // disable stack frame generation
-{$Q-} // disable overflow checking in our code
-{$B-} // expect short circuit boolean
-{$V-} // disable Var-String Checking
-{$T-} // Typed @ operator
-{$Z1} // enumerators stored as byte by default
-
-{$ifndef FPC}
-  {$P+} // Open string params
-  {$ifdef VER150}
-    {$WARN SYMBOL_DEPRECATED OFF}
-    {$WARN UNSAFE_TYPE OFF}
-    {$WARN UNSAFE_CODE OFF}
-    {$WARN UNSAFE_CAST OFF}
-  {$ENDIF}
-  {$ifdef CONDITIONALEXPRESSIONS}  // Delphi 6 or newer
-    {$WARN SYMBOL_PLATFORM OFF}
-    {$WARN UNIT_PLATFORM OFF}
-  {$endif}
-{$endif FPC}
-
-{$ifdef CPUINTEL}
-  {$ifdef CPUX86} // safest to reset x87 exceptions
-    {$ifndef PUREPASCAL}
-      {$ifndef DELPHI5OROLDER}
-        {$define RESETFPUEXCEPTION}
-      {$endif}
-    {$endif}
-  {$endif}
-  {$ifdef DISABLE_SSE42}
-    {$undef FORCE_STRSSE42}
-  {$endif DISABLE_SSE42}
-{$else}
-  {$undef HASAESNI} // AES-NI is an Intel-specific feature
-  {$define ABSOLUTEPASCALORNOTINTEL}
-{$endif CPUINTEL}
-
-{$ifdef ABSOLUTEPASCAL}
-  {$define ABSOLUTEORPUREPASCAL}
-  {$define ABSOLUTEPASCALORNOTINTEL}
-  {$define PUREPASCAL}
-{$endif ABSOLUTEPASCAL}
-{$ifdef PUREPASCAL}
-  {$define ABSOLUTEORPUREPASCAL}
-{$endif PUREPASCAL}
-
-{$define WITHLOG}
-// if defined, logging will be supported via the TSQLLog family
-// - should be left defined: TSQLog.Family.Level default setting won't log
-// anything, so there won't be any noticeable performance penalty to have
-// this WITHLOG conditional defined, which is expected by high-level part
-// of the framework, like DDD or UI units
-
-{$ifdef FPC}
-  {$ifndef FPCSQLITE3STATIC} // see above about this FPC-specific conditional
-    {$define NOSQLITE3STATIC}
-  {$endif}
-{$else}
-  // there is a linking bug with Delphi XE4 on Win64
-  {$ifdef CPUX64}
-    {$if CompilerVersion = 25.0} // exactly XE4
-      {$define NOSQLITE3STATIC}
-      // :( to avoid "Fatal: F2084 Internal Error: AV004A7B1F-R03BDA7B0-0"
-    {$ifend}
-  {$endif} // other Win32/Win64 Delphi platforms should work as expected
-{$endif FPC}
-
-{$ifdef NOSQLITE3STATIC}
-  // our proprietary crypto expects a statically linked custom sqlite3.c
-  {$define NOSQLITE3ENCRYPT}
-{$endif NOSQLITE3STATIC}
-
-{$ifdef MSWINDOWS}
-  {$define USEWININET}         // publish TWinINet/TWinHttp/TWinHttpAPI classes
-  {.$define ONLYUSEHTTPSOCKET} // for testing (no benefit vs http.sys)
-  {.$define USELIBCURL}        // for testing (no benefit vs WinHTTP)
-{$else}
-  {$define ONLYUSEHTTPSOCKET}  // http.sys server is Windows-specific
-  // cross-platform libcurl for https -> TCurlHttp and TSQLHttpClientCurl
-  {$define USELIBCURL}
-  {$ifdef ANDROID}
-    // for Android, consider using https://github.com/gcesarmza/curl-android-ios
-    // static libraries and force USELIBCURL in the project conditionals
-    {$define LIBCURLSTATIC}
-  {$endif ANDROID}
-{$endif MSWINDOWS}
-
-{$ifdef USELIBCURL}
-  {.$define LIBCURLMULTI}
-  // enable https://curl.haxx.se/libcurl/c/libcurl-multi.html interface
-{$endif USELIBCURL}
-
diff --git a/lib/dmustache/SynopseCommit.inc b/lib/dmustache/SynopseCommit.inc
deleted file mode 100644
index 9ebc3527..00000000
--- a/lib/dmustache/SynopseCommit.inc
+++ /dev/null
@@ -1 +0,0 @@
-'1.18.6381'