/// Common ORM and SOA classes for mORMot

// - this unit is a part of the freeware Synopse mORMot framework,

// licensed under a MPL/GPL/LGPL tri-license; version 1.18

unit mORMot;



(*

    This file is part of Synopse mORMot framework.



    Synopse mORMot framework. Copyright (C) 2016 Arnaud Bouchez

      Synopse Informatique - http://synopse.info



  *** BEGIN LICENSE BLOCK *****

  Version: MPL 1.1/GPL 2.0/LGPL 2.1



  The contents of this file are subject to the Mozilla Public License Version

  1.1 (the "License"); you may not use this file except in compliance with

  the License. You may obtain a copy of the License at

  http://www.mozilla.org/MPL



  Software distributed under the License is distributed on an "AS IS" basis,

  WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License

  for the specific language governing rights and limitations under the License.



  The Original Code is Synopse mORMot framework.



  The Initial Developer of the Original Code is Arnaud Bouchez.



  Portions created by the Initial Developer are Copyright (C) 2016

  the Initial Developer. All Rights Reserved.



  Contributor(s):

    Alexander (chaa)

    Alfred Glaenzer (alf)

    Daniel Kuettner

    DigDiver

    EgorovAlex

    Emanuele (lele9)

    Esmond

    Goran Despalatovic (gigo)

    Jordi Tudela

    Maciej Izak (hnb)

    Martin Suer

    MilesYou

    Ondrej

    Pavel (mpv)

    Sabbiolina

    Vadim Orel



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





       Client-Server ORM and SOA kernel of the mORMot framework

      **********************************************************



	- Client-Server classes using a RESTful model via JSON, over named pipes

	  or Windows messages  (HTTP/1.1 protocol with unit mORMotHttpServer/Client)

	- Client-Server ORM via TSQLRecord classes definition

	- Client-Server interface-based services for SOA process

	- optimized low-level RTTI and JSON process (TSQLTable)

	- ready to be used by mORMotSQLite3.pas with a SQLite3 engine

	- implements in-memory database tables with JSON/binary disk persistence



      Initial version: 2008 March, by Arnaud Bouchez



    Version 1.1 - 14 January 2010:

    - SQLite3 database layer updated to version 3.6.22

    - new communication layer, to be used on a local computer: windows messages

      (see TSQLRestClientURIMessage class). On a local machine, this is faster

      than named pipes and http, for small messages (quite as fast as direct

      access); but named pipes seems to be better for bigger messages

    - allow to get rid of our Enhanced Runtime Library dependency if not available

      (e.g. for FPC or on cross-platform, or on Delphi version newer than Delphi

      2007): just define the ENHANCEDRTL conditional below if installed it

      (always undefined if UNICODE is defined)

    - attempt to reach Delphi 2009/2010 compilation (string=UnicodeString):

      the UNICODE conditional will adapt the framework to these compilers

      (you shouldn't have to change any conditional define below)

    - attempt to reach Free Pascal Compiler 2.4.0 compatibility

    - all asm code equivalence in pure pascal code for 64 bits compatibility

      (always slower, but always portable to all CPUs)

    - use of PtrUInt / PtrInt for 64 bits compatibility

    - in case of FPC, the typinfo.pp unit is used: so all published properties

      in any TSQLRecord descendant must have a setter (i.e. a "write fValue"

      statement); the FPC's RTTI is not the same as Delphi's: it's a shame :(



    Version 1.2 - 16 January 2010

    - compatibility tested up to Delphi 2009 (that is tested with Delphi 7,

      Delphi 2007 and Delphi 2009), with or without our Enhanced

      Run Time Library (which now compiles up to Delphi 2007) - by default, the

      ENHANCEDRTL compiler conditional is not defined;

    - lot of rewrite made for the Unicode version of the compiler (tested with

      Delphi 2009) - it was quite difficult to avoid most implicit conversions...

      the compiler is a bit tricky, as soon as you want to use the UTF-8 encoding

      (as we do, since JSON and HTTP do like this encoding, together as SQLite3),

      and not Unicode (which is in fact UTF-16);

    - can create an internal TSQLRestClientURIMessage messaging window, if

      you don't have any User Interface (so you don't have to add Forms unit)

    - named pipe speed improvement (10 times faster) under Vista and Seven



    Version 1.3 - January 22, 2010

    - disconnect piped name client after 30 min of inactivity to free the

      corresponding thread resource if the client failed to close cleanly

    - some small fixes (e.g. integer to and from string conversion, GPF) and

      multi-compiler (Delphi 2009/2010, especialy with TypInfo define) compatibility

    - compiler conditional renamed ENHANCEDRTL instead of ENHANCEDTRTL

    - new TSQLTable.GetRowValues overloaded methods



    Version 1.3.1 - January 23, 2010

    - some Pos() overload problem under Delphi 20007 compiler; since

      this Pos() is seldom used, it was decided to only define it under

      Delphi 2009/2010 (which expect such a RawUTF8 specific overloaded version)

    - source code adaptation to use only ASCII 7 bits characters: should be OK

      with asiatic MBCS text encoding and such IDE



    Version 1.3.2 - January 24, 2010

    - new StringToUTF8() and UTF8ToString() functions; it's prefered to use

    TLanguageFile.StringToUTF8() method from SQLite3i18n, which will handle full

    i18n of your application; these functions use the current RTL codepage

    under Delphi 3-2007



    Version 1.4 - February 8, 2010

    - whole Synopse SQLite3 database framework released under the GNU Lesser

      General Public License version 3, instead of generic "Public Domain"



    Version 1.5 - March 10, 2010

    - SQLite3 database layer updated to version 3.6.23

    - User Interface Query action implementation

    - added security attributes to the named pipes creation: now this

      communication layer can work as a windows service, under Vista or Seven

      (thanks to esmond comment in our blog for the tip)

    - added new FastCGI server (not 100% tested)

    - first attempt to add REST paging requests for 'GET ModelRoot/TableName',

      as expected by the YUI DataSource Request Syntax for data pagination:

      see http://developer.yahoo.com/yui/datatable/#data



    Version 1.6

    - SQLite3 database layer updated to version 3.6.23.1

    - most useful functions are now shared in a separate SynCommons unit

    - the framework is now licensed under a MPL/GPL/LGPL tri-license

    - obscure JSON parsing bug fixed (when a field content finished with '\')



    Version 1.7

    - alter table with newly added fields to a TSQLRecord (see GetSQLAddField()

      methods)

    - some compatibility fixes for Delphi 2009/2010

    - fixed bug: negative numbers were not updated when calling *.Update()



    Version 1.8

    - includes Unitary Testing class and functions

    - update engine to version 3.7.0

    - new direct methods to handle BLOB fields from clients or servers

    - new URI to GET or PUT BLOB fields: ModelRoot/TableName/TableID/BlobFieldName

    - fixed bug in TSQLTable.GetJSONValues: FirstRow parameter not used

    - TTextWriter class moved from SQLite3Commons to SynCommons

    - new ModelRoot/[TableName/TableID/]MethodName RESTful GET/PUT request

     (see TSQLRestServerCallBack definition and comments): implements some custom

     Client/Server request, similar to the DataSnap technology, but in a KISS way;

     it's fully integrated in the Client/Server architecture of our framework,

     and extend its ORM feature to Object-less communication - see new

     ModelRoot/Stat method implement in TSQLRestServer

    - floating point numbers are now encoded using new ExtendedStr[ing] methods:

     such values are now encoded in a more human readable way in the JSON content

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



    Version 1.9

    - update engine to version 3.7.1

    - fixed error calling a TSQLRestServerCallBack with both record & parameters

    - TSQLRecordSigned must now be signed with a specified content (content

      was formerly a fixed field of type RawUTF8, but it didn't apply in

      all cases, e.g. if content field is defined as TSQLRawBlob)

    - new TSQLRestClientURI.ForceBlobTransfert property which enable to

      get and set BLOB fields values with usual Add/Update/Retrieve methods

    - new TSQLRestClientURI.RetrieveBlobFields/UpdateBlobFields methods

      for retrieving/updating all BLOB fields of a record at once

    - better handling of sftID in the User Interface and database use (e.g.

      creates a dedicated index for the TSQLRecord published fields)

    - some code rewrite in order to avoid any implicit conversion from/to

      integer/cardinal after new definition of PtrInt/PtrUInt (matching

      NativeInt/NativeUInt types, available since Delphi 2007)

    - updated TSQLRibbonTabParameters object, with some new fields dedicated

      to the automatic edition of records, via the new SQLite3UIEdit unit

    - new sftSet SQL field kind, handling a TSQLRecord published property

      with a set of enumeration as Delphi type (stored as bit-mapped INTEGER)

    - handle now RowID as a valid alias to the ID field (needed for TSQLRecordFTS3)

    - defines a new TSQLRecordFTS3 type, for defining a FTS3 virtual table,

      i.e. implementing full-text search



    Version 1.9.1

    - update engine to version 3.7.2: an obscure but very old bug makes

      SQLite authors recommend to use 3.7.2  for all new development.

      Upgrading from all prior SQLite versions is also recommended.



    Version 1.9.2

    - WriteObject and CopyObject functions now handle Int64 properties,

      as TJSONWriter.WriteObject method does now also

    - new TSQLRestServerStatic.GetOne and TSQLRestServerStatic.UpdateOne methods,

      methods available since a TSQLRestServerStatic instance may be created

      stand-alone, i.e. without any associated Model/TSQLRestServer

    - diverse fixes in TSQLRestServerStatic which could occur in not expected

      behavior if security events are enabled for this table (wrong IDToIndex)

    - new TSQLRecordLog.CreateFrom method used to append some log records

      to an existing JSON log content



    Version 1.10

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

      to some obscure compiler bugs in SynCrypto.pas)

    - update SQLite3 engine to version 3.7.3



    Version 1.11

    - update SQLite3 engine to version 3.7.4

    - new TSQLRecordProperties class, used internally by TSQLRecord to access

      to the RTTI via some high-level structures (therefore save memory for each

      TSQLRecord instance, and make operations faster)

    - new TSQLRecordFill class, used internally by TSQLRecord.FillPrepare()

      to save memory: a TSQLRecord instance has now only 20 bytes of InstanceSize

    - TSQLRecord.ID reader has now a GetID() getter which can handle the fact that

      a published property declared as TSQLRecord (sftID type) contains not a

      true TSQLRecord instance, but the ID of this record: you can use

      aProperty.ID method in order to get the idea - but prefered method is to

      typecast it via PtrInt(aProperty), because GetID() relies on some low-level

      windows memory mapping trick

    - new TSQLRecordMany to handle "has many" and "has many through" relationships

    - TSQLRestServer.AfterDeleteForceCoherency now handles specifically

      TRecordReference, TSQLRecord (fixed) and new 'has many' Source/Dest fields

      (this is our internal "FOREIGN KEY" implementation - we choose not to

      rely on the database engine for that, in order to be engine-independent...

      and SQLite3 introduced FOREIGN KEY in 3.6.19 version only)

    - TSQLRestServer.AfterDeleteForceCoherency now synchronizes as expected

      TSQLRestServerStatic table content

    - new TSQLRestServerStatic.SearchField method, for fast retrieval of

      all IDs matching a field of a TSQLRestServerStatic table (faster than

      using any OneFieldValues method, which creates a temporary JSON content)

    - TSQLRecord.FillRow method has been made virtual, so that some calculated

      field can be initialize during table content enumeration

    - corrected possible GPF error in TSQLRestServer.Retrieve

    - sftMany/TSQLRecordMany field type handled as a not simple field

    - new TSQLRecord.SimplePropertiesFill() method, to fill the simple properties

      with a given list of const parameters, following the declared order of

      published properties of the supplied table

    - new TSQLRest.Add(aTable: TSQLRecordClass; const aSimpleFields: array of const)

      overloaded method to add a record from a supplied list of const parameters

    - new TSQLRest.Update(aTable,aID,aSimpleFields) overloaded method to update

      a record from a supplied list of const parameters for each simple field

    - new property TSQLRecord.SimpleFieldsCount

    - FTS3Match method renamed FTSMatch, in order to be used without hesitation

      for both FTS3 and FTS4 classes

    - new overloaded FTSMatch method, accepting ranking of MATCH, using the

      new RANK internal function - see http://www.sqlite.org/draft/fts3.html#appendix_a

    - new TSQLRecordFTS4 class, to handle new FTS4 extension module  - see

      http://sqlite.org/fts3.html#section_1_1 - which is available since 3.7.4

    - new TSQLRecord.FillClose method

    - new TSQLRecord.CreateAndFillPrepare() methods, to makes loop into records

      easier (an hidden TSQLTable is created and released by TSQLRecord.Destroy)

    - new overloaded TSQLRestServer.CreateSQLIndex() method, accepting an array

      of field names

    - new TSQLRecord.FillPrepare(const aIDs: TIntegerDynArray) overloaded method,

      which can be handy to loop into some records via an IDs set

    - new TSQLTable.OwnerMustFree property for generic owning of a TSQLTable

      by a record - used for both CreateAndFillPrepare and TSQLRecordMany.FillMany

    - better non-ascii search handling in TSQLTable.SearchValue

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



    Version 1.12

    - now handle automaticaly prepared SQL statements: the parameters must

      be surrounded with :(...): in order to use an internal pool of prepared

      TSQLRequest statements; example of possible inlined values are :(1234):

      :(12.34): :(12E-34): :("text"): or :('text'): (with double quoting

      inside the text, just like any SQL statement)

    - with Delphi 2009+, you can define any string parameter in your

      TSQLRecord definition (will be handled as sftUTF8Text field)

    - with Delphi 2009+, WriteObject, ReadObject and CopyObject functions

      now handle string (UnicodeString) properties, as TINIWriter.WriteObject

      method does also: UTF-8 encoding is used at the storage level

    - new function SQLParamContent() to retrieve :(...): param content and type

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

    - some functions or type/const definitions moved to SynCommons in order

      to introduce new TSynTable class (TJSONWriter, IsRowID, GotoNextJSONField,

      TSynTableStatement...)

    - new TSQLRestServer.CreateSQLMultiIndex method

    - new TSQLTable.GetString and TSQLTable.GetVariant methods

    - new TPropInfo.SetVariant/GetVariant/CopyValue methods

    - new GetFieldValue/SetFieldValue and GetFieldVariant/SetFieldVariant

      methods for TSQLRecord

    - fixed issue in TSQLTable.GetWP(), which truncated data in Grid display

    - fixed issue in TSQLRestServerNamedPipe[Response] multi-thread architecture:

      FastMM in full debug mode detected that a block has been modified after

      being freed - now TSQLRestServerNamedPipeResponse is fully stand-alone



    Version 1.13

    - the ORM will now include all published properties of the parents, up to

      TSQLRecord, to the database fields (it was only using the published

      properties at the topmost class level)

    - dynamic arrays can now be specified for TSQLRecord published properties:

      a new sftBlobDynArray field kind has been added - will be stored as BLOB in

      the database (following the TDynArray.SaveTo binary stream layout), and

      will be transmitted as Base64 encoded in the JSON stream - we implemented

      a sftBlobRecord field kind, but Delphi RTTI is not generated for published

      properties of records: so our code is disabled (see PUBLISHRECORD

      conditional) :( - but you can use dynamic arrays of records

    - TPersistent can be now be specified for TSQLRecord published properties:

      a new sftObject field kind has been added - will be stored as TEXT in the

      database (following the ObjectToJSON serialization format) - TStrings or

      TRawUTF8List will be stored as a JSON array of string, and TCollection

      as a JSON array of objects, other TPersistent classes will have their

      published properties serialized as a JSON object

    - introducing direct content filtering and validation using

      TSynFilterOrValidate dedicated classes

    - filtering is handled directly in the new TSQLRecord.Filter virtual method,

      or via some TSynFilter classes - TSynFilterUpperCase, TSynFilterUpperCaseU,

      TSynFilterLowerCase, TSynFilterLowerCaseU and TSynFilterTrim e.g.

    - validation is handled in the new TSQLRecord.Validate virtual method,

      or via some TSynValidate classes - TSynValidateRest, TSynValidateIPAddress,

      TSynValidateEmail, TSynValidatePattern, TSynValidatePatternI,

      TSynValidateText, TSynValidatePassWord e.g.

    - introducing TSQLRecordRTree to implement R-Tree virtual tables - and new

      TSQLRecordVirtual parent table for all virtual tables like TSQLRecordFTS*

    - new TSQLRestClientURI methods to implement BATCH sequences to speed up

      database modifications: after a call to BatchStart, database modification

      statements are added to the sequence via BatchAdd/BatchUpdate/BatchDelete,

      then all statments are sent as once to the remote server via BatchSend -

      this is MUCH faster than individual calls to Add/Update/Delete in case

      of a slow remote connection (typically HTTP over Internet)

    - introducing TSQLVirtualTableModule / TSQLVirtualTable /

      TSQLVirtualTableCursor classes for a generic Virtual table mechanism

      (used e.g. by TSQLVirtualTableModuleDB in the SQLite3 unit)

    - new TSQLRecordVirtualTableAutoID and TSQLRecordVirtualTableForcedID

      classes, used to access any TSQLVirtualTable in our ORM

    - security and per-user access rights is now implemented in the framework

      core using per-User authentication via in-memory sessions (stored as

      TAuthSession), with group-defined associated security parameters (via

      TSQLAuthUser and TSQLAuthGroup tables), and RESTful Query Authentication

      via URI signature; should avoid most MITM and replay attacks

    - new TJSONSerializer class and ObjectToJSON/JSONToObject method

      (handles also dynamic arrays following the TTextWriter.AddDynArrayJSON

      format, i.e. plain JSON array for common types aka '[1,2,3]', but Base64

      encoded stream aka '["\uFFF0base64encodedbinary"]' for other arrays) and

      corresponding UrlDecodeObject() function (to be called by RESTful Services

      implementation on Server side)

    - wider usage of TSQLRecordProperties, for faster RTTI access, via the new

      class function TSQLRecord.RecordProps: TSQLRecordProperties: only

      virtual class function or procedure are now defined in TSQLRecord

    - enhanced TPropInfo.GetLongStrValue/SetLongStrValue methods, now converting

      RawUnicode, WinAnsiString, TSQLRawBlob and AnsiString properties

    - now ensure that no published property named ID or RowID was defined (this

      unique primary key field must be handled directly by TSQLRecord)

    - MAX_SQLFIELDS default is still 64, but can now be set to any value (64,

      128, 192 and 256 have optimized fast code) so that you can have any number

      of fields in a Table

    - MAX_SQLTABLES default is now 256, i.e. you can have up to 256 tables in a

      TSQLModel instance (you can set any other value, on need)

    - removed MAX_SQLLOCKS constant non-sense (replaced by two dynamic arrays)

    - TSQLModel implementation speed up, in case of a huge number of registered

      TSQLRecord in the database Model (since MAX_SQLTABLES=256 by default)

    - enhanced TSQLRecordMany.DestGetJoinedTable method to handle custom fields

    - TSQLRecordMany.DestGetJoined* methods now accept generic TSQLRest class

    - new aCustomFieldsCSV parameter for FillPrepare / CreateAndFillPrepare

      methods of TSQLRecord, to retrieve only neeeded fields: be aware that

      not specified fields will be left untouched, so a later Update() call may

      corrupt the row data - this optional parameter is about to save bandwidth

      when retrieving records field in a loop

    - TSQLRestServerStaticInMemory can now store its content into UTF-8 JSON

      or an optimized (SynLZ) compressed binary format - associated TPropInfo

      GetBinary/SetBinary and TSQLRecord GetBinaryValues/SetBinaryValues methods

    - the generic TVarData type is now used as a standard way of fast values

      communication: only handled VType are varNull, varInt64, varDouble,

      varString (mapping a constant PUTF8Char), and varAny (BLOB with size =

      VLongs[0]) - used e.g. by SQLite3 unit (VarDataToContext/VarDataFromValue)

    - new TSQLRest.Retrieve(aPublishedRecord, aValue: TSQLRecord) and

      TSQLRecord.Create(aClient: TSQLRest; aPublishedRecord: TSQLRecord..) methods

    - ExecuteList defined in TSQLRest, so now available also in TSQLRestServer

    - added a magic pattern check to ignore broadcasted WM_COPYDATA message

    - fixed issue in serializing sftCurrency type in TSQLRecord.GetJSONValue



  Version 1.14

    - new TPropInfo.GetCurrencyValue method

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



  Version 1.15

    - unit now tested with Delphi XE2 (32 Bit)

    - new sftModTime / TModTime published field type in TSQLRecord, which will

      be set to the current server time stamp before update/adding

    - new sftCreateTime / TCreateTime published field type in TSQLRecord, which

      will be set to the current server time stamp at record creation

    - new TSQLRest.ServerTimeStamp property, which will return the current

      server time as TTimeLog/Int64 value (will use the new /TimeStamp RESTful

      service to retrieve the exact server time)

    - TSQLRestServerStaticInMemory uses a per-Table Critical Section to have

      its EngineList, EngineRetrieve, EngineAdd, EngineUpdate, EngineDelete,

      EngineRetrieveBlob, EngineUpdateBlob methods begin thread-safe

    - enhanced TSQLRestServer.URI thread-safety (e.g. Sessions access)

    - TSQLTable.InitFieldTypes will now also use column type retrieved during

      JSON parsing

    - new TSQLTable.GetCSVValues method

    - GetJSONValues() is now using an internal TRawByteStringStream when

      the expected result is a RawUTF8 (avoid copying content twice, and is

      perfectly thread-safe)

    - the shared fTempMemoryStream is not available any more (not thread-safe)

    - new TSQLRest.AcquireWrite/ReleaseWrite protected methods, used by

      TSQLRestServer.URI to safely write to the DB (e.g. for POST/PUT/DELETE...)

      with TSQLRest.AcquireWriteTimeOut, both thread-safe and transaction-safe

    - TSQLRest.TransactionBegin / Commit / RollBack methods now expect a

      SessionID parameter in order to allow safe concurent access: writing to

      the database is queued within a single client session

    - CreateSQLMultiIndex and CreateSQLIndex methods now working on external

      DB virtual tables (using SynDB.TSQLDBConnectionProperties.SQLAddIndex)

    - new TSQLRecordProperties.ExternalTableName and ExternalDatabase fields

      used by SQLite3DB to handle external SynDB-based database access

    - code refactoring to make TSQLRestServerStatic more generic (for SQLite3DB)

    - TSQLRestServer.UpdateField now accepts to search by ID or by value (used

      e.g. by rewritten TSQLRestServer.AfterDeleteForceCoherency method)

    - introducing TSQLRecordExternal kind of record, able to use any SynDB

      external database engine (e.g. OleDB/MSSQL/Oracle/MySQL/PostgreSQL/SQLite3)

    - new ExtractInlineParameters procedure to handle :(1234): SQL statements

    - new MakePrivateCopy property in TSQLTableJSON.Create, which will avoid

      creating a private copy of the JSON (used e.g. in SynDBExplorer to handle

      very large result sets, with half the memory)

    - new TSQLRecordProperties.SQLUpdateSet, SQLInsertSet and AppendFieldName

      properties/method (used for external DB handling)

    - new TSQLRecord.Create, TSQLRecord.FillPrepare,

      TSQLRecord.CreateAndFillPrepare, TSQLRest.OneFieldValue,

      TSQLRest.MultiFieldValues, TSQLRestClient.EngineExecuteFmt and

      TSQLRestClient.ListFmt overloaded methods, accepting both '%' and '?'

      characters in the SQL WHERE format text, inlining '?' parameters

      with :(...): and auto-quoting strings

    - new UnicodeComparison parameter in TSQLTable.SearchValue to handle

      property non WinAnsi (code page 1252) characters

    - fixed issue in TPropInfo.GetBinary method with dynamic arrays (used e.g.

      by TSQLRestServerStaticInMemory.SaveToBinary)

    - fixed issue with TAuthSession.IDCardinal=0 or 1 after 76 connections

    - fixed issue in SetInt64Prop() with a setter method

    - fixed potential issue in TSQLTable.SearchValue in case of invalid Client

      supplied parameter (now checks TSQLRest class type)



  Version 1.16

    - mORMot framework now implements Client-Server service implementation

      using regular Delphi interfaces (over a RESTful or JSON-RPC protocol),

      using TServiceContainer / TServiceFactory classes, accessible via

      TSQLRest.Services property, on both client and server side, with

      auto-marshaling, JSON serialization, and built-in security

    - added dedicated Exception classes (EORMException, EParsingException,

      ESecurityException, ECommunicationException, EBusinessLayerException,

      EServiceException) all inheriting from SynCommons.ESynException

    - added a generic JSON error message mechanism within the framework

      (including error code as integer and text, with custom error messages

      in RecordCanBeUpdated method and also in TSQLRestServerCallBackParams)

    - added TSQLRestServerFullMemory class to implement a basic REST server

      using only in-memory tables (will only handle CRUD commands, but is

      enough to handle authentication with optional persistence in JSON file)

    - added TSQLRestServerRemoteDB class to implement a REST server using a

      remote TSQLRestClient connection for all its ORM process: can be used

      e.g. to publish services with a dedicated process in a DMZ

    - deep refactoring of TSQLRestClient / TSQLRestClientURI methods, for

      better compliance with the Liskov substitution principle (LSP)

    - TSQLRestServer published method names are now hash-stored for speed

    - the TSQLRestServerCallBack method prototype has been modified to supply

      "var aParams: TSQLRestServerCallBackParams" as unique parameter:

      this is a CODE BREAK change and you shall refresh ALL your server-side

      code to match the new signature (using a record passed by value as

      parameter will ensure faster code and seamless evolution of this structure)

    - new TSQLRestServer.SessionGetUser method to be used e.g. by any

      TSQLRestServerCallBack method implementation to retrieve the connected user

    - now the TSQLAuthUser instance retrieved during the session opening will

      retrieve the Data BLOB field (ready to be consummed on the server side)

    - introduced TSQLRestServerSessionContext structure to include current User

      and Group ID to the execution context (in addition to the Session ID)

    - TSQLRestServerStaticInMemory binary format changed: now will store its

      content per field (to ensure better compression) - magic identifier changed

    - now TSQLRestClientURI BATCH sequences methods will allow to mix several

      TSQLRecord in its sequence of BatchAdd/BatchUpdate/BatchDelete calls - if

      initiated as BatchStart(nil)

    - code clean-up of TSQLRestClientURI.SetUser + added aHashedPassword optional

      parameter (to use already hashed password)

    - added TSQLOccasion to handle the special case of field type (like

      TCreateTime) in case of Upate/Insert/Select

    - TCreateTime published fields now are not modified at update

    - fixed unexpected exception raised in TSQLRecord.FillOne if FillPrepare

      was successfull, but did not return any row

    - introducing TSQLRest.Cache and TSQLRestCache class to handle Client or

      Server side fast in-memory cache (with tuned configuration and timeout)

    - associated TSQLRestServer.CacheFlush service for flushing the Server cache,

      and remote TSQLRestClientURI.ServerCacheFlush() method for the client

    - fixed issue in TSQLRecord.FillPrepare when the table has less columns

      that the filling TSQLTable (can occur e.g. when using aCustomFieldsCSV

      parameter in FillPrepare method)

    - EngineList methods (including TSQLRestServerStaticInMemory class) now

      handles an optional integer pointer, to return the count of row data

    - uses new generic TSynAnsiConvert classes for code page process: that is,

      SQLite3i18n S2U() and U2S() match the SynCommons StringToUTF8() and

      UTF8ToString() functions - therefore, the TUTF8ToStringEvent parameter is

      not useful any more

    - more than MAX_SQLFIELDS-1 columns (by default, 63) will raise an exception

    - added TJSONSerializer.RegisterCustomSerializer() method to allow JSON

      serialization of any class (thanks Pavel "aka mpv" for the idea and patch)

    - added TSQLRestServer.ServiceMethodByPassAuthentication method in order to

      allow by-pass of the RESTful authentication scheme for some methods (can

      be used e.g. to server some HTML content for a non SOA client)

    - fix issue about missing last item in JSONToObject() function

    - fix issue when handling null JSON objects in GetJSONObjectAsSQL() function

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

    - fix issue about record locking in TSQLRestClientURI.Retrieve method

    - fix execution issue in TSQLRestServer.AfterDeleteForceCoherency()

    - fix issue about abusive session timeout: TSQLRestServer.SessionGet is now

      renamed SessionAccess and refreshes the session access timestamp each time

      a session is retrieved (+internal implementation fix)

    - fix issue in SetInt64Prop() procedure which failed the update of a property

      with no explicit setter

    - fix issue in TSQLRecord.FillFrom() which forgot to update InternalState

    - fix issue in TPropInfo.SetValue + TSQLRecord.ClearProperties with Value=nil

    - fix potential formating issue in TSQLTable.GetJSONValues/GetCSVValues

      methods which may create some wrong formating if TEXT is null/false/true

      (were formerly recognized as JSON keywords, whereas it should have already

      been transformed into nil, '0' or '1')

    - fix issue of unhandled buffer in TSQLTableJSON.UpdateFrom()

    - fix issue about transactions not working with TSQLRestServerStaticInMemory

    - fix issue in TSQLRestServerStaticInMemory on SELECT with only one column

    - fix TSQLTable.GetCSVValues() format (adding UTF-8 BOM)

    - TSQLRestServer.URI now returns "Location:" header without the digital

      signature (e.g. 'Location: People/11012') for a POST (=CRUD create/add)

    - TSQLRestClient.List and ListFmt methods now use TSQLRecordClass open

      array instead of TClass (for consistency)

    - new global RecordClassesToClasses() wrapper function to convert an

      array of TSQLRecordClass into the expected array of TClass

    - TPropInfo.CopyValue method now specifically handle copy of TCollection

      published properties items (used e.g. in TSQLRecord.FillFrom)

    - new GetEnumNameTrimed() wrapper function

    - new TRecordType definition, and TTypeinfo.RecordType associated method

    - now JSONToObject/ObjectToJSON functions and WriteObject method will handle

      standard TPersistent class serialization into/from JSON object

    - now ObjectToJSON/JSONToObject will unserialize sets and enumerations

      as an array of string, if HumanReadable is set to TRUE

    - now TSQLRestServer.Auth service returns true JSON response as specified

      by its content type (for better AJAX compatibility)

    - re-declared TSQLAccessRights record as an object, and added some

      dedicated methods: FromString, ToString, Edit

    - faster and more generic TSQLRecord.FillPrepare/FillRow implementation,

      including enhanced TSQLRecordFill class

    - faster TSQLRestServerStaticInMemory.LoadFromJSON and LoadFromBinary methods

    - reUrlEncodedSQL remote access right allows execution of SQL statement from

      a GET with the content encoded on the URI (as from XMLHTTPRequest)

    - new TSQLRest.EngineUpdateField protected method for a field content update

      (with PUT ModelRoot/TableName?setname=..&set=..&wherename=..&where=..)

    - new TSQLRecord.CreateAndFillPrepareMany and FillPrepareMany methods, able

      to create a JOINed SELECT statement including all nested TSQLRecordMany

      properties (including custom WHERE clause if necessary)

    - now nested TCollection and TStringList/TRawUTF8List objects are

      transmitted as true JSON arrays or objects for adding (POST) and update

      (PUT) - this will save bandwidth and increase compatibility

      with AJAX clients (they were formerly transmitted as JSON strings) - note

      that retrieval (GET) is not yet implemented, since it is faster to transmit

      directly the TEXT value as stored within the database

    - new TSQLRest.MainFieldIDs() method

    - new ForceID parameter for TSQLRest.Add() and TSQLRestClientURI.BatchAdd()

      to allow adding a record with a given ID

    - added TSQLRestClientURI.OnSetUser notification event (called from SetUser)

    - now TSQLRestClientURI.BatchUpdate() will set only ID, TModTime and mapped

      fields when called over a TSQLRecord on which a FillPrepare() was made

      (and no FillClose was performed)

    - now TSQLRestServerStats is a plain TPersistent class, and will be sent

      as a JSON object to the client

    - added function IsNotAjaxJSON() function - formerly internal IsExpanded()

    - added RecordManySourceProp / RecordManyDestProp / RecordManySourceClass /

      RecordManyDestClass to the TSQLRecordProperties

    - TSQLRestClientURI.CallBackPut() will now return any HTTP response content

      (even if it is not HTTP/1.1 compliant, and not work over some networks)

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



  Version 1.17

    - TSQLRecord.Create/FillPrepare/CreateAndFillPrepare and

      TSQLRest.OneFieldValue/MultiFieldValues methods signature BREAKING CHANGE:

      array of const used to be ParamsSQLWhere and expecting '%' in the

      FormatSQLWhere statement, is now called BoundsSQLWhere, and expects bound

      parameters specified as '?' in the FormatSQLWhere statement - this is less

      confusing for new users, and more close to the usual way of preparing

      database queries; but your existing user code SHALL BE CHECKED and fixed

    - fixed issue in TSQLTable.GetJSONValues about JSON number encoding

    - added optional "rowCount": in TSQLRestServerStaticInMemory.GetJSONValues,

      TSQLTable.GetJSONValues and in TSQLTableJSON.ParseAndConvert for about

      5% faster process of huge content (mpv proposal)

    - major speedup of TSQLTableJSON.Create(): buffer hashing by-passed until

      TSQLTableJSON.UpdateFrom() method is effectively called

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

    - fixed issue about harcoded 'ID' column, not compatible with virtual tables

    - fixed issue about pessimistic TSQLRestServerStaticInMemory.fIDSorted value

    - fixed ticket [fdf7158601] - about incorrect null value parsing in

      JSONToObject when isObj = oCustom (fix by mpv - thanks!)

    - fixed ticket [a1d9e9148e] - about incorrect reading empty JSON object by

      JSONToObject (fix by mpv - thanks!)

    - fixed ticket [4f5df7f18f] - about potential overflow of TSQLRestServerStats

      values (changed to QWord kind of property)

    - implemented feature request [7f6828999d] - about the possibility to use

      standard read/write in conjunction with custom read/write in JSONToObject

      and ObjectToJSON (mpv proposal - thanks!)

    - JSONToObject is now able to un-serialize a TObjectList class, when a class

      for its items is supplied as TObjectListItemClass optional parameter

    - ExtractInlineParameters() and SQLParamContent() decode ':("\uFFF12012-05-04"):'

      inlined parameters (i.e. text starting with JSON_SQLDATE_MAGIC after UTF-8

      encoding) as sftDateTime kind of parameter

    - added TJSONObjectDecoder.DecodedRowID member and fix GPF issue in Decode()

    - change vague boolean parameter into a TSQLOccasion enumerate in

      TJSONObjectDecoder.EncodeAsSQLPrepared()

    - added ForceID: boolean parameter to TSQLRest.Add() method

    - fixed random issue in TSQLRest.GetServerTimeStamp method (using wrongly

      TTimeLog direct arithmetic, therefore raising EncodeTime() errors)

    - internal cache added in TSQLRest.GetServerTimeStamp method for better speed

    - added TSQLRest.Retrieve() overloaded method for easy parameter binding

    - added TSQLRest.Delete() overloaded method with a WHERE clause parameter

    - implemented transaction process for (external database) virtual tables

    - added ReplaceRowIDWithID optional parameter to GetJSONObjectAsSQL(), in

      order to allow working with external DB not allowing RowID (e.g. Oracle)

    - TSQLRestCache.Notify*() methods made public for low-level potential use

    - made URI check case-insensitive (as for official RFC)

    - new TPropInfo.GetHash and TPropInfo.SameValue methods, with optional

      case sentivity handling

    - changed TSQLRecordProperties.BlobFieldsBits property into BlobFields,

      as an array of PPropInfo (for faster process)

    - added TSQLRecordProperties.HasTypeFields containing set of field types

      appearing in the record - replaces HasModTimeFields and HasCreateTimeField

    - new TListFieldHash class for efficient O(1) search using hashing handling

    - now unique fields are hashed in TSQLRestServerStaticInMemory implementation:

      "stored: false" properties are now checked for unicity before adding or

      update, and search will use the hash table for very fast O(1) process

    - speed optimization: all TSQLRestServerStaticInMemory search methods will

      now call a generic FindWhereEqual() for better code speed and maintenance

    - added ObjectFromInterface() function working also with TInterfacedObjectFake

    - introducing SetWeak() function to handle Weak interface assignment

    - added SetWeakZero() function and TObject class helper to handle ZEROed

      Weak interface assignment (with small performance penalty and memory use),

      corresponding to the ARC's Zeroing Weak pointers model

    - CopyObject() procedure now handle TCollection kind of object not only

      as sub properties

    - introducing TInterfacedCollection dedicated class, properly handling

      collection item creation on the Server side, with interface-based services:

      all contract operations shall use it instead of TCollection

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

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

    - ensure root/table/id and root/table?select=...&where=... REST requests

      return plain standard JSON output for AJAX clients (not mORMot clients)

    - introducing TSQLRestServerURIContext.UserAgent and ClientKind properties

    - added TSQLTable.FieldLengthMax() and ExpandAsSynUnicode() methods

    - added BlobToBytes() function and TSQLTable.GetBytes/GetStream methods

    - added virtual TSQLRestServer.FlushInternalDBCache method and dedicated

      TSQLRestServerStaticInMemoryExternal class, to properly handle external

      DB modification for virtual tables (i.e. flush SQL/JSON cache as expected)

    - added virtual TSQLRestServer.BeginCurrentThread method

    - added virtual TSQLRestServer.EndCurrentThread method which will be called

      e.g. by TSQLite3HttpServer or TSQLRestServerNamedPipeResponse for each

      terminating threads, to release any thread-specific resources (like

      external DB connections defined in SQlite3DB)

    - added new TServiceMethod.ExecutionOptions member, and the new

      TServiceMethodExecutionOption[s] types - used by ExecuteInMainThread()

    - added TServiceFactoryServer.ExecuteInMainThread() method, to force a method

      to be executed with RunningThread.Synchronize() call on multi-thread server

      instances (e.g. TSQLite3HttpServer or TSQLRestServerNamedPipeResponse)

    - refactoring of TServiceMethod.InternalExecute low-level asm code, and

      changed the Instance parameter to be specified as an open array for

      fast execution over multiple instances of implementation classes

    - 'SELECT *' statements on virtual/external tables will by-pass the SQLite3

      virtual table module: TSQLRecord.FillPrepare can be up to 30% faster -

      added TSQLRestServerStatic.AdaptSQLForEngineList virtual method to

      handle most generic SELECT cases (overridden e.g. in SQLite3DB unit)

    - TSQLRestServerStaticInMemory.GetJSONValues will now generate expanded

      JSON content, if specified (only non-expanded format was implemented),

      via the new TSQLRestServerStaticInMemory.ExpandedJSON property

    - added TSQLRestServerStatic.InternalBatchStart / InternalBatchStop methods

      to handle fast grouped sending to remote database engine (e.g. Oracle

      bound arrays or MS SQL bulk insert via SynDB)

    - fixed issue in TSQLRestClientURI.EngineAdd() when server returned -1

    - changed TSQLRestServerCallBackParams content to be used as a generic

      parameters wrapper for both method callbacks and interface-based services:

      now aParams.Context.ID is to be used instead of aParams.ID

    - added TJSONObjectDecoder record/object helper for JSON object decoding

      (used e.g. by GetJSONObjectAsSQL() function, and for SQlite3DB process)

    - removed TSQLRecordExternal class type, to allow any TSQLRecord (e.g.

      TSQLRecordMany) to be used with VirtualTableExternalRegister() - there was

      indeed no implementation requirement to force a specific class type

    - added aUseBatchMode optional parameter to TSQLRecordMany.ManyDelete() method

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

    - now huge service JSON response is truncated (to default 20 KB) in logs



  Version 1.18

    - full Windows 64-bit compatibility, including RTTI and services

    - renamed SQLite3Commons.pas to mORMot.pas

    - BREAKING CHANGE: all ORM IDs are now declared as TID (=Int64) instead of

      integer - also added a new TIDDynArray type to be used e.g. for BatchSend,

      and declared the TRecordReference type as Int64 - whole API is impacted

    - BREAKING CHANGE in TSQLRestServerCallBackParams which is replaced by the

      TSQLRestServerURIContext class: in addition, all method-based services

      should be a procedure, and use Ctxt.Results()/Error() methods to return

      any content - new definition of Ctxt features now full access to

      incoming/outgoing context and parameters, especially via

      the new Input*[] properties, for easy URI parameter retrieval, and

      also allow define specific URI routing by a dedicated class

    - BREAKING CHANGE: TSQLRestServerStatic* classes are now renamed as

      TSQLRestStorage* and do not inherit from TSQLRestServer but plain TSQLRest

      for a much cleaner design, conform to the Liskov substitution principle

    - TSQLRestServer.StaticDataServer[] will now return an abstract TSQLRest

    - URI routing for interface-based service is now specified by the two

      TSQLRestRoutingREST and TSQLRestRoutingJSON_RPC classes (inheriting from

      the abstract TSQLRestServerURIContext class) instead of rmJSON and

      rmJSON_RPC enums - it allows any custom URI routing by inheritance

    - BREAKING CHANGE of TJSONWriter.WriteObject() method and ObjectToJSON()

      function: serialization is now defined with TTextWriterWriteObjectOptions

      set - therefore, TJSONSerializerCustomWriter callback signature changed

    - BREAKING CHANGE of TJSONSerializerCustomReader callback signature, which

      now has an additional aOptions: TJSONToObjectOptions parameter

    - BREAKING CHANGE with newly added reSQLSelectWithoutTable security policy

      flags in TSQLAccessRight.AllowRemoteExecute - older applications which

      expected any SELECT statement to be executed on the server may break:

      you need to explicitely set this flag for the User's TSQLAuthGroup - note

      that SELECT with a simple table name in its FROM clause will now be

      checked againsts TSQLAccessRight.GET[] access rights

    - BREAKING CHANGE: added aSentData parameter to TNotifySQLEvent/OnUpdateEvent

    - BREAKING CHANGE: SQL "where" clause defined as PUTF8Char constant text

      have been changed into RawUTF8, to let the compiler fully handle Unicode

    - BREAKING CHANGE: TSQLRecord.ID is a pure getter property - use the new

      IDValue read/write property to access the ID of a true TSQLRecord instance

    - remove some unused TPropInfo methods, which were duplicates of the

      TSQLPropInfo cleaner class hierarchy: SetValue/GetValue/GetValueVar

      GetBinary/SetBinary GetVariant/SetVariant NormalizeValue/SameValue GetHash

      IsSimpleField AppendName GetCaption GetSQLFromFieldValue SetFieldAddr

    - following the Liskov substitution principle, Execute/ExecuteFmt and

      protected EngineExecute() are defined for TSQLRest, replacing ExecuteAll()

    - TSQLRestServerRemoteDB will now redirect into any TSQLRest instance

    - you can now define any custom property and store it as JSON, e.g. TGUID,

      by using overriding InternalRegisterCustomProperties(), or directly as

      record published properties (since Delphi XE5) - see ticket [b653e5f4ca]

    - TSQLRestRoutingREST will now recognize several URI schemes:

      /root/Calculator.Add + body, /root/Calculator.Add?+%5B+1%2C2+%5D,

      even root/Calculator.Add?n1=1&n2=2 - and /root/Calculator/Add as a

      valid alternative to default /root/Calculator.Add, if needed

    - new TServiceMethodExecute class replacing TServiceMethod.InternalExecute:

      allows incoming parameters to be encoded as a JSON object, in

      addition to the standard JSON array - see request [48e30e0e05]

    - allow stubed/mocked interfaces to be exposed as SOA services 

    - added optional CustomFields parameter to TSQLRest.Update() - and in case

      of a previous *FillPrepare() call, only the retrieved fields are updated

    - added TSQLRestServer.AcquireExecutionMode[] AcquireExecutionLockedTimeOut[]

      properties, able to define threading execution plan for ORM/SOA operations

    - added TSQLRestServer.InitializeTables() method to initialize void tables

    - changed RESTful URI to ModelRoot/Table?where=WhereClause to delete members

    - added TSQLRestServer.RootRedirectGet property to allow easy redirection

    - added TSQLRestServer.URIPagingParameters property, to support alternate

      URI parameters sets for request paging (in addition to YUI syntax),

      and an optional "total":... field within the JSON result (calling

      "SELECT count()" may be slow, especially on external databases)

    - added TSQLRest.PrivateGarbageCollector property, to manage lifetime

      of user class instances linked to a given TSQLRest

    - deep code refactoring, introducing TSQLPropInfo* classes in order to

      decouple the ORM definitions from the RTTI - will allow definition of

      any class members, even if there is no RTTI generated or via custom

      properties attributes or a fluent interface

    - new TJSONSerializer.RegisterClassForJSON() methods, allowing recognition

      of class types from a new {"ClassName":"TMyObject" JSON field generated

      by ObjectToJSON(..[woStoreClassName]) new option: it will be recognized

      by JSONToObject() for TObjectList members, and by the new JSONToNewObject()

      method - all TSQLRecord classes of a model are automaticaly registered

    - new TJSONSerializer.RegisterCollectionForJSON() method, to register a

      TCollection/TCollectionItem pair and allow JSON serialization of any

      "plain" collection - may be a good alternative to TInterfacedCollection

    - new JSONSerializer.RegisterObjArrayForJSON() method for automatic JSON

      serialization of T*ObjArray dynamic array storage

    - introducing ObjectEquals() global function for fast by value comparison

    - sets including all enumerate values will be written in JSON as "*"

      with woHumanReadable option (and recognized as such e.g. by JSONToObject);

    - new woStorePointer option to let ObjectToJSON() add "Address":"0431298a"

    - added ObjectFromInterfaceImplements() functions working with any

      implementation class, including TInterfacedObjectFake

    - introducing TInterfaceFactoryGenerated so that interface methods can be

      described for FPC, which lacks of expected RTTI - see [9357b49fe2]

    - introducing TInjectableObject to easily implement the DI/IoC SOLID

      patterns, for both TSQLRest services and stubing/mocking

    - introducing TInterfaceResolver, TInterfaceResolverForSingleInterface and

      TInterfaceResolverInjected, to be used for DI/IoC with TInjectableObject

      types and allowing TSQLRest.Services.Inject*() and Resolve() methods

    - added TSQLRest*.ServiceDefine() and enhanced TInterfaceStub/TInterfaceMock

      methods to specify interface from it name, without the need to use the

      TypeInfo(IMyInterface) syntax in end-user code

    - interface-based services are now able to work with TObjectList parameters

    - interface-based services will now avoid to transmit the "id":... value

      when ID equals 0

    - interface-based services can now return the result value as JSON object

      instead of JSON array if TServiceFactoryServer.ResultAsJSONObject is set

      (can be useful e.g. when consuming services from JavaScript)

    - interface-based services can now return the result value as XML object

      instead of JSON array or object if TServiceFactoryServer.ResultAsJSONObject

      is set (can be useful e.g. when consuming services from XML only clients) -

      as an alternative, ResultAsXMLObjectIfAcceptOnlyXML option will recognize

      'Accept: application/xml' or 'Accept: text/xml' HTTP header and return

      XML content instead of JSON - with optional ResultAsXMLObjectNameSpace

    - added TServiceCustomAnswer.Status member to override default HTML_SUCCESS

    - new TSQLRest.Service<T: IInterface> method to retrieve a service instance

    - added TServiceMethodArgument.AddJSON/AddValueJSON/AddDefaultJSON methods

    - method-based services are now able to handle "304 Not Modified" optimized

      response to save bandwidth, in TSQLRestServerURIContext.Returns/Results

    - added TSQLRestServerURIContext.ReturnFile() and ReturnFileFromFolder()

      methods, for direct fast transmission to a HTTP client, handling

      "304 Not Modified" and proper mime type recognition

    - added TSQLRestServerURIContext.Input*OrVoid[] properties

    - added TSQLRestServerURIContext.SessionRemoteIP, SessionConnectionID,

      SessionUserName and ResourceFileName properties

    - added TSQLRestServerURIContext.InputAsMultiPart() method

    - added TSQLRestServerURIContext.Redirect() method for HTTP 301 commands

    - added TSQLRestServer.ServiceMethodRegister() low-level method

    - added TSQLRestServer.ServiceMethodRegisterPublishedMethods() to allow

      multi-class method-based services (e.g. for implementing MVC model)

    - new TSQLRestClientURI.ServicePublishOwnInterfaces/ServiceRetrieveAssociated

      methods, implementing a P2P automatic registration of associated services

    - ServiceContext threadvar will now be set in all ORM and SOA process, to

      allow access to the execution context

    - to make the implicit explicit, TSQLRestServerURIContext.ID has been

      renamed TableID, and a new ServiceInstanceID instance has been added

    - BeginCurrentThread/EndCurrentThread will now be defined at TSQLRest class

      abstract level, and code review has been made to ensure that they will

      be triggered as expected (i.e. always and from the thread itself)

    - new function CurrentServiceContext, to be used from packages instead of

      direct ServiceContext threadvar access - circumvent Delphi RTL/compiler

      restriction (bug?) as reported by [155b09dc1b]

    - let the ORM reading methods follow the SELECT column order using

      TSQLFieldIndexDynArray instead of TSQLFieldBits as expected by [94ff704bb1]

    - let TSQLRest.OneFieldValues() handle directly naive expressions like

      'SELECT ID from Table where ID=10' or 'where ID in (10,20,30)'

    - new TSQLRestClientURI.ForceBlobTransfertTable[] property which enable to

      get and set BLOB fields values with usual Add/Update/Retrieve methods for

      a particular table (more tuned than existing ForceBlobTransfert property)

    - once authenticated, TSQLRestClientURI.SessionUser would have all its

      properties retrieved from the remote server

    - added TSQLRestClientURI.SessionID/SessionServer/SessionVersion properties

    - added TSQLRestClientURI.CallBack() method allowing any HTTP verb

    - added new TSQLRestClientURI.RetryOnceOnTimeout property

    - fixed TServiceFactoryClient.Get() not working properly in sicPerSession,

      sicPerUser or sicPerGroup modes - ticket [3fafb53be4]

    - added TServiceInstanceImplementation.sicPerThread mode - feature [cb76c866bb]

    - introduced more readable "stored AS_UNIQUE" published property definition

      in TSQLRecord (via the explicit AS_UNIQUE=false constant)

    - introduced TSQLRecord.Create(aSimpleFields) constructor

    - introduced 32bit/64bit safe TSQLRecord.AsTSQLRecord property, to be used

      when assigning IDs to a TSQLRecord published property

    - TSQLRecord.[CreateAnd]FillPrepare() will now handle aCustomFieldsCSV='*'

      parameter as a all fields selection, including BLOBs (whereas default ''

      value will continue to return simple fields, excluding BLOBs)

    - TSQLRecord.CreateAndFillPrepareMany() will raise an exception when run

      on a TSQLRecord with no many-to-many published field

    - introducing new TSQLRecord.EnginePrepareMany() method

    - added optional FieldBits output parameter to TSQLRecord.FillFrom/FillValue

    - fixed TSQLRecordMany Source/Dest fields serialization - see [22ce911c715]

    - introducing TSQLRecord.CreateJoined() and CreateAndFillPrepareJoined()

      constructors, to auto-initialize and load nested TSQLRecord properties

    - added TSQLRecord.GetAsDocVariant/GetSimpleFieldsAsDocVariant methods

    - added TSQLRecord.AppendAsJsonObject/AppendFillAsJsonArray and

      TSQLRest.AppendListAsJsonArray methods

    - TSQLRecord.InitializeTable() will now create DB indexes for aUnique

      fields (including ID/RowID)

    - TSQLRecord.CreateCopy will handle TStrings property via new CopyStrings()

    - added TSQLInitializeTableOptions parameter to CreateMissingTables and

      InitializeTable methods, to tune underlying table creation (e.g. indexes)

    - introducing TInterfaceStub and TInterfaceMock classes to define

      high-performance interface stubbing and mocking via a fluent interface

    - integrated Windows Authentication to the mORMot Client-Server layer: in

      order to enable it, define a SSPIAUTH conditional and call

      TSQLRestClientURI.SetUser() with an empty user name, and ensure that

      TSQLAuthUser.LoginName contains a matching 'DomainName\UserName' value

    - introducing TSQLRestServerAuthenticationActiveDirectory class, thanks to

      an implementation proposal from EgorovAlex - thanks for sharing!

    - added TSQLRecordTimed class, and TSQLRecord.AddFilterNotVoidAllTextFields

      and TSQLModel.AddTableInherited methods

    - new TSQLModel/TSQLRecordProperties.SetVariantFieldsDocVariantOptions methods

    - Windows Authentication can use either NTLM or the more secure Kerberos

      protocol, if the corresponding SPN domain is set as password

    - feature request [5a17a4277f]: you can now define in the Model your custom

      TSQLAuthUser and/or TSQLAuthGroup classes to store the authorization

      information: TSQLRestServer will search for any table inheriting from

      TSQLAuthUser/TSQLAuthGroup in the TSQLModel - see also corresponding

      TSQLRestServer.SQLAuthUserClass/SQLAuthGroupClass new properties, and

      the new generic TSQLRestServer.OnAuthenticationUserRetrieve optional event

    - introducing TSQLAuthUser.CanUserLog() to ensure authentication is allowed,

      as requested by feature request [842906425928]

    - added TSynAuthenticationRest e.g. for SynDBRemote to check REST users

    - added TSQLRestServer.OnSessionCreate/OnSessionClosed/OnAuthenticationFailed

      callbacks, and TSQLRestServerURIContext.AuthenticationFailed virtual method

    - added TSQLRestServer.SessionClass property to specify the class type

      to handle in-memory sessions, and override e.g. IsValidURI() method

    - CreateMissingTables() method is now declared as virtual in TSQLRestServer

    - TSQLRestServer.URI() and TSQLRestClientURI.InternalURI() methods now uses

      one TSQLRestURIParams parameter for all request input and output values

    - TSQLRestServer.URI() method will return "405 Method Not Allowed" error

      (HTML_NOTALLOWED) if the supplied URI does not match RestAccessRights

    - TSQLRestServer.URI() will now handle POST/PUT/DELETE ModelRoot/MethodName

      as method-based services

    - added TSQLRestServerFullMemory.Flush method-based service

    - added TSQLRestServerFullMemory.DropDatabase method

    - TSQLRestServerFullMemory now generates its expected InternalState value

    - completed HTML_* constant list and messages - feature request [d8de3eb76a]

    - handle HTML_NOTMODIFIED and HTML_TEMPORARYREDIRECT as successful status -

      as expected by feature request [5d2634e8a3]

    - enhanced sllAuth session creation/deletion logged information

    - introducing TSQLRest.LogClass property, allowing to set a custom log class

    - added TAuthSession.SentHeaders, RemoteIP and ConnectionID properties

    - added process of Variant and WideString types in TSQLRecord properties,

      including any custom type, like TDocVariant or TBSONVariant (for MongoDB

      objects), or even a dynamic array of variants (see [d9d091baab])

    - added JSON serialization of Variant and WideString types, and corresponding

      TJSONToObjectOptions optional parameter in JSONToObject() / ObjectToJSON()

      functions and WriteObject() method - including TDocVariant or TBSONVariant

    - fixed TPersistent process in TJSONWriter.WriteObject - thanks Jordi!

    - introducing TSynAutoCreateFields, TPersistentAutoCreateFields and

      TCollectionItemAutoCreateFields classes, with automatic initialization and

      finalization of their nested published properties (e.g. for DDD objects)

    - JSONToObject() is now able to unserialize a nested record - see [5e49b3096a]

    - added TTypeInfo.ClassCreate() method to create a TObject instance from RTTI

    - TEnumType.GetEnumNameValue() will now recognize both 'sllWarning' and

      'Warning' text as a sllWarning item (will enhance JSONToObject() process)

    - fix and enhance boolean values parsing from JSON content ("Yes"=true)

    - implement woHumanReadableFullSetsAsStar and woHumanReadableEnumSetAsComment

      option for JSON serialization and TEnumType.GetEnumNameTrimedAll()

    - fixed ticket [139a846ce88] about TJSONObjectDecoder.EncodeAsSQLPrepared()

    - use GetTickCount64() to fix any issue in case of GetTickCount() overflow -

      some *: cardinal properties are renamed *64: Int64 for consistency

    - added ClassInstanceCreate() function calling any known virtual constructor

    - added GetInterfaceFromEntry() function to speed up interface execution,

      e.g. for TServiceFactoryServer (avoid the RTTI lookup of GetInterface)

    - added TPropInfo.ClassFromJSON() to properly unserialize TObject properties

    - added TPropInfo.CopyToNewObject() method, to instantiate class published

      properties from another instance (possibly one of its nested items)

    - added TSQLPropInfo.SQLFieldTypeName and SQLDBFieldTypeName properties

    - introducing TSQLPropInfo.SetValueVar() method to avoid a call to StrLen()

    - TSQLPropInfo is now able to "flatten" nested properties, e.g. DDD's

      TUser.Address.Country.Iso will be mapped to ORM's TSQLRecord.Address_Country

    - introducing TSQLPropInfo.CopyProp() method which supports flattened classes

    - fixed [f96cf0fc5d] and [221ee9c767] about TSQLRecordMany JSON serialization

    - fixed issue when retrieving a TSQLRecord containing TSQLRecordMany

      properties with external tables (like 'no such column DestList' error)

      via SQLite3 virtual tables (e.g. for a JOINed query like FillPrepareMany)

    - fixed TInterfacedCollection.GetClass to be defined as a class function

    - TSQLRestClientURINamedPipe and TSQLRestClientURIMessage are now thread-safe

      (i.e. protected by a system mutex) therefore can be called from a

      multi-threaded process, e.g. TSQLRestServer instances as proxies

    - modified named pipe client side to avoid unexpected file not found errors

    - TInterfaceFactory instances are now shared among all interface-based

      features (e.g. services, callbacks or mocks/stubs), in a thread-safe cache

    - added dedicated EInterfaceFactoryException

    - added TServiceFactoryServer.TimeoutSec / SetTimeoutSec() property / method

    - TServiceFactoryServer.ExecuteInMainThread() method is now replaced by

      a more generic TServiceFactoryServer.SetOptions() method

    - new optFreeInMainThread execution options for the service, allowing server

      side service class instance release via Synchronize() - ticket [57bea48f30]

    - new optExecInPerInterfaceThread and optFreeInPerInterfaceThread options

      for the service, allowing server side service class instance execution and

      release in a thread dedicated to the interface - ticket [8307f8a547]

    - new optExecLockedPerInterface option for the service, allowing server side

      service instance execution and release to be locked for the whole interface

    - added TServiceFactoryServer.ByPassAuthentication property to release

      authentication for a given interface-based service

    - stub creation speed-up by using a shared PAGE_EXECUTE_READWRITE buffer

    - added TServiceMethod.DefaultResult property, to be used for stubs/mocks

    - TServiceFactory.Create() and its children will now always have an optional

      aContractExpected parameter (for consistency with TServiceFactoryClient)

    - introduce smvVariant kind of parameter for interface-based services

    - new RawJSON string type to force no JSON serialization in interface-based

      services (to be used e.g. for transmitting TSQLTableJSON results)

    - safer TInterfacedObjectFake.FakeCall() stack use

    - TServiceFactoryServerInstance will now create instances server-side

      with a RefCount=1, to allow passing self as an interface in sub-methods

    - huge code refactoring of the ORM model implementation: a new dedicated

      TSQLModelRecordProperties will contain per-TSQLModel parameters, whereas

      shared information retrieved by RTTI remain in TSQLRecordProperties - this

      will allow use of the same TSQLRecord in several TSQLModel at once, with

      dedicated SQL auto-generation and external DB settings

    - added aExternalTableName/Database optional parameters to method

      TSQLModel.VirtualTableRegister()

    - added Owner, Actions, Events parameters to TSQLModel.Create() constructor

    - fixed issue in TSQLRestServer.Create() about authentication enabling

    - introducing TSQLRestServer.CreateWithOwnModel() constructor to ease

      creation of simple Rest in-memory storage, e.g. for testing purposes

    - added TSQLModel.GetTableIndexExisting() method to raise an explicit

      EModelException if the table is not part of the model - used now by

      almost all CRUD Client and Server operations - ticket [aa0d6f1e90]

    - added TSQLModel.URIMatch() method to allow sub-domains generic matching

      at database model level (so that you can set root='/root/sub1' URIs)

    - moved SQLFromSelectWhere() from a global function to a TSQLModel method

      (to prepare "Table per class hierarchy" mapping in mORMot)

    - SQLParamContent() / ExtractInlineParameters() functions moved to SynCommons

    - added TSQLRecordHistory and TSQLRestServer.TrackChanges() for [a78ffe992b]

    - added TSQLRestTempStorage "asynchronous write" for [cac2e379f0]

    - added TSQLRestServer.RecordVersionSynchronize() and the new TRecordVersion

      field kind to maintain a remote versioning of rows - see [3453f314d9]

    - TSQLAuthUser and TSQLAuthGroup have now "index ..." attributes to their

      RawUTF8 properties, to allow direct handling in external databases

    - added TSQLModelRecordProperties.FTS4WithoutContent() method to allow

      TSQLRecordFTS4 tables let the content be store in another TSQLRecord table

    - introducing TSQLRecordFTS3Unicode61 and TSQLRecordFTS4Unicode61 classes

    - new protected TSQLRestServer.InternalAdaptSQL method, extracted from URI()

      process to also be called by TSQLRestServer.MultiFieldValues() for proper

      TSQLRestStorage.AdaptSQLForEngineList(SQL) call

    - new TSQLRestStorage.fOutInternalStateForcedRefresh protected field to

      optionally force the refresh of the content

    - added TSQLRestStorageRemote class and TSQLRestServer.RemoteDataCreate()

      method for feature request [3453f314d97d]

    - new TSQLRestServer.OnBlobUpdateEvent: TNotifyFieldSQLEvent event handler

      to implement feature request [4cafc41f67]

    - new protected TSQLRestServer.InternalUpdateEvent virtual method, to allow

      a server-wide update notification, not coupled to OnUpdateEvent callback -

      see feature request [5688e97251]

    - TSQLRestStorageInMemory.AdaptSQLForEngineList() will now handle

      'select count() from TableName' statements directly, and any RESTful

      requests from client

    - TSQLRestStorageInMemory will now handle SELECT .... WHERE ID IN (...)

    - fixed issue in TSQLRestStorageInMemory.EngineList() when only ID

    - added TSQLRestServerFullMemory.Storage[] and Storages[] properties

    - changed TSQLAccessRights and TSQLAuthGroup.SQLAccessRights CSV format

      to use 'first-last,' pattern to regroup set bits (reduce storage size)

    - added overloaded TSQLAccessRights.Edit() method using TSQLOccasions set

    - added reOneSessionPerUser flag to TSQLAccessRight.AllowRemoteExecute

    - added reUserCanChangeOwnPassword flag to TSQLAccessRight.AllowRemoteExecute

      as requested by [e6f113fc98]

    - enabled reUrlEncodedSQL by default for TSQLAccessRights (needed e.g. for

      plain HTTP GET request, without any body)

    - introducing TSQLRestClientURI.InternalCheckOpen/InternalClose methods to

      properly handle remote connection and re-connection

    - added TSQLRestClientURI.LastErrorCode/LastErrorMessage/LastErrorException

      properties, to retrieve additional information about remote URI() execution

    - added TSQLRestClientURI.ServiceRegister() and ServiceRegisterClientDriven()

      methods for easier Client-side interface-based services initialization

    - added JSONFileToObject() and ObjectToJSONFile() functions

    - unit interface deep refactoring: e.g. now TSQLTable will refers explicitly

      to TSQLRecord classes and not to plain TClass (e.g. for QueryTables[])

    - introducing new TSQLTable[JSON].CreateFromTables/CreateWithColumnTypes()

      constructors, able to specify the column type information to be used

    - added TSQLTable.SetFieldType() method to specify a column type and size

    - introduced TSQLTable.FieldTypeIntegerDetectionOnAllRows property to force

      the detection of number types for all data rows, if needed

    - added TSQLTable.SortFields() overloaded method, able to sort a TSQLTable

      row content by multiple fields - implements feature request [d277153f03]

    - added optional CustomFormat: string parameter to TSQLTable.ExpandAsString()

      to allow numerical or date/time format for a given column [749dfbdb6a]

    - added optional CustomCompare: TUTF8Compare param to TSQLTable.SortFields()

      to allow any kind of custom ordering - feature request [c6804d48a4]

    - speed up of TSQLTable.FieldIndex() TSQLTable.FieldIndexExisting() methods

      (using binary search)

    - added overloaded TSQLTable.FieldIndex() and TSQLTable.FieldIndexExisting()

      methods, to set several local field index integer variables at once

    - added TSQLTable.ToObjectList() and ToObjectList<T: TSQLRecord>() methods

    - added TSQLTable.Step() FieldBuffer() Field() FieldAsInteger() FieldAsFloat()

      methods, handling a cursor at TSQLTable/TSQLTableJSON level, with optional

      late-binding column access

    - added TSQLTable.GetSynUnicode() method

    - added TSQLTable.ToDocVariant() and TSQLRest.RetrieveDocVariantArray()

      overloaded methods, which can be used e.g. to process directly some data

      retrieved from the ORM with TSynMustache.Render()

    - added TSQLTable.GetMSRowSetValues() methods, to return XML content in

      ADODB.recordset format - thanks mpv and Vadim Orel for the input!

    - added TSQLTable.GetODSDocument method, to return a document readable by

      Office applications - thanks esmond for the idea and patch

    - fixed ticket [5a8ec14e25] about potential GPF in TSQLTable.DeleteColumnValues

    - added TSQLRecord.CreateAndFillPrepare(aJSON) overloaded method

    - introducing TSQLRecordInterfaced class, if your TSQLRecord definition

      should be able to implement interfaces

    - in addition to Batch*() methods available at TSQLRestClientURI level, all

      BATCH process is now implemented by stand-alone TSQLRestBatch instances,

      which can safely be used at TSQLRestServer level, even from multi thread

    - introduced "SIMPLE": and "SIMPLE@": commands in the JSON stream for

      default BatchAdd() with simple fields (to reduce bandwidth and memory use) 

    - fixed BATCH process to generate valid JSON content

    - fixed BATCH process to check for the TSQLAccessRights of the current

      logged user just like other CRUD methods, as reported by [27cf02be50]

    - ensure BATCH process take place within execORMWrite context [c47b9ef5800]

    - added optional CustomFields parameter to TSQLRest.BatchUpdate()

      and BatchAdd() methods - TModTime fields will always be sent

    - implemented automatic transaction generation during BATCH process via

      a new AutomaticTransactionPerRow parameter in BatchStart()

    - fixed unexpected issue in TSQLRest.BatchSend() when nothing is to be sent

    - added TSQLRestClientURI.ServerTimeStampSynchronize method to force time

      synchronization with the server - can be handy to test the connection

    - added TSQLRestClientURI.ServerRemoteLog wrapper to method-based service,

      and corresponding ServerRemoteLogStart and ServerRemoteLogStop methods

    - added TSQLRest.TableHasRows/TableRowCount methods, and overridden direct

      implementation for TSQLRestServer/TSQLRestStorageInMemory (including

      SQL pattern recognition for TSQLRestStorageInMemory)

    - added TSQLRest.RetrieveList method to retrieve a TObjectList of TSQLRecord

    - added TSQLRest.RetrieveList<T> generic method to retrieve a TObjectList<T>

    - added TSQLRest.RetrieveListJSON method to get a TSQLRecord list as JSON

    - added TSQLRest.RetrieveListObjArray and TSQLTable.ToObjArray methods

    - added TSQLRest.UpdateField() overloaded methods to update a single field

    - added TSQLRest.UpdateFieldIncrement() method for atomic increase/decrease

    - "rowCount": is added in TSQLRestStorageInMemory.GetJSONValues,

      TSQLTable.GetJSONValues and in TSQLTableJSON.ParseAndConvert, at the end

      of the non expanded JSON content, if needed - improves client performance

    - UpdateBlobFields() and RetrieveBlobFields() methods are now defined at

      TSQLRest level, with dedicated implementation for TSQLRestClient* and

      TSQLRestServer* classes - implements feature request [34664934a9]

    - fixed TSQLRestStorageInMemory.UpdateBlobFields() to return true

      if no BLOB field is defined (as with TSQLRestServer) - ticket [bfa13889d5]

    - fixed issue in TSQLRestStorageInMemory.GetJSONValues(), and handle

      optional LIMIT clause in this very same method

    - added new TSQLRestStorageInMemory.DropValues method

    - fix potential GDI handle resource leak in TSQLRestClientURIMessage.Create

    - introducing TSQLRestClientURIMessage.DoNotProcessMessages property

    - TSQLRestClientURINamedPipe.InternalCheckOpen/InternalURI refactoring

    - allow TSQLRestServer.ServiceRegister() to register an existing instance

      of a class for a shared service - feature request [6e8b2ff3e9]

    - allow TSQLRestServer.ExportServerMessage to be started in conjunction

      with other protocols (like named pipes)

    - added STATICFILE_CONTENT_TYPE[_HEADER] as aliases to HTTP_RESP_STATICFILE

      as defined in SynCrtSock.pas unit, for generic handling

    - added TSQLRestServer.Shutdown method for clean server stop - [55d5babb16]

    - added TSQLRestServer.SessionsSaveToFile/SessionsLoadFromFile methods and

      optional aStateFileName parameter to TSQLRestServer.Shutdown to allow

      session persistence as requested by [a392945901] - warning: not for SOA!

    - TSQLRestServerStats refactored and renamed TSQLRestServerMonitor so that

      it follows the TSynMonitor way of doing statistics - also added several

      properties as requested by feature request [4a2433c045]

    - introducing detailed SOA statistics for method-based and interface-based

      services, available from the TSQLRestServer.ServiceMethodStat[] property

      or the associated TServiceFactoryServer.Stats / Stat[] methods, or

      remotely as an option to the TSQLRestServer.Stat() service

    - fixed potential errors JSON generation issue in TSQLRestServer.URI

      (ticket [b0e9116aeb])

    - TSQLRestServer.LaunchCallBack() is now inlined in TSQLRestServer.URI()

    - fixed ticket [a5e3564e48] about RecordRef typecast (and enhance comments)

    - fixed ticket [4f4dd18ad9] about TPropInfo.IsStored not handling methods

      callbacks, e.g. for TPersistent storage

    - fixed ticket [21c2d5ae96] when inserting/updating blob-only table content

    - fixed ticket [7e9f06bf1a] to let TSQLTable.FieldLengthMax() use caption

      text for enumeration columns

    - fixed ticket [28545a4ce0] about TSQLRestStorageInMemory.EngineDelete

      not thread-safe when run directly on server side

    - fixed ticket [027bb9678d] - now TSQLRecordRTree class works as expected

    - fixed ticket [876a097316] about TSQLRest.Add() when ForcedID<>0

    - added DoNotAutoComputeFields optional param to TSQLRest(Batch).Add/Update

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

    - fixed GPF issue in TServiceFactoryServer after instance time-out deletion

    - added TSQLPropInfo.PropertyIndex member

    - added TSQLRecordProperties.SimpleFieldsCount[] array

    - added TSQLRecordProperties.FieldBits[] field index map for all types

    - added TSQLRecordProperties.SmallFieldsBits property

    - added TSQLRecordProperties.FieldBitsFromCSV()/FieldBitsFromRawUTF8()

      methods (with functions ready to be used e.g. in BatchAdd/BatchUpdate),

      and TSQLRecordProperties.FieldBitsFromBlobField() method

    - added TSQLRecordProperties.RegisterCustomFixedSizeRecordProperty() and

      RegisterCustomRTTIRecordProperty() methods

    - added TSQLRecordProperties.SetCustomCollationForAll() +

      SetCustomCollation() methods, and TSQLModel.SetCustomCollationForAll()

      to implement ticket [bfdc198e70]

    - introducing TSQLRecordProperties.SetMaxLengthValidatorForTextFields() and

      SetMaxLengthFilterForTextFields() methods, and also corresponding

      TSQLModel.SetMaxLength[Validator/Filter]ForAllTextFields() methods

      so that text column lengths may be checked or truncated before sending

      to an external database expecting a maximum length

    - fixed issue in TSQLRecordProperties.SetSimpleFieldsExpandedJSONWriter()

      when the record contains some TCreateTime published field type

    - added TSQLTable.GetAsInt64() method (proposal [3bea5d89c6])

    - added TSQLTable.GetAsFloat() GetAsCurrency() GetAsDateTime() methods

    - JSON parsing will now expect true, false or null to be in lowercase

      (as in json.org specifications)

    - SetWeakZero() function will now use a much faster per-class lock design

    - exposed StatusCodeToErrorMsg() function

    - extraction of TTestLowLevelTypes and TTestBasicClasses code into

      SynSelfTests.pas unit

    - allow only to delete its own session - security fix for ticket [7723fa7ebd]

    - variant published properties will use getter/setter - ticket [479938b694]

    - double/currency published properties will use getter/setter as expected

    - fix TSQLRestClientURI.Commit/RollBack to work as expected

    - added optional RaiseException parameter to TSQLRest.Commit for [fa702c126a]

    - introducing TSQLRestServer.AuthenticationRegister/AuthenticationUnregister

      methods and associated TSQLRestServerAuthentication* classes, used also by

      TSQLRestClientURI.SetUser() to allow generic class-driven authentication

      schemes for feature request [8c8a2a880c]

    - added TSQLRestServerAuthentication.Options, e.g. saoUserByLogonOrID to

      allow login via TSQLAuthUser.ID in addition to LogonName

    - return also "logongroup":TSQLAuthGroup.ID on successful authentication

    - added TSQLRestServerAuthenticationSignedURI.NoTimeStampCoherencyCheck and

      TimeStampCoherencySeconds properties to tune or disable the session

      timestamp check during URI signature authentication (default to 5 seconds)

    - new TSQLRestServerAuthenticationNone weak but simple method

    - force almost-random session ID for TSQLRestServer to avoid collision

      after server restart

    - stronger client-generated nonce for TSQLRestServerAuthenticationDefault

    - ORM/SOA threads will display a friendly name in the IDE for [6acfd0a3d3]

    - new TSynMonitor class, for easy statistics gathering of any process:

      will be shared by framework's ORM, SOA and DDD implementation

    - introducing TSQLRestServerKind enumeration to identify the kind of

      TSQLRestServer instance running (SQlite3/static/virtual) for a table

    - TSQLRestServer.SessionGetUser method is now made public (e.g. when

      calling CurrentServiceContext.Factory.RestServer.SessionGetUser)

    - added TSQLRestClientURI.OnIdle property, to enable more responsive

      User Interface in case of slow network - feature request [68337ae98a]

    - introducing InternalClassPropInfo() as wrapper around InternalClassProp()

    - replaced confusing TVarData by a new dedicated TSQLVar memory structure,

      shared with SynDB and mORMotSQLite3 units (includes methods refactoring)



*)





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



{.$define PUREPASCAL}  // define for debugg, not on production

{.$define USETYPEINFO} // define for debugg, not on production



{$ifdef MSWINDOWS}



  {.$define ANONYMOUSNAMEDPIPE}

  // if defined, the security attributes of the named pipe will use an

  // anonymous connection - it should allow access to a service initialized

  // named pipe on a remote computer.

  // - I tried to implement the code as detailed in this Microsoft article:

  // http://support.microsoft.com/kb/813414 but it didn't work as

  // expected: see our forum http://synopse.info/forum/viewtopic.php?id=43

  // - don't define it, because it's still buggy, and consider using HTTP

  // connection for remote access over the network

    {$define NOSECURITYFORNAMEDPIPECLIENTS}

    // define this may avoid issues with Delphi XE+ for obscure reasons





  {.$define SSPIAUTH}

  // if defined, the Windows built-in authentication will be used

  // along with the usual one

  // - If you pass to TSQLRestClientURI.SetUser an empty string as user name,

  // the Windows authentication will be performed

  // - In this case, in table TSQLAuthUser should be an entry for the

  // windows user, with the LoginName in form 'DomainName\UserName'



{$endif}



interface



uses

{$ifdef MSWINDOWS}

  Windows,

  Messages,

{$endif}

{$ifdef KYLIX3}

  Types,

  LibC,

  SynKylix,

{$endif}

{$ifdef UNICODE}

  Generics.Collections,

{$endif}

  Classes,

  SynZip, // use crc32 for TSQLRestClientURI.SetUser

{$ifdef USETYPEINFO}

  // some pure pascal version must handle the 64-bits ordinal values or

  // a not-Delphi RTTI layout of the underlying compiler (e.g. FPC)

  TypInfo,

  {$ifdef FPC}

  SynFPCTypInfo, // small wrapper unit around FPC's TypInfo.pp

  {$endif}

{$endif}

{$ifndef LVCL}

  SyncObjs, // for TEvent and TCriticalSection

  Contnrs,  // for TObjectList

  {$ifndef NOVARIANTS}

    Variants,

  {$endif}

{$endif LVCL}

  SysUtils,

{$ifdef SSPIAUTH}

  SynSSPIAuth,

{$endif}

  SynCommons,

  SynLog,

  SynTests;







{ ************ low level types and constants for handling JSON and fields }



  { Why use JSON? (extracted from the main framework documentation)

    - The JavaScript Object Notation (JSON) is a lightweight computer data

     interchange format

    - Like XML, it's a text-based, human-readable format for representing

     simple data structures and associative arrays (called objects)

    - It's easier to read, quicker to implement and smaller in size than XML

    - It's a very efficient format for cache

    - It's natively supported by the JavaScript language, making it a perfect

     serialization format for any Ajax application

    - The JSON format is specified in http://tools.ietf.org/html/rfc4627

    - The default text encoding for both JSON and SQLite3 is UTF-8, which

     allows the full Unicode charset to be stored and communicated

    - It is the default data format used by ASP.NET AJAX services created in

     Windows Communication Foundation (WCF) since .NET framework 3.5

    - For binary blob transmission, we simply encode the binary data as hexa

     using the SQLite3 BLOB literals format : hexadecimal data preceded by

     a single "x" or "X" character (for example: X'53514C697465'), or Base64

     encoding - see BlobToTSQLRawBlob() function }





const

  /// maximum number of Tables in a Database Model

  // - this constant is used internaly to optimize memory usage in the

  // generated asm code

  // - you should not change it to a value lower than expected in an existing

  // database (e.g. as expected by TSQLAccessRights or such)

  MAX_SQLTABLES = 256;





type

  /// this is the type to be used for our ORM primary key, i.e. TSQLRecord.ID

  // - it maps the SQLite3 RowID definition

  // - when converted to plain TSQLRecord published properties, you may loose

  // some information under Win32 when stored as a 32 bit pointer

  // - could be defined as value in a TSQLRecord property as such:

  // ! property AnotherRecord: TID read fAnotherRecord write fAnotherRecord;

  TID = type Int64;



  /// a pointer to a ORM primary key, i.e. TSQLRecord.ID: TID

  PID = ^TID;



  /// used to store a dynamic array of ORM primary keys, i.e. TSQLRecord.ID

  TIDDynArray = array of TID;



  /// used to store bit set for all available Tables in a Database Model

  TSQLFieldTables = set of 0..MAX_SQLTABLES-1;



  /// a String used to store the BLOB content

  // - equals RawByteString for byte storage, to force no implicit charset

  // conversion, whatever the codepage of the resulting string is

  // - will identify a sftBlob field type, if used to define such a published

  // property

  // - by default, the BLOB fields are not retrieved or updated with raw

  // TSQLRest.Retrieve() method, that is "Lazy loading" is enabled by default

  // for blobs, unless TSQLRestClientURI.ForceBlobTransfert property is TRUE

  // (for all tables), or ForceBlobTransfertTable[] (for a particular table);

  // so use RetrieveBlob() methods for handling BLOB fields

  // - could be defined as value in a TSQLRecord property as such:

  // ! property Blob: TSQLRawBlob read fBlob write fBlob;

  TSQLRawBlob = type RawByteString;



  /// a reference to another record in any table in the database Model

  // - stored as a 64-bit signed integer (just like the TID type)

  // - type cast any value of TRecordReference with the RecordRef object below

  // for easy access to its content

  // - use TSQLRest.Retrieve(Reference) to get a record value

  // - don't change associated TSQLModel tables order, since TRecordReference

  // depends on it to store the Table type in its highest bits

  // - when the pointed record will be deleted, this property will be set to 0

  // by TSQLRestServer.AfterDeleteForceCoherency()

  // - could be defined as value in a TSQLRecord property as such:

  // ! property AnotherRecord: TRecordReference read fAnotherRecord write fAnotherRecord;

  TRecordReference = type Int64;



  /// a reference to another record in any table in the database Model

  // - stored as a 64-bit signed integer (just like the TID type)

  // - type cast any value of TRecordReference with the RecordRef object below

  // for easy access to its content

  // - use TSQLRest.Retrieve(Reference) to get a record value

  // - don't change associated TSQLModel tables order, since TRecordReference

  // depends on it to store the Table type in its highest bits

  // - when the pointed record will be deleted, any record containg a matching

  // property will be deleted by TSQLRestServer.AfterDeleteForceCoherency()

  // - could be defined as value in a TSQLRecord property as such:

  // ! property AnotherRecord: TRecordReferenceToBeDeleted

  // !   read fAnotherRecord write fAnotherRecord;

  TRecordReferenceToBeDeleted = type TRecordReference;



  /// an Int64-encoded date and time of the latest update of a record

  // - can be used as published property field in TSQLRecord for sftModTime:

  // if any such property is defined in the table, it will be auto-filled with

  // the server timestamp corresponding to the latest record update

  // - use internally for computation an abstract "year" of 16 months of 32 days

  // of 32 hours of 64 minutes of 64 seconds - faster than TDateTime

  // - use TimeLogFromDateTime/TimeLogToDateTime/TimeLogNow/Iso8601ToTimeLog

  // functions, or type-cast the value with a TTimeLogBits memory structure for

  // direct access to its bit-oriented content (or via PTimeLogBits pointer)

  // - could be defined as value in a TSQLRecord property as such:

  // ! property LastModif: TModTime read fLastModif write fLastModif;

  TModTime = type TTimeLog;



  /// an Int64-encoded date and time of the record creation

  // - can be used as published property field in TSQLRecord for sftCreateTime:

  // if any such property is defined in the table, it will be auto-filled with

  // the server timestamp corresponding to the record creation

  // - use internally for computation an abstract "year" of 16 months of 32 days

  // of 32 hours of 64 minutes of 64 seconds - faster than TDateTime

  // - use TimeLogFromDateTime/TimeLogToDateTime/TimeLogNow/Iso8601ToTimeLog

  // functions, or type-cast the value with a TTimeLogBits memory structure for

  // direct access to its bit-oriented content (or via PTimeLogBits pointer)

  // - could be defined as value in a TSQLRecord property as such:

  // ! property CreatedAt: TModTime read fCreatedAt write fCreatedAt;

  TCreateTime = type TTimeLog;



  /// the Int64/TID of the TSQLAuthUser currently logged   

  // - can be used as published property field in TSQLRecord for sftSessionUserID:

  // if any such property is defined in the table, it will be auto-filled with

  // the current TSQLAuthUser.ID value at update, or 0 if no session is running

  // - could be defined as value in a TSQLRecord property as such:

  // ! property User: TSessionUserID read fUser write fUser;

  TSessionUserID = type TID;



  /// a monotonic version number, used to track changes on a table

  // - add such a published field to any TSQLRecord will allow tracking of

  // record modifications - note that only a single field of this type should

  // be defined for a given record

  // - note that this published field is NOT part of the record "simple fields":

  // by default, the version won't be retrieved from the DB, nor will be sent

  // from a client - the Engine*() CRUD method will take care of computing the

  // monotonic version number, just before storage to the persistence engine

  // - such a field will use a separated TSQLRecordTableDeletion table to

  // track the deleted items

  // - could be defined as value in a TSQLRecord property as such:

  // ! property TrackedVersion: TRecordVersion read fVersion write fVersion;

  TRecordVersion = type Int64;



  /// the available types for any SQL field property, as managed with the

  // database driver

  // - sftUnknown: unknown or not defined field type

  // - sftAnsiText: a WinAnsi encoded TEXT, forcing a NOCASE collation

  // (TSQLRecord Delphi property was declared as AnsiString or string before

  // Delphi 2009)

  // - sftUTF8Text is UTF-8 encoded TEXT, forcing a SYSTEMNOCASE collation,

  // i.e. using UTF8IComp() (TSQLRecord property was declared as RawUTF8,

  // RawUnicode or WideString - or string in Delphi 2009+)

  //- sftEnumerate is an INTEGER value corresponding to an index in any

  // enumerate Delphi type; storage is an INTEGER value (fast, easy and size

  // efficient); at display, this integer index will be converted into the

  // left-trimed lowercased chars of the enumerated type text conversion:

  // TOpenType(1) = otDone -> 'Done'

  /// - sftSet is an INTEGER value corresponding to a bitmapped set of

  // enumeration; storage is an INTEGER value (fast, easy and size efficient);

  // displayed as an integer by default, sets with an enumeration type with

  // up to 64 elements is allowed yet (stored as an Int64)

  // - sftInteger is an INTEGER (Int64 precision, as expected by SQLite3) field

  // - sftID is an INTEGER field pointing to the ID/ROWID of another record of

  // a table, defined by the class type of the TSQLRecord inherited property;

  // coherency is always ensured: after a delete, all values pointing to

  // it is reset to 0

  // - sftRecord is an INTEGER field pointing to the ID/ROWID of another

  // record: TRecordReference=Int64 Delphi property which can be typecasted to

  // RecordRef; coherency is always ensured: after a delete, all values

  // pointing to it are reset to 0 by the ORM

  // - sftBoolean is an INTEGER field for a boolean value: 0 is FALSE,

  // anything else TRUE (encoded as JSON 'true' or 'false' constants)

  // - sftFloat is a FLOAT (floating point double precision, cf. SQLite3)

  // field, defined as double (or single) published properties definition

  // - sftDateTime is a ISO 8601 encoded (SQLite3 compatible) TEXT field,

  // corresponding to a TDateTime Delphi property: a ISO8601 collation is

  // forced for such column, for proper date/time sorting and searching

  // - sftTimeLog is an INTEGER field for coding a date and time (not SQLite3

  // compatible), which should be defined as TTimeLog=Int64 Delphi property,

  // ready to be typecasted to the TTimeLogBits optimized type for efficient

  // timestamp storage, with a second resolution

  // - sftCurrency is a FLOAT containing a 4 decimals floating point value,

  // compatible with the Currency Delphi type, which minimizes rounding errors

  // in monetary calculations which may occur with sftFloat type

  // - sftObject is a TEXT containing an ObjectToJSON serialization, able to

  // handle published properties of any not TPersistent as JSON object,

  // TStrings or TRawUTF8List  as JSON arrays of strings, TCollection or

  // TObjectList as JSON arrays of JSON objects

  // - sftVariant is a TEXT containing a variant value encoded as JSON:

  // string values are stored between quotes, numerical values directly stored,

  // and JSON objects or arrays will be handled as TDocVariant custom types

  // - sftNullable is a INTEGER/DOUBLE/TEXT field containing a NULLable value,

  // stored as a local variant property, identifying TNullableInteger,

  // TNullableBoolean, TNullableFloat, TNullableCurrency,

  // TNullableDateTime, TNullableTimeLog and TNullableUTF8Text types

  // - sftBlob is a BLOB field (TSQLRawBlob Delphi property), and won't be

  // retrieved by default (not part of ORM "simple types"), to save bandwidth

  // - sftBlobDynArray is a dynamic array, stored as BLOB field: this kind of

  // property will be retrieved by default, i.e. is recognized as a "simple

  // field", and will use Base64 encoding during JSON transmission, or a true

  // JSON array, depending on the database back-end (e.g. MongoDB)

  // - sftBlobCustom is a custom property, stored as BLOB field: such

  // properties are defined by adding a TSQLPropInfoCustom instance, overriding

  // TSQLRecord.InternalRegisterCustomProperties virtual method - they will

  // be retrieved by default, i.e. recognized as "simple fields"

  // - sftUTF8Custom is a custom property, stored as JSON in a TEXT field,

  // defined by overriding TSQLRecord.InternalRegisterCustomProperties

  // virtual method, and adding a TSQLPropInfoCustom instance, e.g. via

  // RegisterCustomPropertyFromTypeName() or RegisterCustomPropertyFromRTTI();

  // they will be retrieved by default, i.e. recognized as "simple fields"

  // - sftMany is a 'many to many' field (TSQLRecordMany Delphi property);

  // nothing is stored in the table row, but in a separate pivot table: so

  // there is nothing to retrieve here; in contrast to other TSQLRecord

  // published properties, which contains an INTEGER ID, the TSQLRecord.Create

  // will instanciate a true TSQLRecordMany instance to handle this pivot table

  // via its dedicated ManyAdd/FillMany/ManySelect methods - as a result, such

  // properties won't be retrieved by default, i.e. not recognized as "simple

  // fields" unless you used the dedicated methods

  // - sftModTime is an INTEGER field containing the TModTime value, aka time

  // of the record latest update; TModTime (just like TTimeLog or TCreateTime)

  // published property can be typecasted to the TTimeLogBits memory structure;

  // the value of this field is automatically updated with the current

  // date and time each time a record is updated (with external DB, it will

  // use the Server time, as retrieved from SynDB) - see ComputeFieldsBeforeWrite

  // virtual method of TSQLRecord; note also that only RESTful PUT/POST access

  // will change this field value: manual SQL statements (like

  // 'UPDATE Table SET Column=0') won't change its content; note also that

  // this is automated on Delphi client side, so only within TSQLRecord ORM use

  // (a pure AJAX application should fill such fields explicitely before sending)

  // - sftCreateTime is an INTEGER field containing the TCreateTime time

  // of the record creation; TCreateTime (just like TTimeLog or TModTime)

  // published property can be typecasted to the TTimeLogBits memory structure;

  // the value of this field is automatically updated with the current

  // date and time when the record is created (with external DB, it will

  // use the Server time, as retrieved from SynDB) - see ComputeFieldsBeforeWrite

  // virtual method of TSQLRecord; note also that only RESTful PUT/POST access

  // will set this field value: manual SQL statements (like

  // 'INSERT INTO Table ...') won't set its content; note also that this is

  // automated on Delphi client side, so only within TSQLRecord ORM use (a

  // pure AJAX application should fill such fields explicitely before sending)

  // - sftTID is an INTEGER field containing a TID pointing to another record;

  // since regular TSQLRecord published properties (i.e. sftID kind of field)

  // can not be greater than 2,147,483,647 (i.e. a signed 32 bit value) under

  // Win32, defining TID published properties would allow to store the ID

  // as signed 64-bit, e.g. up to 9,223,372,036,854,775,808; despite to

  // sftID kind of record, coherency is NOT ensured: after a deletion, all

  // values pointing to are NOT reset to 0 - it is up to your business logic

  // to ensure data coherency as expected

  // - sftRecordVersion is an INTEGER field containing a TRecordVersion

  // monotonic number: adding such a published field to any TSQLRecord will

  // allow tracking of record modifications, at storage level; by design,

  // such a field won't be part of "simple types", so won't be transmitted

  // between the clients and the server, but will be updated at any write

  // operation by the low-level Engine*() storage methods - such a field

  // will use a TSQLRecordTableDeletion table to track the deleted items

  // - sftSessionUserID is an INTEGER field containing the TSQLAuthUser.ID

  // of the record modification; the value of this field is automatically

  // updated with the current User ID of the active session; note also that

  // only RESTful PUT/POST access will change this field value: manual SQL

  // statements (like 'UPDATE Table SET Column=0') won't change its content;

  // this is automated on Delphi client side, so only within TSQLRecord ORM use

  // (a pure AJAX application should fill such fields explicitely before sending)

  TSQLFieldType = (

    sftUnknown,

    sftAnsiText,

    sftUTF8Text,

    sftEnumerate,

    sftSet,

    sftInteger,

    sftID,

    sftRecord,

    sftBoolean,

    sftFloat,

    sftDateTime,

    sftTimeLog,

    sftCurrency,

    sftObject,

    {$ifndef NOVARIANTS}

    sftVariant,

    sftNullable,

    {$endif}

    sftBlob,

    sftBlobDynArray,

    sftBlobCustom,

    sftUTF8Custom,

    sftMany,

    sftModTime,

    sftCreateTime,

    sftTID,

    sftRecordVersion,

    sftSessionUserID);



  /// set of available SQL field property types

  TSQLFieldTypes = set of TSQLFieldType;



  //// a fixed array of SQL field property types

  TSQLFieldTypeArray = array[0..MAX_SQLFIELDS] of TSQLFieldType;



  /// contains the parameters used for sorting

  // - FieldCount is 0 if was never sorted

  // - used to sort data again after a successfull data update with TSQLTableJSON.FillFrom()

  TSQLTableSortParams = record

    FieldCount, FieldIndex: integer;

    FieldType: TSQLFieldType;

    Asc: boolean;

  end;



  /// used to define the triggered Event types for TNotifySQLEvent

  // - some Events can be triggered via TSQLRestServer.OnUpdateEvent when

  // a Table is modified, and actions can be authorized via overriding the

  // TSQLRest.RecordCanBeUpdated method

  // - OnUpdateEvent is called BEFORE deletion, and AFTER insertion or update; it

  // should be used only server-side, not to synchronize some clients: the framework

  // is designed around a stateless RESTful architecture (like HTTP/1.1), in which

  // clients ask the server for refresh (see TSQLRestClientURI.UpdateFromServer)

  // - is used also by TSQLRecord.ComputeFieldsBeforeWrite virtual method

  TSQLEvent = (

    seAdd,

    seUpdate,

    seDelete,

    seUpdateBlob);



  /// used to define the triggered Event types for TSQLRecordHistory

  // - TSQLRecordHistory.History will be used for heArchiveBlob

  // - TSQLRecordHistory.SentDataJSON will be used for other kind of events

  TSQLHistoryEvent = (

    heAdd,

    heUpdate,

    heDelete,

    heArchiveBlob);



  /// used to defined the CRUD associated SQL statement of a command

  // - used e.g. by TSQLRecord.GetJSONValues methods and SimpleFieldsBits[] array

  // (in this case, soDelete is never used, since deletion is global for all fields)

  // - also used for cache content notification

  TSQLOccasion = (

    soSelect,

    soInsert,

    soUpdate,

    soDelete);



  /// used to defined a set of CRUD associated SQL statement of a command

  TSQLOccasions = set of TSQLOccasion;



const

  /// kind of fields not retrieved during normal query, update or adding

  // - by definition, BLOB are excluded to save transmission bandwidth

  // - by design, TSQLRecordMany properties are stored in an external pivot table

  // - by convenience, the TRecordVersion number is for internal use only

  NOT_SIMPLE_FIELDS: TSQLFieldTypes =

    [sftUnknown,sftBlob,sftMany,sftRecordVersion];



  /// kind of fields which can be copied from one TSQLRecord instance to another

  COPIABLE_FIELDS: TSQLFieldTypes =

    [low(TSQLFieldType)..high(TSQLFieldType)] - [sftUnknown, sftMany];



  /// kind of DB fields which will contain TEXT content when converted to JSON

  TEXT_DBFIELDS: TSQLDBFieldTypes = [ftUTF8,ftDate];



  /// kind of fields which will contain pure TEXT values

  // - independently from the actual storage level

  // - i.e. will match RawUTF8, string, UnicodeString, WideString properties

  RAWTEXT_FIELDS: TSQLFieldTypes = [sftAnsiText,sftUTF8Text];



{$ifndef NOVARIANTS}

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;



const

  /// the SQL field property types with their TNullable* equivalency

  // - those types may be stored in a variant published property, e.g.

  // ! property Int: TNullableInteger read fInt write fInt;

  // ! property Txt: TNullableUTF8Text read fTxt write fTxt;

  // ! property Txt: TNullableUTF8Text index 32 read fTxt write fTxt;

  NULLABLE_TYPES = [sftInteger,sftBoolean,sftEnumerate,sftFloat,sftCurrency,

    sftDateTime,sftTimeLog,sftUTF8Text];



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



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;



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



/// similar to AddInt64() function, but for a TIDDynArray

// - some random GPF were identified with AddInt64(TInt64DynArray(Values),...)

// with the Delphi Win64 compiler

procedure AddID(var Values: TIDDynArray; var ValuesCount: integer; Value: TID);



type

  /// the available options for TSQLRest.BatchStart() process

  // - boInsertOrIgnore will create 'INSERT OR IGNORE' statements instead of

  // plain 'INSERT' - by now, only the direct mORMotSQLite3 engine supports it

  // - boInsertOrUpdate will create 'INSERT OR REPLACE' statements instead of

  // plain 'INSERT' - by now, only the direct mORMotSQLite3 engine supports it

  // - boExtendedJSON would force the JSON to unquote the column names,

  // e.g. writing col1:...,col2:... instead of "col1":...,"col2"...

  // - boPostNoSimpleFields would avoid to send a TSQLRestBach.Add() with simple

  // fields as "SIMPLE":[val1,val2...] or "SIMPLE@tablename":[val1,val2...],

  // without the field names

  TSQLRestBatchOption = (

    boInsertOrIgnore, boInsertOrReplace,

    boExtendedJSON, boPostNoSimpleFields);



  /// a set of options for TSQLRest.BatchStart() process

  // - TJSONObjectDecoder will use it to compute the corresponding SQL

  TSQLRestBatchOptions = set of TSQLRestBatchOption;



  /// define how TJSONObjectDecoder.Decode() will handle JSON string values

  TJSONObjectDecoderParams = (pInlined, pQuoted, pNonQuoted);



  /// define how TJSONObjectDecoder.FieldTypeApproximation[] is identified

  TJSONObjectDecoderFieldType = (

    ftaNumber,ftaBoolean,ftaString,ftaDate,ftaNull,ftaBlob,ftaObject,ftaArray);



  /// JSON object decoding and SQL generation, in the context of ORM process

  // - this is the main process for marshalling JSON into SQL statements

  // - used e.g. by GetJSONObjectAsSQL() function or ExecuteFromJSON and

  // InternalBatchStop methods

  TJSONObjectDecoder = {$ifndef ISDELPHI2010}object{$else}record{$endif}

    /// contains the decoded field names

    FieldNames: array[0..MAX_SQLFIELDS-1] of RawUTF8;

    /// contains the decoded field values

    FieldValues: array[0..MAX_SQLFIELDS-1] of RawUTF8;

    /// Decode() will set each field type approximation

    // - will recognize also JSON_BASE64_MAGIC/JSON_SQLDATE_MAGIC prefix

    FieldTypeApproximation: array[0..MAX_SQLFIELDS-1] of TJSONObjectDecoderFieldType;

    /// number of fields decoded in FieldNames[] and FieldValues[]

    FieldCount: integer;

    /// set to TRUE if parameters are to be :(...): inlined

    InlinedParams: boolean;

    /// internal pointer over field names to be used after Decode() call

    // - either FieldNames, either Fields[] array as defined in Decode()

    DecodedFieldNames: PRawUTF8Array;

    /// the ID=.. value as sent within the JSON object supplied to Decode()

    DecodedRowID: TID;

    /// decode the JSON object fields into FieldNames[] and FieldValues[]

    // - if Fields=nil, P should be a true JSON object, i.e. defined

    // as "COL1"="VAL1" pairs, stopping at '}' or ']'; otherwise, Fields[]

    // contains column names and expects a JSON array as "VAL1","VAL2".. in P

    // - P should be after the initial '{' or '[' character, i.e. at first field

    // - P returns the next object start or nil on unexpected end of input

    // - P^ buffer will let the JSON be decoded in-place, so consider using

    // the overloaded Decode(JSON: RawUTF8; ...) method

    // - FieldValues[] strings will be quoted and/or inlined depending on Params

    // - if RowID is set, a RowID column will be added within the returned content

    procedure Decode(var P: PUTF8Char; const Fields: TRawUTF8DynArray;

      Params: TJSONObjectDecoderParams; const RowID: TID=0; ReplaceRowIDWithID: Boolean=false); overload;

    /// decode the JSON object fields into FieldNames[] and FieldValues[]

    // - overloaded method expecting a RawUTF8 buffer, making a private copy

    // of the JSON content to avoid unexpected in-place modification, then

    // calling Decode(P: PUTF8Char) to perform the process

    procedure Decode(const JSON: RawUTF8; const Fields: TRawUTF8DynArray;

      Params: TJSONObjectDecoderParams; const RowID: TID=0; ReplaceRowIDWithID: Boolean=false); overload;

    /// can be used after Decode() to add a new field in FieldNames/FieldValues

    // - so that EncodeAsSQL() will include this field in the generated SQL

    // - caller should ensure that the FieldName is not already defined in

    // FieldNames[] (e.g. when the TRecordVersion field is forced)

    // - the caller should ensure that the supplied FieldValue will match

    // the quoting/inlining expectations of Decode(TJSONObjectDecoderParams) -

    // e.g. that string values are quoted if needed

    procedure AddFieldValue(const FieldName,FieldValue: RawUTF8;

      FieldType: TJSONObjectDecoderFieldType);

    /// encode as a SQL-ready INSERT or UPDATE statement

    // - after a successfull call to Decode()

    // - escape SQL strings, according to the official SQLite3 documentation

    // (i.e. ' inside a string is stored as '')

    // - if InlinedParams was TRUE, it will create prepared parameters like

    // 'COL1=:("VAL1"):, COL2=:(VAL2):'

    // - called by GetJSONObjectAsSQL() function or TSQLRestStorageExternal

    function EncodeAsSQL(Update: boolean): RawUTF8;

    /// encode as a SQL-ready INSERT or UPDATE statement with ? as values

    // - after a successfull call to Decode()

    // - FieldValues[] content will be ignored

    // - Occasion can be only soInsert or soUpdate

    // - for soUpdate, will create UPDATE ... SET ... where UpdateIDFieldName=?

    // - you can specify some options, e.g. boInsertOrIgnore for soInsert

    function EncodeAsSQLPrepared(const TableName: RawUTF8; Occasion: TSQLOccasion;

      const UpdateIDFieldName: RawUTF8; BatchOptions: TSQLRestBatchOptions): RawUTF8;

    /// encode the FieldNames/FieldValues[] as a JSON object

    procedure EncodeAsJSON(out result: RawUTF8);

    /// set the specified array to the fields names

    // - after a successfull call to Decode()

    procedure AssignFieldNamesTo(var Fields: TRawUTF8DynArray);

    /// returns TRUE if the specified array match the decoded fields names

    // - after a successfull call to Decode()

    function SameFieldNames(const Fields: TRawUTF8DynArray): boolean;

    /// search for a field name in the current identified FieldNames[]

    function FindFieldName(const FieldName: RawUTF8): integer;

  end;



/// set the TID (=64 bits integer) value from the numerical text stored in P^

// - just a redirection to SynCommons.SetInt64()

procedure SetID(P: PUTF8Char; var result: TID); overload;

  {$ifdef HASINLINE}inline;{$endif}



/// set the TID (=64 bits integer) value from the numerical text stored in U

// - just a redirection to SynCommons.SetInt64()

procedure SetID(const U: RawByteString; var result: TID); overload;

  {$ifdef HASINLINE}inline;{$endif}



/// decode JSON fields object into an UTF-8 encoded SQL-ready statement

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

// - P should be after the initial '{' or '[' character, i.e. at first field

// - P contains the next object start or nil on unexpected end of input

// - if Fields is void, expects expanded "COL1"="VAL1" pairs in P^, stopping at '}' or ']'

// - otherwise, Fields[] contains the column names and expects "VAL1","VAL2".. in P^

// - returns 'COL1="VAL1", COL2=VAL2' if UPDATE is true (UPDATE SET format)

// - returns '(COL1, COL2) VALUES ("VAL1", VAL2)' otherwise (INSERT format)

// - escape SQL strings, according to the official SQLite3 documentation

// (i.e. ' inside a string is stored as '')

// - if InlinedParams is set, will create prepared parameters like

// 'COL1=:("VAL1"):, COL2=:(VAL2):'

// - if RowID is set, a RowID column will be added within the returned content

function GetJSONObjectAsSQL(var P: PUTF8Char; const Fields: TRawUTF8DynArray;

  Update, InlinedParams: boolean; RowID: TID=0; ReplaceRowIDWithID: Boolean=false): RawUTF8; overload;



/// decode JSON fields object into an UTF-8 encoded SQL-ready statement

// - is used e.g. by TSQLRestServerDB.EngineAdd/EngineUpdate methods

// - expect a regular JSON expanded object as "COL1"="VAL1",...} pairs

// - make its own temporary copy of JSON data before calling GetJSONObjectAsSQL() above

// - returns 'COL1="VAL1", COL2=VAL2' if UPDATE is true (UPDATE SET format)

// - returns '(COL1, COL2) VALUES ("VAL1", VAL2)' otherwise (INSERT format)

// - if InlinedParams is set, will create prepared parameters like 'COL2=:(VAL2):'

// - if RowID is set, a RowID column will be added within the returned content

function GetJSONObjectAsSQL(const JSON: RawUTF8; Update, InlinedParams: boolean;

  RowID: TID=0; ReplaceRowIDWithID: Boolean=false): RawUTF8; overload;



/// get the FIRST field value of the FIRST row, from a JSON content

// - e.g. useful to get an ID without converting a JSON content into a TSQLTableJSON

function UnJSONFirstField(var P: PUTF8Char): RawUTF8;



/// returns TRUE if the JSON content is in expanded format

// - i.e. as plain [{"ID":10,"FirstName":"John","LastName":"Smith"}...]

// - i.e. not as '{"fieldCount":3,"values":["ID","FirstName","LastName",...']}

function IsNotAjaxJSON(P: PUTF8Char): Boolean;



/// retrieve a JSON '{"Name":Value,....}' object

// - P is nil in return in case of an invalid object

// - returns the UTF-8 encoded JSON object, including first '{' and last '}'

// - if ExtractID is set, it will contain the "ID":203 field value, and this

// field won't be included in the resulting UTF-8 encoded JSON object unless

// KeepIDField is true

// - this function expects this "ID" property to be the FIRST in the

// "Name":Value pairs, as generated by TSQLRecord.GetJSONValues(W)

function JSONGetObject(var P: PUTF8Char; ExtractID: PID;

  var EndOfObject: AnsiChar; KeepIDField: boolean): RawUTF8;



/// retrieve the ID/RowID field of a JSON object

// - this function expects this "ID" property to be the FIRST in the

// "Name":Value pairs, as generated by TSQLRecord.GetJSONValues(W)

// - returns TRUE if ID/RowID has been found, and set ID with the value

function JSONGetID(P: PUTF8Char; out ID: TID): Boolean;



/// fill a TSQLRawBlob from TEXT-encoded blob data

// - blob data can be encoded as SQLite3 BLOB literals (X'53514C697465' e.g.) or

// or Base-64 encoded content ('\uFFF0base64encodedbinary') or plain TEXT

function BlobToTSQLRawBlob(P: PUTF8Char): TSQLRawBlob; overload;



/// fill a TSQLRawBlob from TEXT-encoded blob data

// - blob data can be encoded as SQLite3 BLOB literals (X'53514C697465' e.g.) or

// or Base-64 encoded content ('\uFFF0base64encodedbinary') or plain TEXT

function BlobToTSQLRawBlob(const Blob: RawByteString): TSQLRawBlob; overload;



/// create a TBytes from TEXT-encoded blob data

// - blob data can be encoded as SQLite3 BLOB literals (X'53514C697465' e.g.) or

// or Base-64 encoded content ('\uFFF0base64encodedbinary') or plain TEXT

function BlobToBytes(P: PUTF8Char): TBytes;



/// create a memory stream from TEXT-encoded blob data

// - blob data can be encoded as SQLite3 BLOB literals (X'53514C697465' e.g.) or

// or Base-64 encoded content ('\uFFF0base64encodedbinary') or plain TEXT

// - the caller must free the stream instance after use

function BlobToStream(P: PUTF8Char): TStream;



/// creates a TEXT-encoded version of blob data from a TSQLRawBlob

// - TEXT will be encoded as SQLite3 BLOB literals (X'53514C697465' e.g.)

function TSQLRawBlobToBlob(const RawBlob: TSQLRawBlob): RawUTF8; overload;

  {$ifdef HASINLINE}inline;{$endif}



/// creates a TEXT-encoded version of blob data from a memory data

// - same as TSQLRawBlob, but with direct memory access via a pointer/byte size pair

// - TEXT will be encoded as SQLite3 BLOB literals (X'53514C697465' e.g.)

function TSQLRawBlobToBlob(RawBlob: pointer; RawBlobLength: integer): RawUTF8; overload;



/// convert a Base64-encoded content into binary hexadecimal ready for SQL

// - returns e.g. X'53514C697465'

procedure Base64MagicToBlob(Base64: PUTF8Char; var result: RawUTF8);



/// return true if the TEXT is encoded as SQLite3 BLOB literals (X'53514C697465' e.g.)

function isBlobHex(P: PUTF8Char): boolean;

  {$ifdef HASINLINE}inline;{$endif}



/// compute the SQL corresponding to a WHERE clause

// - returns directly the Where value if it starts with one the

// ORDER/GROUP/LIMIT/OFFSET/JOIN keywords

// - otherwise, append ' WHERE '+Where

function SQLFromWhere(const Where: RawUTF8): RawUTF8;



/// find out if the supplied WHERE clause starts with one of the

// ORDER/GROUP/LIMIT/OFFSET/JOIN keywords

function SQLWhereIsEndClause(const Where: RawUTF8): boolean;



/// naive search of '... FROM TableName ...' pattern in the supplied SQL

function GetTableNameFromSQLSelect(const SQL: RawUTF8;

  EnsureUniqueTableInFrom: boolean): RawUTF8;



/// naive search of '... FROM Table1,Table2 ...' pattern in the supplied SQL

function GetTableNamesFromSQLSelect(const SQL: RawUTF8): TRawUTF8DynArray;



/// guess the content type of an UTF-8 encoded field value, as used in TSQLTable.Get()

// - if P if nil or 'null', return sftUnknown

// - otherwise, guess its type from its value characters

// - sftBlob is returned if the field is encoded as SQLite3 BLOB literals

// (X'53514C697465' e.g.) or with '\uFFF0' magic code

// - since P is PUTF8Char, string type is sftUTF8Text only

// - sftFloat is returned for any floating point value, even if it was

// declared as sftCurrency type

// - sftInteger is returned for any INTEGER stored value, even if it was declared

// as sftEnumerate, sftSet, sftID, sftTID, sftRecord, sftRecordVersion,

// sftSessionUserID, sftBoolean or sftModTime / sftCreateTime / sftTimeLog type

function UTF8ContentType(P: PUTF8Char): TSQLFieldType;



/// guess the number type of an UTF-8 encoded field value, as used in TSQLTable.Get()

// - if P if nil or 'null', return sftUnknown

// - will return sftInteger or sftFloat if the supplied text is a number

// - will return sftUTF8Text for any non numerical content

function UTF8ContentNumberType(P: PUTF8Char): TSQLFieldType;

  {$ifdef HASINLINE}inline;{$endif}





/// read an object properties, as saved by TINIWriter.WriteObject() method

// - i.e. only Integer, Int64, enumerates (including boolean), floating point,

// variant and (Ansi/Wide/Unicode)String properties (excluding shortstring)

// - read only the published properties of the current class level (do NOT

// read the properties content published in the parent classes)

// - "From" must point to the [section] containing the object properties

// - for integers and enumerates, if no value is stored in From (or From is ''),

// the default value from the property definition is set

procedure ReadObject(Value: TObject; From: PUTF8Char; const SubCompName: RawUTF8=''); overload;



/// read an object properties, as saved by TINIWriter.WriteObject() method

// - i.e. only Integer, Int64, enumerates (including boolean), floating point values

// and (Ansi/Wide/Unicode)String properties (excluding shortstring)

// - read only the published properties of the current class level (do NOT

// read the properties content published in the parent classes)

// - for integers, if no value is stored in FromContent, the default value is set

// - this version gets the appropriate section from [Value.ClassName]

// - this version doesn't handle embedded objects

procedure ReadObject(Value: TObject; const FromContent: RawUTF8;

  const SubCompName: RawUTF8=''); overload;



/// write an object properties, as saved by TINIWriter.WriteObject() method

// - i.e. only Integer, Int64, enumerates (including boolean), floating point values

// and (Ansi/Wide/Unicode)String properties (excluding shortstring)

// - write only the published properties of the current class level (do NOT

// write the properties content published in the parent classes)

// - direct update of INI-like content

// - for integers, value is always written, even if matches the default value

procedure WriteObject(Value: TObject; var IniContent: RawUTF8;

  const Section: RawUTF8; const SubCompName: RawUTF8=''); overload;



/// write an object properties, as saved by TINIWriter.WriteObject() method

// - i.e. only Integer, Int64, enumerates (including boolean), floating point values

// and (Ansi/Wide/Unicode)String properties (excluding shortstring)

// - write only the published properties of the current class level (do NOT

// write the properties content published in the parent classes)

// - return the properties as text Name=Values pairs, with no section

// - for integers, if the value matches the default value, it is not added to the result

function WriteObject(Value: TObject): RawUTF8; overload;



/// copy object properties

// - copy Integer, Int64, enumerates (including boolean), variant, records,

// dynamic arrays, classes and any string properties (excluding shortstring)

// - TCollection items can be copied also, if they are of the same exact class

// - object properties instances are created in aTo if the objects are not

// TSQLRecord children (in this case, these are not class instances, but

// INTEGER reference to records, so only the integer value is copied), that is

// for regular Delphi classes

procedure CopyObject(aFrom, aTo: TObject); overload;



/// create a new object instance, from an existing one

// - will create a new instance of the same class, then call the overloaded

// CopyObject() procedure to copy its values

function CopyObject(aFrom: TObject): TObject; overload;



/// copy two TStrings instances

// - will just call Dest.Assign(Source) in practice

procedure CopyStrings(Source, Dest: TStrings);



{$ifndef LVCL}

/// copy two TCollection instances

// - will call CopyObject() in loop to repopulate the Dest collection,

// which would work even if Assign() method was not overriden

procedure CopyCollection(Source, Dest: TCollection);

{$endif}



/// set any default integer or enumerates (including boolean) published

// properties values for a TPersistent/TSynPersistent

// - set only the values set as "property ... default ..." at class type level

// - will also reset the published properties of the nested classes

procedure SetDefaultValuesObject(Value: TObject);



/// will reset all the object properties to their default

// - strings would be set to '', numbers to 0

// - if FreeAndNilNestedObjects is the default FALSE, will recursively reset

// all nested class properties values

// - if FreeAndNilNestedObjects is TRUE, will FreeAndNil() all the nested

// class properties

// - for a TSQLRecord, use its ClearProperties method instead, which will

// handle the ID property, and any nested JOINed instances 

procedure ClearObject(Value: TObject; FreeAndNilNestedObjects: boolean=false);



/// persist a class instance into a JSON file

// - returns TRUE on success, false on error (e.g. the file name is invalid

// or the file is existing and could not be overwritten)

function ObjectToJSONFile(Value: TObject; const JSONFile: TFileName;

  Options: TTextWriterWriteObjectOptions=[woHumanReadable]): boolean;



/// will serialize any TObject into its expanded UTF-8 JSON representation

// - includes debugger-friendly information, similar to TSynLog, i.e.

// class name and sets/enumerates as text

// - could be used to create a TDocVariant object with full information

// - wrapper around ObjectToJSON(Value,[woDontStoreDefault,woFullExpand])

// also able to serialize plain Exception as a simple '{"Exception":"Message"}'

function ObjectToJSONDebug(Value: TObject): RawUTF8;



/// will serialize any TObject into a TDocVariant debugging document

// - just a wrapper around _JsonFast(ObjectToJSONDebug()) with an optional

// "Context":"..." text message

// - if the supplied context format matches '{....}' then it will be added

// as a corresponding TDocVariant JSON object

function ObjectToVariantDebug(Value: TObject;

  const ContextFormat: RawUTF8; const ContextArgs: array of const;

  const ContextName: RawUTF8='context'): variant; overload;



/// will serialize any TObject into a TDocVariant debugging document

// - just a wrapper around _JsonFast(ObjectToJSONDebug())

function ObjectToVariantDebug(Value: TObject): variant; overload;



/// add the property values of a TObject to a document-based object content

// - if Obj is a TDocVariant object, then all Values's published

// properties will be added at the root level of Obj

procedure _ObjAddProps(Value: TObject; var Obj: variant); overload;



/// is able to compare two objects by value

// - both instances may or may not be of the same class, but properties

// should match

// - will use direct RTTI access of property values, or TSQLRecord.SameValues()

// if available to make the comparison as fast and accurate as possible

// - if you want only to compare the plain fields with no getter function,

// e.g. if they are just some conversion of the same information, you can

// set ignoreGetterFields=TRUE

function ObjectEquals(Value1,Value2: TObject; ignoreGetterFields: boolean=false): boolean;



type

  /// available options for JSONToObject() parsing process

  // - by default, function will fail if a JSON field name is not part of the

  // object published properties, unless j2oIgnoreUnknownProperty is defined

  // - by default, function will check that the supplied JSON value would

  // be a JSON string when the property is a string, unless j2oIgnoreStringType

  // is defined and JSON numbers are accepted and stored as text

  // - by default any unexpected value for enumerations would be marked as

  // invalid, unless j2oIgnoreUnknownEnum is defined, so that in such case the

  // ordinal 0 value is left, and loading continues

  // - by default, only simple kind of variant types (string/numbers) are

  // handled: set j2oHandleCustomVariants if you want to handle any custom -

  // in this case , it will handle direct JSON [array] of {object}: but if you

  // also define j2oHandleCustomVariantsWithinString, it will also try to

  // un-escape a JSON string first, i.e. handle "[array]" or "{object}" content

  // (may be used e.g. when JSON has been retrieved from a database TEXT column)

  // - by default, a temporary instance would be created if a published field

  // has a setter, and the instance is expected to be released later by the

  // owner class: set j2oSetterExpectsToFreeTempInstance to let JSONToObject

  // (and TPropInfo.ClassFromJSON) release it when the setter returns

  TJSONToObjectOption = (

    j2oIgnoreUnknownProperty, j2oIgnoreStringType, j2oIgnoreUnknownEnum,

    j2oHandleCustomVariants, j2oHandleCustomVariantsWithinString,

    j2oSetterExpectsToFreeTempInstance);

  /// set of options for JSONToObject() parsing process

  TJSONToObjectOptions = set of TJSONToObjectOption;



const

  /// some open-minded options for JSONToObject() parsing

  // - won't block JSON unserialization due to some minor class type definitions

  // - used e.g. by TObjArraySerializer.CustomReader and

  // TServiceMethodExecute.ExecuteJson methods

  JSONTOOBJECT_TOLERANTOPTIONS = [j2oHandleCustomVariants,

    j2oIgnoreUnknownEnum,j2oIgnoreUnknownProperty,j2oIgnoreStringType];



/// read an object properties, as saved by ObjectToJSON function

// - ObjectInstance must be an existing TObject instance

// - the data inside From^ is modified in-place (unescaped and transformed):

// calling JSONToObject(pointer(JSONRawUTF8)) would change the JSONRawUTF8

// variable content, which may not be what you expect - consider using the

// ObjectLoadJSON() function instead

// - handle Integer, Int64, enumerate (including boolean), set, floating point,

// TDateTime, TCollection, TStrings, TRawUTF8List, variant, and string properties

// (excluding ShortString, but including WideString and UnicodeString under

// Delphi 2009+)

// - TList won't be handled since it may leak memory when calling TList.Clear

// - won't handle TObjectList (even if ObjectToJSON is able to serialize

// them) since has no way of knowing the object type to add (TCollection.Add

// is missing), unless: 1. you set the TObjectListItemClass property as expected,

// and provide a TObjectList object, or 2. woStoreClassName option has been

// used at ObjectToJSON() call and the corresponding classes have been previously

// registered by TJSONSerializer.RegisterClassForJSON() (or Classes.RegisterClass)

// - will clear any previous TCollection objects, and convert any null JSON

// basic type into nil - e.g. if From='null', will call FreeAndNil(Value)

// - you can add some custom (un)serializers for ANY Delphi class, via the

// TJSONSerializer.RegisterCustomSerializer() class method

// - set Valid=TRUE on success, Valid=FALSE on error, and the main function

// will point in From at the syntax error place (e.g. on any unknown property name)

// - caller should explicitely perform a SetDefaultValuesObject(Value) if

// the default values are expected to be set before JSON parsing

function JSONToObject(var ObjectInstance; From: PUTF8Char; var Valid: boolean;

  TObjectListItemClass: TClass=nil; Options: TJSONToObjectOptions=[]): PUTF8Char;



/// read an object properties, as saved by ObjectToJSON function

// - ObjectInstance must be an existing TObject instance

// - this overloaded version will make a private copy of the supplied JSON

// content (via TSynTempBuffer), to ensure the original buffer won't be modified

// during process, before calling safely JSONToObject()

// - will return TRUE on success, or FALSE if the supplied JSON was invalid

function ObjectLoadJSON(var ObjectInstance; const JSON: RawUTF8;

  TObjectListItemClass: TClass=nil; Options: TJSONToObjectOptions=[]): boolean;



/// create a new object instance, as saved by ObjectToJSON(...,[...,woStoreClassName,...]);

// - JSON input should be either 'null', either '{"ClassName":"TMyClass",...}'

// - woStoreClassName option shall have been used at ObjectToJSON() call

// - and the corresponding class shall have been previously registered by

// TJSONSerializer.RegisterClassForJSON(), in order to retrieve the class type

// from it name - or, at least, by a Classes.RegisterClass() function call

// - the data inside From^ is modified in-place (unescaped and transformed):

// don't call JSONToObject(pointer(JSONRawUTF8)) but makes a temporary copy of

// the JSON text buffer before calling this function, if want to reuse it later

function JSONToNewObject(var From: PUTF8Char; var Valid: boolean;

  Options: TJSONToObjectOptions=[]): TObject;



/// decode a specified parameter compatible with URI encoding into its original

// object contents

// - ObjectInstance must be an existing TObject instance

// - will call internaly JSONToObject() function to unserialize its content

// - UrlDecodeExtended('price=20.45&where=LastName%3D%27M%C3%B4net%27','PRICE=',P,@Next)

// will return Next^='where=...' and P=20.45

// - if Upper is not found, Value is not modified, and result is FALSE

// - if Upper is found, Value is modified with the supplied content, and result is TRUE

function UrlDecodeObject(U: PUTF8Char; Upper: PAnsiChar; var ObjectInstance; Next: PPUTF8Char=nil;

  Options: TJSONToObjectOptions=[]): boolean;



/// fill the object properties from a JSON file content

// - ObjectInstance must be an existing TObject instance

// - this function will call RemoveCommentsFromJSON() before process

function JSONFileToObject(const JSONFile: TFileName; var ObjectInstance;

  TObjectListItemClass: TClass=nil; Options: TJSONToObjectOptions=[]): boolean;







{ ************ some RTTI and SQL mapping routines }



type

  /// the class kind as handled by TClassInstance object

  TClassInstanceItemCreate = (

    cicUnknown,cicTSQLRecord,cicTObjectList,cicTPersistentWithCustomCreate,

    cicTSynPersistent,cicTInterfacedCollection,cicTInterfacedObjectWithCustomCreate,

    cicTCollection,cicTCollectionItem,cicTComponent,cicTObject);



  /// store information about a class, able to easily create new instances

  // - using this temporary storage would speed up the creation process

  // - any virtual constructor would be used, including for TCollection types

  TClassInstance = object

  public

    /// the class type itself

    ItemClass: TClass;

    // how the class instance is expected to be created

    ItemCreate: TClassInstanceItemCreate;

    {$ifndef LVCL}

    /// for TCollection instances, the associated TCollectionItem class

    CollectionItemClass: TCollectionItemClass;

    {$endif}

    /// fill the internal information fields for a given class type

    procedure Init(C: TClass);

    /// create a new instance of the registered class

    function CreateNew: TObject;

  end;

  /// points to information about a class, able to create new instances

  PClassInstance = ^TClassInstance;





{ type definitions below were adapted from TypInfo.pas

 - this implementation doesn't require to include Variant.pas any more (which

  allow easy server-side compile with LVCL, e.g.)

 - some code was rewritten in an object orientation manner (declared as objects

  instead of records) to avoid use of global function/procedure

 - allows easy published properties enumeration with ClassProp()

 - if a property doesn't have a write attribute (i.e. no setter), its value

  is set using the field adress itself (from read f* getter)

 - some useful but not implemented functions were added in optimized assembler }



type

{$ifdef FPC}

  /// available type families for Free Pascal RTTI values

  // - values differs from Delphi, and are taken from FPC typinfo.pp unit

  TTypeKind = (tkUnknown,tkInteger,tkChar,tkEnumeration,tkFloat,

    tkSet,tkMethod,tkSString,tkLString,tkAString,

    tkWString,tkVariant,tkArray,tkRecord,tkInterface,

    tkClass,tkObject,tkWChar,tkBool,tkInt64,tkQWord,

    tkDynArray,tkInterfaceRaw,tkProcVar,tkUString,tkUChar,tkHelper);

const

  // maps record or object types

  tkRecordTypes = [tkObject,tkRecord];

{$else}

  /// available type families for Delphi 6 and up

  TTypeKind = (tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat,

    tkString, tkSet, tkClass, tkMethod, tkWChar, tkLString, tkWString,

    tkVariant, tkArray, tkRecord, tkInterface, tkInt64, tkDynArray

    {$ifdef UNICODE}, tkUString{$endif});

const

  // maps record or object types

  tkRecordTypes = [tkRecord];

{$endif}

  // maps long string types

  tkStringTypes =

    [tkLString,tkWString{$ifdef HASVARUSTRING},tkUString{$endif}{$ifdef FPC},tkAString{$endif}];

  // maps 1, 8, 16, 32 and 64-bit ordinal types

  tkOrdinalTypes =

    [tkInteger, tkChar, tkWChar, tkEnumeration, tkSet, tkInt64

     {$ifdef FPC},tkBool,tkQWord{$endif}];



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



  /// specify floating point (ftFloat) storage size and precision

  // - here ftDouble is renamed ftDoub to avoid confusion with TSQLDBFieldType

  TFloatType = (ftSingle, ftDoub, ftExtended, ftComp, ftCurr);



  TTypeKinds = set of TTypeKind;

  PTypeKind = ^TTypeKind;

  PTypeInfo = ^TTypeInfo;

  {$ifdef HASDIRECTTYPEINFO}

  PPTypeInfo = PTypeInfo;

  {$else}

  PPTypeInfo = ^PTypeInfo;

  {$endif}



  PTypeInfoDynArray = array of PTypeInfo;



  TClassDynArray = array of TClass;



{$ifdef FPC}

{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}

{$PACKRECORDS C}

{$else}

{$A-}

{$endif}

{$else}

{$A-} { Delphi compiler use packed storage for this internal types, not aligned data }

{$endif}



  PPropInfo = ^TPropInfo;

  PMethodInfo = ^TMethodInfo;



  /// used to store a chain of properties RTTI

  // - could be used e.g. by TSQLPropInfo to handled flattened properties

  PPropInfoDynArray = array of PPropInfo;



  /// pointer to TClassProp

  PClassProp = ^TClassProp;

  /// a wrapper to published properties of a class

  // - start enumeration by getting a PClassProp with ClassProp()

  // - use PropCount, P := @PropList to get the first PPropInfo, and then P^.Next

  // - this enumeration is very fast and doesn't require any temporary memory,

  //  as in the TypInfo.GetPropInfos() PPropList usage

  // - for TSQLRecord, you should better use the RecordProps.Fields[] array,

  // which is faster and contains the properties published in parent classes

  {$ifndef ISDELPHI2010}

  TClassProp = object

  {$else}

  TClassProp = record

  {$endif}

    /// number of published properties in this object

    PropCount: Word;

    /// point to a TPropInfo packed array

    // - layout is as such, with variable TPropInfo storage size:

    // ! PropList: array[1..PropCount] of TPropInfo

    // - use TPropInfo.Next to get the next one:

    // ! P := @PropList;

    // ! for i := 1 to PropCount do begin

    // !   // ... do something with P

    // !   P := P^.Next;

    // ! end;

    PropList: record end;

    /// retrieve a Field property RTTI information from a Property Name

    function FieldProp(const PropName: shortstring): PPropInfo;

  end;



  PClassType = ^TClassType;

  /// a wrapper to class type information, as defined by the Delphi RTTI

  {$ifndef ISDELPHI2010}

  TClassType = object

  {$else}

  TClassType = record

  {$endif}

    /// the class type

    ClassType: TClass;

    /// the parent class type information

    ParentInfo: PPTypeInfo;

    /// the number of published properties

    PropCount: SmallInt;

    /// the name (without .pas extension) of the unit were the class was defined

    // - then the PClassProp follows: use the method ClassProp to retrieve its

    // address

    UnitName: string[255];

    /// get the information about the published properties of this class

    // - stored after UnitName memory

    function ClassProp: PClassProp;

      {$ifdef HASINLINE}inline;{$endif}

    /// fast and easy find if this class inherits from a specific class type

    // - you should rather consider using TTypeInfo.InheritsFrom directly

    function InheritsFrom(AClass: TClass): boolean;

    /// return the size (in bytes) of this class type information

    // - can be used to create class types at runtime

    function RTTISize: integer;

  end;



  PEnumType = ^TEnumType;

  /// a wrapper to enumeration type information, as defined by the Delphi RTTI

  // - we use this to store the enumeration values as integer, but easily provide

  // a text equivalent, translated if necessary, from the enumeration type

  // definition itself

  {$ifndef ISDELPHI2010}

  TEnumType = object

  {$else}

  TEnumType = record

  {$endif}

    /// specify ordinal storage size and sign

    // - is prefered to MaxValue to identify the number of stored bytes

    OrdType: TOrdType;

    { this seemingly extraneous inner record is here for alignment purposes, so

    that its data gets aligned properly (if FPC_REQUIRES_PROPER_ALIGNMENT is set) }

    {$ifdef FPC_ENUMHASINNER}

    inner:

    {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}

    packed

    {$endif FPC_ENUMHASINNER}

    record

    {$endif}

    {$ifdef FPC_ENUMHASINNER}

      iMinValue: Longint;

      iMaxValue: Longint;

      iBaseType: PPTypeInfo;

    end;

    {$else}

    /// first value of enumeration type, typicaly 0

    MinValue: Longint;

    /// same as ord(high(type)): not the enumeration count, but the highest index

    MaxValue: Longint;

    /// the base type of this enumeration

    /// - always use PEnumType(typeinfo(TEnumType))^.BaseType or more useful

    // method PTypeInfo(typeinfo(TEnumType))^.EnumBaseType before calling

    // any of the methods below

    BaseType: PPTypeInfo;

    {$endif FPC_ENUMHASINNER}

    /// a concatenation of shortstrings, containing the enumeration names

    NameList: string[255];

    {$ifdef FPC_ENUMHASINNER}

    function MinValue: Longint; inline;

    function MaxValue: Longint; inline;

    function BaseType: PPTypeInfo; inline;

    {$endif FPC_ENUMHASINNER}

    /// get the corresponding enumeration name

    // - return the first one if Value is invalid (>MaxValue)

    function GetEnumNameOrd(Value: Integer): PShortString;

    /// get the corresponding enumeration name

    // - return the first one if Value is invalid (>MaxValue)

    // - Value will be converted to the matching ordinal value (byte or word)

    function GetEnumName(const Value): PShortString;

       {$ifdef HASINLINE}inline;{$endif}

    /// retrieve all element names as a dynamic array of RawUTF8

    // - names could be optionally trimmed left from their initial lower chars

    procedure GetEnumNameAll(var result: TRawUTF8DynArray; TrimLeftLowerCase: boolean); overload;

    /// retrieve all element names as CSV, with optional quotes

    procedure GetEnumNameAll(var result: RawUTF8; const Prefix: RawUTF8='';

      quotedValues: boolean=false); overload;

    /// get all enumeration names as a JSON array of strings

    function GetEnumNameAllAsJSONArray(TrimLeftLowerCase: boolean): RawUTF8;

    /// get the corresponding enumeration ordinal value, from its name

    // - if EnumName does start with lowercases 'a'..'z', they will be searched:

    // e.g. GetEnumNameValue('sllWarning') will find sllWarning item

    // - if Value does not start with lowercases 'a'..'z', they will be ignored:

    // e.g. GetEnumNameValue('Warning') will find sllWarning item

    // - return -1 if not found (don't use directly this value to avoid any GPF)

    function GetEnumNameValue(const EnumName: ShortString): Integer; overload;

       {$ifdef HASINLINE}inline;{$endif}

    /// get the corresponding enumeration ordinal value, from its name

    // - if Value does start with lowercases 'a'..'z', they will be searched:

    // e.g. GetEnumNameValue('sllWarning') will find sllWarning item

    // - if Value does not start with lowercases 'a'..'z', they will be ignored:

    // e.g. GetEnumNameValue('Warning') will find sllWarning item

    // - return -1 if not found (don't use directly this value to avoid any GPF)

    function GetEnumNameValue(Value: PUTF8Char): Integer; overload;

       {$ifdef HASINLINE}inline;{$endif}

    /// get the corresponding enumeration ordinal value, from its name

    // - if Value does start with lowercases 'a'..'z', they will be searched:

    // e.g. GetEnumNameValue('sllWarning') will find sllWarning item

    // - if AlsoTrimLowerCase is TRUE, and EnumName does not start with

    // lowercases 'a'..'z', they will be ignored: e.g. GetEnumNameValue('Warning')

    // will find sllWarning item

    // - return -1 if not found (don't use directly this value to avoid any GPF)

    function GetEnumNameValue(Value: PUTF8Char; ValueLen: integer;

      AlsoTrimLowerCase: boolean=true): Integer; overload;

    /// get the corresponding enumeration name, without the first lowercase chars

    // (otDone -> 'Done')

    // - Value will be converted to the matching ordinal value (byte or word)

    function GetEnumNameTrimed(const Value): RawUTF8;

       {$ifdef HASINLINE}inline;{$endif}

    /// get the enumeration names corresponding to a set value 

    function GetSetNameCSV(Value: integer; SepChar: AnsiChar=',';

      FullSetsAsStar: boolean=false): RawUTF8; overload;

    /// get the enumeration names corresponding to a set value

    procedure GetSetNameCSV(W: TTextWriter; Value: integer; SepChar: AnsiChar=',';

      FullSetsAsStar: boolean=false); overload;

    /// get the enumeration names corresponding to a set value, as a JSON array 

    function GetSetNameAsDocVariant(Value: integer; FullSetsAsStar: boolean=false): variant;

    ///  get the corresponding caption name, without the first lowercase chars

    // (otDone -> 'Done')

    // - return "string" type, i.e. UnicodeString for Delphi 2009+

    // - internally call UnCamelCase() then System.LoadResStringTranslate() if available

    // - Value will be converted to the matching ordinal value (byte or word)

    function GetCaption(const Value): string;

    /// get all caption names, ready to be display, as lines separated by #13#10

    // - return "string" type, i.e. UnicodeString for Delphi 2009+

    // - if UsedValuesBits is not nil, only the corresponding bits set are added

    function GetCaptionStrings(UsedValuesBits: Pointer=nil): string;

    /// add caption names, ready to be display, to a TStrings class

    // - add pointer(ord(element)) as Objects[] value

    // - if UsedValuesBits is not nil, only the corresponding bits set are added

    // - can be used e.g. to populate a combo box as such:

    // ! PTypeInfo(TypeInfo(TMyEnum))^.EnumBaseType^.AddCaptionStrings(ComboBox.Items);

    procedure AddCaptionStrings(Strings: TStrings; UsedValuesBits: Pointer=nil);

    /// retrieve all trimed element names as CSV

    procedure GetEnumNameTrimedAll(var result: RawUTF8; const Prefix: RawUTF8='';

      quotedValues: boolean=false);

    /// get the corresponding enumeration ordinal value, from its name without

    // its first lowercase chars ('Done' will find otDone e.g.)

    // - return -1 if not found (don't use directly this value to avoid any GPF)

    function GetEnumNameTrimedValue(const EnumName: ShortString): Integer; overload;

    /// get the corresponding enumeration ordinal value, from its name without

    // its first lowercase chars ('Done' will find otDone e.g.)

    // - return -1 if not found (don't use directly this value to avoid any GPF)

    function GetEnumNameTrimedValue(Value: PUTF8Char): Integer; overload;

    /// compute how many bytes this type would use to be stored as a enumerate

    function SizeInStorageAsEnum: Integer;

    /// compute how many bytes this type would use to be stored as a set

    function SizeInStorageAsSet: Integer;

    /// store an enumeration value from its ordinal representation

    // - copy SizeInStorageAsEnum bytes from Ordinal to Value pointer

    procedure SetEnumFromOrdinal(out Value; Ordinal: Integer);

  end;



{$ifdef FPC}

{$PACKRECORDS 1}

{$else}

{$A-}

{$endif}

 { Delphi and FPC compiler use packed storage for this internal type }

  TRecordField =

    {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}

    packed

    {$endif FPC_REQUIRES_PROPER_ALIGNMENT}

    record

    TypeInfo: PPTypeInfo;

    {$ifdef FPC}

    Offset: SizeInt;

    {$else}

    Offset: Cardinal;

    {$endif FPC}

  end;

  TRecordType =

    {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}

    packed

    {$endif FPC_REQUIRES_PROPER_ALIGNMENT}

    record

    Size: cardinal;

    Count: integer;

    Fields: array[word] of TRecordField;

  end;

  PRecordField = ^TRecordField;

  PRecordType = ^TRecordType;



{$ifdef FPC}

{$PACKRECORDS 1}

{$else}

{$A-}

{$endif}

 { Delphi and FPC compiler use packed storage for this internal type }

  /// a wrapper containing type information definition

  // - user types defined as an alias don't have this type information:

  // & type NewType = OldType;

  // - user types defined as new types have this type information:

  // & type NewType = type OldType;

  {$ifndef ISDELPHI2010}

  TTypeInfo = object

  {$else}

  TTypeInfo = record

  {$endif}

    /// the value type family

    Kind: TTypeKind;

    /// the declared name of the type ('String','Word','RawUnicode'...)

    Name: ShortString;

    /// get the class type information

    function ClassType: PClassType; {$ifdef HASINLINE}inline;{$endif}

    /// create an instance of the corresponding class

    // - will call TObject.Create, or TSQLRecord.Create virtual constructor

    // - will raise EParsingException if class cannot be constructed on the fly,

    // e.g. for a plain TCollectionItem class

    function ClassCreate: TObject;

    /// get the SQL type of this Delphi class type

    // - returns either sftObject, sftID, sftMany or sftUnknown

    function ClassSQLFieldType: TSQLFieldType; {$ifdef HASINLINE}inline;{$endif}

    /// get the number of published properties in this class

    // - you can count the plain fields without any getter function, if you

    // do need only the published properties corresponding to some value

    // actually stored, and ignore e.g. any textual conversion

    function ClassFieldCount(onlyWithoutGetter: boolean): integer;

    /// for ordinal types, get the storage size and sign

    function OrdType: TOrdType; {$ifdef HASINLINE}inline;{$endif}

    /// for set types, get the type information of the corresponding enumeration

    function SetEnumType: PEnumType;

    /// for gloating point types, get the storage size and procision

    function FloatType: TFloatType; {$ifdef HASINLINE}inline;{$endif}

    /// get the SQL type of this Delphi type, as managed with the database driver

    function GetSQLFieldType: TSQLFieldType;

    /// fast and easy find if a class type inherits from a specific class type

    function InheritsFrom(AClass: TClass): boolean;

    /// get the enumeration type information

    function EnumBaseType: PEnumType; {$ifdef HASINLINE}inline;{$endif}

    /// get the record type information

    function RecordType: PRecordType; {$ifdef HASINLINE}inline;{$endif}

    /// get the dynamic array type information of the stored item

    function DynArrayItemType(aDataSize: PInteger=nil): PTypeInfo;

      {$ifdef HASINLINE}inline;{$endif}

    /// get the dynamic array size (in bytes) of the stored item

    function DynArrayItemSize: integer; {$ifdef HASINLINE}inline;{$endif}

    /// recognize most used string types, returning their code page

    // - will recognize TSQLRawBlob as the fake CP_SQLRAWBLOB code page

    // - will return the exact code page since Delphi 2009, from RTTI

    // - for non Unicode versions of Delphi, will recognize WinAnsiString as

    // CODEPAGE_US, RawUnicode as CP_UTF16, RawByteString as CP_RAWBYTESTRING,

    // AnsiString as 0, and any other type as RawUTF8

    function AnsiStringCodePage: integer; {$ifdef HASCODEPAGE}inline;{$endif}

    /// get the TGUID of a given interface type information

    // - returns nil if this type is not an interface

    function InterfaceGUID: PGUID;

    /// get the unit name of a given interface type information

    // - returns '' if this type is not an interface

    function InterfaceUnitName: PShortString;

    /// get the ancestor/parent of a given interface type information

    // - returns nil if this type has no parent

    function InterfaceAncestor: PTypeInfo;

    /// get all ancestors/parents of a given interface type information

    // - only ancestors with an associated TGUID would be added

    // - if OnlyImplementedBy is not nil, only the interface explicitly

    // implemented by this class would be added, and AncestorsImplementedEntry[]

    // would contain the corresponding PInterfaceEntry values 

    procedure InterfaceAncestors(out Ancestors: PTypeInfoDynArray;

      OnlyImplementedBy: TInterfacedObjectClass;

      out AncestorsImplementedEntry: TPointerDynArray);

  end;



{$ifdef FPC}

{$PACKRECORDS 1}

{$else}

{$A-}

{$endif}

  { Delphi and FPC compiler use packed storage for this internal type }

  /// a wrapper containing a property definition, with GetValue() and SetValue()

  // functions for direct Delphi / UTF-8 SQL type mapping/conversion

  // - handle byte, word, integer, cardinal, Int64 properties as INTEGER

  // - handle boolean properties as INTEGER (0 is false, anything else is true)

  // - handle enumeration properties as INTEGER, storing the ordinal value of the

  // enumeration (i.e. starting at 0 for the first element)

  // - handle enumerations set properties as INTEGER, each bit corresponding to

  // an enumeration (therefore a set of up to 64 elements can be stored in such

  // a field)

  // - handle RawUTF8 properties as TEXT (UTF-8 encoded) - this is the preferred

  //  field type for storing some textual content in the ORM

  // - handle WinAnsiString properties as TEXT (UTF-8 decoded in WinAnsi char set)

  // - handle RawUnicode properties as TEXT (UTF-8 decoded as UTF-16 Win32 unicode)

  // - handle Single, Double and Extended properties as FLOAT

  // - handle TDateTime properties as ISO-8061 encoded TEXT

  // - handle TTimeLog properties as properietary fast INTEGER date time

  // - handle Currency property as FLOAT (safely converted to/from currency)

  // - handle TSQLRecord descendant properties as INTEGER ROWID index to another record

  // (warning: the value contains pointer(ROWID), not a valid object memory - you

  // have to manually retrieve the record, using a integer(IDField) typecast)

  // - handle TSQLRecordMany descendant properties as an "has many" instance (this

  // is a particular case of TSQLRecord: it won't contain pointer(ID), but an object)

  // - handle TRecordReference properties as INTEGER (64-bit) RecordRef-like value

  //  (use TSQLRest.Retrieve(Reference) to get a record content)

  // - handle TSQLRawBlob properties as BLOB

  // - handle dynamic arrays as BLOB, in the TDynArray.SaveTo binary format (is able

  //  to handle dynamic arrays of records, with records or strings within records)

  // - handle records as BLOB, in the RecordSave binary format (our code is ready

  //  for that, but Delphi doesn't create the RTTI for records so it won't work)

  // - WideString, shortstring, UnicodeString (i.e. Delphi 2009+ generic string),

  // indexed properties are not handled yet (use faster RawUnicodeString instead

  // of WideString and UnicodeString) - in fact, the generic string type is handled

  {$ifndef ISDELPHI2010}

  TPropInfo = object

  protected

  {$else}

  TPropInfo = packed record

  private

  {$endif}

    function GetOrdProp(Instance: TObject): PtrInt;

     {$ifdef USETYPEINFO}{$ifdef HASINLINE}inline;{$endif}{$endif}

    function GetObjProp(Instance: TObject): TObject;

     {$ifdef HASINLINE}inline;{$endif}

    procedure SetOrdProp(Instance: TObject; Value: PtrInt);

     {$ifdef USETYPEINFO}{$ifdef HASINLINE}inline;{$endif}{$endif}

    function GetInt64Prop(Instance: TObject): Int64;

     {$ifdef USETYPEINFO}{$ifdef HASINLINE}inline;{$endif}{$endif}

    procedure SetInt64Prop(Instance: TObject; const Value: Int64);

     {$ifdef USETYPEINFO}{$ifdef HASINLINE}inline;{$endif}{$endif}

    procedure GetLongStrProp(Instance: TObject; var Value: RawByteString);

     {$ifdef USETYPEINFO}{$ifdef HASINLINE}inline;{$endif}{$endif}

    procedure SetLongStrProp(Instance: TObject; const Value: RawByteString);

     {$ifdef USETYPEINFO}{$ifdef HASINLINE}inline;{$endif}{$endif}

    procedure CopyLongStrProp(Source,Dest: TObject);

     {$ifdef USETYPEINFO}{$ifdef HASINLINE}inline;{$endif}{$endif}

    procedure GetWideStrProp(Instance: TObject; var Value: WideString);

     {$ifdef USETYPEINFO}{$ifdef HASINLINE}inline;{$endif}{$endif}

    procedure SetWideStrProp(Instance: TObject; const Value: WideString);

     {$ifdef USETYPEINFO}{$ifdef HASINLINE}inline;{$endif}{$endif}

    {$ifdef HASVARUSTRING}

    function GetUnicodeStrProp(Instance: TObject): UnicodeString;

     {$ifdef USETYPEINFO}{$ifdef HASINLINE}inline;{$endif}{$endif}

    procedure SetUnicodeStrProp(Instance: TObject; const Value: UnicodeString);

     {$ifdef USETYPEINFO}{$ifdef HASINLINE}inline;{$endif}{$endif}

    {$endif HASVARUSTRING}

    function GetCurrencyProp(Instance: TObject): currency;

     {$ifdef USETYPEINFO}{$ifdef HASINLINE}inline;{$endif}{$endif}

    procedure SetCurrencyProp(Instance: TObject; const Value: Currency);

     {$ifdef HASINLINE}inline;{$endif}

    function GetDoubleProp(Instance: TObject): double;

     {$ifdef USETYPEINFO}{$ifdef HASINLINE}inline;{$endif}{$endif}

    procedure SetDoubleProp(Instance: TObject; Value: Double);

     {$ifdef HASINLINE}inline;{$endif}

    function GetFloatProp(Instance: TObject): double;

     {$ifdef USETYPEINFO}{$ifdef HASINLINE}inline;{$endif}{$endif}

    procedure SetFloatProp(Instance: TObject; Value: TSynExtended);

     {$ifdef USETYPEINFO}{$ifdef HASINLINE}inline;{$endif}{$endif}

    {$ifndef NOVARIANTS}

    procedure GetVariantProp(Instance: TObject; var result: Variant);

     {$ifdef USETYPEINFO}{$ifdef HASINLINE}inline;{$endif}{$endif}

    procedure SetVariantProp(Instance: TObject; const Value: Variant);

     {$ifdef USETYPEINFO}{$ifdef HASINLINE}inline;{$endif}{$endif}

    {$endif}

  public

    /// the type definition of this property

    PropType: PPTypeInfo;

    /// contains the offset of a field, or the getter method set by 'read' Delphi declaration

    GetProc: PtrInt;

    /// contains the offset of a field, or the setter method set by 'write' Delphi declaration

    // - if this field is nil (no 'write' was specified), SetValue() use GetProc to

    // get the field memory address to save into

    SetProc: PtrInt;

    /// contains the 'stored' boolean value/method (used in TPersistent saving)

    // - either integer(True) - the default, integer(False), reference to a Boolean

    // field, or reference to a parameterless method that returns a Boolean value

    // - if a property is marked as "stored AS_UNIQUE" (i.e. "stored false"),

    // it is created as UNIQUE in the SQL database and its bit is set in

    // Model.fIsUnique[]

    StoredProc: PtrInt;

    /// contains the index value of an indexed class data property

    // - outside SQLite3, this can be used to define a VARCHAR() length value

    // for the textual field definition (sftUTF8Text/sftAnsiText); e.g.

    // the following will create a NAME VARCHAR(40) field:

    // ! Name: RawUTF8 index 40 read fName write fName;

    // - is used by a dynamic array property for fast usage of the

    // TSQLRecord.DynArray(DynArrayFieldIndex) method

    Index: Integer;

    /// contains the default value (2147483648=$80000000 indicates nodefault)

    // when an ordinal or set property is saved as TPersistent

    Default: Longint;

    /// index of the property in the current inherited class definition

    // - first name index at a given class level is 0

    // - index is reset to 0 at every inherited class level

    NameIndex: SmallInt;

{$ifdef FPC}

    /// contains the type of the GetProc/SetProc/StoredProc, see also ptxxx

    // bit 0..1 GetProc     e.g. PropProcs and 3=ptField

    //     2..3 SetProc     e.g. (PropProcs shr 2) and 3=ptField

    //     4..5 StoredProc

    //     6 : true, constant index property

    PropProcs : Byte;

{$endif}

    /// the property definition Name

    Name: ShortString;



    /// the type information of this property

    // - would de-reference the PropType pointer on Delphi and newer FPC compilers

    function TypeInfo: PTypeInfo;

      {$ifdef HASINLINE}inline;{$endif}

    /// get the next property information

    // - no range check: use ClassProp()^.PropCount to determine the properties count

    // - get the first PPropInfo with ClassProp()^.PropList

    function Next: PPropInfo;

      {$ifdef FPC}inline;{$else}{$ifdef HASINLINE}inline;{$endif} {$endif}

    /// return FALSE (AS_UNIQUE) if was marked as "stored AS_UNIQUE"

    //  (i.e. "stored false"), or TRUE by default

    // - if Instance=nil, will work only at RTTI level, not with field or method

    // (and will return TRUE if nothing is defined in the RTTI)

    function IsStored(Instance: TObject): boolean;

    /// copy a published property value from one instance to another

    // - this method use direct copy of the low-level binary content, and is

    // therefore faster than a SetValue(Dest,GetValue(Source)) call

    // - if DestInfo is nil, it will assume DestInfo=@self

    procedure CopyValue(Source, Dest: TObject; DestInfo: PPropInfo=nil);

    /// create a new instance of a published property

    // - copying its properties values from a given instance of another class

    // - if the destination property is not of the aFrom class, it will first

    // search for any extact mach in the destination nested properties

    function CopyToNewObject(aFrom: TObject): TObject;

    /// compare two published properties

    function SameValue(Source: TObject; DestInfo: PPropInfo; Dest: TObject): boolean;

    /// return true if this property is a BLOB (TSQLRawBlob)

    function IsBlob: boolean;

      {$ifdef HASINLINE}inline;{$endif}

    /// low-level getter of the ordinal property value of a given instance

    // - this method will check if the corresponding property is ordinal

    // - return -1 on any error

    function GetOrdValue(Instance: TObject): PtrInt;

      {$ifdef HASINLINE}inline;{$endif}

    /// low-level getter of the ordinal property value of a given instance

    // - this method will check if the corresponding property is ordinal

    // - ordinal properties smaller than tkInt64 will return an Int64-converted

    // value (e.g. tkInteger)

    // - return 0 on any error

    function GetInt64Value(Instance: TObject): Int64;

    /// low-level getter of the currency property value of a given instance

    // - this method will check if the corresponding property is exactly currency

    // - return 0 on any error

    function GetCurrencyValue(Instance: TObject): Currency;

    /// low-level getter of the floating-point property value of a given instance

    // - this method will check if the corresponding property is floating-point

    // - return 0 on any error

    function GetExtendedValue(Instance: TObject): TSynExtended;

    /// low-level setter of the floating-point property value of a given instance

    // - this method will check if the corresponding property is floating-point

    procedure SetExtendedValue(Instance: TObject; const Value: TSynExtended);

    /// low-level getter of the long string property value of a given instance

    // - this method will check if the corresponding property is a Long String,

    // and will return '' if it's not the case

    // - it will convert the property content into RawUTF8, for RawUnicode,

    // WinAnsiString, TSQLRawBlob and generic Delphi 6-2007 string property

    // - WideString and UnicodeString properties will also be UTF-8 converted

    procedure GetLongStrValue(Instance: TObject; var result: RawUTF8);

    /// low-level getter of the long string property content of a given instance

    // - just a wrapper around low-level GetLongStrProp() function

    // - call GetLongStrValue() method if you want a conversion into RawUTF8

    // - will work only for Kind=tkLString

    procedure GetRawByteStringValue(Instance: TObject; var Value: RawByteString);

    /// low-level setter of the ordinal property value of a given instance

    // - this method will check if the corresponding property is ordinal

    procedure SetOrdValue(Instance: TObject; Value: PtrInt);

    /// low-level setter of the ordinal property value of a given instance

    // - this method will check if the corresponding property is ordinal

    procedure SetInt64Value(Instance: TObject; Value: Int64);

    /// low-level setter of the long string property value of a given instance

    // - this method will check if the corresponding property is a Long String

    // - it will convert the property content into RawUTF8, for RawUnicode,

    // WinAnsiString, TSQLRawBlob and generic Delphi 6-2007 string property

    // - will set WideString and UnicodeString properties from UTF-8 content

    procedure SetLongStrValue(Instance: TObject; const Value: RawUTF8);

    /// low-level setter of the string property value of a given instance

    // - uses the generic string type: to be used within the VCL

    // - this method will check if the corresponding property is a Long String

    // or an UnicodeString (for Delphi 2009+), and will call the corresponding

    // SetLongStrValue() or SetUnicodeStrValue() method

    procedure SetGenericStringValue(Instance: TObject; const Value: string);

    /// low-level getter of the long string property value of a given instance

    // - uses the generic string type: to be used within the VCL

    // - this method will check if the corresponding property is a Long String,

    // or an UnicodeString (for Delphi 2009+),and will return '' if it's

    // not the case

    function GetGenericStringValue(Instance: TObject): string;

    {$ifdef HASVARUSTRING}

    /// low-level setter of the Unicode string property value of a given instance

    // - this method will check if the corresponding property is a Unicode String

    procedure SetUnicodeStrValue(Instance: TObject; const Value: UnicodeString);

    /// low-level getter of the Unicode string property value of a given instance

    // - this method will check if the corresponding property is a Unicode String

    function GetUnicodeStrValue(Instance: TObject): UnicodeString;

    {$endif}

    /// low-level getter of a dynamic array wrapper

    // - this method will NOT check if the property is a dynamic array: caller

    // must have already checked that PropType^^.Kind=tkDynArray

    function GetDynArray(Instance: TObject): TDynArray; overload;

      {$ifdef HASINLINE}inline;{$endif}

    /// low-level getter of a dynamic array wrapper

    // - this method will NOT check if the property is a dynamic array: caller

    // must have already checked that PropType^^.Kind=tkDynArray

    procedure GetDynArray(Instance: TObject; var result: TDynArray); overload;

      {$ifdef HASINLINE}inline;{$endif}

    /// return TRUE if this dynamic array has been registered as a T*ObjArray

    // - the T*ObjArray dynamic array should have been previously registered

    // via TJSONSerializer.RegisterObjArrayForJSON() overloaded methods

    function DynArrayIsObjArray: boolean;

      {$ifdef HASINLINE}inline;{$endif}

    /// return class instance creation information about a T*ObjArray

    // - the T*ObjArray dynamic array should have been previously registered

    // via TJSONSerializer.RegisterObjArrayForJSON() overloaded methods

    // - returns nil if the supplied type is not a registered T*ObjArray

    // - you can create a new item instance just by calling result^.CreateNew

    function DynArrayIsObjArrayInstance: PClassInstance;

      {$ifdef HASINLINE}inline;{$endif}

    /// return TRUE if the the property has no getter but direct field read

    function GetterIsField: boolean;

      {$ifdef HASINLINE}inline;{$endif}

    /// return TRUE if the the property has no setter but direct field write

    function SetterIsField: boolean;

      {$ifdef HASINLINE}inline;{$endif}

    /// return TRUE if the the property has a write setter or direct field

    function WriteIsDefined: boolean;

      {$ifdef HASINLINE}inline;{$endif}

    /// returns the low-level field read address, if GetterIsField is TRUE

    function GetterAddr(Instance: pointer): pointer;

      {$ifdef HASINLINE}inline;{$endif}

    /// returns the low-level field write address, if SetterIsField is TRUE

    function SetterAddr(Instance: pointer): pointer;

      {$ifdef HASINLINE}inline;{$endif}

    /// low-level getter of the field value memory pointer

    // - return NIL if both getter and setter are methods

    function GetFieldAddr(Instance: TObject): pointer;

      {$ifdef HASINLINE}inline;{$endif}

    /// low-level setter of the property value as its default

    // - this method will check the property type, e.g. setting '' for strings,

    // and 0 for numbers, or running FreeAndNil() on any nested object (unless

    // FreeAndNilNestedObjects is false so that ClearObject() is used

    procedure SetDefaultValue(Instance: TObject; FreeAndNilNestedObjects: boolean=true);

    {$ifndef NOVARIANTS}

    /// low-level setter of the property value from a supplied variant

    procedure SetFromVariant(Instance: TObject; const Value: variant);

    {$endif NOVARIANTS}

    /// read an TObject published property, as saved by ObjectToJSON() function

    // - will use direct in-memory reference to the object, or call the corresponding

    // setter method (if any), creating a temporary instance via TTypeInfo.ClassCreate

    // - unserialize the JSON input buffer via a call to JSONToObject()

    // - by default, a temporary instance would be created if a published field

    // has a setter, and the instance is expected to be released later by the

    // owner class: you can set the j2oSetterExpectsToFreeTempInstance option

    // to let this method release it when the setter returns

    function ClassFromJSON(Instance: TObject; From: PUTF8Char; var Valid: boolean;

      Options: TJSONToObjectOptions=[]): PUTF8Char;

  end;



{$ifdef FPC}

{$PACKRECORDS DEFAULT}

{$else}

{$A+}

{$endif}



  /// the available methods calling conventions

  // - this is by design only relevant to the x86 model

  // - Win64 has one unique calling convention

  TCallingConvention = (ccRegister, ccCdecl, ccPascal, ccStdCall, ccSafeCall);



  /// the available kind of method parameters

  TParamFlag = (pfVar, pfConst, pfArray, pfAddress, pfReference, pfOut,

    {$ifdef FPC}pfConstRef{$else}pfResult{$endif});



  /// a set of kind of method parameters

  TParamFlags = set of TParamFlag;



  PReturnInfo = ^TReturnInfo;

  PCallingConvention = ^TCallingConvention;

  PParamInfo  = ^TParamInfo;



{$A-} { Delphi and FPC compiler use packed storage for this internal type }

  /// a wrapper around method returned result definition

  {$ifndef ISDELPHI2010}

  TReturnInfo = object

  {$else}

  TReturnInfo = record

  {$endif}

    /// RTTI version

    // - 2 up to Delphi 2010, 3 for Delphi XE and up

    Version: byte;

    /// expected calling convention (only relevant for x86 mode)

    CallingConvention: TCallingConvention;

    /// the expected type of the returned function result

    // - is nil for procedure

    ReturnType: ^PTypeInfo;

    /// total size of data needed for stack parameters + 8 (ret-addr + pushed EBP)

    ParamSize: Word;

    /// number of expected parameters

    ParamCount: Byte;

    /// access to the first method parameter definition

    function Param: PParamInfo;

      {$ifdef HASINLINE}inline;{$endif}

  end;



{$A-} { Delphi and FPC compiler use packed storage for this internal type }

  /// a wrapper around an individual method parameter definition

  {$ifndef ISDELPHI2010}

  TParamInfo = object

  {$else}

  TParamInfo = record

  {$endif}

    /// the kind of parameter

    Flags: TParamFlags;

    /// the parameter type information

    ParamType: PPTypeInfo;

    {$ifdef FPC}

    ParReg: byte;

    Offset: longint;

    {$else}

    /// parameter offset

    // - 0 for EAX, 1 for EDX, 2 for ECX

    // - any value >= 8 for stack-based parameter

    Offset: Word;

    {$endif}

    /// parameter name

    Name: ShortString;

    /// get the next parameter information

    // - no range check: use TReturnInfo.ParamCount to determine the appropriate count

    function Next: PParamInfo;

      {$ifdef HASINLINE}inline;{$endif}

  end;



{$A-} { Delphi and FPC compiler use packed storage for this internal type }

  /// a wrapper around a method definition

  {$ifndef ISDELPHI2010}

  TMethodInfo = object

  {$else}

  TMethodInfo = record

  {$endif}

    {$ifdef FPC}

    /// method name

    Name: PShortString;

    /// the associated method code address

    Addr: Pointer;

    {$else}

    /// size (in bytes) of this TMethodInfo block

    Len: Word;

    /// the associated method code address

    Addr: Pointer;

    /// method name

    Name: ShortString;

    {$endif}

    /// retrieve the associated parameters information

    function ReturnInfo: PReturnInfo;

      {$ifdef HASINLINE}inline;{$endif}

    /// wrapper returning nil and avoiding a GPF if @self=nil

    function MethodAddr: Pointer;

      {$ifdef HASINLINE}inline;{$endif}

  end;



{$ifdef FPC}

{$PACKRECORDS DEFAULT}

{$else}

{$A+} { default aligned data }

{$endif}



  TJSONSerializer = class;



  /// ORM attributes for a TSQLPropInfo definition

  TSQLPropInfoAttribute = (

    aIsUnique);



  /// set of ORM attributes for a TSQLPropInfo definition

  TSQLPropInfoAttributes = set of TSQLPropInfoAttribute;



  /// abstract parent class to store information about a published property

  // - property information could be retrieved from RTTI (TSQLPropInfoRTTI*),

  // or be defined by code (TSQLPropInfoCustom derivated classes) when RTTI

  // is not available

  TSQLPropInfo = class

  protected

    fName: RawUTF8;

    fNameUnflattened: RawUTF8;

    fSQLFieldType: TSQLFieldType;

    fSQLFieldTypeStored: TSQLFieldType;

    fSQLDBFieldType: TSQLDBFieldType;

    fAttributes: TSQLPropInfoAttributes;

    fFieldWidth: integer;

    fPropertyIndex: integer;

    fFromRTTI: boolean;

    function GetNameDisplay: string; virtual;

    /// those two protected methods allow custom storage of binary content

    // as text

    // - default implementation is to use hexa (ToSQL=true) or Base64 encodings

    procedure BinaryToText(var Value: RawUTF8; ToSQL: boolean; wasSQLString: PBoolean); virtual;

    procedure TextToBinary(Value: PUTF8Char; var result: RawByteString); virtual;

    function GetSQLFieldTypeName: PShortString;

    function GetSQLFieldRTTITypeName: RawUTF8; virtual;

    // overriden method shall use direct copy of the low-level binary content,

    // to be faster than a DestInfo.SetValue(Dest,GetValue(Source)) call

    procedure CopySameClassProp(Source: TObject; DestInfo: TSQLPropInfo; Dest: TObject); virtual;

  public

    /// initialize the internal fields

    // - should not be called directly, but with dedicated class methods like

    // class function TSQLPropInfoRTTI.CreateFrom() or overridden constructors

    constructor Create(const aName: RawUTF8; aSQLFieldType: TSQLFieldType;

      aAttributes: TSQLPropInfoAttributes; aFieldWidth, aPropertyIndex: integer); reintroduce; virtual;

    /// the property definition Name

    property Name: RawUTF8 read fName;

    /// the property definition Name, afer un-camelcase and translation

    property NameDisplay: string read GetNameDisplay;

    /// the property definition Name, with full path name if has been flattened

    // - if the property has been flattened (for a TSQLPropInfoRTTI), the real

    // full nested class will be returned, e.g. 'Address.Country.Iso' for

    // the 'Address_Country' flattened property name

    property NameUnflattened: RawUTF8 read fNameUnflattened;

    /// the property index in the RTTI

    property PropertyIndex: integer read fPropertyIndex;

    /// the corresponding column type, as managed by the ORM layer

    property SQLFieldType: TSQLFieldType read fSQLFieldType;

    /// the corresponding column type, as stored by the ORM layer

    // - match SQLFieldType, unless for SQLFieldType=sftNullable, in which this

    // field would contain the simple type eventually stored in the database

    property SQLFieldTypeStored: TSQLFieldType read fSQLFieldTypeStored;

    /// the corresponding column type name, as managed by the ORM layer and

    // retrieved by the RTTI

    // - returns e.g. 'sftTimeLog'

    property SQLFieldTypeName: PShortString read GetSQLFieldTypeName;

    /// the type name, as defined in the RTTI

    // - returns e.g. 'RawUTF8'

    // - will return the TSQLPropInfo class name if it is not a TSQLPropInfoRTTI

    property SQLFieldRTTITypeName: RawUTF8 read GetSQLFieldRTTITypeName;

    /// the corresponding column type, as managed for abstract database access

    // - TNullable* fields would report here the corresponding simple DB type,

    // e.g. ftInt64 for TNullableInteger (following SQLFieldTypeStored value)

    property SQLDBFieldType: TSQLDBFieldType read fSQLDBFieldType;

    /// the corresponding column type name, as managed for abstract database access

    function SQLDBFieldTypeName: PShortString;

    /// the ORM attributes of this property

    // - contains aIsUnique e.g for TSQLRecord published properties marked as

    // ! property MyProperty: RawUTF8 stored AS_UNIQUE;

    // (i.e. "stored false")

    property Attributes: TSQLPropInfoAttributes read fAttributes;

    /// the optional width of this field, in external databases

    // - is set e.g. by index attribute of TSQLRecord published properties as

    // ! property MyProperty: RawUTF8 index 10;

    property FieldWidth: integer read fFieldWidth;

  public

    /// convert UTF-8 encoded text into the property value

    // - setter method (write Set*) is called if available

    // - if no setter exists (no write declaration), the getted field address is used

    // - handle UTF-8 SQL to Delphi values conversion

    // - expect BLOB fields encoded as SQlite3 BLOB literals ("x'01234'" e.g.)

    // or base-64 encoded stream for JSON ("\uFFF0base64encodedbinary") - i.e.

    // both format supported by BlobToTSQLRawBlob() function

    // - handle TPersistent, TCollection, TRawUTF8List or TStrings with JSONToObject

    // - note that the supplied Value buffer won't be modified by this method:

    // overriden implementation should create their own temporary copy

    procedure SetValue(Instance: TObject; Value: PUTF8Char; wasString: boolean); virtual; abstract;

    /// convert UTF-8 encoded text into the property value

    // - just a wrapper around SetValue(...,pointer(Value),...) which may be

    // optimized for overriden methods

    procedure SetValueVar(Instance: TObject; const Value: RawUTF8; wasString: boolean); virtual;

    /// convert the property value into an UTF-8 encoded text

    // - if ToSQL is true, result is on SQL form (false->'0' e.g.)

    // - if ToSQL is false, result is on JSON form (false->'false' e.g.)

    // - BLOB field returns SQlite3 BLOB literals ("x'01234'" e.g.) if ToSQL is

    // true, or base-64 encoded stream for JSON ("\uFFF0base64encodedbinary")

    // - getter method (read Get*) is called if available

    // - handle Delphi values into UTF-8 SQL conversion

    // - sftBlobDynArray, sftBlobCustom or sftBlobRecord are returned as BLOB

    // litterals ("X'53514C697465'") if ToSQL is true, or base-64 encoded stream

    // for JSON ("\uFFF0base64encodedbinary")

    // - handle TPersistent, TCollection, TRawUTF8List or TStrings with ObjectToJSON

    function GetValue(Instance: TObject; ToSQL: boolean; wasSQLString: PBoolean=nil): RawUTF8;

      {$ifdef HASINLINE}inline;{$endif}

    /// convert the property value into an UTF-8 encoded text

    // - this method is the same as GetValue(), but avoid assigning the result

    // string variable (some speed up on multi-core CPUs, since avoid a CPU LOCK)

    // - this virtual method is the one to be overridden by the implementing classes

    procedure GetValueVar(Instance: TObject; ToSQL: boolean;

      var result: RawUTF8; wasSQLString: PBoolean); virtual; abstract;

    /// normalize the content of Value, so that GetValue(Object,true) should return the

    // same content (true for ToSQL format)

    procedure NormalizeValue(var Value: RawUTF8); virtual; abstract;

    /// retrieve a field value into a TSQLVar value

    // - the temp RawByteString is used as a temporary storage for TEXT or BLOB

    // and should be available during all access to the TSQLVar fields

    procedure GetFieldSQLVar(Instance: TObject; var aValue: TSQLVar;

      var temp: RawByteString); virtual;

    /// set a field value from a TSQLVar value

    function SetFieldSQLVar(Instance: TObject; const aValue: TSQLVar): boolean; virtual;

    /// append the property value into a binary buffer

    procedure GetBinary(Instance: TObject; W: TFileBufferWriter); virtual; abstract;

    /// read the property value from a binary buffer

    // - returns next char in input buffer on success, or nil in case of invalid

    // content supplied e.g.

    function SetBinary(Instance: TObject; P: PAnsiChar): PAnsiChar; virtual; abstract;

    /// copy a property value from one instance to another

    // - both objects should have the same exact property

    procedure CopyValue(Source, Dest: TObject); virtual;

    /// copy a value from one instance to another property instance

    // - if the property has been flattened (for a TSQLPropInfoRTTI), the real

    // Source/Dest instance will be used for the copy

    procedure CopyProp(Source: TObject; DestInfo: TSQLPropInfo; Dest: TObject);

    {$ifndef NOVARIANTS}

    /// retrieve the property value into a Variant

    // - will set the Variant type to the best matching kind according to the

    // SQLFieldType type

    // - BLOB field returns SQlite3 BLOB textual literals ("x'01234'" e.g.)

    // - dynamic array field is returned as a variant array

    procedure GetVariant(Instance: TObject; var Dest: Variant); virtual;

    /// set the property value from a Variant value

    // - dynamic array field must be set from a variant array

    // - will set the Variant type to the best matching kind according to the

    // SQLFieldType type

    // - expect BLOB fields encoded as SQlite3 BLOB literals ("x'01234'" e.g.)

    procedure SetVariant(Instance: TObject; const Source: Variant); virtual;

    {$endif}

    /// compare the content of the property of two objects

    // - not all kind of properties are handled: only main types (like GetHash)

    // - if CaseInsensitive is TRUE, will apply NormToUpper[] 8 bits uppercase,

    // handling RawUTF8 properties just like the SYSTEMNOCASE collation

    // - this method should match the case-sensitivity of GetHash()

    // - this default implementation will call GetValueVar() for slow comparison

    function CompareValue(Item1,Item2: TObject; CaseInsensitive: boolean): PtrInt; virtual;

    /// retrieve an unsigned 32 bit hash of the corresponding property

    // - not all kind of properties are handled: only main types

    // - if CaseInsensitive is TRUE, will apply NormToUpper[] 8 bits uppercase,

    // handling RawUTF8 properties just like the SYSTEMNOCASE collation

    // - note that this method can return a hash value of 0

    // - this method should match the case-sensitivity of CompareValue()

    // - this default implementation will call GetValueVar() for slow computation

    function GetHash(Instance: TObject; CaseInsensitive: boolean): cardinal; virtual;

    /// add the JSON content corresponding to the given property

    // - this default implementation will call safe but slow GetValueVar() method

    procedure GetJSONValues(Instance: TObject; W: TJSONSerializer); virtual;

    /// returns an untyped pointer to the field property memory in a given instance

    function GetFieldAddr(Instance: TObject): pointer; virtual; abstract;

  end;



  /// class-reference type (metaclass) of a TSQLPropInfo information

  TSQLPropInfoClass = class of TSQLPropInfo;



  /// define how the published properties RTTI is to be interpreted

  // - i.e. how TSQLPropInfoList.Create() and TSQLPropInfoRTTI.CreateFrom()

  // would handle the incoming RTTI

  TSQLPropInfoListOptions = set of (

    pilRaiseEORMExceptionIfNotHandled, pilAllowIDFields,

    pilSubClassesFlattening, pilIgnoreIfGetter,

    pilSingleHierarchyLevel);



  /// parent information about a published property retrieved from RTTI

  TSQLPropInfoRTTI = class(TSQLPropInfo)

  protected

    fPropInfo: PPropInfo;

    fPropType: PTypeInfo;

    fFlattenedProps: PPropInfoDynArray;

    fGetterIsFieldPropOffset: cardinal;

    fInPlaceCopySameClassPropOffset: cardinal;

    function GetSQLFieldRTTITypeName: RawUTF8; override;

  public

    /// this meta-constructor will create an instance of the exact descendant

    // of the specified property RTTI

    // - it will raise an EORMException in case of an unhandled type

    class function CreateFrom(aPropInfo: PPropInfo; aPropIndex: integer;

      aOptions: TSQLPropInfoListOptions; const aFlattenedProps: PPropInfoDynArray): TSQLPropInfo;

    /// initialize the internal fields

    // - should not be called directly, but with dedicated class methods like

    // class function CreateFrom()

    constructor Create(aPropInfo: PPropInfo; aPropIndex: integer;

      aSQLFieldType: TSQLFieldType); reintroduce; virtual;

    {$ifndef NOVARIANTS}

    /// retrieve the property value into a Variant

    // - will set the Variant type to the best matching kind according to the

    // SQLFieldType type

    // - BLOB field returns SQlite3 BLOB textual literals ("x'01234'" e.g.)

    // - dynamic array field is returned as a variant array

    procedure GetVariant(Instance: TObject; var Dest: Variant); override;

    {$endif}

    /// generic way of implementing it

    function GetFieldAddr(Instance: TObject): pointer; override;

    /// for pilSubClassesFlattening properties, compute the actual instance

    // containing the property value

    // - if the property was not flattened, return the instance

    function Flattened(Instance: TObject): TObject;

    /// corresponding RTTI information

    property PropInfo: PPropInfo read fPropInfo;

    /// for pilSubClassesFlattening properties, the parents RTTI

    property FlattenedPropInfo: PPropInfoDynArray read fFlattenedProps;

    /// corresponding type information, as retrieved from PropInfo RTTI

    property PropType: PTypeInfo read fPropType;

  end;



  /// class-reference type (metaclass) of a TSQLPropInfoRTTI information

  TSQLPropInfoRTTIClass = class of TSQLPropInfoRTTI;



  TSQLPropInfoRTTIObjArray = array of TSQLPropInfoRTTI;



  /// information about an ordinal Int32 published property

  TSQLPropInfoRTTIInt32 = class(TSQLPropInfoRTTI)

  protected

    procedure CopySameClassProp(Source: TObject; DestInfo: TSQLPropInfo; Dest: TObject); override;

  public

    procedure SetValue(Instance: TObject; Value: PUTF8Char; wasString: boolean); override;

    procedure GetValueVar(Instance: TObject; ToSQL: boolean;

      var result: RawUTF8; wasSQLString: PBoolean); override;

    procedure GetFieldSQLVar(Instance: TObject; var aValue: TSQLVar;

      var temp: RawByteString); override;

    function SetFieldSQLVar(Instance: TObject; const aValue: TSQLVar): boolean; override;

    procedure GetBinary(Instance: TObject; W: TFileBufferWriter); override;

    function SetBinary(Instance: TObject; P: PAnsiChar): PAnsiChar; override;

    function CompareValue(Item1,Item2: TObject; CaseInsensitive: boolean): PtrInt; override;

    function GetHash(Instance: TObject; CaseInsensitive: boolean): cardinal; override;

    procedure NormalizeValue(var Value: RawUTF8); override;

    procedure GetJSONValues(Instance: TObject; W: TJSONSerializer); override;

  end;



  /// information about a set published property

  TSQLPropInfoRTTISet = class(TSQLPropInfoRTTIInt32)

  protected

    fSetEnumType: PEnumType;

  public

    constructor Create(aPropInfo: PPropInfo; aPropIndex: integer; aSQLFieldType: TSQLFieldType); override;

    property SetEnumType: PEnumType read fSetEnumType;

  end;



  /// information about a enumeration published property

  // - can be either sftBoolean or sftEnumerate kind of property

  TSQLPropInfoRTTIEnum = class(TSQLPropInfoRTTIInt32)

  protected

    fEnumType: PEnumType;

  public

    constructor Create(aPropInfo: PPropInfo; aPropIndex: integer; aSQLFieldType: TSQLFieldType); override;

    procedure SetValue(Instance: TObject; Value: PUTF8Char; wasString: boolean); override;

    procedure GetValueVar(Instance: TObject; ToSQL: boolean;

      var result: RawUTF8; wasSQLString: PBoolean); override;

    procedure NormalizeValue(var Value: RawUTF8); override;

    procedure GetJSONValues(Instance: TObject; W: TJSONSerializer); override;

    function GetCaption(Value: RawUTF8; out IntValue: integer): string;

    property EnumType: PEnumType read fEnumType;

  end;



  /// information about a character published property

  TSQLPropInfoRTTIChar = class(TSQLPropInfoRTTIInt32)

  public

    procedure SetValue(Instance: TObject; Value: PUTF8Char; wasString: boolean); override;

    procedure GetValueVar(Instance: TObject; ToSQL: boolean;

      var result: RawUTF8; wasSQLString: PBoolean); override;

    procedure NormalizeValue(var Value: RawUTF8); override;

  end;



  /// information about an ordinal Int64 published property

  TSQLPropInfoRTTIInt64 = class(TSQLPropInfoRTTI)

  protected

    procedure CopySameClassProp(Source: TObject; DestInfo: TSQLPropInfo; Dest: TObject); override;

  public

    procedure SetValue(Instance: TObject; Value: PUTF8Char; wasString: boolean); override;

    procedure GetValueVar(Instance: TObject; ToSQL: boolean;

      var result: RawUTF8; wasSQLString: PBoolean); override;

    procedure GetFieldSQLVar(Instance: TObject; var aValue: TSQLVar;

      var temp: RawByteString); override;

    function SetFieldSQLVar(Instance: TObject; const aValue: TSQLVar): boolean; override;

    procedure GetBinary(Instance: TObject; W: TFileBufferWriter); override;

    function SetBinary(Instance: TObject; P: PAnsiChar): PAnsiChar; override;

    function CompareValue(Item1,Item2: TObject; CaseInsensitive: boolean): PtrInt; override;

    function GetHash(Instance: TObject; CaseInsensitive: boolean): cardinal; override;

    procedure NormalizeValue(var Value: RawUTF8); override;

    procedure GetJSONValues(Instance: TObject; W: TJSONSerializer); override;

  end;



  /// information about a TTimeLog published property

  // - stored as an Int64, but with a specific class

  TSQLPropInfoRTTITimeLog = class(TSQLPropInfoRTTIInt64);



  /// information about a floating-point Double published property

  TSQLPropInfoRTTIDouble = class(TSQLPropInfoRTTI)

  protected

    procedure CopySameClassProp(Source: TObject; DestInfo: TSQLPropInfo; Dest: TObject); override;

  public

    procedure SetValue(Instance: TObject; Value: PUTF8Char; wasString: boolean); override;

    procedure GetValueVar(Instance: TObject; ToSQL: boolean;

      var result: RawUTF8; wasSQLString: PBoolean); override;

    procedure GetFieldSQLVar(Instance: TObject; var aValue: TSQLVar;

      var temp: RawByteString); override;

    function SetFieldSQLVar(Instance: TObject; const aValue: TSQLVar): boolean; override;

    procedure GetBinary(Instance: TObject; W: TFileBufferWriter); override;

    function SetBinary(Instance: TObject; P: PAnsiChar): PAnsiChar; override;

    procedure NormalizeValue(var Value: RawUTF8); override;

    procedure GetJSONValues(Instance: TObject; W: TJSONSerializer); override;

    function CompareValue(Item1,Item2: TObject; CaseInsensitive: boolean): PtrInt; override;

  end;



  /// information about a fixed-decimal Currency published property

  TSQLPropInfoRTTICurrency = class(TSQLPropInfoRTTIDouble)

  protected

    procedure CopySameClassProp(Source: TObject; DestInfo: TSQLPropInfo; Dest: TObject); override;

  public

    procedure SetValue(Instance: TObject; Value: PUTF8Char; wasString: boolean); override;

    procedure GetValueVar(Instance: TObject; ToSQL: boolean;

      var result: RawUTF8; wasSQLString: PBoolean); override;

    procedure GetFieldSQLVar(Instance: TObject; var aValue: TSQLVar;

      var temp: RawByteString); override;

    function SetFieldSQLVar(Instance: TObject; const aValue: TSQLVar): boolean; override;

    procedure GetBinary(Instance: TObject; W: TFileBufferWriter); override;

    function SetBinary(Instance: TObject; P: PAnsiChar): PAnsiChar; override;

    procedure NormalizeValue(var Value: RawUTF8); override;

    procedure GetJSONValues(Instance: TObject; W: TJSONSerializer); override;

    function CompareValue(Item1,Item2: TObject; CaseInsensitive: boolean): PtrInt; override;

  end;



  /// information about a TDateTime published property

  TSQLPropInfoRTTIDateTime = class(TSQLPropInfoRTTIDouble)

  public

    procedure SetValue(Instance: TObject; Value: PUTF8Char; wasString: boolean); override;

    procedure GetValueVar(Instance: TObject; ToSQL: boolean;

      var result: RawUTF8; wasSQLString: PBoolean); override;

    procedure GetFieldSQLVar(Instance: TObject; var aValue: TSQLVar;

      var temp: RawByteString); override;

    procedure NormalizeValue(var Value: RawUTF8); override;

    procedure GetJSONValues(Instance: TObject; W: TJSONSerializer); override;

    function CompareValue(Item1,Item2: TObject; CaseInsensitive: boolean): PtrInt; override;

  end;



  /// information about a AnsiString published property

  TSQLPropInfoRTTIAnsi = class(TSQLPropInfoRTTI)

  protected

    fEngine: TSynAnsiConvert;

    procedure CopySameClassProp(Source: TObject; DestInfo: TSQLPropInfo; Dest: TObject); override;

  public

    constructor Create(aPropInfo: PPropInfo; aPropIndex: integer; aSQLFieldType: TSQLFieldType); override;

    procedure SetValue(Instance: TObject; Value: PUTF8Char; wasString: boolean); override;

    procedure SetValueVar(Instance: TObject; const Value: RawUTF8; wasString: boolean); override;

    procedure GetValueVar(Instance: TObject; ToSQL: boolean;

      var result: RawUTF8; wasSQLString: PBoolean); override;

    procedure CopyValue(Source, Dest: TObject); override;

    procedure GetBinary(Instance: TObject; W: TFileBufferWriter); override;

    function SetBinary(Instance: TObject; P: PAnsiChar): PAnsiChar; override;

    procedure GetJSONValues(Instance: TObject; W: TJSONSerializer); override;

    procedure GetFieldSQLVar(Instance: TObject; var aValue: TSQLVar;

      var temp: RawByteString); override;

    function SetFieldSQLVar(Instance: TObject; const aValue: TSQLVar): boolean; override;

    function CompareValue(Item1,Item2: TObject; CaseInsensitive: boolean): PtrInt; override;

    function GetHash(Instance: TObject; CaseInsensitive: boolean): cardinal; override;

    procedure NormalizeValue(var Value: RawUTF8); override;

  end;



  /// information about a RawUTF8 published property

  TSQLPropInfoRTTIRawUTF8 = class(TSQLPropInfoRTTIAnsi)

  protected

    procedure CopySameClassProp(Source: TObject; DestInfo: TSQLPropInfo; Dest: TObject); override;

  public

    procedure SetValue(Instance: TObject; Value: PUTF8Char; wasString: boolean); override;

    procedure SetValueVar(Instance: TObject; const Value: RawUTF8; wasString: boolean); override;

    procedure GetValueVar(Instance: TObject; ToSQL: boolean;

      var result: RawUTF8; wasSQLString: PBoolean); override;

    procedure GetFieldSQLVar(Instance: TObject; var aValue: TSQLVar;

      var temp: RawByteString); override;

    function SetFieldSQLVar(Instance: TObject; const aValue: TSQLVar): boolean; override;

    function CompareValue(Item1,Item2: TObject; CaseInsensitive: boolean): PtrInt; override;

    function GetHash(Instance: TObject; CaseInsensitive: boolean): cardinal; override;

    procedure GetJSONValues(Instance: TObject; W: TJSONSerializer); override;

  end;



  /// information about a RawUnicode published property

  TSQLPropInfoRTTIRawUnicode = class(TSQLPropInfoRTTIAnsi)

  protected

    procedure CopySameClassProp(Source: TObject; DestInfo: TSQLPropInfo; Dest: TObject); override;

  public

    procedure SetValue(Instance: TObject; Value: PUTF8Char; wasString: boolean); override;

    procedure SetValueVar(Instance: TObject; const Value: RawUTF8; wasString: boolean); override;

    procedure GetValueVar(Instance: TObject; ToSQL: boolean;

      var result: RawUTF8; wasSQLString: PBoolean); override;

    function CompareValue(Item1,Item2: TObject; CaseInsensitive: boolean): PtrInt; override;

    function GetHash(Instance: TObject; CaseInsensitive: boolean): cardinal; override;

  end;



  /// information about a TSQLRawBlob published property

  TSQLPropInfoRTTIRawBlob = class(TSQLPropInfoRTTIAnsi)

  protected

    procedure CopySameClassProp(Source: TObject; DestInfo: TSQLPropInfo; Dest: TObject); override;

  public

    procedure SetValue(Instance: TObject; Value: PUTF8Char; wasString: boolean); override;

    procedure SetValueVar(Instance: TObject; const Value: RawUTF8; wasString: boolean); override;

    procedure GetValueVar(Instance: TObject; ToSQL: boolean;

      var result: RawUTF8; wasSQLString: PBoolean); override;

    procedure GetFieldSQLVar(Instance: TObject; var aValue: TSQLVar;

      var temp: RawByteString); override;

    function SetFieldSQLVar(Instance: TObject; const aValue: TSQLVar): boolean; override;

    function CompareValue(Item1,Item2: TObject; CaseInsensitive: boolean): PtrInt; override;

    function GetHash(Instance: TObject; CaseInsensitive: boolean): cardinal; override;

    procedure GetJSONValues(Instance: TObject; W: TJSONSerializer); override;

    procedure GetBlob(Instance: TObject; var Blob: RawByteString);

    procedure SetBlob(Instance: TObject; const Blob: RawByteString);

    function IsNull(Instance: TObject): Boolean;

  end;



  /// information about a WideString published property

  TSQLPropInfoRTTIWide = class(TSQLPropInfoRTTI)

  protected

    procedure CopySameClassProp(Source: TObject; DestInfo: TSQLPropInfo; Dest: TObject); override;

  public

    procedure SetValue(Instance: TObject; Value: PUTF8Char; wasString: boolean); override;

    procedure GetValueVar(Instance: TObject; ToSQL: boolean;

      var result: RawUTF8; wasSQLString: PBoolean); override;

    procedure CopyValue(Source, Dest: TObject); override;

    procedure GetBinary(Instance: TObject; W: TFileBufferWriter); override;

    function SetBinary(Instance: TObject; P: PAnsiChar): PAnsiChar; override;

    procedure GetJSONValues(Instance: TObject; W: TJSONSerializer); override;

    function CompareValue(Item1,Item2: TObject; CaseInsensitive: boolean): PtrInt; override;

    function GetHash(Instance: TObject; CaseInsensitive: boolean): cardinal; override;

  end;



  {$ifdef HASVARUSTRING}

  /// information about a UnicodeString published property

  TSQLPropInfoRTTIUnicode = class(TSQLPropInfoRTTI)

  protected

    procedure CopySameClassProp(Source: TObject; DestInfo: TSQLPropInfo; Dest: TObject); override;

  public

    procedure SetValue(Instance: TObject; Value: PUTF8Char; wasString: boolean); override;

    procedure SetValueVar(Instance: TObject; const Value: RawUTF8; wasString: boolean); override;

    procedure GetValueVar(Instance: TObject; ToSQL: boolean;

      var result: RawUTF8; wasSQLString: PBoolean); override;

    procedure CopyValue(Source, Dest: TObject); override;

    procedure GetBinary(Instance: TObject; W: TFileBufferWriter); override;

    function SetBinary(Instance: TObject; P: PAnsiChar): PAnsiChar; override;

    procedure GetJSONValues(Instance: TObject; W: TJSONSerializer); override;

    procedure GetFieldSQLVar(Instance: TObject; var aValue: TSQLVar;

      var temp: RawByteString); override;

    function SetFieldSQLVar(Instance: TObject; const aValue: TSQLVar): boolean; override;

    function CompareValue(Item1,Item2: TObject; CaseInsensitive: boolean): PtrInt; override;

    function GetHash(Instance: TObject; CaseInsensitive: boolean): cardinal; override;

  end;

  {$endif HASVARUSTRING}



  /// information about a dynamic array published property

  TSQLPropInfoRTTIDynArray = class(TSQLPropInfoRTTI)

  protected

    fObjArray: PClassInstance;

    function GetDynArray(Instance: TObject): TDynArray; overload;

      {$ifdef HASINLINE}inline;{$endif}

    procedure GetDynArray(Instance: TObject; var result: TDynArray); overload;

      {$ifdef HASINLINE}inline;{$endif}

    function GetDynArrayElemType: PTypeInfo;

    /// will create TDynArray.SaveTo by default, or JSON if is T*ObjArray

    procedure Serialize(Instance: TObject; var data: RawByteString; ExtendedJson: boolean); virtual;

    procedure CopySameClassProp(Source: TObject; DestInfo: TSQLPropInfo; Dest: TObject); override;

  public

    /// initialize the internal fields

    // - should not be called directly, but with dedicated class methods like

    // class function CreateFrom()

    constructor Create(aPropInfo: PPropInfo; aPropIndex: integer;

      aSQLFieldType: TSQLFieldType); override;

    procedure SetValue(Instance: TObject; Value: PUTF8Char; wasString: boolean); override;

    procedure GetValueVar(Instance: TObject; ToSQL: boolean;

      var result: RawUTF8; wasSQLString: PBoolean); override;

    procedure GetFieldSQLVar(Instance: TObject; var aValue: TSQLVar;

      var temp: RawByteString); override;

    function SetFieldSQLVar(Instance: TObject; const aValue: TSQLVar): boolean; override;

    procedure GetBinary(Instance: TObject; W: TFileBufferWriter); override;

    function SetBinary(Instance: TObject; P: PAnsiChar): PAnsiChar; override;

    function CompareValue(Item1,Item2: TObject; CaseInsensitive: boolean): PtrInt; override;

    function GetHash(Instance: TObject; CaseInsensitive: boolean): cardinal; override;

    procedure NormalizeValue(var Value: RawUTF8); override;

    procedure GetJSONValues(Instance: TObject; W: TJSONSerializer); override;

    {$ifndef NOVARIANTS}

    procedure GetVariant(Instance: TObject; var Dest: Variant); override;

    procedure SetVariant(Instance: TObject; const Source: Variant); override;

    {$endif}

    /// optional index of the dynamic array published property

    // - used e.g. for fast lookup by TSQLRecord.DynArray(DynArrayFieldIndex)

    property DynArrayIndex: integer read fFieldWidth;

    /// read-only access to the low-level type information the array item type

    property DynArrayElemType: PTypeInfo read GetDynArrayElemType;

    /// dynamic array item information for a T*ObjArray

    // - equals nil if this dynamic array was not previously registered via

    // TJSONSerializer.RegisterObjArrayForJSON()

    // - note that if the field is a T*ObjArray, you could create a new item

    // by calling ObjArray^.CreateNew

    // - T*ObjArray database column will be stored as text

    property ObjArray: PClassInstance read fObjArray;

  end;



  TSQLPropInfoRTTIDynArrayObjArray = array of TSQLPropInfoRTTIDynArray;



{$ifndef NOVARIANTS}

  /// information about a variant published property

  // - is also used for TNullable* properties

  TSQLPropInfoRTTIVariant = class(TSQLPropInfoRTTI)

  protected

    fDocVariantOptions: TDocVariantOptions;

    procedure CopySameClassProp(Source: TObject; DestInfo: TSQLPropInfo; Dest: TObject); override;

  public

    /// initialize the internal fields

    constructor Create(aPropInfo: PPropInfo; aPropIndex: integer;

      aSQLFieldType: TSQLFieldType); override;

    procedure SetValue(Instance: TObject; Value: PUTF8Char; wasString: boolean); override;

    procedure SetValueVar(Instance: TObject; const Value: RawUTF8; wasString: boolean); override;

    procedure SetValuePtr(Instance: TObject; Value: PUTF8Char; ValueLen: integer;

      wasString: boolean);

    procedure GetValueVar(Instance: TObject; ToSQL: boolean;

      var result: RawUTF8; wasSQLString: PBoolean); override;

    procedure GetBinary(Instance: TObject; W: TFileBufferWriter); override;

    function SetBinary(Instance: TObject; P: PAnsiChar): PAnsiChar; override;

    function CompareValue(Item1,Item2: TObject; CaseInsensitive: boolean): PtrInt; override;

    function GetHash(Instance: TObject; CaseInsensitive: boolean): cardinal; override;

    procedure NormalizeValue(var Value: RawUTF8); override;

    procedure GetJSONValues(Instance: TObject; W: TJSONSerializer); override;

    procedure GetVariant(Instance: TObject; var Dest: Variant); override;

    procedure SetVariant(Instance: TObject; const Source: Variant); override;

    /// how this property will deal with its instances (including TDocVariant)

    // - by default, contains JSON_OPTIONS_FAST for best performance - i.e.

    // [dvoReturnNullForUnknownProperty,dvoValueCopiedByReference]

    // - set JSON_OPTIONS_FAST_EXTENDED (or include dvoSerializeAsExtendedJson)

    // so that any TDocVariant nested field names would not be double-quoted,

    // saving some chars in the stored TEXT column and in the JSON escaped

    // transmitted data over REST, by writing '{name:"John",age:123}' instead of

    // '{"name":"John","age":123}': be aware that this syntax is supported by

    // the ORM, SOA, TDocVariant, TBSONVariant, and our SynCrossPlatformJSON

    // unit, but not AJAX/JavaScript or most JSON libraries

    // - see also TSQLModel/TSQLRecordProperties.SetVariantFieldsDocVariantOptions 

    property DocVariantOptions: TDocVariantOptions read fDocVariantOptions write fDocVariantOptions;

  end;

{$endif NOVARIANTS}



  /// optional event handler used by TSQLPropInfoRecord to handle textual storage

  // - by default, TSQLPropInfoRecord content will be stored as sftBlobCustom;

  // specify such a callback event to allow storage as UTF-8 textual field and

  // use a sftUTF8Custom kind of column

  // - event implementation shall convert data/datalen binary value into Text

  TOnSQLPropInfoRecord2Text = procedure(Data: pointer; DataLen: integer;

    var Text: RawUTF8);

  /// optional event handler used by TSQLPropInfoRecord to handle textual storage

  // - by default, TSQLPropInfoRecord content will be stored as sftBlobCustom;

  // specify such a callback event to allow storage as UTF-8 textual field and

  // use a sftUTF8Custom kind of column

  // - event implementaiton shall convert Text into Data binary value

  TOnSQLPropInfoRecord2Data = procedure(Text: PUTF8Char; var Data: RawByteString);



  /// abstract information about a record-like property defined directly in code

  // - do not use this class, but TSQLPropInfoRecordRTTI and TSQLPropInfoRecordFixedSize

  // - will store the content as BLOB by default, and SQLFieldType as sftBlobCustom

  // - if aData2Text/aText2Data are defined, use TEXT storage and sftUTF8Custom type

  TSQLPropInfoCustom = class(TSQLPropInfo)

  protected

    fOffset: PtrUInt;

    fData2Text: TOnSQLPropInfoRecord2Text;

    fText2Data: TOnSQLPropInfoRecord2Data;

    procedure BinaryToText(var Value: RawUTF8; ToSQL: boolean; wasSQLString: PBoolean); override;

    procedure TextToBinary(Value: PUTF8Char; var result: RawByteString); override;

  public

    /// define a custom property in code

    // - do not call this constructor directly, but one of its inherited classes,

    // via a call to TSQLRecordProperties.RegisterCustom*()

    constructor Create(const aName: RawUTF8; aSQLFieldType: TSQLFieldType;

      aAttributes: TSQLPropInfoAttributes; aFieldWidth, aPropIndex: Integer;

      aProperty: pointer; aData2Text: TOnSQLPropInfoRecord2Text;

      aText2Data: TOnSQLPropInfoRecord2Data); reintroduce;

  public

    function GetFieldAddr(Instance: TObject): pointer; override;

  end;



  /// information about a record property defined directly in code using RTTI

  TSQLPropInfoRecordTyped = class(TSQLPropInfoCustom)

  protected

    fTypeInfo: PTypeInfo;

  public

    property TypeInfo: PTypeInfo read fTypeInfo;

  end;



  /// information about a record property defined directly in code

  // - Delphi does not publish RTTI for published record properties

  // - you can use this class to register a record property from its RTTI

  // - will store the content as BLOB by default, and SQLFieldType as sftBlobCustom

  // - if aData2Text/aText2Data are defined, use TEXT storage and sftUTF8Custom type

  // - this class will use only binary RecordLoad/RecordSave methods

  TSQLPropInfoRecordRTTI = class(TSQLPropInfoRecordTyped)

  protected

    function GetSQLFieldRTTITypeName: RawUTF8; override;

    procedure CopySameClassProp(Source: TObject; DestInfo: TSQLPropInfo; Dest: TObject); override;

  public

    /// define a record property from its RTTI definition

    // - handle any kind of record with available generated TypeInfo()

    // - aPropertyPointer shall be filled with the offset to the private

    // field within a nil object, e.g for

    // !  class TMainObject = class(TSQLRecord)

    // !    (...)

    // !    fFieldName: TMyRecord;

    // !  public

    // !    (...)

    // !    property FieldName: TMyRecord read fFieldName write fFieldName;

    // !  end;

    // you will have to register it via a call to

    // TSQLRecordProperties.RegisterCustomRTTIRecordProperty()

    // - optional aIsNotUnique parametercanl be defined

    // - implementation will use internally RecordLoad/RecordSave functions

    // - you can specify optional aData2Text/aText2Data callbacks to store

    // the content as textual values, and not as BLOB

    constructor Create(aRecordInfo: PTypeInfo; const aName: RawUTF8; aPropertyIndex: integer;

      aPropertyPointer: pointer; aAttributes: TSQLPropInfoAttributes=[];

      aFieldWidth: integer=0; aData2Text: TOnSQLPropInfoRecord2Text=nil;

      aText2Data: TOnSQLPropInfoRecord2Data=nil); reintroduce; overload;

  public

    procedure SetValue(Instance: TObject; Value: PUTF8Char; wasString: boolean); override;

    procedure GetValueVar(Instance: TObject; ToSQL: boolean;

      var result: RawUTF8; wasSQLString: PBoolean); override;

    procedure GetFieldSQLVar(Instance: TObject; var aValue: TSQLVar;

      var temp: RawByteString); override;

    function SetFieldSQLVar(Instance: TObject; const aValue: TSQLVar): boolean; override;

    procedure GetBinary(Instance: TObject; W: TFileBufferWriter); override;

    function SetBinary(Instance: TObject; P: PAnsiChar): PAnsiChar; override;

    function CompareValue(Item1,Item2: TObject; CaseInsensitive: boolean): PtrInt; override;

    function GetHash(Instance: TObject; CaseInsensitive: boolean): cardinal; override;

    procedure NormalizeValue(var Value: RawUTF8); override;

    {$ifndef NOVARIANTS}

    procedure GetVariant(Instance: TObject; var Dest: Variant); override;

    procedure SetVariant(Instance: TObject; const Source: Variant); override;

    {$endif}

  end;



  /// information about a fixed-size record property defined directly in code

  // - Delphi does not publish RTTI for published record properties

  // - you can use this class to register a record property with no RTTI (i.e.

  // a record with no reference-counted types within)

  // - will store the content as BLOB by default, and SQLFieldType as sftBlobCustom

  // - if aData2Text/aText2Data are defined, use TEXT storage and sftUTF8Custom type

  TSQLPropInfoRecordFixedSize = class(TSQLPropInfoRecordTyped)

  protected

    fRecordSize: integer;

    function GetSQLFieldRTTITypeName: RawUTF8; override;

    procedure CopySameClassProp(Source: TObject; DestInfo: TSQLPropInfo; Dest: TObject); override;

  public

    /// define an unmanaged fixed-size record property

    // - simple kind of records (i.e. those not containing reference-counted

    // members) do not have RTTI generated, at least in older versions of Delphi:

    // use this constructor to define a direct property access

    // - main parameter is the record size, in bytes

    constructor Create(aRecordSize: cardinal; const aName: RawUTF8; aPropertyIndex: integer;

      aPropertyPointer: pointer; aAttributes: TSQLPropInfoAttributes=[];

      aFieldWidth: integer=0; aData2Text: TOnSQLPropInfoRecord2Text=nil;

      aText2Data: TOnSQLPropInfoRecord2Data=nil); reintroduce; overload;

  public

    procedure SetValue(Instance: TObject; Value: PUTF8Char; wasString: boolean); override;

    procedure GetValueVar(Instance: TObject; ToSQL: boolean;

      var result: RawUTF8; wasSQLString: PBoolean); override;

    procedure GetFieldSQLVar(Instance: TObject; var aValue: TSQLVar;

      var temp: RawByteString); override;

    function SetFieldSQLVar(Instance: TObject; const aValue: TSQLVar): boolean; override;

    procedure GetBinary(Instance: TObject; W: TFileBufferWriter); override;

    function SetBinary(Instance: TObject; P: PAnsiChar): PAnsiChar; override;

    function CompareValue(Item1,Item2: TObject; CaseInsensitive: boolean): PtrInt; override;

    function GetHash(Instance: TObject; CaseInsensitive: boolean): cardinal; override;

    procedure NormalizeValue(var Value: RawUTF8); override;

    {$ifndef NOVARIANTS}

    procedure GetVariant(Instance: TObject; var Dest: Variant); override;

    procedure SetVariant(Instance: TObject; const Source: Variant); override;

    {$endif}

  end;



  /// information about a custom property defined directly in code

  // - you can define any kind of property, either a record or any type

  // - this class will use JSON serialization, by type name or TypeInfo() pointer

  // - will store the content as TEXT by default, and SQLFieldType as sftUTF8Custom

  TSQLPropInfoCustomJSON = class(TSQLPropInfoRecordTyped)

  protected

    fCustomParser: TJSONCustomParserRTTI;

    function GetSQLFieldRTTITypeName: RawUTF8; override;

    procedure SetCustomParser(aCustomParser: TJSONCustomParserRTTI);

  public

    /// initialize the internal fields

    // - should not be called directly

    constructor Create(aPropInfo: PPropInfo; aPropIndex: integer);

      reintroduce; overload; virtual;

    /// define a custom property from its RTTI definition

    // - handle any kind of property, e.g. from enhanced RTTI or a custom record

    // defined via TTextWriter.RegisterCustomJSONSerializer[FromText]()

    // - aPropertyPointer shall be filled with the offset to the private

    // field within a nil object, e.g for

    // !  class TMainObject = class(TSQLRecord)

    // !    (...)

    // !    fFieldName: TMyRecord;

    // !  public

    // !    (...)

    // !    property FieldName: TMyRecord read fFieldName write fFieldName;

    // !  end;

    // you will have to register it via a call to

    // TSQLRecordProperties.RegisterCustomPropertyFromRTTI()

    // - optional aIsNotUnique parameter can be defined

    // - implementation will use internally RecordLoadJSON/RecordSave functions

    // - you can specify optional aData2Text/aText2Data callbacks to store

    // the content as textual values, and not as BLOB

    constructor Create(aTypeInfo: PTypeInfo; const aName: RawUTF8;

      aPropertyIndex: integer; aPropertyPointer: pointer;

      aAttributes: TSQLPropInfoAttributes=[]; aFieldWidth: integer=0);

        reintroduce; overload;

    /// define a custom property from its RTTI definition

    // - handle any kind of property, e.g. from enhanced RTTI or a custom record

    // defined via TTextWriter.RegisterCustomJSONSerializer[FromText]()

    // - aPropertyPointer shall be filled with the offset to the private

    // field within a nil object, e.g for

    // !  class TMainObject = class(TSQLRecord)

    // !    (...)

    // !    fGUID: TGUID;

    // !  public

    // !    (...)

    // !    property GUID: TGUID read fGUID write fGUID;

    // !  end;

    // you will have to register it via a call to

    // TSQLRecordProperties.RegisterCustomPropertyFromTypeName()

    // - optional aIsNotUnique parameter can be defined

    // - implementation will use internally RecordLoadJSON/RecordSave functions

    // - you can specify optional aData2Text/aText2Data callbacks to store

    // the content as textual values, and not as BLOB

    constructor Create(const aTypeName, aName: RawUTF8;

      aPropertyIndex: integer; aPropertyPointer: pointer;

      aAttributes: TSQLPropInfoAttributes=[]; aFieldWidth: integer=0);

        reintroduce; overload;

    /// finalize the instance

    destructor Destroy; override;

    /// the corresponding custom JSON parser

    property CustomParser: TJSONCustomParserRTTI read fCustomParser;

  public

    procedure SetValue(Instance: TObject; Value: PUTF8Char; wasString: boolean); override;

    procedure GetJSONValues(Instance: TObject; W: TJSONSerializer); override;

    procedure GetValueVar(Instance: TObject; ToSQL: boolean;

      var result: RawUTF8; wasSQLString: PBoolean); override;

    procedure GetBinary(Instance: TObject; W: TFileBufferWriter); override;

    function SetBinary(Instance: TObject; P: PAnsiChar): PAnsiChar; override;

    procedure NormalizeValue(var Value: RawUTF8); override;

  end;



  /// dynamic array of ORM fields information for published properties

  TSQLPropInfoObjArray = array of TSQLPropInfo;



  /// handle a read-only list of fields information for published properties

  // - is mainly used by our ORM for TSQLRecord RTTI, but may be used for

  // any TPersistent

  TSQLPropInfoList = class

  protected

    fList: TSQLPropInfoObjArray;

    fCount: integer;

    fTable: TClass;

    fOptions: TSQLPropInfoListOptions;

    fOrderedByName: TIntegerDynArray;

    function GetItem(aIndex: integer): TSQLPropInfo;

    procedure QuickSortByName(L,R: PtrInt);

    procedure InternalAddParentsFirst(aClassType: TClass); overload;

    procedure InternalAddParentsFirst(aClassType: TClass;

      aFlattenedProps: PPropInfoDynArray); overload;

  public

    /// initialize the list from a given class RTTI

    constructor Create(aTable: TClass; aOptions: TSQLPropInfoListOptions);

    /// release internal list items

    destructor Destroy; override;

    /// add a TSQLPropInfo to the list

    function Add(aItem: TSQLPropInfo): integer;

    /// find an item in the list

    // - returns nil if not found

    function ByRawUTF8Name(const aName: RawUTF8): TSQLPropInfo; overload;

      {$ifdef HASINLINE}inline;{$endif}

    /// find an item in the list

    // - returns nil if not found

    function ByName(aName: PUTF8Char): TSQLPropInfo; overload;

      {$ifdef HASINLINE}inline;{$endif}

    /// find an item in the list

    // - returns -1 if not found

    function IndexByName(const aName: RawUTF8): integer; overload;

      {$ifdef HASINLINE}inline;{$endif}

    /// find an item in the list

    // - returns -1 if not found

    function IndexByName(aName: PUTF8Char): integer; overload;

    /// find an item by name in the list, including RowID/ID

    // - will identify 'ID' / 'RowID' field name as -1

    // - raise an EORMException if not found in the internal list

    function IndexByNameOrExcept(const aName: RawUTF8): integer;

    /// find one or several items by name in the list, including RowID/ID

    // - will identify 'ID' / 'RowID' field name as -1

    // - raise an EORMException if not found in the internal list

    procedure IndexesByNamesOrExcept(const aNames: array of RawUTF8;

      const aIndexes: array of PInteger);

    /// find an item in the list, searching by unflattened name

    // - for a flattened property, you may for instance call

    // IndexByNameUnflattenedOrExcept('Address.Country.Iso')

    // instead of IndexByNameOrExcept('Address_Country')

    // - won't identify 'ID' / 'RowID' field names, just List[].

    // - raise an EORMException if not found in the internal list

    function IndexByNameUnflattenedOrExcept(const aName: RawUTF8): integer;

    /// fill a TRawUTF8DynArray instance from the field names

    // - excluding ID

    procedure NamesToRawUTF8DynArray(var Names: TRawUTF8DynArray);

    /// returns the number of TSQLPropInfo in the list

    property Count: integer read fCount;

    /// quick access to the TSQLPropInfo list

    // - note that length(List) may not equal Count, since is its capacity

    property List: TSQLPropInfoObjArray read fList;

    /// read-only retrieval of a TSQLPropInfo item

    // - will raise an exception if out of range

    property Items[aIndex: integer]: TSQLPropInfo read GetItem; //default;

  end;



  /// simple writer to a Stream, specialized for writing an object as INI

  // - resulting content will be UTF-8 encoded

  // - use an internal buffer, faster than string+string

  TINIWriter = class(TTextWriter)

    /// write the published integer, Int64, floating point values, (wide)string,

    // enumerates (e.g. boolean), variant properties of the object

    // - won't handle shortstring properties

    // - add a new INI-like section with [Value.ClassName] if WithSection is true

    // - the object must have been compiled with the $M+ define, i.e. must

    // inherit from TPersistent or TSQLRecord

    // - the enumerates properties are stored with their integer index value

    // - content can be read back using overloaded procedures ReadObject()

    procedure WriteObject(Value: TObject; const SubCompName: RawUTF8='';

      WithSection: boolean=true); reintroduce;

  end;



  /// method prototype to be used for custom serialization of a class

  // - to be used with TJSONSerializer.RegisterCustomSerializer() method

  // - note that the generated JSON content is not required to start with '{',

  // as a normal JSON object (you may e.g. write a JSON string for some class) -

  // as a consequence, custom code could explicitely start with Add('{')

  // - implementation code shall follow function TJSONSerializer.WriteObject()

  // patterns, i.e. aSerializer.Add/AddInstanceName/AddJSONEscapeString...

  // - implementation code shall follow the same exact format for the

  // associated TJSONSerializerCustomReader callback

  TJSONSerializerCustomWriter = procedure(const aSerializer: TJSONSerializer;

    aValue: TObject; aOptions: TTextWriterWriteObjectOptions) of object;

  /// method prototype to be used for custom un-serialization of a class

  // - to be used with TJSONSerializer.RegisterCustomSerializer() method

  // - note that the read JSON content is not required to start with '{',

  // as a normal JSON object (you may e.g. read a JSON string for some class) -

  // as a consequence, custom code could explicitely start with "if aFrom^='{'..."

  // - implementation code shall follow function JSONToObject() patterns, i.e.

  // calling low-level GetJSONField() function to decode the JSON content

  // - implementation code shall follow the same exact format for the

  // associated TJSONSerializerCustomWriter callback

  TJSONSerializerCustomReader = function(const aValue: TObject; aFrom: PUTF8Char;

    var aValid: Boolean; aOptions: TJSONToObjectOptions): PUTF8Char of object;



  /// several options to customize how TSQLRecord would be serialized

  // - e.g. if properties storing JSON should be serialized as an object, and not

  // escaped as a string (which is the default, matching ORM column storage)

  // - if an additional "ID_str":"12345" field should be added to the standard

  // "ID":12345 field, which may exceed 53-bit integer precision of JavsCript

  TJSONSerializerSQLRecordOption = (

    jwoAsJsonNotAsString, jwoID_str);

  /// options to customize how TSQLRecord would be written by TJSONSerializer

  TJSONSerializerSQLRecordOptions = set of TJSONSerializerSQLRecordOption;



  /// simple writer to a Stream, specialized for writing an object as JSON

  // - resulting JSON content will be UTF-8 encoded

  // - use an internal buffer, faster than string+string

  TJSONSerializer = class(TJSONWriter)

  protected

    fSQLRecordOptions: TJSONSerializerSQLRecordOptions;

    procedure SetSQLRecordOptions(Value: TJSONSerializerSQLRecordOptions);

  public

    /// serialize as JSON the published integer, Int64, floating point values,

    // TDateTime (stored as ISO 8601 text), string and enumerate (e.g. boolean)

    // properties of the object

    // - won't handle shortstring properties

    // - the object must have been compiled with the $M+ define, i.e. must

    // inherit from TPersistent or TSQLRecord, or has been defined with a

    // custom serializer via RegisterCustomSerializer()

    // - will write also the properties published in the parent classes

    // - the enumerates properties are stored with their integer index value by

    // default, but will be written as text if woFullExpand option is set

    // - TList objects are not handled by default - they will be written only

    // if FullExpand is set to true (and JSONToObject won't be able to read it)

    // - nested properties are serialized as nested JSON objects

    // - any TCollection property will also be serialized as JSON array

    // - any TStrings or TRawUTF8List property will also be serialized as

    // JSON string array

    // - function ObjectToJSON() is just a wrapper over this method

    procedure WriteObject(Value: TObject;

      Options: TTextWriterWriteObjectOptions=[woDontStoreDefault]); override;

    /// override method, handling IncludeUnitName option

    procedure AddInstancePointer(Instance: TObject; SepChar: AnsiChar;

      IncludeUnitName: boolean); override;

    /// customize TSQLRecord.GetJSONValues serialization process

    // - jwoAsJsonNotAsString would force TSQLRecord.GetJSONValues to serialize

    // nested property instances as a JSON object/array, not a JSON string:

    // i.e. root/table/id REST would be ready-to-be-consummed from AJAX clients

    // (e.g. TSQLPropInfoRTTIObject.GetJSONValues as a JSON object, and

    // TSQLPropInfoRTTIDynArray.GetJSONValues as a JSON array)

    // - jwoID_str would add an "ID_str":"12345" property to the default

    // "ID":12345 field to circumvent JavaScript's limitation of 53-bit for

    // integer numbers, which is easily reached with our 64-bit TID values, e.g.

    // if TSynUniqueIdentifier are used to generate the IDs: AJAX clients should

    // better use this "ID_str" string value to identify each record, and ignore

    // the "id" fields

    property SQLRecordOptions: TJSONSerializerSQLRecordOptions

      read fSQLRecordOptions write SetSQLRecordOptions;



    /// define a custom serialization for a given class

    // - by default, TSQLRecord, TPersistent, TStrings, TCollection classes

    // are processed: but you can specify here some callbacks to perform

    // the serialization process for any class

    // - any previous registration is overridden

    // - setting both aReader=aWriter=nil will return back to the default class

    // serialization (i.e. published properties serialization)

    // - note that any inherited classes will be serialized as the parent class

    class procedure RegisterCustomSerializer(aClass: TClass;

      aReader: TJSONSerializerCustomReader; aWriter: TJSONSerializerCustomWriter);

    /// let a given class be recognized by JSONToObject() from "ClassName":".."

    // - TObjectList item instances will be created corresponding to the

    // serialized class name field specified, and JSONToNewObject() can create a

    // new instance using the "ClassName":"..." field to identify the class type

    // - by default, all referenced TSQLRecord classes will be globally

    // registered when TSQLRecordProperties information is retrieved

    class procedure RegisterClassForJSON(aItemClass: TClass); overload;

    /// let a given class be recognized by JSONToObject() from "ClassName":".."

    // - TObjectList item instances will be created corresponding to the

    // serialized class name field specified, and JSONToNewObject() can create a

    // new instance using the "ClassName":"..." field to identify the class type

    // - by default, all referenced TSQLRecord classes will be globally

    // registered when TSQLRecordProperties information is retrieved

    class procedure RegisterClassForJSON(const aItemClass: array of TClass); overload;

    {$ifndef LVCL}

    /// let a given TCollection be recognized during JSON serialization

    // - due to how TCollection instances are created, you can not create a

    // server-side instance of TCollection directly

    // - first workaround is to inherit from TInterfacedCollection

    // - this method allows to recognize the needed TCollectionItem class for

    // a given TCollection class, so allow to (un)serialize any TCollection,

    // without defining a new method and inherits from TInterfacedCollection

    // - note that both supplied classes will be registered for the internal

    // "ClassName":"..." RegisterClassForJSON() process

    class procedure RegisterCollectionForJSON(aCollection: TCollectionClass;

      aItem: TCollectionItemClass);

    {$endif}

    /// let a T*ObjArray dynamic array be used for storage of class instances

    // - will allow JSON serialization and unserialization of the registered

    // dynamic array property defined in any TPersistent or TSQLRecord

    // - could be used as such (note the T*ObjArray type naming convention):

    // ! TUserObjArray = array of TUser;

    // ! ...

    // ! TJSONSerializer.RegisterObjArrayForJSON(TypeInfo(TUserObjArray),TUser);

    // - then you can use ObjArrayAdd/ObjArrayFind/ObjArrayDelete to manage

    // the stored items, and never forget to call ObjArrayClear to release

    // the memory

    class procedure RegisterObjArrayForJSON(aDynArray: PTypeInfo; aItem: TClass); overload;

    /// let T*ObjArray dynamic arrays be used for storage of class instances

    // - will allow JSON serialization and unserialization of the registered

    // dynamic array property defined in any TPersistent or TSQLRecord

    // - will call the overloaded RegisterObjArrayForJSON() class method by pair:

    // ! TJSONSerializer.RegisterObjArrayForJSON([

    // !     TypeInfo(TAddressObjArray),TAddress, TypeInfo(TUserObjArray),TUser]);

    class procedure RegisterObjArrayForJSON(const aDynArrayClassPairs: array of const); overload;

    /// retrieve TClassInstance information for a T*ObjArray dynamic array type

    // - the T*ObjArray dynamic array should have been previously registered

    // via TJSONSerializer.RegisterObjArrayForJSON() overloaded methods

    // - returns nil if the supplied type is not a registered T*ObjArray

    class function RegisterObjArrayFindType(aDynArray: PTypeInfo): PClassInstance;

  end;



const

  /// fake TTypeInfo RTTI used for TGUID on older versions of the compiler

  GUID_FAKETYPEINFO: packed record

    Kind: TTypeKind;

    Name: string[5];

    Size: cardinal;

    Count: integer;

  end = (

    Kind: tkRecord;

    Name: 'TGUID';

    Size: sizeof(TGUID);

    Count: 0);



/// retrieve a Field property RTTI information from a Property Name

function ClassFieldProp(ClassType: TClass; const PropName: shortstring): PPropInfo;



/// retrieve a Field property RTTI information from a Property Name

// - this special version also search into parent properties (default is only current)

function ClassFieldPropWithParents(aClassType: TClass; const PropName: shortstring): PPropInfo;



/// retrieve a class Field property instance from a Property Name

// - this version also search into parent properties

// - returns TRUE and set PropInstance if a matching property was found

function ClassFieldInstance(Instance: TObject; const PropName: shortstring;

  PropClassType: TClass; out PropInstance): boolean; overload;



/// retrieve a Field property RTTI information from a Property Name

// - this special version also search into parent properties (default is only current)

function ClassFieldPropWithParentsFromUTF8(aClassType: TClass; PropName: PUTF8Char;

  PropNameLen: integer): PPropInfo;



/// retrieve a Field property RTTI information searching for a Property class type

// - this special version also search into parent properties

function ClassFieldPropWithParentsFromClassType(aClassType,aSearchedClassType: TClass): PPropInfo;



/// retrieve a class Field property instance from a Property class type

// - this version also search into parent properties

// - returns TRUE and set PropInstance if a matching property was found

function ClassFieldInstance(Instance: TObject; PropClassType: TClass;

  out PropInstance): boolean; overload;



/// retrieve a class instance property value matching a class type

// - if aSearchedInstance is aSearchedClassType, will return aSearchedInstance

// - if aSearchedInstance is not aSearchedClassType, it will try all nested

// properties of aSearchedInstance for a matching aSearchedClassType: if no

// exact match is found, will return aSearchedInstance

function ClassFieldPropInstanceMatchingClass(aSearchedInstance: TObject;

  aSearchedClassType: TClass): TObject;



/// retrieve the total number of properties for a class, including its parents

function ClassFieldCountWithParents(ClassType: TClass;

  onlyWithoutGetter: boolean=false): integer;



/// returns TRUE if the class has some published fields, including its parents

function ClassHasPublishedFields(ClassType: TClass): boolean;



/// retrieve all class hierachy types which have some published properties

function ClassHierarchyWithField(ClassType: TClass): TClassDynArray;



/// retrieve the PPropInfo values of all published properties of a class

// - you could select which property types should be included in the list

function ClassFieldAllProps(ClassType: TClass;

  Types: TTypeKinds=[low(TTypeKind)..high(TTypeKind)]): PPropInfoDynArray;



/// retrieve the field names of all published properties of a class

// - will optionally append the property type to the name, e.g 'Age: integer'

// - you could select which property types should be included in the list

function ClassFieldNamesAllProps(ClassType: TClass; IncludePropType: boolean=false;

  Types: TTypeKinds=[low(TTypeKind)..high(TTypeKind)]): TRawUTF8DynArray;



/// retrieve the field names of all published properties of a class

// - will optionally append the property type to the name, e.g 'Age: integer'

// - you could select which property types should be included in the list

function ClassFieldNamesAllPropsAsText(ClassType: TClass; IncludePropType: boolean=false;

  Types: TTypeKinds=[low(TTypeKind)..high(TTypeKind)]): RawUTF8;



/// retrieve an object's component from its property name and class

// - useful to set User Interface component, e.g.

function GetObjectComponent(Obj: TPersistent; const ComponentName: shortstring;

  ComponentClass: TClass): pointer;



/// retrieve the class property RTTI information for a specific class

function InternalClassProp(ClassType: TClass): PClassProp;

  {$ifdef FPC}inline;{$endif}



/// retrieve the class property RTTI information for a specific class

// - will return the number of published properties

// - and set the PropInfo variable to point to the first property

// - typical use to enumerate all published properties could be:

//  !  var i: integer;

//  !      CT: TClass;

//  !      P: PPropInfo;

//  !  begin

//  !    CT := ..;

//  !    repeat

//  !      for i := 1 to InternalClassPropInfo(CT,P) do begin

//  !        // use P^

//  !        P := P^.Next;

//  !      end;

//  !      CT := CT.ClassParent;

//  !    until CT=nil;

//  !  end;

// such a loop is much faster than using the RTL's TypeInfo or RTTI units

function InternalClassPropInfo(ClassType: TClass; out PropInfo: PPropInfo): integer;



/// retrieve a method RTTI information for a specific class

function InternalMethodInfo(aClassType: TClass; const aMethodName: ShortString): PMethodInfo;



/// execute an instance method from its RTTI per-interface information

// - calling this function with a pre-computed PInterfaceEntry value is faster

// than calling the TObject.GetInterface() method, especially when the class

// implements several interfaces, since it avoid a slow GUID lookup

function GetInterfaceFromEntry(Instance: TObject; Entry: PInterfaceEntry; out Obj): boolean;



/// retrieve the ready to be displayed text of an enumeration

// - will "uncamel" then translate into a generic VCL string

// - aIndex will be converted to the matching ordinal value (byte or word)

function GetEnumCaption(aTypeInfo: PTypeInfo; const aIndex): string;



/// get the corresponding enumeration name, without the first lowercase chars

// (otDone -> 'Done')

// - aIndex will be converted to the matching ordinal value (byte or word)

// - this will return the code-based English text; use GetEnumCaption() to

// retrieve the enumeration display text

function GetEnumNameTrimed(aTypeInfo: PTypeInfo; const aIndex): RawUTF8;



/// get all included values of an enumeration set, as CSV names

function GetSetNameCSV(aTypeInfo: PTypeInfo; const aValue): RawUTF8;



var

  /// a shared list of T*ObjArray registered serializers

  // - you should not access this variable, but via inline methods

  ObjArraySerializers: TPointerClassHash;



/// fill a class instance from a TDocVariant object document properties

// - returns FALSE if the variant is not a dvObject, TRUE otherwise

function DocVariantToObject(var doc: TDocVariantData; obj: TObject): boolean;



/// fill a T*ObjArray variable from a TDocVariant array document values

// - will always erase the T*ObjArray instance, and fill it from arr values

procedure DocVariantToObjArray(var arr: TDocVariantData; var objArray;

  objClass: TClass); overload;



/// fill a T*ObjArray variable from a TDocVariant array document values

// - will always erase the T*ObjArray instance, and fill it from arr values

procedure DocVariantToObjArray(var arr: TDocVariantData; var objArray;

  objClass: PClassInstance); overload;





{ ************ cross-cutting classes and types }



type

  {$ifndef LVCL}

  /// any TCollection used between client and server shall inherit from this class

  // - you should override the GetClass virtual method to provide the

  // expected collection item class to be used on server side

  // - another possibility is to register a TCollection/TCollectionItem pair

  // via a call to TJSONSerializer.RegisterCollectionForJSON()

  TInterfacedCollection = class(TCollection)

  protected

    /// you shall override this abstract method

    class function GetClass: TCollectionItemClass; virtual; abstract;

  public

    /// this constructor which will call GetClass to initialize the collection

    constructor Create; reintroduce; virtual;

  end;



  /// class-reference type (metaclass) of a TInterfacedCollection kind

  TInterfacedCollectionClass = class of TInterfacedCollection;



  /// abstract TCollectionItem class, which will instantiate all its nested

  // TPersistent/TSynPersistent class published properties, then release them when freed

  // - could be used for gathering of TCollectionItem properties, e.g. for

  // Domain objects in DDD, especially for list of value objects

  // - note that non published properties won't be instantiated

  // - please take care that you would not create any endless recursion: you

  // should ensure that at one level, nested published properties won't have any

  // class instance matching its parent type

  // - since the destructor will release all nested properties, you should

  // never store a reference of any of those nested instances outside

  TCollectionItemAutoCreateFields = class(TCollectionItem)

  public

    /// this overriden constructor will instantiate all its nested

    // TPersistent class published properties

    constructor Create(Collection: TCollection); override;

    /// finalize the instance, and release its published properties

    destructor Destroy; override;

  end;



  {$endif LVCL}



  /// abstract TPersistent class, which will instantiate all its nested TPersistent

  // class published properties, then release them (and any T*ObjArray) when freed

  // - TSynAutoCreateFields is to be preferred in most cases, due to its lower overhead

  // - note that non published (e.g. public) properties won't be instantiated

  // - please take care that you would not create any endless recursion: you

  // should ensure that at one level, nested published properties won't have any

  // class instance matching its parent type

  // - since the destructor will release all nested properties, you should

  // never store a reference of any of those nested instances outside

  TPersistentAutoCreateFields = class(TPersistentWithCustomCreate)

  public

    /// this overriden constructor will instantiate all its nested

    // TPersistent class published properties

    constructor Create; override;

    /// finalize the instance, and release its published properties

    destructor Destroy; override;

  end;



  /// our own empowered TPersistentAutoCreateFields-like parent class

  // - TPersistent/TPersistentAutoCreateFields have an unexpected speed overhead

  // due a giant lock introduced to manage property name fixup resolution

  // (which we won't use outside the VCL)

  // - abstract class able with a virtual constructor, RTTI for published

  // properties, and automatic memory management of all nested class

  // published properties

  // - will also release any T*ObjArray dynamic array storage of persistents,

  // previously registered via TJSONSerializer.RegisterObjArrayForJSON()

  // - this class is a perfect parent for any class storing data by value, e.g.

  // DDD Value Objects, Entities or Aggregates

  // - note that non published (e.g. public) properties won't be instantiated

  // - please take care that you would not create any endless recursion: you

  // should ensure that at one level, nested published properties won't have any

  // class instance matching its parent type

  // - since the destructor will release all nested properties, you should

  // never store a reference to any of those nested instances if this owner

  // may be freed before

  TSynAutoCreateFields = class(TSynPersistent)

  public

    /// this overriden constructor will instantiate all its nested

    // TPersistent/TSynPersistent/TSynAutoCreateFields class published properties

    {$ifdef FPC_OR_PUREPASCAL}

    constructor Create; override;

    {$else}

    class function NewInstance: TObject; override;

    {$endif}

    /// finalize the instance, and release its published properties

    destructor Destroy; override;

  end;



  /// adding locking methods to a TSynAutoCreateFields with virtual constructor

  TSynAutoCreateFieldsLocked = class(TSynAutoCreateFields)

  protected

    fSafe: TSynLocker;

  public

    /// initialize the object instance, and its associated lock

    constructor Create; override;

    /// release the instance (including the locking resource)

    destructor Destroy; override;

    /// access to the locking methods of this instance

    // - use Safe.Lock/TryLock with a try ... finally Safe.Unlock block

    property Safe: TSynLocker read fSafe;

    /// could be used as a short-cut to Safe.Lock

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

    /// could be used as a short-cut to Safe.UnLock

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

  end;



  /// abstract TInterfacedObject class, which will instantiate all its nested

  // TPersistent/TSynPersistent published properties, then release them when freed

  // - could be used for gathering of TCollectionItem properties, e.g. for

  // Domain objects in DDD, especially for list of value objects

  // - note that non published properties won't be instantiated

  // - please take care that you would not create any endless recursion: you

  // should ensure that at one level, nested published properties won't have any

  // class instance matching its parent type

  // - since the destructor will release all nested properties, you should

  // never store a reference of any of those nested instances outside

  TInterfacedObjectAutoCreateFields = class(TInterfacedObjectWithCustomCreate)

  public

    /// this overriden constructor will instantiate all its nested

    // TPersistent/TSynPersistent/TSynAutoCreateFields class published properties

    constructor Create; override;

    /// finalize the instance, and release its published properties

    destructor Destroy; override;

  end;



  /// used by TRawUTF8ObjectCacheList to manage a list of information cache

  TRawUTF8ObjectCacheSettings = class(TSynPersistent)

  protected

    fTimeOutMS: integer;

    fPurgePeriodMS: integer;

  public

    /// will set default values to settings

    constructor Create; override;

  published

    /// period after which the cache information should be flushed

    // - use -1 to disable time out; any big value would be limited to 10 minutes

    // - default is 120000, i.e. 2 minutes

    property TimeOutMS: integer read fTimeOutMS write fTimeOutMS;

    // period after which TRawUTF8ObjectCacheList would search for expired entries

    // - use -1 to disable purge (not adviced, since may break process)

    // - default is 1000, i.e. 1 second

    property PurgePeriodMS: integer read fPurgePeriodMS write fPurgePeriodMS;

  end;



  TRawUTF8ObjectCacheList = class;



  /// maintain information cache for a given key

  // - after a given period of time, the entry is not deleted, but CacheClear

  // virtual method is called to release the associated data or services

  // - inherit from this abstract class to store your own key-defined information

  // or you own interface-based services

  TRawUTF8ObjectCache = class(TSynAutoCreateFieldsLocked)

  protected

    fKey: RawUTF8; // inherited class could publish fKey with a custom name

    fOwner: TRawUTF8ObjectCacheList;

    fTimeoutMS: integer;

    fTimeoutTix: Int64;

    /// should be called by inherited classes when information or services are set

    // - set fTimeoutTix according to fTimeoutMS, to enable timeout mechanism

    // - could be used when the content is refreshed, to increase the entry TTL

    // - caller should do Safe.Lock to ensure thread-safety 

    procedure CacheSet; virtual;

    /// called by Destroy and TRawUTF8ObjectCacheList.DoPurge

    // - set fTimeoutTix := 0 (inherited should also release services interfaces)

    // - protected by Safe.Lock from TRawUTF8ObjectCacheList.DoPurge

    procedure CacheClear; virtual;

  public

    /// initialize the information cache entry

    // - should not be called directly, but by TRawUTF8ObjectCacheList.GetLocked

    constructor Create(aOwner: TRawUTF8ObjectCacheList; const aKey: RawUTF8); reintroduce; virtual;

    /// finalize the information cache entry

    // - would also call the virtual CacheClear method

    destructor Destroy; override;

    /// Dependency Injection using fOwner.OnKeyResolve, for the current Key

    function Resolve(const aInterface: TGUID; out Obj): boolean;

    /// access to the associated storage list 

    property Owner: TRawUTF8ObjectCacheList read fOwner;

  end;

  /// class-reference type (metaclass) of a TRawUTF8ObjectCache

  // - used e.g. by TRawUTF8ObjectCacheClass.Create to generate the

  // expected cache instances

  TRawUTF8ObjectCacheClass = class of TRawUTF8ObjectCache;



  /// manage a list of information cache, identified by a hashed key

  // - you should better inherit from this class, to give a custom name and

  // constructor, or alter the default behavior

  // - would maintain a list of TRawUTF8ObjectCache instances

  TRawUTF8ObjectCacheList = class(TRawUTF8ListHashedLocked)

  protected

    fSettings: TRawUTF8ObjectCacheSettings;

    fLog: TSynLogFamily;

    fLogEvent: TSynLogInfo;

    fClass: TRawUTF8ObjectCacheClass;

    fNextPurgeTix: Int64;

    fOnKeyResolve: TOnKeyResolve;

    procedure DoPurge; virtual;

    // returns fClass.Create by default: inherited classes may add custom check

    // or return nil if Key is invalid

    function NewObjectCache(const Key: RawUTF8): TRawUTF8ObjectCache; virtual;

  public

    /// initialize the cache-information for a given class

    // - inherited classes may reintroduce a new constructor, for ease of use

    constructor Create(aClass: TRawUTF8ObjectCacheClass;

      aSettings: TRawUTF8ObjectCacheSettings; aLog: TSynLogFamily; aLogEvent: TSynLogInfo;

      const aOnKeyResolve: TOnKeyResolve); reintroduce;

    /// fill TRawUTF8ObjectCache with the matching key information

    // - an unknown key, but with a successful NewObjectCache() call, will

    // create and append a new fClass instance to the list (if onlyexisting

    // is left to its default FALSE)

    // - global or key-specific purge would be performed, if needed

    // - on success (true), output cache instance would be locked

    function GetLocked(const Key: RawUTF8; out cache: TRawUTF8ObjectCache;

      onlyexisting: boolean=false): boolean; virtual;

    /// you may call this method regularly to check for a needed purge

    // - if Settings.PurgePeriodMS is reached, each TRawUTF8ObjectCache instance

    // would check for its TimeOutMS and call CacheClear if information is outdated

    procedure TryPurge;

    /// this method will clear all associated information

    // - a regular Clear would destroy all TRawUTF8ObjectCache instances,

    // whereas this method would call CacheClear on each entry, so would

    // be more thread-safe and efficient in pratice

    procedure ForceCacheClear;

    /// access to the associated logging instance

    procedure Log(const TextFmt: RawUTF8; const TextArgs: array of const;

      Level: TSynLogInfo = sllNone);

    /// optional service locator for by-key Dependency Injection

    property OnKeyResolve: TOnKeyResolve read fOnKeyResolve write fOnKeyResolve;

  end;



const

  /// HTML Status Code for "Continue"

  HTML_CONTINUE = 100;

  /// HTML Status Code for "Switching Protocols"

  HTML_SWITCHINGPROTOCOLS = 101;

  /// HTML Status Code for "Success"

  HTML_SUCCESS = 200;

  /// HTML Status Code for "Created"

  HTML_CREATED = 201;

  /// HTML Status Code for "Accepted"

  HTML_ACCEPTED = 202;

  /// HTML Status Code for "Non-Authoritative Information"

  HTML_NONAUTHORIZEDINFO = 203;

  /// HTML Status Code for "No Content"

  HTML_NOCONTENT = 204;

  /// HTML Status Code for "Multiple Choices"

  HTML_MULTIPLECHOICES = 300;

  /// HTML Status Code for "Moved Permanently"

  HTML_MOVEDPERMANENTLY = 301;

  /// HTML Status Code for "Found"

  HTML_FOUND = 302;

  /// HTML Status Code for "See Other"

  HTML_SEEOTHER = 303;

  /// HTML Status Code for "Not Modified"

  HTML_NOTMODIFIED = 304;

  /// HTML Status Code for "Use Proxy"

  HTML_USEPROXY = 305;

  /// HTML Status Code for "Temporary Redirect"

  HTML_TEMPORARYREDIRECT = 307;

  /// HTML Status Code for "Bad Request"

  HTML_BADREQUEST = 400;

  /// HTML Status Code for "Unauthorized"

  HTML_UNAUTHORIZED = 401;

  /// HTML Status Code for "Forbidden"

  HTML_FORBIDDEN = 403;

  /// HTML Status Code for "Not Found"

  HTML_NOTFOUND = 404;

  // HTML Status Code for "Method Not Allowed"

  HTML_NOTALLOWED = 405;

  // HTML Status Code for "Not Acceptable"

  HTML_NOTACCEPTABLE = 406;

  // HTML Status Code for "Proxy Authentication Required"

  HTML_PROXYAUTHREQUIRED = 407;

  /// HTML Status Code for "Request Time-out"

  HTML_TIMEOUT = 408;

  /// HTML Status Code for "Internal Server Error"

  HTML_SERVERERROR = 500;

  /// HTML Status Code for "Not Implemented"

  HTML_NOTIMPLEMENTED = 501;

  /// HTML Status Code for "Bad Gateway"

  HTML_BADGATEWAY = 502;

  /// HTML Status Code for "Service Unavailable"

  HTML_UNAVAILABLE = 503;

  /// HTML Status Code for "Gateway Timeout"

  HTML_GATEWAYTIMEOUT = 504;

  /// HTML Status Code for "HTTP Version Not Supported"

  HTML_HTTPVERSIONNONSUPPORTED = 505;



  /// you can use this cookie value to delete a cookie on the browser side

  COOKIE_EXPIRED = '; Expires=Sat, 01 Jan 2010 00:00:01 GMT';



  /// used e.g. by THttpApiServer.Request for http.sys to send a static file

  // - the OutCustomHeader should contain the proper 'Content-type: ....'

  // corresponding to the file (e.g. by calling GetMimeContentType() function

  // from SynCommons supplyings the file name)

  // - should match HTTP_RESP_STATICFILE constant defined in SynCrtSock.pas unit

  STATICFILE_CONTENT_TYPE = '!STATICFILE';



  /// used to notify e.g. the THttpServerRequest not to wait for any response

  // from the client

  // - is not to be used in normal HTTP process, but may be used e.g. by

  // TWebSocketProtocolRest.ProcessFrame() to avoid to wait for an incoming

  // response from the other endpoint

  // - should match HTTP_RESP_NORESPONSE constant defined in SynCrtSock.pas unit

  NORESPONSE_CONTENT_TYPE = '!NORESPONSE';



  /// HTTP header used e.g. by THttpApiServer.Request for http.sys to send

  // a static file in kernel mode

  STATICFILE_CONTENT_TYPE_HEADER = HEADER_CONTENT_TYPE+STATICFILE_CONTENT_TYPE;

  /// uppercase version of HTTP header for static file content serving

  STATICFILE_CONTENT_TYPE_HEADER_UPPPER = HEADER_CONTENT_TYPE_UPPER+STATICFILE_CONTENT_TYPE;



/// convert any HTML_* constant to a short English text

// - see @http://www.w3.org/Protocols/rfc2616/rfc2616-sec10.html

procedure StatusCodeToErrorMsg(Code: integer; var result: RawUTF8); overload;



/// convert any HTML_* constant to an integer error code and its English text

// - see @http://www.w3.org/Protocols/rfc2616/rfc2616-sec10.html

function StatusCodeToErrorMsg(Code: integer): RawUTF8; overload;



/// returns true for SUCCESS (200), CREATED (201), NOCONTENT (204),

// NOTMODIFIED (304) or TEMPORARYREDIRECT (307) codes

function StatusCodeIsSuccess(Code: integer): boolean;

  {$ifdef HASINLINE}inline;{$endif}



type

  /// the available HTTP methods transmitted between client and server

  // - some custom verbs are available in addition to standard REST commands

  // - most of iana verbs are available

  // see http://www.iana.org/assignments/http-methods/http-methods.xhtml

  // - for basic CRUD operations, we considered Create=mPOST, Read=mGET,

  // Update=mPUT and Delete=mDELETE

  TSQLURIMethod = (mNone, mGET, mPOST, mPUT, mDELETE, mHEAD,

                   mBEGIN, mEND, mABORT, mLOCK, mUNLOCK, mSTATE,

                   mOPTIONS, mPROPFIND, mPROPPATCH, mTRACE, mCOPY,

                   mMKCOL, mMOVE, mPURGE, mREPORT, mMKACTIVITY,

                   mMKCALENDAR,mCHECKOUT, mMERGE, mNOTIFY, mPATCH,

                   mSEARCH, mCONNECT);

  /// set of available HTTP methods transmitted between client and server

  TSQLURIMethods = set of TSQLURIMethod;



/// convert a string HTTP verb into its TSQLURIMethod enumerate

function StringToMethod(const method: RawUTF8): TSQLURIMethod;



{$ifdef MSWINDOWS}

{$ifdef ISDELPHIXE} // fix Delphi XE imcompatilibility

type

  TSecurityAttributes = packed record

    nLength: DWORD;

    lpSecurityDescriptor: Pointer;

    bInheritHandle: BOOL;

  end;

const

  SECURITY_DESCRIPTOR_REVISION = 1;

  SECURITY_DESCRIPTOR_MIN_LENGTH = 20;

{$endif ISDELPHIXE}

{$endif MSWINDOWS}





{ ******************* process monitoring / statistics }



type

  /// the time periods covered by TSynMonitorUsage process

  // - defines the resolution of information computed and stored  

  TSynMonitorUsageGranularity = (

    mugUndefined,

    mugMinute,

    mugHour,

    mugDay,

    mugMonth,

    mugYear);



  /// defines one or several time periods for TSynMonitorUsage process

  TSynMonitorUsageGranularities = set of TSynMonitorUsageGranularity;



  /// how the TSynMonitorUsage storage IDs are computed

  // - stored e.g. in TSQLMonitorUsage.ID primary key (after a shift)

  // - it follows a 23 bit pattern of hour (5 bit), day (5 bit), month (4 bit),

  // year (9 bit - starting at 2016) so that it is monotonic over time

  // - by default, will store the information using mugHour granularity (i.e.

  // values for the 60 minutes in a record), and pseudo-hours of 29, 30 and 31

  // (see USAGE_ID_HOURMARKER[]) would identify mugDay, mugMonth and mugYear

  // consolidated statistics

  // - it would therefore store up to 24*365+365+12+1 = 9138 records per year

  // in the associated storage engine (so there is no actual need to purge it)

  TSynMonitorUsageID = object

  public

    /// the TID, as computed from time and granularity

    Value: integer;

    /// computes an ID corresponding to mugHour granularity of a given time

    // - minutes and seconds would be ignored

    // - mugHour granularity would store 0..59 information about each minute

    procedure From(Y,M,D,H: integer); overload;

    /// computes an ID corresponding to mugDay granularity of a given time

    // - hours, minutes and seconds would be merged

    // - mugDay granularity would store 0..23 information about each hour

    // - a pseudo hour of 29 (i.e. USAGE_ID_HOURMARKER[mugDay]) is used

    procedure From(Y,M,D: integer); overload;

    /// computes an ID corresponding to mugMonth granularity of a given time

    // - days, hours, minutes and seconds would be merged

    // - mugMonth granularity would store 0..31 information about each day

    // - a pseudo hour of 30 (i.e. USAGE_ID_HOURMARKER[mugMonth]) is used

    procedure From(Y,M: integer); overload;

    /// computes an ID corresponding to mugYear granularity of a given time

    // - months, days, hours, minutes and seconds would be merged

    // - mugYear granularity would store 0..11 information about each month

    // - a pseudo hour of 31 (i.e. USAGE_ID_HOURMARKER[mugYear]) is used

    procedure From(Y: integer); overload;

    /// computes an ID corresponding to a given time

    // - will set the ID with mugHour granularity, i.e. the information about

    // the given hour, stored as per minute 0..59 values

    // - minutes and seconds in supplied TimeLog value would therefore be ignored

    procedure FromTimeLog(const TimeLog: TTimeLog); 

    /// computes an ID corresponding to the current UTC date/time

    // - minutes and seconds would be ignored

    procedure FromNowUTC;

    /// returns the date/time

    // - minutes and seconds would set to 0

    function ToTimeLog: TTimeLog;

    /// convert to Iso-8601 encoded text

    function Text(Expanded: boolean; FirstTimeChar: AnsiChar = 'T'): RawUTF8;

    /// retrieve the resolution of the stored information

    // - i.e. either mugHour, mugDay, mugMonth or mugYear, which would store

    // a true 0..23 hour value (for mugHour), or 29/30/31 pseudo-hour (i.e.

    // USAGE_ID_HOURMARKER[mugDay/mugMonth/mugYear])

    function Granularity: TSynMonitorUsageGranularity;

    /// change the resolution of the stored information

    procedure Truncate(gran: TSynMonitorUsageGranularity);

    /// low-level read of a time field stored in this ID, per granularity

    function GetTime(gran: TSynMonitorUsageGranularity): integer;

      {$ifdef HASINLINE}inline;{$endif}

    /// low-level modification of a time field stored in this ID, per granularity

    procedure SetTime(gran: TSynMonitorUsageGranularity; aValue: integer);

  end;



  TSynMonitorUsageTrackProp = record

    Info: PPropInfo;

    /// property type, as recognized by MonitorPropUsageValue()

    Kind: TSynMonitorType;

    Name: RawUTF8;

    Values: array[mugHour..mugYear] of TInt64DynArray;

    CumulativeLast: Int64;

  end;

  TSynMonitorUsageTrackPropDynArray = array of TSynMonitorUsageTrackProp;

  TSynMonitorUsageTrack = record

    Instance: TObject;

    Name: RawUTF8;

    Props: TSynMonitorUsageTrackPropDynArray;

  end;

  PSynMonitorUsageTrackProp = ^TSynMonitorUsageTrackProp;

  PSynMonitorUsageTrack = ^TSynMonitorUsageTrack;



  /// abstract class to track, compute and store TSynMonitor detailed statistics

  // - you should inherit from this class to implement proper data persistence,

  // e.g. using TSynMonitorUsageRest for ORM-based storage

  TSynMonitorUsage = class(TSynPersistentLocked)

  protected

    fLog: TSynLogFamily;

    fTracked: array of TSynMonitorUsageTrack;

    fValues: array[mugHour..mugYear] of Variant;

    fCustomWritePropGranularity: TSynMonitorUsageGranularity;

    fLastInstance: TObject;

    fLastTrack: PSynMonitorUsageTrack;

    fPrevious: TTimeLogBits;

    fComment: RawUTF8;

    function TrackPropLock(Instance: TObject; Info: PPropInfo): PSynMonitorUsageTrackProp;

    // those methods would be protected (e.g. in Modified) by fSafe.Lock:

    procedure SavePrevious(Scope: TSynMonitorUsageGranularity);

    procedure Save(ID: TSynMonitorUsageID; Gran, Scope: TSynMonitorUsageGranularity);

    function Load(const Time: TTimeLogBits): boolean;

    procedure LoadTrack(var Track: TSynMonitorUsageTrack);

    // should be overriden with proper persistence storage:

    function SaveDB(ID: integer; const Track: variant; Gran: TSynMonitorUsageGranularity): boolean; virtual; abstract;

    function LoadDB(ID: integer; Gran: TSynMonitorUsageGranularity; out Track: variant): boolean; virtual; abstract;

    // may be overriden for testing purposes

    procedure SetCurrentUTCTime(out minutes: TTimeLogBits); virtual;

  public

    /// finalize the statistics, saving any pending information

    destructor Destroy; override;

    /// track the values of one named object instance

    // - would recognize the TSynMonitor* properties as TSynMonitorType from

    // RTTI, using MonitorPropUsageValue(), within any (nested) object

    // - the instance would be stored in fTracked[].Instance: ensure it would

    // stay available during the whole TSynMonitorUsage process

    function Track(Instance: TObject; const Name: RawUTF8=''): integer; overload; virtual;

    /// track the values of the given object instances

    // - would recognize the TSynMonitor* properties as TSynMonitorType from

    // RTTI, using MonitorPropUsageValue(), within any (nested) object

    // - instances would be stored in fTracked[].Instance: ensure they would

    // stay available during the whole TSynMonitorUsage process

    procedure Track(const Instances: array of TSynMonitor); overload;

    /// to be called when tracked properties changed on a tracked class instance

    procedure Modified(Instance: TObject); overload;

    /// to be called when tracked properties changed on a tracked class instance

    procedure Modified(Instance: TObject; const PropNames: array of RawUTF8); overload; virtual;

    /// some custom text, associated with the current stored state

    // - would be persistented by Save() methods

    property Comment: RawUTF8 read fComment write fComment;

  end;



const

  USAGE_VALUE_LEN: array[mugHour..mugYear] of integer = (60,24,31,12);

  USAGE_ID_SHIFT: array[mugHour..mugYear] of byte = (0,5,10,14);

  USAGE_ID_BITS: array[mugHour..mugYear] of byte = (5,5,4,9);

  USAGE_ID_MASK: array[mugHour..mugYear] of integer = (31,31,15,511);

  USAGE_ID_MAX: array[mugHour..mugYear] of cardinal = (23,30,11,127);

  USAGE_ID_HOURMARKER: array[mugDay..mugYear] of integer = (29,30,31);

  USAGE_ID_YEAROFFSET = 2016;



  /// kind of "cumulative" TSynMonitorType stored in TSynMonitor / TSynMonitorUsage

  // - those properties would have their values reset for each granularity level

  // - would recognize TSynMonitorTotalMicroSec, TSynMonitorTotalBytes,

  // TSynMonitorOneBytes, TSynMonitorBytesPerSec, TSynMonitorCount and

  // TSynMonitorCount64 types

  SYNMONITORVALUE_CUMULATIVE = [smvMicroSec,smvBytes,smvCount, smvCount64];





function ToText(gran: TSynMonitorUsageGranularity): PShortString; overload;



/// guess the kind of value stored in a TSynMonitor / TSynMonitorUsage property

// - would recognize TSynMonitorTotalMicroSec, TSynMonitorOneMicroSec,

// TSynMonitorTotalBytes, TSynMonitorOneBytes, TSynMonitorBytesPerSec,

// TSynMonitorCount and TSynMonitorCount64 types from supplied RTTI

function MonitorPropUsageValue(info: PPropInfo): TSynMonitorType;





{ ************ main ORM / SOA classes and types }



const

  /// the used TAuthSession.IDCardinal value if the session not started yet

  // - i.e. if the session handling is still in its handshaking phase

  CONST_AUTHENTICATION_SESSION_NOT_STARTED = 0;



  /// the used TAuthSession.IDCardinal value if authentication mode is not set

  // - i.e. if TSQLRest.HandleAuthentication equals FALSE

  CONST_AUTHENTICATION_NOT_USED = 1;



  /// maximum handled dimension for TSQLRecordRTree

  // - this value is the one used by SQLite3 R-Tree virtual table

  RTREE_MAX_DIMENSION = 5;



  /// used as "stored AS_UNIQUE" published property definition in TSQLRecord

  AS_UNIQUE = false;



  /// custom contract value to ignore contract validation from client side

  // - you could set the aContractExpected parameter to this value for

  // TSQLRestClientURI.ServiceDefine or TSQLRestClientURI.ServiceRegister

  // so that the contract won't be checked with the server

  // - it would be used e.g. if the remote server is not a mORMot server,

  // but a plain REST/HTTP server - e.g. for public API notifications 

  SERVICE_CONTRACT_NONE_EXPECTED = '*';





type

  TSQLTable = class;



{$M+} { we need the RTTI information to be compiled for the published

        properties of these classes and their children (like TPersistent),

        to enable ORM - must be defined at the forward definition level }

  TSQLRecordProperties = class;

  TSQLModel = class;

  TSQLModelRecordProperties = class;

  TSQLRecord = class;      // published properties = ORM fields/columns

  TSQLRecordMany = class;

  TSQLAuthUser = class;

  TSQLRest = class;

  TSQLRestClient = class;

  {.$METHODINFO ON} // this would include public methods as RESTful callbacks :(

  TSQLRestServer = class;

  {.$METHODINFO OFF}

  TSQLRestStorage = class;

  TSQLRestStorageRemote = class;

  TSQLRestClientURI = class;

  TInterfaceFactory = class;

  TSQLRestBatch = class;

  TSQLRestBatchLocked = class;

{$M-}



  /// class-reference type (metaclass) of TSQLRecord

  TSQLRecordClass = class of TSQLRecord;



  PClass = ^TClass;

  PSQLRecordClass = ^TSQLRecordClass;



  /// a dynamic array storing TSQLRecord instances

  // - not used direcly, but as specialized T*ObjArray types

  TSQLRecordObjArray = array of TSQLRecord;



  /// a dynamic array used to store the TSQLRecord classes in a Database Model

  TSQLRecordClassDynArray = array of TSQLRecordClass;





  /// exception raised in case of incorrect TSQLTable.Step / Field*() use

  ESQLTableException = class(ESynException);



  /// generic parent class of all custom Exception types of this unit

  EORMException = class(ESynException);



  /// exception raised in case of wrong Model definition

  EModelException = class(EORMException);



  /// exception raised in case of unexpected parsing error

  EParsingException = class(EORMException);



  /// exception raised in case of a Client-Server communication error

  ECommunicationException = class(EORMException);



  /// exception raised in case of an error in project implementation logic

  EBusinessLayerException = class(EORMException);



  /// exception raised in case of any authentication error

  ESecurityException = class(EORMException);



  /// exception dedicated to interface factory, e.g. services and mock/stubs

  EInterfaceFactoryException = class(ESynException);



  /// exception raised in case of Dependency Injection (aka IoC) issue

  EInterfaceResolverException = class(ESynException);



  /// exception dedicated to interface based service implementation

  EServiceException = class(EORMException);





  /// information about a TSQLRecord class property

  // - sftID for TSQLRecord properties, which are pointer(RecordID), not

  // any true class instance

  // - sftMany for TSQLRecordMany properties, for which no data is

  // stored in the table itself, but in a pivot table

  // - sftObject for e.g. TStrings TRawUTF8List TCollection instances

  {$ifdef CPU64}

  TSQLPropInfoRTTIInstance = class(TSQLPropInfoRTTIInt64)

  {$else}

  TSQLPropInfoRTTIInstance = class(TSQLPropInfoRTTIInt32)

  {$endif}

  protected

    fObjectClass: TClass;

  public

    /// will setup the corresponding ObjectClass property

    constructor Create(aPropInfo: PPropInfo; aPropIndex: integer; aSQLFieldType: TSQLFieldType); override;

    /// direct access to the property class instance

    function GetInstance(Instance: TObject): TObject;

      {$ifdef HASINLINE}inline;{$endif}

    /// direct access to the property class instance

    procedure SetInstance(Instance, Value: TObject);

      {$ifdef HASINLINE}inline;{$endif}

    /// direct access to the property class

    // - can be used e.g. for TSQLRecordMany properties

    property ObjectClass: TClass read fObjectClass;

  end;



  /// information about a TRecordReference/TRecordReferenceToBeDeleted

  // published property

  // - identified as a sftRecord kind of property

  TSQLPropInfoRTTIRecordReference = class(TSQLPropInfoRTTIInt64)

  protected

    fCascadeDelete: boolean;

  public

    /// will identify TRecordReferenceToBeDeleted kind of field, and

    // setup the corresponding CascadeDelete property

    constructor Create(aPropInfo: PPropInfo; aPropIndex: integer; aSQLFieldType: TSQLFieldType); override;

    /// TRUE if this sftRecord is a TRecordReferenceToBeDeleted

    property CascadeDelete: boolean read fCascadeDelete;

  end;



  /// information about a TID published property

  // - identified as a sftTID kind of property, optionally tied to a TSQLRecord

  // class, via its custom type name, e.g.

  // ! TSQLRecordClientID = type TID;  ->  TSQLRecordClient class

  TSQLPropInfoRTTITID = class(TSQLPropInfoRTTIRecordReference)

  protected

    fRecordClass: TSQLRecordClass;

  public

    /// will setup the corresponding RecordClass property from the TID type name

    // - the TSQLRecord type should have previously been registered to the

    // TJSONSerializer.RegisterClassForJSON list, e.g. in TSQLModel.Create, so

    // that e.g. 'TSQLRecordClientID' type name would match TSQLRecordClient

    // - in addition, the '...ToBeDeletedID' name pattern would set CascadeDelete

    constructor Create(aPropInfo: PPropInfo; aPropIndex: integer; aSQLFieldType: TSQLFieldType); override;

    /// the TSQLRecord class associated to this TID

    // - is computed from its type name - for instance, if you define:

    // ! type

    // !   TSQLRecordClientID = type TID;

    // !   TSQLOrder = class(TSQLRecord)

    // !   ...

    // !   published OrderedBy: TSQLRecordClientID read fOrderedBy write fOrderedBy;

    // !   ...

    // then this OrderedBy property would be tied to the TSQLRecordClient class

    // of the corresponding model, and the field value will be reset to 0 when

    // the targetting record is deleted (emulating a ON DELETE SET DEFAULT)

    property RecordClass: TSQLRecordClass read fRecordClass;

    /// TRUE if this sftTID type name follows the '...ToBeDeletedID' pattern

    // - e.g. 'TSQLRecordClientToBeDeletedID' type name would match

    // TSQLRecordClient and set CascadeDelete

    // - is computed from its type name - for instance, if you define:

    // ! type

    // !   TSQLRecordClientToBeDeletedID = type TID;

    // !   TSQLOrder = class(TSQLRecord)

    // !   ...

    // !   published OrderedBy: TSQLRecordClientToBeDeletedID read fOrderedBy write fOrderedBy;

    // !   ...

    // then this OrderedBy property would be tied to the TSQLRecordClient class

    // of the corresponding model, and the whole record will be deleted when

    // the targetting record is deleted (emulating a ON DELETE CASCADE)

    property CascadeDelete: boolean read fCascadeDelete;

  end;



  /// information about a TRecordVersion published property

  // - identified as a sftRecordVersion kind of property, to track changes

  TSQLPropInfoRTTIRecordVersion = class(TSQLPropInfoRTTIInt64);



  /// information about a TSQLRecord class TSQLRecord property

  // - kind sftID, which are pointer(RecordID), not any true class instance

  // - will store the content just as an integer value

  // - will recognize any instance pre-allocated via Create*Joined() constructor

  TSQLPropInfoRTTIID = class(TSQLPropInfoRTTIInstance)

  public

    /// raise an exception if was created by Create*Joined() constructor

    procedure SetValue(Instance: TObject; Value: PUTF8Char; wasString: boolean); override;

    /// this method will recognize if the TSQLRecord was allocated by

    // a Create*Joined() constructor: in this case, it will write the ID

    // of the nested property, and not the PtrInt() transtyped value

    procedure GetJSONValues(Instance: TObject; W: TJSONSerializer); override;

  end;



  TSQLPropInfoRTTIIDObjArray = array of TSQLPropInfoRTTIID;



  /// information about a TSQLRecord class TStrings/TRawUTF8List/TCollection

  // property

  // - kind sftObject e.g. for TStrings TRawUTF8List TCollection TObjectList instances

  // - binary serialization will store textual JSON serialization of the

  // object, including custom serialization

  TSQLPropInfoRTTIObject = class(TSQLPropInfoRTTIInstance)

  protected

    procedure CopySameClassProp(Source: TObject; DestInfo: TSQLPropInfo; Dest: TObject); override;

  public

    procedure SetValue(Instance: TObject; Value: PUTF8Char; wasString: boolean); override;

    procedure GetValueVar(Instance: TObject; ToSQL: boolean;

      var result: RawUTF8; wasSQLString: PBoolean); override;

    procedure GetBinary(Instance: TObject; W: TFileBufferWriter); override;

    function SetBinary(Instance: TObject; P: PAnsiChar): PAnsiChar; override;

    function GetHash(Instance: TObject; CaseInsensitive: boolean): cardinal; override;

    procedure NormalizeValue(var Value: RawUTF8); override;

    procedure GetJSONValues(Instance: TObject; W: TJSONSerializer); override;

  end;



  /// information about a TSQLRecord class TSQLRecordMany property

  // - kind sftMany, for which no data is stored in the table itself, but in

  // a separated pivot table

  TSQLPropInfoRTTIMany = class(TSQLPropInfoRTTIInstance)

  public

    procedure SetValue(Instance: TObject; Value: PUTF8Char; wasString: boolean); override;

    procedure GetValueVar(Instance: TObject; ToSQL: boolean;

      var result: RawUTF8; wasSQLString: PBoolean); override;

    procedure GetBinary(Instance: TObject; W: TFileBufferWriter); override;

    function SetBinary(Instance: TObject; P: PAnsiChar): PAnsiChar; override;

  end;



  TSQLPropInfoRTTIManyObjArray = array of TSQLPropInfoRTTIMany;



  /// the kind of SQlite3 (virtual) table

  // - TSQLRecordFTS3 will be associated with vFTS3, TSQLRecordFTS4 with vFTS4,

  // TSQLRecordRTree with vRTree, any native SQlite3 table as vSQLite3, and

  // a TSQLRecordVirtualTable*ID with rCustomForcedID/rCustomAutoID

  // - a plain TSQLRecord class can be defined as rCustomForcedID (e.g. for

  // TSQLRecordMany) after registration for an external DB via a call to

  // VirtualTableExternalRegister() from mORMotDB unit

  TSQLRecordVirtualKind = (

    rSQLite3, rFTS3, rFTS4, rRTree, rCustomForcedID, rCustomAutoID);



  /// kind of (static) database server implementation available

  // - sMainEngine will identify the default main SQlite3 engine

  // - sStaticDataTable will identify a TSQLRestStorageInMemory - i.e.

  // TSQLRestServer.fStaticData[] which can work without SQLite3

  // - sVirtualTable will identify virtual TSQLRestStorage classes - i.e.

  // TSQLRestServer.fStaticVirtualTable[] which points to SQLite3 virtual tables

  // (e.g. TObjectList or external databases)

  TSQLRestServerKind = (sMainEngine, sStaticDataTable, sVirtualTable);

  /// pointer to the kind of (static) database server implementation

  PSQLRestServerKind = ^TSQLRestServerKind;



  /// some information about a given TSQLRecord class properties

  // - used internaly by TSQLRecord, via a global cache handled by this unit:

  // you can access to each record's properties via TSQLRecord.RecordProps class

  // - such a global cache saves some memory for each TSQLRecord instance,

  // and allows faster access to most wanted RTTI properties

  TSQLRecordProperties = class

  protected

    fTable: TSQLRecordClass;

    fClassType: PClassType;

    fClassProp: PClassProp;

    fHasNotSimpleFields: boolean;

    fHasTypeFields: TSQLFieldTypes;

    fFields: TSQLPropInfoList;

    fSimpleFields: TSQLPropInfoObjArray;

    fSQLTableName: RawUTF8;

    fCopiableFields: TSQLPropInfoObjArray;

    fManyFields: TSQLPropInfoRTTIManyObjArray;

    fJoinedFields: TSQLPropInfoRTTIIDObjArray;

    fJoinedFieldsTable: TSQLRecordClassDynArray;

    fDynArrayFields: TSQLPropInfoRTTIDynArrayObjArray;

    fDynArrayFieldsHasObjArray: boolean;

    fBlobCustomFields: TSQLPropInfoObjArray;

    fBlobFields: TSQLPropInfoRTTIObjArray;

    fFilters: TSynFilterOrValidateObjArrayArray;

    fRecordManySourceProp: TSQLPropInfoRTTIInstance;

    fRecordManyDestProp: TSQLPropInfoRTTIInstance;

    fSQLTableNameUpperWithDot: RawUTF8;

    fSQLFillPrepareMany: RawUTF8;

    fSQLTableSimpleFieldsNoRowID: RawUTF8;

    fSQLTableUpdateBlobFields: RawUTF8;

    fSQLTableRetrieveBlobFields: RawUTF8;

    fSQLTableRetrieveAllFields: RawUTF8;

    fRecordVersionField: TSQLPropInfoRTTIRecordVersion;

    fWeakZeroClass: TObject;

    /// the associated TSQLModel instances

    // - e.g. allow O(1) search of a TSQLRecordClass in a model

    fModel: array of record

      /// one associated model

      Model: TSQLModel;

      /// the index in the Model.Tables[] array

      TableIndex: integer;

      /// associated ORM parameters

      Properties: TSQLModelRecordProperties;

    end;

    fLock: TRTLCriticalSection;

    fModelMax: integer;

    fCustomCollation: TRawUTF8DynArray;

    /// add an entry in fModel[] / fModelMax

    procedure InternalRegisterModel(aModel: TSQLModel;

      aTableIndex: integer; aProperties: TSQLModelRecordProperties);

  public

    /// initialize the properties content

    constructor Create(aTable: TSQLRecordClass);

    /// release associated used memory

    destructor Destroy; override;



    /// return TRUE if the given name is either ID/RowID, either a property name

    function IsFieldName(const PropName: RawUTF8): boolean;

    /// return TRUE if the given name is either ID/RowID, either a property name,

    // or an aggregate function (MAX/MIN/AVG/SUM) on a valid property name 

    function IsFieldNameOrFunction(const PropName: RawUTF8): boolean;

    /// set all bits corresponding to the supplied field names

    // - returns TRUE on success, FALSE if any field name is not existing

    function FieldBitsFromRawUTF8(const aFields: array of RawUTF8;

      var Bits: TSQLFieldBits): boolean; overload;

    /// set all bits corresponding to the supplied field names

    // - returns the matching fields set

    function FieldBitsFromRawUTF8(const aFields: array of RawUTF8): TSQLFieldBits; overload;

    /// set all bits corresponding to the supplied CSV field names

    // - returns TRUE on success, FALSE if any field name is not existing

    function FieldBitsFromCSV(const aFieldsCSV: RawUTF8;

      var Bits: TSQLFieldBits): boolean; overload;

    /// set all bits corresponding to the supplied CSV field names, including ID

    // - returns TRUE on success, FALSE if any field name is not existing

    // - this overloaded method would identify ID/RowID field name, and set

    // withID output parameter according to its presence

    // - if aFieldsCSV='*', Bits will contain all simple fields, and withID=true

    function FieldBitsFromCSV(const aFieldsCSV: RawUTF8;

      var Bits: TSQLFieldBits; out withID: boolean): boolean; overload;

    /// set all bits corresponding to the supplied CSV field names

    // - returns the matching fields set

    function FieldBitsFromCSV(const aFieldsCSV: RawUTF8): TSQLFieldBits; overload;

    /// set all simple bits corresponding to the simple fields, excluding some

    // - could be a convenient alternative to FieldBitsFromCSV() if only some

    // fields are to be excluded

    // - returns the matching fields set

    function FieldBitsFromExcludingCSV(const aFieldsCSV: RawUTF8;

      aOccasion: TSQLOccasion=soSelect): TSQLFieldBits;

    /// set all bits corresponding to the supplied BLOB field type information

    // - returns TRUE on success, FALSE if blob field is not recognized

    function FieldBitsFromBlobField(aBlobField: PPropInfo;

      var Bits: TSQLFieldBits): boolean;

    /// compute the CSV field names text from a set of bits

    function CSVFromFieldBits(const Bits: TSQLFieldBits): RawUTF8;

    /// set all field indexes corresponding to the supplied field names

    // - returns TRUE on success, FALSE if any field name is not existing

    function FieldIndexDynArrayFromRawUTF8(const aFields: array of RawUTF8;

      var Indexes: TSQLFieldIndexDynArray): boolean; overload;

    /// set all field indexes corresponding to the supplied field names

    // - returns the matching fields set

    function FieldIndexDynArrayFromRawUTF8(const aFields: array of RawUTF8): TSQLFieldIndexDynArray; overload;

    /// set all field indexes corresponding to the supplied CSV field names

    // - returns TRUE on success, FALSE if any field name is not existing

    function FieldIndexDynArrayFromCSV(const aFieldsCSV: RawUTF8;

      var Indexes: TSQLFieldIndexDynArray): boolean; overload;

    /// set all field indexes corresponding to the supplied CSV field names

    // - returns the matching fields set

    function FieldIndexDynArrayFromCSV(const aFieldsCSV: RawUTF8): TSQLFieldIndexDynArray; overload;

    /// set all field indexes corresponding to the supplied BLOB field type information

    // - returns TRUE on success, FALSE if blob field is not recognized

    function FieldIndexDynArrayFromBlobField(aBlobField: PPropInfo;

      var Indexes: TSQLFieldIndexDynArray): boolean;

    /// retrieve a Field property RTTI information from a Property Name

    // - this version returns nil if the property is not a BLOB field

    function BlobFieldPropFromRawUTF8(const PropName: RawUTF8): PPropInfo;

    /// retrieve a Field property RTTI information from a Property Name

    // - this version returns nil if the property is not a BLOB field

    function BlobFieldPropFromUTF8(PropName: PUTF8Char; PropNameLen: integer): PPropInfo;



    /// append a field name to a RawUTF8 Text buffer

    // - if FieldIndex=VIRTUAL_TABLE_ROWID_COLUMN (-1), appends 'RowID' or

    // 'ID' (if ForceNoRowID=TRUE) to Text

    // - on error (i.e. if FieldIndex is out of range) will return TRUE

    // - otherwise, will return FALSE and append the field name to Text

    function AppendFieldName(FieldIndex: Integer; var Text: RawUTF8; ForceNoRowID: boolean): boolean;

    /// return the first unique property of kind RawUTF8

    // - this property is mainly the "Name" property, i.e. the one with

    // "stored AS_UNIQUE" (i.e. "stored false") definition on most TSQLRecord

    // - if ReturnFirstIfNoUnique is TRUE and no unique property is found,

    // the first RawUTF8 property is returned anyway

    // - returns '' if no matching field was found

    function MainFieldName(ReturnFirstIfNoUnique: boolean=false): RawUTF8;

    /// return the SQLite3 field datatype for each specified field

    // - set to '' for fields with no column created in the database (e.g. sftMany)

    // - returns e.g. ' INTEGER, ' or ' TEXT COLLATE SYSTEMNOCASE, '

    function SQLFieldTypeToSQL(FieldIndex: integer): RawUTF8;

    /// set a custom SQlite3 text column collation for a specified field

    // - can be used e.g. to override the default COLLATE SYSTEMNOCASE of RawUTF8

    // - collations defined within our SynSQLite3 unit are named BINARY, NOCASE,

    // RTRIM and our custom SYSTEMNOCASE, ISO8601, WIN32CASE, WIN32NOCASE

    // - do nothing if FieldIndex is not valid, and returns false

    // - to be set in overridden class procedure

    // TSQLRecord.InternalRegisterCustomProperties() so that it will be common

    // to all database models, for both client and server

    function SetCustomCollation(FieldIndex: integer; const aCollationName: RawUTF8): boolean; overload;

    /// set a custom SQlite3 text column collation for a specified field

    // - overloaded method which expects the field to be named

    function SetCustomCollation(const aFieldName, aCollationName: RawUTF8): boolean; overload;

    /// set a custom SQlite3 text column collation for a given field type

    // - can be used e.g. to override ALL default COLLATE SYSTEMNOCASE of RawUTF8,

    // or the default COLLATE ISO8601 of TDateTime, and let the generated SQLite3

    // file be available outside the scope of mORMot's SQLite3 engine

    // - collations defined within our SynSQLite3 unit are named BINARY, NOCASE,

    // RTRIM and our custom SYSTEMNOCASE, ISO8601, WIN32CASE, WIN32NOCASE

    // - to be set in overridden class procedure InternalRegisterCustomProperties()

    // so that it will be common to all database models, for both client and server

    procedure SetCustomCollationForAll(aFieldType: TSQLFieldType;

      const aCollationName: RawUTF8);

    /// allow to validate length of all text published properties of this table

    // - the "index" attribute of the RawUTF8/string published properties could

    // be used to specify a maximum length for external VARCHAR() columns

    // - SQLite3 will just ignore this "index" information, but it could be

    // handy to be able to validate the value length before sending to the DB

    // - this method will create TSynValidateText corresponding to the maximum

    // field size specified by the "index" attribute, to validate before write

    // - will expect the "index" value to be in UTF-16 codepoints, unless

    // IndexIsUTF8Length is set to TRUE, indicating UTF-8 length in "index"

    procedure SetMaxLengthValidatorForTextFields(IndexIsUTF8Length: boolean=false);

    /// allow to filter the length of all text published properties of this table

    // - the "index" attribute of the RawUTF8/string published properties could

    // be used to specify a maximum length for external VARCHAR() columns

    // - SQLite3 will just ignore this "index" information, but it could be

    // handy to be able to filter the value length before sending to the DB

    // - this method will create TSynFilterTruncate corresponding to the maximum

    // field size specified by the "index" attribute, to filter before write

    // - will expect the "index" value to be in UTF-16 codepoints, unless

    // IndexIsUTF8Length is set to TRUE, indicating UTF-8 length in "index"

    procedure SetMaxLengthFilterForTextFields(IndexIsUTF8Length: boolean=false);

    {$ifndef NOVARIANTS}

    /// customize the TDocVariant options for all variant published properties

    // - will change the TSQLPropInfoRTTIVariant.DocVariantOptions value

    // - use e.g. as SetVariantFieldDocVariantOptions(JSON_OPTIONS_FAST_EXTENDED)

    procedure SetVariantFieldsDocVariantOptions(const Options: TDocVariantOptions);

    {$endif}

    /// return the UTF-8 encoded SQL statement source to alter the table for

    //  adding the specified field

    function SQLAddField(FieldIndex: integer): RawUTF8;



    /// create a TJSONWriter, ready to be filled with TSQLRecord.GetJSONValues(W)

    // - you can use TSQLRecordProperties.FieldBitsFromCSV() or

    // TSQLRecordProperties.FieldBitsFromRawUTF8() to compute aFields

    function CreateJSONWriter(JSON: TStream; Expand: boolean; withID: boolean;

      const aFields: TSQLFieldBits; KnownRowsCount: integer): TJSONSerializer; overload;

    /// create a TJSONWriter, ready to be filled with TSQLRecord.GetJSONValues(W)

    // - you can use TSQLRecordProperties.FieldBitsFromCSV() or

    // TSQLRecordProperties.FieldBitsFromRawUTF8() to compute aFields

    function CreateJSONWriter(JSON: TStream; Expand: boolean; withID: boolean;

      const aFields: TSQLFieldIndexDynArray; KnownRowsCount: integer): TJSONSerializer; overload;

    /// create a TJSONWriter, ready to be filled with TSQLRecord.GetJSONValues(W)

    // - this overloaded method would call FieldBitsFromCSV(aFieldsCSV,bits,withID)

    // to retrieve the bits just like a SELECT (i.e. '*' for simple fields)

    function CreateJSONWriter(JSON: TStream; Expand: boolean;

       const aFieldsCSV: RawUTF8; KnownRowsCount: integer): TJSONSerializer; overload;

    /// set the W.ColNames[] array content + W.AddColumns

    procedure SetJSONWriterColumnNames(W: TJSONSerializer; KnownRowsCount: integer);

    /// save the TSQLRecord RTTI into a binary header

    // - used e.g. by TSQLRestStorageInMemory.SaveToBinary()

    procedure SaveBinaryHeader(W: TFileBufferWriter);

    /// ensure that the TSQLRecord RTTI matches the supplied binary header

    // - used e.g. by TSQLRestStorageInMemory.LoadFromBinary()

    function CheckBinaryHeader(var R: TFileBufferReader): boolean;

    /// convert a JSON array of simple field values into a matching JSON object

    function SaveSimpleFieldsFromJsonArray(var P: PUTF8Char;

      var EndOfObject: AnsiChar; ExtendedJSON: boolean): RawUTF8;



    /// register a custom filter (transformation) or validation rule to

    // the TSQMRecord class for a specified field

    // - this will be used by TSQLRecord.Filter and TSQLRecord.Validate

    // methods (in default implementation)

    // - will return FALSE in case of an invalid field index

    function AddFilterOrValidate(aFieldIndex: integer;

      aFilter: TSynFilterOrValidate): boolean; overload;

    /// register a custom filter (transformation) or validatation to the

    // TSQLRecord class for a specified field

    // - this will be used by TSQLRecord.Filter and TSQLRecord.Validate

    // methods (in default implementation)

    // - will raise an EModelException if the field name does not exist

    procedure AddFilterOrValidate(const aFieldName: RawUTF8;

      aFilter: TSynFilterOrValidate); overload;



    /// add a custom unmanaged fixed-size record property

    // - simple kind of records (i.e. those not containing reference-counted

    // members) do not have RTTI generated, at least in older versions of Delphi

    // - use this method within TSQLRecord.InternalRegisterCustomProperties

    // overridden method to define a custom record property with no

    // reference-counted types within (like strings) - typical use may be TGUID

    // - main parameters are the record size, in bytes, and the property pointer

    // - add an TSQLPropInfoRecordFixedSize instance to the internal list

    // - if aData2Text/aText2Data parameters are not defined, it will fallback

    // to TSQLPropInfo.BinaryToText() simple text Base64 encoding

    // - can be used to override the default TSQLRecord corresponding method:

    // !class procedure TSQLMyRecord.InternalRegisterCustomProperties(

    // !  Props: TSQLRecordProperties);

    // !begin

    // !  Props.RegisterCustomFixedSizeRecordProperty(self,sizeof(TMyRec),'RecField',

    // !    @TSQLMyRecord(nil).fRecField, [], sizeof(TMyRec));

    // !end;

    procedure RegisterCustomFixedSizeRecordProperty(aTable: TClass;

      aRecordSize: cardinal; const aName: RawUTF8;  aPropertyPointer: pointer;

      aAttributes: TSQLPropInfoAttributes; aFieldWidth: integer;

      aData2Text: TOnSQLPropInfoRecord2Text=nil;

      aText2Data: TOnSQLPropInfoRecord2Data=nil);

    /// add a custom record property from its RTTI definition

    // - handle any kind of record with TypeInfo() generated

    // - use this method within InternalRegisterCustomProperties overridden method

    // to define a custom record property containing reference-counted types

    // - main parameters are the record RTTI information, and the property pointer

    // - add an TSQLPropInfoRecordRTTI instance to the internal list

    // - can be used as such:

    // !class procedure TSQLMyRecord.InternalRegisterCustomProperties(

    // !  Props: TSQLRecordProperties);

    // !begin

    // !  Props.RegisterCustomRTTIRecordProperty(self,TypeInfo(TMyRec),'RecField',

    // !    @TSQLMyRecord(nil).fRecField);

    // !end;

    procedure RegisterCustomRTTIRecordProperty(aTable: TClass;

      aRecordInfo: PTypeInfo; const aName: RawUTF8; aPropertyPointer: pointer;

      aAttributes: TSQLPropInfoAttributes=[]; aFieldWidth: integer=0;

      aData2Text: TOnSQLPropInfoRecord2Text=nil;

      aText2Data: TOnSQLPropInfoRecord2Data=nil);

    /// add a custom property from its RTTI definition stored as JSON

    // - handle any kind of record with TypeInfo() generated

    // - use this method within InternalRegisterCustomProperties overridden method

    // to define a custom record property containing reference-counted types

    // - main parameters are the record RTTI information, and the property pointer

    // - add an TSQLPropInfoCustomJSON instance to the internal list

    // - can be used as such:

    // !class procedure TSQLMyRecord.InternalRegisterCustomProperties(

    // !  Props: TSQLRecordProperties);

    // !begin

    // !  Props.RegisterCustomPropertyFromRTTI(self,TypeInfo(TMyRec),'RecField',

    // !    @TSQLMyRecord(nil).fRecField);

    // !end;

    procedure RegisterCustomPropertyFromRTTI(aTable: TClass;

      aTypeInfo: PTypeInfo; const aName: RawUTF8; aPropertyPointer: pointer;

      aAttributes: TSQLPropInfoAttributes=[]; aFieldWidth: integer=0);

    /// add a custom property from its type name, stored as JSON

    // - handle any kind of registered record, including TGUID

    // - use this method within InternalRegisterCustomProperties overridden method

    // to define a custom record property containing reference-counted types

    // - main parameters are the record RTTI information, and the property pointer

    // - add an TSQLPropInfoCustomJSON instance to the internal list

    // - can be used as such:

    // !class procedure TSQLMyRecord.InternalRegisterCustomProperties(

    // !  Props: TSQLRecordProperties);

    // !begin

    // !  Props.RegisterCustomPropertyFromTypeName(self,'TGUID','GUID',

    // !    @TSQLMyRecord(nil).fGUID,[aIsUnique],38);

    // !end;

    procedure RegisterCustomPropertyFromTypeName(aTable: TClass;

      const aTypeName, aName: RawUTF8; aPropertyPointer: pointer;

      aAttributes: TSQLPropInfoAttributes=[]; aFieldWidth: integer=0);



    /// fast access to the RTTI properties attribute

    property TableClassType: PClassType read fClassType;

    /// fast access to the RTTI properties attribute

    property TableClassProp: PClassProp read fClassProp;

    /// if this class has any BLOB or TSQLRecodMany fields

    // - i.e. some fields to be ignored

    property HasNotSimpleFields: boolean read fHasNotSimpleFields;

    /// set of field types appearing in this record

    property HasTypeFields: TSQLFieldTypes read fHasTypeFields;

    /// list all fields, as retrieved from RTTI

    property Fields: TSQLPropInfoList read fFields;

    /// list all "simple" fields of this TSQLRecord

    // - by default, the TSQLRawBlob and TSQLRecordMany fields are not included

    // into this set: they must be read specificaly (in order to spare

    // bandwidth for BLOBs)

    // - dynamic arrays belong to simple fields: they are sent with other

    // properties content

    // - match inverted NOT_SIMPLE_FIELDS mask

    property SimpleFields: TSQLPropInfoObjArray read fSimpleFields;

    /// list all fields which can be copied from one TSQLRecord instance to another

    // - match COPIABLE_FIELDS mask, i.e. all fields except sftMany

    property CopiableFields: TSQLPropInfoObjArray read fCopiableFields;

    /// list all TSQLRecordMany fields of this TSQLRecord

    property ManyFields: TSQLPropInfoRTTIManyObjArray read fManyFields;

    /// list all TSQLRecord fields of this TSQLRecord

    // - ready to be used by TSQLTableJSON.CreateFromTables()

    // - i.e. the class itself then, all fields of type sftID (excluding sftMany)

    property JoinedFields: TSQLPropInfoRTTIIDObjArray read fJoinedFields;

    /// wrapper of all nested TSQLRecord class of this TSQLRecord

    // - ready to be used by TSQLTableJSON.CreateFromTables()

    // - i.e. the class itself as JoinedFieldsTable[0], then, all nested

    // TSQLRecord published properties (of type sftID, ergo excluding sftMany)

    // - equals nil if there is no nested TSQLRecord property (i.e. JoinedFields=nil)

    property JoinedFieldsTable: TSQLRecordClassDynArray read fJoinedFieldsTable;

    /// list of all sftBlobDynArray fields of this TSQLRecord

    property DynArrayFields: TSQLPropInfoRTTIDynArrayObjArray read fDynArrayFields;

    /// TRUE if any of the sftBlobDynArray fields of this TSQLRecord is a T*ObjArray

    property DynArrayFieldsHasObjArray: boolean read fDynArrayFieldsHasObjArray;

    /// list of all sftBlobCustom fields of this TSQLRecord

    // - have been defined e.g. as TSQLPropInfoCustom custom definition

    property BlobCustomFields: TSQLPropInfoObjArray read fBlobCustomFields;

    /// list all BLOB fields of this TSQLRecord

    // - i.e. generic sftBlob fields (not sftBlobDynArray, sftBlobCustom nor

    // sftBlobRecord)

    property BlobFields: TSQLPropInfoRTTIObjArray read fBlobFields;

    /// all TSynFilter or TSynValidate instances registered per each field

    // - since validation and filtering are used within some CPU-consuming

    // part of the framework (like UI edition), both filters and validation

    // rules are grouped in the same list - for TSynTableFieldProperties there

    // are separated Filters[] and Validates[] arrays, for better performance

    property Filters: TSynFilterOrValidateObjArrayArray read fFilters;

    /// for a TSQLRecordMany class, points to the Source property RTTI

    property RecordManySourceProp: TSQLPropInfoRTTIInstance read fRecordManySourceProp;

    /// for a TSQLRecordMany class, points to the Dest property RTTI

    property RecordManyDestProp: TSQLPropInfoRTTIInstance read fRecordManyDestProp;

    /// points to any TRecordVersion field

    // - contains nil if no such sftRecordVersion field do exist

    // - will be used by low-level storage engine to compute and store the

    // monotonic version number during any write operation

    property RecordVersionField: TSQLPropInfoRTTIRecordVersion read fRecordVersionField;

    /// the Table name in the database in uppercase with a final '.'

    // - e.g. 'TEST.' for TSQLRecordTest class

    // - can be used with IdemPChar() for fast check of a table name

    property SQLTableNameUpperWithDot: RawUTF8 read fSQLTableNameUpperWithDot;

    /// returns 'COL1,COL2' with all COL* set to simple field names

    // - same value as SQLTableSimpleFields[false,false]

    // - this won't change depending on the ORM settings: so it can be safely

    // computed here and not in TSQLModelRecordProperties

    // - used e.g. by TSQLRecord.GetSQLValues

    property SQLTableSimpleFieldsNoRowID: RawUTF8 read fSQLTableSimpleFieldsNoRowID;

    /// returns 'COL1=?,COL2=?' with all BLOB columns names

    // - used e.g. by TSQLRestServerDB.UpdateBlobFields()

    property SQLTableUpdateBlobFields: RawUTF8 read fSQLTableUpdateBlobFields;

    /// returns 'COL1,COL2' with all BLOB columns names

    // - used e.g. by TSQLRestServerDB.RetrieveBlobFields()

    property SQLTableRetrieveBlobFields: RawUTF8 read fSQLTableRetrieveBlobFields;

  public

    /// bit set to 1 for indicating each TSQLFieldType fields of this TSQLRecord

    FieldBits: array[TSQLFieldType] of TSQLFieldBits;

    /// bit set to 1 for indicating TModTime/TSessionUserID fields

    // of this TSQLRecord (leaving TCreateTime untouched)

    // - as applied before an UPDATE

    // - i.e. sftModTime and sftSessionUserID fields

    ComputeBeforeUpdateFieldsBits: TSQLFieldBits;

    /// bit set to 1 for indicating TModTime/TCreateTime/TSessionUserID fields

    // of this TSQLRecord

    // - as applied before an INSERT

    // - i.e. sftModTime, sftCreateTime and sftSessionUserID fields

    ComputeBeforeAddFieldsBits: TSQLFieldBits;

    /// bit set to 1 for indicating fields to export, i.e. "simple" fields

    // - this array will handle special cases, like the TCreateTime fields

    // which shall not be included in soUpdate but soInsert and soSelect e.g.

    SimpleFieldsBits: array[TSQLOccasion] of TSQLFieldBits;

    /// number of fields to export, i.e. "simple" fields

    // - this array will handle special cases, like the TCreateTime fields

    // which shall not be included in soUpdate but soInsert and soSelect e.g.

    SimpleFieldsCount: array[TSQLOccasion] of integer;

    /// bit set to 1 for an unique field

    // - an unique field is defined as "stored AS_UNIQUE" (i.e. "stored false")

    // in its property definition

    IsUniqueFieldsBits: TSQLFieldBits;

    /// bit set to 1 for the smallest simple fields

    // - i.e. excluding non only sftBlob and sftMany, but also sftVariant,

    // sftBlobDynArray, sftBlobCustom and sftUTF8Custom fields

    // - may be used to minimize the transmitted content, e.g. when serializing

    // to JSON for the most

    SmallFieldsBits: TSQLFieldBits;

    /// bit set to 1 for the all fields storing some data

    // - match COPIABLE_FIELDS mask, i.e. all fields except sftMany

    CopiableFieldsBits: TSQLFieldBits;

    /// contains the main field index (e.g. mostly 'Name')

    // - the [boolean] is for [ReturnFirstIfNoUnique] version

    // - contains -1 if no field matches

    MainField: array[boolean] of integer;

  published

    /// the TSQLRecord class

    property Table: TSQLRecordClass read fTable;

    /// the Table name in the database, associated with this TSQLRecord class

    // - 'TSQL' or 'TSQLRecord' chars are trimmed at the beginning of the ClassName

    // - or the ClassName is returned as is, if no 'TSQL' or 'TSQLRecord' at first

    property SQLTableName: RawUTF8 read fSQLTableName;

    /// returns 'COL1,COL2' with all COL* set to all field names, including

    // RowID, TRecordVersion and BLOBs

    // - this won't change depending on the ORM settings: so it can be safely

    // computed here and not in TSQLModelRecordProperties

    // - used e.g. by TSQLRest.InternalListJSON()

    property SQLTableRetrieveAllFields: RawUTF8 read fSQLTableRetrieveAllFields;

  end;



  TServiceFactoryServer = class;

  PSQLAccessRights = ^TSQLAccessRights;



  /// flags which may be set by the caller to notify low-level context

  // - llfSSL will indicates that the communication was made over HTTPS

  TSQLRestURIParamsLowLevelFlag = (llfSSL);



  /// some flags set by the caller to notify low-level context

  TSQLRestURIParamsLowLevelFlags = set of TSQLRestURIParamsLowLevelFlag;



  /// store all parameters for a TSQLRestServer.URI() method call

  // - see TSQLRestClient to check how data is expected in our RESTful format

  TSQLRestURIParams = {$ifndef ISDELPHI2010}object{$else}record{$endif}

    /// input parameter containing the caller URI

    Url: RawUTF8;

    /// input parameter containing the caller method

    // - handle enhanced REST codes: LOCK/UNLOCK/BEGIN/END/ABORT

    Method: RawUTF8;

    /// input parameter containing the caller message headers

    // - you can use e.g.

    // ! FindIniNameValue(pointer(Call.InHead),HEADER_CONTENT_TYPE_UPPER)

    // to retrieve the incoming message body content type

    // - or to retrieve the remote IP

    // ! FindIniNameValue(pointer(Call.InHead),'REMOTEIP: ')

    // - but consider also using TSQLRestServerURIContext.InHeader['remoteip']

    InHead: RawUTF8;

    /// input parameter containing the caller message body

    // - e.g. some GET/POST/PUT JSON data can be specified here

    InBody: RawUTF8;

    /// output parameter to be set to the response message header

    // - it is the right place to set the returned message body content type,

    // e.g. TEXT_CONTENT_TYPE_HEADER or HTML_CONTENT_TYPE_HEADER: if not set,

    // the default JSON_CONTENT_TYPE_HEADER will be returned to the client,

    // meaning that the message is JSON

    // - you can use OutBodyType() function to retrieve the stored content-type

    OutHead: RawUTF8;

    /// output parameter to be set to the response message body

    OutBody: RawUTF8;

    /// output parameter to be set to the HTTP status integer code

    // - HTML_NOTFOUND=404 e.g. if the url doesn't start with Model.Root (caller

    // can try another TSQLRestServer)

    OutStatus: cardinal;

    /// output parameter to be set to the database internal state

    OutInternalState: cardinal;

    /// associated RESTful access rights

    // - AccessRights must be handled by the TSQLRestServer child, according

    // to the Application Security Policy (user logging, authentification and

    // rights management) - making access rights a parameter allows this method

    // to be handled as pure stateless, thread-safe and session-free

    RestAccessRights: PSQLAccessRights;

    /// opaque reference to the protocol context which made this request

    // - may point e.g. to a THttpServerResp, a TWebSocketServerResp,

    // a THttpApiServer, a TSQLRestClientURI, a TFastCGIServer or a

    // TSQLRestServerNamedPipeResponse instance

    // - is a Int64 as expected by http.sys, but is an incremental sequence

    // of integer for THttpServer/TWebSocketServer, or a PtrInt(self)

    LowLevelConnectionID: Int64;

    /// low-level properties of the current protocol context

    LowLevelFlags: TSQLRestURIParamsLowLevelFlags;

    /// initialize the non RawUTF8 values

    procedure Init; overload;

    /// initialize the input values

    procedure Init(const aURI,aMethod,aInHead,aInBody: RawUTF8); overload;

    /// retrieve the "Content-Type" value from InHead

    // - if GuessJSONIfNoneSet is TRUE, returns JSON if none was set in headers

    function InBodyType(GuessJSONIfNoneSet: boolean=True): RawUTF8;

    /// retrieve the "Content-Type" value from OutHead

    // - if GuessJSONIfNoneSet is TRUE, returns JSON if none was set in headers

    function OutBodyType(GuessJSONIfNoneSet: boolean=True): RawUTF8;

  end;



  /// used to map set of parameters for a TSQLRestServer.URI() method

  PSQLRestURIParams = ^TSQLRestURIParams;



  /// points to the currently running service on the server side

  // - your code may use such a local pointer to retrieve the ServiceContext

  // threadvar once in a method, since threadvar access does cost some CPU

  // !var context: PServiceRunningContext;

  // !begin

  // !  context := @ServiceContext; // threadvar access once

  // !  ...

  PServiceRunningContext = ^TServiceRunningContext;



  TSQLRestServerURIContext = class;

  TAuthSession = class;



  /// used to identify the authentication failure reason

  // - as transmitted e.g. by TSQLRestServerURIContext.AuthenticationFailed or

  // TSQLRestServer.OnAuthenticationFailed

  TNotifyAuthenticationFailedReason = (

   afInvalidSignature,afRemoteServiceExecutionNotAllowed,

   afUnknownUser,afInvalidPassword,

   afSessionAlreadyStartedForThisUser,afSessionCreationAborted);



  /// will identify the currently running service on the server side

  // - is the type of the global ServiceContext threadvar

  // - to access the current TSQLRestServer instance (and e.g. its ORM/CRUD

  // or SOA methods), use Request.Server and not Factory.Server, which may not

  // be available e.g. if you run the service from the server side (so no

  // factory is involved)

  // - note that the safest (and slightly faster) access to the TSQLRestServer

  // instance associated with a service is to inherit your implementation

  // class from TInjectableObjectRest

  TServiceRunningContext = record

    /// the currently running service factory

    // - it can be used within server-side implementation to retrieve the

    // associated TSQLRestServer instance

    // - note that TServiceFactoryServer.Get() won't override this value, when

    // called within another service (i.e. if Factory is not nil)

    Factory: TServiceFactoryServer;

    /// the currently runnning context which launched the method

    // - low-level RESTful context is also available in its Call member

    // - Request.Server is the safe access point to the underlying TSQLRestServer,

    // unless the service is implemented via TInjectableObjectRest, so the

    // TInjectableObjectRest.Server property is preferred

    // - make available e.g. current session or authentication parameters

    // (including e.g. user details via Request.Server.SessionGetUser)

    Request: TSQLRestServerURIContext;

    /// the thread which launched the request

    // - is set by TSQLRestServer.BeginCurrentThread from multi-thread server

    // handlers - e.g. TSQLite3HttpServer or TSQLRestServerNamedPipeResponse

    RunningThread: TThread;

  end;



  /// possible service provider method options, e.g. about logging or execution

  // - see TServiceMethodOptions for a description of each available option

  TServiceMethodOption = (

    optExecLockedPerInterface,

    optExecInPerInterfaceThread, optFreeInPerInterfaceThread,

    {$ifndef LVCL}

    optExecInMainThread, optFreeInMainThread,

    optVariantCopiedByReference, optInterceptInputOutput,

    {$endif}

    optNoLogInput, optNoLogOutput, optErrorOnMissingParam

  );



  /// set of per-method execution options for an interface-based service provider

  // - by default, mehthod executions are concurrent, for better server

  // responsiveness; if you set optExecLockedPerInterface, all methods of

  // a given interface will be executed with a critical section

  // - optExecInMainThread will force the method to be called within

  // a RunningThread.Synchronize() call - it can be used e.g. if your

  // implementation rely heavily on COM servers - by default, service methods

  // are called within the thread which received them, on multi-thread server

  // instances (e.g. TSQLite3HttpServer or TSQLRestServerNamedPipeResponse),

  // for better response time and CPU use (this is the technical reason why

  // service implementation methods have to handle multi-threading safety

  // carefully, e.g. by using TRTLCriticalSection mutex on purpose)

  // - optFreeInMainThread will force the _Release/Destroy method to be run

  // in the main thread: setting this option for any method will affect the

  // whole service class - is not set by default, for performance reasons

  // - optExecInPerInterfaceThread and optFreeInPerInterfaceThread will allow

  // creation of a per-interface dedicated thread

  // - if optInterceptInputOutput is set, TServiceFactoryServer.AddInterceptor()

  // events would have their Sender.Input/Output values defined

  // - if optNoLogInput/optNoLogOutput is set, TSynLog and ServiceLog() database

  // won't log any parameter values at input/output - this may be useful for

  // regulatory/safety purposes, e.g. to ensure that no sensitive information

  // (like a credit card number or a password), is logged during process

  // - when parameters are transmitted as JSON object, any missing parameter

  // would be replaced by their default value, unless optErrorOnMissingParam

  // is defined to reject the call

  TServiceMethodOptions = set of TServiceMethodOption;



  /// internal per-method list of execution context as hold in TServiceFactory

  TServiceFactoryExecution = record

    /// the list of denied TSQLAuthGroup ID(s)

    // - used on server side within TSQLRestServerURIContext.ExecuteSOAByInterface

    // - bit 0 for client TSQLAuthGroup.ID=1 and so on...

    // - is therefore able to store IDs up to 256

    // - void by default, i.e. no denial = all groups allowed for this method

    Denied: set of 0..255;

    /// execution options for this method (about thread safety or logging)

    Options: TServiceMethodOptions;

    /// where execution information should be written as TSQLRecordServiceLog

    LogRest: TSQLRest;

    /// the TSQLRecordServiceLog class to use, as defined in LogRest.Model

    LogClassModelIndex: integer;

    /// curent BATCH instance used to write on LogRest

    // - points to a TServiceFactoryServer.fLogRestBatch[] instance

    LogRestBatch: TSQLRestBatchLocked;

  end;

  /// points to the execution context of one method within TServiceFactory

  PServiceFactoryExecution = ^TServiceFactoryExecution;



  /// all commands which may be executed by TSQLRestServer.URI() method

  // - execSOAByMethod for method-based services

  // - execSOAByInterface for interface-based services

  // - execORMGet for ORM reads i.e. Retrieve*() methods

  // - execORMWrite for ORM writes i.e. Add Update Delete TransactionBegin

  // Commit Rollback methods

  TSQLRestServerURIContextCommand = (

    execNone, execSOAByMethod, execSOAByInterface, execORMGet, execORMWrite);



  /// class used to define the Client-Server expected routing

  // - most of the internal methods are declared as virtual, so it allows any

  // kind of custom routing or execution scheme

  // - TSQLRestRoutingREST and TSQLRestRoutingJSON_RPC classes

  // are provided in this unit, to allow RESTful and JSON/RPC protocols

  TSQLRestServerURIContextClass = class of TSQLRestServerURIContext;



  /// a set of potential actions to be executed from the server

  // - reSQL will indicate the right to execute any POST SQL statement (not only

  // SELECT statements)

  // - reSQLSelectWithoutTable will allow executing a SELECT statement with

  // arbitrary content via GET/LOCK (simple SELECT .. FROM aTable will be checked

  // against TSQLAccessRights.GET[] per-table right

  // - reService will indicate the right to execute the interface-based JSON-RPC

  // service implementation

  // - reUrlEncodedSQL will indicate the right to execute a SQL query encoded

  // at the URI level, for a GET (to be used e.g. with XMLHTTPRequest, which

  // forced SentData='' by definition), encoded as sql=.... inline parameter

  // - reUrlEncodedDelete will indicate the right to delete items using a

  // WHERE clause for DELETE verb at /root/TableName?WhereClause

  // - reOneSessionPerUser will force that only one session may be created

  // for one user, even if connection comes from the same IP: in this case,

  // you may have to set the SessionTimeOut to a small value, in case the

  // session is not closed gracefully

  // - by default, read/write access to the TSQLAuthUser table is disallowed,

  // for obvious security reasons: but you can define reUserCanChangeOwnPassword

  // so that the current logged user would be able to change its own password

  // - order of this set does matter, since it will be stored as a byte value

  // e.g. by TSQLAccessRights.ToString: ensure that new items would always be

  // appended to the list, not inserted within

  TSQLAllowRemoteExecute = set of (

    reSQL, reService, reUrlEncodedSQL, reUrlEncodedDelete, reOneSessionPerUser,

    reSQLSelectWithoutTable, reUserCanChangeOwnPassword);



  /// set the User Access Rights, for each Table

  // - one property for every and each URI method (GET/POST/PUT/DELETE)

  // - one bit for every and each Table in Model.Tables[]

  {$ifndef ISDELPHI2010}

  TSQLAccessRights = object

  {$else}

  TSQLAccessRights = record

  {$endif}

    /// set of allowed actions on the server side

    AllowRemoteExecute: TSQLAllowRemoteExecute;

    /// GET method (retrieve record) table access bits

    // - note that a GET request with a SQL statement without a table (i.e.

    // on 'ModelRoot' URI with a SQL statement as SentData, as used in

    // TSQLRestClientURI.UpdateFromServer) will be checked for simple cases

    // (i.e. the first table in the FROM clause), otherwise will follow , whatever the bits

    // here are: since TSQLRestClientURI.UpdateFromServer() is called only

    // for refreshing a direct statement, it will be OK; you can improve this

    // by overriding the TSQLRestServer.URI() method

    // - if the REST request is LOCK, the PUT access bits will be read instead

    // of the GET bits value

    GET: TSQLFieldTables;

    /// POST method (create record) table access bits

    POST: TSQLFieldTables;

    /// PUT method (update record) table access bits

    // - if the REST request is LOCK, the PUT access bits will be read instead

    // of the GET bits value

    PUT: TSQLFieldTables;

    /// DELETE method (delete record) table access bits

    DELETE: TSQLFieldTables;

    /// wrapper method which can be used to set the CRUD abilities over a table

    // - C=Create, R=Read, U=Update, D=Delete rights

    procedure Edit(aTableIndex: integer; C, R, U, D: Boolean); overload;

    /// wrapper method which can be used to set the CRUD abilities over a table

    // - use TSQLOccasion set as parameter

    procedure Edit(aTableIndex: integer; aRights: TSQLOccasions); overload;

    /// wrapper method which can be used to set the CRUD abilities over a table

    // - will raise an EModelException if the supplied table is incorrect

    // - C=Create, R=Read, U=Update, D=Delete rights

    procedure Edit(aModel: TSQLModel; aTable: TSQLRecordClass; C, R, U, D: Boolean); overload;

    /// wrapper method which can be used to set the CRUD abilities over a table

    // - will raise an EModelException if the supplied table is incorrect

    // - use TSQLOccasion set as parameter

    procedure Edit(aModel: TSQLModel; aTable: TSQLRecordClass; aRights: TSQLOccasions); overload;

    /// serialize the content as TEXT

    // - use the TSQLAuthGroup.AccessRights CSV format

    function ToString: RawUTF8;

    /// unserialize the content from TEXT

    // - use the TSQLAuthGroup.AccessRights CSV format

    procedure FromString(P: PUTF8Char);

    /// validate mPost/mPut/mDelete action against those access rights

    // - used by TSQLRestServerURIContext.ExecuteORMWrite and

    // TSQLRestServer.EngineBatchSend methods for proper security checks

    function CanExecuteORMWrite(Method: TSQLURIMethod;

      Table: TSQLRecordClass; TableIndex: integer; const TableID: TID;

      Context: TSQLRestServerURIContext): boolean;

  end;



  /// used by TSQLRestServerURIContext.ClientKind to identify the

  // currently connected client

  TSQLRestServerURIContextClientKind = (ckUnknown, ckFramework, ckAJAX);



  /// abstract calling context for a TSQLRestServerCallBack event handler

  // - having a dedicated class avoid changing the implementation methods

  // signature if the framework add some parameters or behavior to it

  // - see TSQLRestServerCallBack for general code use

  // - most of the internal methods are declared as virtual, so it allows any

  // kind of custom routing or execution scheme

  // - instantiated by the TSQLRestServer.URI() method using its ServicesRouting

  // property

  // - see TSQLRestRoutingREST and TSQLRestRoutingJSON_RPC

  // for overridden methods - NEVER set this abstract TSQLRestServerURIContext

  // class on TSQLRest.ServicesRouting property !

  TSQLRestServerURIContext = class

  protected

    fInput: TRawUTF8DynArray; // even items are parameter names, odd are values

    fInputPostContentType: RawUTF8;

    fInputCookiesRetrieved: boolean;

    fInputCookies: TRawUTF8DynArray; // only computed if InCookie[] is used

    fInputCookieLastName: RawUTF8;

    fInputCookieLastValue: RawUTF8;

    fOutSetCookie: RawUTF8;

    fUserAgent: RawUTF8;

    fAuthSession: TAuthSession;

    fServiceListInterfaceMethodIndex: integer;

    fClientKind: TSQLRestServerURIContextClientKind;

    // just a wrapper over @ServiceContext threadvar

    fThreadServer: PServiceRunningContext;

    fSessionAccessRights: TSQLAccessRights; // session may be deleted meanwhile

    {$ifndef NOVARIANTS}

    function GetInput(const ParamName: RawUTF8): variant;

    function GetInputOrVoid(const ParamName: RawUTF8): variant;

    function GetInputAsTDocVariant: variant;

    {$endif}

    function GetInputNameIndex(const ParamName: RawUTF8): integer;

    function GetInputExists(const ParamName: RawUTF8): Boolean;

    function GetInputInt(const ParamName: RawUTF8): Int64;

    function GetInputDouble(const ParamName: RawUTF8): Double;

    function GetInputUTF8(const ParamName: RawUTF8): RawUTF8;

    function GetInputString(const ParamName: RawUTF8): string;

    function GetInputIntOrVoid(const ParamName: RawUTF8): Int64;

    function GetInputHexaOrVoid(const ParamName: RawUTF8): cardinal;

    function GetInputDoubleOrVoid(const ParamName: RawUTF8): Double;

    function GetInputUTF8OrVoid(const ParamName: RawUTF8): RawUTF8;

    function GetInputStringOrVoid(const ParamName: RawUTF8): string;

    function GetInHeader(const HeaderName: RawUTF8): RawUTF8;

    function GetInCookie(CookieName: RawUTF8): RawUTF8;

    procedure SetInCookie(CookieName, CookieValue: RawUTF8);

    function GetUserAgent: RawUTF8;

    function GetResourceFileName: TFileName;

    procedure SetOutSetCookie(aOutSetCookie: RawUTF8);

    procedure ServiceResultStart(WR: TTextWriter); virtual;

    procedure ServiceResultEnd(WR: TTextWriter; ID: TID); virtual;

    procedure InternalSetTableFromTableIndex(Index: integer); virtual;

    procedure InternalSetTableFromTableName(TableName: PUTF8Char); virtual;

    procedure InternalExecuteSOAByInterface; virtual;

    procedure StatsFromContext(Stats: TSynMonitorInputOutput;

      var Diff: Int64; DiffIsMicroSecs: boolean);

    /// event raised by ExecuteMethod() for interface parameters

    // - match TServiceMethodInternalExecuteCallback signature

    procedure ExecuteCallback(var Par: PUTF8Char; ParamInterfaceInfo: PTypeInfo;

      out Obj);

    /// initialize the execution context

    // - this method has been declared as protected, since it shuold never be

    // called outside the TSQLRestServer.URI() method workflow

    // - should set Call,  and Method members

    constructor Create(aServer: TSQLRestServer; const aCall: TSQLRestURIParams); virtual;

    /// retrieve RESTful URI routing

    // - should set URI, Table,TableIndex,TableRecordProps,TableEngine,

    // ID, URIBlobFieldName and Parameters members

    // - all Table* members will be set via a InternalSetTableFromTableName() call

    // - default implementation expects an URI encoded with

    // 'ModelRoot[/TableName[/TableID][/BlobFieldName]][?param=...]' format

    // - will also set URISessionSignaturePos and URIWithoutSignature members

    // - return FALSE in case of incorrect URI (e.g. does not match Model.Root)

    function URIDecodeREST: boolean; virtual;

    /// retrieve method-based SOA URI routing with optional RESTful mode

    // - should set MethodIndex member

    // - default RESTful implementation expects an URI encoded with

    // 'ModelRoot/MethodName' or 'ModelRoot/TableName[/TableID]/MethodName' formats

    procedure URIDecodeSOAByMethod; virtual;

    /// retrieve interface-based SOA

    // - should set Service member (and possibly ServiceMethodIndex)

    // - abstract implementation which is to be overridden

    procedure URIDecodeSOAByInterface; virtual; abstract;

    /// process authentication

    // - return FALSE in case of invalid signature, TRUE if authenticated

    function Authenticate: boolean; virtual;

    /// method called in case of authentication failure

    // - the failure origin is stated by the Reason parameter

    // - this default implementation will just set OutStatus := HTML_FORBIDDEN

    // and call TSQLRestServer.OnAuthenticationFailed event (if any)

    procedure AuthenticationFailed(Reason: TNotifyAuthenticationFailedReason); virtual;

    /// direct launch of a method-based service

    // - URI() will ensure that MethodIndex>=0 before calling it

    procedure ExecuteSOAByMethod; virtual;

    /// direct launch of an interface-based service

    // - URI() will ensure that Service<>nil before calling it

    // - abstract implementation which is to be overridden

    procedure ExecuteSOAByInterface; virtual; abstract;

    /// handle GET/LOCK/UNLOCK/STATE verbs for ORM/CRUD process

    procedure ExecuteORMGet; virtual;

    /// handle POST/PUT/DELETE/BEGIN/END/ABORT verbs for ORM/CRUD process

    // - execution of this method is protected by a critical section

    procedure ExecuteORMWrite; virtual;

    /// launch the Execute* method  in the execution mode

    // set by Server.AcquireExecutionMode/AcquireExecutionLockedTimeOut

    // - this is the main process point from TSQLRestServer.URI()

    procedure ExecuteCommand;

  public

    /// the associated TSQLRestServer instance which executes its URI method

    Server: TSQLRestServer;

    /// the used Client-Server method (matching the corresponding HTTP Verb)

    // - this property will be set from incoming URI, even if RESTful

    // authentication is not enabled

    Method: TSQLURIMethod;

    /// the URI address, excluding ?par1=.... parameters

    // - can be either the table name (in RESTful protocol), or a service name

    URI: RawUTF8;

    /// same as URI, but without the &session_signature=... ending

    URIWithoutSignature: RawUTF8;

    /// the optional Blob field name as specified in URI

    // - e.g. retrieved from "ModelRoot/TableName/TableID/BlobFieldName"

    URIBlobFieldName: RawUTF8;

    /// position of the &session_signature=... text in Call^.url string

    URISessionSignaturePos: integer;

    /// the Table as specified at the URI level (if any)

    Table: TSQLRecordClass;

    /// the index in the Model of the Table specified at the URI level (if any)

    TableIndex: integer;

    /// the RTTI properties of the Table specified at the URI level (if any)

    TableRecordProps: TSQLModelRecordProperties;

    /// the RESTful instance implementing the Table specified at the URI level (if any)

    // - equals TSQLRestServer most of the time, but may be an TSQLRestStorage

    // for any in-memory/MongoDB/virtual instance

    TableEngine: TSQLRest;

    /// the associated TSQLRecord.ID, as decoded from URI scheme

    // - this property will be set from incoming URI, even if RESTful

    // authentication is not enabled

    TableID: TID;

    /// the current execution command

    Command: TSQLRestServerURIContextCommand;

    /// the index of the callback published method within the internal class list

    MethodIndex: integer;

    /// the service identified by an interface-based URI

    Service: TServiceFactoryServer;

    /// the method index for an interface-based service

    // - Service member has already be retrieved from URI (so is not nil)

    // - 0..2 are the internal _free_/_contract_/_signature_ pseudo-methods

    ServiceMethodIndex: integer;

    /// the JSON array of parameters for an the interface-based service

    // - Service member has already be retrieved from URI (so is not nil)

    ServiceParameters: PUTF8Char;

    /// the instance ID for interface-based services instance

    // - can be e.g. the client session ID for sicPerSession or the thread ID for

    // sicPerThread

    ServiceInstanceID: PtrUInt;

    /// the current execution context of an interface-based service

    // - maps to Service.fExecution[ServiceMethodIndex]

    ServiceExecution: PServiceFactoryExecution;

    /// force the interface-based service methods to return a JSON object

    // - default behavior is to follow Service.ResultAsJSONObject property value

    // (which own default is to return a more convenient JSON array)

    // - if set to TRUE, this execution context will FORCE the method to return

    // a JSON object, even if Service.ResultAsJSONObject=false: this may be

    // handy when the method is executed from a JavaScript content

    ForceServiceResultAsJSONObject: boolean;

    /// force the interface-based service methods to return a plain JSON object

    // - i.e. '{....}' instead of '{"result":{....}}'

    // - only set if ForceServiceResultAsJSONObject=TRUE and if no ID is about

    // to be returned

    // - could be used e.g. for stateless interaction with a (non mORMot)

    // stateless JSON REST Server 

    ForceServiceResultAsJSONObjectWithoutResult: boolean;

    /// force the interface-based service methods to return a XML object

    // - default behavior is to follow Service.ResultAsJSONObject property value

    // (which own default is to return a more convenient JSON array)

    // - if set to TRUE, this execution context will FORCE the method to return

    // a XML object, by setting ForceServiceResultAsJSONObject then converting

    // the resulting JSON object into the corresponding XML via JSONBufferToXML()

    // - TSQLRestServerURIContext.InternalExecuteSOAByInterface will inspect the

    // Accept HTTP header to check if the answer should be XML rather than JSON

    ForceServiceResultAsXMLObject: boolean;

    /// specify a custom name space content when returning a XML object

    // - default behavior is to follow Service.ResultAsXMLObjectNameSpace

    // property (which is void by default)

    // - service may set e.g. XMLUTF8_NAMESPACE, which will append <content ...>

    // </content> around the generated XML data, to avoid validation problems

    // or set a particular XML name space, depending on the application

    ForceServiceResultAsXMLObjectNameSpace: RawUTF8;

    /// URI inlined parameters

    // - use UrlDecodeValue*() functions to retrieve the values

    // - for mPOST requests, would also be filled for following content types:

    // ! application/x-www-form-urlencoded or multipart/form-data

    Parameters: PUTF8Char;

    /// URI inlined parameters position in Call^.url string

    // - use Parameters field to retrieve the values

    ParametersPos: integer;

    /// access to all input/output parameters at TSQLRestServer.URI() level

    // - process should better call Results() or Success() methods to set the

    // appropriate answer or Error() method in case of an error

    // - low-level access to the call parameters can be made via this pointer

    Call: PSQLRestURIParams;

    /// the corresponding session TAuthSession.IDCardinal value

    // - equals 0 (CONST_AUTHENTICATION_SESSION_NOT_STARTED) if the session

    // is not started yet - i.e. if still in handshaking phase

    // - equals 1 (CONST_AUTHENTICATION_NOT_USED) if authentication mode

    // is not enabled - i.e. if TSQLRestServer.HandleAuthentication = FALSE

    Session: cardinal;

    /// the corresponding TAuthSession.User.GroupRights.ID value

    // - is undefined if Session is 0 or 1 (no authentication running)

    SessionGroup: integer;

    /// the corresponding TAuthSession.User.ID value

    // - is undefined if Session is 0 or 1 (no authentication running)

    SessionUser: TID;

    /// the corresponding TAuthSession.User.LogonName value

    // - is undefined if Session is 0 or 1 (no authentication running)

    SessionUserName: RawUTF8;

    /// the remote IP from which the TAuthSession was created, if any

    // - is undefined if Session is 0 or 1 (no authentication running)

    SessionRemoteIP: RawUTF8;

    /// the static instance corresponding to the associated Table (if any)

    {$ifdef FPC}&Static{$else}Static{$endif}: TSQLRest;

    /// the kind of static instance corresponding to the associated Table (if any)

    StaticKind: TSQLRestServerKind;

    /// optional error message which will be transmitted as JSON error (if set)

    CustomErrorMsg: RawUTF8;

    /// high-resolution timimg of the execution command, in micro-seconds

    // - only set when TSQLRestServer.URI finished

    MicroSecondsElapsed: QWord;

    {$ifdef WITHLOG}

    /// associated logging instance for the current thread on the server

    // - you can use it to log some process on the server side

    Log: TSynLog;

    {$endif}

    /// finalize the execution context

    destructor Destroy; override;

    /// extract the input parameters from its URI

    // - you should not have to call this method directly, but rather

    // all the InputInt/InputDouble/InputUTF8/InputExists/... properties

    // - may be useful if you want to access directly to InputPairs[] with no

    // prior knowledge of the input parameter names

    // - you can specify a title text to optionally log the input array

    procedure FillInput(const LogInputIdent: RawUTF8='');

    /// retrieve one input parameter from its URI name as Int64

    // - raise an EParsingException if the parameter is not found

    property InputInt[const ParamName: RawUTF8]: Int64 read GetInputInt;

    /// retrieve one input parameter from its URI name as double

    // - raise an EParsingException if the parameter is not found

    property InputDouble[const ParamName: RawUTF8]: double read GetInputDouble;

    /// retrieve one input parameter from its URI name as RawUTF8

    // - raise an EParsingException if the parameter is not found

    property InputUTF8[const ParamName: RawUTF8]: RawUTF8 read GetInputUTF8;

    /// retrieve one input parameter from its URI name as a VCL string

    // - raise an EParsingException if the parameter is not found

    // - prior to Delphi 2009, some Unicode characters may be missing in the

    // returned AnsiString value

    property InputString[const ParamName: RawUTF8]: string read GetInputString;

    /// retrieve one input parameter from its URI name as Int64

    // - returns 0 if the parameter is not found

    property InputIntOrVoid[const ParamName: RawUTF8]: Int64 read GetInputIntOrVoid;

    /// retrieve one hexadecimal input parameter from its URI name as cardinal

    // - returns 0 if the parameter is not found

    property InputHexaOrVoid[const ParamName: RawUTF8]: cardinal read GetInputHexaOrVoid;

    /// retrieve one input parameter from its URI name as double

    // - returns 0 if the parameter is not found

    property InputDoubleOrVoid[const ParamName: RawUTF8]: double read GetInputDoubleOrVoid;

    /// retrieve one input parameter from its URI name as RawUTF8

    // - returns '' if the parameter is not found

    property InputUTF8OrVoid[const ParamName: RawUTF8]: RawUTF8 read GetInputUTF8OrVoid;

    /// retrieve one input parameter from its URI name as a VCL string

    // - returns '' if the parameter is not found

    // - prior to Delphi 2009, some Unicode characters may be missing in the

    // returned AnsiString value

    property InputStringOrVoid[const ParamName: RawUTF8]: string read GetInputStringOrVoid;

    /// retrieve one input parameter from its URI name as RawUTF8

    // - returns FALSE and call Error(ErrorMessageForMissingParameter) - which

    // may be a resourcestring - if the parameter is not found

    // - returns TRUE and set Value if the parameter is found

    function InputUTF8OrError(const ParamName: RawUTF8; out Value: RawUTF8;

      const ErrorMessageForMissingParameter: string): boolean;

    /// retrieve one input parameter from its URI name as RawUTF8

    // - returns supplied DefaultValue if the parameter is not found

    function InputUTF8OrDefault(const ParamName, DefaultValue: RawUTF8): RawUTF8;

    /// retrieve one input parameter from its URI name as an enumeration

    // - will expect the value to be specified as integer, or as the textual

    // representation of the enumerate, ignoring any optional lowercase prefix

    // as featured by TEnumType.GetEnumNameValue()

    // - returns TRUE and set ValueEnum if the parameter is found and correct

    // - returns FALSE and set ValueEnum to first item (i.e. DefaultEnumOrd) if

    // the parameter is not found, or not containing a correct value

    function InputEnum(const ParamName: RawUTF8; EnumType: PTypeInfo;

      out ValueEnum; DefaultEnumOrd: integer=0): boolean;

    /// return TRUE if the input parameter is available at URI

    // - even if InputUTF8['param']='', there may be '..?param=&another=2'

    property InputExists[const ParamName: RawUTF8]: Boolean read GetInputExists;

    {$ifndef NOVARIANTS}

    /// retrieve one input parameter from its URI name as variant

    // - if the parameter value is text, it is stored in the variant as

    // a generic VCL string content: so before Delphi 2009, you may loose

    // some characters at decoding from UTF-8 input buffer

    // - raise an EParsingException if the parameter is not found

    property Input[const ParamName: RawUTF8]: variant read GetInput; default;

    /// retrieve one input parameter from its URI name as variant

    // - if the parameter value is text, it is stored in the variant as

    // a RawUTF8: so before Delphi 2009, you won't loose any Unicode character,

    // but you should convert its value to AnsiString using UTF8ToString()

    // - returns Unassigned if the parameter is not found

    property InputOrVoid[const ParamName: RawUTF8]: variant read GetInputOrVoid;

    /// retrieve one input parameter from its URI name as variant

    // - returns FALSE and call Error(ErrorMessageForMissingParameter) - which

    // may be a resourcestring - if the parameter is not found

    // - returns TRUE and set Value if the parameter is found

    // - if the parameter value is text, it is stored in the variant as

    // a RawUTF8: so before Delphi 2009, you won't loose any Unicode character,

    // but you should convert its value to AnsiString using UTF8ToString()

    function InputOrError(const ParamName: RawUTF8; out Value: variant;

      const ErrorMessageForMissingParameter: string): boolean;

    /// retrieve all input parameters from URI as a variant JSON object

    // - returns Unassigned if no parameter was defined

    // - returns a JSON object with input parameters encoded as

    // ! {"name1":value1,"name2":value2...}

    // - if the parameters were encoded as multipart, the JSON object

    // will be encoded with its textual values, or with nested objects, if

    // the data was supplied as binary:

    // ! {"name1":{"data":..,"filename":...,"contenttype":...},"name2":...}

    // since name1.data would be Base64 encoded, so you should better

    // use the InputAsMultiPart() method instead when working with binary

    property InputAsTDocVariant: variant read GetInputAsTDocVariant;

    {$endif}

    /// decode any multipart/form-data POST request input

    // - returns TRUE and set MultiPart array as expected, on success

    function InputAsMultiPart(var MultiPart: TMultiPartDynArray): Boolean;

    /// low-level access to the input parameters, stored as pairs of UTF-8

    // - even items are parameter names, odd are values

    // - Input*[] properties should have been called previously to fill the

    // internal array, or by calling FillInput if you do not know the input

    // parameters which may appear

    property InputPairs: TRawUTF8DynArray read FInput;

    /// retrieve an incoming HTTP header

    // - the supplied header name is case-insensitive

    // - you could call e.g. InHeader['remoteip'] to retrieve the caller IP

    property InHeader[const HeaderName: RawUTF8]: RawUTF8 read GetInHeader;

    /// retrieve an incoming HTTP cookie value

    // - the supplied cookie name is case-insensitive

    property InCookie[CookieName: RawUTF8]: RawUTF8 read GetInCookie write SetInCookie;

    /// define a new 'name=value' cookie to be returned to the client

    // - if not void, TSQLRestServer.URI() will define a new 'set-cookie: ...'

    // header in Call^.OutHead

    // - you can use COOKIE_EXPIRED as value to delete a cookie in the browser

    // - if no Path=/.. is included, it will append '; Path=/'+Server.Model.Root

    property OutSetCookie: RawUTF8 read fOutSetCookie write SetOutSetCookie;

    /// retrieve the "User-Agent" value from the incoming HTTP headers

    property UserAgent: RawUTF8 read GetUserAgent;

    /// identify which kind of client is actually connected

    // - the "User-Agent" HTTP will be checked for 'mORMot' substring, and

    // set ckFramework on match

    // - either ckAjax for a classic (AJAX) browser, or any other kind of

    // HTTP client

    // - will be used e.g. by ClientSQLRecordOptions to check if the

    // current remote client expects standard JSON in all cases

    function ClientKind: TSQLRestServerURIContextClientKind;

    /// identify if the request is about a Table containing nested objects or

    // arrays, which could be serialized as JSON objects or arrays, instead

    // of plain JSON string (as stored in the database)

    // - will idenfity ClientKind=ckAjax, or check for rsoGetAsJsonNotAsString

    // in TSQLRestServer.Options

    function ClientSQLRecordOptions: TJSONSerializerSQLRecordOptions;

    /// true if called from TSQLRestServer.AdministrationExecute

    function IsRemoteAdministrationExecute: boolean;

    /// compute the file name corresponding to the URI

    // - e.g. '/root/methodname/toto/index.html' will return 'toto\index.html'

    property ResourceFileName: TFileName read GetResourceFileName;

    /// use this method to send back directly a result value to the caller

    // - expects Status to be either HTML_SUCCESS, HTML_NOTMODIFIED,

    // HTML_CREATED, or HTML_TEMPORARYREDIRECT, and will return as answer the

    // supplied Result content with no transformation

    // - if Status is an error code, it will call Error() method

    // - CustomHeader optional parameter can be set e.g. to

    // TEXT_CONTENT_TYPE_HEADER if the default JSON_CONTENT_TYPE is not OK,

    // or calling GetMimeContentTypeHeader() on the returned binary buffer

    // - if Handle304NotModified is TRUE and Status is HTML_SUCCESS, the Result

    // content will be hashed (using crc32c) and in case of no modification

    // will return HTML_NOTMODIFIED to the browser, without the actual result

    // content (to save bandwidth)

    procedure Returns(const Result: RawUTF8; Status: integer=HTML_SUCCESS;

      const CustomHeader: RawUTF8=''; Handle304NotModified: boolean=false;

      HandleErrorAsRegularResult: boolean=false); overload;

    /// use this method to send back a JSON object to the caller

    // - this method will encode the supplied values e.g. as

    // ! JSONEncode(['name','John','year',1972]) = '{"name":"John","year":1972}'

    // - implementation is just a wrapper around Returns(JSONEncode([]))

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

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

    // - expects Status to be either HTML_SUCCESS or HTML_CREATED

    // - caller can set Handle304NotModified=TRUE for Status=HTML_SUCCESS

    procedure Returns(const NameValuePairs: array of const; Status: integer=HTML_SUCCESS;

      Handle304NotModified: boolean=false; HandleErrorAsRegularResult: boolean=false); overload;

    /// use this method to send back any object as JSON document to the caller

    // - this method will call ObjectToJson() to compute the returned content

    // - you can customize SQLRecordOptions, to force the returned JSON

    // object to have its TSQLRecord nested fields serialized as true JSON

    // arrays or objects, or add an "ID_str" string field for JavaScript

    procedure Returns(Value: TObject; Status: integer=HTML_SUCCESS;

      Handle304NotModified: boolean=false;

      SQLRecordOptions: TJSONSerializerSQLRecordOptions=[]); overload;

    /// use this method to send back any variant as JSON to the caller

    // - this method will call VariantSaveJSON() to compute the returned content

    procedure ReturnsJson(const Value: variant; Status: integer=HTML_SUCCESS;

      Handle304NotModified: boolean=false; Escape: TTextWriterKind=twJSONEscape;

      MakeHumanReadable: boolean=false);

    /// uses this method to send back directly any binary content to the caller

    // - the exact MIME type will be retrieved using GetMimeContentTypeHeader(),

    // from the supplied Blob binary buffer, and optional a file name

    // - by default, the HTML_NOTMODIFIED process will take place, to minimize

    // bandwidth between the server and the client

    procedure ReturnBlob(const Blob: RawByteString; Status: integer=HTML_SUCCESS;

      Handle304NotModified: boolean=true; const FileName: TFileName='');

    /// use this method to send back a file to the caller

    // - this method will let the HTTP server return the file content

    // - if Handle304NotModified is TRUE, will check the file age to ensure

    // that the file content will be sent back to the server only if it changed

    // - if ContentType is left to default '', method will guess the expected

    // mime-type from the file name extension

    // - if the file name does not exist, a generic 404 error page would be

    // returned, unless an explicit redirection is defined in Error404Redirect

    // - you can also specify the resulting file name, as downloaded and written

    // by the client browser, in the optional AttachmentFileName parameter, if

    // the URI does not match the expected file name

    procedure ReturnFile(const FileName: TFileName;

      Handle304NotModified: boolean=false; const ContentType: RawUTF8='';

      const AttachmentFileName: RawUTF8=''; const Error404Redirect: RawUTF8='');

    /// use this method to send back a file from a local folder to the caller

    // - URIBlobFieldName value, as parsed from the URI, would containn the

    // expected file name in the local folder, using DefaultFileName if the

    // URI is void, and redirecting to Error404Redirect if the file is not found

    // - this method will let the HTTP server return the file content

    // - if Handle304NotModified is TRUE, will check the file age to ensure

    // that the file content will be sent back to the server only if it changed

    procedure ReturnFileFromFolder(const FolderName: TFileName;

      Handle304NotModified: boolean=true; const DefaultFileName: TFileName='index.html';

      const Error404Redirect: RawUTF8='');

    /// use this method notify the caller that the resource URI has changed

    // - returns a HTML_TEMPORARYREDIRECT status with the specified location,

    // or HTML_MOVEDPERMANENTLY if PermanentChange is TRUE

    procedure Redirect(const NewLocation: RawUTF8; PermanentChange: boolean=false);

    /// use this method to send back a JSON object with a "result" field

    // - this method will encode the supplied values as a {"result":"...}

    // JSON object, as such for one value:

    // $ {"result":"OneValue"}

    // (with one value, you can just call TSQLRestClientURI.CallBackGetResult

    // method to call and decode this value)

    // or as a JSON object containing an array of values:

    // $ {"result":["One","two"]}

    // - expects Status to be either HTML_SUCCESS or HTML_CREATED

    // - caller can set Handle304NotModified=TRUE for Status=HTML_SUCCESS

    procedure Results(const Values: array of const; Status: integer=HTML_SUCCESS;

      Handle304NotModified: boolean=false);

    /// use this method if the caller expect no data, just a status

    // - just wrap the overloaded Returns() method with no result value

    // - if Status is an error code, it will call Error() method

    // - by default, calling this method will mark process as successfull

    procedure Success(Status: integer=HTML_SUCCESS); virtual;

    /// use this method to send back an error to the caller

    // - expects Status to not be HTML_SUCCESS neither HTML_CREATED,

    // and will send back a JSON error message to the caller, with the

    // supplied error text

    // - if no ErrorMessage is specified, will return a default text

    // corresponding to the Status code

    procedure Error(const ErrorMessage: RawUTF8='';

      Status: integer=HTML_BADREQUEST); overload; virtual;

    /// use this method to send back an error to the caller

    // - implementation is just a wrapper over Error(FormatUTF8(Format,Args))

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

      Status: integer=HTML_BADREQUEST); overload;

    /// use this method to send back an error to the caller

    // - will serialize the supplied exception, with an optional error message

    procedure Error(E: Exception; const Format: RawUTF8; const Args: array of const;

      Status: integer=HTML_BADREQUEST); overload;

    /// implements a method-based service for live update of some settings

    // - should be called from a method-based service, e.g. Configuration()

    // - the settings are expected to be stored e.g. in a TSynAutoCreateFields

    // instance, potentially with nested objects

    // - accept the following REST methods to read and write the settings:

    // ! GET http://server:888/root/configuration

    // ! GET http://server:888/root/configuration/propname

    // ! GET http://server:888/root/configuration/propname?value=propvalue

    // - could be used e.g. as such:

    // ! procedure TMyRestServerMethods.Configuration(Ctxt: TSQLRestServerURIContext);

    // ! begin //  http://server:888/myrestserver/configuration/name?value=newValue

    // !   Ctxt.ConfigurationRestMethod(fSettings);

    // ! end;

    procedure ConfigurationRestMethod(SettingsStorage: TObject);

    /// at Client Side, compute URI and BODY according to the routing scheme

    // - abstract implementation which is to be overridden

    // - as input, method should be the method name to be executed,

    // params should contain the incoming parameters as JSON CSV (without []),

    // and clientDriven ID should contain the optional Client ID value

    // - at output, should update the HTTP uri corresponding to the proper

    // routing, and should return the corresponding HTTP body within sent

    class procedure ClientSideInvoke(var uri: RawUTF8;

      const method, params, clientDrivenID: RawUTF8; out sent: RawUTF8); virtual; abstract;

  end;



  /// calling context for a TSQLRestServerCallBack using simple REST for

  // interface-based services

  // - this class will use RESTful routing for interface-based services:

  // method name will be identified within the URI, as

  // $ /Model/Interface.Method[/ClientDrivenID]

  // e.g. for ICalculator.Add:

  // $ POST /root/Calculator.Add

  // $ (...)

  // $ [1,2]

  // or, for a sicClientDriven mode service:

  // $ POST /root/ComplexNumber.Add/1234

  // $ (...)

  // $ [20,30]

  // in this case, the sent content will be a JSON array of [parameters...]

  // - as an alternative, input parameters may be encoded at URI level (with

  // a size limit depending on the HTTP routers, whereas there is no such

  // limitation when they are transmitted as message body)

  // - one benefit of having .../ClientDrivenID encoded at URI is that it will

  // be more secured in our RESTful authentication scheme: each method and even

  // client driven session will be signed individualy

  TSQLRestRoutingREST = class(TSQLRestServerURIContext)

  protected

    /// retrieve interface-based SOA with URI RESTful routing

    // - should set Service member (and possibly ServiceMethodIndex)

    // - this overridden implementation expects an URI encoded with

    // '/Model/Interface.Method[/ClientDrivenID]' for this class, and

    // will set ServiceMethodIndex for next ExecuteSOAByInterface method call

    procedure URIDecodeSOAByInterface; override;

    /// direct launch of an interface-based service with URI RESTful routing

    // - this overridden implementation expects parameters to be sent as one JSON

    // array body (Delphi/AJAX way) or optionally with URI decoding (HTML way):

    // ! function TServiceCalculator.Add(n1, n2: integer): integer;

    // would accept such requests:

    // !  URL='root/Calculator.Add' and InBody='[ 1,2 ]'

    // !  URL='root/Calculator.Add?+%5B+1%2C2+%5D' // decoded as ' [ 1,2 ]'

    // !  URL='root/Calculator.Add?n1=1&n2=2'      // in any order, even missing

    procedure ExecuteSOAByInterface; override;

  public

    /// at Client Side, compute URI and BODY according to RESTful routing scheme

    // - e.g. on input uri='root/Calculator', method='Add', params='1,2' and

    // clientDrivenID='1234' -> on output uri='root/Calculator.Add/1234' and

    // sent='[1,2]'

    class procedure ClientSideInvoke(var uri: RawUTF8;

      const method, params, clientDrivenID: RawUTF8; out sent: RawUTF8); override;

  end;



  /// calling context for a TSQLRestServerCallBack using JSON/RPC for

  // interface-based services

  // - in this routing scheme, the URI will define the interface, then the

  // method name will be inlined with parameters, e.g.

  // $ POST /root/Calculator

  // $ (...)

  // $ {"method":"Add","params":[1,2]}

  // or, for a sicClientDriven mode service:

  // $ POST /root/ComplexNumber

  // $ (...)

  // $ {"method":"Add","params":[20,30],"id":1234}

  TSQLRestRoutingJSON_RPC = class(TSQLRestServerURIContext)

  protected

    /// retrieve interface-based SOA with URI JSON/RPC routing

    // - this overridden implementation expects an URI encoded with

    // '/Model/Interface' as for the JSON/RPC routing scheme, and won't

    // set ServiceMethodIndex at this level (but in ExecuteSOAByInterface)

    procedure URIDecodeSOAByInterface; override;

    /// direct launch of an interface-based service with URI JSON/RPC routing

    // - URI() will ensure that Service<>nil before calling it

    // - this overridden implementation expects parameters to be sent as part

    // of a JSON object body:

    // $ {"method":"Add","params":[20,30],"id":1234}

    procedure ExecuteSOAByInterface; override;

  public

    /// at Client Side, compute URI and BODY according to JSON/RPC routing scheme

    // - e.g. on input uri='root/Calculator', method='Add', params='1,2' and

    // clientDrivenID='1234' -> on output uri='root/Calculator' and

    // sent={"method":"Add","params":[1,2],"id":1234}

    class procedure ClientSideInvoke(var uri: RawUTF8;

      const method, params, clientDrivenID: RawUTF8; out sent: RawUTF8); override;

  end;



  /// method prototype to be used on Server-Side for method-based services

  // - will be routed as ModelRoot/[TableName/TableID/]MethodName RESTful requests

  // - this mechanism is able to handle some custom Client/Server request, similar

  // to the DataSnap technology, but in a KISS way; it's fully integrated in the

  // Client/Server architecture of our framework

  // - just add a published method of this type to any TSQLRestServer descendant

  // - when TSQLRestServer.URI receive a request for ModelRoot/MethodName

  // or ModelRoot/TableName/TableID/MethodName, it will check for a published method

  // in its self instance named MethodName which MUST be of TSQLRestServerCallBack

  // type (not checked neither at compile time neither at runtime: beware!) and

  // call it to handle the request

  // - important warning: the method implementation MUST be thread-safe

  // - when TSQLRestServer.URI receive a request for ModelRoot/MethodName,

  // it calls the corresponding published method with aRecord set to nil

  // - when TSQLRestServer.URI receive a request for ModelRoot/TableName/TableID/MethodName,

  // it calls the corresponding published method with aRecord pointing to a

  // just created instance of the corresponding class,  with its field ID set;

  // note that the only set field is ID: other fields of aRecord are not set, but

  // must secificaly be retrieved on purpose

  // - for ModelRoot/TableName/TableID/MethodName, the just created instance will

  // be freed by TSQLRestServer.URI when the method returns

  // - Ctxt.Parameters values are set from incoming URI, and each parameter can be

  // retrieved with a loop like this:

  // !  if not UrlDecodeNeedParameters(Ctxt.Parameters,'SORT,COUNT') then

  // !    exit;

  // !  while Ctxt.Parameters<>nil do begin

  // !    UrlDecodeValue(Ctxt.Parameters,'SORT=',aSortString);

  // !    UrlDecodeValueInteger(Ctxt.Parameters,'COUNT=',aCountInteger,@Ctxt.Parameters);

  // !  end;

  // - Ctxt.Call is set with low-level incoming and outgoing data from client

  // (e.g. Ctxt.Call.InBody contain POST/PUT data message)

  // - Ctxt.Session* will identify to the authentication session of the remote client

  // (CONST_AUTHENTICATION_NOT_USED=1 if authentication mode is not enabled or

  // CONST_AUTHENTICATION_SESSION_NOT_STARTED=0 if the session not started yet) -

  // code may use SessionGetUser() method to retrieve the user details

  // - Ctxt.Method will indicate the used HTTP verb (e.g. GET/POST/PUT..)

  // - if process succeeded, implementation shall call Ctxt.Results([]) method to

  // set a JSON response object with one "result" field name or Ctxt.Returns([])

  // with a JSON object described in Name/Value pairs; if the returned value is

  // not JSON_CONTENT_TYPE, use Ctxt.Returns() and its optional CustomHeader

  // parameter can specify a custom header like TEXT_CONTENT_TYPE_HEADER

  // - if process succeeded, and no data is expected to be returned to the caller,

  // implementation shall call overloaded Ctxt.Success() method with the

  // expected status (i.e. just Ctxt.Success will return HTML_SUCCESS)

  // - if process failed, implementation shall call Ctxt.Error() method to

  // set the corresponding error message and error code number

  // - a typical implementation may be:

  // ! procedure TSQLRestServerTest.Sum(Ctxt: TSQLRestServerURIContext);

  // ! var a,b: TSynExtended;

  // ! begin

  // !   if UrlDecodeNeedParameters(Ctxt.Parameters,'A,B') then begin

  // !     while Ctxt.Parameters<>nil do begin

  // !       UrlDecodeExtended(Ctxt.Parameters,'A=',a);

  // !       UrlDecodeExtended(Ctxt.Parameters,'B=',b,@Ctxt.Parameters);

  // !     end;

  // !     Ctxt.Results([a+b]);

  // !     // same as: Ctxt.Returns(JSONEncode(['result',a+b]));

  // !     // same as: Ctxt.Returns(['result',a+b]);

  // !   end else

  // !     Ctxt.Error('Missing Parameter');

  // ! end;

  // - Client-Side can be implemented as you wish. By convention, it could be

  // appropriate to define in either TSQLRestServer (if to be called as

  // ModelRoot/MethodName), either TSQLRecord (if to be called as

  // ModelRoot/TableName[/TableID]/MethodName) a custom public or protected method,

  // calling TSQLRestClientURI.URL with the appropriate parameters, and named

  // (by convention) as MethodName; TSQLRestClientURI has dedicated methods

  // like CallBackGetResult, CallBackGet, CallBackPut and CallBack; see also

  // TSQLModel.getURICallBack and JSONDecode function

  // ! function TSQLRecordPeople.Sum(aClient: TSQLRestClientURI; a, b: double): double;

  // ! var err: integer;

  // ! begin

  // !   val(aClient.CallBackGetResult('sum',['a',a,'b',b]),result,err);

  // ! end;

  TSQLRestServerCallBack = procedure(Ctxt: TSQLRestServerURIContext) of object;



  /// description of a method-based service

  TSQLRestServerMethod = record

    /// the method name

    Name: RawUTF8;

    /// the event which will be executed for this method

    CallBack: TSQLRestServerCallBack;

    /// set to TRUE disable Authentication check for this method

    // - use TSQLRestServer.ServiceMethodByPassAuthentication() method

    ByPassAuthentication: boolean;

    /// detailed statistics associated with this method

    Stats: TSynMonitorInputOutput;

  end;



  /// used to store all method-based services of a TSQLRestServer instance

  TSQLRestServerMethods = array of TSQLRestServerMethod;



  /// pointer to a description of a method-based service

  PSQLRestServerMethod = ^TSQLRestServerMethod;



  /// the possible options for handling table names

  TSQLCheckTableName = (ctnNoCheck,ctnMustExist,ctnTrimExisting);



  /// the possible options for TSQLRestServer.CreateMissingTables and

  // TSQLRecord.InitializeTable methods

  // - itoNoAutoCreateGroups and itoNoAutoCreateUsers will avoid

  // TSQLAuthGroup.InitializeTable to fill the TSQLAuthGroup and TSQLAuthUser

  // tables with default records

  // - itoNoCreateMissingField will avoid to create the missing fields on a table

  // - itoNoIndex4ID won't create the index for the main ID field

  // - itoNoIndex4UniqueField won't create indexes for "stored AS_UNIQUE" fields

  // - itoNoIndex4NestedRecord won't create indexes for TSQLRecord fields

  // - itoNoIndex4RecordReference won't create indexes for TRecordReference fields

  // - itoNoIndex4TID won't create indexes for TID fields

  // - itoNoIndex4RecordVersion won't create indexes for TRecordVersion fields

  // - INITIALIZETABLE_NOINDEX constant contain all itoNoIndex* items

  TSQLInitializeTableOption = (

    itoNoAutoCreateGroups, itoNoAutoCreateUsers,

    itoNoCreateMissingField, 

    itoNoIndex4ID, itoNoIndex4UniqueField,

    itoNoIndex4NestedRecord, itoNoIndex4RecordReference,

    itoNoIndex4TID, itoNoIndex4RecordVersion);



  /// the options to be specified for TSQLRestServer.CreateMissingTables and

  // TSQLRecord.InitializeTable methods

  TSQLInitializeTableOptions = set of TSQLInitializeTableOption;



  /// a dynamic array of TSQLRecordMany instances

  TSQLRecordManyObjArray = array of TSQLRecordMany;



  /// internal data used by TSQLRecord.FillPrepare()/FillPrepareMany() methods

  // - using a dedicated class will reduce memory usage for each TSQLRecord

  // instance (which won't need these properties most of the time)

  TSQLRecordFill = class

  protected

    /// associated table

    fTable: TSQLTable;

    /// current retrieved row

    fFillCurrentRow: integer;

    /// number of used items in TableMap[] array

    // - calculated in FillPrepare() or FillPrepareMany() methods

    fTableMapCount: integer;

    /// set by TSQLRecord.FillPrepareMany() to release M.fDestID^ instances

    fTableMapRecordManyInstances: TSQLRecordManyObjArray;

    /// map the published fields index

    // - calculated in FillPrepare() or FillPrepareMany() methods

    fTableMap: array of record

      /// the class instance to be filled from the TSQLTable

      // - can be a TSQLRecordMany instance after FillPrepareMany() method call

      Dest: TSQLRecord;

      /// the published property RTTI to be filled from the TSQLTable

      // - is nil for the RowID/ID field

      DestField: TSQLPropInfo;

      /// the column index in TSQLTable

      TableIndex: integer;

    end;

    /// mark all mapped or TModTime fields

    fTableMapFields: TSQLFieldBits;

    /// if Joined instances were initialized via TSQLRecord.CreateJoined()

    fJoinedFields: boolean;

    /// return fJoinedFields or false if self=nil

    function GetJoinedFields: boolean;

      {$ifdef HASINLINE}inline;{$endif}

    /// add a property to the fTableMap[] array

    // - aIndex is the column index in TSQLTable

    procedure AddMap(aRecord: TSQLRecord; aField: TSQLPropInfo; aIndex: integer); overload;

    /// add a property to the fTableMap[] array

    // - aIndex is the column index in TSQLTable

    procedure AddMap(aRecord: TSQLRecord; const aFieldName: RawUTF8; aIndex: integer); overload;

    /// add all simple property names, with  to the fTableMap[] array

    // - will map ID/RowID, then all simple fields of this TSQLRecord

    // - aIndex is the column index in TSQLTable

    procedure AddMapSimpleFields(aRecord: TSQLRecord; const aProps: array of TSQLPropInfo;

      var aIndex: integer);

  public

    /// finalize the mapping

    destructor Destroy; override;

    /// map all columns of a TSQLTable to a record mapping

    procedure Map(aRecord: TSQLRecord; aTable: TSQLTable; aCheckTableName: TSQLCheckTableName);

    /// reset the mapping

    // - is called e.g. by TSQLRecord.FillClose

    // - will free any previous Table if necessary

    // - will release TSQLRecordMany.Dest instances as set by TSQLRecord.FillPrepareMany()

    procedure UnMap;

    /// fill a TSQLRecord published properties from a TSQLTable row

    // - use the mapping prepared with Map() method

    function Fill(aRow: integer): Boolean; overload;

      {$ifdef HASINLINE}inline;{$endif}

    /// fill a TSQLRecord published properties from a TSQLTable row

    // - use the mapping prepared with Map() method

    // - aTableRow will point to the first column of the matching row

    procedure Fill(aTableRow: PPUtf8CharArray); overload;

    /// fill a TSQLRecord published properties from a TSQLTable row

    // - overloaded method using a specified destination record to be filled

    // - won't work with cross-reference mapping (FillPrepareMany)

    // - use the mapping prepared with Map() method

    // - aTableRow will point to the first column of the matching row

    procedure Fill(aTableRow: PPUtf8CharArray; aDest: TSQLRecord); overload;

    /// fill a TSQLRecord published properties from a TSQLTable row

    // - overloaded method using a specified destination record to be filled

    // - won't work with cross-reference mapping (FillPrepareMany)

    // - use the mapping prepared with Map() method

    function Fill(aRow: integer; aDest: TSQLRecord): Boolean; overload;

      {$ifdef HASINLINE}inline;{$endif}

    /// used to compute the updated field bits during a fill

    // - will return Props.SimpleFieldsBits[soUpdate] if no fill is in process

    procedure ComputeSetUpdatedFieldBits(Props: TSQLRecordProperties; out Bits: TSQLFieldBits);

    /// return all mapped fields, or [] if nil

    function TableMapFields: TSQLFieldBits;

    /// the TSQLTable stated as FillPrepare() parameter

    // - the internal temporary table is stored here for TSQLRecordMany

    // - this instance is freed by TSQLRecord.Destroy if fTable.OwnerMustFree=true

    property Table: TSQLTable read fTable;

    /// the current Row during a Loop

    property FillCurrentRow: integer read fFillCurrentRow;

    /// equals TRUE if the instance was initialized via TSQLRecord.CreateJoined()

    // TSQLRecord.CreateAndFillPrepareJoined()

    // - it means that all nested TSQLRecord are pre-allocated instances,

    // not trans-typed pointer(IDs)

    property JoinedFields: boolean read GetJoinedFields;

  end;



  /// event signature triggered by TSQLRestBatch.OnWrite

  // - also used by TSQLRestServer.RecordVersionSynchronizeSlave*() methods

  TOnBatchWrite = procedure(Sender: TSQLRestBatch; Event: TSQLOccasion;

    Table: TSQLRecordClass; const ID: TID; Value: TSQLRecord;

    const ValueFields: TSQLFieldBits) of object;



  /// used to store a BATCH sequence of writing operations

  // - is used by TSQLRest to process BATCH requests using BatchSend() method,

  // or TSQLRestClientURI for its Batch*() methods

  // - but you can create your own stand-alone BATCH process, so that it will

  // be able to make some transactional process - aka the "Unit Of Work" pattern

  TSQLRestBatch = class

  protected

    fRest: TSQLRest;

    fCalledWithinRest: boolean;

    fBatch: TJSONSerializer;

    fBatchFields: TSQLFieldBits;

    fTable: TSQLRecordClass;

    fTablePreviousSendData: TSQLRecordClass;

    fTableIndex: integer;

    fBatchCount: integer;

    fDeletedRecordRef: TIDDynArray;

    fDeletedCount: integer;

    fAddCount: integer;

    fUpdateCount: integer;

    fDeleteCount: integer;

    fAutomaticTransactionPerRow: cardinal;

    fOptions: TSQLRestBatchOptions;

    fOnWrite: TOnBatchWrite;

    function GetCount: integer;

    function GetSizeBytes: cardinal;

    procedure SetExpandedJSONWriter(Props: TSQLRecordProperties;

      ForceResetFields, withID: boolean; const WrittenFields: TSQLFieldBits);

  public

    /// begin a BATCH sequence to speed up huge database change

    // - each call to normal Add/Update/Delete methods will create a Server request,

    //   therefore can be slow (e.g. if the remote server has bad ping timing)

    // - start a BATCH sequence using this method, then call BatchAdd() BatchUpdate()

    //   or BatchDelete() methods to make some changes to the database

    // - when BatchSend will be called, all the sequence transactions will be sent

    //   as one to the remote server, i.e. in one URI request

    // - if BatchAbort is called instead, all pending BatchAdd/Update/Delete

    //   transactions will be aborted, i.e. ignored

    // - expect one TSQLRecordClass as parameter, which will be used for the whole

    //   sequence (in this case, you can't mix classes in the same BATCH sequence)

    // - if no TSQLRecordClass is supplied, the BATCH sequence will allow any

    //   kind of individual record in BatchAdd/BatchUpdate/BatchDelete

    // - return TRUE on success, FALSE if aTable is incorrect or a previous BATCH

    //   sequence was already initiated

    // - should normally be used inside a Transaction block: there is no automated

    //   TransactionBegin..Commit/RollBack generated in the BATCH sequence if

    //   you leave the default AutomaticTransactionPerRow=0 parameter - but

    //   this may be a concern with a lot of concurrent clients

    // - you should better set AutomaticTransactionPerRow > 0 to execute all

    //   BATCH processes within an unique transaction grouped by a given number

    //   of rows, on the server side - set AutomaticTransactionPerRow=maxInt if

    //   you want one huge transaction, or set a convenient value (e.g. 10000)

    //   depending on the back-end database engine abilities, if you want to

    //   retain the transaction log file small enough for the database engine

    // - BatchOptions could be set to tune the SQL execution, e.g. force INSERT

    //   OR IGNORE on internal SQLite3 engine

    constructor Create(aRest: TSQLRest; aTable: TSQLRecordClass;

      AutomaticTransactionPerRow: cardinal=0; Options: TSQLRestBatchOptions=[]);

    /// finalize the BATCH instance

    destructor Destroy; override;

    /// reset the BATCH sequence so that you can re-use the same TSQLRestBatch

    procedure Reset(aTable: TSQLRecordClass; AutomaticTransactionPerRow: cardinal=0;

      Options: TSQLRestBatchOptions=[]); overload; virtual;

    /// reset the BATCH sequence to its previous state

    // - could be used to prepare a next chunk of values, after a call to

    // TSQLRest.BatchSend

    procedure Reset; overload;

    /// create a new member in current BATCH sequence

    // - work in BATCH mode: nothing is sent to the server until BatchSend call

    // - returns the corresponding index in the current BATCH sequence, -1 on error

    // - if SendData is true, content of Value is sent to the server as JSON

    // - if ForceID is true, client sends the Value.ID field to use this ID for

    // adding the record (instead of a database-generated ID)

    // - if Value is TSQLRecordFTS3, Value.ID is stored to the virtual table

    // - Value class MUST match the TSQLRecordClass used at BatchStart,

    // or may be of any kind if no class was specified

    // - BLOB fields are NEVER transmitted here, even if ForceBlobTransfert=TRUE

    // - if CustomFields is left void, the simple fields will be used; otherwise,

    // you can specify your own set of fields to be transmitted when SendData=TRUE

    // (including BLOBs, even if they will be Base64-encoded within JSON content) -

    // CustomFields could be computed by TSQLRecordProperties.FieldBitsFromCSV()

    // or TSQLRecordProperties.FieldBitsFromRawUTF8(), or by setting ALL_FIELDS

    // - this method will always compute and send TCreateTime/TModTime fields

    function Add(Value: TSQLRecord; SendData: boolean; ForceID: boolean=false;

      const CustomFields: TSQLFieldBits=[]; DoNotAutoComputeFields: boolean=false): integer;

    /// update a member in current BATCH sequence

    // - work in BATCH mode: nothing is sent to the server until BatchSend call

    // - returns the corresponding index in the current BATCH sequence, -1 on error

    // - Value class MUST match the TSQLRecordClass used at BatchStart,

    // or may be of any kind if no class was specified

    // - BLOB fields are NEVER transmitted here, even if ForceBlobTransfert=TRUE

    // - if Value has an opened FillPrepare() mapping, only the mapped fields

    // will be updated (and also ID and TModTime fields) - FillPrepareMany() is

    // not handled yet (all simple fields will be updated)

    // - if CustomFields is left void, the  simple fields will be used, or the

    // fields retrieved via a previous FillPrepare() call; otherwise, you can

    // specify your own set of fields to be transmitted (including BLOBs, even

    // if they will be Base64-encoded within the JSON content) - CustomFields

    // could be computed by TSQLRecordProperties.FieldBitsFromCSV()

    // or TSQLRecordProperties.FieldBitsFromRawUTF8()

    // - this method will always compute and send any TModTime fields, unless

    // DoNotAutoComputeFields is set to true

    function Update(Value: TSQLRecord; const CustomFields: TSQLFieldBits=[];

      DoNotAutoComputeFields: boolean=false): integer; overload; virtual;

    /// update a member in current BATCH sequence

    // - work in BATCH mode: nothing is sent to the server until BatchSend call

    // - is an overloaded method to Update(Value,FieldBitsFromCSV())

    function Update(Value: TSQLRecord; const CustomCSVFields: RawUTF8;

      DoNotAutoComputeFields: boolean=false): integer; overload;

    /// delete a member in current BATCH sequence

    // - work in BATCH mode: nothing is sent to the server until BatchSend call

    // - returns the corresponding index in the current BATCH sequence, -1 on error

    // - deleted record class is the TSQLRecordClass used at BatchStart()

    // call: it will fail if no class was specified for this BATCH sequence

    function Delete(ID: TID): integer; overload;

    /// delete a member in current BATCH sequence

    // - work in BATCH mode: nothing is sent to the server until BatchSend call

    // - returns the corresponding index in the current BATCH sequence, -1 on error

    // - with this overloaded method, the deleted record class is specified:

    // no TSQLRecordClass shall have been set at BatchStart() call

    function Delete(Table: TSQLRecordClass; ID: TID): integer; overload;

    /// allow to append some JSON content to the internal raw buffer

    // - could be used to emulate Add/Update/Delete

    // - FullRow=TRUE would increment the global Count

    function RawAppend(FullRow: boolean=true): TTextWriter;

    /// allow to append some JSON content to the internal raw buffer for a POST

    // - could be used to emulate Add() with an already pre-computed JSON object

    procedure RawAdd(const SentData: RawUTF8);

    /// allow to append some JSON content to the internal raw buffer for a PUT

    // - could be used to emulate Update() with an already pre-computed JSON object

    procedure RawUpdate(const SentData: RawUTF8; ID: TID);

    /// close a BATCH sequence started by Start method

    // - Data is ready to be supplied to TSQLRest.BatchSend() overloaded method

    // - will also notify the TSQLRest.Cache for all deleted IDs

    // - you should not have to call it in normal use cases

    function PrepareForSending(out Data: RawUTF8): boolean; virtual;

    /// read only access to the associated TSQLRest instance

    property Rest: TSQLRest read fRest;

    /// retrieve the current number of pending transactions in the BATCH sequence

    property Count: integer read GetCount;

    /// retrieve the current JSON size of pending transaction in the BATCH sequence

    property SizeBytes: cardinal read GetSizeBytes;

    /// read only access to the main associated TSQLRecord class (if any)

    property Table: TSQLRecordClass read fTable;

    /// how many times Add() has been called for this BATCH process

    property AddCount: integer read fAddCount;

    /// how many times Update() has been called for this BATCH process

    property UpdateCount: integer read fUpdateCount;

    /// how many times Delete() has been called for this BATCH process

    property DeleteCount: integer read fDeleteCount;

    /// this event handler will be triggerred by each Add/Update/Delete method

    property OnWrite: TOnBatchWrite read fOnWrite write fOnWrite;

  end;



  /// thread-safe class to store a BATCH sequence of writing operations

  TSQLRestBatchLocked = class(TSQLRestBatch)

  protected

    fTix: Int64;

    fSafe: TSynLocker;

  public

    /// initialize the BATCH instance

    constructor Create(aRest: TSQLRest; aTable: TSQLRecordClass;

      AutomaticTransactionPerRow: cardinal=0; Options: TSQLRestBatchOptions=[]);

    /// finalize the BATCH instance

    destructor Destroy; override;

    /// reset the BATCH sequence so that you can re-use the same TSQLRestBatch

    procedure Reset(aTable: TSQLRecordClass; AutomaticTransactionPerRow: cardinal=0;

      Options: TSQLRestBatchOptions=[]); override; 

    /// access to the locking methods of this instance

    // - use Safe.Lock/TryLock with a try ... finally Safe.Unlock block

    property Safe: TSynLocker read fSafe;

    /// property set to the current GetTickCount64 value when Reset is called

    property ResetTix: Int64 read fTix write fTix;

  end;



  /// root class for defining and mapping database records

  // - inherits a class from TSQLRecord, and add published properties to describe

  // the table columns (see TPropInfo for SQL and Delphi type mapping/conversion)

  // - this published properties can be auto-filled from TSQLTable answer with

  // FillPrepare() and FillRow(), or FillFrom() with TSQLTable or JSON data

  // - these published properties can be converted back into UTF-8 encoded SQL

  // source with GetSQLValues or GetSQLSet or into JSON format with GetJSONValues

  // - BLOB fields are decoded to auto-freeing TSQLRawBlob properties

  // - any published property defined as a T*ObjArray dynamic array storage

  // of persistents (via TJSONSerializer.RegisterObjArrayForJSON) will be freed

  TSQLRecord = class(TObject)

  { note that every TSQLRecord has an Instance size of 20 bytes for private and

    protected fields (such as fID or fProps e.g.) }

  protected

    /// used by FillPrepare() and corresponding Fill*() methods

    fFill: TSQLRecordFill;

    /// internal properties getters (using fProps data for speed)

    function GetHasBlob: boolean;

    function GetSimpleFieldCount: integer;

    function GetFillCurrentRow: integer;

    function GetTable: TSQLTable;

  protected

    fInternalState: cardinal;

    fID: TID;

    /// virtual class method to be overridden to register some custom properties

    // - do nothing by default, but allow inherited classes to define some

    // properties, by adding some TSQLPropInfo instances to Props.Fields list,

    // or calling Props.RegisterCustomFixedSizeRecordProperty() or

    // Props.RegisterCustomRTTIRecordProperty() methods

    // - can also be used to specify a custom text collation, by calling

    // Props.SetCustomCollationForAll() or SetCustomCollation() methods

    // - do not call RecordProps from here (e.g. by calling AddFilter*): it

    // woult trigger a stack overflow, since at this state Props is not stored -

    // but rather use InternalDefineModel class method

    class procedure InternalRegisterCustomProperties(Props: TSQLRecordProperties); virtual;

    /// virtual class method to be overridden to define some record-level modeling

    // - do nothing by default, but allow inherited classes to define some

    // process which would take place after TSQLRecordProperties initialization

    // - this may be the place e.g. to call AddFilter*() methods, if you do not

    // want those to be written "in stone", and not manually when creating the

    // TSQLModel instance

    class procedure InternalDefineModel(Props: TSQLRecordProperties); virtual;

  {$ifdef MSWINDOWS}{$ifdef HASINLINE}

  public

  {$endif}{$endif}

    /// trick to get the ID even in case of a sftID published property

    function GetID: TID;

      {$ifdef MSWINDOWS}{$ifdef HASINLINE}inline;{$endif}{$endif}

    /// trick to typecast the ID on 64-bit platform

    function GetIDAsPointer: pointer;

      {$ifdef MSWINDOWS}{$ifdef HASINLINE}inline;{$endif}{$endif}

  public

    /// direct access to the TSQLRecord properties from RTTI

    // - TSQLRecordProperties is faster than e.g. the class function FieldProp()

    // - use internal the unused vmtAutoTable VMT entry to fast retrieve of a

    // class variable which is unique for each class ("class var" is unique only

    // for the class within it is defined, and we need a var for each class:

    // so even Delphi XE syntax is not powerful enough for our purpose, and the

    // vmtAutoTable trick if very fast, and works with all versions of Delphi -

    // including 64-bit target)

    class function RecordProps: TSQLRecordProperties;

      {$ifdef FPC_OR_PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif}

    /// the Table name in the database, associated with this TSQLRecord class

    // - 'TSQL' or 'TSQLRecord' chars are trimmed at the beginning of the ClassName

    // - or the ClassName is returned as is, if no 'TSQL' or 'TSQLRecord' at first

    // - is just a wrapper around RecordProps.SQLTableName

    class function SQLTableName: RawUTF8;

      {$ifdef HASINLINE}inline;{$endif}

    /// register a custom filter (transformation) or validate to the

    // TSQLRecord class for a specified field

    // - this will be used by TSQLRecord.Filter and TSQLRecord.Validate

    // methods (in default implementation)

    // - will raise an EModelException on failure

    // - this function is just a wrapper around RecordProps.AddFilterOrValidate

    class procedure AddFilterOrValidate(const aFieldName: RawUTF8;

      aFilter: TSynFilterOrValidate);

    /// register a TSynFilterTrim and a TSynValidateText filters so that

    // the specified fields, after space trimming, won't be void

    class procedure AddFilterNotVoidText(const aFieldNames: array of RawUTF8);

    /// register a TSynFilterTrim and a TSynValidateText filters so that

    // all text fields, after space trimming, won't be void

    // - will only affect RAWTEXT_FIELDS

    class procedure AddFilterNotVoidAllTextFields;

    /// protect several TSQLRecord local variable instances

    // - specified as localVariable/recordClass pairs

    // - is a wrapper around TAutoFree.Several(...) constructor

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

    // - you may write for instance:

    // ! var info: TSQLBlogInfo;

    // !     article: TSQLArticle;

    // !     comment: TSQLComment;

    // ! begin

    // !   TSQLRecord.AutoFree([ // avoid several try..finally

    // !     @info,TSQLBlogInfo, @article,TSQLArticle, @comment,TSQLComment]);

    // !   .... now you can use info, article or comment

    // ! end; // will call info.Free article.Free and comment.Free

    // - warning: under FPC, you should assign the result of this method to a local

    // IAutoFree variable - see bug http://bugs.freepascal.org/view.php?id=26602

    class function AutoFree(varClassPairs: array of pointer): IAutoFree; overload;

    /// protect one TSQLRecord local variable instance

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

    // - you may write for instance:

    // ! var info: TSQLBlogInfo;

    // ! begin

    // !   TSQLBlogInfo.AutoFree(info);

    // !   .... now you can use info

    // ! end; // will call info.Free

    // - warning: under FPC, you should assign the result of this method to a local

    // IAutoFree variable - see bug http://bugs.freepascal.org/view.php?id=26602

    class function AutoFree(var localVariable): IAutoFree; overload;

    /// read and protect one TSQLRecord local variable instance

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

    // - warning: under FPC, you should assign the result of this method to a local

    // IAutoFree variable - see bug http://bugs.freepascal.org/view.php?id=26602

    class function AutoFree(var localVariable; Rest: TSQLRest; ID: TID): IAutoFree; overload;



    /// get the captions to be used for this class

    // - if Action is nil, return the caption of the table name

    // - if Action is not nil, return the caption of this Action (lowercase left-trimed)

    // - return "string" type, i.e. UnicodeString for Delphi 2009+

    // - internally call UnCamelCase() then System.LoadResStringTranslate() if available

    // - ForHint is set to TRUE when the record caption name is to be displayed inside

    // the popup hint of a button (i.e. the name must be fully qualified, not

    // the default short version)

    // - is not part of TSQLRecordProperties because has been declared as virtual

    class function CaptionName(Action: PRawUTF8=nil; ForHint: boolean=false): string; virtual;

    /// get the captions to be used for this class

    // - just a wrapper calling CaptionName() virtual method, from a ShortString pointer

    class function CaptionNameFromRTTI(Action: PShortString): string;

    /// virtual method called when the associated table is created in the database

    // - if FieldName is '', initialization regarding all fields must be made;

    // if FieldName is specified, initialization regarding this field must be processed

    // - override this method in order to initialize indexs or create default records

    // - by default, create indexes for all TRecordReference properties, and

    // for all TSQLRecord inherited properties (i.e. of sftID type, that is

    // an INTEGER field containing the ID of the pointing record)

    // - the options specified at CreateMissingTables() are passed to this method

    // - is not part of TSQLRecordProperties because has been declared as virtual

    class procedure InitializeTable(Server: TSQLRestServer; const FieldName: RawUTF8;

      Options: TSQLInitializeTableOptions); virtual;



    /// filter/transform the specified fields values of the TSQLRecord instance

    // - by default, this will perform all TSynFilter as registered by

    // [RecordProps.]AddFilterOrValidate()

    // - inherited classes may add some custom filtering/transformation here, if

    // it's not needed nor mandatory to create a new TSynFilter class type: in

    // this case, the function has to return TRUE if the filtering took place,

    // and FALSE if any default registered TSynFilter must be processed

    // - the default aFields parameter will process all fields

    function Filter(const aFields: TSQLFieldBits=[0..MAX_SQLFIELDS-1]): boolean; overload; virtual;

    ///  filter/transform the specified fields values of the TSQLRecord instance

    // - this version will call the overloaded Filter() method above

    // - return TRUE if all field names were correct and processed, FALSE otherwise

    function Filter(const aFields: array of RawUTF8): boolean; overload;

    /// validate the specified fields values of the current TSQLRecord instance

    // - by default, this will perform all TSynValidate as registered by

    //  [RecordProps.]AddFilterOrValidate()

    // - it will also check if any UNIQUE field value won't be duplicated

    // - inherited classes may add some custom validation here, if it's not needed

    //  nor mandatory to create a new TSynValidate class type: in this case, the

    //  function has to return an explicit error message (as a generic VCL string)

    //  if the custom validation failed, or '' if the validation was successful:

    //  in this later case, all default registered TSynValidate are processed

    // - the default aFields parameter will process all fields

    // - if aInvalidFieldIndex is set, it will contain the first invalid field

    //  index found

    // - caller SHOULD always call the Filter() method before calling Validate()

    function Validate(aRest: TSQLRest; const aFields: TSQLFieldBits=[0..MAX_SQLFIELDS-1];

      aInvalidFieldIndex: PInteger=nil; aValidator: PSynValidate=nil): string; overload; virtual;

    ///  validate the specified fields values of the current TSQLRecord instance

    // - this version will call the overloaded Validate() method above

    // - returns '' if all field names were correct and processed, or an

    // explicit error message (translated in the current language) on error

    // - if aInvalidFieldIndex is set, it will contain the first invalid field index

    function Validate(aRest: TSQLRest; const aFields: array of RawUTF8;

      aInvalidFieldIndex: PInteger=nil; aValidator: PSynValidate=nil): string; overload;

    /// filter (transform) then validate the specified fields values of the TSQLRecord

    // - this version will call the overloaded Filter() and Validate() methods

    // and display the faulty field name at the beginning of the error message

    // - returns true if all field names were correct and processed, or false

    // and an explicit error message (translated in the current language) on error

    function FilterAndValidate(aRest: TSQLRest; out aErrorMessage: string;

      const aFields: TSQLFieldBits=[0..MAX_SQLFIELDS-1];

      aValidator: PSynValidate=nil): boolean; overload;

    /// filter (transform) then validate the specified fields values of the TSQLRecord

    // - this version will call the overloaded Filter() and Validate() methods

    // and return '' on validation success, or an error message with the faulty

    // field names at the beginning

    function FilterAndValidate(aRest: TSQLRest;

      const aFields: TSQLFieldBits=[0..MAX_SQLFIELDS-1];

      aValidator: PSynValidate=nil): RawUTF8; overload;

    /// should modify the record content before writing to the Server

    // - this default implementation will update any sftModTime / TModTime,

    // sftCreateTime / TCreateTime and sftSessionUserID / TSessionUserID

    // properties content with the exact server time stamp

    // - you may override this method e.g. for custom calculated fields

    // - note that this is computed only on the Client side, before sending

    // back the content to the remote Server: therefore, TModTime / TCreateTime

    // fields are a pure client ORM feature - it won't work directly at REST level

    procedure ComputeFieldsBeforeWrite(aRest: TSQLRest; aOccasion: TSQLEvent); virtual;



    /// this constructor initializes the record

    // - auto-instanciate any TSQLRecordMany instance defined in published properties

    // - override this method if you want to use some internal objects (e.g.

    // TStringList or TCollection as published property)

    constructor Create; overload; virtual;

    /// this constructor initializes the record and set the simple fields

    // with the supplied values

    // - the aSimpleFields parameters must follow explicitely the order of

    // published properties of the aTable class, excepting the TSQLRawBlob and

    // TSQLRecordMany kind (i.e. only so called "simple fields") - in

    // particular, parent properties must appear first in the list

    // - the aSimpleFields must have exactly the same count of parameters as

    // there are "simple fields" in the published properties

    // - will raise an EORMException in case of wrong supplied values

    constructor Create(const aSimpleFields: array of const; aID: TID); overload;

    /// this constructor initializes the object as above, and fills its content

    // from a client or server connection

    // - if ForUpdate is true, the REST method is LOCK and not GET: it tries to lock

    // the corresponding record, then retrieve its content; caller has to call

    // UnLock() method after Value usage, to release the record

    constructor Create(aClient: TSQLRest; aID: TID;

      ForUpdate: boolean=false); overload;

    /// this constructor initializes the object and fills its content from a client

    // or server connection, from a TSQLRecord published property content

    // - is just a wrapper around Create(aClient,PtrInt(aPublishedRecord))

    // or Create(aClient,aPublishedRecord.ID)

    // - a published TSQLRecord property is not a class instance, but a typecast to

    // TObject(RecordID) - you can also use its ID property

    // - if ForUpdate is true, the REST method is LOCK and not GET: it tries to lock

    // the corresponding record, then retrieve its content; caller has to call

    // UnLock() method after Value usage, to release the record

    constructor Create(aClient: TSQLRest; aPublishedRecord: TSQLRecord;

      ForUpdate: boolean=false); overload;

    /// this constructor initializes the object as above, and fills its content

    //  from a client or server connection, using a specified WHERE clause

    //  - the WHERE clause should use inlined parameters (like 'Name=:('Arnaud'):')

    //  for better server speed - note that you can use FormatUTF8() as such:

    //  ! aRec := TSQLMyRec.Create(Client,FormatUTF8('Salary>? AND Salary<?',[],[1000,2000]));

    //  or call the overloaded contructor with BoundsSQLWhere array of parameters

    constructor Create(aClient: TSQLRest; const aSQLWhere: RawUTF8); overload;

    /// this constructor initializes the object as above, and fills its content

    // from a client or server connection, using a specified WHERE clause

    // with parameters

    // - for better server speed, the WHERE clause should use bound parameters

    // identified as '?' in the FormatSQLWhere statement, which is expected to

    // follow the order of values supplied in BoundsSQLWhere open array - use

    // DateToSQL/DateTimeToSQL for TDateTime, or directly any integer / double /

    // currency / RawUTF8 values to be bound to the request as parameters

    // - note that this method prototype changed with revision 1.17 of the

    // framework: array of const used to be ParamsSQLWhere and '%' in the

    // FormatSQLWhere statement, whereas it now expects bound parameters as '?'

    constructor Create(aClient: TSQLRest; const FormatSQLWhere: RawUTF8;

      const BoundsSQLWhere: array of const); overload;

    /// this constructor initializes the object as above, and fills its content

    // from a client or server connection, using a specified WHERE clause

    // with parameters

    // - the FormatSQLWhere clause will replace all '%' chars with the supplied

    // ParamsSQLWhere[] values, and all '?' chars with BoundsSQLWhere[] values,

    // as :(...): inlined parameters - you should either call:

    // ! Rec := TSQLMyRecord.Create(aClient,'Count=:(%):'[aCount],[]);

    // or (letting the inlined parameters being computed by FormatUTF8)

    // !  Rec := TSQLMyRecord.Create(aClient,'Count=?',[],[aCount]);

    // or even better, using the other Create overloaded constructor:

    // !  Rec := TSQLMyRecord.Create(aClient,'Count=?',[aCount]);

    // - using '?' and BoundsSQLWhere[] is perhaps more readable in your code, and

    // will in all case create a request with :(..): inline parameters, with

    // automatic RawUTF8 quoting if necessary

    constructor Create(aClient: TSQLRest; const FormatSQLWhere: RawUTF8;

      const ParamsSQLWhere, BoundsSQLWhere: array of const); overload;

    /// this constructor initializes the object as above, and fills its content

    // from a supplied JSON content

    // - is a wrapper around Create + FillFrom() methods

    // - use JSON data, as exported by GetJSONValues(), expanded or not

    // - make an internal copy of the JSONTable RawUTF8 before calling

    // FillFrom() below

    constructor CreateFrom(const JSONRecord: RawUTF8); overload;

    /// this constructor initializes the object as above, and fills its content

    // from a supplied JSON buffer

    // - is a wrapper around Create + FillFrom() methods

    // - use JSON data, as exported by GetJSONValues(), expanded or not

    // - the data inside P^ is modified (unescaped and transformed in-place):

    // don't call CreateFrom(pointer(JSONRecord)) but CreateFrom(JSONRecord) which

    // makes a temporary copy of the JSONRecord text variable before parsing

    constructor CreateFrom(P: PUTF8Char); overload;

    {$ifndef NOVARIANTS}

    /// this constructor initializes the object as above, and fills its content

    // from a supplied TDocVariant object document

    // - is a wrapper around Create + FillFrom() methods

    constructor CreateFrom(const aDocVariant: variant); overload;

    {$endif}



    /// this constructor initializes the object as above, and prepares itself to

    // loop through a statement using a specified WHERE clause

    // - this method creates a TSQLTableJSON, retrieves all records corresponding

    // to the WHERE clause, then call FillPrepare - previous Create(aClient)

    // methods retrieve only one record, this one more multiple rows

    // - you should then loop for all rows using 'while Rec.FillOne do ...'

    // - the TSQLTableJSON will be freed by TSQLRecord.Destroy

    // - the WHERE clause should use inlined parameters (like 'Name=:('Arnaud'):')

    // for better server speed - note that you can use FormatUTF8() as such:

    // ! aRec := TSQLMyRec.CreateAndFillPrepare(Client,FormatUTF8('Salary>? AND Salary<?',[],[1000,2000]));

    // or call the overloaded CreateAndFillPrepare() contructor directly with

    // BoundsSQLWhere array of parameters

    // - aCustomFieldsCSV can be used to specify which fields must be retrieved

    // - default aCustomFieldsCSV='' will retrieve all simple table fields

    // - if aCustomFieldsCSV='*', it will retrieve all fields, including BLOBs

    // - aCustomFieldsCSV can also be set to a CSV field list to retrieve only

    // the needed fields, and save remote bandwidth - note that any later

    // Update() will update all simple fields, so potentially with wrong

    // values; but BatchUpdate() can be safely used since it will

    constructor CreateAndFillPrepare(aClient: TSQLRest; const aSQLWhere: RawUTF8;

      const aCustomFieldsCSV: RawUTF8=''); overload;

    /// this constructor initializes the object as above, and prepares itself to

    // loop through a statement using a specified WHERE clause

    // - this method creates a TSQLTableJSON, retrieves all records corresponding

    // to the WHERE clause, then call FillPrepare - previous Create(aClient)

    // methods retrieve only one record, this one more multiple rows

    // - you should then loop for all rows using 'while Rec.FillOne do ...'

    // - the TSQLTableJSON will be freed by TSQLRecord.Destroy

    // - for better server speed, the WHERE clause should use bound parameters

    // identified as '?' in the FormatSQLWhere statement, which is expected to

    // follow the order of values supplied in BoundsSQLWhere open array - use

    // DateToSQL/DateTimeToSQL for TDateTime, or directly any integer / double /

    // currency / RawUTF8 values to be bound to the request as parameters

    // - note that this method prototype changed with revision 1.17 of the

    // framework: array of const used to be ParamsSQLWhere and '%' in the

    // FormatSQLWhere statement, whereas it now expects bound parameters as '?'

    // - aCustomFieldsCSV can be used to specify which fields must be retrieved

    // - default aCustomFieldsCSV='' will retrieve all simple table fields, but

    // you may need  to access only one or several fields, and will save remote

    // bandwidth by specifying the needed fields

    // - if aCustomFieldsCSV='*', it will retrieve all fields, including BLOBs

    // - note that you should not use this aCustomFieldsCSV optional parameter if

    // you want to Update the retrieved record content later, since any

    // missing fields will be left with previous values - but BatchUpdate() can be

    // safely used after FillPrepare (will set only ID, TModTime and mapped fields)

    constructor CreateAndFillPrepare(aClient: TSQLRest; const FormatSQLWhere: RawUTF8;

      const BoundsSQLWhere: array of const; const aCustomFieldsCSV: RawUTF8=''); overload;

    /// this constructor initializes the object as above, and prepares itself to

    // loop through a statement using a specified WHERE clause

    // - this method creates a TSQLTableJSON, retrieves all records corresponding

    // to the WHERE clause, then call FillPrepare - previous Create(aClient)

    // methods retrieve only one record, this one more multiple rows

    // - you should then loop for all rows using 'while Rec.FillOne do ...'

    // - the TSQLTableJSON will be freed by TSQLRecord.Destroy

    // - the FormatSQLWhere clause will replace all '%' chars with the supplied

    // ParamsSQLWhere[] supplied values, and bind all '?' chars as parameters

    // with BoundsSQLWhere[] values

    // - aCustomFieldsCSV can be used to specify which fields must be retrieved

    // - default aCustomFieldsCSV='' will retrieve all simple table fields, but

    // you may need  to access only one or several fields, and will save remote

    // bandwidth by specifying the needed fields

    // - if aCustomFieldsCSV='*', it will retrieve all fields, including BLOBs

    // - note that you should not use this aCustomFieldsCSV optional parameter if

    // you want to Update the retrieved record content later, since any

    // missing fields will be left with previous values - but BatchUpdate() can be

    // safely used after FillPrepare (will set only ID, TModTime and mapped fields)

    constructor CreateAndFillPrepare(aClient: TSQLRest; const FormatSQLWhere: RawUTF8;

      const ParamsSQLWhere, BoundsSQLWhere: array of const;

      const aCustomFieldsCSV: RawUTF8=''); overload;

    /// this constructor initializes the object as above, and prepares itself to

    // loop through a given list of IDs

    // - this method creates a TSQLTableJSON, retrieves all records corresponding

    // to the specified IDs, then call FillPrepare - previous Create(aClient)

    // methods retrieve only one record, this one more multiple rows

    // - you should then loop for all rows using 'while Rec.FillOne do ...'

    // - the TSQLTableJSON will be freed by TSQLRecord.Destroy

    // - aCustomFieldsCSV can be used to specify which fields must be retrieved

    // - default aCustomFieldsCSV='' will retrieve all simple table fields, but

    // you may need  to access only one or several fields, and will save remote

    // bandwidth by specifying the needed fields

    // - if aCustomFieldsCSV='*', it will retrieve all fields, including BLOBs

    // - note that you should not use this aCustomFieldsCSV optional parameter if

    // you want to Update the retrieved record content later, since any

    // missing fields will be left with previous values - but BatchUpdate() can be

    // safely used after FillPrepare (will set only ID, TModTime and mapped fields)

    constructor CreateAndFillPrepare(aClient: TSQLRest; const aIDs: array of Int64;

      const aCustomFieldsCSV: RawUTF8=''); overload;

    /// this constructor initializes the object, and prepares itself to loop

    // through a specified JSON table

    // - this method creates a TSQLTableJSON, fill it with the supplied JSON buffer,

    // then call FillPrepare - previous Create(aClient) methods retrieve only

    // one record, this one more multiple rows

    // - you should then loop for all rows using 'while Rec.FillOne do ...'

    // - the TSQLTableJSON will be freed by TSQLRecord.Destroy

    constructor CreateAndFillPrepare(const aJSON: RawUTF8); overload;

    /// this constructor initializes the object from its ID, including all

    // nested TSQLRecord properties, through a JOINed statement

    // - by default, Create(aClient,aID) will return only the one-to-one

    // nested TSQLRecord published properties IDs trans-typed as pointer - this

    // constructor allow to retrieve the nested values in one statement

    // - use this constructor if you want all TSQLRecord published properties to

    // be allocated, and loaded with the corresponding values

    // - Free/Destroy will release these instances

    // - warning: if you call Update() after it, only the main object will be

    // updated, not the nested TSQLRecord properties

    constructor CreateJoined(aClient: TSQLRest; aID: TID);

    /// this constructor initializes the object, and prepares itself to loop

    // nested TSQLRecord properties, through a JOINed statement and a WHERE clause

    // - by default, CreateAndFillPrepare() will return only the one-to-one

    // nested TSQLRecord published properties IDs trans-typed as pointer - this

    // constructor allow to retrieve the nested values in one statement

    //  - this method creates a TSQLTableJSON, fill it with the supplied JSON buffer,

    // then call FillPrepare - previous CreateJoined() method retrieve only

    // one record, this one more multiple rows

    // - you should then loop for all rows using 'while Rec.FillOne do ...'

    // - use this constructor if you want all TSQLRecord published properties to

    // be allocated, and loaded with the corresponding values

    // - Free/Destroy will release these instances

    // - warning: if you call Update() after it, only the main object will be

    // updated, not the nested TSQLRecord properties

    constructor CreateAndFillPrepareJoined(aClient: TSQLRest;

      const aFormatSQLJoin: RawUTF8; const aParamsSQLJoin, aBoundsSQLJoin: array of const);

    /// this constructor initializes the object including all TSQLRecordMany properties,

    // and prepares itself to loop through a JOINed statement

    // - the created instance will have all its TSQLRecordMany Dest property allocated

    // with proper instance (and not only pointer(DestID) e.g.), ready to be

    // consumed during a while FillOne do... loop (those instances will be

    // freed by TSQLRecord.FillClose or Destroy) - and the Source property

    // won't contain pointer(SourceID) but the main TSQLRecord instance

    // - the aFormatSQLJoin clause will define a WHERE clause for an automated

    // JOINed statement, including TSQLRecordMany published properties (and

    // their nested properties)

    // - a typical use could be the following:

    // ! aProd := TSQLProduct.CreateAndFillPrepareMany(Database,

    // !   'Owner=? and Categories.Dest.Name=? and (Sizes.Dest.Name=? or Sizes.Dest.Name=?)',[],

    // !   ['mark','for boy','small','medium']);

    // ! if aProd<>nil then

    // ! try

    // !   while aProd.FillOne do

    // !     //  here e.g. aProd.Categories.Dest are instantied (and Categories.Source=aProd)

    // !     writeln(aProd.Name,' ',aProd.Owner,' ',aProd.Categories.Dest.Name,' ',aProd.Sizes.Dest.Name);

    // !   //  you may also use aProd.FillTable to fill a grid, e.g.

    // !   //  (do not forget to set aProd.FillTable.OwnerMustFree := false)

    // ! finally

    // !   aProd.Free; //  will also free aProd.Categories/Sizes instances

    // ! end;

    // this will execute a JOINed SELECT statement similar to the following:

    // $ select p.*, c.*, s.*

    // $ from Product p, Category c, Categories cc, Size s, Sizes ss

    // $ where c.id=cc.dest and cc.source=p.id and

    // $  s.id=ss.dest and ss.source=p.id and

    // $  p.Owner='mark' and c.Name='for boy' and (s.Name='small' or s.Name='medium')

    // - you SHALL call explicitely the FillClose method before using any

    // methods of nested TSQLRecordMany instances which may override the Dest

    // instance content (e.g. ManySelect) to avoid any GPF

    // - the aFormatSQLJoin clause will replace all '%' chars with the supplied

    // aParamsSQLJoin[] supplied values, and bind all '?' chars as bound

    // parameters with aBoundsSQLJoin[] values

    constructor CreateAndFillPrepareMany(aClient: TSQLRest; const aFormatSQLJoin: RawUTF8;

      const aParamsSQLJoin, aBoundsSQLJoin: array of const);



    /// this method create a clone of the current record, with same ID and properties

    // - copy all COPIABLE_FIELDS, i.e. all fields excluding tftMany (because

    // those fields don't contain any data, but a TSQLRecordMany instance

    // which allow to access to the pivot table data)

    // - you can override this method to allow custom copy of the object,

    // including (or not) published properties copy

    function CreateCopy: TSQLRecord; overload; virtual;

    /// this method create a clone of the current record, with same ID and properties

    // - overloaded method to copy the specified properties

    function CreateCopy(const CustomFields: TSQLFieldBits): TSQLRecord; overload;

    /// release the associated memory

    // - in particular, release all TSQLRecordMany instance created by the

    // constructor of this TSQLRecord

    destructor Destroy; override;



    /// return the UTF-8 encoded SQL source to create the table containing the

    // published fields of a TSQLRecord child

    // - a 'ID INTEGER PRIMARY KEY' field is always created first (mapping

    // SQLite3 RowID)

    // - AnsiString are created as TEXT COLLATE NOCASE (fast SQLite3 7bits compare)

    // - RawUnicode and RawUTF8 are created as TEXT COLLATE SYSTEMNOCASE

    // (i.e. use our fast UTF8IComp() for comparaison)

    // - TDateTime are created as TEXT COLLATE ISO8601

    // (which calls our very fast ISO TEXT to Int64 conversion routine)

    // - an individual bit set in UniqueField forces the corresponding field to

    // be marked as UNIQUE (an unique index is automaticaly created on the specified

    // column); use TSQLModel fIsUnique[] array, which set the bits values

    // to 1 if a property field was published with "stored AS_UNIQUE"

    // (i.e. "stored false")

    // - this method will handle TSQLRecordFTS* classes like FTS* virtual tables,

    // TSQLRecordRTree as RTREE virtual table, and TSQLRecordVirtualTable*ID

    // classes as corresponding Delphi designed virtual tables

    // - is not part of TSQLRecordProperties because has been declared as virtual

    // so that you could specify a custom SQL statement, per TSQLRecord type

    // - anyway, don't call this method directly, but use TSQLModel.GetSQLCreate()

    // - the aModel parameter is used to retrieve the Virtual Table module name,

    // and can be ignored for regular (not virtual) tables

    class function GetSQLCreate(aModel: TSQLModel): RawUTF8; virtual;

    /// return the Class Type of the current TSQLRecord

    function RecordClass: TSQLRecordClass;

      {$ifdef PUREPASCAL} {$ifdef HASINLINE}inline;{$endif} {$endif}

    /// return the RTTI property information for this record

    function ClassProp: PClassProp;

      {$ifdef PUREPASCAL} {$ifdef HASINLINE}inline;{$endif} {$endif}

    /// return the TRecordReference Int64 value pointing to this record

    function RecordReference(Model: TSQLModel): TRecordReference;



    /// return the UTF-8 encoded SQL source to INSERT the values contained

    // in the current published fields of a TSQLRecord child

    // - only simple fields name (i.e. not TSQLRawBlob/TSQLRecordMany) are updated:

    // BLOB fields are ignored (use direct update via dedicated methods instead)

    // - format is '(COL1, COL2) VALUES ('VAL1', 'VAL2')' if some column was ignored

    // (BLOB e.g.)

    // - format is 'VALUES ('VAL1', 'VAL2')' if all columns values are available

    // - is not used by the ORM (do not use prepared statements) - only here

    // for conveniency

    function GetSQLValues: RawUTF8;

    /// return the UTF-8 encoded SQL source to UPDATE the values contained

    // in the current published fields of a TSQLRecord child

    // - only simple fields name (i.e. not TSQLRawBlob/TSQLRecordMany) are retrieved:

    // BLOB fields are ignored (use direct access via dedicated methods instead)

    // - format is 'COL1='VAL1', COL2='VAL2''

    // - is not used by the ORM (do not use prepared statements) - only here

    // for conveniency

    function GetSQLSet: RawUTF8;

    /// return the UTF-8 encoded JSON objects for the values of this TSQLRecord

    // - layout and fields should have been set at TJSONSerializer construction:

    // to append some content to an existing TJsonSerializer, call the

    // AppendAsJsonObject() method

    procedure GetJSONValues(W : TJSONSerializer); overload;

    /// return the UTF-8 encoded JSON objects for the values of this TSQLRecord

    // - layout and fields should have been set at TJSONSerializer construction:

    // to append some content to an existing TJsonSerializer, call the

    // AppendAsJsonObject() method

    // - the JSON buffer will be finalized if needed (e.g. non expanded mode),

  	// and the supplied TJSONSerializer instance will be freed by this method

    procedure GetJSONValuesAndFree(JSON : TJSONSerializer); overload;

    /// return the UTF-8 encoded JSON objects for the values contained

    // in the current published fields of a TSQLRecord child

    // - only simple fields (i.e. not TSQLRawBlob/TSQLRecordMany) are retrieved:

    //   BLOB fields are ignored (use direct access via dedicated methods instead)

    // - if Expand is true, JSON data is an object, for direct use with any Ajax or .NET client:

    // ! {"col1":val11,"col2":"val12"}

    // - if Expand is false, JSON data is serialized (as used in TSQLTableJSON)

    // ! { "fieldCount":1,"values":["col1","col2",val11,"val12",val21,..] }

    // - if withID is true, then the first ID field value is included

    // - you can customize SQLRecordOptions, e.g. if sftObject/sftBlobDynArray

    // property instance would be serialized as a JSON object or array, not a

    // JSON string (which is the default, as expected by the database storage),

    // or if an "ID_str" string field should be added for JavaScript

    procedure GetJSONValues(JSON: TStream; Expand: boolean; withID: boolean;

      Occasion: TSQLOccasion; SQLRecordOptions: TJSONSerializerSQLRecordOptions=[]); overload;

    /// same as overloaded GetJSONValues(), but returning result into a RawUTF8

    // - if UsingStream is not set, it will use a temporary THeapMemoryStream instance

    function GetJSONValues(Expand: boolean; withID: boolean; Occasion: TSQLOccasion;

      UsingStream: TCustomMemoryStream=nil; SQLRecordOptions: TJSONSerializerSQLRecordOptions=[]): RawUTF8; overload;

    /// same as overloaded GetJSONValues(), but allowing to set the fields to

    // be retrieved, and returning result into a RawUTF8

    function GetJSONValues(Expand: boolean; withID: boolean;

      const Fields: TSQLFieldBits; SQLRecordOptions: TJSONSerializerSQLRecordOptions=[]): RawUTF8; overload;

    /// same as overloaded GetJSONValues(), but allowing to set the fields to

    // be retrieved, and returning result into a RawUTF8

    function GetJSONValues(Expand: boolean; withID: boolean;

      const FieldsCSV: RawUTF8; SQLRecordOptions: TJSONSerializerSQLRecordOptions=[]): RawUTF8; overload;

    /// will append the record fields as an expanded JSON object

    // - GetJsonValues() will expect a dedicated TJSONSerializer, whereas this

    // method will add the JSON object directly to any TJSONSerializer

    // - by default, will append the simple fields, unless the Fields optional

    // parameter is customized to a non void value

    procedure AppendAsJsonObject(W: TJSONSerializer; Fields: TSQLFieldBits=[]);

    /// will append all the FillPrepare() records as an expanded JSON array

    // - generates '[{rec1},{rec2},...]' using a loop similar to:

    // ! while FillOne do .. AppendJsonObject() ..

    // - if FieldName is set, the JSON array will be written as a JSON property,

    // i.e. surrounded as '"FieldName":[....],' - note the ',' at the end

    // - by default, will append the simple fields, unless the Fields optional

    // parameter is customized to a non void value

    // - see also TSQLRest.AppendListAsJsonArray for a high-level wrapper method

    procedure AppendFillAsJsonArray(const FieldName: RawUTF8;

       W: TJSONSerializer; Fields: TSQLFieldBits=[]);

    /// change TDocVariantData.Options for all variant published fields

    // - may be used to replace e.g. JSON_OPTIONS_FAST_EXTENDED by JSON_OPTIONS_FAST

    procedure ForceVariantFieldsOptions(aOptions: TDocVariantOptions=JSON_OPTIONS_FAST);

    /// write the field values into the binary buffer

    // - won't write the ID field (should be stored before, with the Count e.g.)

    procedure GetBinaryValues(W: TFileBufferWriter); overload;

    /// write the field values into the binary buffer

    // - won't write the ID field (should be stored before, with the Count e.g.)

    procedure GetBinaryValues(W: TFileBufferWriter; const aFields: TSQLFieldBits); overload;

    /// write the simple field values (excluding ID) into the binary buffer

    procedure GetBinaryValuesSimpleFields(W: TFileBufferWriter);

    /// set the field values from a binary buffer

    // - won't read the ID field (should be read before, with the Count e.g.)

    // - returns true on success, or false in case of invalid content in P^ e.g.

    // - P is updated to the next pending content after the read values

    function SetBinaryValues(var P: PAnsiChar): Boolean;

    /// set the simple field values from a binary buffer

    // - won't read the ID field (should be read before, with the Count e.g.)

    // - returns true on success, or false in case of invalid content in P^ e.g.

    // - P is updated to the next pending content after the read values

    function SetBinaryValuesSimpleFields(var P: PAnsiChar): Boolean;

    /// write the record fields into RawByteString a binary buffer

    // - same as GetBinaryValues(), but also writing the ID field first

    function GetBinary: RawByteString;

    /// set the record fields from a binary buffer saved by GetBinary()

    // - same as SetBinaryValues(), but also reading the ID field first

    function SetBinary(P: PAnsiChar): Boolean;

    /// set all field values from a supplied array of TSQLVar values

    // - Values[] array must match the RecordProps.Field[] order: will return

    // false if the Values[].VType does not match RecordProps.FieldType[]

    function SetFieldSQLVars(const Values: TSQLVarDynArray): boolean;

    /// retrieve a field value from a given property name, as encoded UTF-8 text

    // - you should use strong typing and direct property access, following

    // the ORM approach of the framework; but in some cases (a custom Grid

    // display, for instance), it could be useful to have this method available

    // - will return '' in case of wrong property name

    // - BLOB and dynamic array fields are returned as '\uFFF0base64encodedbinary'

    function GetFieldValue(const PropName: RawUTF8): RawUTF8;

    /// set a field value of a given property name, from some encoded UTF-8 text

    // - you should use strong typing and direct property access, following

    // the ORM approach of the framework; but in some cases (a custom Grid

    // display, for instance), it could be useful to have this method available

    // - won't do anything in case of wrong property name

    // - expect BLOB and dynamic array fields encoded as SQlite3 BLOB literals

    // ("x'01234'" e.g.) or '\uFFF0base64encodedbinary'

    procedure SetFieldValue(const PropName: RawUTF8; Value: PUTF8Char);

    {$ifndef NOVARIANTS}

    /// retrieve the record content as a TDocVariant custom variant object

    function GetAsDocVariant(withID: boolean; const withFields: TSQLFieldBits;

      options: PDocVariantOptions=nil): variant; overload;

      {$ifdef HASINLINE}inline;{$endif}

    /// retrieve the record content as a TDocVariant custom variant object

    procedure GetAsDocVariant(withID: boolean; const withFields: TSQLFieldBits;

      var result: variant; options: PDocVariantOptions=nil); overload;

    /// retrieve the simple record content as a TDocVariant custom variant object

    function GetSimpleFieldsAsDocVariant(withID: boolean=true;

      options: PDocVariantOptions=nil): variant;

    /// retrieve the published property value into a Variant

    // - will set the Variant type to the best matching kind according to the

    // property type

    // - will return a null variant in case of wrong property name

    // - BLOB fields are returned as SQlite3 BLOB literals ("x'01234'" e.g.)

    // - dynamic array fields are returned as a Variant array

    function GetFieldVariant(const PropName: string): Variant;

    /// set the published property value from a Variant value

    // - will convert from the variant type into UTF-8 text before setting the

    // value (so will work with any kind of Variant)

    // - won't do anything in case of wrong property name

    // - expect BLOB fields encoded as SQlite3 BLOB literals ("x'01234'" e.g.)

    procedure SetFieldVariant(const PropName: string; const Source: Variant);

    {$endif}



    /// prepare to get values from a TSQLTable result

    // - then call FillRow(1..Table.RowCount) to get any row value

    // - or you can also loop through all rows with

    // ! while Rec.FillOne do

    // !   dosomethingwith(Rec);

    // - the specified TSQLTable is stored in an internal fTable protected field

    // - set aCheckTableName if you want e.g. the Field Names from the Table

    // any pending 'TableName.' trimmed before matching to the current record

    procedure FillPrepare(Table: TSQLTable; aCheckTableName: TSQLCheckTableName=ctnNoCheck); overload;

    /// prepare to get values from a SQL where statement

    // - returns true in case of success, false in case of an error during SQL request

    // - then call FillRow(1..Table.RowCount) to get any row value

    // - or you can also loop through all rows with

    // ! while Rec.FillOne do

    // !   dosomethingwith(Rec);

    // - a temporary TSQLTable is created then stored in an internal fTable protected field

    // - if aSQLWhere is left to '', all rows are retrieved as fast as possible

    // (e.g. by-passing SQLite3 virtual table modules for external databases)

    // - the WHERE clause should use inlined parameters (like 'Name=:('Arnaud'):')

    // for better server speed - note that you can use FormatUTF8() as such:

    // ! aRec.FillPrepare(Client,FormatUTF8('Salary>? AND Salary<?',[],[1000,2000]));

    // or call the overloaded FillPrepare() method directly with  BoundsSQLWhere

    // array of parameters

    // - aCustomFieldsCSV can be used to specify which fields must be retrieved

    // - default aCustomFieldsCSV='' will retrieve all simple table fields, but

    // you may need  to access only one or several fields, and will save remote

    // bandwidth by specifying the needed fields

    // - if aCustomFieldsCSV='*', it will retrieve all fields, including BLOBs

    // - note that you should not use this aCustomFieldsCSV optional parameter if

    // you want to Update the retrieved record content later, since any

    // missing fields will be left with previous values - but BatchUpdate() can be

    // safely used after FillPrepare (will set only ID, TModTime and mapped fields)

    function FillPrepare(aClient: TSQLRest; const aSQLWhere: RawUTF8='';

      const aCustomFieldsCSV: RawUTF8=''; aCheckTableName: TSQLCheckTableName=ctnNoCheck): boolean; overload;

    /// prepare to get values using a specified WHERE clause with '%' parameters

    // - returns true in case of success, false in case of an error during SQL request

    // - then call FillRow(1..Table.RowCount) to get any row value

    // - or you can also loop through all rows with

    // ! while Rec.FillOne do

    // !   dosomethingwith(Rec);

    // - a temporary TSQLTable is created then stored in an internal fTable protected field

    // - for better server speed, the WHERE clause should use bound parameters

    // identified as '?' in the FormatSQLWhere statement, which is expected to

    // follow the order of values supplied in BoundsSQLWhere open array - use

    // DateToSQL/DateTimeToSQL for TDateTime, or directly any integer / double /

    // currency / RawUTF8 values to be bound to the request as parameters

    // - note that this method prototype changed with revision 1.17 of the

    // framework: array of const used to be ParamsSQLWhere and '%' in the

    // FormatSQLWhere statement, whereas it now expects bound parameters as '?'

    // - aCustomFieldsCSV can be used to specify which fields must be retrieved

    // - default aCustomFieldsCSV='' will retrieve all simple table fields, but

    // you may need  to access only one or several fields, and will save remote

    // bandwidth by specifying the needed fields

    // - if aCustomFieldsCSV='*', it will retrieve all fields, including BLOBs

    // - note that you should not use this aCustomFieldsCSV optional parameter if

    // you want to Update the retrieved record content later, since any

    // missing fields will be left with previous values - but BatchUpdate() can be

    // safely used after FillPrepare (will set only ID, TModTime and mapped fields)

    function FillPrepare(aClient: TSQLRest; const FormatSQLWhere: RawUTF8;

      const BoundsSQLWhere: array of const; const aCustomFieldsCSV: RawUTF8=''): boolean; overload;

    /// prepare to get values using a specified WHERE clause with '%' and '?' parameters

    // - returns true in case of success, false in case of an error during SQL request

    // - then call FillRow(1..Table.RowCount) to get any row value

    // - or you can also loop through all rows with

    // ! while Rec.FillOne do

    // !   dosomethingwith(Rec);

    // - a temporary TSQLTable is created then stored in an internal fTable

    // protected field

    // - the FormatSQLWhere clause will replace all '%' chars with the supplied

    // ParamsSQLWhere[] supplied values, and bind all '?' chars as bound

    // parameters with BoundsSQLWhere[] values

    // - aCustomFieldsCSV can be used to specify which fields must be retrieved

    // - default aCustomFieldsCSV='' will retrieve all simple table fields, but

    // you may need  to access only one or several fields, and will save remote

    // bandwidth by specifying the needed fields

    // - if aCustomFieldsCSV='*', it will retrieve all fields, including BLOBs

    // - note that you should not use this aCustomFieldsCSV optional parameter if

    // you want to Update the retrieved record content later, since any

    // missing fields will be left with previous values - but BatchUpdate() can be

    // safely used after FillPrepare (will set only ID, TModTime and mapped fields)

    function FillPrepare(aClient: TSQLRest; const FormatSQLWhere: RawUTF8;

      const ParamsSQLWhere, BoundsSQLWhere: array of const;

      const aCustomFieldsCSV: RawUTF8=''): boolean; overload;

    /// prepare to get values from a list of IDs

    // - returns true in case of success, false in case of an error during SQL request

    // - then call FillRow(1..Table.RowCount) to get any row value

    // - or you can also loop through all rows with

    // ! while Rec.FillOne do

    // !   dosomethingwith(Rec);

    // - a temporary TSQLTable is created then stored in an internal fTable protected field

    // - aCustomFieldsCSV can be used to specify which fields must be retrieved

    // - default aCustomFieldsCSV='' will retrieve all simple table fields, but

    // you may need  to access only one or several fields, and will save remote

    // bandwidth by specifying the needed fields

    // - if aCustomFieldsCSV='*', it will retrieve all fields, including BLOBs

    // - note that you should not use this aCustomFieldsCSV optional parameter if

    // you want to Update the retrieved record content later, since any

    // missing fields will be left with previous values - but BatchUpdate() can be

    // safely used after FillPrepare (will set only ID, TModTime and mapped fields)

    function FillPrepare(aClient: TSQLRest; const aIDs: array of Int64;

      const aCustomFieldsCSV: RawUTF8=''): boolean; overload;

    // / prepare to loop through a JOINed statement including TSQLRecordMany fields

    // - all TSQLRecordMany.Dest published fields will now contain a true TSQLRecord

    // instance, ready to be filled with the JOINed statement results (these

    // instances will be released at FillClose) - the same for Source which will

    // point to the self instance

    // - the aFormatSQLJoin clause will define a WHERE clause for an automated

    // JOINed statement, including TSQLRecordMany published properties (and

    // their nested properties)

    // - returns true in case of success, false in case of an error during SQL request

    // - a typical use could be the following:

    // ! if aProd.FillPrepareMany(Database,

    // !    'Owner=? and Categories.Dest.Name=? and (Sizes.Dest.Name=? or Sizes.Dest.Name=?)',[],

    // !    ['mark','for boy','small','medium']) then

    // !   while aProd.FillOne do

    // !     //  here e.g. aProd.Categories.Dest are instantied (and Categories.Source=aProd)

    // !     writeln(aProd.Name,' ',aProd.Owner,' ',aProd.Categories.Dest.Name,' ',aProd.Sizes.Dest.Name);

    // !   //  you may also use aProd.FillTable to fill a grid, e.g.

    // !   //  (do not forget to set aProd.FillTable.OwnerMustFree := false)

    // this will execute a JOINed SELECT statement similar to the following:

    // $ select p.*, c.*, s.*

    // $ from Product p, Category c, Categories cc, Size s, Sizes ss

    // $ where c.id=cc.dest and cc.source=p.id and

    // $  s.id=ss.dest and ss.source=p.id and

    // $  p.Owner='mark' and c.Name='for boy' and (s.Name='small' or s.Name='medium')

    // - the FormatSQLWhere clause will replace all '%' chars with the supplied

    // ParamsSQLWhere[] supplied values, and bind all '?' chars as parameters

    // with BoundsSQLWhere[] values

    // - you SHALL call explicitely the FillClose method before using any

    // methods of nested TSQLRecordMany instances which may override the Dest

    // instance content (e.g. ManySelect) to avoid any GPF

    // - is used by TSQLRecord.CreateAndFillPrepareMany constructor

    function FillPrepareMany(aClient: TSQLRest; const aFormatSQLJoin: RawUTF8;

      const aParamsSQLJoin, aBoundsSQLJoin: array of const): boolean;

    /// compute a JOINed statement including TSQLRecordMany fields

    // - is called by FillPrepareMany() to retrieve the JSON of the corresponding

    // request: so you could use this method to retrieve directly the same

    // information, ready to be transmitted (e.g. as RawJSON) to a client

    function EnginePrepareMany(aClient: TSQLRest; const aFormatSQLJoin: RawUTF8;

      const aParamsSQLJoin, aBoundsSQLJoin: array of const;

      out ObjectsClass: TSQLRecordClassDynArray; out SQL: RawUTF8): RawUTF8;

    /// fill all published properties of an object from a TSQLTable prepared row

    // - FillPrepare() must have been called before

    // - if Dest is nil, this object values are filled

    // - if Dest is not nil, this object values will be filled, but it won't

    // work with TSQLRecordMany properties (i.e. after FillPrepareMany call)

    // - ID field is updated if first Field Name is 'ID'

    // - Row number is from 1 to Table.RowCount

    // - setter method (write Set*) is called if available

    // - handle UTF-8 SQL to Delphi values conversion (see TPropInfo mapping)

    // - this method has been made virtual e.g. so that a calculated value can be

    // used in a custom field

    function FillRow(aRow: integer; aDest: TSQLRecord=nil): boolean; virtual;

    /// fill all published properties of this object from the next available

    // TSQLTable prepared row

    // - FillPrepare() must have been called before

    // - the Row number is taken from property FillCurrentRow

    // - return true on success, false if no more Row data is available

    // - internally call FillRow() to update published properties values

    function FillOne: boolean;

    /// go to the first prepared row, ready to loop through all rows with FillOne()

    // - the Row number (property FillCurrentRow) is reset to 1

    // - return true on success, false if no Row data is available

    // - you can use it e.g. as:

    // ! while Rec.FillOne do

    // !   dosomethingwith(Rec);

    // ! if Rec.FillRewind then

    // !   while Rec.FillOne do

    // !     dosomeotherthingwith(Rec);

    function FillRewind: boolean;

    /// close any previous FillPrepare..FillOne loop

    // - is called implicitely by FillPrepare() call to release any previous loop

    // - release the internal hidden TSQLTable instance if necessary

    // - is not mandatory if the TSQLRecord is released just after, since

    // TSQLRecord.Destroy will call it

    // - used e.g. by FillFrom methods below to avoid any GPF/memory confusion

    procedure FillClose;

    /// will iterate over all FillPrepare items, appending them as a JSON array

    // - creates a JSON array of all record rows, using

    // ! while FillOne do GetJSONValues(W)...

    procedure AppendFillAsJsonValues(W: TJSONSerializer);



    /// fill all published properties of this object from a TSQLTable result row

    // - call FillPrepare() then FillRow(Row)

    procedure FillFrom(Table: TSQLTable; Row: integer); overload;

    /// fill all published properties of this object from a JSON result row

    // - create a TSQLTable from the JSON data

    // - call FillPrepare() then FillRow(Row)

    procedure FillFrom(const JSONTable: RawUTF8; Row: integer); overload;

    /// fill all published properties of this object from a JSON object result

    // - use JSON data, as exported by GetJSONValues()

    // - JSON data may be expanded or not

    // - make an internal copy of the JSONTable RawUTF8 before calling

    // FillFrom() below

    // - if FieldBits is defined, it will store the identified field index

    procedure FillFrom(const JSONRecord: RawUTF8; FieldBits: PSQLFieldBits=nil); overload;

    /// fill all published properties of this object from a JSON result

    // - the data inside P^ is modified (unescaped and transformed): don't call

    // FillFrom(pointer(JSONRecordUTF8)) but FillFrom(JSONRecordUTF8) which makes

    // a temporary copy of the JSONRecordUTF8 text

    // - use JSON data, as exported by GetJSONValues()

    // - JSON data may be expanded or not

    // - if FieldBits is defined, it will store the identified field index

    procedure FillFrom(P: PUTF8Char; FieldBits: PSQLFieldBits=nil); overload;

    /// fill all published properties of this object from another object

    // - source object must be a parent or of the same class as the current record

    // - copy all COPIABLE_FIELDS, i.e. all fields excluding tftMany (because

    // those fields don't contain any data, but a TSQLRecordMany instance

    // which allow to access to the pivot table data)

    procedure FillFrom(aRecord: TSQLRecord); overload;

    /// fill the specified properties of this object from another object

    // - source object must be a parent or of the same class as the current record

    // - copy the fields, as specified by their bit index in the source record

    procedure FillFrom(aRecord: TSQLRecord; const aRecordFieldBits: TSQLFieldBits); overload;

    {$ifndef NOVARIANTS}

    /// fill all published properties of this object from a supplied TDocVariant

    // object document

    // - is a wrapper around VariantSaveJSON() + FillFrom() methods

    procedure FillFrom(const aDocVariant: variant); overload;

    {$endif}

    /// fill a published property value of this object from a UTF-8 encoded value

    // - see TPropInfo about proper Delphi / UTF-8 type mapping/conversion

    // - use this method to fill a BLOB property, i.e. a property defined with

    // type TSQLRawBlob, since by default all BLOB properties are not

    // set by the standard Retrieve() method (to save bandwidth)

    // - if FieldBits is defined, it will store the identified field index

    procedure FillValue(PropName, Value: PUTF8Char; wasString: boolean;

      FieldBits: PSQLFieldBits=nil);



    /// return true if all published properties values in Other are identical to

    // the published properties of this object

    // - work with different classes: Reference properties name must just be

    // present in the calling object

    // - only simple fields (i.e. not TSQLRawBlob/TSQLRecordMany) are compared

    // - compare the text representation of the values: fields may be of different

    // type, encoding or precision, but still have same values

    function SameValues(Reference: TSQLRecord): boolean;

    /// return true if all published properties values in Other are identical to

    // the published properties of this object

    // - instances must be of the same class type

    // - only simple fields (i.e. not TSQLRawBlob/TSQLRecordMany) are compared

    // - comparaison is much faster than SameValues() above

    function SameRecord(Reference: TSQLRecord): boolean;

    /// clear the values of all published properties, and also the ID property

    procedure ClearProperties; overload;

    /// clear the values of specified published properties

    // - '' would leave the content untouched, '*' will clear all simple fields

    procedure ClearProperties(const aFieldsCSV: RawUTF8); overload;

    /// set the simple fields with the supplied values

    // - the aSimpleFields parameters must follow explicitely the order of published

    // properties of the supplied aTable class, excepting the TSQLRawBlob and

    // TSQLRecordMany kind (i.e. only so called "simple fields") - in particular,

    // parent properties must appear first in the list

    // - the aSimpleFields must have exactly the same count of parameters as there are

    // "simple fields" in the published properties

    // - return true on success, but be aware that the field list must match

    // the field layout, otherwise if may return true but will corrupt data

    function SimplePropertiesFill(const aSimpleFields: array of const): boolean;

    /// initialize a TDynArray wrapper to map dynamic array property values

    // - if the field name is not existing or not a dynamic array, result.IsVoid

    // will be TRUE

    function DynArray(const DynArrayFieldName: RawUTF8): TDynArray; overload;

    /// initialize a TDynArray wrapper to map dynamic array property values

    // - this overloaded version expect the dynamic array to have been defined

    // with a not null index attribute, e.g.

    // ! published

    // !   property Ints: TIntegerDynArray index 1 read fInts write fInts;

    // !   property Currency: TCurrencyDynArray index 2 read fCurrency write fCurrency;

    // - if the field index is not existing or not a dynamic array, result.IsVoid

    // will be TRUE

    function DynArray(DynArrayFieldIndex: integer): TDynArray; overload;



    /// this property stores the record's integer ID

    // - if this TSQLRecord is not a instance, but a field value in a published

    //  property of type sftID (i.e. TSQLRecord(aID)), this method will try

    //  to retrieve it; but prefered method is to typecast it via PtrInt(aProperty),

    //  because GetID() relies on some low-level Windows memory mapping trick, and

    //  will recognize an ID value up to 1,048,576 (i.e. $100000)

    // - notice: the Setter should not be used usualy; you should not have to write

    //  aRecord.ID := someID in your code, since the ID is set during Retrieve or

    //  Add of the record

    property ID: TID read GetID;

    /// this property gives direct access to the record's integer ID

    // - using IDValue expects this TSQLRecord to be a true instance, not a

    // transtyped sftID (i.e. TSQLRecord(aID))

    property IDValue: TID read fID write fID;

    /// this read-only property can be used to retrieve the ID as a TSQLRecord object

    // - published properties of type TSQLRecord (one-to-many relationship) do not

    // store real class instances (only exception is if they inherit from

    // TSQLRecordMany) - you can use this value to assign a TSQLRecord instance

    // to a published property, as such:

    // ! Main := TSQLRecordMain.Create;

    // ! Client.Add(Main);

    // ! Detail := TSQLRecordDetail.Create;

    // ! Detail.Main := Main.AsTSQLRecord; // will store Main.ID in MAIN column

    // ! Client.Add(Detail);

    // - is especially useful on 64-bit plaform, since on 32 bit:

    // ! Detail.Main := pointer(Main.ID)

    // compiles (whereas it won't on 64-bit) and is the same than platform-independent

    // ! Detail.Main := Main.AsTSQLRecord;

    // - using Main.AsTSQLRecord will ensure that the ID is retrieved, even

    // if Main itself is not a true instance

    // - if the stored ID is bigger than 32 bits, then it would raise an

    // EORMException: in this case, you should use a TID / T*ID kind of

    // published property, and not a TSQLRecord, which is limited to the

    // pointer size 

    property AsTSQLRecord: pointer read GetIDAsPointer;

    /// this property is set to true, if any published property is a BLOB (TSQLRawBlob)

    property HasBlob: boolean read GetHasBlob;

    /// this property returns the published property count with any valid

    // database field except TSQLRawBlob/TSQLRecordMany

    // - by default, the TSQLRawBlob (BLOB) fields are not included into this set:

    // they must be read specificaly (in order to spare bandwidth)

    // - TSQLRecordMany fields are not accessible directly, but as instances

    // created by TSQLRecord.Create

    property SimpleFieldCount: integer read GetSimpleFieldCount;

    /// this property contains the TSQLTable after a call to FillPrepare()

    property FillTable: TSQLTable read GetTable;

    /// this property contains the current row number (beginning with 1),

    // initialized to 1 by FillPrepare(), which will be read by FillOne

    property FillCurrentRow: integer read GetFillCurrentRow;

    /// used internally by FillPrepare() and corresponding Fill*() methods

    property FillContext: TSQLRecordFill read fFill;

    /// this property contains the internal state counter of the server database

    // when the data was retrieved from it

    // - can be used to check if retrieved data may be out of date

    property InternalState: cardinal read fInternalState;

  published

    { published properties in inherited classes will be interpreted as SQL fields }

  end;



  /// allow on-the-fly translation of a TSQLTable grid value

  // - should return valid JSON value of the given cell (i.e. quoted strings,

  // or valid JSON object/array)

  // - e.g. TSQLTable.OnExportValue property will customize TSQLTable's

  // GetJSONValues, GetHtmlTable, and GetCSVValues methods returned content

  TOnSQLTableGetValue = function(Sender: TSQLTable; Row, Field: integer): RawJSON of object;



  /// wrapper to an ORM result table, staticaly stored as UTF-8 text

  // - contain all result in memory, until destroyed

  // - first row contains the field names

  // - following rows contains the data itself

  // - GetString() can be used in a TDrawString

  // - will be implemented as TSQLTableJSON for remote access through optimized

  // JSON content

  TSQLTable = class

  protected

    fRowCount: integer;

    fFieldCount: integer;

    /// contains the data, as returned by sqlite3_get_table()

    fResults: PPUTF8CharArray;

    /// contains the TSQLFieldType and TypeInfo(enumerate), after calculation

    // from the fQueryTables values

    fFieldType: array of record

      // the field kind, as in JSON (match TSQLPropInfo.SQLFieldTypeStored)

      ContentType: TSQLFieldType;

      // the field size in bytes; -1 means not computed yet

      ContentSize: integer;

      // used for sftEnumerate, sftSet and sftBlobDynArray fields

      ContentTypeInfo: pointer;

      // the corresponding index in fQueryTables[]

      TableIndex: integer;

    end;

    fFieldTypeAllRows: boolean;

    /// the field names

    fFieldNames: TRawUTF8DynArray;

    /// used by FieldIndex() for fast binary search

    fFieldNameOrder: TCardinalDynArray;

    /// contain the fResults[] pointers, after a IDColumnHide() call

    fIDColumn, fNotIDColumn: array of PUTF8Char;

    /// index of a 'ID' field, -1 if none (e.g. after IDColumnHide method call)

    fFieldIndexID: integer;

    /// the internal state counter of the database when the data was retrieved

    fInternalState: cardinal;

    /// contains the parameters used for sorting

    fSortParams: TSQLTableSortParams;

    /// contains the TSQLRecord instances created by NewRecord method

    fOwnedRecords: TObjectList;

    /// if the TSQLRecord is the owner of this table, i.e. if it must free it

    fOwnerMustFree: Boolean;

    /// current cursor row (1..RowCount), as set by the Step() method

    fStepRow: integer;

    /// information about the Query sourcing this result set

    fQueryTables: TSQLRecordClassDynArray;

    fQueryColumnTypes: array of TSQLFieldType;

    fQuerySQL: RawUTF8;

    fQueryTableNameFromSQL: RawUTF8;

    fQueryTableIndexFromSQL: integer; // -2=nosearch -1=notfound fQueryTables[0..n]

    /// field length information

    fFieldLengthMean: TIntegerDynArray;

    fFieldLengthMeanSum: integer;

    /// column bit set at parsing to mark a string value (e.g. "..." in JSON)

    fFieldParsedAsString: set of 0..255;

    fOnExportValue: TOnSQLTableGetValue;

    /// avoid GPF when TSQLTable is nil

    function GetRowCount: integer; {$ifdef HASINLINE}inline;{$endif}

    /// fill the fFieldType[] array (from fQueryTables[] or fResults[] content)

    procedure InitFieldTypes;

    /// fill the internal fFieldNames[] array

    procedure InitFieldNames;

    /// guess the property type information from ORM 

    function FieldPropFromTables(const PropName: RawUTF8;

      out PropInfo: TSQLPropInfo; out TableIndex: integer): TSQLFieldType;

    function GetQueryTableNameFromSQL: RawUTF8;

  public

    /// initialize the result table

    // - you can optionaly associate the corresponding TSQLRecordClass types,

    // by which the results were computed (it will use RTTI for column typing)

    constructor Create(const aSQL: RawUTF8);

    /// initialize the result table

    // - you can associate the corresponding TSQLRecordClass types,

    // by which the results were computed (it will use RTTI for column typing)

    constructor CreateFromTables(const Tables: array of TSQLRecordClass; const aSQL: RawUTF8);

    /// initialize the result table

    // - you can set the expected column types matching the results column layout

    constructor CreateWithColumnTypes(const ColumnTypes: array of TSQLFieldType; const aSQL: RawUTF8);

    /// free associated memory and owned records

    destructor Destroy; override;

    /// read-only access to a particular field value, as UTF-8 encoded buffer

    // - if Row and Fields are correct, returns a pointer to the UTF-8 buffer,

    // or nil if the corresponding JSON was null or ""

    // - if Row and Fields are not correct, returns nil

    function Get(Row,Field: integer): PUTF8Char; overload;

      {$ifdef HASINLINE}inline;{$endif}

    /// read-only access to a particular field value, as RawUTF8 text

    function GetU(Row,Field: integer): RawUTF8; overload;

    /// read-only access to a particular field value, as UTF-8 encoded buffer

    // - points to memory buffer allocated by Init()

    function Get(Row: integer; const FieldName: RawUTF8): PUTF8Char; overload;

    /// read-only access to a particular field value, as RawUTF8 text

    function GetU(Row: integer; const FieldName: RawUTF8): RawUTF8; overload;

    /// read-only access to a particular field value, as Win Ansi text

    function GetA(Row,Field: integer): WinAnsiString;

    /// read-only access to a particular field value, as Win Ansi text shortstring

    function GetS(Row,Field: integer): shortstring;

    {$ifndef NOVARIANTS}

    /// read-only access to a particular field value, as a Variant

    // - text will be stored as RawUTF8 (as varString type)

    // - will try to use the most approriate Variant type for conversion (will

    // use e.g. TDateTime for sftDateTime, or a TDocVariant for JSON objects

    // in a sftVariant column) - so you should better set the exact field types

    // (e.g. from ORM) before calling this method

    function GetVariant(Row,Field: integer; Client: TObject): variant; overload;

    /// read-only access to a particular field value, as a Variant

    // - text will be stored as RawUTF8 (as varString type)

    // - will try to use the most approriate Variant type for conversion (will

    // use e.g. TDateTime for sftDateTime, or a TDocVariant for JSON objects

    // in a sftVariant column) - so you should better set the exact field types

    // (e.g. from ORM) before calling this method

    procedure GetVariant(Row,Field: integer; Client: TObject; var result: variant); overload;

    /// read-only access to a particular field, via a lookup field name

    // - will call GetVariant() on the corresponding field

    // - returns null if the lookup did not have any match

    function GetValue(const aLookupFieldName,aLookupValue,aValueFieldName: RawUTF8): variant;

    {$endif}

    /// read-only access to a particular field value, as VCL string text

    // - the global UTF8ToString() function will be used for the conversion:

    // for proper i18n handling before Delphi 2009, you should use the

    // overloaded method with aUTF8ToString=Language.UTF8ToString

    function GetString(Row,Field: integer): string;

    /// read-only access to a particular field value, as fast Unicode string text

    // - SynUnicode is either WideString, either UnicodeString, depending on the

    // Delphi compiler revision, to ensure fastest native Unicode process available

    function GetSynUnicode(Row,Field: integer): SynUnicode;

    /// fill a unicode buffer with a particular field value

    // - return number of wide characters written in Dest^

    function GetWP(Row,Field: integer; Dest: PWideChar; MaxDestChars: cardinal): integer;

    /// read-only access to a particular field value, as UTF-16 Unicode text

    // - Raw Unicode is WideChar(zero) terminated

    // - its content is allocated to contain all WideChars (not trimed to 255,

    // like GetWP() above

    function GetW(Row,Field: integer): RawUnicode;

    /// read-only access to a particular field value, as integer value

    function GetAsInteger(Row,Field: integer): integer; overload;

      {$ifdef HASINLINE}inline;{$endif}

    /// read-only access to a particular field value, as integer value

    function GetAsInteger(Row: integer; const FieldName: RawUTF8): integer; overload;

      {$ifdef HASINLINE}inline;{$endif}

    /// read-only access to a particular field value, as Int64 value

    function GetAsInt64(Row,Field: integer): Int64; overload;

      {$ifdef HASINLINE}inline;{$endif}

    /// read-only access to a particular field value, as Int64 value

    function GetAsInt64(Row: integer; const FieldName: RawUTF8): Int64; overload;

      {$ifdef HASINLINE}inline;{$endif}

    /// read-only access to a particular field value, as extended value

    function GetAsFloat(Row,Field: integer): TSynExtended; overload;

      {$ifdef HASINLINE}inline;{$endif}

    /// read-only access to a particular field value, as extended value

    function GetAsFloat(Row: integer; const FieldName: RawUTF8): TSynExtended; overload;

      {$ifdef HASINLINE}inline;{$endif}

    /// read-only access to a particular field value, as TDateTime value

    // - explicit sftDateTime will be converted from ISO-8601 text

    // - sftTimeLog, sftModTime, sftCreateTime will expect the content to be

    // encoded as a TTimeLog Int64 value - as sftInteger may have been

    // identified by TSQLTable.InitFieldTypes

    // - for sftTimeLog, sftModTime, sftCreateTime fields, you may have to force

    // the column type, since it may be identified as sftInteger or sftCurrency

    // by default from its JSON number content, e.g. via:

    // ! aTable.SetFieldType('FieldName',sftModTime);

    // - sftCurrency,sftFloat will return the corresponding double value

    // - any other types will try to convert ISO-8601 text }

    function GetAsDateTime(Row,Field: integer): TDateTime; overload;

    /// read-only access to a particular field value, as TDateTime value

    function GetAsDateTime(Row: integer; const FieldName: RawUTF8): TDateTime; overload;

    /// read-only access to a particular field value, as currency value

    function GetAsCurrency(Row,Field: integer): currency; overload;

      {$ifdef HASINLINE}inline;{$endif}

    /// read-only access to a particular field value, as currency value

    function GetAsCurrency(Row: integer; const FieldName: RawUTF8): currency; overload;

      {$ifdef HASINLINE}inline;{$endif}

    /// read-only access to a particular field value, ready to be displayed

    // - mostly used with Row=0, i.e. to get a display value from a field name

    // - use "string" type, i.e. UnicodeString for Delphi 2009+

    // - value is first un-camel-cased: 'OnLine' value will return 'On line' e.g.

    // - then System.LoadResStringTranslate() is called if available

    function GetCaption(Row,Field: integer): string;

    /// read-only access to a particular Blob value

    // - a new TSQLRawBlob is created

    // - Blob data is converted from SQLite3 BLOB literals (X'53514C697465' e.g.)

    // or Base-64 encoded content ('\uFFF0base64encodedbinary')

    // - prefered manner is to directly use REST protocol to retrieve a blob field

    function GetBlob(Row,Field: integer): TSQLRawBlob;

    /// read-only access to a particular Blob value

    // - a new TBytes is created

    // - Blob data is converted from SQLite3 BLOB literals (X'53514C697465' e.g.)

    //   or Base-64 encoded content ('\uFFF0base64encodedbinary')

    // - prefered manner is to directly use REST protocol to retrieve a blob field

    function GetBytes(Row,Field: integer): TBytes;

    /// read-only access to a particular Blob value

    // - a new TCustomMemoryStream is created - caller shall free its instance

    // - Blob data is converted from SQLite3 BLOB literals (X'53514C697465' e.g.)

    //   or Base-64 encoded content ('\uFFF0base64encodedbinary')

    // - prefered manner is to directly use REST protocol to retrieve a blob field

    function GetStream(Row,Field: integer): TStream;

    /// read-only access to a particular field value, as VCL text

    // - Client is one TSQLClient instance (used to display TRecordReference via

    // the associated TSQLModel)

    // - returns the Field Type

    // - return generic string Text, i.e. UnicodeString for Delphi 2009+,

    // ready to be displayed to the VCL, for sftEnumerate, sftTimeLog

    // and sftRecord/sftRecordVersion/sftID/sftTID

    // - returns '' as string Text, if text can by displayed directly

    // with Get*() methods above

    // - returns '' for other properties kind, if UTF8ToString is nil,

    // or the ready to be displayed value if UTF8ToString event is set

    // (to be used mostly with Language.UTF8ToString)

    // - CustomFormat can optionaly set a custom format string, e.g. '%f' or '%n'

    // or complex FormatFloat()/FormatCurr() syntax (as '#,##0.00') for sftFloat

    // and sftCurrency columns (instead of plain JSON float value), or

    // date/time format as expected by FormatDateTime() for all date time kind

    // of fields (as sftDateTime, sftTimeLog, sftModTime, sftCreateTime)

    function ExpandAsString(Row,Field: integer; Client: TObject; out Text: string;

      const CustomFormat: string=''): TSQLFieldType;

    /// read-only access to a particular field value, as VCL text

    // - this method is just a wrapper around ExpandAsString method, returning

    // the content as a SynUnicode string type (i.e. UnicodeString since Delphi

    // 2009, and WideString for non Unicode versions of Delphi)

    // - it is used by the reporting layers of the framework (e.g. TSQLRibbon.AddToReport)

    function ExpandAsSynUnicode(Row,Field: integer; Client: TObject; out Text: SynUnicode): TSQLFieldType;

    /// read-only access to a particular DateTime field value

    // - expect SQLite3 TEXT field in ISO 8601 'YYYYMMDD hhmmss' or

    // 'YYYY-MM-DD hh:mm:ss' format

    function GetDateTime(Row,Field: integer): TDateTime;

      {$ifdef PUREPASCAL} {$ifdef HASINLINE}inline;{$endif} {$endif}

    /// read-only access to a particular TTimeLog field value

    // - return the result as TTimeLogBits.Text() Iso-8601 encoded text

    function GetTimeLog(Row,Field: integer; Expanded: boolean; FirstTimeChar: AnsiChar = 'T'): RawUTF8;

    /// widechar length (UTF-8 decoded as UTF-16) of a particular field value

    // - could be used with VCL's UnicodeString, or for Windows API

    function LengthW(Row,Field: integer): integer;

    /// get all values for a specified field into a dynamic RawUTF8 array

    // - don't perform any conversion, but just create an array of raw PUTF8Char data

    procedure GetRowValues(Field: integer; out Values: TRawUTF8DynArray); overload;

    /// get all values for a specified field into a dynamic Integer array

    procedure GetRowValues(Field: integer; out Values: TInt64DynArray); overload;

    /// get all values for a specified field as CSV

    // - don't perform any conversion, but create a CSV from raw PUTF8Char data

    function GetRowValues(Field: integer; Sep: AnsiChar=','): RawUTF8; overload;

    {$ifndef NOVARIANTS}

    /// retrieve a field value in a variant

    // - returns null if the row/field is incorrect

    // - expand* methods would allow to return human-friendly representations 

    procedure GetAsVariant(row,field: integer; out value: variant;

      expandTimeLogAsText,expandEnumsAsText,expandHugeIDAsUniqueIdentifier: boolean;

      options: TDocVariantOptions=JSON_OPTIONS_FAST);

    /// retrieve a row value as a variant, ready to be accessed via late-binding

    // - Row parameter numbering starts from 1 to RowCount

    // - this method will return a TDocVariant containing a copy of all

    // field values of this row, uncoupled to the TSQLTable instance life time

    // - expand* methods would allow to return human-friendly representations 

    procedure ToDocVariant(Row: integer; out doc: variant;

      options: TDocVariantOptions=JSON_OPTIONS_FAST;

      expandTimeLogAsText: boolean=false; expandEnumsAsText: boolean=false;

      expandHugeIDAsUniqueIdentifier: boolean=false); overload;

    /// retrieve all row values as a dynamic array of variants, ready to be

    // accessed via late-binding

    // - if readonly is TRUE, will contain an array of TSQLTableRowVariant, which

    // will point directly to the TSQLTable, which should remain allocated

    // - if readonly is FALSE, will contain an array of TDocVariant, containing

    // a copy of all field values of this row, uncoupled to the TSQLTable instance

    // - readonly=TRUE is faster to allocate (around 4 times for 10,000 rows), but

    // may be slightly slower to access than readonly=FALSE, if all values are

    // likely be accessed later in the process

    procedure ToDocVariant(out docs: TVariantDynArray; readonly: boolean); overload;

    /// retrieve all row values as a TDocVariant of kind dvArray, ready to be

    // accessed via late-binding

    // - if readonly is TRUE, will contain an array of TSQLTableRowVariant, which

    // will point directly to the TSQLTable, which should remain allocated

    // - if readonly is FALSE, will contain an array of TDocVariant, containing

    // a copy of all field values of this row, uncoupled to the TSQLTable instance

    // - readonly=TRUE is faster to allocate (around 4 times for 10,000 rows), but

    // may be slightly slower to access than readonly=FALSE, if all values are

    // likely be accessed later in the process

    procedure ToDocVariant(out docarray: variant; readonly: boolean); overload;

      // {$ifdef HASINLINE}inline;{$endif} won't reset docarray as required

    {$endif NOVARIANTS}



    /// save the table values in JSON format

    // - JSON data is added to TStream, with UTF-8 encoding

    // - if Expand is true, JSON data is an array of objects, for direct use

    // with any Ajax or .NET client:

    // & [ {"col1":val11,"col2":"val12"},{"col1":val21,... ]

    // - if Expand is false, JSON data is serialized (used in TSQLTableJSON)

    // & { "fieldCount":1,"values":["col1","col2",val11,"val12",val21,..] }

    // - RowFirst and RowLast can be used to ask for a specified row extent

    // of the returned data (by default, all rows are retrieved)

    procedure GetJSONValues(JSON: TStream; Expand: boolean;

      RowFirst: integer=0; RowLast: integer=0); overload;

    /// same as the overloaded method, but returning result into a RawUTF8

    function GetJSONValues(Expand: boolean): RawUTF8; overload;

    /// same as the overloaded method, but appending an array to a TTextWriter

    // - will call W.FlushToStream, then append all content

    procedure GetJSONValues(W: TTextWriter; Expand: boolean;

      RowFirst: integer=0; RowLast: integer=0); overload;

    /// save the table as CSV format, into a stream

    // - if Tab=TRUE, will use TAB instead of ',' between columns

    // - you can customize the ',' separator - use e.g. the global ListSeparator

    // variable (from SysUtils) to reflect the current system definition (some

    // country use ',' as decimal separator, for instance our "douce France")

    // - AddBOM will add a UTF-8 Byte Order Mark at the beginning of the content

    procedure GetCSVValues(Dest: TStream; Tab: boolean; CommaSep: AnsiChar=',';

      AddBOM: boolean=false; RowFirst: integer=0; RowLast: integer=0); overload;

    /// save the table as CSV format, into a string variable

    // - if Tab=TRUE, will use TAB instead of ',' between columns

    // - you can customize the ',' separator - use e.g. the global ListSeparator

    // variable (from SysUtils) to reflect the current system definition (some

    // country use ',' as decimal separator, for instance our "douce France")

    // - AddBOM will add a UTF-8 Byte Order Mark at the beginning of the content

    function GetCSVValues(Tab: boolean; CommaSep: AnsiChar=',';

      AddBOM: boolean=false; RowFirst: integer=0; RowLast: integer=0): RawUTF8; overload;

    /// save the table in 'schemas-microsoft-com:rowset' XML format

    // - this format is used by ADODB.recordset, easily consummed by MS apps

    // - see @http://synopse.info/forum/viewtopic.php?pid=11691#p11691

    procedure GetMSRowSetValues(Dest: TStream; RowFirst,RowLast: integer); overload;

    /// save the table in 'schemas-microsoft-com:rowset' XML format

    // - this format is used by ADODB.recordset, easily consummed by MS apps

    // - see @http://synopse.info/forum/viewtopic.php?pid=11691#p11691

    function GetMSRowSetValues: RawUTF8; overload;

    /// save the table in Open Document Spreadsheet compressed format

    // - this is a set of XML files compressed in a zip container

    // - this method will return the raw binary buffer of the file

    // - see @http://synopse.info/forum/viewtopic.php?id=2133

    function GetODSDocument: RawByteString;

    /// append the table content as a HTML <table> ... </table>

    procedure GetHtmlTable(Dest: TTextWriter); overload;

    /// save the table as a <html><body><table> </table></body></html> content

    function GetHtmlTable(const Header: RawUTF8='<head><style>table,th,td'+

      '{border: 1px solid black;border-collapse: collapse;}th,td{padding: 5px;'+

      'font-family: sans-serif;}</style></head>'#10): RawUTF8; overload;

    /// get the Field index of a FieldName

    // - return -1 if not found, index (0..FieldCount-1) if found

    function FieldIndex(FieldName: PUTF8Char): integer; overload;

    /// get the Field index of a FieldName

    // - return -1 if not found, index (0..FieldCount-1) if found

    function FieldIndex(const FieldName: RawUTF8): integer; overload;

      {$ifdef HASINLINE}inline;{$endif}

    /// get the Field index of a FieldName

    // - raise an ESQLTableException if not found, index (0..FieldCount-1) if found

    function FieldIndexExisting(const FieldName: RawUTF8): integer; overload;

    /// get the Field indexes of several Field names

    // - could be used to speed-up field access in a TSQLTable loop, avoiding

    // a FieldIndex(aFieldName) lookup for each value

    // - return -1 in FieldIndexes[]^ if not found, index (0..FieldCount-1) if found

    procedure FieldIndex(const FieldNames: array of RawUTF8;

      const FieldIndexes: array of PInteger); overload;

    /// get the Field indexes of several Field names

    // - raise an ESQLTableException if not found

    // - set FieldIndexes[]^ to the index (0..FieldCount-1) if found

    // - could be used to speed-up field access in a TSQLTable loop, avoiding

    // a FieldIndex(aFieldName) lookup for each value, as such:

    //! list := TSQLTableJSON.Create('',pointer(json),length(json));

    //! list.FieldIndexExisting(

    //!   ['FirstName','LastName','YearOfBirth','YearOfDeath','RowID','Data'],

    //!   [@FirstName,@LastName,@YearOfBirth,@YearOfDeath,@RowID,@Data]);

    //! for i := 1 to list.RowCount do begin

    //!   Check(list.Get(i,FirstName)<>nil);

    //!   Check(list.Get(i,LastName)<>nil);

    //!   Check(list.GetAsInteger(i,YearOfBirth)<10000);

    procedure FieldIndexExisting(const FieldNames: array of RawUTF8;

      const FieldIndexes: array of PInteger); overload;

    /// retrieve all field names as a RawUTF8 dynamic array

    function FieldNames: TRawUTF8DynArray;

    /// get the Field content (encoded as UTF-8 text) from a property name

    // - return nil if not found

    function FieldValue(const FieldName: RawUTF8; Row: integer): PUTF8Char;

      {$ifdef HASINLINE}inline;{$endif}

    /// sort result Rows, according to a specific field

    // - default is sorting by ascending order (Asc=true)

    // - you can specify a Row index to be updated during the sort in PCurrentRow

    // - sort is very fast, even for huge tables (more faster than any indexed

    // SQL query): 500,000 rows are sorted instantly

    // - this optimized sort implementation does the comparaison first by the

    // designed field, and, if the field value is identical, the ID value is

    // used (it will therefore sort by time all identical values)

    procedure SortFields(Field: integer; Asc: boolean=true;

      PCurrentRow: PInteger=nil; FieldType: TSQLFieldType=sftUnknown;

      CustomCompare: TUTF8Compare=nil); overload;

    /// sort result Rows, according to a specific field

    // - overloaded method allowing to specify the field by its name

    procedure SortFields(const FieldName: RawUTF8; Asc: boolean=true;

      PCurrentRow: PInteger=nil; FieldType: TSQLFieldType=sftUnknown;

      CustomCompare: TUTF8Compare=nil); overload;

    /// sort result Rows, according to some specific fields

    // - is able to make multi-field sort

    // - both Fields[] and Asc[] array should have the same count, otherwise

    // default Asc[]=true value will be assumed

    // - set any Fields[]=-1 to identify the ID column (even if is hidden)

    procedure SortFields(const Fields: array of integer;

      const Asc: array of boolean); overload;

    /// sort result Rows, according to the Bits set to 1 first

    procedure SortBitsFirst(var Bits);

    /// guess the field type from first non null data row

    // - if QueryTables[] are set, exact field type and enumerate TypeInfo() is

    // retrieved from the Delphi RTTI; otherwise, get from the cells content

    // - return sftUnknown is all data fields are null

    // - sftBlob is returned if the field is encoded as SQLite3 BLOB literals

    // (X'53514C697465' e.g.)

    // - since TSQLTable data is PUTF8Char, string type is sftUTF8Text only

    function FieldType(Field: integer): TSQLFieldType; overload;

    /// guess the field type from first non null data row

    // - if QueryTables[] are set, exact field type and (enumerate) TypeInfo() is

    // retrieved from the Delphi RTTI; otherwise, get from the cells content

    // - return sftUnknown is all data fields are null

    // - sftBlob is returned if the field is encoded as SQLite3 BLOB literals

    // (X'53514C697465' e.g.)

    // - since TSQLTable data is PUTF8Char, string type is sftUTF8Text only

    function FieldType(Field: integer; OutFieldTypeInfo: PPointer): TSQLFieldType; overload;

    /// get the appropriate Sort comparaison function for a field,

    // nil if not available (bad field index or field is blob)

    // - field type is guessed from first data row

    function SortCompare(Field: integer): TUTF8Compare;

    /// get the mean of characters length of all fields

    // - the character length is for the first line of text only (stop counting

    // at every newline character, i.e. #10 or #13 char)

    // - return the sum of all mean of character lengths

    function CalculateFieldLengthMean(var aResult: TIntegerDynArray;

      FromDisplay: boolean=false): integer;

    /// get the mean of characters length of this field

    // - the character length is for the first line of text only (stop counting

    // at every newline character, i.e. #10 or #13 char)

    // - very fast: calculated only once for all fields

    function FieldLengthMean(Field: integer): cardinal;

    /// get the sum of all mean of characters length of all fields

    // - very fast: calculated only once for all fields

    function FieldLengthMeanSum: cardinal;

    /// get the maximum number of characters of this field

    function FieldLengthMax(Field: integer; NeverReturnsZero: boolean=false): cardinal;

    /// get the record class (i.e. the table) associated to a field

    // - is nil if this table has no QueryTables property

    // - very fast: calculated only once for all fields

    function FieldTable(Field: integer): TSQLRecordClass;

    /// force the mean of characters length for every field

    // - expect as many parameters as fields in this table

    // - override internal fFieldLengthMean[] and fFieldLengthMeanSum values

    procedure SetFieldLengthMean(const Lengths: array of cardinal);

    /// set the exact type of a given field

    // - by default, column types and sizes will be retrieved from JSON content

    // from first row, or all rows if FieldTypeIntegerDetectionOnAllRows is set

    // - you can define a specific type for a given column, and optionally

    // a maximum column size

    // - FieldTypeInfo can be specified for sets or enumerations, as such:

    // ! aTable.SetFieldType(0,sftEnumerate,TypeInfo(TEnumSample));

    // ! aTable.SetFieldType(1,sftSet,TypeInfo(TSetSamples));

    // or for dynamic arrays

    procedure SetFieldType(Field: integer; FieldType: TSQLFieldType;

       FieldTypeInfo: pointer=nil; FieldSize: integer=-1;

       FieldTableIndex: integer=-1); overload;

    /// set the exact type of a given field

    // - by default, column types and sizes will be retrieved from JSON content

    // from first row, or all rows if FieldTypeIntegerDetectionOnAllRows is set

    // - you can define a specific type for a given column, and optionally

    // a maximum column size

    // - FieldTypeInfo can be specified for sets or enumerations, as such:

    // ! aTable.SetFieldType('Sample',sftEnumerate,TypeInfo(TEnumSample));

    // ! aTable.SetFieldType('Samples',sftSet,TypeInfo(TSetSamples));

    procedure SetFieldType(const FieldName: RawUTF8; FieldType: TSQLFieldType;

       FieldTypeInfo: pointer=nil; FieldSize: integer=-1); overload;

    /// increase a particular Field Length Mean value

    // - to be used to customize the field appareance (e.g. for adding of left

    // checkbox for Marked[] fields)

    procedure FieldLengthMeanIncrease(aField, aIncrease: integer);



    /// copy the parameters of a TSQLTable into this instance

    // - the fResults remain in the source TSQLTable: source TSQLTable has not to

    // be destroyed before this TSQLTable

    procedure Assign(source: TSQLTable);



    /// search a text value inside the table data in a specified field

    // - the text value must already be uppercased 7-bits ANSI encoded

    // - return the Row on success, 0 on error

    // - search only in the content of FieldIndex data

    // - you can specify a Soundex pronunciation to use, or leave as sndxNone for

    // standard case insensitive character match; aUpperValue can optional

    // indicate a Soundex search, by predeceding the searched text with % for

    // English, %% for French or %%% for Spanish (only works with WinAnsi

    // char set - i.e. code page 1252)

    // - if UnicodeComparison is set to TRUE, search will use low-level Windows

    // API for Unicode-level conversion - it will be much slower, but accurate

    // for the whole range of UTF-8 encoding

    // - if UnicodeComparison is left to FALSE, UTF-8 decoding will be done only

    // if necessary: it will work only with standard western-occidental alphabet

    // (i.e. WinAnsi - code page 1252), but it will be very fast

    function SearchValue(const aUpperValue: RawUTF8; StartRow, FieldIndex: integer;

      Client: TObject; Lang: TSynSoundExPronunciation=sndxNone;

      UnicodeComparison: boolean=false): integer; overload;

    /// search a text value inside the table data in all fields

    // - the text value must already be uppercased 7-bits ANSI encoded

    // - return the Row on success, 0 on error

    // - search on all fields, returning field found in FieldIndex (if not nil)

    // - you can specify a Soundex pronunciation to use, or leave as sndxNone for

    // standard case insensitive character match; aUpperValue can optional

    // indicate a Soundex search, by predeceding the searched text with % for

    // English, %% for French or %%% for Spanish (only works with WinAnsi

    // char set - i.e. code page 1252)

    // - if UnicodeComparison is set to TRUE, search will use low-level Windows

    // API for Unicode-level conversion - it will be much slower, but accurate

    // for the whole range of UTF-8 encoding

    // - if UnicodeComparison is left to FALSE, UTF-8 decoding will be done only

    // if necessary: it will work only with standard western-occidental alphabet

    // (i.e. WinAnsi - code page 1252), but it will be very fast

    function SearchValue(const aUpperValue: RawUTF8; StartRow: integer;

      FieldIndex: PInteger; Client: TObject; Lang: TSynSoundExPronunciation=sndxNone;

      UnicodeComparison: boolean=false): integer; overload;

    /// search for a value inside the raw table data

    // - returns 0 if not found, or the matching Row number otherwise

    function SearchFieldEquals(const aValue: RawUTF8; FieldIndex: integer): integer;



    /// if the ID column is available, hides it from fResults[]

    // - useful for simplier UI, with a hidden ID field

    // - use IDColumnHiddenValue() to get the ID of a specific row

    // - return true is ID was succesfully hidden, false if not possible

    function IDColumnHide: boolean;

    /// return the (previously hidden) ID value, 0 on error

    function IDColumnHiddenValue(Row: integer): TID;

    /// return all (previously hidden) ID values

    procedure IDColumnHiddenValues(var IDs: TIDDynArray);

    /// get all IDs where individual bit in Bits are set

    procedure IDArrayFromBits(const Bits; var IDs: TIDDynArray);

    /// get all individual bit in Bits corresponding to the supplied IDs

    // - warning: IDs integer array will be sorted within this method call

    procedure IDArrayToBits(var Bits; var IDs: TIDDynArray);

    /// get the Row index corresponding to a specified ID

    // - return the Row number, from 1 to RowCount

    // - return RowCount (last row index) if this ID was not found or no

    // ID field is available

    function RowFromID(aID: TID): integer;



    /// delete the specified data Row from the Table

    // - only overwrite the internal fResults[] pointers, don't free any memory,

    // nor modify the internal DataSet

    procedure DeleteRow(Row: integer);

    /// delete the specified Column text from the Table

    // - don't delete the Column: only delete UTF-8 text in all rows for this field

    procedure DeleteColumnValues(Field: integer);



    /// retrieve QueryTables[0], if existing

    function QueryRecordType: TSQLRecordClass;



    /// create a new TSQLRecord instance for a specific Table

    // - use the specified TSQLRecord class or create one instance

    // of the first associated record class (from internal QueryTables[])

    // - use this method to create a working copy of a table's record, e.g.

    // - the record will be freed when the TSQLTable will be destroyed:

    // you don't need to make a Try..Finally..Free..end block with it

    function NewRecord(RecordType: TSQLRecordClass=nil): TSQLRecord;

    /// create a TObjectList with TSQLRecord instances corresponding to this

    // TSQLTable result set

    // - use the specified TSQLRecord class or create instances

    // of the first associated record class (from internal QueryTables[])

    // - always returns an instance, even if the TSQLTable is nil or void

    function ToObjectList(RecordType: TSQLRecordClass=nil): TObjectList; overload;

    /// fill an existing TObjectList with TSQLRecord instances corresponding

    // to this TSQLTable result set

    // - use the specified TSQLRecord class or create instances

    // of the first associated record class (from internal QueryTables[])

    procedure ToObjectList(DestList: TObjectList; RecordType: TSQLRecordClass=nil); overload;

    {$ifdef ISDELPHI2010} // Delphi 2009 generics are buggy

    /// create a TObjectList<TSQLRecord> with TSQLRecord instances corresponding

    // to this TSQLTable result set

    // - use the specified TSQLRecord class or create instances

    // of the first associated record class (from internal QueryTables[])

    // - always returns an instance, even if the TSQLTable is nil or void

    function ToObjectList<T: TSQLRecord>: TObjectList<T>; overload;

    {$endif}

    /// fill an existing T*ObjArray variable with TSQLRecord instances

    // corresponding to this TSQLTable result set

    // - use the specified TSQLRecord class or create instances

    // of the first associated record class (from internal QueryTables[])

    // - returns TRUE on success (even if ObjArray=[]), FALSE on error

    function ToObjArray(var ObjArray; RecordType: TSQLRecordClass=nil): boolean;



    /// After a TSQLTable has been initialized, this method can be called

    // one or more times to iterate through all data rows

    // - you shall call this method before calling FieldBuffer()/Field() methods

    // - return TRUE on success, with data ready to be retrieved by Field*()

    // - return FALSE if no more row is available (i.e. exceeded RowCount)

    // - if SeekFirst is TRUE, will put the cursor on the first row of results,

    // otherwise, it will fetch one row of data, to be called within a loop

    // - you can specify a variant instance (e.g. allocated on the stack) in

    // optional RowVariant parameter, to access field values using late binding

    // - typical use may be:

    // ! while TableCustomers.Step do

    // !   writeln(Field('name'));

    // - or, when using a variant and late-binding:

    // ! var customer: variant;

    // ! ...

    // !   while TableCustomers.Step(false,@customer) do

    // !     writeln(customer.Name);

    function Step(SeekFirst: boolean=false; RowVariant: PVariant=nil): boolean;

    /// read-only access to a particular field value, as UTF-8 encoded buffer

    // - raise an ESQLTableException if called outside valid Step() sequence

    // - similar to Get() method, but for the current Step

    function FieldBuffer(FieldIndex: Integer): PUTF8Char; overload;

    /// read-only access to a particular field value, as UTF-8 encoded buffer

    // - raise an ESQLTableException if called outside valid Step() sequence

    // - similar to Get() method, but for the current Step

    function FieldBuffer(const FieldName: RawUTF8): PUTF8Char; overload;

    /// read-only access to a particular field value, as Integer

    // - raise an ESQLTableException if called outside valid Step() sequence

    // - similar to GetAsInteger() method, but for the current Step

    function FieldAsInteger(FieldIndex: Integer): Int64; overload;

      {$ifdef HASINLINE}inline;{$endif}

    /// read-only access to a particular field value, as Integer

    // - raise an ESQLTableException if called outside valid Step() sequence

    // - similar to GetAsInteger() method, but for the current Step

    function FieldAsInteger(const FieldName: RawUTF8): Int64; overload;

      {$ifdef HASINLINE}inline;{$endif}

    /// read-only access to a particular field value, as floating-point value

    // - raise an ESQLTableException if called outside valid Step() sequence

    // - similar to GetAsFloat() method, but for the current Step

    function FieldAsFloat(FieldIndex: Integer): TSynExtended; overload;

      {$ifdef HASINLINE}inline;{$endif}

    /// read-only access to a particular field value, as floating-point value

    // - raise an ESQLTableException if called outside valid Step() sequence

    // - similar to GetAsFloat() method, but for the current Step

    function FieldAsFloat(const FieldName: RawUTF8): TSynExtended; overload;

      {$ifdef HASINLINE}inline;{$endif}

    {$ifndef NOVARIANTS}

    /// read-only access to a particular field value, as a variant

    // - raise an ESQLTableException if called outside valid Step() sequence

    // - will call GetVariant() method for appropriate data conversion

    function Field(FieldIndex: integer): variant; overload;

    /// read-only access to a particular field value, as a variant

    // - raise an ESQLTableException if called outside valid Step() sequence

    // - will call GetVariant() method for appropriate data conversion

    function Field(const FieldName: RawUTF8): variant; overload;

    {$endif}



    /// contains the associated record class on Query

    property QueryTables: TSQLRecordClassDynArray read fQueryTables;

    /// contains the associated SQL statement on Query

    property QuerySQL: RawUTF8 read fQuerySQL;

    /// returns the SQL Table name, guessed from the associated QuerySQL statement 

    property QueryTableNameFromSQL: RawUTF8 read GetQueryTableNameFromSQL;

    /// read-only access to the number of data Rows in this table

    // - first row contains field name

    // - then 1..RowCount rows contain the data itself

    property RowCount: integer read GetRowCount;

    /// read-only access to the number of fields for each Row in this table

    property FieldCount: integer read fFieldCount;

    /// read-only access to the ID/RowID field index

    // - do not use this property if the ID column has been hidden, but

    // use IDColumnHiddenValue() method instead

    property FieldIndexID: integer read fFieldIndexID;

    /// read-only acccess to the current Row number, after a Step() call

    // - contains 0 if accessed outside valid Step() sequence call

    // - contains 1..RowCount after a valid Step() iteration

    property StepRow: integer read fStepRow;

    /// this property contains the internal state counter of the server database

    // when the data was retrieved from it

    // - can be used to check if retrieved data may be out of date

    property InternalState: cardinal read fInternalState write fInternalState;

    /// if the TSQLRecord is the owner of this table, i.e. if it must free it

    property OwnerMustFree: Boolean read fOwnerMustFree write fOwnerMustFree;

    /// by default, if field types are not set, only the content of the first

    // row will be checked, to make a difference between a sftInteger and sftFloat

    // - you can set this property to TRUE so that all non string rows will

    // be checked for the exact number precision

    // - note that the safest is to provide the column type, either by supplying

    // the TSQLRecord class, or by calling SetFieldType() overloaded methods

    property FieldTypeIntegerDetectionOnAllRows: boolean

      read fFieldTypeAllRows write fFieldTypeAllRows;

    /// used by GetJsonValues, GetHtmlTable and GetCSVValues methods

    // to export custom JSON content

    property OnExportValue: TOnSQLTableGetValue read fOnExportValue write fOnExportValue;

  end;



{$ifndef NOVARIANTS}

  /// memory structure used for our TSQLTableRowVariant custom variant type

  // used to have direct access to TSQLTable content

  // - the associated TSQLTable must stay allocated as long as this variant

  // is used, otherwise random GPF issues may occur

  TSQLTableRowVariantData = packed record

    /// the custom variant type registered number

    VType: TVarType;

    VFiller: array[1..sizeof(TVarData)-sizeof(TVarType)-sizeof(TSQLTable)

      -sizeof(integer)] of byte;

    /// reference to the associated TSQLTable

    VTable: TSQLTable;

    /// the row number corresponding to this value

    // - equals -1 if should follow StepRow property value

    VRow: integer;

  end;



  /// pointer to the memory structure used for TSQLTableRowVariant storage

  PSQLTableRowVariantData = ^TSQLTableRowVariantData;



  /// a custom variant type used to have direct access to TSQLTable content

  // - use TSQLTable.Step(..,@Data) method to initialize such a Variant

  // - the variant members/fields are read-only by design

  // - the associated TSQLTable must stay allocated as long as this variant

  // is used, otherwise random GPF issues may occur

  TSQLTableRowVariant = class(TSynInvokeableVariantType)

  protected

    procedure IntGet(var Dest: TVarData; const V: TVarData; Name: PAnsiChar); override;

    procedure IntSet(const V, Value: TVarData; Name: PAnsiChar); override;

  public

    /// customization of variant into JSON serialization

    procedure ToJSON(W: TTextWriter; const Value: variant; Escape: TTextWriterKind); override;

    /// handle type conversion to string

    procedure Cast(var Dest: TVarData; const Source: TVarData); override;

    /// handle type conversion to string

    procedure CastTo(var Dest: TVarData; const Source: TVarData;

      const AVarType: TVarType); override;

  end;

{$endif NOVARIANTS}





  /// get a SQL result from a JSON message, and store it into its own memory

  TSQLTableJSON = class(TSQLTable)

  protected

    /// used if a private copy of the JSON buffer is needed

    fPrivateCopy: RawUTF8;

    /// contains the pointers of start of every field value in JSONData

    fJSONResults: array of PUTF8Char;

    /// contain the hash value of the last JSON data sent to ContentChanged()

    // - used to don't repeat parsing if data has not been changed

    fPrivateCopyHash: cardinal;

    /// fill the result table content from a JSON-formated Data message

    // - returns TRUE on parsing success

    // - returns FALSE if no valid JSON data was found

    // - update all content fields (fResults[], fRowCount, fFieldCount, etc...)

    // - expect the UTF-8 Buffer in either TSQLRequest.EngineExecute(DB,SQL,JSON)

    // format (i.e. expanded) or either in a not expanded format (as an

    // AJAX-ready array of objects)

    // - the conversion into PPUTF8CharArray is made inplace and is very fast

    // (no additional memory buffer is allocated)

    function ParseAndConvert(Buffer: PUTF8Char; BufferLen: integer): boolean;

    /// will check then set (if needed) internal fPrivateCopy[Hash] values

    // - returns TRUE if content changed (then fPrivateCopy+fPrivateCopyHash

    // will be updated using crc32c hash)

    function PrivateCopyChanged(aJSON: PUTF8Char; aLen: integer): boolean;

  public

    /// create the result table from a JSON-formated Data message

    // - the JSON data is parsed and formatted in-place

    // - please note that the supplied JSON buffer content will be changed:

    // if you want to reuse this JSON content, you shall make a private copy

    // before calling this constructor and you shall NOT release the corresponding

    // variable (fResults/JSONResults[] will point inside this memory buffer):

    // use instead the overloaded Create constructor expecting aJSON parameter

    // making a private copy of the data

    constructor Create(const aSQL: RawUTF8;

      JSONBuffer: PUTF8Char; JSONBufferLen: integer); reintroduce; overload;

    /// create the result table from a JSON-formated Data message

    // - the JSON data is parsed and formatted in-place, after having been

    // copied in the protected fPrivateCopy variable

    constructor Create(const aSQL, aJSON: RawUTF8); reintroduce; overload;

    /// create the result table from a JSON-formated Data message

    // - the JSON data is parsed and formatted in-place

    // - you can specify a set of TSQLRecord classes which will be used to

    // retrieve the column exact type information

    // - please note that the supplied JSON buffer content will be changed

    constructor CreateFromTables(const Tables: array of TSQLRecordClass;

      const aSQL: RawUTF8; JSONBuffer: PUTF8Char; JSONBufferLen: integer); reintroduce; overload;

    /// create the result table from a JSON-formated Data message

    // - you can specify a set of TSQLRecord classes which will be used to

    // retrieve the column exact type information

    // - the JSON data is parsed and formatted in-place, after having been

    // copied in the protected fPrivateCopy variable

    constructor CreateFromTables(const Tables: array of TSQLRecordClass;

      const aSQL, aJSON: RawUTF8); reintroduce; overload;

    /// initialize the result table from a JSON-formated Data message

    // - you can set the expected column types matching the results column layout

    // - the JSON data is parsed and formatted in-place

    constructor CreateWithColumnTypes(const ColumnTypes: array of TSQLFieldType;

      const aSQL: RawUTF8; JSONBuffer: PUTF8Char; JSONBufferLen: integer); reintroduce; overload;

    /// initialize the result table from a JSON-formated Data message

    // - you can set the expected column types matching the results column layout

    // - the JSON data is parsed and formatted in-place, after having been

    // copied in the protected fPrivateCopy variable

    constructor CreateWithColumnTypes(const ColumnTypes: array of TSQLFieldType;

      const aSQL, aJSON: RawUTF8); reintroduce; overload;



    /// update the result table content from a JSON-formated Data message

    // - return true on parsing success, false if no valid JSON data was found

    // - set Refreshed to true if the content changed

    // - update all content fields (fResults[], fRowCount, fFieldCount, etc...)

    // - call SortFields() or IDColumnHide if was already done for this TSQLTable

    // - the conversion into PPUTF8CharArray is made inplace and is very fast

    // (only one memory buffer is allocated for the whole data)

    function UpdateFrom(const aJSON: RawUTF8; var Refreshed: boolean;

      PCurrentRow: PInteger): boolean;



    /// the private copy of the processed data buffer

    // - available e.g. for Create constructor using aJSON parameter,

    // or after the UpdateFrom() process

    // - this buffer is not to be access directly: this won't be a valid JSON

    // content, but a processed buffer, on which fResults[] elements point to -

    // it will contain unescaped text and numerical values, ending with #0

    property PrivateInternalCopy: RawUTF8 read fPrivateCopy;

  end;



  PSQLLocks = ^TSQLLocks;

  /// used to store the locked record list, in a specified table

  // - the maximum count of the locked list if fixed to 512 by default,

  // which seems correct for common usage

  TSQLLocks = {$ifndef ISDELPHI2010}object{$else}record{$endif}

    /// the number of locked records stored in this object

    Count: integer;

    /// contains the locked record ID

    // - an empty position is marked with 0 after UnLock()

    IDs: TIDDynArray;

    /// contains the time and date of the lock

    // - filled internally by the fast GetTickCount64() function (faster than

    // TDateTime or TSystemTime/GetLocalTime)

    // - used to purge to old entries - see PurgeOlderThan() method below

    Ticks64s: TInt64DynArray;

    /// lock a record, specified by its ID

    // - returns true on success, false if was already locked

    function Lock(aID: TID): boolean;

    /// unlock a record, specified by its ID

    // - returns true on success, false if was not already locked

    function UnLock(aID: TID): boolean;

    /// return true if a record, specified by its ID, is locked

    function isLocked(aID: TID): boolean;

    /// delete all the locked IDs entries, after a specified time

    // - to be used to release locked records if the client crashed

    // - default value is 30 minutes, which seems correct for common database usage

    procedure PurgeOlderThan(MinutesFromNow: cardinal=30);

  end;



  TSQLLocksDynArray = array of TSQLLocks;



  /// UI Query comparison operators

  // - these operators are e.g. used to mark or unmark some lines in a UI Grid

  // or for TInterfaceStub.ExpectsCount() methods

  TSQLQueryOperator =

    (qoNone,

     qoEqualTo,

     qoNotEqualTo,

     qoLessThan,

     qoLessThanOrEqualTo,

     qoGreaterThan,

     qoGreaterThanOrEqualTo,

     qoEqualToWithCase,

     qoNotEqualToWithCase,

     qoContains,

     qoBeginWith,

     qoSoundsLikeEnglish,

     qoSoundsLikeFrench,

     qoSoundsLikeSpanish);



  /// set of UI Query comparison operators

  TSQLQueryOperators = set of TSQLQueryOperator;



  /// User Interface Query action evaluation function prototype

  // - Operator is ord(TSQLQueryOperator) by default (i.e. for class function

  // TSQLRest.QueryIsTrue), or is a custom enumeration index for custom queries

  // (see TSQLQueryCustom.EnumIndex below, and TSQLRest.QueryAddCustom() method)

  // - for default Operator as ord(TSQLQueryOperator), qoContains and qoBeginWith

  // expect the Reference to be already uppercase

  // - qoEqualTo to qoGreaterThanOrEqualTo apply to all field kind (work with

  // either numeric either UTF-8 values)

  // - qoEqualToWithCase to qoSoundsLikeSpanish handle the field as UTF-8 text,

  // and make the comparison using the phonetic algorithm corresponding to

  // a language family

  // - for default Operator as ord(TSQLQueryOperator), qoSoundsLike* operators

  // expect the Reference not to be a PUTF8Char, but a typecast of a prepared

  // TSynSoundEx object instance (i.e. pointer(@SoundEx)) by the caller

  // - for custom query (from TSQLQueryCustom below), the event must

  // handle a special first call with Value=nil to select if this custom

  // Operator/Query is available for the specified aTable: in this case,

  // returning true indicates that this custom query is available for this table

  // - for custom query (from TSQLQueryCustom below), the event is called with

  // FieldType := TSQLFieldType(TSQLQueryCustom.EnumIndex)+64

  TSQLQueryEvent = function(aTable: TSQLRecordClass; aID: TID;

    FieldType: TSQLFieldType; Value: PUTF8Char; Operator: integer;

    Reference: PUTF8Char): boolean of object;



  /// store one custom query parameters

  // - add custom query by using the TSQLRest.QueryAddCustom() method

  // - use EnumType^.GetCaption(EnumIndex) to retrieve the caption associated

  // to this custom query

  TSQLQueryCustom = record

    /// the associated enumeration type

    EnumType: PEnumType;

    /// the associated enumeration index in EnumType

    // - will be used to fill the Operator parameter for the Event call

    EnumIndex: integer;

    /// the associated evaluation Event handler

    // - the Operator parameter will be filled with the EnumIndex value

    Event: TSQLQueryEvent;

    /// User Interface Query action operators

    Operators: TSQLQueryOperators;

  end;



  /// standard actions for User Interface generation

  // - actNoAction for not defined action

  // - actMark (standard action) to Mark rows, i.e. display sub-menu with

  // actmarkAllEntries..actmarkOlderThanOneYear items

  // - actUnmarkAll (standard action) to UnMark all rows

  // - actmarkAllEntries to Mark all rows

  // - actmarkToday to Mark rows for today

  // - actmarkThisWeek to Mark rows for this Week

  // - actmarkThisMonth to Mark rows for this month

  // - actmarkYesterday to Mark rows for today

  // - actmarkLastWeek to Mark rows for Last Week

  // - actmarkLastMonth to Mark rows for Last month

  // - actmarkOlderThanOneDay to Mark rows After one day

  // - actmarkOlderThanOneWeek to Mark rows older than one week

  // - actmarkOlderThanOneMonth to Mark rows older than one month

  // - actmarkOlderThanSixMonths to Mark rows older than one half year

  // - actmarkOlderThanOneYear to Mark rows older than one year

  // - actmarkInverse to Inverse Mark values (ON->OFF, OFF->ON)

  TSQLAction = (

    actNoAction,

    actMark,

    actUnmarkAll,

    actmarkAllEntries,

    actmarkToday,

    actmarkThisWeek,

    actmarkThisMonth,

    actmarkYesterday,

    actmarkLastWeek,

    actmarkLastMonth,

    actmarkOlderThanOneDay,

    actmarkOlderThanOneWeek,

    actmarkOlderThanOneMonth,

    actmarkOlderThanSixMonths,

    actmarkOlderThanOneYear,

    actmarkInverse);



  /// set of standard actions for User Interface generation

  TSQLActions = set of TSQLAction;



  /// how TSQLModel.URIMatch() would compare an URI

  // - will allow to make a difference about case-sensitivity

  TSQLRestModelMatch = (rmNoMatch, rmMatchExact, rmMatchWithCaseChange);



  /// defines the way the TDrawGrid is displayed by User Interface generation

  TSQLListLayout = (llLeft, llUp, llClient, llLeftUp);



  PSQLRibbonTabParameters = ^TSQLRibbonTabParameters;



  /// defines the settings for a Tab for User Interface generation

  // - used in mORMotToolBar.pas unit and TSQLModel.Create() overloaded method

  TSQLRibbonTabParameters = object

  public

    /// the Table associated to this Tab

    Table: TSQLRecordClass;

    /// the caption of the Tab, to be translated on the screen

    // - by default, Tab name is taken from TSQLRecord.Caption(nil) method

    // - but you can override this value by setting a pointer to a resourcestring

    CustomCaption: PResStringRec;

    /// the hint type of the Tab, to be translated on the screen

    // - by default, hint will replace all %s instance by the Tab name, as taken

    // from TSQLRecord.Caption(nil) method

    // - but you can override this value by setting a pointer to a resourcestring

    CustomHint: PResStringRec;

    /// SQL fields to be displayed on the data lists

    // 'ID,' is always added at the beginning

    Select: RawUTF8;

     /// Tab Group number (index starting at 0)

    Group: integer;

    /// displayed field length mean, one char per field (A=1,Z=26)

    // - put lowercase character in order to center the field data

    FieldWidth: RawUTF8;

    /// if set, the ID column is shown

    ShowID: boolean;

    /// index of field used for displaying order

    OrderFieldIndex: integer;

    /// if set, the list is displayed in reverse order (i.e. decreasing)

    ReverseOrder: boolean;

    /// layout of the List, below the ribbon

    Layout: TSQLListLayout;

    /// width of the List, in percent of the client area

    // - default value (as stated in TSQLRibbonTab.Create) is 30%

    ListWidth: integer;

    /// by default, the detail are displayed as a report (TGDIPages component)

    // - set this property to true to customize the details display

    // - this property is ignored if Layout is llClient (i.e. details hidden)

    NoReport: boolean;

    /// by default, the screens are not refreshed automaticaly

    // - but you can enable the auto-refresh feature by setting this

    // property to TRUE, and creating a WM_TIMER message handler for the form,

    // which will handle both WM_TIMER_REFRESH_SCREEN and WM_TIMER_REFRESH_REPORT

    // timers:

    // !procedure TMainForm.WMRefreshTimer(var Msg: TWMTimer);

    // !begin

    // !  Ribbon.WMRefreshTimer(Msg);

    // !end;

    AutoRefresh: boolean;

    /// the associated hints to be displayed during the edition of this table

    // - every field hint must be separated by a '|' character

    // (e.g. 'The First Name|Its Company Name')

    // - all fields need to be listed in this text resource, even if it won't

    // be displayed on screen (enter a void item like ||)

    // - you can define some value by setting a pointer to a resourcestring

    EditFieldHints: PResStringRec;

    /// write hints above field during the edition of this table

    // - if EditExpandFieldHints is TRUE, the hints are written as text on the

    // dialog, just above the field content; by default, hints are displayed as

    // standard delayed popup when the mouse hover the field editor

    EditExpandFieldHints: boolean;

    /// the associated field name width (in pixels) to be used for creating

    // the edition dialog for this table

    EditFieldNameWidth: integer;

    /// a CSV list of field names to be hidden in both editor and default report

    // - handy to hide fields containing JSON data or the name of another

    // sftRecord/sftID/sftTID (i.e. TRecordReference/TSQLRecord props) fields

    // - list is to be separated by commas (e.g. "RunLogJSON,OrdersJSON" or

    // "ConnectionName")

    EditFieldNameToHideCSV: RawUTF8;

    /// if the default report must contain the edit field hints

    // - i.e. if the resourcestring pointed by EditFieldHints must be used

    // to display some text above every property value on the reports

    EditFieldHintsToReport: boolean;

  end;



  /// parent of all virtual classes

  // - you can define a plain TSQLRecord class as virtual if needed  - e.g.

  // inheriting from TSQLRecordMany then calling VirtualTableExternalRegister() -

  // but using this class will seal its state to be virtual

  TSQLRecordVirtual = class(TSQLRecord);



  TSQLVirtualTable = class;



  /// class-reference type (metaclass) of a virtual table implementation

  TSQLVirtualTableClass = class of TSQLVirtualTable;



  /// pre-computed SQL statements for ORM operations for a given

  // TSQLModelRecordProperties instance

  TSQLModelRecordPropertiesSQL = record

    /// the simple field names in a SQL SELECT compatible format: 'COL1,COL2' e.g.

    // - format is

    // ! SQL.TableSimpleFields[withID: boolean; withTableName: boolean]

    // - returns '*' if no field is of TSQLRawBlob/TSQLRecordMany kind

    // - returns 'COL1,COL2' with all COL* set to simple field names if withID is false

    // - returns 'ID,COL1,COL2' with all COL* set to simple field names if withID is true

    // - returns 'Table.ID,Table.COL1,Table.COL2' if withTableName and withID are true

    TableSimpleFields: array[boolean,boolean] of RawUTF8;

    /// the SQL statement for reading all simple fields and RowID

    // - to be checked if we may safely call EngineList()

    SelectAllWithRowID: RawUTF8;

    /// the SQL statement for reading all simple fields with ID

    // - to be checked if we may safely call EngineList()

    SelectAllWithID: RawUTF8;

    /// the JOINed SQL statement for reading all fields with ID, including

    // nested TSQLRecord pre-allocated instances

    // - is '' if there is no nested TSQLRecord

    SelectAllJoined: RawUTF8;

    /// the updated simple fields exposed as 'COL1=?,COL2=?'

    // - excluding ID (but including TCreateTime fields - as used in

    // TSQLVirtualTableExternal.Update method)

    // - to be used e.g. for UPDATE statements

    UpdateSetSimple: RawUTF8;

    /// all updated fields exposed as 'COL1=?,COL2=?'

    // - excluding ID (but including TCreateTime fields - as used in

    // TSQLVirtualTableExternal.Update method)

    // - to be used e.g. for UPDATE statements

    UpdateSetAll: RawUTF8;

    /// all fields, excluding the ID field, exposed as 'COL1,COL2'

    // - to be used e.g. in TSQLVirtualTableExternal.Insert()

    InsertSet: RawUTF8;

  end;



  /// used by TSQLRecordPropertiesMapping.Options for custom field mapping

  // of a TSQLRecord on an external database process

  // - rpmAutoMapKeywordFields is set if MapAutoKeywordFields has been defined,

  // i.e. if field names which may conflict with a keyword should be

  // automatically mapped to a harmless symbol name

  // - rpmNoCreateMissingTable would bypass the existing table check, e.g.

  // to circumvent some specific DB provider or case sensitivity issue on tables

  // - rpmNoCreateMissingField would bypass the existing field check, e.g.

  // to circumvent some specific DB provider or case sensitivity issue on fields

  // - by default, check of missing field name would be case insensitive, unless

  // the rpmMissingFieldNameCaseSensitive option is set

  TSQLRecordPropertiesMappingOptions = set of (

    rpmAutoMapKeywordFields,

    rpmNoCreateMissingTable, rpmNoCreateMissingField,

    rpmMissingFieldNameCaseSensitive);

    

  /// pointer to external database properties for ORM

  // - is used e.g. to allow a "fluent" interface for MapField() method

  PSQLRecordPropertiesMapping = ^TSQLRecordPropertiesMapping;



  /// allow custom field mapping of a TSQLRecord

  // - used e.g. for external database process, including SQL generation,

  // as implemented in the mORMotDB.pas unit

  // - in end user code, mostly MapField/MapFields/Options methods

  // should be used, if needed as a fluent chained interface - other lower

  // level methods will be used by the framework internals

  {$ifndef ISDELPHI2010}

  TSQLRecordPropertiesMapping = object

  {$else}

  TSQLRecordPropertiesMapping = record

  {$endif}

  private

    /// storage of main read-only properties

    fProps: TSQLRecordProperties;

    fConnectionProperties: TObject;

    fTableName: RawUTF8;

    fRowIDFieldName: RawUTF8;

    fFieldNames: TRawUTF8DynArray;

    fSQL: TSQLModelRecordPropertiesSQL;

    fFieldNamesMatchInternal: TSQLFieldBits;

    fOptions: TSQLRecordPropertiesMappingOptions;

    fAutoComputeSQL: boolean;

    fMappingVersion: cardinal;

    /// fill fRowIDFieldName/fSQL with the current information

    procedure ComputeSQL;

  public

    /// add a custom field mapping

    // - will re-compute all needed SQL statements as needed, and initialize

    // fSortedFieldsName[] and fSortedFieldsIndex[] internal sorted arrays

    // - can be used e.g. as

    // ! aModel.Props[TSQLMyExternal].ExternalDB.MapField('IntField','ExtField');

    // - since it returns a PSQLRecordPropertiesMapping instance, you can

    // chain MapField().MapField().MapField(); calls to map several fields

    function MapField(const InternalName, ExternalName: RawUTF8): PSQLRecordPropertiesMapping;

    /// call this method to ensure that all fields won't conflict with a SQL

    // keyword for the given database

    // - by default, no check is performed: you can use this method to ensure

    // that all field names won't conflict with a SQL reserved keyword: such

    // fields will be identified and automatically mapped as fieldname_

    // - can be used e.g. as

    // ! aModel.Props[TSQLMyExternal].ExternalDB.

    // !   MapField('IntField','ExtField').

    // !   MapAutoKeywordFields;

    // - will in fact include the rpmAutoMapKeywordFields flag in Options

    // - since it returns a PSQLRecordPropertiesMapping instance, you can

    // chain MapField().MapAutoKeywordFields.MapField(); calls to map several fields

    function MapAutoKeywordFields: PSQLRecordPropertiesMapping;

    /// specify some advanced options for the field mapping

    // - see TSQLRecordPropertiesMappingOptions for all possibilities

    // - can be used e.g. as

    // ! aModel.Props[TSQLMyExternal].ExternalDB.

    // !   MapField('IntField','ExtField').

    // !   SetOptions([rpmNoCreateMissingTable,rpmNoCreateMissingField]);

    // - since it returns a PSQLRecordPropertiesMapping instance, you can

    // chain MapField().SetOptions().MapField(); calls to map several fields

    function SetOptions(aOptions: TSQLRecordPropertiesMappingOptions): PSQLRecordPropertiesMapping;

    /// add several custom field mappings

    // - can be used e.g. as

    // ! aModel.Props[TSQLMyExternal].ExternalDB.

    // !   MapFields(['IntField1','ExtField1', 'IntField2','ExtField2']);

    // - will re-compute all needed SQL statements as needed, and initialize

    // fSortedFieldsName[] and fSortedFieldsIndex[] internal sorted arrays

    // - is slightly faster than several chained MapField() calls, since SQL

    // will be computed only once

    function MapFields(const InternalExternalPairs: array of RawUTF8): PSQLRecordPropertiesMapping;

  public

    /// initialize the field mapping for a given TSQLRecord

    // - if AutoComputeSQL is true, will pre-compute all needed SQL from the

    // supplied information

    // - will left void fSortedFieldsName[] and fSortedFieldsIndex[], to disable

    // custom field mapping

    procedure Init(Table: TSQLRecordClass; const MappedTableName: RawUTF8;

      MappedConnection: TObject; AutoComputeSQL: boolean); overload;

    /// map a field name from its internal name to its external name

    // - raise an EORMException if the supplied field name is not defined in

    // the TSQLRecord as ID or a published property

    function InternalToExternal(const FieldName: RawUTF8): RawUTF8;

    /// map a CSV list of field names from its internals to its externals values

    // - raise an EORMException if any of the supplied field name is not defined

    // in the TSQLRecord as ID or as property (RowIDFieldName or FieldNames[])

    // - to be used for a simple CSV (e.g. for INSERT/SELECT statements):

    // ! ExtCSV := InternalCSVToExternalCSV('ID,Name');

    // - or for a more complex CSV (e.g. for UPDATE statements);

    // ! ExtCSV := InternalCSVToExternalCSV('ID=?,Name=?','=?,'=?');

    function InternalCSVToExternalCSV(const CSVFieldNames: RawUTF8;

      const Sep: RawUTF8=','; const SepEnd: RawUTF8=''): RawUTF8;

    /// create a list of external field names, from the internal field names

    // - raise an EORMException if any of the supplied field name is not defined

    // in the TSQLRecord as ID or a published property

    // - if IntFieldIndex is set, it will store an array of internal field

    // indexes, i.e. -1 for ID or index in in FieldNames[] for other fields

    procedure InternalToExternalDynArray(const IntFieldNames: array of RawUTF8;

      out result: TRawUTF8DynArray; IntFieldIndex: PIntegerDynArray=nil);

    /// map an external field name into its internal field name

    // - return '' if the external field name is not RowIDFieldName nor in

    // FieldNames[]

    function ExternalToInternalOrNull(const ExtFieldName: RawUTF8): RawUTF8;

    /// map an external field name into its internal field index

    // - returns the index >=0 in FieldNames[] for a matching external field

    // - returns -1 if the field name is RowIDFieldName

    // - returns -2 if the field name is not mapped

    function ExternalToInternalIndex(const ExtFieldName: RawUTF8): integer;

    /// append a field name to a RawUTF8 Text buffer

    // - if FieldIndex=VIRTUAL_TABLE_ROWID_COLUMN (-1), appends RowIDFieldName

    // - on error (i.e. if FieldIndex is out of range) will return TRUE

    // - otherwise, will return FALSE and append the external field name to Text

    function AppendFieldName(FieldIndex: Integer; var Text: RawUTF8): boolean;

    /// return the field name as RawUTF8 value

    // - if FieldIndex=VIRTUAL_TABLE_ROWID_COLUMN (-1), appends RowIDFieldName

    // - otherwise, will return the external field name

    function FieldNameByIndex(FieldIndex: Integer): RawUTF8;



    /// opaque object used on the Server side to specify e.g. the DB connection

    // - will define such a generic TObject, to avoid any unecessary type

    // dependency to other units, e.g. the SynDB unit in mORMot.pas

    // - in practice, will be assigned by VirtualTableExternalRegister() to

    // a TSQLDBConnectionProperties instance in mORMotDB.pas, or by

    // StaticMongoDBRegister() to a TMongoCollection instance, or by

    // TDDDRepositoryRestObjectMapping.Create to its associated TSQLRest

    // - in ORM context, equals nil if the table is internal to SQLite3:

    // ! if Server.Model.Props[TSQLArticle].ExternalDB.ConnectionProperties=nil then

    // !   // this is not an external table, since Init() was not called

    property ConnectionProperties: TObject read fConnectionProperties;

    /// the associated TSQLRecordProperties

    property Properties: TSQLRecordProperties read fProps;

    /// used on the Server side to specify the external DB table name

    // - e.g. for including a schema name or an existing table name, with an

    // OleDB/MSSQL/Oracle/MySQL/PostgreSQL/Jet/SQLite3 backend

    // - equals SQLTableName by default (may be overridden e.g. by mORMotDB's

    // VirtualTableExternalRegister procedure)

    property TableName: RawUTF8 read fTableName;

    /// pre-computed SQL statements for this external TSQLRecord in this model

    // - you can use those SQL statements directly with the external engine

    // - filled if AutoComputeSQL was set to true in Init() method

    property SQL: TSQLModelRecordPropertiesSQL read fSQL;

    /// the ID/RowID customized external field name, if any

    // - is 'ID' by default, since 'RowID' is a reserved column name for some

    // database engines (e.g. Oracle)

    // - can be customized e.g. via

    // ! aModel.Props[TSQLMyExternal].ExternalDB.MapField('ID','ExternalID');

    property RowIDFieldName: RawUTF8 read fRowIDFieldName;

    /// the external field names, following fProps.Props.Field[] order

    // - excluding ID/RowID field, which is stored in RowIDFieldName

    property FieldNames: TRawUTF8DynArray read fFieldNames;

    /// each bit set, following fProps.Props.Field[]+1 order (i.e. 0=ID,

    // 1=Field[0], ...), indicates that this external field name

    // has not been mapped

    property FieldNamesMatchInternal: TSQLFieldBits read fFieldNamesMatchInternal;

    /// how the mapping process would take place

    property Options: TSQLRecordPropertiesMappingOptions read fOptions;

    /// each time MapField/MapFields is called, this number will increase

    // - can be used to track mapping changes in real time

    property MappingVersion: cardinal read fMappingVersion;

  end;



  /// dynamic array of TSQLModelRecordProperties

  // - used by TSQLModel to store the non-shared information of all its tables

  TSQLModelRecordPropertiesObjArray = array of TSQLModelRecordProperties;



  /// ORM properties associated to a TSQLRecord within a given model

  // - "stable" / common properties derivated from RTTI are shared in the

  // TSQLRecordProperties instance

  // - since the same TSQLRecord can be defined in several models, with diverse

  // implementation patterns (e.g. internal in one, external in another),

  // this class is used to regroup all model-specific settings, like SQL

  // pre-generated patterns or external DB properties

  TSQLModelRecordProperties = class

  protected

    fProps: TSQLRecordProperties;

    fKind: TSQLRecordVirtualKind;

    fModel: TSQLModel;

    fTableIndex: integer;

    fFTSWithoutContentTableIndex: integer;

    fFTSWithoutContentFields: RawUTF8;

    procedure SetKind(Value: TSQLRecordVirtualKind);

    function GetProp(const PropName: RawUTF8): TSQLPropInfo;

  public

    /// pre-computed SQL statements for this TSQLRecord in this model

    // - those statements will work for internal tables, not for external

    // tables with mapped table or fields names

    SQL: TSQLModelRecordPropertiesSQL;

    /// allow SQL process for one external TSQLRecord in this model

    ExternalDB: TSQLRecordPropertiesMapping;



    /// initialize the ORM properties from the TSQLRecord RTTI and the supplied

    // TSQLModel

    constructor Create(aModel: TSQLModel; aTable: TSQLRecordClass; aKind: TSQLRecordVirtualKind);

    /// clone ORM properties from an existing TSQLModelRecordProperties to

    // another model

    constructor CreateFrom(aModel: TSQLModel; aSource: TSQLModelRecordProperties);



    /// compute the SQL statement to be executed for a specific SELECT

    // - non simple fields (e.g. BLOBs) will be excluded if SelectFields='*'

    // - by default, will return the SELECT statement to be used for internal

    // virtual SQLite3 table - but if ExternalTable is TRUE, then it will

    // compute a SELECT matching ExternalDB settings

    function SQLFromSelectWhere(const SelectFields, Where: RawUTF8): RawUTF8;

    /// define if a FTS4 virtual table will not store its content, but would

    // be defined as an "external content" FTS4 table

    // - see https://www.sqlite.org/fts3.html#section_6_2_2

    // - the virtual table will be created with content="ContentTableName",

    // and all fields of the FTS4 table

    // - by design, all fields of the FTS4 table should exist in the source

    // ContentTable - otherwise an exception is raised

    // - the indexed text will be assigned to the FTS4 table, using triggers

    // generated by TSQLRecordFTS4.InitializeTable at table creation

    // - note that FTS3 does not support this feature

    procedure FTS4WithoutContent(ContentTable: TSQLRecordClass);



    /// the table index of this TSQLRecord in the associated Model

    property TableIndex: Integer read fTableIndex;

    /// direct access to a property RTTI information, by name

    property Prop[const PropName: RawUTF8]: TSQLPropInfo read GetProp; default;

  published

    /// the shared TSQLRecordProperties information of this TSQLRecord

    // - as retrieved from RTTI

    property Props: TSQLRecordProperties read fProps;

    /// define if is a normal table (rSQLite3), an FTS3/FTS4/R-Tree virtual

    // table or a custom TSQLVirtualTable*ID (rCustomForcedID/rCustomAutoID)

    // - when set, all internal SQL statements will be (re)created, depending of

    // the expected ID/RowID column name expected (i.e. SQLTableSimpleFields[]

    // and SQLSelectAll[] - SQLUpdateSet and SQLInsertSet do not include ID)

    property Kind: TSQLRecordVirtualKind read fKind write SetKind default rSQLite3;

  end;



  /// how a TSQLModel stores a foreign link to be cascaded

  TSQLModelRecordReference = record

    TableIndex: integer;

    FieldType: TSQLPropInfo;

    FieldTable: TSQLRecordClass;

    FieldTableIndex: integer;

    CascadeDelete: boolean;

  end;

  PSQLModelRecordReference = ^TSQLModelRecordReference;

  

  /// a Database Model (in a MVC-driven way), for storing some tables types

  // as TSQLRecord classes

  // - share this Model between TSQLRest Client and Server

  // - use this class to access the table properties: do not rely on the

  // low-level database methods (e.g. TSQLDataBase.GetTableNames), since the

  // tables may not exist in the main SQLite3 database, but in-memory or external

  // - don't modify the order of Tables inside this Model, if you publish

  // some TRecordReference property in any of your tables

  TSQLModel = class

  private

    fTables: TSQLRecordClassDynArray;

    fRoot: RawUTF8;

    fRootUpper: RawUTF8;

    fTablesMax: integer;

    fActions: PEnumType;

    fEvents: PEnumType;

    fTableProps: TSQLModelRecordPropertiesObjArray;

    fCustomCollationForAll: array[TSQLFieldType] of RawUTF8;

    {$ifndef LVCL}

    fOnClientIdle: TOnIdleSynBackgroundThread;

    {$endif}

    /// contains the caller of CreateOwnedStream()

    fRestOwner: TSQLRest;

    /// for every table, contains a locked record list

    // - very fast, thanks to the use of a dynamic array with one entry by table

    fLocks: TSQLLocksDynArray;

    /// for fastest SQL Table name lookup via binary search

    fSortedTablesName: TRawUTF8DynArray;

    fSortedTablesNameIndex: TIntegerDynArray;

    /// will contain the registered virtual table modules

    fVirtualTableModule: array of TSQLVirtualTableClass;

    /// this array contain all TRecordReference and TSQLRecord properties

    // existing in the database model

    // - used in TSQLRestServer.Delete() to enforce relational database coherency

    // after deletion of a record: all other records pointing to it will be

    // reset to 0 or deleted (if CascadeDelete is true) by

    // TSQLRestServer.AfterDeleteForceCoherency

    fRecordReferences: array of TSQLModelRecordReference;

    fIDGenerator: array of TSynUniqueIdentifierGenerator;

    procedure SetTableProps(aIndex: integer);

    function GetTableIndexSafe(aTable: TSQLRecordClass;

      RaiseExceptionIfNotExisting: boolean): integer;

    function GetTableProps(aClass: TSQLRecordClass): TSQLModelRecordProperties;

    /// get the enumerate type information about the possible actions to be

    function GetLocks(aTable: TSQLRecordClass): PSQLLocks;

    function GetTable(const SQLTableName: RawUTF8): TSQLRecordClass;

    function GetTableExactIndex(const TableName: RawUTF8): integer;

    function GetTableExactClass(const TableName: RawUTF8): TSQLRecordClass;

    function getURI(aTable: TSQLRecordClass): RawUTF8;

    function getURIID(aTable: TSQLRecordClass; aID: TID): RawUTF8;

    function getURICallBack(const aMethodName: RawUTF8; aTable: TSQLRecordClass; aID: TID): RawUTF8;

  public

    /// initialize the Database Model

    // - set the Tables to be associated with this Model, as TSQLRecord classes

    // - set the optional Root URI path of this Model

    // - initialize the fIsUnique[] array from "stored AS_UNIQUE" (i.e. "stored

    // false") published properties of every TSQLRecordClass

    constructor Create(const Tables: array of TSQLRecordClass; const aRoot: RawUTF8='root'); reintroduce; overload;

    /// you should not use this constructor, but one of the overloaded versions,

    // specifying the associated TSQLRecordClass

    constructor Create; reintroduce; overload;

    /// clone an existing Database Model

    // - all supplied classes won't be redefined as non-virtual:

    // VirtualTableExternalRegister explicit calls are not mandatory here

    constructor Create(CloneFrom: TSQLModel); reintroduce; overload;

    /// initialize the Database Model from an User Interface parameter structure

    // - this constructor will reset all supplied classes to be defined as

    // non-virtual (i.e. Kind=rSQLite3): VirtualTableExternalRegister explicit

    // calls are to be made if tables should be managed as external

    constructor Create(Owner: TSQLRest; TabParameters: PSQLRibbonTabParameters;

      TabParametersCount, TabParametersSize: integer;

      const NonVisibleTables: array of TSQLRecordClass;

      Actions: PTypeInfo=nil; Events: PTypeInfo=nil;

      const aRoot: RawUTF8='root'); reintroduce; overload;

    /// release associated memory

    destructor Destroy; override;

    /// add the class if it doesn't exist yet

    // - return index in Tables[] if not existing yet and successfully added (in this case,

    // aTableIndexCreated^ is set to the newly created index in Tables[])

    // - supplied class will be redefined as non-virtual: VirtualTableExternalRegister

    // explicit call is to be made if table should be managed as external

    // - return FALSE if already present, or TRUE if was added to the internal list

    function AddTable(aTable: TSQLRecordClass; aTableIndexCreated: PInteger=nil): boolean;

    /// add the class if it doesn't exist yet as itself or as inherited class

    // - similar to AddTable(), but any class inheriting from the supplied type

    // would be considered as sufficient

    // - return the class which has been added, or was already there as

    // inherited, so that could be used for further instance creation:

    // ! fSQLAuthUserClass := Model.AddTableInherited(TSQLAuthUser);

    function AddTableInherited(aTable: TSQLRecordClass): pointer;

    /// get the index of aTable in Tables[]

    // - returns -1 if the table is not in the model

    function GetTableIndex(aTable: TSQLRecordClass): integer; overload;

    /// get the index of any class inherithing from aTable in Tables[]

    // - returns -1 if no table is matching in the model

    function GetTableIndexInheritsFrom(aTable: TSQLRecordClass): integer;

    /// get the index of aTable in Tables[]

    // - raise an EModelException if the table is not in the model

    function GetTableIndexExisting(aTable: TSQLRecordClass): integer;

    /// get the index of a table in Tables[]

    // - expects SQLTableName to be SQL-like formatted (i.e. without TSQL[Record])

    function GetTableIndex(const SQLTableName: RawUTF8): integer; overload;

    /// get the index of a table in Tables[]

    // - expects SQLTableName to be SQL-like formatted (i.e. without TSQL[Record])

    function GetTableIndex(SQLTableName: PUTF8Char): integer; overload;

    /// return the UTF-8 encoded SQL source to create the table

    function GetSQLCreate(aTableIndex: integer): RawUTF8;

    /// return the UTF-8 encoded SQL source to add the corresponding field

    // via a "ALTER TABLE" statement

    function GetSQLAddField(aTableIndex, aFieldIndex: integer): RawUTF8;

    /// return the TRecordReference pointing to the specified record

    function RecordReference(Table: TSQLRecordClass; ID: TID): TRecordReference;

    /// return the table class correspondig to a TRecordReference

    function RecordReferenceTable(const Ref: TRecordReference): TSQLRecordClass;

    /// return TRUE if the specified field of this class was marked as unique

    // - an unique field is defined as "stored AS_UNIQUE" (i.e. "stored false")

    // in its property definition

    // - reflects the internal private fIsUnique propery

    function GetIsUnique(aTable: TSQLRecordClass; aFieldIndex: integer): boolean;

    /// try to retrieve a table index from a SQL statement

    // - naive search of '... FROM TableName' pattern in the supplied SQL,

    // using GetTableNameFromSQLSelect() function

    // - if EnsureUniqueTableInFrom is TRUE, it will check that only one Table

    // is in the FROM clause, otherwise it will return the first Table specified

    function GetTableIndexFromSQLSelect(const SQL: RawUTF8; EnsureUniqueTableInFrom: boolean): integer;

    /// try to retrieve one or several table index from a SQL statement

    // - naive search of '... FROM Table1,Table2' pattern in the supplied SQL,

    // using GetTableNamesFromSQLSelect() function

    function GetTableIndexesFromSQLSelect(const SQL: RawUTF8): TIntegerDynArray;

    /// try to retrieve one or several TSQLRecordClass from a SQL statement

    // - naive search of '... FROM Table1,Table2' pattern in the supplied SQL,

    // using GetTableNamesFromSQLSelect() function

    function GetTablesFromSQLSelect(const SQL: RawUTF8): TSQLRecordClassDynArray;

    /// check if the supplied URI matches the model's Root property

    // - allows sub-domains, e.g. if Root='root/sub1', then '/root/sub1/toto' and

    // '/root/sub1?n=1' will match, whereas '/root/sub1nope/toto' won't

    // - the returned enumerates allow to check if the match was exact (e.g.

    // 'root/sub' matches exactly Root='root'), or with character case

    // approximation (e.g. 'Root/sub' approximates Root='root')

    function URIMatch(const URI: RawUTF8): TSQLRestModelMatch;

    /// compute the SQL statement to be executed for a specific SELECT on Tables

    // - you can set multiple Table class in Tables: the statement will contain the

    // table name ('SELECT T1.F1,T1.F2,T1.F3,T2.F1,T2.F2 FROM T1,T2 WHERE ..' e.g.)

    function SQLFromSelectWhere(const Tables: array of TSQLRecordClass;

      const SQLSelect, SQLWhere: RawUTF8): RawUTF8;

    /// set a custom SQlite3 text column collation for all fields of a given

    // type for all TSQLRecord of this model

    // - can be used e.g. to override ALL default COLLATE SYSTEMNOCASE of RawUTF8,

    // or COLLATE ISO8601 for TDateTime, and let the generated SQLite3 file be

    // available outside the scope of mORMot's SQLite3 engine

    // - collations defined within our SynSQLite3 unit are named BINARY, NOCASE,

    // RTRIM and our custom SYSTEMNOCASE, ISO8601, WIN32CASE, WIN32NOCASE: if

    // you want to use the slow but Unicode ready Windows API, set for each model:

    // ! SetCustomCollationForAll(sftUTF8Text,'WIN32CASE');

    // - shall be set on both Client and Server sides, otherwise some issues

    // may occur

    procedure SetCustomCollationForAll(aFieldType: TSQLFieldType;

      const aCollationName: RawUTF8);

    /// allow to validate length of all text published properties of all tables

    // of this model

    // - the "index" attribute of the RawUTF8/string published properties could

    // be used to specify a maximum length for external VARCHAR() columns

    // - SQLite3 will just ignore this "index" information, but it could be

    // handy to be able to validate the value length before sending to the DB

    // - this method will create TSynValidateText corresponding to the maximum

    // field size specified by the "index" attribute, to validate before write

    // - will expect the "index" value to be in UTF-16 codepoints, unless

    // IndexIsUTF8Length is set to TRUE, indicating UTF-8 length

    procedure SetMaxLengthValidatorForAllTextFields(IndexIsUTF8Length: boolean=false);

    /// allow to filter the length of all text published properties of all tables

    // of this model

    // - the "index" attribute of the RawUTF8/string published properties could

    // be used to specify a maximum length for external VARCHAR() columns

    // - SQLite3 will just ignore this "index" information, but it could be

    // handy to be able to filter the value length before sending to the DB

    // - this method will create TSynFilterTruncate corresponding to the maximum

    // field size specified by the "index" attribute, to validate before write

    // - will expect the "index" value to be in UTF-16 codepoints, unless

    // IndexIsUTF8Length is set to TRUE, indicating UTF-8 length

    procedure SetMaxLengthFilterForAllTextFields(IndexIsUTF8Length: boolean=false);

    {$ifndef NOVARIANTS}

    /// customize the TDocVariant options for all variant published properties

    // - will change the TSQLPropInfoRTTIVariant.DocVariantOptions value

    // - use e.g. as SetVariantFieldDocVariantOptions(JSON_OPTIONS_FAST_EXTENDED)

    procedure SetVariantFieldsDocVariantOptions(const Options: TDocVariantOptions);

    {$endif}

    /// force a given table to use a TSynUniqueIdentifierGenerator for its IDs

    /// - would initialize a generator for the supplied table, using 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

    function SetIDGenerator(aTable: TSQLRecordClass;

      aIdentifier: TSynUniqueIdentifierProcess; const aSharedObfuscationKey: RawUTF8=''): TSynUniqueIdentifierGenerator;

    /// returns the TSynUniqueIdentifierGenerator associated to a table, if any 

    function GetIDGenerator(aTable: TSQLRecordClass): TSynUniqueIdentifierGenerator;



    /// assign an enumeration type to the possible actions to be performed

    // with this model

    // - call with the TypeInfo() pointer result of an enumeration type

    // - actions are handled by TSQLRecordForList in the mORMotToolBar.pas unit

    procedure SetActions(aActions: PTypeInfo);

    /// assign an enumeration type to the possible events to be triggered

    // with this class model

    // - call with the TypeInfo() pointer result of an enumeration type

    procedure SetEvents(aEvents: PTypeInfo);

    /// get the text conversion of a given Action, ready to be displayed

    function ActionName(const Action): string;

    /// get the text conversion of a given Event, ready to be displayed

    function EventName(const Event): string;



    /// register a Virtual Table module for a specified class

    // - to be called server-side only (Client don't need to know the virtual

    // table implementation details, and it will increase the code size)

    // - aClass parameter could be either a TSQLRecordVirtual class, either

    // a TSQLRecord class which has its kind set to rCustomForcedID or

    // rCustomAutoID (e.g. TSQLRecordMany calling VirtualTableExternalRegister)

    // - optional aExternalTableName and aExternalDataBase can be used to

    // specify e.g. connection parameters as expected by mORMotDB

    // - call it before TSQLRestServer.Create()

    function VirtualTableRegister(aClass: TSQLRecordClass;

      aModule: TSQLVirtualTableClass; const aExternalTableName: RawUTF8='';

      aExternalDataBase: TObject=nil): boolean;

    /// retrieve a Virtual Table module associated to a class

    function VirtualTableModule(aClass: TSQLRecordClass): TSQLVirtualTableClass;



    /// create a New TSQLRecord instance for a specific Table

    // - expects SQLTableName to be SQL-like formated (i.e. without TSQL[Record])

    // - use this to create a working copy of a table's record, e.g.

    // - don't forget to Free it when not used any more (use a try...finally

    // block)

    // - it's prefered in practice to directly call TSQLRecord*.Create()

    // in your code

    function NewRecord(const SQLTableName: RawUTF8): TSQLRecord;



    /// lock a record

    // - returns true on success, false if was already locked

    function Lock(aTable: TSQLRecordClass; aID: TID): boolean; overload;

    /// lock a record

    // - returns true on success, false if was already locked

    function Lock(aTableIndex, aID: TID): boolean; overload;

    /// lock a record

    // - returns true on success, false if was already locked

    function Lock(aRec: TSQLRecord): boolean; overload;

    /// unlock a specified record

    // - returns true on success, false if was not already locked

    function UnLock(aTable: TSQLRecordClass; aID: TID): boolean; overload;

    /// unlock a specified record

    // - returns true on success, false if was not already locked

    function UnLock(aTableIndex: integer; aID: TID): boolean; overload;

    /// unlock a specified record

    // - returns true on success, false if was not already locked

    function UnLock(aRec: TSQLRecord): boolean; overload;

    /// unlock all previously locked records

    procedure UnLockAll;

    /// return true if a specified record is locked

    function isLocked(aTable: TSQLRecordClass; aID: TID): boolean; overload;

    /// return true if a specified record is locked

    function isLocked(aRec: TSQLRecord): boolean; overload;

    /// delete all the locked IDs entries, after a specified time

    // - to be used to release locked records if the client crashed

    // - default value is 30 minutes, which seems correct for common usage

    procedure PurgeOlderThan(MinutesFromNow: cardinal=30);

    /// get the classes list (TSQLRecord descendent) of all available tables

    property Tables: TSQLRecordClassDynArray read fTables;

    /// get a class from a table name

    // - expects SQLTableName to be SQL-like formated (i.e. without TSQL[Record])

    property Table[const SQLTableName: RawUTF8]: TSQLRecordClass read GetTable; default;

    /// get a class from a table TableName (don't truncate TSQLRecord* if necessary)

    property TableExact[const TableName: RawUTF8]: TSQLRecordClass read GetTableExactClass;

    /// get the URI for a class in this Model, as 'ModelRoot/SQLTableName'

    property URI[aClass: TSQLRecordClass]: RawUTF8 read getURI;

    /// the associated ORM information for a given TSQLRecord class

    // - raise an EModelException if aClass is not declared within this model

    // - returns the corresponding TableProps[] item if the class is known

    property Props[aClass: TSQLRecordClass]: TSQLModelRecordProperties read GetTableProps;

    /// the maximum index of TableProps[] class properties array

    property TablesMax: integer read fTablesMax;

    // performed with this model

    // - Actions are e.g. linked to some buttons in the User Interface

    property Actions: PEnumType read fActions;

    /// get the enumerate type information about the possible Events to be

    // performed with this model

    // - Events can be linked to actions and custom status, to provide a

    // centralized handling of logging (e.g. in an Audit Trail table)

    property Events: PEnumType read fEvents;

    /// this property value is used to auto free the database Model class

    // - set this property after Owner.Create() in order to have

    // Owner.Destroy autofreeing it

    property Owner: TSQLRest read fRestOwner write fRestOwner;

    /// for every table, contains a locked record list

    // - very fast, thanks to the use one TSQLLocks entry by table

    property Locks: TSQLLocksDynArray read fLocks;

    {$ifndef LVCL}

    /// set a callback event to be executed in loop during client remote

    // blocking process, e.g. to refresh the UI during a somewhat long request

    // - will be passed to TSQLRestClientURI.OnIdle property by

    // TSQLRestClientURI.RegisteredClassCreateFrom() method, if applying

    property OnClientIdle: TOnIdleSynBackgroundThread

      read fOnClientIdle write fOnClientIdle;

    {$endif}

  published

    /// the Root URI path of this Database Model

    property Root: RawUTF8 read fRoot write fRoot;

    /// the associated ORM information about all handled TSQLRecord class properties

    // - this TableProps[] array will map the Tables[] array, and will allow

    // fast direct access to the Tables[].RecordProps values

    property TableProps: TSQLModelRecordPropertiesObjArray read fTableProps;

  end;



  PRecordRef = ^RecordRef;



  /// useful object to type cast TRecordReference type value into explicit

  // TSQLRecordClass and ID

  // - use RecordRef(Reference).TableIndex/Table/ID/Text methods to retrieve

  // the details of a TRecordReference encoded value

  // - use TSQLRest.Retrieve(Reference) to get a record content from DB

  // - instead of From(Reference).From(), you could use the more explicit

  // TSQLRecord.RecordReference(Model) or TSQLModel.RecordReference()

  // methods or RecordReference() function to encode the value

  // - don't change associated TSQLModel tables order, since TRecordReference

  // depends on it to store the Table type

  // - since 6 bits are used for the table index, the corresponding table

  // MUST appear in the first 64 items of the associated TSQLModel.Tables[]

  RecordRef = {$ifndef ISDELPHI2010}object{$else}record{$endif}

  public

    /// the value itself

    // - (value and 63) is the TableIndex in the current database Model

    // - (value shr 6) is the ID of the record in this table

    // - value=0 means no reference stored

    // - we use this coding and not the opposite (Table in MSB) to minimize

    // integer values; but special UTF8CompareRecord() function has to be used

    // for sorting

    // - type definition matches TRecordReference (i.e. Int64/TID) to allow

    // typecast as such:

    // ! aClass := PRecordRef(@Reference)^.Table(Model);

    Value: TID;

    /// return the index of the content Table in the TSQLModel

    function TableIndex: integer;  {$ifdef HASINLINE}inline;{$endif}

    /// return the class of the content in a specified TSQLModel

    function Table(Model: TSQLModel): TSQLRecordClass;

    /// return the ID of the content

    function ID: TID;              {$ifdef HASINLINE}inline;{$endif}

    /// fill Value with the corresponding parameters

    // - since 6 bits are used for the table index, aTable MUST appear in the

    // first 64 items of the associated TSQLModel.Tables[] array

    procedure From(Model: TSQLModel; aTable: TSQLRecordClass; aID: TID);

    /// get a ready to be displayed text from the stored Table and ID

    // - display 'Record 2301' e.g.

    function Text(Model: TSQLModel): RawUTF8; overload;

    /// get a ready to be displayed text from the stored Table and ID

    // - display 'Record "RecordName"' e.g.

    function Text(Rest: TSQLRest): RawUTF8; overload;

  end;



  /// this kind of record array can be used for direct coordinates storage

  TSQLRecordTreeCoords = array[0..RTREE_MAX_DIMENSION-1] of packed record

    min, max: double; end;



  /// a base record, corresponding to an R-Tree table

  // - an R-Tree is a special index that is designed for doing range queries.

  // R-Trees are most commonly used in geospatial systems where each entry is a

  // rectangle with minimum and maximum X and Y coordinates. Given a query

  // rectangle, an R-Tree is able to quickly find all entries that are contained

  // within the query rectangle or which overlap the query rectangle. This idea

  // is easily extended to three dimensions for use in CAD systems. R-Trees also

  // find use in time-domain range look-ups. For example, suppose a database

  // records the starting and ending times for a large number of events. A R-Tree

  // is able to quickly find all events, for example, that were active at any

  // time during a given time interval, or all events that started during a

  // particular time interval, or all events that both started and ended within

  // a given time interval. And so forth. See http:// www.sqlite.org/rtree.html

  // - any record which inherits from this class must have only sftFloat

  // (double) fields, grouped by pairs, each as minimum- and maximum-value,

  // up to 5 dimensions (i.e. 11 columns, including the ID property)

  // - the ID: TID property must be set before adding a TSQLRecordRTree to

  // the database, e.g. to link a R-Tree representation to a regular

  // TSQLRecord table

  // - queries against the ID or the coordinate ranges are almost immediate: so

  // you can e.g. extract some coordinates box from the regular TSQLRecord

  // table, then use a TSQLRecordRTree joined query to make the process faster;

  // this is exactly what the TSQLRestClient.RTreeMatch method offers

  TSQLRecordRTree = class(TSQLRecordVirtual)

  public

    { override this class function to implement a custom box coordinates

      from a given BLOB content

      - by default, the BLOB array will contain a simple array of double

      - but you can override this method to handle a custom BLOB field content,

        intended to hold some kind of binary representation of the precise

        boundaries of the object, and convert it into box coordinates as

        understood by the ContainedIn() class function

      - the number of pairs in OutCoord will be taken from the current number

        of published double properties

      - used e.g. by the TSQLRestClient.RTreeMatch method }

    class procedure BlobToCoord(const InBlob; var OutCoord: TSQLRecordTreeCoords); virtual;

    { override this class function to implement a custom SQL *_in() function

      - by default, the BLOB array will be decoded via the BlobToCoord class

        procedure, and will create a SQL function from the class name

      - for instance, the following class will define a 2 dimensional

        MapBox_in() function

      ! TSQLRecordMapBox = class(TSQLRecordRTree)

      ! protected

      !   fMinX, fMaxX, fMinY, fMaxY: double;

      ! published

      !   property MinX: double read fMinX write fMinX;

      !   property MaxX: double read fMaxX write fMaxX;

      !   property MinY: double read fMinY write fMinY;

      !   property MaxY: double read fMaxY write fMaxY;

      ! end;

      - used e.g. by the TSQLRestClient.RTreeMatch method   }

    class function ContainedIn(const BlobA,BlobB): boolean; virtual;

    /// will return 'MapBox_in' e.g. for TSQLRecordMapBox

    class function RTreeSQLFunctionName: RawUTF8;

  end;



  /// a base record, corresponding to a FTS3 table, i.e. implementing full-text

  // - FTS3/FTS4 table are SQLite virtual tables which allow users to perform

  // full-text searches on a set of documents. The most common (and effective)

  // way to describe full-text searches is "what Google, Yahoo and Altavista do

  // with documents placed on the World Wide Web". Users input a term, or

  // series of terms, perhaps connected by a binary operator or grouped together

  // into a phrase, and the full-text query system finds the set of documents

  // that best matches those terms considering the operators and groupings the

  // user has specified. See http:// sqlite.org/fts3.html

  // - any record which inherits from this class must have only sftUTF8Text

  // (RawUTF8) fields - with Delphi 2009+, you can have string fields

  // - this record has its fID: TID property which may be published

  // as DocID, to be consistent with SQLite3 praxis, and reflect that it

  // points to an ID of another associated TSQLRecord

  // - a good approach is to store your data in a regular TSQLRecord table, then

  // store your text content in a separated FTS3 table, associated to this

  // TSQLRecordFTS3 table via its ID/DocID

  // - the ID/DocID property can be set when the record is added, to retrieve any

  // associated TSQLRecord (note that for a TSQLRecord record,

  // the ID property can't be set at adding, but is calculated by the engine)

  // - static tables don't handle TSQLRecordFTS3 classes

  // - by default, the FTS3 engine ignore all characters >= #80, but handle

  // low-level case insentivity (i.e. 'A'..'Z') so you must keep your

  // request with the same range for upper case

  // - by default, the "simple" tokenizer is used, but you can inherits from

  // TSQLRecordFTS3Porter class if you want a better English matching, using

  // the Porter Stemming algorithm, or TSQLRecordFTS3Unicode61 for Unicode

  // support - see http:// sqlite.org/fts3.html#tokenizer

  // - you can select either the FTS3 engine, or the more efficient (and new)

  // FTS4 engine (available since version 3.7.4), by using the TSQLRecordFTS4 type

  // - in order to make FTS3/FTS4 queries, use the dedicated TSQLRest.FTSMatch

  // method, with the MATCH operator (you can use regular queries, but you must

  // specify 'RowID' instead of 'DocID' or 'ID' because of FTS3 Virtual

  // table specificity):

  // ! var IDs: TIDDynArray;

  // ! if FTSMatch(TSQLMyFTS3Table,'text MATCH "linu*"',IDs) then

  // !  //  you have all matching IDs in IDs[]

  TSQLRecordFTS3 = class(TSQLRecordVirtual)

  public

     /// optimize the FTS3 virtual table

     // - this causes FTS3 to merge all existing index b-trees into a single large

     // b-tree containing the entire index. This can be an expensive operation,

     // but may speed up future queries. See http://sqlite.org/fts3.html#section_1_2

     // - this method must be called server-side

     // - returns TRUE on success

     class function OptimizeFTS3Index(Server: TSQLRestServer): boolean;

     /// this DocID property map the internal Row_ID property

     // - but you can set a value to this property before calling the Add()

     // method, to associate this TSQLRecordFTS3 to another TSQLRecord

     // - ID property is read-only, but this DocID property can be written/set

     // - internaly, we use RowID in the SQL statements, which is compatible

     // with both TSQLRecord and TSQLRecordFTS3 kind of table

     property DocID: TID read GetID write fID;

  end;



  /// this base class will create a FTS3 table using the Porter Stemming algorithm

  // - see http://sqlite.org/fts3.html#tokenizer

  TSQLRecordFTS3Porter = class(TSQLRecordFTS3);



  /// this base class will create a FTS3 table using the Unicode61 Stemming algorithm

  // - see http://sqlite.org/fts3.html#tokenizer

  TSQLRecordFTS3Unicode61 = class(TSQLRecordFTS3);



  /// class-reference type (metaclass) of a FTS3/FTS4 virtual table

  TSQLRecordFTS3Class = class of TSQLRecordFTS3;



  /// class-reference type (metaclass) of a RTREE virtual table

  TSQLRecordRTreeClass = class of TSQLRecordRTree;



  /// a base record, corresdonding to a FTS4 table, which is an enhancement to FTS3

  // - FTS3 and FTS4 are nearly identical. They share most of their code in common,

  // and their interfaces are the same. The only difference is that FTS4 stores

  // some additional information about the document collection in two of new FTS

  // shadow tables. This additional information allows FTS4 to use certain

  // query performance optimizations that FTS3 cannot use. And the added information

  // permits some additional useful output options in the matchinfo() function.

  // - For newer applications, TSQLRecordFTS4 is recommended; though if minimal disk

  // usage or compatibility with older versions of SQLite are important, then

  // TSQLRecordFTS3 will usually serve just as well.

  // - see http:// sqlite.org/fts3.html#section_1_1

  TSQLRecordFTS4 = class(TSQLRecordFTS3)

  public

    /// this overriden method will create TRIGGERs for FTSWithoutContent()

    class procedure InitializeTable(Server: TSQLRestServer; const FieldName: RawUTF8;

      Options: TSQLInitializeTableOptions); override;

  end;



  /// this base class will create a FTS4 table using the Porter Stemming algorithm

  // - see http://sqlite.org/fts3.html#tokenizer

  TSQLRecordFTS4Porter = class(TSQLRecordFTS4);



  /// this base class will create a FTS4 table using the Unicode61 Stemming algorithm

  // - see http://sqlite.org/fts3.html#tokenizer

  TSQLRecordFTS4Unicode61 = class(TSQLRecordFTS4);



  /// the kind of fields to be available in a Table resulting of

  // a TSQLRecordMany.DestGetJoinedTable() method call

  // - Source fields are not available, because they will be always the same for

  // a same SourceID, and they should be available from the TSQLRecord which

  // hold the TSQLRecordMany instance

  // - jkDestID and jkPivotID will retrieve only DestTable.ID and PivotTable.ID

  // - jkDestFields will retrieve DestTable.* simple fields, or the fields

  // specified by aCustomFieldsCSV (the Dest table name will be added: e.g.

  // for aCustomFieldsCSV='One,Two', will retrieve DestTable.One, DestTable.Two)

  // - jkPivotFields will retrieve PivotTable.* simple fields, or the fields

  // specified by aCustomFieldsCSV (the Pivot table name will be added: e.g.

  // for aCustomFieldsCSV='One,Two', will retrieve PivotTable.One, PivotTable.Two)

  // - jkPivotAndDestAllFields for PivotTable.* and DestTable.* simple fields,

  // or will retrieve the specified aCustomFieldsCSV fields (with

  // the table name associated: e.g. 'PivotTable.One, DestTable.Two')

  TSQLRecordManyJoinKind = (

    jkDestID, jkPivotID, jkDestFields, jkPivotFields, jkPivotAndDestFields);



  /// handle "has many" and "has many through" relationships

  // - many-to-many relationship is tracked using a table specifically for that

  // relationship, turning the relationship into two one-to-many relationships

  // pointing in opposite directions

  // - by default, only two TSQLRecord (i.e. INTEGER) fields must be created,

  // named "Source" and "Dest", the first pointing to the source record (the one

  // with a TSQLRecordMany published property) and the second to the destination record

  // - you should first create a type inheriting from TSQLRecordMany, which

  // will define the pivot table, providing optional "through" parameters if needed

  // ! TSQLDest = class(TSQLRecord);

  // ! TSQLSource = class;

  // ! TSQLDestPivot = class(TSQLRecordMany)

  // ! private

  // !  fSource: TSQLSource;

  // !  fDest: TSQLDest;

  // !  fTime: TDateTime;

  // ! published

  // !   property Source: TSQLSource read fSource; // map Source column

  // !   property Dest: TSQLDest read fDest; // map Dest column

  // !   property AssociationTime: TDateTime read fTime write fTime;

  // ! end;

  // ! TSQLSource = class(TSQLRecord)

  // ! private

  // !   fDestList: TSQLDestPivot;

  // ! published

  // !   DestList: TSQLDestPivot read fDestList;

  // ! end;

  // - in all cases, at leat two 'Source' and 'Dest' published properties must

  // be declared as TSQLRecord children in any TSQLRecordMany descendant

  // because they will always be needed for the 'many to many' relationship

  // - when a TSQLRecordMany published property exists in a TSQLRecord, it is

  // initialized automaticaly by TSQLRecord.Create

  // - to add some associations to the pivot table, use the ManyAdd() method

  // - to retrieve an association, use the ManySelect() method

  // - to delete an association, use the ManyDelete() method

  // - to read all Dest records IDs, use the DestGet() method

  // - to read the Dest records and the associated "through" fields content, use

  // FillMany then FillRow, FillOne and FillRewind methods to loop through records

  // - to read all Source records and the associaed "through" fields content,

  // FillManyFromDest then FillRow, FillOne and FillRewind methods

  // - to read all Dest IDs after a join to the pivot table, use DestGetJoined

  TSQLRecordMany = class(TSQLRecord)

  protected

    // internal fields initialized during TSQLRecord.Create

    // - map to the Source and Dest properties field values in TSQLRecord values

    fSourceID: PPtrInt;

    fDestID: PPtrInt;

    /// retrieve the TSQLRecordMany ID from a given source+dest IDs pair

    function InternalIDFromSourceDest(aClient: TSQLRest; aSourceID, aDestID: TID): TID;

    function InternalFillMany(aClient: TSQLRest; aID: TID;

      const aAndWhereSQL: RawUTF8; isDest: boolean): integer;

  public

    /// initialize this instance, and needed internal fields

    // - will set protected fSourceID/fDestID fields

    constructor Create; override;

    /// retrieve all records associated to a particular source record, which

    // has a TSQLRecordMany property

    // - returns the Count of records corresponding to this aSource record

    // - the records are stored in an internal TSQLTable, refered in the private

    // fTable field, and initialized via a FillPrepare call: all Dest items

    // are therefore accessible with standard FillRow, FillOne and FillRewind methods

    // - use a "for .." loop or a "while FillOne do ..." loop to iterate

    // through all Dest items, getting also any additional 'through' columns

    // - if source ID parameter is 0, the ID is taken from the fSourceID field

    // (set by TSQLRecord.Create)

    // - note that if the Source record has just been added, fSourceID is not

    // set, so this method will fail: please specify aSourceID parameter with

    // the one just added/created

    // - the optional aAndWhereSQL parameter can be used to add any additional

    // condition to the WHERE statement (e.g. 'Salary>:(1000): AND Salary<:(2000):')

    // according to TSQLRecordMany properties - note that you should better use

    // inlined parameters for faster processing on server, so you may call e.g.

    // ! aRec.FillMany(Client,0,FormatUTF8('Salary>? AND Salary<?',[],[1000,2000]));

    function FillMany(aClient: TSQLRest; aSourceID: TID=0;

      const aAndWhereSQL: RawUTF8=''): integer;

    /// retrieve all records associated to a particular Dest record, which

    // has a TSQLRecordMany property

    // - returns the Count of records corresponding to this aSource record

    // - use a "for .." loop or a "while FillOne do ..." loop to iterate

    // through all Dest items, getting also any additional 'through' columns

    // - the optional aAndWhereSQL parameter can be used to add any additional

    // condition to the WHERE statement (e.g. 'Salary>:(1000): AND Salary<:(2000):')

    // according to TSQLRecordMany properties - note that you should better use

    // inlined parameters for faster processing on server, so you may call e.g.

    // ! aRec.FillManyFromDest(Client,DestID,FormatUTF8('Salary>? AND Salary<?',[],[1000,2000]));

    function FillManyFromDest(aClient: TSQLRest; aDestID: TID;

      const aAndWhereSQL: RawUTF8=''): integer;

    /// retrieve all Dest items IDs associated to the specified Source

    function DestGet(aClient: TSQLRest; aSourceID: TID; out DestIDs: TIDDynArray): boolean; overload;

    /// retrieve all Dest items IDs associated to the current Source ID

    // - source ID is taken from the fSourceID field (set by TSQLRecord.Create)

    // - note that if the Source record has just been added, fSourceID is not

    // set, so this method will fail: please call the other overloaded method

    function DestGet(aClient: TSQLRest; out DestIDs: TIDDynArray): boolean; overload;

    /// retrieve all Source items IDs associated to the specified Dest ID

    function SourceGet(aClient: TSQLRest; aDestID: TID; out SourceIDs: TIDDynArray): boolean;

    /// retrieve all Dest items IDs associated to the current or

    // specified Source ID, adding a WHERE condition against the Dest rows

    // - if aSourceID is 0, the value is taken from current fSourceID field

    // (set by TSQLRecord.Create)

    // - aDestWhereSQL can specify the Dest table name in the statement, e.g.

    //  'Salary>:(1000): AND Salary<:(2000):' - note that you should better use

    // inlined parameters for faster processing on server, so you may use the

    // more convenient function

    // ! FormatUTF8('Salary>? AND Salary<?',[],[1000,2000])

    // - this is faster than a manual FillMany() then loading each Dest,

    // because the condition is executed in the SQL statement by the server

    function DestGetJoined(aClient: TSQLRest; const aDestWhereSQL: RawUTF8;

      aSourceID: TID; out DestIDs: TIDDynArray): boolean; overload;

    /// create a Dest record, then FillPrepare() it to retrieve all Dest items

    // associated to the current or specified Source ID, adding a WHERE condition

    // against the Dest rows

    // - if aSourceID is 0, the value is taken from current fSourceID field

    // (set by TSQLRecord.Create)

    // - aDestWhereSQL can specify the Dest table name in the statement, e.g.

    // 'Salary>:(1000): AND Salary<:(2000):') according to TSQLRecordMany

    // properties - note that you should better use such inlined parameters as

    // ! FormatUTF8('Salary>? AND Salary<?',[],[1000,2000])

    function DestGetJoined(aClient: TSQLRest; const aDestWhereSQL: RawUTF8;

      aSourceID: TID): TSQLRecord; overload;

    /// create a TSQLTable, containing all specified Fields, after a JOIN

    // associated to the current or specified Source ID

    // - the Table will have the fields specified by the JoinKind parameter

    // - aCustomFieldsCSV can be used to specify which fields must be retrieved

    // (for jkDestFields, jkPivotFields, jkPivotAndDestFields) - default is all

    // - if aSourceID is 0, the value is taken from current fSourceID field

    // (set by TSQLRecord.Create)

    // - aDestWhereSQL can specify the Dest table name in the statement, e.g.

    // 'Salary>:(1000): AND Salary<:(2000):') according to TSQLRecordMany

    // properties - note that you should better use such inlined parameters as

    // ! FormatUTF8('Salary>? AND Salary<?',[],[1000,2000])

    function DestGetJoinedTable(aClient: TSQLRest; const aDestWhereSQL: RawUTF8;

      aSourceID: TID; JoinKind: TSQLRecordManyJoinKind;

      const aCustomFieldsCSV: RawUTF8=''): TSQLTable;

    /// add a Dest record to the Source record list

    // - returns TRUE on success, FALSE on error

    // - if NoDuplicates is TRUE, the existence of this Source/Dest ID pair

    // is first checked

    // - current Source and Dest properties are filled with the corresponding

    // TRecordReference values corresponding to the supplied IDs

    // - any current value of the additional fields are used to populate the

    // newly created content (i.e. all published properties of this record)

    // - if aUseBatch is set, it will use this TSQLRestBach.Add() instead

    // of the slower aClient.Add() method

    function ManyAdd(aClient: TSQLRest; aSourceID, aDestID: TID;

      NoDuplicates: boolean=false; aUseBatch: TSQLRestBatch=nil): boolean; overload;

    /// add a Dest record to the current Source record list

    // - source ID is taken from the fSourceID field (set by TSQLRecord.Create)

    // - note that if the Source record has just been added, fSourceID is not

    // set, so this method will fail: please call the other overloaded method

    function ManyAdd(aClient: TSQLRest; aDestID: TID;

      NoDuplicates: boolean=false): boolean; overload;

    /// will delete the record associated with a particular Source/Dest pair

    // - will return TRUE if the pair was found and successfully deleted

    // - if aUseBatch is set, it will use this TSQLRestBach.Delete() instead

    // of the slower aClient.Delete() method

    function ManyDelete(aClient: TSQLRest; aSourceID, aDestID: TID;

      aUseBatch: TSQLRestBatch=nil): boolean; overload;

    /// will delete the record associated with the current source and a specified Dest

    // - source ID is taken from the fSourceID field (set by TSQLRecord.Create)

    // - note that if the Source record has just been added, fSourceID is not

    // set, so this method will fail: please call the other overloaded method

    function ManyDelete(aClient: TSQLRest; aDestID: TID): boolean; overload;

    /// will retrieve the record associated with a particular Source/Dest pair

    // - will return TRUE if the pair was found

    // - in this case, all "through" columns are available in the TSQLRecordMany

    // field instance

    function ManySelect(aClient: TSQLRest; aSourceID, aDestID: TID): boolean; overload;

    /// will retrieve the record associated with the current source and a specified Dest

    // - source ID is taken from the fSourceID field (set by TSQLRecord.Create)

    // - note that if the Source record has just been added, fSourceID is not

    // set, so this method will fail: please call the other overloaded method

    function ManySelect(aClient: TSQLRest; aDestID: TID): boolean; overload;



    // get the SQL WHERE statement to be used to retrieve the associated

    // records according to a specified ID

    // - search for aID as Source ID if isDest is FALSE

    // - search for aID as Dest ID if isDest is TRUE

    // - the optional aAndWhereSQL parameter can be used to add any additional

    // condition to the WHERE statement (e.g. 'Salary>:(1000): AND Salary<:(2000):')

    // according to TSQLRecordMany properties - note that you should better use

    // such inlined parameters e.g. calling

    // ! FormatUTF8('Salary>? AND Salary<?',[],[1000,2000])

    function IDWhereSQL(aClient: TSQLRest; aID: TID; isDest: boolean;

      const aAndWhereSQL: RawUTF8=''): RawUTF8;

  end;



  /// a base record, with a JSON-logging capability

  // - used to store a log of events into a JSON text, easy to be displayed

  // with a TSQLTableToGrid

  // - this log can then be stored as a RawUTF8 field property into a result

  // record, for instance

  TSQLRecordLog = class(TSQLRecord)

  protected

    /// store the Log Table JSON content

    fLogTableStorage: TMemoryStream;

    /// used by Log() to add the value of OneLog to fLogTableStorage

    fLogTableWriter: TJSONSerializer;

    /// current internal row count

    fLogTableRowCount: integer;

    /// maximum rows count

    fMaxLogTableRowCount: integer;

  public

    /// initialize the internal storage with a supplied JSON content

    // - this JSON content must follow the format retrieved by

    // LogTableJSON and LogTableJSONFrom methods

    constructor CreateFrom(OneLog: TSQLRecord; const aJSON: RawUTF8);

    /// release the private fLogTableWriter and fLogTableStorage objects

    destructor Destroy; override;

    /// add the value of OneLog to the Log Table JSON content

    // - the ID property of the supplied OneLog record is incremented before adding

    procedure Log(OneLog: TSQLRecord);

    /// returns the JSON data as added by previous call to Log()

    // - JSON data is in not-expanded format

    // - this function can be called multiple times

    function LogTableJSON: RawUTF8;

    /// returns the internal position of the Log content

    // - use this value to later retrieve a log range with LogTableJSONFrom()

    function LogCurrentPosition: integer;

    /// returns the log JSON data from a given start position

    // - StartPosition was retrieved previously with LogCurrentPosition

    // - if StartPosition=0, the whole Log content is returned

    // - multiple instances of LogCurrentPosition/LogTableJSONFrom() can be

    // used at once

    function LogTableJSONFrom(StartPosition: integer): RawUTF8;

    /// the current associated Log Table rows count value

    // - is incremented every time Log() method is called

    // - will be never higher than MaxLogTableRowCount below (if set)

    property LogTableRowCount: integer read fLogTableRowCount;

    /// if the associated Log Table rows count reachs this value, the

    // first data row will be trimed

    // - do nothing is value is left to 0 (which is the default)

    // - total rows count won't never be higher than this value

    // - used to spare memory usage

    property MaxLogTableRowCount: integer read fMaxLogTableRowCount;

  end;



  /// common ancestor for tables with digitally signed RawUTF8 content

  // - content is signed according to a specific User Name and the digital

  // signature date and time

  // - internaly uses the very secure SHA-256 hashing algorithm for performing

  // the digital signature

  TSQLRecordSigned = class(TSQLRecord)

  protected

    /// time and date of signature

    fSignatureTime: TTimeLog;

    /// hashed signature

    fSignature: RawUTF8;

  public

    /// time and date of signature

    // - if the signature is invalid, this field will contain numerical 1 value

    // - this property is defined here to allow inherited to just declared the name

    // in its published section:

    // ! property SignatureTime;

    property SignatureTime: TTimeLog read fSignatureTime write fSignatureTime;

    /// as the Content of this record is added to the database,

    // its value is hashed and stored as 'UserName/03A35C92....' into this property

    // - very secured SHA-256 hashing is used internaly

    // - digital signature is allowed only once: this property is written only once

    // - this property is defined here to allow inherited to just declared the name

    // in its published section:

    // ! property SignatureTime;

    property Signature: RawUTF8 read fSignature write fSignature;

  public

    /// use this procedure to sign the supplied Content of this record for a

    // specified UserName, with the current Date and Time  (SHA-256 hashing is used

    // internaly)

    // - returns true if signed successfully (not already signed)

    function SetAndSignContent(const UserName: RawUTF8;

      const Content: RawByteString; ForcedSignatureTime: Int64=0): boolean;

    /// returns true if this record content is correct according to the

    // stored digital Signature

    function CheckSignature(const Content: RawByteString): boolean;

    /// retrieve the UserName who digitally signed this record

    // - returns '' if was not digitally signed

    function SignedBy: RawUTF8;

    /// reset the stored digital signature

    // - SetAndSignContent() can be called after this method

    procedure UnSign;

  end;



  /// a base record, which would have creation and modification timestamp fields

  TSQLRecordTimed = class(TSQLRecord)

  protected

    fCreated: TCreateTime;

    fModified: TModTime;

  published

    /// will be filled by the ORM when this item will be created in the database

    property Created: TCreateTime read fCreated write fCreated;

    /// will be filled by the ORM each time this item will be written in the database

    property Modified: TModTime read fModified write fModified;

  end;



  /// common ancestor for tables which should implement any interface

  // - by default, TSQLRecord does not implement any interface: this does make

  // sense for performance and resource use reasons

  // - inherit from this class if you want your class to implement the needed

  // IInterface methods (QueryInterface/AddRef/Release)

  TSQLRecordInterfaced = class(TSQLRecord, IInterface)

  protected

    fRefCount: Integer;

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

    class function NewInstance: TObject; override;

    procedure AfterConstruction; override;

    procedure BeforeDestruction; override;

    property RefCount: Integer read fRefCount;

  end;



  /// the possible Server-side instance implementation patterns for

  // interface-based services

  // - each interface-based service will be implemented by a corresponding

  // class instance on the server: this parameter is used to define how

  // class instances are created and managed

  // - on the Client-side, each instance will be handled depending on the

  // server side implementation (i.e. with sicClientDriven behavior if necessary)

  // - sicSingle: one object instance is created per call - this is the

  // most expensive way of implementing the service, but is safe for simple

  // workflows (like a one-type call); this is the default setting for

  // TSQLRestServer.ServiceRegister method

  // - sicShared: one object instance is used for all incoming calls and is

  // not recycled subsequent to the calls - the implementation should be

  // thread-safe on the server side

  // - sicClientDriven: one object instance will be created in synchronization

  // with the client-side lifetime of the corresponding interface: when the

  // interface will be released on client, it will be released on the server

  // side - a numerical identifier will be transmitted for all JSON requests

  // - sicPerSession, sicPerUser and sicPerGroup modes will maintain one

  // object instance per running session / user / group (only working if

  // RESTful authentication is enabled) - since it may be shared among users or

  // groups, the sicPerUser and sicPerGroup implementation should be thread-safe

  // - sicPerThread will maintain one object instance per calling thread - it

  // may be useful instead of sicShared mode if the service process expects

  // some per-heavy thread initialization, for instance

  TServiceInstanceImplementation = (

    sicSingle, sicShared, sicClientDriven, sicPerSession, sicPerUser, sicPerGroup,

    sicPerThread);

  /// set of Server-side instance implementation patterns for

  // interface-based services

  TServiceInstanceImplementations = set of TServiceInstanceImplementation;



  /// handled kind of parameters for an interface-based service provider method

  // - we do not handle all kind of Delphi variables, but provide some

  // enhanced types handled by JSONToObject/ObjectToJSON functions (smvObject)

  // or TDynArray.LoadFromJSON / TTextWriter.AddDynArrayJSON methods (smvDynArray)

  // - records will be serialized as Base64 string, with our RecordSave/RecordLoad

  // low-level format by default, or as true JSON objects since Delphi 2010 or

  // after registration via a TTextWriter.RegisterCustomJSONSerializer call

  // - smvRawJSON will transmit the raw JSON content, without serialization

  TServiceMethodValueType = (

    smvNone,

    smvSelf,

    smvBoolean,

    smvEnum,

    smvSet,

    smvInteger,

    smvCardinal,

    smvInt64,

    smvDouble,

    smvDateTime,

    smvCurrency,

    smvRawUTF8,

    smvString,

    smvRawByteString,

    smvWideString,

    smvRecord,

    {$ifndef NOVARIANTS}

    smvVariant,

    {$endif}

    smvObject,

    smvRawJSON,

    smvDynArray,

    smvInterface);



  /// handled kind of parameters internal variables for an interface-based method

  // - reference-counted variables will have their own storage

  // - all non referenced-counted variables are stored within some 64-bit content

  // - smvVariant kind of parameter will be handled as a special smvvRecord

  TServiceMethodValueVar = (

    smvvNone, smvvSelf, smvv64, smvvRawUTF8, smvvString, smvvWideString,

    smvvRecord, smvvObject, smvvDynArray, smvvInterface);



  /// set of parameters for an interface-based service provider method

  TServiceMethodValueTypes = set of TServiceMethodValueType;



  /// handled kind of parameters direction for an interface-based service method

  // - IN, IN/OUT, OUT directions can be applied to arguments, and will

  // be available through our JSON-serialized remote access: smdVar and smdOut

  // kind of parameters will be returned within the "result": JSON array

  // - smdResult is used for a function method, to handle the returned value

  TServiceMethodValueDirection = (

    smdConst,

    smdVar,

    smdOut,

    smdResult);



  /// set of parameters direction for an interface-based service method

  TServiceMethodValueDirections = set of TServiceMethodValueDirection;



  /// describe a service provider method argument

  TServiceMethodArgument = {$ifndef ISDELPHI2010}object{$else}record{$endif}

  public

    /// the argument name, as declared in Delphi

    ParamName: PShortString;

    /// the type name, as declared in Delphi

    ArgTypeName: PShortString;

    /// the low-level RTTI information of this argument

    ArgTypeInfo: PTypeInfo;

    /// we do not handle all kind of Delphi variables

    ValueType: TServiceMethodValueType;

    /// the variable direction as defined at code level

    ValueDirection: TServiceMethodValueDirection;

    /// how the variable may be stored

    ValueVar: TServiceMethodValueVar;

    /// how the variable is to be passed at asm level

    // - vIsString is included for smvRawUTF8, smvString, smvRawByteString and

    // smvWideString kind of parameter (smvRecord has it to false, even if they

    // are Base-64 encoded within the JSON content, and also smvVariant/smvRawJSON)

    // - vPassedByReference is included if the parameter is passed as reference

    // (i.e. defined as var/out, or is a record or a reference-counted type result)

    // - vIsObjArray is set if the dynamic array is a T*ObjArray, so should be

    // cleared with ObjArrClear() and not TDynArray.Clear

    ValueKindAsm: set of (vIsString, vPassedByReference, vIsObjArray);

    /// byte offset in the CPU stack of this argument

    // - may be -1 if pure register parameter with no backup on stack (x86)

    InStackOffset: integer;

    /// used to specify if the argument is passed as register

    // - contains 0 if parameter is not a register

    // - contains 1 for EAX, 2 for EDX and 3 for ECX registers for x86

    // - contains 1 for RCX, 2 for RDX, 3 for R8, and

    // 4 for R9, with a backing store on the stack for x64

    // - contains 1 for R0, 2 R1 ... 4 for R3, with a backing store on the stack for arm

    // - contains 1 for X0, 2 X1 ... 8 for X7, with a backing store on the stack for aarch64

    RegisterIdent: integer;

    /// used to specify if a floating-point argument is passed as register

    // - contains always 0 for x86/x87

    // - contains 1 for XMM0, 2 for XMM1 ... 4 for XMM3 for x64

    // - contains 1 for D0, 2 D1 ... 8 for D7 for armhf

    // - contains 1 for V0, 2 V1 ... 8 for V7 for aarch64

    FPRegisterIdent: integer;

    /// size (in bytes) of this argument on the stack

    SizeInStack: integer;

    /// size (in bytes) of this smvv64 ordinal value

    // - e.g. depending of the associated kind of enumeration

    SizeInStorage: integer;

    /// index of the associated variable in the local array[ArgsUsedCount[]]

    // - for smdConst argument, contains -1 (no need to a local var: the value

    // will be on the stack only)

    IndexVar: integer;

    {$ifndef FPC}

    /// set ArgTypeName and ArgTypeInfo values from RTTI

    procedure SetFromRTTI(var P: PByte);

    {$endif}

    /// serialize the argument into the TServiceContainer.Contract JSON format

    // - non standard types (e.g. clas, enumerate, dynamic array or record)

    // are identified by their type identifier - so contract does not extend

    // up to the content of such high-level structures

    procedure SerializeToContract(WR: TTextWriter);

    /// append the JSON value corresponding to this argument

    // - includes a pending ','

    procedure AddJSON(WR: TTextWriter; V: pointer);

    /// append the value corresponding to this argument as within a JSON string

    // - will escape any JSON string character, and include a pending ','

    procedure AddJSONEscaped(WR: TTextWriter; V: pointer);

    /// append the JSON value corresponding to this argument, from its text value

    // - includes a pending ','

    procedure AddValueJSON(WR: TTextWriter; const Value: RawUTF8);

    /// append the default JSON value corresponding to this argument

    // - includes a pending ','

    procedure AddDefaultJSON(WR: TTextWriter);

    /// convert a value into its JSON representation

    procedure AsJson(var DestValue: RawUTF8; V: pointer);

    {$ifndef NOVARIANTS}

    /// convert a value into its variant representation

    // - complex objects would be converted into a TDocVariant, after JSON

    // serialization: variant conversion options may e.g. be retrieve from

    // TInterfaceFactory.DocVariantOptions

    procedure AsVariant(var DestValue: variant; V: pointer;

      Options: TDocVariantOptions);

    /// add a value into a TDocVariant object or array

    // - Dest should already have set its Kind to either dvObject or dvArray

    procedure AddAsVariant(var Dest: TDocVariantData; V: pointer);

    /// normalize a value containing one input or output argument

    // - sets and enumerates would be translated to strings (also in embedded

    // objects and T*ObjArray)

    procedure FixValue(var Value: variant);

    /// normalize a value containing one input or output argument, and add

    // it to a destination variant Document

    // - sets and enumerates would be translated to strings (also in embedded

    // objects and T*ObjArray)

    procedure FixValueAndAddToObject(const Value: variant; var DestDoc: TDocVariantData);

    {$endif}

  end;



  /// describe a service provider method arguments

  TServiceMethodArgumentDynArray = array of TServiceMethodArgument;



  /// callback called by TServiceMethodExecute to process an interface

  // callback parameter

  // - implementation should set the Obj local variable to an instance of

  // a fake class implementing the aParamInfo interface

  TServiceMethodExecuteCallback =

    procedure(var Par: PUTF8Char; ParamInterfaceInfo: PTypeInfo; out Obj) of object;



  /// how TServiceMethod.TServiceMethod method would return the generated document

  // - will return either a dvObject or dvArray TDocVariantData, depending on

  // the expected returned document layout

  // - returned content could be "normalized" (for any set or enumerate) if

  // Kind is pdvObjectFixed

  TServiceMethodParamsDocVariantKind = (pdvArray, pdvObject, pdvObjectFixed);



  /// describe an interface-based service provider method

  TServiceMethod = {$ifndef ISDELPHI2010}object{$else}record{$endif}

  public

    /// the method URI

    // - basicaly the method name as declared in Delphi code (e.g. 'Add' for

    // ICalculator.Add)

    // - this property value is hashed internaly for faster access

    URI: RawUTF8;

    /// the method default result, formatted as a JSON array

    // - example of content may be '[]' for a procedure or '[0]' for a function

    // - any var/out and potential function result will be set as a JSON array

    // of values, with 0 for numerical values, "" for textual values,

    // false for booleans, [] for dynamic arrays, a void record serialized

    // as expected (including customized serialization) and null for objects

    DefaultResult: RawUTF8;

    /// the fully qualified dotted method name, including the interface name

    // - as used by TServiceContainerInterfaceMethod.InterfaceDotMethodName

    // - match the URI fullpath name, e.g. 'Calculator.Add'

    InterfaceDotMethodName: RawUTF8;

    /// method index in the original (non emulated) interface

    // - our custom methods start at index 3 (RESERVED_VTABLE_SLOTS), since

    // QueryInterface, _AddRef, and _Release are always defined by default

    // - so it maps TServiceFactory.Interface.Methods[ExecutionMethodIndex-3]

    ExecutionMethodIndex: byte;

    /// TRUE if the method is inherited from another parent interface

    IsInherited: boolean;

    /// is 0 for the root interface, 1..n for all inherited interfaces

    HierarchyLevel: byte;

    /// describe expected method arguments

    // - Args[0] always is smvSelf

    // - if method is a function, an additional smdResult argument is appended

    Args: TServiceMethodArgumentDynArray;

    /// the index of the result pseudo-argument in Args[]

    // - is -1 if the method is defined as a (not a function)

    ArgsResultIndex: shortint;

    /// the index of the first const / var argument in Args[]

    ArgsInFirst: shortint;

    /// the index of the last const / var argument in Args[]

    ArgsInLast: shortint;

    /// the index of the first var / out / result argument in Args[]

    ArgsOutFirst: shortint;

    /// the index of the last var / out / result argument in Args[]

    ArgsOutLast: shortint;

    /// the index of the last argument in Args[], excepting result

    ArgsNotResultLast: shortint;

    /// the index of the last var / out argument in Args[]

    ArgsOutNotResultLast: shortint;

    /// the number of const / var parameters in Args[]

    // - i.e. the number of elements in the input JSON array

    ArgsInputValuesCount: byte;

    /// the number of var / out parameters +  in Args[]

    // - i.e. the number of elements in the output JSON array or object

    ArgsOutputValuesCount: byte;

    /// true if the result is a TServiceCustomAnswer record

    // - that is, a custom Header+Content BLOB transfert, not a JSON object

    ArgsResultIsServiceCustomAnswer: boolean;

    /// the index of the first argument expecting manual stack initialization

    // - set if there is any smvObject,smvDynArray,smvRecord,smvInterface or

    // smvVariant

    ArgsManagedFirst: shortint;

    /// the index of the last argument expecting manual stack initialization

    // - set if there is any smvObject,smvDynArray,smvRecord, smvInterface or

    // smvVariant

    ArgsManagedLast: shortint;

    /// contains all used kind of arguments

    ArgsUsed: TServiceMethodValueTypes;

    /// contains the count of variables for all used kind of arguments

    ArgsUsedCount: array[TServiceMethodValueVar] of byte;

    /// needed CPU stack size (in bytes) for all arguments

    // - under x64, does not include the backup space for the four registers

    ArgsSizeInStack: cardinal;

    /// retrieve an argument index in Args[] from its name

    // - search is case insensitive

    // - if Input is TRUE, will search within const / var arguments

    // - if Input is FALSE, will search within var / out / result arguments

    // - returns -1 if not found

    function ArgIndex(ArgName: PUTF8Char; ArgNameLen: integer; Input: boolean): integer;

    /// find the next argument index in Args[]

    // - if Input is TRUE, will search within const / var arguments

    // - if Input is FALSE, will search within var / out / result arguments

    // - returns true if arg is the new value, false otherwise

    function ArgNext(var arg: integer; Input: boolean): boolean;

    /// convert parameters encoded as a JSON array into a JSON object

    // - if Input is TRUE, will handle const / var arguments

    // - if Input is FALSE, will handle var / out / result arguments

    function ArgsArrayToObject(P: PUTF8Char; Input: boolean): RawUTF8;

    /// returns a dynamic array list of all parameter names

    // - if Input is TRUE, will handle const / var arguments

    // - if Input is FALSE, will handle var / out / result arguments

    function ArgsNames(Input: Boolean): TRawUTF8DynArray;

    {$ifndef NOVARIANTS}

    /// computes a TDocVariant containing the input or output arguments values

    // - Values[] should contain the input/output raw values as variant

    // - Kind would specify the expected returned document layout

    procedure ArgsValuesAsDocVariant(Kind: TServiceMethodParamsDocVariantKind;

      out Dest: TDocVariantData; const Values: TVariantDynArray; Input: boolean;

      Options: TDocVariantOptions=[dvoReturnNullForUnknownProperty,dvoValueCopiedByReference]);

    /// normalize a TDocVariant containing the input or output arguments values

    // - "normalization" will ensure sets and enums are seralized as text

    // - if Input is TRUE, will handle const / var arguments

    // - if Input is FALSE, will handle var / out / result arguments

    procedure ArgsAsDocVariantFix(var ArgsObject: TDocVariantData; Input: boolean);

    /// convert a TDocVariant array containing the input or output arguments

    // values in order, into an object with named parameters

    // - here sets and enums would keep their current values, mainly numerical

    // - if Input is TRUE, will handle const / var arguments

    // - if Input is FALSE, will handle var / out / result arguments

    procedure ArgsAsDocVariantObject(const ArgsParams: TDocVariantData;

      var ArgsObject: TDocVariantData; Input: boolean);

    /// computes a TDocVariant containing the input or output arguments values

    // - Values[] should point to the input/output raw binary values, as stored

    // in TServiceMethodExecute.Values during execution

    procedure ArgsStackAsDocVariant(const Values: TPPointerDynArray;

      out Dest: TDocVariantData; Input: Boolean);

    {$endif}

  end;



  /// describe all mtehods of an interface-based service provider

  TServiceMethodDynArray = array of TServiceMethod;



  /// a pointer to an interface-based service provider method description

  // - since TInterfaceFactory instances are shared in a global list, we

  // can safely use such pointers in our code to refer to a particular method

  PServiceMethod = ^TServiceMethod;



  /// common ancestor for storing interface-based service execution statistics

  // - each call could be logged and monitored in the database

  // - TServiceMethodExecute could store all its calls in such a table

  // - enabled on server side via either TServiceFactoryServer.SetServiceLog or

  // TServiceContainerServer.SetServiceLog method

  TSQLRecordServiceLog = class(TSQLRecord)

  protected

    fMethod: RawUTF8;

    fInput: variant;

    fOutput: variant;

    fUser: integer;

    fSession: integer;

    fTime: TModTime;

    fMicroSec: integer;

    // define Input/Output as dvoSerializeAsExtendedJson

    class procedure InternalDefineModel(Props: TSQLRecordProperties); override;

  public

    /// overriden method creating an index on the Method/MicroSec columns

    class procedure InitializeTable(Server: TSQLRestServer; const FieldName: RawUTF8;

      Options: TSQLInitializeTableOptions); override;

  published

    /// the 'interface.method' identifier of this call

    // - this column will be indexed, for fast SQL queries, with the MicroSec

    // column (for performance tuning)

    property Method: RawUTF8 read fMethod write fMethod;

    /// the input parameters, as a JSON document

    // - will be stored in JSON_OPTIONS_FAST_EXTENDED format, i.e. with

    // shortened field names, for smaller TEXT storage

    // - content may be searched using JsonGet/JsonHas SQL functions on a

    // SQlite3 storage, or with direct document query under MongoDB/PostgreSQL

    property Input: variant read fInput write fInput;

    /// the output parameters, as a JSON document, including result: for a function

    // - will be stored in JSON_OPTIONS_FAST_EXTENDED format, i.e. with

    // shortened field names, for smaller TEXT storage

    // - content may be searched using JsonGet/JsonHas SQL functions on a

    // SQlite3 storage, or with direct document query under MongoDB/PostgreSQL

    property Output: variant read fOutput write fOutput;

    /// the Session ID, if there is any

    property Session: integer read fSession write fSession;

    /// the User ID, if there is an identified Session

    property User: integer read fUser write fUser;

    /// will be filled by the ORM when this record is written in the database

    property Time: TModTime read fTime write fTime;

    /// execution time of this method, in micro seconds

    property MicroSec: integer read fMicroSec write fMicroSec;

  end;



  /// execution statistics used for DB-based asynchronous notifications

  // - as used by TServiceFactoryClient.SendNotifications

  // - here, the Output column may contain the information about an error

  // occurred during process

  TSQLRecordServiceNotifications = class(TSQLRecordServiceLog)

  protected

    fSent: TTimeLog;

  public

    /// this overriden method will create an index on the 'Sent' column

    class procedure InitializeTable(Server: TSQLRestServer; const FieldName: RawUTF8;

      Options: TSQLInitializeTableOptions); override;

    /// search for pending events since a supplied ID

    // - returns FALSE if no notification was found

    // - returns TRUE ad fill a TDocVariant array of JSON Objects, including

    // "ID": field, and Method as "MethodName": field

    class function LastEventsAsObjects(Rest: TSQLRest; LastKnownID: TID; Limit: integer;

      Service: TInterfaceFactory; out Dest: TDocVariantData;

      const MethodName: RawUTF8 = 'Method'; IDAsHexa: boolean = false): boolean;

    /// allows to convert the Input array into a proper single JSON Object

    // - "ID": field would be included, and Method as "MethodName": field

    function SaveInputAsObject(Service: TInterfaceFactory;

      const MethodName: RawUTF8 = 'Method'; IDAsHexa: boolean = false): variant; virtual;

    /// run FillOne and SaveInputAsObject into a TDocVariant array of JSON Objects

    // - "ID": field would be included, and Method as "MethodName": field

    procedure SaveFillInputsAsObjects(Service: TInterfaceFactory; out Dest: TDocVariantData;

      const MethodName: RawUTF8 = 'Method'; IDAsHexa: boolean = false);

  published

    /// when this notification has been sent

    // - equals 0 until it was actually notified

    property Sent: TTimeLog read fSent write fSent;

  end;



  /// class-reference type (metaclass) for storing interface-based service

  // execution statistics

  // - you could inherit from TSQLRecordServiceLog, and specify additional

  // fields corresponding to the execution context

  TSQLRecordServiceLogClass = class of TSQLRecordServiceLog;



  /// class-reference type (metaclass) for storing interface-based service

  // execution statistics used for DB-based asynchronous notifications

  // - as used by TServiceFactoryClient.SendNotifications

  TSQLRecordServiceNotificationsClass = class of TSQLRecordServiceNotifications;





  TServiceMethodExecute = class;



  /// the current step of a TServiceMethodExecute.OnExecute call

  TServiceMethodExecuteEventStep = (smsUndefined, smsBefore, smsAfter, smsError);



  /// the TServiceMethodExecute.OnExecute signature

  TServiceMethodExecuteEvent = procedure(Sender: TServiceMethodExecute;

    Step: TServiceMethodExecuteEventStep) of object;



  /// execute a method of a TInterfacedObject instance, from/to JSON

  TServiceMethodExecute = class

  protected

    fMethod: PServiceMethod;

    fRawUTF8s: TRawUTF8DynArray;

    fStrings: TStringDynArray;

    fWideStrings: TWideStringDynArray;

    fRecords: array of TBytes;

    fInt64s: TInt64DynArray;

    fObjects: TObjectDynArray;

    fInterfaces: TPointerDynArray;

    fDynArrays: array of record

      Value: Pointer;

      Wrapper: TDynArray;

    end;

    fValues: TPPointerDynArray;

    fAlreadyExecuted: boolean;

    fTempTextWriter: TJSONSerializer;

    fOnExecute: array of TServiceMethodExecuteEvent;

    fBackgroundExecutionThread: TSynBackgroundThreadMethod;

    fOnCallback: TServiceMethodExecuteCallback;

    fOptions: TServiceMethodOptions;

    fServiceCustomAnswerHead: RawUTF8;

    fServiceCustomAnswerStatus: cardinal;

    fLastException: Exception;

    fInput: TDocVariantData;

    fOutput: TDocVariantData;

    fCurrentStep: TServiceMethodExecuteEventStep;

    procedure BeforeExecute;

    procedure RawExecute(const Instances: PPointerArray; InstancesLast: integer);

    procedure AfterExecute;

  public

    /// initialize the execution instance

    constructor Create(aMethod: PServiceMethod);

    /// finalize the execution instance

    destructor Destroy; override;

    /// allow to hook method execution

    // - if optInterceptInputOutput is defined in Options, then Sender.Input/Output

    // fields would contain the execution data context when Hook is called

    procedure AddInterceptor(const Hook: TServiceMethodExecuteEvent);

    /// execute the corresponding method of a given TInterfacedObject instance

    // - will retrieve a JSON array of parameters from Par

    // - will append a JSON array of results in Res, or set an Error message, or

    // a JSON object (with parameter names) in Res if ResultAsJSONObject is set

    function ExecuteJson(const Instances: array of pointer; Par: PUTF8Char;

      Res: TTextWriter; ResAsJSONObject: boolean=false): boolean;

    /// low-level direct access to the associated method information

    property Method: PServiceMethod read fMethod;

    /// low-level direct access to the current input/output parameter values

    // - you should not need to access this, but rather set

    // optInterceptInputOutput in Options, and read Input/Output content

    property Values: TPPointerDynArray read fValues;

    /// associated settings, as copied from TServiceFactoryServer.Options

    property Options: TServiceMethodOptions read fOptions write fOptions;

    /// the current state of the execution

    property CurrentStep: TServiceMethodExecuteEventStep

      read fCurrentStep write fCurrentStep;

    /// set from output TServiceCustomAnswer.Header result parameter

    property ServiceCustomAnswerHead: RawUTF8

      read fServiceCustomAnswerHead write fServiceCustomAnswerHead;

    /// set from output TServiceCustomAnswer.Status result parameter

    property ServiceCustomAnswerStatus: cardinal

      read fServiceCustomAnswerStatus write fServiceCustomAnswerStatus;

    /// set if optInterceptInputOutput is defined in TServiceFactoryServer.Options

    // - contains a dvObject with input parameters as "argname":value pairs

    // - this is a read-only property: you cannot change the input content

    property Input: TDocVariantData read fInput;

    /// set if optInterceptInputOutput is defined in TServiceFactoryServer.Options

    // - this is a read-only property: you cannot change the output content

    // - contains a dvObject with output parameters as "argname":value pairs

    property Output: TDocVariantData read fOutput;

    /// set if intercepted event Step is smsError

    property LastException: Exception read fLastException;

    /// reference to the background execution thread, if any

    property BackgroundExecutionThread: TSynBackgroundThreadMethod

      read fBackgroundExecutionThread;

    /// points e.g. to TSQLRestServerURIContext.ExecuteCallback

    property OnCallback: TServiceMethodExecuteCallback read fOnCallback;

    /// allow to use an instance-specific temporary TTextWriter

    function TempTextWriter: TJSONSerializer;

  end;



  /// a record type to be used as result for a function method for custom content

  // for interface-based services

  // - all answers are pure JSON object by default: using this kind of record

  // as result will allow a response of any type (e.g. binary, HTML or text)

  // - this kind of answer will be understood by our TServiceContainerClient

  // implementation, and it may be used with plain AJAX or HTML requests

  // (via POST), to retrieve some custom content

  TServiceCustomAnswer = record

    /// mandatory response type, as encoded in the HTTP header

    // - useful to set the response mime-type - see e.g. the

    // TEXT_CONTENT_TYPE_HEADER or HTML_CONTENT_TYPE_HEADER constants or

    // GetMimeContentType() function

    // - in order to be handled as expected, this field SHALL be set to NOT ''

    // (otherwise TServiceCustomAnswer will be transmitted as raw JSON)

    Header: RawUTF8;

    /// the response body

    // - corresponding to the response type, as defined in Header

    Content: RawByteString;

    /// the HTML response code

    // - if not overriden, will default to HTML_SUCCESS = 200 on server side

    // - on client side, would always contain HTML_SUCCESS = 200 on success,

    // or any error should be handled as expected by the caller (e.g. using

    // TServiceFactoryClient.GetErrorMessage for decoding REST/SOA errors)

    Status: cardinal;

  end;



  PServiceCustomAnswer = ^TServiceCustomAnswer;



  {$M+}

  /// abstract factory class allowing to call interface resolution in cascade

  // - you can inherit from this class to chain the TryResolve() calls so

  // that several kind of implementations may be asked by a TInjectableObject,

  // e.g. TInterfaceStub, TServiceContainer or TDDDRepositoryRestObjectMapping

  // - this will implement factory pattern, as a safe and thread-safe DI/IoC

  TInterfaceResolver = class

  protected

    /// override this method to resolve an interface from this instance 

    function TryResolve(aInterface: PTypeInfo; out Obj): boolean; virtual; abstract;

    /// override this method check if this instance implements aInterface

    function Implements(aInterface: PTypeInfo): boolean; virtual; abstract;

  end;

  {$M-}



  /// abstract factory class targetting a single kind of interface

  TInterfaceResolverForSingleInterface = class(TInterfaceResolver)

  protected

    fInterfaceTypeInfo: PTypeInfo;

    fInterfaceAncestors: PTypeInfoDynArray;

    fInterfaceAncestorsImplementationEntry: TPointerDynArray;

    fImplementationEntry: PInterfaceEntry;

    fImplementation: TClassInstance;

    function TryResolve(aInterface: PTypeInfo; out Obj): boolean; override;

    function Implements(aInterface: PTypeInfo): boolean; override;

    function GetImplementationName: string;

    // main IoC/DI virtual method - call fImplementation.CreateNew by default

    function CreateInstance: TInterfacedObject; virtual;

  public

    /// this overriden constructor will check and store the supplied class

    // to implement an interface

    constructor Create(aInterface: PTypeInfo; aImplementation: TInterfacedObjectClass); overload;

    /// this overriden constructor will check and store the supplied class

    // to implement an interface by TGUID

    constructor Create(const aInterface: TGUID; aImplementation: TInterfacedObjectClass); overload;

    /// you can use this method to resolve the interface as a new instance

    function GetOneInstance(out Obj): boolean;

  published

    /// the class name which will implement each repository instance

    property ImplementationClass: string read GetImplementationName;

  end;



  TInterfaceStub = class;



  /// used to store a list of TInterfacedObject instances

  TInterfacedObjectObjArray = array of TInterfacedObject;



  /// used to store a list of TInterfaceResolver instances

  TInterfaceResolverObjArray = array of TInterfaceResolver;



  /// used to store a list of TInterfaceStub instances

  TInterfaceStubObjArray = array of TInterfaceStub;



  /// abstract factory class targetting any kind of interface

  // - you can inherit from this class to customize dependency injection (DI/IoC),

  // defining the resolution via InjectStub/InjectResolver/InjectInstance methods,

  // and doing the instance resolution using the overloaded Resolve*() methods

  // - TServiceContainer will inherit from this class, as the main entry point

  // for interface-based services of the framework (via TSQLRest.Services)

  // - you can use RegisterGlobal() class method to define some process-wide DI

  TInterfaceResolverInjected = class(TInterfaceResolver)

  protected

    fResolvers: TInterfaceResolverObjArray;

    fResolversToBeReleased: TInterfaceResolverObjArray;

    fDependencies: TInterfacedObjectObjArray;

    function TryResolve(aInterface: PTypeInfo; out Obj): boolean; override;

    function TryResolveInternal(aInterface: PTypeInfo; out Obj): boolean;

    function Implements(aInterface: PTypeInfo): boolean; override;

    class function RegisterGlobalCheck(aInterface: PTypeInfo;

      aImplementationClass: TClass): PInterfaceEntry;

  public

    /// define a global class type for interface resolution

    // - most of the time, you would need a local DI/IoC resolution list; but

    // you may use this method to register a set of shared and global resolution

    // patterns, common to the whole injection process

    // - by default, TAutoLocker and TLockedDocVariant will be registered by

    // this unit to implement IAutoLocker and ILockedDocVariant interfaces

    class procedure RegisterGlobal(aInterface: PTypeInfo;

      aImplementationClass: TInterfacedObjectWithCustomCreateClass); overload;

    /// define a global instance for interface resolution

    // - most of the time, you would need a local DI/IoC resolution list; but

    // you may use this method to register a set of shared and global resolution

    // patterns, common to the whole injection process

    // - the supplied instance will be owned by the global list (incrementing

    // its internal reference count), until it would be released via

    // ! RegisterGlobalDelete()

    // - the supplied instance will be freed in the finalization of this unit,

    // if not previously released via RegisterGlobalDelete()

    class procedure RegisterGlobal(aInterface: PTypeInfo;

      aImplementation: TInterfacedObject); overload;

    /// undefine a global instance for interface resolution

    // - you can unregister a given instance previously defined via

    // ! RegisterGlobal(aInterface,aImplementation)

    // - if you do not call RegisterGlobalDelete(), the remaning instances will

    // be freed in the finalization of this unit

    class procedure RegisterGlobalDelete(aInterface: PTypeInfo);

    /// prepare and setup interface DI/IoC resolution with some blank

    // TInterfaceStub specified by their TGUID

    procedure InjectStub(const aStubsByGUID: array of TGUID); overload; virtual;

    /// prepare and setup interface DI/IoC resolution with TInterfaceResolver

    // kind of factory

    // - e.g. a customized TInterfaceStub/TInterfaceMock, a TServiceContainer,

    // a TDDDRepositoryRestObjectMapping or any factory class

    // - by default, only TInterfaceStub/TInterfaceMock would be owned by this

    // instance, and released by Destroy - unless you set OwnOtherResolvers

    procedure InjectResolver(const aOtherResolvers: array of TInterfaceResolver;

      OwnOtherResolvers: boolean=false); overload; virtual;

    /// prepare and setup interface DI/IoC resolution from a TInterfacedObject instance

    // - any TInterfacedObject declared as dependency will have its reference

    // count increased, and decreased in Destroy

    procedure InjectInstance(const aDependencies: array of TInterfacedObject); overload; virtual;

    /// can be used to perform an DI/IoC for a given interface

    // - will search for the supplied interface to its internal list of resolvers

    // - returns TRUE and set the Obj variable with a matching instance

    // - can be used as such to resolve an ICalculator interface:

    // ! var calc: ICalculator;

    // ! begin

    // !   if Catalog.Resolve(TypeInfo(ICalculator),calc) then

    // !   ... use calc methods

    function Resolve(aInterface: PTypeInfo; out Obj): boolean; overload;

    /// can be used to perform an DI/IoC for a given interface

    // - you shall have registered the interface TGUID by a previous call to

    // ! TInterfaceFactory.RegisterInterfaces([TypeInfo(ICalculator),...])

    // - returns TRUE and set the Obj variable with a matching instance

    // - can be used as such to resolve an ICalculator interface:

    // ! var calc: ICalculator;

    // ! begin

    // !   if ServiceContainer.Resolve(ICalculator,cal) then

    // !   ... use calc methods

    function Resolve(const aGUID: TGUID; out Obj): boolean; overload;

    /// can be used to perform several DI/IoC for a given set of interfaces

    // - here interfaces and instances are provided as TypeInfo,@Instance pairs

    // - raise an EServiceException if any interface can't be resolved, unless

    // aRaiseExceptionIfNotFound is set to FALSE

    procedure ResolveByPair(const aInterfaceObjPairs: array of pointer;

      aRaiseExceptionIfNotFound: boolean=true);

    /// can be used to perform several DI/IoC for a given set of interfaces

    // - here interfaces and instances are provided as TGUID and @Instance

    // - you shall have registered the interface TGUID by a previous call to

    // ! TInterfaceFactory.RegisterInterfaces([TypeInfo(ICalculator),...])

    // - raise an EServiceException if any interface can't be resolved, unless

    // aRaiseExceptionIfNotFound is set to FALSE

    procedure Resolve(const aInterfaces: array of TGUID; const aObjs: array of pointer;

      aRaiseExceptionIfNotFound: boolean=true); overload;

    /// release all used instances

    // - including all TInterfaceStub instances as specified to Inject(aStubsByGUID)

    // - will call _Release on all TInterfacedObject dependencies

    destructor Destroy; override;

  end;



  /// any service implementation class could inherit from this class to

  // allow dependency injection aka SOLID DI/IoC by the framework

  // - once created, the framework will call AddResolver() member, so that its

  // Resolve*() methods could be used to inject any needed dependency for lazy

  // dependency resolution (e.g. within a public property getter)

  // - any interface published property would also be automatically injected

  // - if you implement a SOA service with this class, TSQLRestServer.Services

  // will be auto-injected via TServiceFactoryServer.CreateInstance()

  TInjectableObject = class(TInterfacedObjectWithCustomCreate)

  protected

    fResolver: TInterfaceResolver;

    fResolverOwned: Boolean;

    // DI/IoC resolution protected methods

    function TryResolve(aInterface: PTypeInfo; out Obj): boolean;

    /// this method will resolve all interface published properties

    procedure AutoResolve(aRaiseEServiceExceptionIfNotFound: boolean);

  public

    /// initialize an instance, defining one or several mean of dependency resolution

    // - simple TInterfaceStub could be created directly from their TGUID,

    // then any kind of DI/IoC resolver instances could be specified, i.e.

    // either customized TInterfaceStub/TInterfaceMock, a TServiceContainer or

    // a TDDDRepositoryRestObjectMapping, and then any TInterfacedObject

    // instance would be used during dependency resolution:

    // ! procedure TMyTestCase.OneTestCaseMethod;

    // ! var Test: IServiceToBeTested;

    // ! begin

    // !   Test := TServiceToBeTested.CreateInjected(

    // !     [ICalculator],

    // !     [TInterfaceMock.Create(IPersistence,self).

    // !       ExpectsCount('SaveItem',qoEqualTo,1),

    // !      RestInstance.Services],

    // !     [AnyInterfacedObject]);

    // !   ...

    // - note that all the injected stubs/mocks instances will be owned by the

    // TInjectableObject, and therefore released with it

    // - any TInterfacedObject declared as dependency will have its reference

    // count increased, and decreased in Destroy

    // - once DI/IoC is defined, will call the AutoResolve() protected method

    constructor CreateInjected(const aStubsByGUID: array of TGUID;

      const aOtherResolvers: array of TInterfaceResolver;

      const aDependencies: array of TInterfacedObject;

      aRaiseEServiceExceptionIfNotFound: boolean=true); virtual;

    /// initialize an instance, defining one dependency resolver

    // - the resolver may be e.g. a TServiceContainer

    // - once the DI/IoC is defined, will call the AutoResolve() protected method

    constructor CreateWithResolver(aResolver: TInterfaceResolver;

      aRaiseEServiceExceptionIfNotFound: boolean=true); virtual;

    /// can be used to perform an DI/IoC for a given interface type information

    procedure Resolve(aInterface: PTypeInfo; out Obj); overload;

    /// can be used to perform an DI/IoC for a given interface TGUID

    procedure Resolve(const aGUID: TGUID; out Obj); overload;

    /// can be used to perform several DI/IoC for a given set of interfaces

    // - here interfaces and instances are provided as TypeInfo,@Instance pairs

    procedure ResolveByPair(const aInterfaceObjPairs: array of pointer);

    /// can be used to perform several DI/IoC for a given set of interfaces

    // - here interfaces and instances are provided as TGUID and pointers

    procedure Resolve(const aInterfaces: array of TGUID; const aObjs: array of pointer); overload;

    /// release all used instances

    // - including all TInterfaceStub instances as specified to CreateInjected()

    destructor Destroy; override;

    /// access to the associated dependency resolver, if any

    property Resolver: TInterfaceResolver read fResolver;

  end;



  /// class-reference type (metaclass) of a TInjectableObject type

  TInjectableObjectClass = class of TInjectableObject;



  /// service implementation class, with direct access on the associated

  // TServiceFactoryServer/TSQLRestServer instances

  // - allow dependency injection aka SOLID DI/IoC by the framework using

  // inherited TInjectableObject.Resolve() methods

  // - allows direct access to the underlying ORM using its Server method

  // - this class would allow Server instance access outside the scope of

  // remote SOA execution, e.g. when a DI is performed on server side: it

  // is therefore a better alternative to ServiceContext.Factory,

  // ServiceContext.Factory.RestServer or ServiceContext.Request.Server

  TInjectableObjectRest = class(TInjectableObject)

  protected

    fFactory: TServiceFactoryServer;

    fServer: TSQLRestServer;

  public

    /// access to the associated interface factory

    // - this property will be injected by TServiceFactoryServer.CreateInstance,

    // so may be nil if the instance was created outside the SOA context

    property Factory: TServiceFactoryServer read fFactory;

    /// access ot the associated REST Server, e.g. to its ORM methods 

    // - slightly faster than Factory.RestServer

    // - this value will be injected by TServiceFactoryServer.CreateInstance,

    // so may be nil if the instance was created outside the SOA context

    property Server: TSQLRestServer read fServer;

  end;



  /// used to set the published properties of a TInjectableAutoCreateFields

  // - TInjectableAutoCreateFields.Create will check any resolver able to

  // implement this interface, then run its SetProperties() method on it

  IAutoCreateFieldsResolve = interface

    ['{396362E9-B60D-43D4-A0D4-802E4479F24E}']

    /// this method will be called once on any TInjectableAutoCreateFields just

    // created instance

    procedure SetProperties(Instance: TObject);

  end;



  /// abstract class which will auto-inject its dependencies (DI/IoC), and also

  // manage the instances of its TPersistent/TSynPersistent published properties

  // - abstract class able with a virtual constructor, dependency injection

  // (i.e. SOLID DI/IoC), and automatic memory management of all nested class

  // published properties

  // - will also release any T*ObjArray dynamic array storage of persistents,

  // previously registered via TJSONSerializer.RegisterObjArrayForJSON()

  // - this class is a perfect parent for any class storing data by value, and

  // dependency injection, e.g. DDD services or daemons

  // - note that non published (e.g. public) properties won't be instantiated

  // - please take care that you would not create any endless recursion: you

  // should ensure that at one level, nested published properties won't have any

  // class instance matching its parent type

  // - since the destructor will release all nested properties, you should

  // never store a reference of any of those nested instances outside

  // - if any associated resolver implements IAutoCreateFieldsResolve, its

  // SetProperties() method will be called on all created T*Persistent

  // published properties, so that it may initialize its values

  TInjectableAutoCreateFields = class(TInjectableObject)

  public

    /// this overriden constructor will instantiate all its nested

    // TPersistent/TSynPersistent/TSynAutoCreateFields class published properties

    // - then resolve and call IAutoCreateFieldsResolve.SetProperties(self)

    constructor Create; override;

    /// finalize the instance, and release its published properties

    destructor Destroy; override;

  end;



  /// event used by TInterfaceFactory to run a method from a fake instance

  // - aMethod will specify which method is to be executed

  // - aParams will contain the input parameters, encoded as a JSON array

  // - shall return TRUE on success, or FALSE in case of failure, with

  // a corresponding explanation in aErrorMsg

  // - method results shall be serialized as JSON in aResult;  if

  // aServiceCustomAnswer is not nil, the result shall use this record

  // to set HTTP custom content and headers, and ignore aResult content

  // - aClientDrivenID can be set optionally to specify e.g. an URI-level session

  TOnFakeInstanceInvoke = function (const aMethod: TServiceMethod;

    const aParams: RawUTF8; aResult, aErrorMsg: PRawUTF8;

    aClientDrivenID: PCardinal; aServiceCustomAnswer: PServiceCustomAnswer): boolean of object;



  /// event called when destroying a TInterfaceFactory's fake instance

  /// - this method will be run when the fake class instance is destroyed

  // (e.g. if aInstanceCreation is sicClientDriven, to notify the server

  // than the client life time just finished)

  TOnFakeInstanceDestroy = procedure(aClientDrivenID: cardinal) of object;



  /// may be used to store the Methods[] indexes of a TInterfaceFactory

  TInterfaceFactoryMethodBits = set of 0..255;



  /// a dynamic array of TInterfaceFactory instances

  TInterfaceFactoryObjArray = array of TInterfaceFactory;



  /// class handling interface RTTI and fake implementation class

  // - a thread-safe global list of such class instances is implemented to cache

  // information for better speed: use class function TInterfaceFactory.Get()

  // and not manual TInterfaceFactory.Create / Free

  // - if you want to search the interfaces by name or TGUID, call once

  // Get(TypeInfo(IMyInterface)) or RegisterInterfaces() for proper registration

  // - will use TInterfaceFactoryRTTI classes generated from Delphi RTTI

  TInterfaceFactory = class

  protected

    fInterfaceTypeInfo: PTypeInfo;

    fInterfaceIID: TGUID;

    fMethodsCount: cardinal;

    fAddMethodsLevel: integer;

    fMethods: TServiceMethodDynArray;

    fMethod: TDynArrayHashed;

    // contains e.g. [{"method":"Add","arguments":[...]},{"method":"...}]

    fContract: RawUTF8;

    fInterfaceName: RawUTF8;

    {$ifndef NOVARIANTS}

    fDocVariantOptions: TDocVariantOptions;

    {$endif}

    fFakeVTable: array of pointer;

    fFakeStub: PByteArray;

    fMethodIndexCallbackReleased: Integer;

    fMethodIndexCurrentFrameCallback: Integer;

    {$ifdef CPUAARCH64} 

    fDetectX0ResultMagic: cardinal; // alf: temporary hack for AARCH64

    {$endif}

    procedure AddMethodsFromTypeInfo(aInterface: PTypeInfo); virtual; abstract;

    function GetMethodsVirtualTable: pointer;

  public

    /// this is the main entry point to the global interface factory cache

    // - access to this method is thread-safe

    // - this method will also register the class to further retrieval

    class function Get(aInterface: PTypeInfo): TInterfaceFactory; overload;

    /// retrieve an interface factory from cache, from its TGUID

    // - access to this method is thread-safe

    // - you shall have registered the interface by a previous call to the

    // overloaded Get(TypeInfo(IMyInterface)) method or RegisterInterfaces()

    // - if the supplied TGUID has not been previously registered, returns nil

    class function Get(const aGUID: TGUID): TInterfaceFactory; overload;

    /// retrieve an interface factory from cache, from its name (e.g. 'IMyInterface')

    // - access to this method is thread-safe

    // - you shall have registered the interface by a previous call to the

    // overloaded Get(TypeInfo(IMyInterface)) method or RegisterInterfaces()

    // - if the supplied TGUID has not been previously registered, returns nil

    class function Get(const aInterfaceName: RawUTF8): TInterfaceFactory; overload;

    /// register one or several interfaces to the global interface factory cache

    // - so that you can use TInterfaceFactory.Get(aGUID) or Get(aName)

    class procedure RegisterInterfaces(const aInterfaces: array of PTypeInfo);

    /// could be used to retrieve an array of TypeInfo() from their GUID

    class function GUID2TypeInfo(const aGUIDs: array of TGUID): PTypeInfoDynArray; overload;

    /// could be used to retrieve an array of TypeInfo() from their GUID

    class function GUID2TypeInfo(const aGUID: TGUID): PTypeInfo; overload;

    /// returns the list of all declared TInterfaceFactory

    // - as used by SOA and mocking/stubing features of this unit

    class function GetUsedInterfaces: TObjectList;

    /// add some TInterfaceFactory instances from their GUID

    class procedure AddToObjArray(var Obj: TInterfaceFactoryObjArray;

       const aGUIDs: array of TGUID);



    /// initialize the internal properties from the supplied interface RTTI

    // - it will check and retrieve all methods of the supplied interface,

    // and prepare all internal structures for later use

    // - do not call this constructor directly, but TInterfaceFactory.Get()

    constructor Create(aInterface: PTypeInfo);

    /// find the index of a particular method in internal Methods[] list

    // - will search for a match against Methods[].URI property

    // - won't find the default AddRef/Release/QueryInterface methods

    // - will return -1 if the method is not known

    // - if aMethodName does not have an exact method match, it would try with a

    // trailing underscore, so that e.g. /service/start would match IService._Start()

    function FindMethodIndex(const aMethodName: RawUTF8): integer;

    /// find the index of a particular interface.method in internal Methods[] list

    // - will search for a match against Methods[].InterfaceDotMethodName property

    // - won't find the default AddRef/Release/QueryInterface methods

    // - will return -1 if the method is not known

    function FindFullMethodIndex(const aFullMethodName: RawUTF8;

      alsoSearchExactMethodName: boolean=false): integer;

    /// find the index of a particular method in internal Methods[] list

    // - won't find the default AddRef/Release/QueryInterface methods

    // - will raise an EInterfaceFactoryException if the method is not known

    function CheckMethodIndex(const aMethodName: RawUTF8): integer; overload;

    /// find the index of a particular method in internal Methods[] list

    // - won't find the default AddRef/Release/QueryInterface methods

    // - will raise an EInterfaceFactoryException if the method is not known

    function CheckMethodIndex(aMethodName: PUTF8Char): integer; overload;

    /// returns the method name from its method index

    // - the method index should start at 0 for _free_/_contract_/_signature_

    // pseudo-methods, and start at index 3 for real Methods[]

    function GetMethodName(MethodIndex: integer): RawUTF8;

    /// set the Methods[] indexes bit from some methods names

    // - won't find the default AddRef/Release/QueryInterface methods

    // - will raise an EInterfaceFactoryException if the method is not known

    procedure CheckMethodIndexes(const aMethodName: array of RawUTF8; aSetAllIfNone: boolean;

      out aBits: TInterfaceFactoryMethodBits);

    /// returns the full 'Interface.MethodName' text, from a method index

    // - the method index should start at 0 for _free_/_contract_/_signature_

    // pseudo-methods, and start at index 3 for real Methods[]

    // - will return plain 'Interface' text, if aMethodIndex is incorrect

    function GetFullMethodName(aMethodIndex: integer): RawUTF8;

    /// the declared internal methods

    // - list does not contain default AddRef/Release/QueryInterface methods

    // - nor the _free_/_contract_/_signature_ pseudo-methods

    property Methods: TServiceMethodDynArray read fMethods;

    /// the number of internal methods

    // - does not include the default AddRef/Release/QueryInterface methods

    // - nor the _free_/_contract_/_signature_ pseudo-methods

    property MethodsCount: cardinal read fMethodsCount;

    /// identifies a CallbackReleased() method in this interface

    // - i.e. the index in Methods[] of the following signature:

    // ! procedure CallbackReleased(const callback: IInvokable; const interfaceName: RawUTF8);

    // - this method will be called e.g. by TInterfacedCallback.Destroy, when

    // a callback is released on the client side so that you may be able e.g. to

    // unsubscribe the callback from an interface list (via InterfaceArrayDelete)

    // - contains -1 if no such method do exist in the interface definition

    property MethodIndexCallbackReleased: Integer read fMethodIndexCallbackReleased;

    /// identifies a CurrentFrame() method in this interface

    // - i.e. the index in Methods[] of the following signature:

    // ! procedure CurrentFrame(isLast: boolean);

    // - this method will be called e.g. by TSQLHttpClientWebsockets.CallbackRequest

    // for interface callbacks in case of WebSockets jumbo frames, to allow e.g.

    // faster database access via a batch

    // - contains -1 if no such method do exist in the interface definition

    property MethodIndexCurrentFrameCallback: Integer read fMethodIndexCurrentFrameCallback;

    /// the registered Interface low-level Delphi RTTI type

    property InterfaceTypeInfo: PTypeInfo read fInterfaceTypeInfo;

    /// the registered Interface GUID

    property InterfaceIID: TGUID read fInterfaceIID;

    {$ifndef NOVARIANTS}

    /// how this interface will work with variants (including TDocVariant)

    // - by default, contains JSON_OPTIONS_FAST for best performance - i.e.

    // [dvoReturnNullForUnknownProperty,dvoValueCopiedByReference]

    property DocVariantOptions: TDocVariantOptions

      read fDocVariantOptions write fDocVariantOptions;

    {$endif}

  published

    /// will return the interface name, e.g. 'ICalculator'

    // - published property to be serializable as JSON e.g. for debbuging info

    property InterfaceName: RawUTF8 read fInterfaceName;

  end;



  {$ifdef HASINTERFACERTTI}



  /// class handling interface RTTI and fake implementation class

  // - this class only exists for Delphi 6 and up, since FPC does not generate

  // the expected RTTI - see http://bugs.freepascal.org/view.php?id=26774

  TInterfaceFactoryRTTI = class(TInterfaceFactory)

  protected

    procedure AddMethodsFromTypeInfo(aInterface: PTypeInfo); override;

  end;



  {$endif HASINTERFACERTTI}

  

  {$M+}

  /// how TInterfacedObjectFromFactory would perform its execution

  // - by default, fInvoke() would receive standard JSON content, unless

  // ifoJsonAsExtended is set, and extended JSON is used

  TInterfacedObjectFromFactoryOption = (ifoJsonAsExtended);

  /// defines how TInterfacedObjectFromFactory would perform its execution

  TInterfacedObjectFromFactoryOptions = set of TInterfacedObjectFromFactoryOption;



  /// abstract class handling a generic interface implementation class

  TInterfacedObjectFromFactory = class(TInterfacedObject)

  protected

    fFactory: TInterfaceFactory;

    fOptions: TInterfacedObjectFromFactoryOptions;

    fInvoke: TOnFakeInstanceInvoke;

    fNotifyDestroy: TOnFakeInstanceDestroy;

    fClientDrivenID: Cardinal;

  public

    /// create an instance, using the specified interface

    constructor Create(aFactory: TInterfaceFactory;

      aOptions: TInterfacedObjectFromFactoryOptions;

      aInvoke: TOnFakeInstanceInvoke; aNotifyDestroy: TOnFakeInstanceDestroy);

    /// release the remote server instance (in sicClientDriven mode);

    destructor Destroy; override;

  published

    /// the associated interface factory class

    property Factory: TInterfaceFactory read fFactory;

    /// the ID used in sicClientDriven mode

    property ClientDrivenID: Cardinal read fClientDrivenID;

  end;

  {$M-}



  /// class handling interface implementation generated from source

  // - this class targets FPC, which does not generate the expected RTTI - see

  // http://bugs.freepascal.org/view.php?id=26774

  // - mORMotWrapper.pas will generate a new inherited class, overriding abstract

  // AddMethodsFromTypeInfo() to define the interface methods

  TInterfaceFactoryGenerated = class(TInterfaceFactory)

  protected

    fTempStrings: TRawUTF8DynArray;

    /// the overriden AddMethodsFromTypeInfo() method will call e.g. as

    // ! AddMethod('Add',[

    // !   0,'n1',TypeInfo(Integer),

    // !   0,'n2',TypeInfo(Integer),

    // !   3,'Result',TypeInfo(Integer)]);

    // with 0=ord(smdConst) and 3=ord(smdResult)

    procedure AddMethod(const aName: RawUTF8; const aParams: array of const); virtual;

  public

    /// register one interface type definition from the current class

    // - will be called by mORMotWrapper.pas generated code, in initialization

    // section, so that the needed type information would be available

    class procedure RegisterInterface(aInterface: PTypeInfo); virtual;

  end;



  /// abstract parameters used by TInterfaceStub.Executes() events callbacks

  TOnInterfaceStubExecuteParamsAbstract = class

  private

    function GetSenderAsMockTestCase: TSynTestCase;

  protected

    fSender: TInterfaceStub;

    fMethod: PServiceMethod;

    fParams: RawUTF8;

    fEventParams: RawUTF8;

    fResult: RawUTF8;

    fFailed: boolean;

  public

    /// constructor of one parameters marshalling instance

    constructor Create(aSender: TInterfaceStub; aMethod: PServiceMethod;

      const aParams,aEventParams: RawUTF8); virtual;

    /// call this method if the callback implementation failed

    procedure Error(const aErrorMessage: RawUTF8); overload;

    /// call this method if the callback implementation failed

    procedure Error(const Format: RawUTF8; const Args: array of const); overload;

    /// the stubbing / mocking generator

    property Sender: TInterfaceStub read fSender;

    /// the mocking generator associated test case

    // - will raise an exception if the associated Sender generator is not

    // a TInterfaceMock

    property TestCase: TSynTestCase read GetSenderAsMockTestCase;

    /// pointer to the method which is to be executed

    property Method: PServiceMethod read fMethod;

    /// a custom message, defined at TInterfaceStub.Executes() definition

    property EventParams: RawUTF8 read fEventParams;

    /// outgoing values array encoded as JSON

    // - every var, out parameter or the function result shall be encoded as

    // a JSON array into this variable, in the same order than the stubbed

    // method declaration

    // - use Returns() method to create the JSON array directly, from an array

    // of values

    property Result: RawUTF8 read fResult;

    /// low-level flag, set to TRUE if one of the Error() method was called

    property Failed: boolean read fFailed;

  end;



{$ifndef NOVARIANTS}

  /// parameters used by TInterfaceStub.Executes() events callbacks as Variant

  // - this class will expect input and output parameters to specified as

  // variant arrays properties, so is easier (and a bit slower) than the

  // TOnInterfaceStubExecuteParamsJSON class

  TOnInterfaceStubExecuteParamsVariant = class(TOnInterfaceStubExecuteParamsAbstract)

  private

    function GetInput(Index: Integer): variant;

    procedure SetOutput(Index: Integer; const Value: variant);

    function GetInNamed(const aParamName: RawUTF8): variant;

    procedure SetOutNamed(const aParamName: RawUTF8; const Value: variant);

  protected

    fInput: TVariantDynArray;

    fOutput: TVariantDynArray;

    procedure SetResultFromOutput;

  public

    /// constructor of one parameters marshalling instance

    constructor Create(aSender: TInterfaceStub; aMethod: PServiceMethod;

      const aParams,aEventParams: RawUTF8); override;

    /// returns the input parameters as a TDocVariant object or array

    function InputAsDocVariant(Kind: TServiceMethodParamsDocVariantKind;

      Options: TDocVariantOptions=[dvoReturnNullForUnknownProperty,dvoValueCopiedByReference]): variant;

    /// returns the output parameters as a TDocVariant object or array

    function OutputAsDocVariant(Kind: TServiceMethodParamsDocVariantKind;

      Options: TDocVariantOptions=[dvoReturnNullForUnknownProperty,dvoValueCopiedByReference]): variant;

    /// input parameters when calling the method

    // - order shall follow the method const and var parameters

    // ! Stub.Add(10,20) -> Input[0]=10, Input[1]=20

    // - if the supplied Index is out of range, an EInterfaceStub will be raised

    property Input[Index: Integer]: variant read GetInput;

    /// output parameters returned after method process

    // - order shall follow the method var, out parameters and the function

    // result (if method is not a procedure)

    // - if the supplied Index is out of range, an EInterfaceStub will be raised

    // - can be used as such:

    // !  procedure TFooTestCase.ExecuteBar(Ctxt: TOnInterfaceStubExecuteParamsVariant);

    // !  begin // Input[0]=i

    // !    Ctxt.Output[0] := Ctxt.Input[0]+1;  // i := i+1;

    // !    Ctxt.Output[1] := 42;               // result := 42;

    // !  end; // Output|0]=i, Output[1]=result

    // to emulate this native implementation:

    // ! function Bar(var i: Integer): Integer;

    // ! begin

    // !    inc(i);

    // !    result := 42;

    // !  end;

    // - consider using the safest Named[] property, to avoid parameters

    // index matching issue

    // - if an Output[]/Named[] item is not set, a default value would be used

    property Output[Index: Integer]: variant write SetOutput;

    /// access to input/output parameters when calling the method

    // - if the supplied name is incorrect, an EInterfaceStub will be raised

    // - is a bit slower than Input[]/Output[] indexed properties, but easier

    // to work with, and safer in case of method signature change (like parameter

    // add or rename)

    // - marked as default property, so you can use it e.g. as such:

    // !  procedure TFooTestCase.ExecuteBar(Ctxt: TOnInterfaceStubExecuteParamsVariant);

    // !  begin

    // !    Ctxt['i'] := Ctxt['i']+1;  // i := i+1;

    // !    Ctxt['result'] := 42;      // result := 42;

    // !  end;

    // to emulate this native implementation:

    // ! function Bar(var i: Integer): Integer;

    // ! begin

    // !    inc(i);

    // !    result := 42;

    // !  end;

    // - using this default Named[] property is recommended over the index-based

    // Output[] property

    // - if an Output[]/Named[] item is not set, a default value would be used

    property Named[const ParamName: RawUTF8]: variant read GetInNamed write SetOutNamed; default;

  end;

{$endif NOVARIANTS}



  /// parameters used by TInterfaceStub.Executes() events callbacks as JSON

  // - this class will expect input and output parameters to be encoded as

  // JSON arrays, so is faster than TOnInterfaceStubExecuteParamsVariant

  TOnInterfaceStubExecuteParamsJSON = class(TOnInterfaceStubExecuteParamsAbstract)

  public

    /// a method to return an array of values into Result

    // - just a wrapper around JSONEncodeArrayOfConst([...])

    // - can be used as such:

    // !  procedure TFooTestCase.ExecuteBar(var Ctxt: TOnInterfaceStubExecuteParamsJSON);

    // !  begin // Ctxt.Params := '[i]' -> Ctxt.Result := '[i+1,42]'

    // !    Ctxt.Returns([GetInteger(pointer(Ctxt.Params))+1,42]);

    // !  end;

    // to emulate this native implementation:

    // ! function Bar(var i: Integer): Integer;

    // ! begin

    // !    inc(i);

    // !    result := 42;

    // !  end;

    procedure Returns(const Values: array of const); overload;

    /// a method to return a JSON array of values into Result

    // - expected format is e.g. '[43,42]'

    procedure Returns(const ValuesJsonArray: RawUTF8); overload;

    /// incoming parameters array encoded as JSON array without braces

    // - order follows the method const and var parameters

    // ! Stub.Add(10,20) -> Params = '10,20';

    property Params: RawUTF8 read fParams;

  end;



{$ifndef NOVARIANTS}

  /// event called by the TInterfaceStub.Executes() fluent method for variant process

  // - by default Ctxt.Result shall contain the default JSON array result for

  // this method - use Ctxt.Named[] default properties, e.g. as

  // ! Ctxt['result'] := Ctxt['n1']-Ctxt['n2'];

  // or with Input[] / Output[] properties:

  // ! with Ctxt do Output[0] := Input[0]-Input[1];

  // - you can call Ctxt.Error() to notify the caller for an execution error

  TOnInterfaceStubExecuteVariant = procedure(Ctxt: TOnInterfaceStubExecuteParamsVariant) of object;

{$endif NOVARIANTS}



  /// event called by the TInterfaceStub.Executes() fluent method for JSON process

  // - by default Ctxt.Result shall contain the default JSON array result for

  // this method - use Ctxt.Named[] default properties, e.g. as

  // !  P := pointer(Ctxt.Params);

  // !  Ctxt.Returns([GetNextItemDouble(P)-GetNextItemDouble(P)]);

  // - you can call Ctxt.Error() to notify the caller for an execution error

  TOnInterfaceStubExecuteJSON = procedure(Ctxt: TOnInterfaceStubExecuteParamsJSON) of object;



  /// diverse types of stubbing / mocking rules

  // - isUndefined is the first, since it will be a ExpectsCount() weak rule

  // which may be overwritten by the other real run-time rules

  TInterfaceStubRuleKind =

    (isUndefined, isExecutesJSON, {$ifndef NOVARIANTS}isExecutesVariant, {$endif}

     isRaises, isReturns, isFails);



  /// define a mocking / stubing rule used internaly by TInterfaceStub

  TInterfaceStubRule = record

    /// optional expected parameters, serialized as a JSON array

    // - if equals '', the rule is not parametrized - i.e. it will be the

    // default for this method

    Params: RawUTF8;

    /// values associated to the rule

    // - for TInterfaceStub.Executes(), is the aEventParams parameter transmitted

    // to Execute event handler (could be used to e.g. customize the handler)

    // - for TInterfaceStub.Raises(), is the Exception.Message associated

    // to one ExceptionClass

    // - for TInterfaceStub.Returns(), is the returned result, serialized as a

    // JSON array (including var / out parameters then any function result)

    // - for TInterfaceStub.Fails() is the returned error message for

    // TInterfaceStub exception or TInterfaceMock associated test case

    Values: RawUTF8;

    /// the type of this rule

    // - isUndefined is used for a TInterfaceStub.ExpectsCount() weak rule

    Kind: TInterfaceStubRuleKind;

    /// the event handler to be executed

    // - for TInterfaceStub.Executes(), Values is transmitted as aResult parameter

    // - either a TOnInterfaceStubExecuteJSON, or a TOnInterfaceStubExecuteVariant

    Execute: TMethod;

    /// the exception class to be raised

    // - for TInterfaceStub.Raises(), Values contains Exception.Message

    ExceptionClass: ExceptClass;

    /// the number of times this rule has been executed

    RulePassCount: cardinal;

    /// comparison operator set by TInterfaceStub.ExpectsCount()

    // - only qoEqualTo..qoGreaterThanOrEqualTo are relevant here

    ExpectedPassCountOperator: TSQLQueryOperator;

    /// expected pass count value set by TInterfaceStub.ExpectsCount()

    // - value to be compared to the number of times this rule has been executed

    // - TInterfaceStub/TInterfaceMock will check it in their Destroy destructor,

    // using the comparison stated by ExpectedPassCountOperator

    ExpectedPassCount: cardinal;

    /// log trace value set by TInterfaceStub.ExpectsTrace()

    // - value to be compared to the Hash32() value of the execution log trace

    // - TInterfaceStub/TInterfaceMock will check it in their Destroy destructor,

    // using the fLogs[] content

    ExpectedTraceHash: cardinal;

  end;



  /// define the rules for a given method as used internaly by TInterfaceStub

  TInterfaceStubRules = {$ifndef ISDELPHI2010}object{$else}record{$endif}

    /// the mocking / stubing rules associated to this method

    Rules: array of TInterfaceStubRule;

    /// index in Rules[] of the default rule, i.e. the one with Params=''

    DefaultRule: integer;

    /// the number of times this method has been executed

    MethodPassCount: cardinal;

    /// find a rule index from its Params content

    function FindRuleIndex(const aParams: RawUTF8): integer;

    /// find a strong rule index from its Params content

    function FindStrongRuleIndex(const aParams: RawUTF8): integer;

    /// register a rule

    procedure AddRule(Sender: TInterfaceStub; aKind: TInterfaceStubRuleKind;

      const aParams, aValues: RawUTF8; const aEvent: TNotifyEvent=nil;

      aExceptionClass: ExceptClass=nil;

      aExpectedPassCountOperator: TSQLQueryOperator=qoNone; aValue: cardinal=0);

  end;



  /// diverse options available to TInterfaceStub

  // - by default, method execution stack is not recorded - include

  // imoLogMethodCallsAndResults in the options to track all method calls

  // and the returned values; note that ExpectsTrace() method will set it

  // - by default, TInterfaceStub will be released when the stubed/mocked

  // interface is released - include imoFakeInstanceWontReleaseTInterfaceStub

  // in the options to force manual memory handling of TInterfaceStubs

  // - by default, all interfaces will return some default values, unless

  // imoRaiseExceptionIfNoRuleDefined or imoReturnErrorIfNoRuleDefined is

  // included in the options

  // - by default, any TInterfaceMock.Fails() rule execution will notify the

  // TSynTestCase, unless imoMockFailsWillPassTestCase which will let test pass

  TInterfaceStubOption = (

    imoLogMethodCallsAndResults,

    imoFakeInstanceWontReleaseTInterfaceStub,

    imoRaiseExceptionIfNoRuleDefined,

    imoReturnErrorIfNoRuleDefined,

    imoMockFailsWillPassTestCase);



  /// set of options available to TInterfaceStub

  TInterfaceStubOptions = set of TInterfaceStubOption;



  /// every potential part of TInterfaceStubLog.AddAsText() log entry

  TInterfaceStubLogLayout = (wName, wParams, wResults);



  /// set the output layout of TInterfaceStubLog.AddAsText() log entry

  TInterfaceStubLogLayouts = set of TInterfaceStubLogLayout;



  /// used to keep track of one stubbed method call

  TInterfaceStubLog = {$ifndef ISDELPHI2010}object{$else}record{$endif}

    /// call timestamp, in milliseconds

    // - is filled with GetTickCount64() API returned value

    TimeStamp64: Int64;

    /// set to TRUE if this calls failed

    // - i.e. if EInterfaceFactoryException was raised for TInterfaceStub, or

    // if TInterfaceMock did notify its associated TSynTestCase via a Check()

    // - CustomResults/Results will contain the error message

    WasError: boolean;

    /// the method called

    // - a pointer to the existing information in shared TInterfaceFactory

    Method: PServiceMethod;

    /// the parameters at execution call

    Params: RawUTF8;

    /// any non default result returned after execution

    // - if not set (i.e. if equals ''), Method^.DefaultResult has been returned

    // - if WasError is TRUE, always contain the error message

    CustomResults: RawUTF8;

    /// the result returned after execution

    // - this method will return Method^.DefaultResult

    function Results: RawUTF8;

    /// append the log in textual format

    // - typical output is as such:

    // $ Add(10,20)=[30],

    // or, if WasError is TRUE:

    // $ Divide(20,0) error "divide by zero",

    procedure AddAsText(WR: TTextWriter; aScope: TInterfaceStubLogLayouts;

      SepChar: AnsiChar=',');

  end;



  /// used to keep track of all stubbed methods calls

  TInterfaceStubLogDynArray = array of TInterfaceStubLog;



  /// used to stub an interface implementation

  // - define the expected workflow in a fluent interface using Executes /

  // Fails / Returns / Raises

  // - this class will be inherited by TInterfaceMock which will contain some

  // additional methods dedicated to mocking behavior (e.g. including in tests)

  // - each instance of this class will be owned by its generated fake

  // implementation class (retrieved at constructor out parameter): when the

  // stubed/mocked interface is freed, its associated TInterfaceStub will be

  // freed - so you do not need to protect TInterfaceStub.Create with a

  // try..finally clause, since it will be released when no more needed

  // - inherits from TInterfaceResolver so match TInjectableObject expectations

  TInterfaceStub = class(TInterfaceResolver)

  protected

    fInterface: TInterfaceFactory;

    fRules: array of TInterfaceStubRules;

    fOptions: TInterfaceStubOptions;

    fHasExpects: set of (eCount,eTrace);

    fLogs: TInterfaceStubLogDynArray;

    fLog: TDynArray;

    fLogCount: integer;

    fInterfaceExpectedTraceHash: cardinal;

    fLastInterfacedObjectFake: TInterfacedObject;

    function TryResolve(aInterface: PTypeInfo; out Obj): boolean; override;

    function Implements(aInterface: PTypeInfo): boolean; override;

    procedure InternalGetInstance(out aStubbedInterface); virtual;

    function InternalCheck(aValid,aExpectationFailed: boolean;

      const aErrorMsgFmt: RawUTF8; const aErrorMsgArgs: array of const): boolean; virtual;

    // match TOnFakeInstanceInvoke callback signature

    function Invoke(const aMethod: TServiceMethod;

      const aParams: RawUTF8; aResult, aErrorMsg: PRawUTF8;

      aClientDrivenID: PCardinal; aServiceCustomAnswer: PServiceCustomAnswer): boolean;

    // will launch InternalCheck() process if some expectations defined by

    // ExpectsCount() are not met, i.e. raise an exception for TInterfaceStub

    // or notify the associated test case for TInterfaceMock

    procedure InstanceDestroyed(aClientDrivenID: cardinal);

    procedure IntSetOptions(Options: TInterfaceStubOptions); virtual;

    procedure IntCheckCount(aMethodIndex, aComputed: cardinal; aOperator: TSQLQueryOperator; aCount: cardinal);

    function IntGetLogAsText(asmndx: integer; const aParams: RawUTF8;

      aScope: TInterfaceStubLogLayouts; SepChar: AnsiChar): RawUTF8;

    function GetLogHash: cardinal;

    procedure OnExecuteToLog(Ctxt: TOnInterfaceStubExecuteParamsVariant);

    /// low-level internal constructor

    constructor Create(aFactory: TInterfaceFactory;

      const aInterfaceName: RawUTF8); reintroduce; overload; virtual;

  public

    /// initialize an interface stub from TypeInfo(IMyInterface)

    // - assign the fake class instance to a stubbed interface variable:

    // !var I: ICalculator;

    // !  TInterfaceStub.Create(TypeInfo(ICalculator),I);

    // !  Check(I.Add(10,20)=0,'Default result');

    constructor Create(aInterface: PTypeInfo; out aStubbedInterface); reintroduce; overload;

    /// initialize an interface stub from an interface GUID

    // - you shall have registered the interface by a previous call to

    // ! TInterfaceFactory.RegisterInterfaces([TypeInfo(IMyInterface),...])

    // - once registered, create and use the fake class instance as such:

    // !var I: ICalculator;

    // !  TInterfaceStub.Create(ICalculator,I);

    // !  Check(I.Add(10,20)=0,'Default result');

    // - if the supplied TGUID has not been previously registered, raise an Exception

    constructor Create(const aGUID: TGUID; out aStubbedInterface); reintroduce; overload;

    /// initialize an interface stub from an interface name (e.g. 'IMyInterface')

    // - you shall have registered the interface by a previous call to

    // TInterfaceFactory.Get(TypeInfo(IMyInterface)) or RegisterInterfaces([])

    // - if the supplied name has not been previously registered, raise an Exception

    constructor Create(const aInterfaceName: RawUTF8; out aStubbedInterface); reintroduce; overload;

    /// prepare an interface stub from TypeInfo(IMyInterface) for later injection

    // - create several TInterfaceStub instances for a given TInjectableObject

    // ! procedure TMyTestCase.OneTestCaseMethod;

    // ! var Test: IServiceToBeTested;

    // ! begin

    // !   Test := TServiceToBeTested.CreateInjected([],

    // !     TInterfaceStub.Create(TypeInfo(ICalculator)),

    // !     TInterfaceMock.Create(TypeInfo(IPersistence),self).

    // !       ExpectsCount('SaveItem',qoEqualTo,1)]);

    constructor Create(aInterface: PTypeInfo); reintroduce; overload;

    /// prepare an interface stub from a given TGUID for later injection

    // - you shall have registered the interface by a previous call to

    // ! TInterfaceFactory.RegisterInterfaces([TypeInfo(IMyInterface),...])

    // - then create TInterfaceStub instances for a given TInjectableObject:

    // ! procedure TMyTestCase.OneTestCaseMethod;

    // ! var Test: IServiceToBeTested;

    // ! begin

    // !   Test := TServiceToBeTested.CreateInjected(

    // !     [IMyInterface],

    // !     TInterfaceMock.Create(IPersistence,self).

    // !       ExpectsCount('SaveItem',qoEqualTo,1)]);

    constructor Create(const aGUID: TGUID); reintroduce; overload;



    /// add an execution rule for a given method, with JSON marshalling

    // - optional aEventParams parameter will be transmitted to aEvent handler

    // - raise an Exception if the method name does not exist for this interface

    function Executes(const aMethodName: RawUTF8;

      aEvent: TOnInterfaceStubExecuteJSON; const aEventParams: RawUTF8=''): TInterfaceStub; overload;

    /// add an execution rule for a given method and a set of parameters,

    // with JSON marshalling

    // - if execution context matches the supplied aParams value, aEvent is triggered

    // - optional aEventParams parameter will be transmitted to aEvent handler

    // - raise an Exception if the method name does not exist for this interface

    function Executes(const aMethodName, aParams: RawUTF8;

      aEvent: TOnInterfaceStubExecuteJSON; const aEventParams: RawUTF8=''): TInterfaceStub; overload;

    /// add an execution rule for a given method and a set of parameters,

    // with JSON marshalling

    // - if execution context matches the supplied aParams value, aEvent is triggered

    // - optional aEventParams parameter will be transmitted to aEvent handler

    // - raise an Exception if the method name does not exist for this interface

    function Executes(const aMethodName: RawUTF8; const aParams: array of const;

      aEvent: TOnInterfaceStubExecuteJSON; const aEventParams: RawUTF8=''): TInterfaceStub; overload;

{$ifndef NOVARIANTS}

    /// add an execution rule for a given method, with Variant marshalling

    // - optional aEventParams parameter will be transmitted to aEvent handler

    // - raise an Exception if the method name does not exist for this interface

    function Executes(const aMethodName: RawUTF8;

      aEvent: TOnInterfaceStubExecuteVariant; const aEventParams: RawUTF8=''): TInterfaceStub; overload;

    /// add an execution rule for a given method and a set of parameters,

    // with Variant marshalling

    // - if execution context matches the supplied aParams value, aEvent is triggered

    // - optional aEventParams parameter will be transmitted to aEvent handler

    // - raise an Exception if the method name does not exist for this interface

    function Executes(const aMethodName, aParams: RawUTF8;

      aEvent: TOnInterfaceStubExecuteVariant; const aEventParams: RawUTF8=''): TInterfaceStub; overload;

    /// add an execution rule for a given method and a set of parameters,

    // with Variant marshalling

    // - if execution context matches the supplied aParams value, aEvent is triggered

    // - optional aEventParams parameter will be transmitted to aEvent handler

    // - raise an Exception if the method name does not exist for this interface

    function Executes(const aMethodName: RawUTF8; const aParams: array of const;

      aEvent: TOnInterfaceStubExecuteVariant; const aEventParams: RawUTF8=''): TInterfaceStub; overload;

    /// add an execution rule for all methods, with Variant marshalling

    // - optional aEventParams parameter will be transmitted to aEvent handler

    // - callback's Ctxt: TOnInterfaceStubExecuteParamsVariant's Method field

    // would identify the executed method

    function Executes(aEvent: TOnInterfaceStubExecuteVariant; const aEventParams: RawUTF8=''): TInterfaceStub; overload;

    /// will add execution rules for all methods to log the input parameters

    // - aKind would define how the input parameters are serialized in JSON

    function Executes(aLog: TSynLogClass; aLogLevel: TSynLogInfo;

       aKind: TServiceMethodParamsDocVariantKind): TInterfaceStub; overload;

{$endif}



    /// add an exception rule for a given method

    // - will create and raise the specified exception for this method

    // - raise an Exception if the method name does not exist for this interface

    function Raises(const aMethodName: RawUTF8;

      aException: ExceptClass; const aMessage: string): TInterfaceStub; overload;

    /// add an exception rule for a given method and a set of parameters

    // - will create and raise the specified exception for this method, if the

    // execution context matches the supplied aParams value

    // - raise an Exception if the method name does not exist for this interface

    function Raises(const aMethodName, aParams: RawUTF8;

      aException: ExceptClass; const aMessage: string): TInterfaceStub; overload;

    /// add an exception rule for a given method and a set of parameters

    // - will create and raise the specified exception for this method, if the

    // execution context matches the supplied aParams value

    // - raise an Exception if the method name does not exist for this interface

    function Raises(const aMethodName: RawUTF8; const aParams: array of const;

      aException: ExceptClass; const aMessage: string): TInterfaceStub; overload;



    /// add an evaluation rule for a given method

    // - aExpectedResults JSON array will be returned to the caller

    // - raise an Exception if the method name does not exist for this interface

    function Returns(const aMethodName, aExpectedResults: RawUTF8): TInterfaceStub; overload;

    /// add an evaluation rule for a given method

    // - aExpectedResults will be returned to the caller after conversion to

    // a JSON array

    // - raise an Exception if the method name does not exist for this interface

    function Returns(const aMethodName: RawUTF8; const aExpectedResults: array of const): TInterfaceStub; overload;

    /// add an evaluation rule for a given method and a set of parameters

    // - aExpectedResults JSON array will be returned to the caller

    // - raise an Exception if the method name does not exist for this interface

    function Returns(const aMethodName, aParams, aExpectedResults: RawUTF8): TInterfaceStub; overload;

    /// add an evaluation rule for a given method and a set of parameters

    // - aExpectedResults JSON array will be returned to the caller

    // - raise an Exception if the method name does not exist for this interface

    function Returns(const aMethodName: RawUTF8;

      const aParams, aExpectedResults: array of const): TInterfaceStub; overload;



    /// add an error rule for a given method

    // - an error will be returned to the caller, with aErrorMsg as message

    // - it will raise EInterfaceFactoryException for TInterfaceStub, but

    // TInterfaceMock will push the failure to the associated test case

    // - raise an Exception if the method name does not exist for this interface

    function Fails(const aMethodName, aErrorMsg: RawUTF8): TInterfaceStub; overload;

    /// add an error rule for a given method and a set of parameters

    // - an error will be returned to the caller, with aErrorMsg as message

    // - it will raise EInterfaceFactoryException for TInterfaceStub, but

    // TInterfaceMock will push the failure to the associated test case

    // - raise an Exception if the method name does not exist for this interface

    function Fails(const aMethodName, aParams, aErrorMsg: RawUTF8): TInterfaceStub; overload;

    /// add an error rule for a given method and a set of parameters

    // - an error will be returned to the caller, with aErrorMsg as message

    // - it will raise EInterfaceFactoryException for TInterfaceStub, but

    // TInterfaceMock will push the failure to the associated test case

    // - raise an Exception if the method name does not exist for this interface

    function Fails(const aMethodName: RawUTF8; const aParams: array of const;

      const aErrorMsg: RawUTF8): TInterfaceStub; overload;



    /// add a pass count expectation rule for a given method

    // - those rules will be evaluated at Destroy execution

    // - only qoEqualTo..qoGreaterThanOrEqualTo are relevant here

    // - it will raise EInterfaceFactoryException for TInterfaceStub, but

    // TInterfaceMock will push the failure to the associated test case

    // - raise an Exception if the method name does not exist for this interface

    function ExpectsCount(const aMethodName: RawUTF8; aOperator: TSQLQueryOperator;

      aValue: cardinal): TInterfaceStub; overload;

    /// add a pass count expectation rule for a given method and a set of parameters

    // - those rules will be evaluated at Destroy execution

    // - only qoEqualTo..qoGreaterThanOrEqualTo are relevant here

    // - it will raise EInterfaceFactoryException for TInterfaceStub, but

    // TInterfaceMock will push the failure to the associated test case

    // - raise an Exception if the method name does not exist for this interface

    function ExpectsCount(const aMethodName, aParams: RawUTF8; aOperator: TSQLQueryOperator;

      aValue: cardinal): TInterfaceStub; overload;

    /// add a pass count expectation rule for a given method and a set of parameters

    // - those rules will be evaluated at Destroy execution

    // - only qoEqualTo..qoGreaterThanOrEqualTo are relevant here

    // - it will raise EInterfaceFactoryException for TInterfaceStub, but

    // TInterfaceMock will push the failure to the associated test case

    // - raise an Exception if the method name does not exist for this interface

    function ExpectsCount(const aMethodName: RawUTF8; const aParams: array of const;

      aOperator: TSQLQueryOperator; aValue: cardinal): TInterfaceStub; overload;



    /// add a hash-based execution expectation rule for the whole interface

    // - those rules will be evaluated at Destroy execution

    // - supplied aValue is a Hash32() of the trace in LogAsText format

    // - it will raise EInterfaceFactoryException for TInterfaceStub, but

    // TInterfaceMock will push the failure to the associated test case

    function ExpectsTrace(aValue: cardinal): TInterfaceStub; overload;

    /// add a hash-based execution expectation rule for a given method

    // - those rules will be evaluated at Destroy execution

    // - supplied aValue is a Hash32() of the trace in LogAsText format

    // - it will raise EInterfaceFactoryException for TInterfaceStub, but

    // TInterfaceMock will push the failure to the associated test case

    // - raise an Exception if the method name does not exist for this interface

    function ExpectsTrace(const aMethodName: RawUTF8; aValue: cardinal): TInterfaceStub; overload;

    /// add a hash-based execution expectation rule for a given method

    // and a set of parameters

    // - those rules will be evaluated at Destroy execution

    // - supplied aValue is a Hash32() of the trace in LogAsText format

    // - it will raise EInterfaceFactoryException for TInterfaceStub, but

    // TInterfaceMock will push the failure to the associated test case

    // - raise an Exception if the method name does not exist for this interface

    function ExpectsTrace(const aMethodName, aParams: RawUTF8;

      aValue: cardinal): TInterfaceStub; overload;

    /// add a hash-based execution expectation rule for a given method

    // and a set of parameters

    // - those rules will be evaluated at Destroy execution

    // - supplied aValue is a Hash32() of the trace in LogAsText format

    // - it will raise EInterfaceFactoryException for TInterfaceStub, but

    // TInterfaceMock will push the failure to the associated test case

    // - raise an Exception if the method name does not exist for this interface

    function ExpectsTrace(const aMethodName: RawUTF8; const aParams: array of const;

      aValue: cardinal): TInterfaceStub; overload;

    /// add a JSON-based execution expectation rule for the whole interface

    // - those rules will be evaluated at Destroy execution

    // - supplied aValue is the trace in LogAsText format

    // - it will raise EInterfaceFactoryException for TInterfaceStub, but

    // TInterfaceMock will push the failure to the associated test case

    function ExpectsTrace(const aValue: RawUTF8): TInterfaceStub; overload;

    /// add a JSON-based execution expectation rule for a given method

    // - those rules will be evaluated at Destroy execution

    // - supplied aValue is the trace in LogAsText format

    // - it will raise EInterfaceFactoryException for TInterfaceStub, but

    // TInterfaceMock will push the failure to the associated test case

    // - raise an Exception if the method name does not exist for this interface

    function ExpectsTrace(const aMethodName, aValue: RawUTF8): TInterfaceStub; overload;

    /// add a JSON-based execution expectation rule for a given method

    // and a set of parameters

    // - those rules will be evaluated at Destroy execution

    // - supplied aValue is the trace in LogAsText format

    // - it will raise EInterfaceFactoryException for TInterfaceStub, but

    // TInterfaceMock will push the failure to the associated test case

    // - raise an Exception if the method name does not exist for this interface

    function ExpectsTrace(const aMethodName, aParams, aValue: RawUTF8): TInterfaceStub; overload;

    /// add a JSON-based execution expectation rule for a given method

    // and a set of parameters

    // - those rules will be evaluated at Destroy execution

    // - supplied aValue is the trace in LogAsText format

    // - it will raise EInterfaceFactoryException for TInterfaceStub, but

    // TInterfaceMock will push the failure to the associated test case

    // - raise an Exception if the method name does not exist for this interface

    function ExpectsTrace(const aMethodName: RawUTF8; const aParams: array of const;

      const aValue: RawUTF8): TInterfaceStub; overload;



    /// set the optional stubing/mocking options

    // - same as the Options property, but in a fluent-style interface

    function SetOptions(Options: TInterfaceStubOptions): TInterfaceStub;

    /// reset the internal trace

    // - Log, LogAsText, LogHash and LogCount would be initialized

    procedure ClearLog;



    /// the stubbed method execution trace items

    property Log: TInterfaceStubLogDynArray read fLogs;

    /// the stubbed method execution trace converted as text

    // - typical output is a list of calls separated by commas:

    // $ Add(10,20)=[30],Divide(20,0) error "divide by zero"

    function LogAsText(SepChar: AnsiChar=','): RawUTF8;

    /// returns the last created TInterfacedObject instance

    // - e.g. corresponding to the out aStubbedInterface parameter of Create()

    property LastInterfacedObjectFake: TInterfacedObject read fLastInterfacedObjectFake;

  published

    /// access to the registered Interface RTTI information

    property InterfaceFactory: TInterfaceFactory read fInterface;

    /// optional stubing/mocking options

    // - you can use the SetOptions() method in a fluent-style interface

    property Options: TInterfaceStubOptions read fOptions write IntSetOptions;

    /// the stubbed method execution trace number of items

    property LogCount: Integer read fLogCount;

    /// the stubbed method execution trace converted as one numerical hash

    // - returns Hash32(LogAsText)

    property LogHash: cardinal read GetLogHash;

  end;



  /// used to mock an interface implementation via expect-run-verify pattern

  // - TInterfaceStub will raise an exception on Fails(), ExpectsCount() or

  // ExpectsTrace() rule activation, but TInterfaceMock will call

  // TSynTestCase.Check() with no exception with such rules, as expected by

  // a mocked interface

  // - this class will follow the expect-run-verify pattern, i.e. expectations

  // are defined before running the test, and verification is performed

  // when the instance is released - use TInterfaceMockSpy if you prefer the

  // more explicit run-verify pattern

  TInterfaceMock = class(TInterfaceStub)

  protected

    fTestCase: TSynTestCase;

    function InternalCheck(aValid,aExpectationFailed: boolean;

      const aErrorMsgFmt: RawUTF8; const aErrorMsgArgs: array of const): boolean; override;

  public

    /// initialize an interface mock from TypeInfo(IMyInterface)

    // - aTestCase.Check() will be called in case of mocking failure

    // ! procedure TMyTestCase.OneTestCaseMethod;

    // ! var Persist: IPersistence;

    // ! ...

    // !   TInterfaceMock.Create(TypeInfo(IPersistence),Persist,self).

    // !     ExpectsCount('SaveItem',qoEqualTo,1)]);

    constructor Create(aInterface: PTypeInfo; out aMockedInterface;

      aTestCase: TSynTestCase); reintroduce; overload;

    /// initialize an interface mock from an interface TGUID

    // - aTestCase.Check() will be called during validation of all Expects*()

    // - you shall have registered the interface by a previous call to

    // ! TInterfaceFactory.RegisterInterfaces([TypeInfo(IPersistence),...])

    // - once registered, create and use the fake class instance as such:

    // !procedure TMyTestCase.OneTestCaseMethod;

    // !var Persist: IPersistence;

    // ! ...

    // !   TInterfaceMock.Create(IPersistence,Persist,self).

    // !     ExpectsCount('SaveItem',qoEqualTo,1)]);

    // - if the supplied TGUID has not been previously registered, raise an Exception

    constructor Create(const aGUID: TGUID; out aMockedInterface;

      aTestCase: TSynTestCase); reintroduce; overload;

    /// initialize an interface mock from an interface name (e.g. 'IMyInterface')

    // - aTestCase.Check() will be called in case of mocking failure

    // - you shall have registered the interface by a previous call to

    // TInterfaceFactory.Get(TypeInfo(IMyInterface)) or RegisterInterfaces()

    // - if the supplied name has not been previously registered, raise an Exception

    constructor Create(const aInterfaceName: RawUTF8; out aMockedInterface;

      aTestCase: TSynTestCase); reintroduce; overload;

    /// initialize an interface mock from TypeInfo(IMyInterface) for later injection

    // - aTestCase.Check() will be called in case of mocking failure

    constructor Create(aInterface: PTypeInfo; aTestCase: TSynTestCase); reintroduce; overload;

    /// initialize an interface mock from TypeInfo(IMyInterface) for later injection

    // - aTestCase.Check() will be called in case of mocking failure

    constructor Create(const aGUID: TGUID; aTestCase: TSynTestCase); reintroduce; overload;

    /// the associated test case

    property TestCase: TSynTestCase read fTestCase;

  end;



  /// how TInterfaceMockSpy.Verify() shall generate the calls trace

  TInterfaceMockSpyCheck = (chkName, chkNameParams, chkNameParamsResults);



  /// used to mock an interface implementation via run-verify pattern

  // - this class will implement a so called "test-spy" mocking pattern, i.e.

  // no expectation is to be declared at first, but all calls are internally

  // logged (i.e. it force imoLogMethodCallsAndResults option to be defined),

  // and can afterwards been check via Verify() calls

  TInterfaceMockSpy = class(TInterfaceMock)

  protected

    procedure IntSetOptions(Options: TInterfaceStubOptions); override;

    /// this will set and force imoLogMethodCallsAndResults option as needed

    constructor Create(aFactory: TInterfaceFactory;

      const aInterfaceName: RawUTF8); override;

  public

    /// check that a method has been called a specify number of times

    procedure Verify(const aMethodName: RawUTF8;

      aOperator: TSQLQueryOperator=qoGreaterThan; aCount: cardinal=0); overload;

    /// check a method calls count with a set of parameters

    // - parameters shall be defined as a JSON array of values

    procedure Verify(const aMethodName, aParams: RawUTF8;

      aOperator: TSQLQueryOperator=qoGreaterThan; aCount: cardinal=0); overload;

    /// check a method calls count with a set of parameters

    // - parameters shall be defined as a JSON array of values

    procedure Verify(const aMethodName: RawUTF8; const aParams: array of const;

      aOperator: TSQLQueryOperator=qoGreaterThan; aCount: cardinal=0); overload;

    /// check an execution trace for the global interface

    // - text trace format shall follow method calls, e.g.

    // ! Verify('Multiply,Add',chkName);

    // or may include parameters:

    // ! Verify('Multiply(10,30),Add(2,35)',chkNameParams);

    // or include parameters and function results:

    // ! Verify('Multiply(10,30)=[300],Add(2,35)=[37]',chkNameParamsResults);

    procedure Verify(const aTrace: RawUTF8; aScope: TInterfaceMockSpyCheck); overload;

    /// check an execution trace for a specified method

    // - text trace format will follow specified scope, e.g.

    // ! Verify('Add','(10,30),(2,35)',chkNameParams);

    // or include parameters and function results:

    // ! Verify('Add','(10,30)=[300],(2,35)=[37]',chkNameParamsResults);

    // - if aMethodName does not exists or aScope=chkName, will raise an exception

    procedure Verify(const aMethodName, aTrace: RawUTF8; aScope: TInterfaceMockSpyCheck); overload;

    /// check an execution trace for a specified method and parameters

    // - text trace format shall contain only results, e.g.

    // ! Verify('Add','2,35','[37]');

    procedure Verify(const aMethodName, aParams, aTrace: RawUTF8); overload;

    /// check an execution trace for a specified method and parameters

    // - text trace format shall contain only results, e.g.

    // ! Verify('Add',[2,35],'[37]');

    procedure Verify(const aMethodName: RawUTF8; const aParams: array of const;

      const aTrace: RawUTF8); overload;

  end;



  {$M+}

  /// an abstract service provider, as registered in TServiceContainer

  // - each registered interface has its own TServiceFactory instance, available

  // as one TSQLServiceContainer item from TSQLRest.Services property

  // - this will be either implemented by a registered TInterfacedObject on the

  // server, or by a on-the-fly generated fake TInterfacedObject class

  // communicating via JSON on a client

  // - TSQLRestServer will have to register an interface implementation as:

  // ! Server.ServiceRegister(TServiceCalculator,[TypeInfo(ICalculator)],sicShared);

  // - TSQLRestClientURI will have to register an interface remote access as:

  // ! Client.ServiceRegister([TypeInfo(ICalculator)],sicShared));

  // note that the implementation (TServiceCalculator) remain on the server side

  // only: the client only needs the ICalculator interface

  // - then TSQLRestServer and TSQLRestClientURI will both have access to the

  // service, via their Services property, e.g. as:

  // !var I: ICalculator;

  // !...

  // ! if Services.Info(ICalculator).Get(I) then

  // !   result := I.Add(10,20);

  // which is in practice to be used with the faster wrapper method:

  // ! if Services.Resolve(ICalculator,I) then

  // !   result := I.Add(10,20);

  TServiceFactory = class

  protected

    fInterface: TInterfaceFactory;

    fInterfaceURI: RawUTF8;

    fInterfaceMangledURI: RawUTF8;

    fInstanceCreation: TServiceInstanceImplementation;

    fRest: TSQLRest;

    fSharedInstance: TInterfacedObject;

    fContract: RawUTF8;

    fContractHash: RawUTF8;

    fContractExpected: RawUTF8;

    // per-method execution rights

    fExecution: array of TServiceFactoryExecution;

    function GetInterfaceTypeInfo: PTypeInfo;

      {$ifdef HASINLINE}inline;{$endif}

    function GetInterfaceIID: TGUID;

      {$ifdef HASINLINE}inline;{$endif}

  public

    /// initialize the service provider parameters

    // - it will check and retrieve all methods of the supplied interface,

    // and prepare all internal structures for its serialized execution

    constructor Create(aRest: TSQLRest; aInterface: PTypeInfo;

      aInstanceCreation: TServiceInstanceImplementation;

      const aContractExpected: RawUTF8);

    /// retrieve an instance of this interface

    // - this virtual method will be overridden to reflect the expected

    // behavior of client or server side

    // - can be used as such to resolve an I: ICalculator interface:

    // ! var I: ICalculator;

    // ! begin

    // !   if fClient.Services.Info(TypeInfo(ICalculator)).Get(I) then

    // !   ... use I

    function Get(out Obj): Boolean; virtual; abstract;

    /// retrieve the published signature of this interface

    // - is always available on TServiceFactoryServer, but TServiceFactoryClient

    // will be able to retrieve it only if TServiceContainerServer.PublishSignature

    // is set to TRUE (which is not the default setting, for security reasons)

    function RetrieveSignature: RawUTF8; virtual; abstract;

    /// the associated RESTful instance

    property Rest: TSQLRest read fRest;

    /// access to the registered Interface RTTI information

    property InterfaceFactory: TInterfaceFactory read fInterface;

    /// the registered Interface low-level Delphi RTTI type

    // - just maps InterfaceFactory.InterfaceTypeInfo

    property InterfaceTypeInfo: PTypeInfo read GetInterfaceTypeInfo;

    /// the registered Interface GUID

    // - just maps InterfaceFactory.InterfaceIID

    property InterfaceIID: TGUID read GetInterfaceIID;

    (*/ the service contract, serialized as a JSON object

    - a "contract" is in fact the used interface signature, i.e. its

      implementation mode (InstanceCreation) and all its methods definitions

    - a possible value for a one-method interface defined as such:

    ! function ICalculator.Add(n1,n2: integer): integer;

    may be returned as the following JSON object:

    $ {"contract":"Calculator","implementation":"shared",

    $  "methods":[{"method":"Add",

    $  "arguments":[{"argument":"Self","direction":"in","type":"self"},

    $               {"argument":"n1","direction":"in","type":"integer"},

    $               {"argument":"n2","direction":"in","type":"integer"},

    $               {"argument":"Result","direction":"out","type":"integer"}

    $ ]}]} *)

    property Contract: RawUTF8 read fContract;

    /// the published service contract, as expected by both client and server

    // - by default, will contain ContractHash property value (for security)

    // - but you can override this value using plain Contract or any custom

    // value (e.g. a custom version number) - in this case, both TServiceFactoryClient

    // and TServiceFactoryServer instances must have a matching ContractExpected

    // - this value is returned by a '_contract_' pseudo-method name, with the URI:

    // $ POST /root/Interface._contract_

    // or (if TSQLRestRoutingJSON_RPC is used):

    // $ POST /root/Interface

    // $ (...)

    // $ {"method":"_contract_","params":[]}

    // (e.g. to be checked in TServiceFactoryClient.Create constructor)

    // - if set to SERVICE_CONTRACT_NONE_EXPECTED (i.e. '*'), the client won't

    // check and ask the server contract for consistency: it may be used e.g.

    // for accessing a plain REST HTTP server which is not based on mORMot,

    // so may not implement POST /root/Interface._contract_

    property ContractExpected: RawUTF8 read fContractExpected write fContractExpected;

  published

    /// the registered Interface URI

    // - in fact this is the Interface name without the initial 'I', e.g.

    // 'Calculator' for ICalculator

    property InterfaceURI: RawUTF8 read fInterfaceURI;

    /// the registered Interface mangled URI

    // - in fact this is encoding the GUID using BinToBase64URI(), e.g.

    // ! ['{c9a646d3-9c61-4cb7-bfcd-ee2522c8f633}'] into '00amyWGct0y_ze4lIsj2Mw'

    // - can be substituted to the clear InterfaceURI name

    property InterfaceMangledURI: RawUTF8 read fInterfaceMangledURI;

    /// how each class instance is to be created

    // - only relevant on the server side; on the client side, this class will

    // be accessed only to retrieve a remote access instance, i.e. sicSingle

    property InstanceCreation: TServiceInstanceImplementation read fInstanceCreation;

    /// a hash of the service contract, serialized as a JSON string

    // - this may be used instead of the JSON signature, to enhance security

    // (i.e. if you do not want to publish the available methods, but want

    // to check for the proper synchronization of both client and server)

    // - a possible value may be: "C351335A7406374C"

    property ContractHash: RawUTF8 read fContractHash;

  end;

  {$M-}



  /// server-side service provider uses this to store one internal instance

  // - used by TServiceFactoryServer in sicClientDriven, sicPerSession,

  // sicPerUser or sicPerGroup mode

  TServiceFactoryServerInstance = {$ifndef ISDELPHI2010}object{$else}record{$endif}

  public

    /// the internal Instance ID, as remotely sent in "id":1

    // - is set to 0 when an entry in the array is free

    InstanceID: PtrUInt;

    /// GetTickCount64() time stamp corresponding to the last access of

    // this instance

    LastAccess64: Int64;

    /// the implementation instance itself

    Instance: TInterfacedObject;

    /// used to release the implementation instance

    // - direct FreeAndNil(Instance) may lead to A/V if self has been assigned

    // to an interface to any sub-method on the server side -> dec(RefCount)

    procedure SafeFreeInstance(Factory: TServiceFactoryServer);

  end;



  /// server-side service provider uses this to store its internal instances

  // - used by TServiceFactoryServer in sicClientDriven, sicPerSession,

  // sicPerUser or sicPerGroup mode

  TServiceFactoryServerInstanceDynArray = array of TServiceFactoryServerInstance;



  /// callback called before any interface-method service execution to allow

  // its execution

  // - see Ctxt.Service, Ctxt.ServiceMethodIndex and Ctxt.ServiceParameters

  // are used to identify the executed method context

  // - Method parameter would help identify easily the corresponding method, and

  // would contain in fact Service.InterfaceFactory.Methods[ServiceMethodIndex]

  // - should return TRUE if the method can be executed

  // - should return FALSE if the method should not be executed, and set the

  // corresponding error to the supplied context e.g.

  // ! Ctxt.Error('Unauthorized method',HTML_NOTALLOWED);

  // - i.e. called by TSQLRestServerURIContext.InternalExecuteSOAByInterface

  TOnServiceCanExecute = function(Ctxt: TSQLRestServerURIContext;

    const Method: TServiceMethod): boolean of object;



  /// a service provider implemented on the server side

  // - each registered interface has its own TServiceFactoryServer instance,

  // available as one TSQLServiceContainerServer item from TSQLRest.Services property

  // - will handle the implementation class instances of a given interface

  // - by default, all methods are allowed to execution: you can call AllowAll,

  // DenyAll, Allow or Deny in order to specify your exact security policy

  TServiceFactoryServer = class(TServiceFactory)

  protected

    fInstances: TServiceFactoryServerInstanceDynArray;

    fInstance: TDynArray;

    fInstancesCount: integer;

    fInstanceCurrentID: TID;

    fInstanceTimeOut: cardinal;

    fInstanceLock: TRTLCriticalSection;

    fStats: TSynMonitorInputOutputObjArray;

    fImplementationClass: TInterfacedClass;

    fImplementationClassKind: (ickBlank,

      ickWithCustomCreate, ickInjectable, ickInjectableRest, 

      ickFromInjectedResolver, ickFake);

    fImplementationClassInterfaceEntry: PInterfaceEntry;

    fSharedInterface: IInterface;

    fByPassAuthentication: boolean;

    fResultAsJSONObject: boolean;

    fResultAsJSONObjectWithoutResult: boolean;

    fResultAsXMLObject: boolean;

    fResultAsJSONObjectIfAccept: boolean;

    fResultAsXMLObjectNameSpace: RawUTF8;

    fBackgroundThread: TSynBackgroundThreadMethod;

    fOnMethodExecute: TOnServiceCanExecute;

    fOnExecute: array of TServiceMethodExecuteEvent;

    fLogRestBatch: array of TSQLRestBatchLocked; // store one BATCH per Rest

    /// union of all fExecution[].Options

    fAnyOptions: TServiceMethodOptions;

    procedure SetServiceLogByIndex(const aMethods: TInterfaceFactoryMethodBits;

      aLogRest: TSQLRest; aLogClass: TSQLRecordServiceLogClass);

    procedure SetTimeoutSecInt(value: cardinal);

    function GetTimeoutSec: cardinal;

    function GetStat(const aMethod: RawUTF8): TSynMonitorInputOutput;

    /// get an implementation Inst.Instance for the given Inst.InstanceID

    // - is called by ExecuteMethod() in sicClientDrive mode

    // - returns true for successfull {"method":"_free_".. call (aMethodIndex=-1)

    // - otherwise, fill Inst.Instance with the matching implementation (or nil)

    function InternalInstanceRetrieve(var Inst: TServiceFactoryServerInstance;

      aMethodIndex: integer): boolean;

    /// call a given method of this service provider

    // - here Ctxt.ServiceMethodIndex should be the index in fInterface.Methods[]

    // (i.e. excluding _free_/_contract_/_signature_ pseudo-methods)

    // - Ctxt.ServiceMethodIndex=-1, then it will free/release corresponding aInstanceID

    // (is called  e.g. from {"method":"_free_", "params":[], "id":1234} )

    // - Ctxt.ServiceParameters is e.g. '[1,2]' i.e. a true JSON array, which

    // will contain the incoming parameters in the same exact order than the

    // corresponding implemented interface method

    // - Ctxt.ID is an optional number, to be used in case of sicClientDriven

    // kind of Instance creation to identify the corresponding client session

    // - returns 200/HTML_SUCCESS on success, or an HTTP error status, with an

    // optional error message in aErrorMsg

    // - on success, Ctxt.Call.OutBody shall contain a serialized JSON object

    // with one nested result property, which may be a JSON array, containing

    // all "var" or "out" parameters values, and then the method main result -

    // for instance, ExecuteMethod(..,'[1,2]') over ICalculator.Add will return:

    // $ {"result":[3],"id":0}

    // the returned "id" number is the Instance identifier to be used for any later

    // sicClientDriven remote call - or just 0 in case of sicSingle or sicShared

    procedure ExecuteMethod(Ctxt: TSQLRestServerURIContext);

    /// called by ExecuteMethod to append input/output params to Sender.TempTextWriter

    procedure OnLogRestExecuteMethod(Sender: TServiceMethodExecute;

      Step: TServiceMethodExecuteEventStep);

    /// this method will create an implementation instance

    // - reference count will be set to one, in order to allow safe passing

    // of the instance into an interface, if AndIncreaseRefCount is TRUE

    // - will handle TInterfacedObjectWithCustomCreate and TInjectableObject

    // as expected, if necessary

    function CreateInstance(AndIncreaseRefCount: boolean): TInterfacedObject;

  public

    /// initialize the service provider on the server side

    // - expect an direct server-side implementation class, which may inherit

    // from plain TInterfacedClass, TInterfacedObjectWithCustomCreate if you

    // need an overridden constructor, or TInjectableObject to support DI/IoC

    // - for sicClientDriven, sicPerSession, sicPerUser or sicPerGroup modes,

    // a time out (in seconds) can be defined (default is 30 minutes) - if the

    // specified aTimeOutSec is 0, interface will be forced in sicSingle mode

    // - you should usualy have to call the TSQLRestServer.ServiceRegister()

    // method instead of calling this constructor directly

    constructor Create(aRestServer: TSQLRestServer; aInterface: PTypeInfo;

      aInstanceCreation: TServiceInstanceImplementation;

      aImplementationClass: TInterfacedClass; const aContractExpected: RawUTF8='';

      aTimeOutSec: cardinal=30*60; aSharedInstance: TInterfacedObject=nil); reintroduce;

    /// release all used memory

    // - e.g. any internal TServiceFactoryServerInstance instances (any shared

    // instance, and all still living instances in sicClientDrive mode)

    destructor Destroy; override;



    /// allow all methods execution for all TSQLAuthGroup

    // - all Groups will be affected by this method (on both client and server sides)

    // - this method returns self in order to allow direct chaining of security

    // calls, in a fluent interface

    function AllowAll: TServiceFactoryServer;

    /// allow all methods execution for the specified TSQLAuthGroup ID(s)

    // - the specified group ID(s) will be used to authorize remote service

    // calls from the client side

    // - you can retrieve a TSQLAuthGroup ID from its identifier, as such:

    // ! UserGroupID := fServer.MainFieldID(TSQLAuthGroup,'User');

    // - this method returns self in order to allow direct chaining of security

    // calls, in a fluent interface

    function AllowAllByID(const aGroupID: array of TID): TServiceFactoryServer;

    /// allow all methods execution for the specified TSQLAuthGroup names

    // - is just a wrapper around the other AllowAllByID() method, retrieving the

    // Group ID from its main field

    // - this method returns self in order to allow direct chaining of security

    // calls, in a fluent interface

    function AllowAllByName(const aGroup: array of RawUTF8): TServiceFactoryServer;

    /// deny all methods execution for all TSQLAuthGroup

    // - all Groups will be affected by this method (on both client and server sides)

    // - this method returns self in order to allow direct chaining of security

    // calls, in a fluent interface

    function DenyAll: TServiceFactoryServer;

    /// deny all methods execution for the specified TSQLAuthGroup ID(s)

    // - the specified group ID(s) will be used to authorize remote service

    // calls from the client side

    // - you can retrieve a TSQLAuthGroup ID from its identifier, as such:

    // ! UserGroupID := fServer.MainFieldID(TSQLAuthGroup,'User');

    // - this method returns self in order to allow direct chaining of security

    // calls, in a fluent interface

    function DenyAllByID(const aGroupID: array of TID): TServiceFactoryServer;

    /// dent all methods execution for the specified TSQLAuthGroup names

    // - is just a wrapper around the other DenyAllByID() method, retrieving the

    // Group ID from its main field

    // - this method returns self in order to allow direct chaining of security

    // calls, in a fluent interface

    function DenyAllByName(const aGroup: array of RawUTF8): TServiceFactoryServer;

    /// allow specific methods execution for the all TSQLAuthGroup

    // - methods names should be specified as an array (e.g. ['Add','Multiply'])

    // - all Groups will be affected by this method (on both client and server sides)

    // - this method returns self in order to allow direct chaining of security

    // calls, in a fluent interface

    function Allow(const aMethod: array of RawUTF8): TServiceFactoryServer;

    /// allow specific methods execution for the specified TSQLAuthGroup ID(s)

    // - methods names should be specified as an array (e.g. ['Add','Multiply'])

    // - the specified group ID(s) will be used to authorize remote service

    // calls from the client side

    // - you can retrieve a TSQLAuthGroup ID from its identifier, as such:

    // ! UserGroupID := fServer.MainFieldID(TSQLAuthGroup,'User');

    // - this method returns self in order to allow direct chaining of security

    // calls, in a fluent interface

    function AllowByID(const aMethod: array of RawUTF8; const aGroupID: array of TID): TServiceFactoryServer;

    /// allow specific methods execution for the specified TSQLAuthGroup name(s)

    // - is just a wrapper around the other AllowByID() method, retrieving the

    // Group ID from its main field

    // - methods names should be specified as an array (e.g. ['Add','Multiply'])

    // - this method returns self in order to allow direct chaining of security

    // calls, in a fluent interface

    function AllowByName(const aMethod: array of RawUTF8; const aGroup: array of RawUTF8): TServiceFactoryServer;

    /// deny specific methods execution for the all TSQLAuthGroup

    // - methods names should be specified as an array (e.g. ['Add','Multiply'])

    // - all Groups will be affected by this method (on both client and server sides)

    // - this method returns self in order to allow direct chaining of security

    // calls, in a fluent interface

    function Deny(const aMethod: array of RawUTF8): TServiceFactoryServer;

    /// deny specific methods execution for the specified TSQLAuthGroup ID(s)

    // - methods names should be specified as an array (e.g. ['Add','Multiply'])

    // - the specified group ID(s) will be used to unauthorize remote service

    // calls from the client side

    // - you can retrieve a TSQLAuthGroup ID from its identifier, as such:

    // ! UserGroupID := fServer.MainFieldID(TSQLAuthGroup,'User');

    // - this method returns self in order to allow direct chaining of security

    // calls, in a fluent interface

    function DenyByID(const aMethod: array of RawUTF8; const aGroupID: array of TID): TServiceFactoryServer; overload;

    /// deny specific methods execution for the specified TSQLAuthGroup name(s)

    // - is just a wrapper around the other DenyByID() method, retrieving the

    // Group ID from its main field

    // - methods names should be specified as an array (e.g. ['Add','Multiply'])

    // - this method returns self in order to allow direct chaining of security

    // calls, in a fluent interface

    function DenyByName(const aMethod: array of RawUTF8; const aGroup: array of RawUTF8): TServiceFactoryServer;

    /// define execution options for a given set of methods

    // - methods names should be specified as an array (e.g. ['Add','Multiply'])

    // - if no method name is given (i.e. []), option will be set for all methods

    // - include optExecInMainThread will force the method(s) to be called within

    // a RunningThread.Synchronize() call - slower, but thread-safe

    // - this method returns self in order to allow direct chaining of security

    // calls, in a fluent interface

    function SetOptions(const aMethod: array of RawUTF8; aOptions: TServiceMethodOptions): TServiceFactoryServer;

    /// define the the instance life time-out, in seconds

    // - for sicClientDriven, sicPerSession, sicPerUser or sicPerGroup modes

    // - raise an exception for other kind of execution

    // - this method returns self in order to allow direct chaining of setting

    // calls for the service, in a fluent interface

    function SetTimeoutSec(value: cardinal): TServiceFactoryServer;

    /// log method execution information to a TSQLRecordServiceLog table

    // - methods names should be specified as an array (e.g. ['Add','Multiply'])

    // - if no method name is given (i.e. []), option will be set for all methods

    // - will write to the specified aLogRest instance, and would disable

    // writing if aLogRest is nil

    // - will write to a (inherited) TSQLRecordServiceLog table, as available in

    // TSQLRest's model, unless a dedicated table is specified as aLogClass

    // - this method returns self in order to allow direct chaining of security

    // calls, in a fluent interface

    function SetServiceLog(const aMethod: array of RawUTF8;

      aLogRest: TSQLRest; aLogClass: TSQLRecordServiceLogClass=nil): TServiceFactoryServer;

    /// you can define here an event to allow/deny execution of any method

    // of this service, at runtime

    property OnMethodExecute: TOnServiceCanExecute read fOnMethodExecute write fOnMethodExecute;

    /// allow to hook the methods execution

    // - several events could be registered, and would be called directly

    // before and after method execution

    // - if optInterceptInputOutput is defined in Options, then Sender.Input/Output

    // fields would contain the execution data context when Hook is called

    // - see OnMethodExecute if you want to implement security features

    procedure AddInterceptor(const Hook: TServiceMethodExecuteEvent);



    /// retrieve an instance of this interface from the server side

    // - sicShared mode will retrieve the shared instance

    // - sicPerThread mode will retrieve the instance corresponding to the

    // current running thread

    // - all other kind of instance creation will behave the same as sicSingle

    // when accessed directly from this method, i.e. from server side: in fact,

    // on the server side, there is no notion of client, session, user nor group

    // - if ServiceContext.Factory is nil (i.e. if there is no other

    // service context currently associated), this method will also update

    // ServiceContext.Factory, so that the implementation method would be able

    // to access the associated TSQLRestServer instance if needed

    function Get(out Obj): Boolean; override;

    /// retrieve the published signature of this interface

    // - is always available on TServiceFactoryServer, but TServiceFactoryClient

    // will be able to retrieve it only if TServiceContainerServer.PublishSignature

    // is set to TRUE (which is not the default setting, for security reasons)

    function RetrieveSignature: RawUTF8; override;



    /// just type-cast the associated TSQLRest instance to a true TSQLRestServer

    function RestServer: TSQLRestServer;

      {$ifdef HASINLINE}inline;{$endif}



    /// direct access to per-method detailed process statistics

    // - this Stats[] array follows Interface.Methods[] order

    // - see Stat[] property to retrieve information about a method by name

    property Stats: TSynMonitorInputOutputObjArray read fStats;

    /// retrieve detailed statistics about a method use

    // - will return a reference to the actual item in Stats[]: caller should

    // not free the returned instance

    property Stat[const aMethod: RawUTF8]: TSynMonitorInputOutput read GetStat;

  published

    /// the class type used to implement this interface

    property ImplementationClass: TInterfacedClass read fImplementationClass;

    /// the instance life time-out, in seconds

    // - for sicClientDriven, sicPerSession, sicPerUser or sicPerGroup modes

    // - raise an exception for other kind of execution

    // - you can also use the SetTimeOutSec() fluent function instead

    property TimeoutSec: cardinal read GetTimeoutSec write SetTimeoutSecInt;

    /// set to TRUE disable Authentication method check for the whole interface

    // - by default (FALSE), all interface-based services will require valid

    // RESTful authentication (if enabled on the server side); setting TRUE will

    // disable authentication for all methods of this interface

    // (e.g. for returning some HTML content from a public URI, or to implement

    // a public service catalog)

    property ByPassAuthentication: boolean read fByPassAuthentication write fByPassAuthentication;

    /// set to TRUE to return the interface's methods result as JSON object

    // - by default (FALSE), any method execution will return a JSON array with

    // all VAR/OUT parameters, in order

    // - TRUE will generate a JSON object instead, with the VAR/OUT parameter

    // names as field names (and "Result" for any function result) - may be

    // useful e.g. when working with JavaScript clients

    // - Delphi clients (i.e. TServiceFactoryClient/TInterfacedObjectFake) will

    // transparently handle both formats

    // - this value can be overridden by setting ForceServiceResultAsJSONObject

    // for a given TSQLRestServerURIContext (e.g. for server-side JavaScript work)

    property ResultAsJSONObject: boolean

      read fResultAsJSONObject write fResultAsJSONObject;

    /// set to TRUE to return the interface's methods result as JSON object

    // with no '{"result":{...}}' nesting

    // - could be used e.g. for plain non mORMot REST Client with in sicSingle

    // or sicShared mode kind of services

    property ResultAsJSONObjectWithoutResult: boolean

      read fResultAsJSONObjectWithoutResult write fResultAsJSONObjectWithoutResult;

    /// set to TRUE to return the interface's methods result as XML object

    // - by default (FALSE), method execution will return a JSON array with

    // all VAR/OUT parameters, or a JSON object if ResultAsJSONObject is TRUE

    // - TRUE will generate a XML object instead, with the VAR/OUT parameter

    // names as field names (and "Result" for any function result) - may be

    // useful e.g. when working with some XML-only clients

    // - Delphi clients (i.e. TServiceFactoryClient/TInterfacedObjectFake) does

    // NOT handle this XML format yet

    // - this value can be overridden by setting ForceServiceResultAsXMLObject

    // for a given TSQLRestServerURIContext instance

    property ResultAsXMLObject: boolean

      read fResultAsXMLObject write fResultAsXMLObject;

    /// set to TRUE to return XML objects for the interface's methods result

    // if the Accept: HTTP header is exactly 'application/xml' or 'text/xml'

    // - the header should be exactly 'Accept: application/xml' or

    // 'Accept: text/xml' (and no other value)

    // - in this case, ForceServiceResultAsXMLObject will be set for this

    // particular TSQLRestServerURIContext instance, and result returned as XML

    // - using this method allows to mix standard JSON requests (from JSON

    // or AJAX clients) and XML requests (from XML-only clients)

    property ResultAsXMLObjectIfAcceptOnlyXML: boolean

      read fResultAsJSONObjectIfAccept write fResultAsJSONObjectIfAccept;

    /// specify a custom name space content when returning a XML object

    // - by default, no name space would be appended - but such rough XML would

    // have potential validation problems

    // - you may use e.g. XMLUTF8_NAMESPACE, which will append <content ...> ...

    // </content> around the generated XML data

    property ResultAsXMLObjectNameSpace: RawUTF8

      read fResultAsXMLObjectNameSpace write fResultAsXMLObjectNameSpace;

  end;



  /// a service provider implemented on the client side

  // - each registered interface has its own TServiceFactoryClient instance,

  // available as one TSQLServiceContainerClient item from TSQLRest.Services property

  // - will emulate "fake" implementation class instance of a given interface

  // and call remotely the server to process the actual implementation

  TServiceFactoryClient = class(TServiceFactory)

  protected

    fForcedURI: RawUTF8;

    fClient: TSQLRestClientURI;

    fParamsAsJSONObject: boolean;

    fResultAsJSONObject: boolean;

    fSendNotificationsThread: TThread;

    fSendNotificationsRest: TSQLRest;

    fSendNotificationsLogClass: TSQLRecordServiceNotificationsClass;

    function CreateFakeInstance: TInterfacedObject;

    function InternalInvoke(const aMethod: RawUTF8; const aParams: RawUTF8='';

      aResult: PRawUTF8=nil; aErrorMsg: PRawUTF8=nil; aClientDrivenID: PCardinal=nil;

      aServiceCustomAnswer: PServiceCustomAnswer=nil; aClient: TSQLRestClientURI=nil): boolean; virtual;

    // match TOnFakeInstanceInvoke callback signature

    function Invoke(const aMethod: TServiceMethod; const aParams: RawUTF8;

      aResult: PRawUTF8; aErrorMsg: PRawUTF8; aClientDrivenID: PCardinal;

      aServiceCustomAnswer: PServiceCustomAnswer): boolean;

    procedure NotifyInstanceDestroyed(aClientDrivenID: cardinal); virtual;

  public

    /// initialize the service provider parameters

    // - it will check and retrieve all methods of the supplied interface,

    // and prepare all internal structures for its serialized execution

    // - also set the inherited TServiceInstanceImplementation property

    // - initialize fSharedInstance if aInstanceCreation is sicShared

    // - it will also ensure that the corresponding TServiceFactory.Contract

    // matches on both client and server sides, either by comparing the default

    // signature (based on methods and arguments), either by using the supplied

    // expected contract (which may be a custom version number)

    constructor Create(aRest: TSQLRest; aInterface: PTypeInfo;

      aInstanceCreation: TServiceInstanceImplementation;

      const aContractExpected: RawUTF8='');

    /// finalize the service provider used instance

    // - e.g. the shared fake implementation instance

    destructor Destroy; override;

    /// retrieve an instance of this interface from the client side

    function Get(out Obj): Boolean; override;

    /// retrieve the published signature of this interface

    // - TServiceFactoryClient will be able to retrieve it only if

    // TServiceContainerServer.PublishSignature is set to TRUE (which is not the

    // default setting, for security reasons) - this function is always available

    // on TServiceFactoryServer side

    function RetrieveSignature: RawUTF8; override;

    /// convert a HTTP error from mORMot's REST/SOA into an English text message

    // - would recognize the HTML_UNAVAILABLE, HTML_NOTIMPLEMENTED,

    // HTML_NOTALLOWED, HTML_UNAUTHORIZED or HTML_NOTACCEPTABLE errors, as

    // generated by the TSQLRestServer side

    // - is used by TServiceFactoryClient.InternalInvoke, but may be called

    // on client side for TServiceCustomAnswer.Status <> HTML_SUCCESS 

    class function GetErrorMessage(status: integer): RawUTF8;

    /// define execution options for a given set of methods

    // - methods names should be specified as an array (e.g. ['Add','Multiply'])

    // - if no method name is given (i.e. []), option will be set for all methods

    // - only supports optNoLogInput and optNoLogOutput on the client side

    procedure SetOptions(const aMethod: array of RawUTF8; aOptions: TServiceMethodOptions);

    /// persist all service calls into a database instead of calling the client 

    // - expect a REST instance, which would store all methods without any

    // results (i.e. procedure without any var/out parameters) on the

    // associated TSQLRecordServiceNotifications class

    // - once set, regular fClient.URI() won't be called but a new aLogClass

    // entry would be stored in aRest

    // - to disable this redirection, set aRest and aLogClass to nil

    procedure StoreNotifications(aRest: TSQLRest;

      aLogClass: TSQLRecordServiceNotificationsClass);

    /// allow background process of method with no results, via a temporary

    // database, to be used e.g. for safe notifications transmission

    // - would call StoreNotifications() and start background notification

    // - expect a REST instance, which would store all methods without any

    // results (i.e. procedure without any var/out parameters) on the

    // associated TSQLRecordServiceNotifications class

    // - a background thread would be used to check for pending notifications,

    // and send them to the supplied aRemote TSQLRestClient instance, or

    // to the main TServiceFactoryClient.fClient instance 

    // - if the remote client is not reachable, will retry after the specified

    // period of time, in seconds

    // - this method is not blocking, and would write the pending calls to

    // the aRest/aLogClass table, which would be retrieved asynchronously

    // by the background thread

    procedure SendNotifications(aRest: TSQLRest;

      aLogClass: TSQLRecordServiceNotificationsClass; aRetryPeriodSeconds: Integer=30;

      aRemote: TSQLRestClientURI=nil);

    /// compute how many pending notifications are waiting for background process

    // initiated by SendNotifications() method

    function SendNotificationsPending: integer;

    /// wait for all pending notifications to be sent

    // - you can supply a time out period after which no wait would take place

    procedure SendNotificationsWait(aTimeOutSeconds: integer);

  published

    /// could be used to force the remote URI to access the service

    // - by default, the URI would be Root/Calculator or Root/InterfaceMangledURI

    // but you may use this property to use another value, e.g. if you are

    // accessign a non mORMot REST server (probably with aContractExpected set

    // to SERVICE_CONTRACT_NONE_EXPECTED, and running

    // Client.ServerTimeStamp := TimeLogNowUTC to avoid an unsupported

    // ServerTimeStampSynchronize call)

    property ForcedURI: RawUTF8 read fForcedURI write fForcedURI;

    /// set to TRUE to send the interface's methods parameters as JSON object

    // - by default (FALSE), any method execution will send a JSON array with

    // all CONST/VAR parameters, in order

    // - TRUE will generate a JSON object instead, with the CONST/VAR parameter

    // names as field names - may be useful e.g. when working with a non

    // mORMot server

    property ParamsAsJSONObject: boolean read fParamsAsJSONObject write fParamsAsJSONObject;

    /// set to TRUE to expect the interface's methods result to be a JSON object

    // without the {"result":... } nesting

    // - by default (FALSE), any method execution will return a JSON array with

    // all VAR/OUT parameters, within a {"result":...,id:...} layout

    // - TRUE will expect a simple JSON object instead, with the VAR/OUT parameter

    // names as field names (and "Result" for any function result) - may be

    // useful e.g. when working with JavaScript clients

    // - this value can be overridden by setting ForceServiceResultAsJSONObject

    // for a given TSQLRestServerURIContext (e.g. for server-side JavaScript work)

    property ResultAsJSONObjectWithoutResult: boolean read fResultAsJSONObject

      write fResultAsJSONObject;

  end;



  /// used to lookup one method in a global list of interface-based services

  TServiceContainerInterfaceMethod = record

    /// one 'service.method' item, as set at URI

    // - e.g.'Calculator.Add','Calculator.Multiply'...

    InterfaceDotMethodName: RawUTF8;

    /// the associated service provider

    InterfaceService: TServiceFactory;

    /// the index of the method for the given service

    // - 0..2 indicates _free_/_contract_/_signature_ pseudo-methods

    // - then points to InterfaceService.Interface.Methods[InterfaceMethodIndex-3]

    InterfaceMethodIndex: integer;

  end;



  /// pointer to one method lookup in a global list of interface-based services

  PServiceContainerInterfaceMethod = ^TServiceContainerInterfaceMethod;



  /// used to store all methods in a global list of interface-based services

  TServiceContainerInterfaceMethods = array of TServiceContainerInterfaceMethod;



  /// used in TServiceContainer to identify fListInterfaceMethod[] entries

  TServiceContainerInterfaceMethodBits = set of 0..255;



  /// a global services provider class

  // - used to maintain a list of interfaces implementation

  // - inherits from TInterfaceResolverInjected and its Resolve() methods,

  // compatible with TInjectableObject

  TServiceContainer = class(TInterfaceResolverInjected)

  protected

    fRest: TSQLRest;

    // list of service names ['Calculator',...]

    // - Objects[] = TServiceFactory instance

    fList: TRawUTF8ListHashed;

    // list of service.method ['Calculator.Add','Calculator.Multiply',...]

    fListInterfaceMethod: TServiceContainerInterfaceMethods;

    fListInterfaceMethods: TDynArrayHashed;

    fExpectMangledURI: boolean;

    procedure SetExpectMangledURI(aValue: Boolean);

    procedure SetInterfaceMethodBits(MethodNamesCSV: PUTF8Char;

      IncludePseudoMethods: boolean; out bits: TServiceContainerInterfaceMethodBits);

    function GetMethodName(ListInterfaceMethodIndex: integer): RawUTF8;

    procedure CheckInterface(const aInterfaces: array of PTypeInfo);

    function AddServiceInternal(aService: TServiceFactory): integer;

    function TryResolve(aInterface: PTypeInfo; out Obj): boolean; override;

    /// retrieve a service provider from its URI

    function GetService(const aURI: RawUTF8): TServiceFactory;

  public

    /// initialize the list

    constructor Create(aRest: TSQLRest);

    /// release all registered services

    destructor Destroy; override;

    /// release all services of a TSQLRest instance before shutdown

    // - would allow to properly release any pending callbacks

    // - TSQLRest.Services.Release would call FreeAndNil(fServices)

    procedure Release;

    /// return the number of registered service interfaces

    function Count: integer;

    /// method called on the client side to register a service via its interface(s)

    // - will add a TServiceFactoryClient instance to the internal list

    // - is called e.g. by TSQLRestClientURI.ServiceRegister or even by

    // TSQLRestServer.ServiceRegister(aClient: TSQLRest...) for a remote access -

    // use TServiceContainerServer.AddImplementation() instead for normal

    // server side implementation

    // - will raise an exception on error

    // - will return true if some interfaces have been added

    // - will check for the availability of the interfaces on the server side,

    // with an optional custom contract to be used instead of methods signature

    // (only for the first interface)

    function AddInterface(const aInterfaces: array of PTypeInfo;

      aInstanceCreation: TServiceInstanceImplementation;

      aContractExpected: RawUTF8=''): boolean; overload;

    /// method called on the client side to register a service via one interface

    // - overloaded method returning the corresponding service factory client,

    // or nil on error

    function AddInterface(aInterface: PTypeInfo;

      aInstanceCreation: TServiceInstanceImplementation;

      const aContractExpected: RawUTF8=''): TServiceFactoryClient; overload;

    /// retrieve a service provider from its index in the list

    // - returns nil if out of range index

    function Index(aIndex: integer): TServiceFactory; overload;

      {$ifdef HASINLINE}inline;{$endif}

    /// retrieve a service provider from its GUID / Interface type

    // - you shall have registered the interface by a previous call to

    // ! TInterfaceFactory.RegisterInterfaces([TypeInfo(IMyInterface),...])

    // - on match, it will return the service the corresponding interface factory

    // - returns nil if the GUID does not match any registered interface

    // - can be used as such to resolve an I: ICalculator interface

    // ! if fClient.Services.Info(ICalculator).Get(I) then

    // !   ... use I

    function Info(const aGUID: TGUID): TServiceFactory; overload;

    /// retrieve a service provider from its type information

    // - on match, it  will return the service the corresponding interface factory

    // - returns nil if the type information does not match any registered interface

    // - can be used as such to resolve an I: ICalculator interface

    // ! if fClient.Services.Info(TypeInfo(ICalculator)).Get(I) then

    // !   ... use I

    // - is defined as virtual so that e.g. TServiceContainerClient would

    // automatically register the interface, if it was not already done

    function Info(aTypeInfo: PTypeInfo): TServiceFactory; overload; virtual;

    /// notify the other side that the given Callback event interface is released

    // - this default implementation will do nothing

    function CallBackUnRegister(const Callback: IInvokable): boolean; virtual;

    /// retrieve all registered Services TGUID 

    procedure SetGUIDs(out Services: TGUIDDynArray);

    /// retrieve all registered Services names

    // - i.e. all interface names without the initial 'I', e.g. 'Calculator' for

    // ICalculator 

    procedure SetInterfaceNames(out Names: TRawUTF8DynArray);

    /// retrieve all registered Services contracts as a JSON array

    // - i.e. a JSON array of TServiceFactory.Contract JSON objects

    function AsJson: RawJSON;

    /// retrieve a service provider from its URI

    // - it expects the supplied URI variable  to be e.g. '00amyWGct0y_ze4lIsj2Mw'

    // or 'Calculator', depending on the ExpectMangledURI property

    // - on match, it  will return the service the corresponding interface factory

    // - returns nil if the URI does not match any registered interface

    property Services[const aURI: RawUTF8]: TServiceFactory read GetService; default;

    /// the associated RESTful instance

    property Rest: TSQLRest read fRest;

    /// set if the URI is expected to be mangled from the GUID

    // - by default (FALSE), the clear service name is expected to be supplied at

    // the URI level (e.g. 'Calculator')

    // - if this property is set to TRUE, the mangled URI value will be expected

    // instead (may enhance security) - e.g. '00amyWGct0y_ze4lIsj2Mw'

    property ExpectMangledURI: boolean read fExpectMangledURI write SetExpectMangledURI;

  end;



  /// a callback interface used to notify a TSQLRecord modification in real time

  // - will be used e.g. by TSQLRestServer.RecordVersionSynchronizeSubscribeMaster()

  // - all methods of this interface will be called asynchronously when

  // transmitted via our WebSockets implementation, since they are defined as

  // plain procedures

  // - each callback instance should be private to a specific TSQLRecord

  IServiceRecordVersionCallback = interface(IInvokable)

    ['{8598E6BE-3590-4F76-9449-7AF7AF4241B0}']

    /// this event will be raised on any Add on a versioned record

    // - the supplied JSON object will contain the TRecordVersion field

    procedure Added(const NewContent: RawJSON);

    /// this event will be raised on any Update on a versioned record

    // - the supplied JSON object will contain the TRecordVersion field

    procedure Updated(const ModifiedContent: RawJSON);

    /// this event will be raised on any Delete on a versioned record

    procedure Deleted(const ID: TID; const Revision: TRecordVersion);

    /// allow to optimize process for WebSockets "jumbo frame" items

    // - this method may be called with isLast=false before the first method

    // call of this interface, then with isLast=true after the call of the

    // last method of the "jumbo frame"

    // - match TInterfaceFactory.MethodIndexCurrentFrameCallback signature

    // - allow e.g. to create a temporary TSQLRestBatch for jumbo frames

    // - if individual frames are received, this method won't be called

    procedure CurrentFrame(isLast: boolean);

  end;



  /// a list of callback interfaces to notify TSQLRecord modifications

  // - you can use InterfaceArray*() wrapper functions to manage the list

  IServiceRecordVersionCallbackDynArray = array of IServiceRecordVersionCallback;



  /// service definition for master/slave replication notifications subscribe

  // - implemented by TServiceRecordVersion, as used by

  // TSQLRestServer.RecordVersionSynchronizeMasterStart(), and expected by

  // TSQLRestServer.RecordVersionSynchronizeSlaveStart()

  IServiceRecordVersion = interface(IInvokable)

    ['{06A355CA-19EB-4CC6-9D87-7B48967D1D9F}']

    /// will register the supplied callback for the given table

    function Subscribe(const SQLTableName: RawUTF8; const revision: TRecordVersion;

      const callback: IServiceRecordVersionCallback): boolean;

  end;



  /// service definition with a method which will be called when a callback

  // interface instance is released on the client side

  // - may be used to implement safe publish/subscribe mechanism using

  // interface callbacks, e.g. over WebSockets

  IServiceWithCallbackReleased = interface(IInvokable)

    ['{8D518FCB-62C3-42EB-9AE7-96ED322140F7}']

    /// will be called when a callback is released on the client side

    // - this method matches the TInterfaceFactory.MethodIndexCallbackReleased

    // signature, so that it would be called with the interface instance by

    // TServiceContainerServer.FakeCallbackRelease

    // - you may use it as such - see sample Project31ChatServer.dpr:

    // ! procedure TChatService.CallbackReleased(const callback: IInvokable;

    // !   const interfaceName: RawUTF8);

    // ! begin  // unsubscribe from fConnected: array of IChatCallback

    // !   if interfaceName='IChatCallback' then

    // !     InterfaceArrayDelete(fConnected,callback);

    // ! end;

    procedure CallbackReleased(const callback: IInvokable; const interfaceName: RawUTF8);

  end;



  /// event signature triggerred when a callback instance is released

  // - used by TServiceContainerServer.OnCallbackReleasedOnClientSide

  // and TServiceContainerServer.OnCallbackReleasedOnServerSide event properties

  // - the supplied Instance will be a TInterfacedObjectFakeServer, and the

  // Callback would be a pointer to the corresponding interface value

  // - assigned implementation should be as fast a possible, since this event

  // will be executed in a global lock for all server-side callbacks

  TOnCallbackReleased = procedure(Sender: TServiceContainer;

    Instance: TInterfacedObject; Callback: pointer) of object;



  /// how TServiceContainerServer would handle SOA callbacks

  // - by default, a callback released on the client side will log a warning

  // and continue the execution (relying e.g. on a CallbackReleased() method to

  // unsubscribe the event), but coRaiseExceptionIfReleasedByClient can be

  // defined to raise an EInterfaceFactoryException in this case

  TServiceCallbackOptions = set of (

    coRaiseExceptionIfReleasedByClient);



  /// a services provider class to be used on the server side

  // - this will maintain a list of true implementation classes

  TServiceContainerServer = class(TServiceContainer)

  protected

    fPublishSignature: boolean;

    fConnectionID: Int64;

    fFakeCallbacks: TObjectListLocked; // TInterfacedObjectFakeServer instances

    fOnCallbackReleasedOnClientSide: TOnCallbackReleased;

    fOnCallbackReleasedOnServerSide: TOnCallbackReleased;

    fCallbackOptions: TServiceCallbackOptions;

    fRecordVersionCallback: array of IServiceRecordVersionCallbackDynArray;

    /// make some garbage collection when session is finished

    procedure OnCloseSession(aSessionID: cardinal); virtual;

    procedure FakeCallbackAdd(aFakeInstance: TObject);

    procedure FakeCallbackRemove(aFakeInstance: TObject);

    procedure FakeCallbackRelease(Ctxt: TSQLRestServerURIContext);

    procedure RecordVersionCallbackNotify(TableIndex: integer;

      Occasion: TSQLOccasion; const DeletedID: TID;

      const DeletedRevision: TRecordVersion; const AddUpdateJson: RawUTF8);

  public

    /// class method able to check if a given server-side callback event fake

    // instance has been released on the client side

    // - may be used to automatically purge a list of subscribed callbacks,

    // e.g. before trigerring the interface instance, and avoid an exception

    class function CallbackReleasedOnClientSide(const callback: IInterface): boolean;

    /// method called on the server side to register a service via its

    // interface(s) and a specified implementation class or a shared

    // instance (for sicShared mode)

    // - will add a TServiceFactoryServer instance to the internal list

    // - will raise an exception on error

    // - will return the first of the registered TServiceFactoryServer created

    // on success (i.e. the one corresponding to the first item of the aInterfaces

    // array), or nil if registration failed (e.g. if any of the supplied interfaces

    // is not implemented by the given class)

    // - the same implementation class can be used to handle several interfaces

    // (just as Delphi allows to do natively)

    function AddImplementation(aImplementationClass: TInterfacedClass;

      const aInterfaces: array of PTypeInfo;

      aInstanceCreation: TServiceInstanceImplementation;

      aSharedImplementation: TInterfacedObject; const aContractExpected: RawUTF8): TServiceFactoryServer;

    /// finalize the service container

    destructor Destroy; override;

    /// register a callback interface which will be called each time a write

    // operation is performed on a given TSQLRecord with a TRecordVersion field

    // - called e.g. by TSQLRestServer.RecordVersionSynchronizeSubscribeMaster

    function RecordVersionSynchronizeSubscribeMaster(TableIndex: integer;

      RecordVersion: TRecordVersion; const SlaveCallback: IServiceRecordVersionCallback): boolean;

    /// notify any TRecordVersion callback for a table Add/Update from a

    // TDocVariant content

    // - used e.g. by TSQLRestStorageMongoDB.DocFromJSON()

    procedure RecordVersionNotifyAddUpdate(Occasion: TSQLOccasion;

      TableIndex: integer; const Document: TDocVariantData); overload;

    /// notify any TRecordVersion callback for a table Add/Update from a

    // TJSONObjectDecoder content

    // - used e.g. by TSQLRestStorageMongoDB.DocFromJSON()

    procedure RecordVersionNotifyAddUpdate(Occasion: TSQLOccasion;

      TableIndex: integer; const Decoder: TJSONObjectDecoder); overload;

    /// notify any TRecordVersion callback for a table Delete

    procedure RecordVersionNotifyDelete(TableIndex: integer;

      const ID: TID; const Revision: TRecordVersion);

    /// log method execution information to a TSQLRecordServiceLog table

    // - TServiceFactoryServer.SetServiceLog() will be called for all registered

    // interfaced-based services of this container

    // - will write to the specified aLogRest instance, and would disable

    // writing if aLogRest is nil

    // - will write to a (inherited) TSQLRecordServiceLog table, as available in

    // TSQLRest's model, unless a dedicated table is specified as aLogClass

    // - you could specify a CSV list of method names to be excluded from logging

    // (containing e.g. a password or a credit card number), containing either

    // the interface name (as 'ICalculator.Add'), or not (as 'Add')

    procedure SetServiceLog(aLogRest: TSQLRest; aLogClass: TSQLRecordServiceLogClass=nil;

      const aExcludedMethodNamesCSV: RawUTF8='');

    /// defines if the "method":"_signature_" or /root/Interface._signature

    // pseudo method is available to retrieve the whole interface signature,

    // encoded as a JSON object

    // - is set to FALSE by default, for security reasons: only "_contract_"

    // pseudo method is available - see TServiceContainer.ContractExpected

    property PublishSignature: boolean read fPublishSignature write fPublishSignature;

    /// this event will be launched when a callback interface is notified as

    // relased on the Client side

    // - as an alternative, you may define the following method on the

    // registration service interface type, which would be called when a

    // callback registered via this service is released (e.g. to unsubscribe

    // the callback from an interface list, via InterfaceArrayDelete):

    // ! procedure CallbackReleased(const callback: IInvokable; const interfaceName: RawUTF8);

    property OnCallbackReleasedOnClientSide: TOnCallbackReleased

      read fOnCallbackReleasedOnClientSide;

    /// this event will be launched when a callback interface is relased on

    // the Server side

    property OnCallbackReleasedOnServerSide: TOnCallbackReleased

      read fOnCallbackReleasedOnServerSide;

    /// defines how SOA callbacks will be handled

    property CallbackOptions: TServiceCallbackOptions read fCallbackOptions

      write fCallbackOptions;

  end;



  /// this class implements a service, which may be called to push notifications

  // for master/slave replication

  // - as used by TSQLRestServer.RecordVersionSynchronizeMasterStart(), and

  // expected by TSQLRestServer.RecordVersionSynchronizeSlaveStart()

  TServiceRecordVersion = class(TInjectableObjectRest,IServiceRecordVersion)

  public

    /// will register the supplied callback for the given table

    function Subscribe(const SQLTableName: RawUTF8; const revision: TRecordVersion;

      const callback: IServiceRecordVersionCallback): boolean;

   end;



  /// a services provider class to be used on the client side

  // - this will maintain a list of fake implementation classes, which will

  // remotely call the server to make the actual process

  TServiceContainerClient = class(TServiceContainer)

  protected

    fDisableAutoRegisterAsClientDriven: boolean;

  public

    /// retrieve a service provider from its type information

    // - this overridden method will register the interface, if was not yet made

    // - in this case, the interface will be registered with sicClientDriven

    // implementation method, unless DisableAutoRegisterAsClientDriven is TRUE

    function Info(aTypeInfo: PTypeInfo): TServiceFactory; overload; override;

    /// notify the other side that the given Callback event interface is released

    // - this overriden implementation will check the private fFakeCallbacks list

    function CallBackUnRegister(const Callback: IInvokable): boolean; override;

    /// allow to disable the automatic registration as sicClientDriven in Info()

    property DisableAutoRegisterAsClientDriven: boolean

      read fDisableAutoRegisterAsClientDriven write fDisableAutoRegisterAsClientDriven;

  end;



  /// TInterfacedObject class which would notify a REST server when it is released

  // - could be used when implementing event callbacks as interfaces, so that

  // the other side instance would be notified when it is destroyed

  TInterfacedCallback = class(TInterfacedObjectLocked)

  protected

    fRest: TSQLRest;

    fInterface: TGUID;

  public

    /// initialize the instance for a given REST and callback interface

    constructor Create(aRest: TSQLRest; const aGUID: TGUID); reintroduce;

    /// notify the associated TSQLRestServer that the callback is disconnnected

    // - i.e. will call TSQLRestServer's TServiceContainer.CallBackUnRegister()

    // - this method will process the unsubscription only once, and

    procedure CallbackRestUnregister; virtual;

    /// finalize the instance, and notify the TSQLRestServer that the callback

    // is now unreachable

    // - i.e. will call CallbackRestUnregister

    destructor Destroy; override;

    /// the associated TSQLRestServer instance, which would be notified

    // when the callback is released

    property Rest: TSQLRest read fRest;

    /// the interface type, implemented by this callback class

    property RestInterface: TGUID read fInterface write fInterface;

  end;



  /// asynchrounous callback to emulate a synchronous/blocking process

  // - once created, process would block via a WaitFor call, which would be

  // released when CallbackFinished() is called by the process background thread

  TBlockingCallback = class(TInterfacedCallback)

  protected

    fProcess: TBlockingProcess;

    function GetEvent: TBlockingEvent;

  public

    /// initialize the callback 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)

    // - you can optionally set a REST and callback interface for automatic

    // notification when this TInterfacedCallback would be released

    constructor Create(aTimeOutMs: integer;

      aRest: TSQLRest; const aGUID: TGUID); reintroduce;

    /// finalize the callback instance

    destructor Destroy; override;

    /// called to wait for the callback to be processed, or trigger timeout

    // - would block until CallbackFinished() is called by the processing thread

    // - returns the final state of the process, i.e. beRaised or beTimeOut

    function WaitFor: TBlockingEvent; virtual;

    /// should be called by the callback when the process is finished

    // - the caller would then let its WaitFor method return

    // - if aServerUnregister is TRUE, will also call CallbackRestUnregister to

    // notify the server that the callback is no longer needed

    // - would optionally log all published properties values to the log class

    // of the supplied REST instance

    procedure CallbackFinished(aRestForLog: TSQLRest;

      aServerUnregister: boolean=false); virtual;

    /// just a wrapper to reset the internal Event state to evNone

    // - may be used to re-use the same TBlockingCallback instance, after

    // a successfull WaitFor/CallbackFinished process

    // - returns TRUE on success (i.e. status was not beWaiting)

    // - if there is a WaitFor currently in progress, returns FALSE

    function Reset: boolean; virtual;

    /// the associated blocking process instance

    property Process: TBlockingProcess read fProcess;

  published

    /// the current state of process

    // - just a wrapper around Process.Event

    // - use Reset method to re-use this instance after a WaitFor process

    property Event: TBlockingEvent read GetEvent;

  end;



  /// this class implements a callback interface, able to write all remote ORM

  // notifications to the local DB

  // - could be supplied as callback parameter, possibly via WebSockets

  // transmission, to TSQLRestServer.RecordVersionSynchronizeSubscribeMaster()

  TServiceRecordVersionCallback = class(TInterfacedCallback,IServiceRecordVersionCallback)

  protected

    fTable: TSQLRecordClass;

    fRecordVersionField: TSQLPropInfoRTTIRecordVersion;

    fBatch: TSQLRestBatch;

    fSlave: TSQLRestServer; // fRest is master remote access

    fOnNotify: TOnBatchWrite;

    // local TSQLRecordTableDeleted.ID follows current Model -> pre-compute offset

    fTableDeletedIDOffset: Int64;

    procedure SetCurrentRevision(const Revision: TRecordVersion; Event: TSQLOccasion);

  public

    /// initialize the instance able to apply callbacks for a given table on

    // a local slave REST server from a remote master REST server

    // - the optional low-level aOnNotify callback will be triggerred for each

    // incoming notification, to track the object changes in real-time

    constructor Create(aSlave: TSQLRestServer; aMaster: TSQLRestClientURI;

      aTable: TSQLRecordClass; aOnNotify: TOnBatchWrite); reintroduce;

    /// finalize this callback instance

    destructor Destroy; override;

    /// this event will be raised on any Add on a versioned record

    procedure Added(const NewContent: RawJSON); virtual;

    /// this event will be raised on any Update on a versioned record

    procedure Updated(const ModifiedContent: RawJSON); virtual;

    /// this event will be raised on any Delete on a versioned record

    procedure Deleted(const ID: TID; const Revision: TRecordVersion); virtual;

    /// match TInterfaceFactory.MethodIndexCurrentFrameCallback signature,

    // so that TSQLHttpClientWebsockets.CallbackRequest will call it

    // - it will create a temporary TSQLRestBatch for the whole "jumbo frame"

    procedure CurrentFrame(isLast: boolean); virtual;

    /// low-level event handler triggerred by Added/Updated/Deleted methods

    property OnNotify: TOnBatchWrite read fOnNotify write fOnNotify;

  end;



  /// for TSQLRestCache, stores a table values

  TSQLRestCacheEntryValue = packed record

    /// corresponding ID

    ID: TID;

    /// JSON encoded UTF-8 serialization of the record

    JSON: RawUTF8;

    /// GetTickCount64() value when this cached value was stored

    // - equals 0 when there is no JSON value cached

    TimeStamp64: Int64;

  end;



  /// for TSQLRestCache, stores all tables values

  TSQLRestCacheEntryValueDynArray = array of TSQLRestCacheEntryValue;



  /// for TSQLRestCache, stores a table settings and values

  TSQLRestCacheEntry = {$ifndef ISDELPHI2010}object{$else}record{$endif}

  public

    /// TRUE if this table should use caching

    // - i.e. if was not set, or worth it for this table (e.g. in-memory table)

    CacheEnable: boolean;

    /// the whole specified Table content will be cached

    CacheAll: boolean;

    /// time out value (in ms)

    // - if 0, caching will never expire

    TimeOutMS: Cardinal;

    /// the number of entries stored in Values[]

    Count: integer;

    /// all cached IDs and JSON content

    Values: TSQLRestCacheEntryValueDynArray;

    /// TDynArray wrapper around the Values[] array

    Value: TDynArray;

    /// used to lock the table cache for multi thread safety

    Mutex: TSynLocker;

    /// initialize this table cache

    // - will set Value wrapper and Mutex handle - other fields should have

    // been cleared by caller (is the case for a TSQLRestCacheEntryDynArray)

    procedure Init;

    /// reset all settings corresponding to this table cache

    procedure Clear;

    /// finalize this table cache entry

    procedure Done;

    /// flush cache for a given Value[] index

    procedure FlushCacheEntry(Index: Integer);

    /// flush cache for all Value[]

    procedure FlushCacheAllEntries;

    /// add the supplied ID to the Value[] array

    procedure SetCache(aID: TID);

    /// update/refresh the cached JSON serialization of a given ID

    procedure SetJSON(aID: TID; const aJSON: RawUTF8); overload;

    /// update/refresh the cached JSON serialization of a supplied Record

    procedure SetJSON(aRecord: TSQLRecord); overload;

    /// retrieve a JSON serialization of a given ID from cache

    function RetrieveJSON(aID: TID; var aJSON: RawUTF8): boolean; overload;

    /// unserialize a JSON cached record of a given ID

    function RetrieveJSON(aID: TID; aValue: TSQLRecord): boolean; overload;

  end;



  /// for TSQLRestCache, stores all table settings and values

  // - this dynamic array will follow TSQLRest.Model.Tables[] layout, i.e. one

  // entry per TSQLRecord class in the data model

  TSQLRestCacheEntryDynArray = array of TSQLRestCacheEntry;



  /// implement a fast TSQLRecord cache, per ID, at the TSQLRest level

  // - purpose of this caching mechanism is to speed up retrieval of some common

  // values at either Client or Server level (like configuration settings)

  // - only caching synchronization is about the following RESTful basic commands:

  // RETRIEVE, ADD, DELETION and UPDATE (that is, a complex direct SQL UPDATE

  // or via TSQLRecordMany pattern won't be taken in account)

  // - only Simple fields are cached: e.g. the BLOB fields are not stored

  // - this cache is thread-safe (access is locked per table)

  // - this caching will be located at the TSQLRest level, that is no automated

  // synchronization is implemented between TSQLRestClient and TSQLRestServer:

  // you shall ensure that your code won't fail due to this restriction

  TSQLRestCache = class

  protected

    fRest: TSQLRest;

    /// fCache[] follows fRest.Model.Tables[] array: one entry per TSQLRecord

    fCache: TSQLRestCacheEntryDynArray;

    /// retrieve a record specified by its ID from cache into JSON content

    // - return '' if the item is not in cache

    function Retrieve(aTableIndex, aID: TID): RawUTF8; overload;

    /// fill a record specified by its ID from cache into a new TSQLRecord instance

    // - return false if the item is not in cache

    // - this method will call RetrieveJSON method, unserializing the cached

    // JSON content into the supplied aValue instance

    function Retrieve(aID: TID; aValue: TSQLRecord): boolean; overload;

  public

    /// create a cache instance

    // - the associated TSQLModel will be used internaly

    constructor Create(aRest: TSQLRest); reintroduce;

    /// release the cache instance

    destructor Destroy; override;

    /// flush the cache

    // - this will flush all stored JSON content, but keep the settings

    // (SetCache/SetTimeOut) as before

    procedure Flush; overload;

    /// flush the cache for a given table

    // - this will flush all stored JSON content, but keep the settings

    // (SetCache/SetTimeOut) as before for this table

    procedure Flush(aTable: TSQLRecordClass); overload;

    /// flush the cache for a given record

    // - this will flush the stored JSON content for this record (and table

    // settings will be kept)

    procedure Flush(aTable: TSQLRecordClass; aID: TID); overload;

    /// flush the cache for a set of specified records

    // - this will flush the stored JSON content for these record (and table

    // settings will be kept)

    procedure Flush(aTable: TSQLRecordClass; const aIDs: array of TID); overload;

    /// flush the cache, and destroy all settings

    // - this will flush all stored JSON content, AND destroy the settings

    // (SetCache/SetTimeOut) to default (i.e. no cache enabled)

    procedure Clear;

    /// activate the internal caching for a whole Table

    // - any cached item of this table will be flushed

    // - return true on success

    function SetCache(aTable: TSQLRecordClass): boolean; overload;

    /// activate the internal caching for a given TSQLRecord

    // - if this item is already cached, do nothing

    // - return true on success

    function SetCache(aTable: TSQLRecordClass; aID: TID): boolean; overload;

    /// activate the internal caching for a set of specified TSQLRecord

    // - if these items are already cached, do nothing

    // - return true on success

    function SetCache(aTable: TSQLRecordClass; const aIDs: array of TID): boolean; overload;

    /// activate the internal caching for a given TSQLRecord

    // - will cache the specified aRecord.ID item

    // - if this item is already cached, do nothing

    // - return true on success

    function SetCache(aRecord: TSQLRecord): boolean; overload;

    /// set the internal caching time out delay (in ms) for a given table

    // - time out setting is common to all items of the table

    // - if aTimeOut is left to its default 0 value, caching will never expire

    // - return true on success

    function SetTimeOut(aTable: TSQLRecordClass; aTimeoutMS: cardinal): boolean;

    /// returns TRUE if the table is part of the current caching policy

    function IsCached(aTable: TSQLRecordClass): boolean;

    /// returns the number of JSON serialization records within this cache

    function CachedEntries: cardinal;

    /// returns the memory used by JSON serialization records within this cache

    // - this method will also flush any outdated entries in the cache

    function CachedMemory(FlushedEntriesCount: PInteger=nil): cardinal;

    /// read-only access to the associated TSQLRest instance

    property Rest: TSQLRest read fRest;

  public { TSQLRest low level methods which are not to be called usualy: }

    /// TSQLRest instance shall call this method when a record is added or updated

    // - this overloaded method expects the content to be specified as JSON object

    procedure Notify(aTable: TSQLRecordClass; aID: TID; const aJSON: RawUTF8;

     aAction: TSQLOccasion); overload;

    /// TSQLRest instance shall call this method when a record is retrieved,

    // added or updated

    // - this overloaded method expects the content to be specified as JSON object,

    // and TSQLRecordClass to be specified as its index in Rest.Model.Tables[]

    procedure Notify(aTableIndex: integer; aID: TID; const aJSON: RawUTF8;

      aAction: TSQLOccasion); overload;

    /// TSQLRest instance shall call this method when a record is added or updated

    // - this overloaded method will call the other Trace method, serializing

    // the supplied aRecord content as JSON (not in the case of seDelete)

    procedure Notify(aRecord: TSQLRecord; aAction: TSQLOccasion); overload;

    /// TSQLRest instance shall call this method when a record is deleted

    // - this method is dedicated for a record deletion

    procedure NotifyDeletion(aTable: TSQLRecordClass; aID: TID); overload;

    /// TSQLRest instance shall call this method when a record is deleted

    // - this method is dedicated for a record deletion

    // - TSQLRecordClass to be specified as its index in Rest.Model.Tables[]

    procedure NotifyDeletion(aTableIndex, aID: TID); overload;

  end;



  /// how a TSQLRest class may execute read or write operations

  // - used e.g. for TSQLRestServer.AcquireWriteMode or

  // TSQLRestServer.AcquireExecutionMode/AcquireExecutionLockedTimeOut

  TSQLRestServerAcquireMode = (

    amUnlocked, amLocked, amBackgroundThread, amBackgroundORMSharedThread

    {$ifndef LVCL}, amMainThread{$endif});



  /// class-reference type (metaclass) of a TSQLRest kind

  TSQLRestClass = class of TSQLRest;



  /// a dynamic array of TSQLRest instances

  TSQLRestDynArray = array of TSQLRest;



  /// a dynamic array of TSQLRest instances, owniing the instances

  TSQLRestObjArray = array of TSQLRest;



  /// used to store the execution parameters for a TSQLRest instance

  TSQLRestAcquireExecution = class(TSynPersistentLocked)

  public

    /// how read or write operations will be executed

    Mode: TSQLRestServerAcquireMode;

    /// delay before failing to acquire the lock

    LockedTimeOut: cardinal;

    /// background thread instance (if any)

    Thread: TSynBackgroundThreadMethod;

    /// finalize the memory structure, and the associated background thread

    destructor Destroy; override;

  end;



  /// a generic REpresentational State Transfer (REST) client/server class

  TSQLRest = class

  protected

    fModel: TSQLModel;

    fCache: TSQLRestCache;

    fTransactionActiveSession: cardinal;

    fTransactionTable: TSQLRecordClass;

    fServerTimeStampOffset: TDateTime;

    fServerTimeStampCacheTix: cardinal;

    fServerTimeStampCacheValue: TTimeLogBits;

    fServices: TServiceContainer;

    fPrivateGarbageCollector: TObjectList;

    fRoutingClass: TSQLRestServerURIContextClass;

    fFrequencyTimeStamp: Int64;

    fAcquireExecution: array[TSQLRestServerURIContextCommand] of TSQLRestAcquireExecution;

    {$ifdef WITHLOG}

    fLogClass: TSynLogClass;   // =SQLite3Log by default

    fLogFamily: TSynLogFamily; // =SQLite3Log.Family by default

    procedure SetLogClass(aClass: TSynLogClass); virtual;

    function GetLogClass: TSynLogClass;

    {$endif}

    /// log the corresponding text (if logging is enabled)

    procedure InternalLog(const Text: RawUTF8; Level: TSynLogInfo); overload;

      {$ifdef HASINLINE}inline;{$endif}

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

      Level: TSynLogInfo); overload;

    /// internal method used by Delete(Table,SQLWhere) method

    function InternalDeleteNotifyAndGetIDs(Table: TSQLRecordClass; const SQLWhere: RawUTF8;

      var IDs: TIDDynArray): boolean;

    /// retrieve the server time stamp

    // - default implementation will use fServerTimeStampOffset to compute

    // the value from PC time (i.e. NowUTC+fServerTimeStampOffset as TTimeLog)

    // - inherited classes may override this method, or set the appropriate

    // value in fServerTimeStampOffset protected field

    function GetServerTimeStamp: TTimeLog; virtual;

    /// compute the server time stamp offset from the given

    procedure SetServerTimeStamp(const Value: TTimeLog);

    /// handle Client or Server side fast in-memory cache

    // - creates the internal fCache instance, if necessary

    function GetCache: TSQLRestCache;

      {$ifdef HASINLINE}inline;{$endif}

    /// returns TRUE if this table is worth caching (e.g. not in memory)

    // - this default implementation always returns TRUE (always allow cache)

    function CacheWorthItForTable(aTableIndex: cardinal): boolean; virtual;

    /// compute SELECT ... FROM TABLE WHERE ...

    function SQLComputeForSelect(Table: TSQLRecordClass;

      const FieldNames, WhereClause: RawUTF8): RawUTF8;

    /// wrapper method for RoutingClass property

    procedure SetRoutingClass(aServicesRouting: TSQLRestServerURIContextClass);

    /// wrapper methods to access fAcquireExecution[]

    function GetAcquireExecutionMode(Cmd: TSQLRestServerURIContextCommand): TSQLRestServerAcquireMode;

    procedure SetAcquireExecutionMode(Cmd: TSQLRestServerURIContextCommand; Value: TSQLRestServerAcquireMode);

    function GetAcquireExecutionLockedTimeOut(Cmd: TSQLRestServerURIContextCommand): cardinal;

    procedure SetAcquireExecutionLockedTimeOut(Cmd: TSQLRestServerURIContextCommand; Value: cardinal);

    /// internal method called by TSQLRestServer.Batch() to process fast sending

    // to remote database engine (e.g. Oracle bound arrays or MS SQL Bulk insert)

    // - returns TRUE if this method is handled by the engine, or FALSE if

    // individual calls to Engine*() are expected

    // - this default implementation returns FALSE

    // - an overridden method returning TRUE shall ensure that calls to

    // EngineAdd / EngineUpdate / EngineDelete (depending of supplied Method)

    // will properly handle operations until InternalBatchStop() is called

    function InternalBatchStart(Method: TSQLURIMethod;

      BatchOptions: TSQLRestBatchOptions): boolean; virtual;

    /// internal method called by TSQLRestServer.Batch() to process fast sending

    // to remote database engine (e.g. Oracle bound arrays or MS SQL Bulk insert)

    // - this default implementation will raise an EORMException (since

    // InternalBatchStart returns always FALSE at this TSQLRest level)

    // - InternalBatchStart/Stop may safely use a lock for multithreading:

    // implementation in TSQLRestServer.Batch use a try..finally block

    procedure InternalBatchStop; virtual;

    /// send/execute the supplied JSON BATCH content, and return the expected array

    // - this method will be implemented for TSQLRestClient and TSQLRestServer only

    // - this default implementation will trigger an EORMException

    function EngineBatchSend(Table: TSQLRecordClass; const Data: RawUTF8;

       var Results: TIDDynArray; ExpectedResultsCount: integer): integer; virtual;

    /// any overriden TSQLRest class should call it in the initialization section

    class procedure RegisterClassNameForDefinition;

    // inherited classes should unserialize the other aDefinition properties by

    // overriding this method, in a reverse logic to overriden DefinitionTo()

    constructor RegisteredClassCreateFrom(aModel: TSQLModel;

      aDefinition: TSynConnectionDefinition); virtual;

    /// used by Add() and AddWithBlobs() before EngineAdd()

    procedure GetJSONValuesForAdd(TableIndex: integer; Value: TSQLRecord;

      ForceID, DoNotAutoComputeFields, WithBlobs: boolean;

      CustomFields: PSQLFieldBits; var result: RawUTF8);

    /// used by all overloaded Add() methods

    function InternalAdd(Value: TSQLRecord; SendData: boolean; CustomFields: PSQLFieldBits;

      ForceID, DoNotAutoComputeFields: boolean): TID; virtual; 

   protected // these abstract methods must be overriden by real database engine

    /// retrieve a list of members as JSON encoded data

    // - implements REST GET collection

    // - returns '' on error, or JSON data, even with no result rows

    // - override this method for direct data retrieval from the database engine

    // and direct JSON export, avoiding a TSQLTable which allocates memory for every

    // field values before the JSON export

    // - can be called for a single Table (ModelRoot/Table), or with low level SQL

    // query (ModelRoot + SQL sent as request body)

    // - if ReturnedRowCount points to an integer variable, it must be filled with

    // the number of row data returned (excluding field names)

    // - this method must be implemented in a thread-safe manner

    function EngineList(const SQL: RawUTF8; ForceAJAX: Boolean=false;

      ReturnedRowCount: PPtrInt=nil): RawUTF8; virtual; abstract;

    /// Execute directly a SQL statement, without any result

    // - implements POST SQL on ModelRoot URI

    // - return true on success

    // - override this method for proper calling the database engine

    // - don't call this method in normal cases

    // - this method must be implemented to be thread-safe

    function EngineExecute(const aSQL: RawUTF8): boolean; virtual; abstract;

    /// get a member from its ID

    // - implements REST GET member

    // - returns the data of this object as JSON

    // - override this method for proper data retrieval from the database engine

    // - this method must be implemented in a thread-safe manner

    function EngineRetrieve(TableModelIndex: integer; ID: TID): RawUTF8; virtual; abstract;

    /// create a new member

    // - implements REST POST collection

    // - SentData can contain the JSON object with field values to be added

    // - class is taken from Model.Tables[TableModelIndex]

    // - returns the TSQLRecord ID/ROWID value, 0 on error

    // - if a "RowID":.. or "ID":.. member is set in SentData, it shall force

    // this value as insertion ID

    // - override this method for proper calling the database engine

    // - this method must be implemented in a thread-safe manner

    function EngineAdd(TableModelIndex: integer; const SentData: RawUTF8): TID; virtual; abstract;

    /// update a member

    // - implements REST PUT collection

    // - SentData can contain the JSON object with field values to be added

    // - returns true on success

    // - override this method for proper calling the database engine

    // - this method must be implemented in a thread-safe manner

    function EngineUpdate(TableModelIndex: integer; ID: TID; const SentData: RawUTF8): boolean; virtual; abstract;

    /// delete a member

    // - implements REST DELETE collection

    // - returns true on success

    // - override this method for proper calling the database engine

    // - this method must be implemented in a thread-safe manner

    function EngineDelete(TableModelIndex: integer; ID: TID): boolean; virtual; abstract;

    /// delete several members, from a WHERE clause

    // - IDs[] contains the already-computed matching IDs for SQLWhere

    // - returns true on success

    // - override this method for proper calling the database engine, i.e.

    // using either IDs[] or a faster SQL statement

    // - this method must be implemented in a thread-safe manner

    function EngineDeleteWhere(TableModelIndex: integer; const SQLWhere: RawUTF8;

      const IDs: TIDDynArray): boolean; virtual; abstract;

    /// get a blob field content from its member ID and field name

    // - implements REST GET member with a supplied blob field name

    // - returns TRUE on success

    // - returns the data of this blob as raw binary (not JSON) in BlobData

    // - override this method for proper data retrieval from the database engine

    // - this method must be implemented in a thread-safe manner

    function EngineRetrieveBlob(TableModelIndex: integer; aID: TID;

      BlobField: PPropInfo; out BlobData: TSQLRawBlob): boolean; virtual; abstract;

    /// update a blob field content from its member ID and field name

    // - implements REST PUT member with a supplied blob field name

    // - returns TRUE on success

    // - the data of this blob must be specified as raw binary (not JSON) in BlobData

    // - override this method for proper data retrieval from the database engine

    // - this method must be implemented in a thread-safe manner

    function EngineUpdateBlob(TableModelIndex: integer; aID: TID;

      BlobField: PPropInfo; const BlobData: TSQLRawBlob): boolean; virtual; abstract;

    /// update an individual record field value from a specified ID or Value

    // - return true on success

    // - will allow execution of requests like

    // $ UPDATE tablename SET setfieldname=setvalue WHERE wherefieldname=wherevalue

    // - SetValue and WhereValue parameters must match our inline format, i.e.

    // by double quoted with " for strings, or be plain text for numbers - e.g.

    // $ Client.EngineUpdateField(TSQLMyRecord,'FirstName','"Smith"','RowID','10')

    // but you should better use the UpdateField() overload methods instead

    // - WhereFieldName and WhereValue must be set: for security reasons,

    // implementations of this method will reject an UPDATE without any WHERE

    // clause, so you won't be able to use it to execute such statements:

    // $ UPDATE tablename SET setfieldname=setvalue

    // - this method must be implemented in a thread-safe manner

    function EngineUpdateField(TableModelIndex: integer;

      const SetFieldName, SetValue, WhereFieldName, WhereValue: RawUTF8): boolean; virtual; abstract;

    /// increments one integer field value

    // - this default implementation is just a wrapper around OneFieldValue +

    // UpdateField methods

    function EngineUpdateFieldIncrement(TableModelIndex: integer; ID: TID;

      const FieldName: RawUTF8; Increment: Int64): boolean; virtual;

    function GetCurrentSessionUserID: TID; virtual; abstract;

  public

    /// initialize the class, and associate it to a specified database Model

    constructor Create(aModel: TSQLModel); virtual;

    /// release internal used instances

    // - e.g. release associated TSQLModel or TServiceContainer

    destructor Destroy; override;

    /// save the TSQLRest properties into a persistent storage object

    // - you can then use TSQLRest.CreateFrom() to re-instantiate it

    // - current Definition.Key value will be used for the password encryption

    // - this default implementation will set the class name in Definition.Kind:

    // inherited classes should override this method and serialize other

    // properties, then override RegisteredClassCreateFrom() protected method

    // to initiate the very same instance

    procedure DefinitionTo(Definition: TSynConnectionDefinition); virtual;

    /// save the properties into a JSON file

    // - you can then use TSQLRest.CreateFromJSON() to re-instantiate it

    // - you can specify a custom Key, if the default is not enough for you

    function DefinitionToJSON(Key: cardinal=0): RawUTF8;

    /// save the properties into a JSON file

    // - you can then use TSQLRest.CreateFromFile() to re-instantiate it

    // - you can specify a custom Key, if the default is not enough for you

    procedure DefinitionToFile(const aJSONFile: TFileName; aKey: cardinal=0);

    /// create a new TSQLRest instance from its Model and stored values

    // - aDefinition.Kind will define the actual class which will be

    // instantiated: currently TSQLRestServerFullMemory, TSQLRestServerDB,

    // TSQLRestClientURINamedPipe, TSQLRestClientURIMessage,

    // TSQLHttpClientWinSock, TSQLHttpClientWinINet, TSQLHttpClientWinHTTP,

    // and TSQLHttpClientCurl classes are recognized by this method

    // - then other aDefinition fields will be used to refine the instance:

    // please refer to each overriden DefinitionTo() method documentation

    // - use TSQLRestMongoDBCreate() and/or TSQLRestExternalDBCreate() instead

    // to create a TSQLRest instance will all tables defined as external when

    // aDefinition.Kind is 'MongoDB' or a TSQLDBConnectionProperties class

    // - will raise an exception if the supplied definition are not valid

    class function CreateFrom(aModel: TSQLModel;

      aDefinition: TSynConnectionDefinition): TSQLRest;

    /// try to create a new TSQLRest instance from its Model and stored values

    // - will return nil if the supplied definition are not valid

    // - if the newly created instance is a TSQLRestServer, will force the

    // supplied aServerHandleAuthentication parameter to enable authentication

    class function CreateTryFrom(aModel: TSQLModel;

      aDefinition: TSynConnectionDefinition;

      aServerHandleAuthentication: boolean): TSQLRest;

    /// create a new TSQLRest instance from its Model and JSON stored values

    // - aDefinition.Kind will define the actual class which will be instantiated

    // - you can specify a custom Key, if the default is not safe enough for you

    class function CreateFromJSON(aModel: TSQLModel;

      const aJSONDefinition: RawUTF8; aKey: cardinal=0): TSQLRest;

    /// create a new TSQLRest instance from its Model and a JSON file

    // - aDefinition.Kind will define the actual class which will be instantiated

    // - you can specify a custom Key, if the default is not safe enough for you

    class function CreateFromFile(aModel: TSQLModel;

      const aJSONFile: TFileName; aKey: cardinal=0): TSQLRest;

    /// retrieve the registered class from the aDefinition.Kind string

    class function ClassFrom(aDefinition: TSynConnectionDefinition): TSQLRestClass;

    {$ifdef WITHLOG}

    /// the logging family used for this instance

    // - is set by default to SQLite3Log.Family, but could be set to something

    // else by setting a custom class to the LogClass property

    property LogFamily: TSynLogFamily read fLogFamily;

    {$endif}

    /// a local "Garbage collector" list, for some classes instances which must

    // live during the whole TSQLRestServer process

    // - is used internally by the class, but can be used for business code

    property PrivateGarbageCollector: TObjectList read fPrivateGarbageCollector;

  public

    /// get the row count of a specified table

    // - returns -1 on error

    // - returns the row count of the table on success

    // - calls internaly the "SELECT Count(*) FROM TableName;" SQL statement

    function TableRowCount(Table: TSQLRecordClass): Int64; virtual;

    /// check if there is some data rows in a specified table

    // - calls internaly a "SELECT RowID FROM TableName LIMIT 1" SQL statement,

    // which is much faster than testing if "SELECT count(*)" equals 0 - see

    // @http://stackoverflow.com/questions/8988915

    function TableHasRows(Table: TSQLRecordClass): boolean; virtual;

    /// search for the last inserted ID in a specified table

    // - returns -1 on error

    // - will execute by default "SELECT max(rowid) FROM TableName"

    function TableMaxID(Table: TSQLRecordClass): TID; virtual;

    /// check if a given ID do exist for a given table

    function MemberExists(Table: TSQLRecordClass; ID: TID): boolean;

    /// get the UTF-8 encoded value of an unique field with a Where Clause

    // - example of use - including inlined parameters via :(...):

    // ! aClient.OneFieldValue(TSQLRecord,'Name','ID=:(23):')

    // you should better call the corresponding overloaded method as such:

    // ! aClient.OneFieldValue(TSQLRecord,'Name','ID=?',[aID])

    // which is the same as calling:

    // ! aClient.OneFieldValue(TSQLRecord,'Name',FormatUTF8('ID=?',[],[23]))

    // - call internaly ExecuteList() to get the value

    function OneFieldValue(Table: TSQLRecordClass;

      const FieldName, WhereClause: RawUTF8): RawUTF8; overload;

    /// get the UTF-8 encoded value of an unique field with a Where Clause

    // - this overloaded function will call FormatUTF8 to create the Where Clause

    // from supplied parameters, binding all '?' chars with Args[] values

    // - example of use:

    // ! aClient.OneFieldValue(TSQLRecord,'Name','ID=?',[aID])

    // - call internaly ExecuteList() to get the value

    // - note that this method prototype changed with revision 1.17 of the

    // framework: array of const used to be Args and '%' in the FormatSQLWhere

    // statement, whereas it now expects bound parameters as '?'

    function OneFieldValue(Table: TSQLRecordClass; const FieldName: RawUTF8;

      const FormatSQLWhere: RawUTF8; const BoundsSQLWhere: array of const): RawUTF8; overload;

    /// get the UTF-8 encoded value of an unique field with a Where Clause

    // - this overloaded function will call FormatUTF8 to create the Where Clause

    // from supplied parameters, replacing all '%' chars with Args[], and all '?'

    // chars with Bounds[] (inlining them with :(...): and auto-quoting strings)

    // - example of use:

    // ! OneFieldValue(TSQLRecord,'Name','%=?',['ID'],[aID])

    // - call internaly ExecuteList() to get the value

    function OneFieldValue(Table: TSQLRecordClass; const FieldName: RawUTF8;

      const WhereClauseFmt: RawUTF8; const Args, Bounds: array of const): RawUTF8; overload;

    /// get one integer value of an unique field with a Where Clause

    // - this overloaded function will return the field value as integer

    function OneFieldValue(Table: TSQLRecordClass; const FieldName: RawUTF8;

      const WhereClauseFmt: RawUTF8; const Args, Bounds: array of const;

      out Data: Int64): boolean; overload;

    /// get the UTF-8 encoded value of an unique field from its ID

    // - example of use: OneFieldValue(TSQLRecord,'Name',23)

    // - call internaly ExecuteList() to get the value

    function OneFieldValue(Table: TSQLRecordClass;

      const FieldName: RawUTF8; WhereID: TID): RawUTF8; overload;

    /// get the UTF-8 encoded value of some fields with a Where Clause

    // - example of use: MultiFieldValue(TSQLRecord,['Name'],Name,'ID=:(23):')

    // (using inlined parameters via :(...): is always a good idea)

    // - FieldValue[] will have the same length as FieldName[]

    // - return true on success, false on SQL error or no result

    // - call internaly ExecuteList() to get the list

    function MultiFieldValue(Table: TSQLRecordClass;

      const FieldName: array of RawUTF8; var FieldValue: array of RawUTF8;

      const WhereClause: RawUTF8): boolean; overload;

    /// get the UTF-8 encoded value of some fields from its ID

    // - example of use: MultiFieldValue(TSQLRecord,['Name'],Name,23)

    // - FieldValue[] will have the same length as FieldName[]

    // - return true on success, false on SQL error or no result

    // - call internaly ExecuteList() to get the list

    function MultiFieldValue(Table: TSQLRecordClass;

      const FieldName: array of RawUTF8; var FieldValue: array of RawUTF8;

      WhereID: TID): boolean; overload;

    /// get the UTF-8 encoded values of an unique field with a Where Clause

    // - example of use: OneFieldValue(TSQLRecord,'FirstName','Name=:("Smith"):',Data)

    // (using inlined parameters via :(...): is always a good idea)

    // - leave WhereClause void to get all records

    // - call internaly ExecuteList() to get the list

    // - returns TRUE on success, FALSE if no data was retrieved

    function OneFieldValues(Table: TSQLRecordClass; const FieldName: RawUTF8;

      const WhereClause: RawUTF8; out Data: TRawUTF8DynArray): boolean; overload;

    /// get the integer value of an unique field with a Where Clause

    // - example of use: OneFieldValue(TSQLRecordPeople,'ID','Name=:("Smith"):',Data)

    // (using inlined parameters via :(...): is always a good idea)

    // - leave WhereClause void to get all records

    // - call internaly ExecuteList() to get the list

    function OneFieldValues(Table: TSQLRecordClass; const FieldName: RawUTF8;

      const WhereClause: RawUTF8; var Data: TInt64DynArray; SQL: PRawUTF8=nil): boolean; overload;

    /// dedicated method used to retrieve free-text matching DocIDs

    // - this method will work for both TSQLRecordFTS3 and TSQLRecordFTS4

    // - this method expects the column/field names to be supplied in the MATCH

    // statement clause

    // - example of use:  FTSMatch(TSQLMessage,'Body MATCH :("linu*"):',IntResult)

    // (using inlined parameters via :(...): is always a good idea)

    function FTSMatch(Table: TSQLRecordFTS3Class; const WhereClause: RawUTF8;

      var DocID: TIDDynArray): boolean; overload;

    /// dedicated method used to retrieve free-text matching DocIDs with

    // enhanced ranking information

    // - this method will work for both TSQLRecordFTS3 and TSQLRecordFTS4

    // - this method will search in all FTS3 columns, and except some floating-point

    // constants for weigthing each column (there must be the same number of

    // PerFieldWeight parameters as there are columns in the TSQLRecordFTS3 table)

    // - example of use:  FTSMatch(TSQLDocuments,'"linu*"',IntResult,[1,0.5])

    // which will sort the results by the rank obtained with the 1st column/field

    // beeing given twice the weighting of those in the 2nd (and last) column

    // - FTSMatch(TSQLDocuments,'linu*',IntResult,[1,0.5]) will perform a

    // SQL query as such, which is the fastest way of ranking according to

    // http://www.sqlite.org/fts3.html#appendix_a

    // $ SELECT RowID FROM Documents WHERE Documents MATCH 'linu*'

    // $ ORDER BY rank(matchinfo(Documents),1.0,0.5) DESC

    function FTSMatch(Table: TSQLRecordFTS3Class; const MatchClause: RawUTF8;

      var DocID: TIDDynArray; const PerFieldWeight: array of double;

      limit: integer=0; offset: integer=0): boolean; overload;

    /// get the CSV-encoded UTF-8 encoded values of an unique field with a Where Clause

    // - example of use: OneFieldValue(TSQLRecord,'FirstName','Name=:("Smith")',Data)

    // (using inlined parameters via :(...): is always a good idea)

    // - leave WhereClause void to get all records

    // - call internaly ExecuteList() to get the list

    // - using inlined parameters via :(...): in WhereClause is always a good idea

    function OneFieldValues(Table: TSQLRecordClass; const FieldName: RawUTF8;

      const WhereClause: RawUTF8=''; const Separator: RawUTF8=','): RawUTF8; overload;

    /// get the string-encoded values of an unique field into some TStrings

    // - Items[] will be filled with string-encoded values of the given field)

    // - Objects[] will be filled with pointer(ID)

    // - call internaly ExecuteList() to get the list

    // - returns TRUE on success, FALSE if no data was retrieved

    // - if IDToIndex is set, its value will be replaced with the index in

    // Strings.Objects[] where ID=IDToIndex^

    // - using inlined parameters via :(...): in WhereClause is always a good idea

    function OneFieldValues(Table: TSQLRecordClass;

      const FieldName, WhereClause: RawUTF8; Strings: TStrings;

      IDToIndex: PID=nil): Boolean; overload;

    /// Execute directly a SQL statement, expecting a list of resutls

    // - return a result table on success, nil on failure

    // - FieldNames can be the CSV list of field names to be retrieved

    // - if FieldNames is '', will get all simple fields, excluding BLOBs

    // - if FieldNames is '*', will get ALL fields, including ID and BLOBs

    // - call internaly ExecuteList() to get the list

    // - using inlined parameters via :(...): in WhereClause is always a good idea

    function MultiFieldValues(Table: TSQLRecordClass; const FieldNames: RawUTF8;

       const WhereClause: RawUTF8=''): TSQLTableJSON; overload; virtual;

    /// Execute directly a SQL statement, expecting a list of resutls

    // - return a result table on success, nil on failure

    // - FieldNames can be the CSV list of field names to be retrieved

    // - if FieldNames is '', will get all simple fields, excluding BLOBs

    // - if FieldNames is '*', will get ALL fields, including ID and BLOBs

    // - this overloaded function will call FormatUTF8 to create the Where Clause

    // from supplied parameters, binding all '?' chars with Args[] values

    // - example of use:

    // ! aList := aClient.MultiFieldValues(TSQLRecord,'Name,FirstName','Salary>=?',[aMinSalary]);

    // - call overloaded MultiFieldValues() / ExecuteList() to get the list

    // - note that this method prototype changed with revision 1.17 of the

    // framework: array of const used to be Args and '%' in the WhereClauseFormat

    // statement, whereas it now expects bound parameters as '?'

    function MultiFieldValues(Table: TSQLRecordClass; const FieldNames: RawUTF8;

      const WhereClauseFormat: RawUTF8; const BoundsSQLWhere: array of const): TSQLTableJSON; overload;

    /// Execute directly a SQL statement, expecting a list of results

    // - return a result table on success, nil on failure

    // - FieldNames can be the CSV list of field names to be retrieved

    // - if FieldNames is '', will get all simple fields, excluding BLOBs

    // - if FieldNames is '*', will get ALL fields, including ID and BLOBs

    // - in this version, the WHERE clause can be created with the same format

    // as FormatUTF8() function, replacing all '%' chars with Args[], and all '?'

    // chars with Bounds[] (inlining them with :(...): and auto-quoting strings)

    // - example of use:

    // ! Table := MultiFieldValues(TSQLRecord,'Name','%=?',['ID'],[aID]);

    // - call overloaded MultiFieldValues() / ExecuteList() to get the list

    function MultiFieldValues(Table: TSQLRecordClass; const FieldNames: RawUTF8;

      const WhereClauseFormat: RawUTF8; const Args, Bounds: array of const): TSQLTableJSON; overload;

    /// retrieve the main field (mostly 'Name') value of the specified record

    // - use GetMainFieldName() method to get the main field name

    // - use OneFieldValue() method to get the field value

    // - return '' if no such field or record exists

    // - if ReturnFirstIfNoUnique is TRUE and no unique property is found,

    // the first RawUTF8 property is returned anyway

    function MainFieldValue(Table: TSQLRecordClass; ID: TID;

      ReturnFirstIfNoUnique: boolean=false): RawUTF8;

    /// return the ID of the record which main field match the specified value

    // - search field is mainly the "Name" property, i.e. the one with

    // "stored AS_UNIQUE" (i.e. "stored false") definition on most TSQLRecord

    // - returns 0 if no matching record was found }

    function MainFieldID(Table: TSQLRecordClass; const Value: RawUTF8): TID;

    /// return the IDs of the record which main field match the specified values

    // - search field is mainly the "Name" property, i.e. the one with

    // "stored AS_UNIQUE" (i.e. "stored false") definition on most TSQLRecord

    // - if any of the Values[] is not existing, then no ID will appear in the

    // IDs[] array - e.g. it will return [] if no matching record was found

    // - returns TRUE if any matching ID was found (i.e. if length(IDs)>0) }

    function MainFieldIDs(Table: TSQLRecordClass; const Values: array of RawUTF8;

      out IDs: TIDDynArray): boolean;

  public // here are REST basic direct calls (works with Server or Client)

    /// get a member from a SQL statement

    // - implements REST GET collection

    // - return true on success

    // - Execute 'SELECT * FROM TableName WHERE SQLWhere LIMIT 1' SQL Statememt

    // (using inlined parameters via :(...): in SQLWhere is always a good idea)

    // - since no record is specified, locking is pointless here

    // - default implementation call ExecuteList(), and fill Value from a

    // temporary TSQLTable

    // - if aCustomFieldsCSV is '', will get all simple fields, excluding BLOBs

    // and TSQLRecordMany fields (use RetrieveBlob method or set

    // TSQLRestClientURI.ForceBlobTransfert)

    // - if aCustomFieldsCSV is '*', will get ALL fields, including ID and BLOBs

    // - if this default set of simple fields does not fit your need, you could

    // specify your own set

    function Retrieve(const SQLWhere: RawUTF8; Value: TSQLRecord;

      const aCustomFieldsCSV: RawUTF8=''): boolean; overload; virtual;

    /// get a member from a SQL statement

    // - implements REST GET collection

    // - return true on success

    // - same as Retrieve(const SQLWhere: RawUTF8; Value: TSQLRecord) method, but

    // this overloaded function will call FormatUTF8 to create the Where Clause

    // from supplied parameters, replacing all '%' chars with Args[], and all '?'

    // chars with Bounds[] (inlining them with :(...): and auto-quoting strings)

    // - if aCustomFieldsCSV is '', will get all simple fields, excluding BLOBs

    // - if aCustomFieldsCSV is '*', will get ALL fields, including ID and BLOBs

    function Retrieve(const WhereClauseFmt: RawUTF8; const Args,Bounds: array of const;

      Value: TSQLRecord; const aCustomFieldsCSV: RawUTF8=''): boolean; overload;

    /// get a member from its ID

    // - return true on success

    // - Execute 'SELECT * FROM TableName WHERE ID=:(aID): LIMIT 1' SQL Statememt

    // - if ForUpdate is true, the REST method is LOCK and not GET: it tries to lock

    // the corresponding record, then retrieve its content; caller has to call

    // UnLock() method after Value usage, to release the record

    // - this method will call EngineRetrieve() abstract method

    // - the TSQLRawBlob (BLOB) fields are not retrieved by this method, to

    // preserve bandwidth: use the RetrieveBlob() methods for handling

    // BLOB fields, or set either the TSQLRestClientURI.ForceBlobTransfert

    // or TSQLRestClientURI.ForceBlobTransfertTable[] properties

    // - the TSQLRecordMany fields are not retrieved either: they are separate

    // instances created by TSQLRecordMany.Create, with dedicated methods to

    // access to the separated pivot table

   function Retrieve(aID: TID; Value: TSQLRecord;

      ForUpdate: boolean=false): boolean; overload; virtual;

    /// get a member from its TRecordReference property content

    // - instead of the other Retrieve() methods, this implementation Create an

    // instance, with the appropriated class stored in Reference

    // - returns nil on any error (invalid Reference e.g.)

    // - if ForUpdate is true, the REST method is LOCK and not GET: it tries to lock

    // the corresponding record, then retrieve its content; caller has to call

    // UnLock() method after Value usage, to release the record

    // - the TSQLRawBlob (BLOB) fields are not retrieved by this method, to

    // preserve bandwidth: use the RetrieveBlob() methods for handling

    // BLOB fields, or set either the TSQLRestClientURI.ForceBlobTransfert

    // or TSQLRestClientURI.ForceBlobTransfertTable[] properties

    // - the TSQLRecordMany fields are not retrieved either: they are separate

    // instances created by TSQLRecordMany.Create, with dedicated methods to

    // access to the separated pivot table

    function Retrieve(Reference: TRecordReference;

      ForUpdate: boolean=false): TSQLRecord; overload; virtual;

    /// get a member from a published property TSQLRecord

    // - those properties are not class instances, but TObject(aRecordID)

    // - is just a wrapper around Retrieve(aPublishedRecord.ID,aValue)

    // - return true on success

    function Retrieve(aPublishedRecord, aValue: TSQLRecord): boolean; overload;

    /// get a list of members from a SQL statement as TObjectList

    // - implements REST GET collection

    // - for better server speed, the WHERE clause should use bound parameters

    // identified as '?' in the FormatSQLWhere statement, which is expected to

    // follow the order of values supplied in BoundsSQLWhere open array - use

    // DateToSQL()/DateTimeToSQL() for TDateTime, or directly any integer,

    // double, currency, RawUTF8 values to be bound to the request as parameters

    // - aCustomFieldsCSV can be the CSV list of field names to be retrieved

    // - if aCustomFieldsCSV is '', will get all simple fields, excluding BLOBs

    // - if aCustomFieldsCSV is '*', will get ALL fields, including ID and BLOBs

    // - return a TObjectList on success (possibly with Count=0) - caller is

    // responsible of freeing the instance

    // - this TObjectList will contain a list of all matching records

    // - return nil on error

    function RetrieveList(Table: TSQLRecordClass; const FormatSQLWhere: RawUTF8;

      const BoundsSQLWhere: array of const;

      const aCustomFieldsCSV: RawUTF8=''): TObjectList; overload;

    /// get a list of members from a SQL statement as RawJSON

    // - implements REST GET collection

    // - for better server speed, the WHERE clause should use bound parameters

    // identified as '?' in the FormatSQLWhere statement, which is expected to

    // follow the order of values supplied in BoundsSQLWhere open array - use

    // DateToSQL()/DateTimeToSQL() for TDateTime, or directly any integer,

    // double, currency, RawUTF8 values to be bound to the request as parameters

    // - aCustomFieldsCSV can be the CSV list of field names to be retrieved

    // - if aCustomFieldsCSV is '', will get all simple fields, excluding BLOBs

    // - if aCustomFieldsCSV is '*', will get ALL fields, including ID and BLOBs

    // - returns the raw JSON array content with all items on success, with

    // our expanded / not expanded JSON format - so can be used with SOA methods

    // and RawJSON results, for direct process from the client side

    // - returns '' on error

    // - the data is directly retrieved from raw JSON as returned by the database

    // without any conversion, so this method would be the fastest, but complex

    // types like dynamic array would be returned as Base64-encoded blob value -

    // if you need proper JSON access to those, see RetrieveDocVariantArray()

    function RetrieveListJSON(Table: TSQLRecordClass; const FormatSQLWhere: RawUTF8;

      const BoundsSQLWhere: array of const;

      const aCustomFieldsCSV: RawUTF8=''; aForceAJAX: boolean=false): RawJSON; overload;

    /// get a list of members from a SQL statement as RawJSON

    // - implements REST GET collection

    // - this overloaded version expect the SQLWhere clause to be already

    // prepared with inline parameters using a previous FormatUTF8() call

    // - aCustomFieldsCSV can be the CSV list of field names to be retrieved

    // - if aCustomFieldsCSV is '', will get all simple fields, excluding BLOBs

    // - if aCustomFieldsCSV is '*', will get ALL fields, including ID and BLOBs

    // - returns the raw JSON array content with all items on success, with

    // our expanded / not expanded JSON format - so can be used with SOA methods

    // and RawJSON results, for direct process from the client side

    // - returns '' on error

    // - the data is directly retrieved from raw JSON as returned by the database

    // without any conversion, so this method would be the fastest, but complex

    // types like dynamic array would be returned as Base64-encoded blob value -

    // if you need proper JSON access to those, see RetrieveDocVariantArray()

    function RetrieveListJSON(Table: TSQLRecordClass; const SQLWhere: RawUTF8;

      const aCustomFieldsCSV: RawUTF8=''; aForceAJAX: boolean=false): RawJSON; overload;

    {$ifndef NOVARIANTS}

    /// get a list of all members from a SQL statement as a TDocVariant

    // - implements REST GET collection

    // - if ObjectName='', it will return a TDocVariant of dvArray kind

    // - if ObjectName is set, it will return a TDocVariant of dvObject kind,

    // with one property containing the array of values: this returned variant

    // can be pasted e.g. directly as parameter to TSynMustache.Render()

    // - aCustomFieldsCSV can be the CSV list of field names to be retrieved

    // - if aCustomFieldsCSV is '', will get all simple fields, excluding BLOBs

    // - if aCustomFieldsCSV is '*', will get ALL fields, including ID and BLOBs

    // - the data will be converted to variants and TDocVariant following the

    // TSQLRecord layout, so complex types like dynamic array would be returned

    // as a true array of values (in contrast to the RetrieveListJSON method)

    function RetrieveDocVariantArray(Table: TSQLRecordClass;

      const ObjectName, CustomFieldsCSV: RawUTF8; FirstRecordID: PID=nil;

      LastRecordID: PID=nil): variant; overload;

      {$ifdef HASINLINE}inline;{$endif}

    /// get a list of members from a SQL statement as a TDocVariant

    // - implements REST GET collection over a specified WHERE clause

    // - if ObjectName='', it will return a TDocVariant of dvArray kind

    // - if ObjectName is set, it will return a TDocVariant of dvObject kind,

    // with one property containing the array of values: this returned variant

    // can be pasted e.g. directly as parameter to TSynMustache.Render()

    // - for better server speed, the WHERE clause should use bound parameters

    // identified as '?' in the FormatSQLWhere statement, which is expected to

    // follow the order of values supplied in BoundsSQLWhere open array - use

    // DateToSQL()/DateTimeToSQL() for TDateTime, or directly any integer,

    // double, currency, RawUTF8 values to be bound to the request as parameters

    // - aCustomFieldsCSV can be the CSV list of field names to be retrieved

    // - if aCustomFieldsCSV is '', will get all simple fields, excluding BLOBs

    // - if aCustomFieldsCSV is '*', will get ALL fields, including ID and BLOBs

    // - the data will be converted to variants and TDocVariant following the

    // TSQLRecord layout, so complex types like dynamic array would be returned

    // as a true array of values (in contrast to the RetrieveListJSON method)

    function RetrieveDocVariantArray(Table: TSQLRecordClass;

      const ObjectName: RawUTF8;

      const FormatSQLWhere: RawUTF8; const BoundsSQLWhere: array of const;

      const CustomFieldsCSV: RawUTF8; FirstRecordID: PID=nil;

      LastRecordID: PID=nil): variant; overload;

    /// get all values of a SQL statement on a single column as a TDocVariant array

    // - implements REST GET collection on a single field

    // - for better server speed, the WHERE clause should use bound parameters

    // identified as '?' in the FormatSQLWhere statement, which is expected to

    // follow the order of values supplied in BoundsSQLWhere open array - use

    // DateToSQL()/DateTimeToSQL() for TDateTime, or directly any integer,

    // double, currency, RawUTF8 values to be bound to the request as parameters

    // - the data will be converted to variants and TDocVariant following the

    // TSQLRecord layout, so complex types like dynamic array would be returned

    // as a true array of values (in contrast to the RetrieveListJSON method)

    function RetrieveOneFieldDocVariantArray(Table: TSQLRecordClass;

      const FieldName, FormatSQLWhere: RawUTF8;

      const BoundsSQLWhere: array of const): variant;

    /// get one member from a SQL statement as a TDocVariant

    // - implements REST GET collection

    // - the data will be converted to a TDocVariant variant following the

    // TSQLRecord layout, so complex types like dynamic array would be returned

    // as a true array of values

    function RetrieveDocVariant(Table: TSQLRecordClass;

      const FormatSQLWhere: RawUTF8; const BoundsSQLWhere: array of const;

      const CustomFieldsCSV: RawUTF8): variant;

    {$endif NOVARIANTS}

    /// get a list of members from a SQL statement as T*ObjArray

    // - implements REST GET collection

    // - for better server speed, the WHERE clause should use bound parameters

    // identified as '?' in the FormatSQLWhere statement, which is expected to

    // follow the order of values supplied in BoundsSQLWhere open array - use

    // DateToSQL()/DateTimeToSQL() for TDateTime, or directly any integer,

    // double, currency, RawUTF8 values to be bound to the request as parameters

    // - aCustomFieldsCSV can be the CSV list of field names to be retrieved

    // - if aCustomFieldsCSV is '', will get all simple fields, excluding BLOBs

    // - if aCustomFieldsCSV is '*', will get ALL fields, including ID and BLOBs

    // - set the T*ObjArray variable with all items on success - so that it can

    // be used with SOA methods

    // - it is up to the caller to ensure that ObjClear(ObjArray) is called

    // when the T*ObjArray list is not needed any more

    // - returns true on success, false on error

    function RetrieveListObjArray(var ObjArray; Table: TSQLRecordClass;

      const FormatSQLWhere: RawUTF8; const BoundsSQLWhere: array of const;

      const aCustomFieldsCSV: RawUTF8=''): boolean;

    /// get and append a list of members as an expanded JSON array

    // - implements REST GET collection

    // - generates '[{rec1},{rec2},...]' using a loop similar to:

    // ! while FillOne do .. AppendJsonObject() ..

    // - for better server speed, the WHERE clause should use bound parameters

    // identified as '?' in the FormatSQLWhere statement, which is expected to

    // follow the order of values supplied in BoundsSQLWhere open array - use

    // DateToSQL()/DateTimeToSQL() for TDateTime, or directly any integer,

    // double, currency, RawUTF8 values to be bound to the request as parameters

    // - if OutputFieldName is set, the JSON array will be written as a JSON,

    // property i.e. surrounded as '"OutputFieldName":[....],' - note ending ','

    // - CustomFieldsCSV can be the CSV list of field names to be retrieved

    // - if CustomFieldsCSV is '', will get all simple fields, excluding BLOBs

    // - if CustomFieldsCSV is '*', will get ALL fields, including ID and BLOBs

    // - is just a wrapper around TSQLRecord.AppendFillAsJsonArray()

    procedure AppendListAsJsonArray(Table: TSQLRecordClass;

      const FormatSQLWhere: RawUTF8; const BoundsSQLWhere: array of const;

      const OutputFieldName: RawUTF8; W: TJSONSerializer;

      const CustomFieldsCSV: RawUTF8='');

    /// Execute directly a SQL statement, expecting a list of results

    // - return a result table on success, nil on failure

    // - will call EngineList() abstract method to retrieve its JSON content

    function ExecuteList(const Tables: array of TSQLRecordClass; const SQL: RawUTF8): TSQLTableJSON; virtual;

    /// Execute directly a SQL statement, expecting a list of results

    // - you should not have to use this method, but the ORM versions instead

    // - return a result set as JSON on success, '' on failure

    // - will call EngineList() abstract method to retrieve its JSON content

    function ExecuteJson(const Tables: array of TSQLRecordClass; const SQL: RawUTF8): RawJSON; virtual;

    /// Execute directly a SQL statement, without any expected result

    // - implements POST SQL on ModelRoot URI

    // - return true on success

    // - will call EngineExecute() abstract method to run the SQL statement

    function Execute(const aSQL: RawUTF8): boolean; virtual;

    /// Execute directly a SQL statement with supplied parameters, with no result

    // - expect the same format as FormatUTF8() function, replacing all '%' chars

    // with Args[] values

    // - return true on success

    function ExecuteFmt(const SQLFormat: RawUTF8; const Args: array of const): boolean; overload;

    /// Execute directly a SQL statement with supplied parameters, with no result

    // - expect the same format as FormatUTF8() function, replacing all '%' chars

    // with Args[] values, and all '?' chars with Bounds[] (inlining them

    // with :(...): and auto-quoting strings)

    // - return true on success

    function ExecuteFmt(const SQLFormat: RawUTF8; const Args, Bounds: array of const): boolean; overload;

    /// unlock the corresponding record

    // - record should have been locked previously e.g. with Retrieve() and

    // forupdate=true, i.e. retrieved not via GET with LOCK REST-like verb

    // - use our custom UNLOCK REST-like verb

    // - returns true on success

    function UnLock(Table: TSQLRecordClass; aID: TID): boolean; overload; virtual; abstract;

    /// unlock the corresponding record

    // - record should have been locked previously e.g. with Retrieve() and

    // forupdate=true, i.e. retrieved not via GET with LOCK REST-like verb

    // - use our custom UNLOCK REST-like method

    // - calls internally UnLock() above

    // - returns true on success

    function UnLock(Rec: TSQLRecord): boolean; overload;

    /// create a new member

    // - implements REST POST collection

    // - if SendData is true, client sends the current content of Value with the

    // request, otherwise record is created with default values

    // - if ForceID is true, client sends the Value.ID field to use this ID for

    // adding the record (instead of a database-generated ID)

    // - on success, returns the new ROWID value; on error, returns 0

    // - on success, Value.ID is updated with the new ROWID

    // - the TSQLRawBlob(BLOB) fields values are not set by this method, to

    // preserve bandwidth - see UpdateBlobFields() and AddWithBlobs() methods

    // - the TSQLRecordMany fields are not set either: they are separate

    // instances created by TSQLRecordMany.Create, with dedicated methods to

    // access to the separated pivot table

    // - this method will call EngineAdd() to perform the request

    function Add(Value: TSQLRecord; SendData: boolean; ForceID: boolean=false;

      DoNotAutoComputeFields: boolean=false): TID; overload;

      {$ifdef HASINLINE}inline;{$endif}

    /// create a new member, including selected fields

    // - implements REST POST collection

    // - if ForceID is true, client sends the Value.ID field to use this ID for

    // adding the record (instead of a database-generated ID)

    // - this method will call EngineAdd() to perform the request

    function Add(Value: TSQLRecord; const CustomCSVFields: RawUTF8;

      ForceID: boolean=false; DoNotAutoComputeFields: boolean=false): TID; overload;

    /// create a new member, including selected fields

    // - implements REST POST collection

    // - if ForceID is true, client sends the Value.ID field to use this ID for

    // adding the record (instead of a database-generated ID)

    // - this method will call EngineAdd() to perform the request

    function Add(Value: TSQLRecord; const CustomFields: TSQLFieldBits;

      ForceID: boolean=false; DoNotAutoComputeFields: boolean=false): TID; overload;

      {$ifdef HASINLINE}inline;{$endif}

    /// create a new member, including its BLOB fields

    // - implements REST POST collection

    // - this method would create a JSON representation of the document

    // including the BLOB fields as Base64 encoded text, so would be less

    // efficient than a dual Add() + UpdateBlobFields() methods if the

    // binary content has a non trivial size

    // - this method will call EngineAdd() to perform the request

    function AddWithBlobs(Value: TSQLRecord; ForceID: boolean=false;

      DoNotAutoComputeFields: boolean=false): TID; virtual;

    /// create a new member, from a supplied list of field values

    // - implements REST POST collection

    // - the aSimpleFields parameters must follow explicitely the order of published

    // properties of the supplied aTable class, excepting the TSQLRawBlob and

    // TSQLRecordMany kind (i.e. only so called "simple fields")

    // - the aSimpleFields must have exactly the same count of parameters as

    // there are "simple fields" in the published properties

    // - if ForcedID is set to non null, client sends this ID to be used

    // when adding the record (instead of a database-generated ID)

    // - on success, returns the new RowID value; on error, returns 0

    // - call internaly the Add virtual method above

    function Add(aTable: TSQLRecordClass; const aSimpleFields: array of const;

      ForcedID: TID=0): TID; overload;

    /// update a member from Value simple fields content

    // - implements REST PUT collection

    // - return true on success

    // - the TSQLRawBlob(BLOB) fields values are not updated by this method, to

    // preserve bandwidth: use the UpdateBlob() methods for handling BLOB fields

    // - the TSQLRecordMany fields are not set either: they are separate

    // instances created by TSQLRecordMany.Create, with dedicated methods to

    // access to the separated pivot table

    // - if CustomFields is left void, the  simple fields will be used, or the

    // fields retrieved via a previous FillPrepare() call; otherwise, you can

    // specify your own set of fields to be transmitted (including BLOBs, even

    // if they will be Base64-encoded within the JSON content) - CustomFields

    // could be computed by TSQLRecordProperties.FieldBitsFromCSV()

    // or TSQLRecordProperties.FieldBitsFromRawUTF8()

    // - this method will always compute and send any TModTime fields

    // - this method will call EngineUpdate() to perform the request

    function Update(Value: TSQLRecord; const CustomFields: TSQLFieldBits=[];

      DoNotAutoComputeFields: boolean=false): boolean; overload; virtual;

    /// update a member from Value simple fields content

    // - implements REST PUT collection

    // - return true on success

    // - is an overloaded method to Update(Value,FieldBitsFromCSV())

    function Update(Value: TSQLRecord; const CustomCSVFields: RawUTF8;

      DoNotAutoComputeFields: boolean=false): boolean; overload;

    /// update a member from a supplied list of simple field values

    // - implements REST PUT collection

    // - the aSimpleFields parameters MUST follow explicitely both count and

    // order of published properties of the supplied aTable class, excepting the

    // TSQLRawBlob and TSQLRecordMany kind (i.e. only so called "simple fields")

    // - return true on success

    // - call internaly the Update() / EngineUpdate() virtual methods

    function Update(aTable: TSQLRecordClass; aID: TID;

      const aSimpleFields: array of const): boolean; overload;

    /// create or update a member, depending if the Value has already an ID

    // - implements REST POST if Value.ID=0 or ForceID is set, or a REST PUT

    // collection to update the record pointed by a Value.ID<>0 

    // - will return the created or updated ID

    function AddOrUpdate(Value: TSQLRecord; ForceID: boolean=false): TID;

    /// update one field/column value a given member

    // - implements REST PUT collection with one field value

    // - only one single field shall be specified in FieldValue, but could

    // be of any kind of value - for BLOBs, you should better use UpdateBlob()

    // - return true on success

    // - call internaly the EngineUpdateField() abstract method

    // - note that this method won't update the TModTime properties: you should

    // rather use a classic Retrieve()/FillPrepare() followed by Update()

    function UpdateField(Table: TSQLRecordClass; ID: TID;

      const FieldName: RawUTF8; const FieldValue: array of const): boolean; overload; virtual;

    /// update one field in one or several members, depending on a WHERE clause

    // - implements REST PUT collection with one field value on a one where value

    // - only one single field shall be specified in FieldValue, but could

    // be of any kind of value - for BLOBs, you should better use UpdateBlob()

    // - only one single field shall be specified in WhereFieldValue, but could

    // be of any kind of value - for security reasons, void WHERE clause will

    // be rejected

    // - return true on success

    // - call internaly the EngineUpdateField() abstract method

    // - note that this method won't update the TModTime properties: you should

    // rather use a classic Retrieve()/FillPrepare() followed by Update()

    function UpdateField(Table: TSQLRecordClass;

      const WhereFieldName: RawUTF8; const WhereFieldValue: array of const;

      const FieldName: RawUTF8; const FieldValue: array of const): boolean; overload; virtual;

    {$ifndef NOVARIANTS}

    /// update one field in a given member with a value specified as variant

    // - implements REST PUT collection with one field value

    // - any value can be set in FieldValue, but for BLOBs, you should better

    // use UpdateBlob()

    // - return true on success

    // - call internaly the EngineUpdateField() abstract method

    // - note that this method won't update the TModTime properties: you should

    // rather use a classic Retrieve()/FillPrepare() followed by Update()

    function UpdateField(Table: TSQLRecordClass; ID: TID;

      const FieldName: RawUTF8; const FieldValue: variant): boolean; overload; virtual;

    /// update one field in one or several members, depending on a WHERE clause,

    // with both update and where values specified as variant

    // - implements REST PUT collection with one field value on a one where value

    // - any value can be set in FieldValue, but for BLOBs, you should better

    // use UpdateBlob()

    // - for security reasons, void WHERE clause will be rejected

    // - return true on success

    // - call internaly the EngineUpdateField() abstract method

    // - note that this method won't update the TModTime properties: you should

    // rather use a classic Retrieve()/FillPrepare() followed by Update()

    function UpdateField(Table: TSQLRecordClass;

      const WhereFieldName: RawUTF8; const WhereFieldValue: variant;

      const FieldName: RawUTF8; const FieldValue: variant): boolean; overload; virtual;

    /// update one field in one or several members, depending on a set of IDs

    // - return true on success

    // - note that this method won't update the TModTime properties: you should

    // rather use a classic Retrieve()/FillPrepare() followed by Update(), but

    // it would be much slower, even over a BATCH

    // - will be executed as a regular SQL statement:

    // $ UPDATE table SET fieldname=fieldvalue WHERE RowID IN (...)

    // - warning: this method would call directly EngineExecute(), and would

    // work just fine with SQLite3, but some other DB engines may not allow

    // a huge number of items within the IN(...) clause

    function UpdateField(Table: TSQLRecordClass; const IDs: array of Int64;

      const FieldName: RawUTF8; const FieldValue: variant): boolean; overload; virtual;

    {$endif NOVARIANTS}

    /// increments one integer field value

    // - if available, this method will use atomic value modification, e.g.

    // $ UPDATE table SET field=field+?

    function UpdateFieldIncrement(Table: TSQLRecordClass; ID: TID;

      const FieldName: RawUTF8; Increment: Int64=1): boolean; virtual;

    /// override this method to guess if this record can be updated or deleted

    // - this default implementation returns always true

    // - e.g. you can add digital signature to a record to disallow record editing

    // - the ErrorMsg can be set to a variable, which will contain an explicit

    // error message

    function RecordCanBeUpdated(Table: TSQLRecordClass; ID: TID; Action: TSQLEvent;

      ErrorMsg: PRawUTF8 = nil): boolean; virtual;

    /// delete a member

    // - implements REST DELETE collection

    // - return true on success

    // - call internaly the EngineDelete() abstract method

    function Delete(Table: TSQLRecordClass; ID: TID): boolean; overload; virtual;

    /// delete a member with a WHERE clause

    // - implements REST DELETE collection

    // - return true on success

    // - this default method call OneFieldValues() to retrieve all matching IDs,

    // then will delete each row using protected EngineDeleteWhere() virtual method

    function Delete(Table: TSQLRecordClass; const SQLWhere: RawUTF8): boolean; overload; virtual;

    /// delete a member with a WHERE clause

    // - implements REST DELETE collection

    // - return true on success

    // - for better server speed, the WHERE clause should use bound parameters

    // identified as '?' in the FormatSQLWhere statement, which is expected to

    // follow the order of values supplied in BoundsSQLWhere open array - use

    // DateToSQL/DateTimeToSQL for TDateTime, or directly any integer / double /

    // currency / RawUTF8 values to be bound to the request as parameters

    // - is a simple wrapper around:

    // ! Delete(Table,FormatUTF8(FormatSQLWhere,[],BoundsSQLWhere))

    function Delete(Table: TSQLRecordClass; const FormatSQLWhere: RawUTF8;

      const BoundsSQLWhere: array of const): boolean; overload;



    /// access the internal caching parameters for a given TSQLRecord

    // - will always return a TSQLRestCache instance, creating one if needed

    // - purpose of this caching mechanism is to speed up retrieval of some

    // common values at either Client or Server level (like configuration settings)

    // - by default, this CRUD level per-ID cache is disabled

    // - use Cache.SetCache() and Cache.SetTimeOut() methods to set the appropriate

    // configuration for this particular TSQLRest instance

    // - only caching synchronization is about the direct RESTful/CRUD commands:

    // RETRIEVE, ADD, UPDATE and DELETE (that is, a complex direct SQL UPDATE or

    // via TSQLRecordMany pattern won't be taken in account - only exception is

    // TSQLRestStorage tables accessed as SQLite3 virtual table)

    // - this caching will be located at the TSQLRest level, that is no automated

    // synchronization is implemented between TSQLRestClient and TSQLRestServer -

    // you shall ensure that your business logic is safe, calling Cache.Flush()

    // overloaded methods on purpose: better no cache than unproper cache -

    // "premature optimization is the root of all evil"

    property Cache: TSQLRestCache read GetCache;

    /// access the internal caching parameters for a given TSQLRecord

    // - would return nil if no TSQLRestCache instance has been defined

    function CacheOrNil: TSQLRestCache;

      {$ifdef HASINLINE}inline;{$endif}



    /// get a blob field content from its record ID and supplied blob field name

    // - implements REST GET collection with a supplied member ID and a blob field name

    // - return true on success

    // - this method is defined as abstract, i.e. there is no default implementation:

    // it must be implemented 100% RestFul with a

    // GET ModelRoot/TableName/TableID/BlobFieldName request for example

    // - this method retrieve the blob data as a TSQLRawBlob string using

    // EngineRetrieveBlob()

    function RetrieveBlob(Table: TSQLRecordClass; aID: TID;

      const BlobFieldName: RawUTF8; out BlobData: TSQLRawBlob): boolean; overload; virtual;

    /// get a blob field content from its record ID and supplied blob field name

    // - implements REST GET collection with a supplied member ID and field name

    // - return true on success

    // - this method will create a TStream instance (which must be freed by the

    // caller after use) and fill it with the blob data

    function RetrieveBlob(Table: TSQLRecordClass; aID: TID;

      const BlobFieldName: RawUTF8; out BlobStream: THeapMemoryStream): boolean; overload;

    /// update a blob field from its record ID and supplied blob field name

    // - implements REST PUT collection with a supplied member ID and field name

    // - return true on success

    // - call internaly the EngineUpdateBlob() abstract method

    // - this method expect the Blob data to be supplied as TSQLRawBlob, using

    // EngineUpdateBlob()

    function UpdateBlob(Table: TSQLRecordClass; aID: TID;

      const BlobFieldName: RawUTF8; const BlobData: TSQLRawBlob): boolean; overload; virtual;

    /// update a blob field from its record ID and blob field name

    // - implements REST PUT collection with a supplied member ID and field name

    // - return true on success

    // - call internaly the EngineUpdateBlob() abstract method

    // - this method expect the Blob data to be supplied as a TStream: it will

    // send the whole stream content (from its beginning position upto its

    // current size) to the database engine

    function UpdateBlob(Table: TSQLRecordClass; aID: TID;

      const BlobFieldName: RawUTF8; BlobData: TStream): boolean; overload;

    /// update a blob field from its record ID and blob field name

    // - implements REST PUT collection with a supplied member ID and field name

    // - return true on success

    // - call internaly the EngineUpdateBlob() abstract method

    // - this method expect the Blob data to be supplied as direct memory pointer

    // and size

    function UpdateBlob(Table: TSQLRecordClass; aID: TID;

      const BlobFieldName: RawUTF8; BlobData: pointer; BlobSize: integer): boolean; overload;

    /// update all BLOB fields of the supplied Value

    // - call several REST PUT collection (one for each BLOB) for the member

    // - uses the UpdateBlob() method to send the BLOB properties content to the Server

    // - called internaly by Add and Update methods when ForceBlobTransfert /

    // ForceBlobTransfertTable[] is set

    // - you can use this method by hand, to avoid several calls to UpdateBlob()

    // - returns TRUE on success (or if there is no BLOB field)

    // - returns FALSE on error (e.g. if Value is invalid or with db/transmission)

    function UpdateBlobFields(Value: TSQLRecord): boolean; virtual;

    /// get all BLOB fields of the supplied value from the remote server

    // - call several REST GET collection (one for each BLOB) for the member

    // - call internaly e.g. by TSQLRestClient.Retrieve method when

    // ForceBlobTransfert / ForceBlobTransfertTable[] is set

    function RetrieveBlobFields(Value: TSQLRecord): boolean; virtual;



    /// begin a transaction

    // - implements REST BEGIN collection

    // - may be used to speed up CRUD statements like Add/Update/Delete

    // - in the current implementation, nested transactions are not allowed

    // - must be ended with Commit on success

    // - must be aborted with Rollback if any SQL statement failed

    // - default implementation just handle the protected fTransactionActiveSession flag

    // - return true if no transaction is active, false otherwise

    // - in aClient-Server environment with multiple Clients connected at the

    // same time, you should better use BATCH process, specifying a positive

    // AutomaticTransactionPerRow parameter to BatchStart()

    // - in a multi-threaded or Client-Server with multiple concurrent Client

    // connections, you may check the returned value, as such:

    //  !if Client.TransactionBegin(TSQLRecordPeopleObject) then

    //  !try

    //  !  //.... modify the database content, raise exceptions on error

    //  !  Client.Commit;

    //  !except

    //  !  Client.RollBack; // in case of error

    //  !end;

    // or use the TransactionBeginRetry() method

    // - the supplied SessionID will allow multi-user transaction safety on the

    // Server-Side: all database modification from another session will wait

    // for the global transaction to be finished; on Client-side, the SessionID

    // is just ignored (TSQLRestClient will override this method with a default

    // SessionID=CONST_AUTHENTICATION_NOT_USED=1 parameter)

    // - if you have an external database engine which expect transactions to

    // take place in the same thread, ensure TSQLRestServer force execution of

    // this method when accessed from RESTful clients in the same thread, e.g.:

    // ! AcquireExecutionMode[execORMWrite] := amBackgroundThread;

    // ! AcquireWriteMode := amBackgroundThread; // same as previous

    function TransactionBegin(aTable: TSQLRecordClass; SessionID: cardinal): boolean; virtual;

    /// check current transaction status

    // - returns the session ID if a transaction is active

    // - returns 0 if no transaction is active

    function TransactionActiveSession: cardinal;

    /// end a transaction

    // - implements REST END collection

    // - write all pending SQL statements to the disk

    // - default implementation just reset the protected fTransactionActiveSession flag

    // - the supplied SessionID will allow multi-user transaction safety on the

    // Server-Side: all database modification from another session will wait

    // for the global transaction to be finished; on Client-side, the SessionID

    // is just ignored (TSQLRestClient will override this method with a default

    // SessionID=CONST_AUTHENTICATION_NOT_USED=1 parameter)

    // - if you have an external database engine which expect transactions to

    // take place in the same thread, ensure TSQLRestServer force execution of

    // this method when accessed from RESTful clients in the same thread, e.g.:

    // ! AcquireExecutionMode[execORMWrite] := amBackgroundThread;

    // ! AcquireWriteMode := amBackgroundThread; // same as previous

    // - by default, any exception will be catch and ignored, unless RaiseException

    // is set to TRUE so that the caller would be able to handle it

    procedure Commit(SessionID: cardinal; RaiseException: boolean=false); virtual;

    /// abort a transaction

    // - implements REST ABORT collection

    // - restore the previous state of the database, before the call to TransactionBegin

    // - default implementation just reset the protected fTransactionActiveSession flag

    // - the supplied SessionID will allow multi-user transaction safety on the

    // Server-Side: all database modification from another session will wait

    // for the global transaction to be finished; on Client-side, the SessionID

    // is just ignored (TSQLRestClient will override this method with a default

    // SessionID=CONST_AUTHENTICATION_NOT_USED=1 parameter)

    // - if you have an external database engine which expect transactions to

    // take place in the same thread, ensure TSQLRestServer force execution of

    // this method when accessed from RESTful clients in the same thread, e.g.:

    // ! AcquireExecutionMode[execORMWrite] := amBackgroundThread;

    // ! AcquireWriteMode := amBackgroundThread; // same as previous

    procedure RollBack(SessionID: cardinal); virtual;

    /// execute a BATCH sequence prepared in a TSQLRestBatch instance

    // - implements the "Unit Of Work" pattern, i.e. safe transactional process

    // even on multi-thread environments

    // - send all pending Add/Update/Delete statements to the DB or remote server

    // - will return the URI Status value, i.e. 200/HTML_SUCCESS OK on success

    // - a dynamic array of integers will be created in Results,

    // containing all ROWDID created for each BatchAdd call, 200 (=HTML_SUCCESS)

    // for all successfull BatchUpdate/BatchDelete, or 0 on error

    // - any error during server-side process MUST be checked against Results[]

    // (the main URI Status is 200 if about communication success, and won't

    // imply that all statements in the BATCH sequence were successfull

    // - note that the caller shall still free the supplied Batch instance

    function BatchSend(Batch: TSQLRestBatch; var Results: TIDDynArray): integer; overload; virtual;

    /// execute a BATCH sequence prepared in a TSQLRestBatch instance

    // - just a wrapper around the overloaded BatchSend() method without the

    // Results: TIDDynArray parameter

    function BatchSend(Batch: TSQLRestBatch): integer; overload;



    {$ifdef ISDELPHI2010} // Delphi 2009 generics support is buggy :(

    /// get an instance of one interface-based service

    // - may return nil if this service interface is not available

    function Service<T: IInterface>: T;

    /// get a list of members from a SQL statement

    // - implements REST GET collection

    // - aCustomFieldsCSV can be the CSV list of field names to be retrieved

    // - if aCustomFieldsCSV is '', will get all simple fields, excluding BLOBs

    // - if aCustomFieldsCSV is '*', will get ALL fields, including ID and BLOBs

    // - return a TObjectList<T> on success (possibly with Count=0) - caller is

    // responsible of freeing the instance

    // - return nil on error

    // - you can write for instance:

    // !var List: TObjectList<TSQLRecordTest>;

    // !    R: TSQLRecordTest;

    // ! ...

    // !    List := Client.RetrieveList<TSQLRecordTest>('ID,Test');

    // !    if List<>nil then

    // !    try

    // !      for R in List do

    // !        writeln(R.ID,'=',R.Test);

    // !    finally

    // !      List.Free;

    // !    end;

    function RetrieveList<T: TSQLRecord>(const aCustomFieldsCSV: RawUTF8=''): TObjectList<T>; overload;

       {$ifdef HASINLINE}inline;{$endif}

    /// get a list of members from a SQL statement

    // - implements REST GET collection with a WHERE clause

    // - for better server speed, the WHERE clause should use bound parameters

    // identified as '?' in the FormatSQLWhere statement, which is expected to

    // follow the order of values supplied in BoundsSQLWhere open array - use

    // DateToSQL()/DateTimeToSQL() for TDateTime, or directly any integer,

    // double, currency, RawUTF8 values to be bound to the request as parameters

    // - aCustomFieldsCSV can be the CSV list of field names to be retrieved

    // - if aCustomFieldsCSV is '', will get all simple fields, excluding BLOBs

    // - if aCustomFieldsCSV is '*', will get ALL fields, including ID and BLOBs

    // - return a TObjectList<T> on success (possibly with Count=0) - caller is

    // responsible of freeing the instance

    // - return nil on error

    function RetrieveList<T: TSQLRecord>(const FormatSQLWhere: RawUTF8;

      const BoundsSQLWhere: array of const;

      const aCustomFieldsCSV: RawUTF8=''): TObjectList<T>; overload;

    {$endif}



    /// you can call this method in TThread.Execute to ensure that

    // the thread will be taken in account during process

    // - this abstract method won't do anything, but TSQLRestServer's will

    procedure BeginCurrentThread(Sender: TThread); virtual;

    /// you can call this method just before a thread is finished to ensure

    // e.g. that the associated external DB connection will be released

    // - this abstract method will call fLogClass.Add.NotifyThreadEnded

    // but TSQLRestServer.EndCurrentThread would do the main process

    procedure EndCurrentThread(Sender: TThread); virtual;

    /// allows to safely execute a processing method in a background thread

    // - returns a TSynBackgroundThreadMethod instance, ready to execute any

    // background task via its RunAndWait() method

    // - will properly call BeginCurrentThread/EndCurrentThread methods

    // - you should supply some runtime information to name the thread, for

    // proper debugging

    function NewBackgroundThreadMethod(const Format: RawUTF8; const Args: array of const): TSynBackgroundThreadMethod;

    /// allows to safely execute a process at a given pace

    // - returns a TSynBackgroundThreadProcess instance, ready to execute the

    // supplied aOnProcess event in a loop, as aOnProcessMS periodic task

    // - will properly call BeginCurrentThread/EndCurrentThread methods

    // - you should supply some runtime information to name the thread, for

    // proper debugging

    function NewBackgroundThreadProcess(aOnProcess: TOnSynBackgroundThreadProcess;

      aOnProcessMS: cardinal; const Format: RawUTF8; const Args: array of const;

      aStats: TSynMonitorClass=nil): TSynBackgroundThreadProcess;

    /// how this class execute its internal commands

    // - by default, TSQLRestServer.URI() will lock for Write ORM according to

    // AcquireWriteMode (i.e. AcquireExecutionMode[execORMWrite]=amLocked) and

    // other operations won't be protected (for better scaling)

    // - you can tune this behavior by setting this property to the expected

    // execution mode, e.g. execute all method-based services in a dedicated

    // thread via

    // ! aServer.AcquireExecutionMode[execSOAByMethod] := amBackgroundThread;

    // - if you use external DB and a custom ConnectionTimeOutMinutes value,

    // both read and write access should be locked, so you should set:

    // ! aServer.AcquireExecutionMode[execORMGet] := am***;

    // ! aServer.AcquireExecutionMode[execORMWrite] := am***;

    // here, safe blocking am*** modes are any mode but amUnlocked, i.e. either

    // amLocked, amBackgroundThread, amBackgroundORMSharedThread or amMainThread

    property AcquireExecutionMode[Cmd: TSQLRestServerURIContextCommand]: TSQLRestServerAcquireMode

      read GetAcquireExecutionMode write SetAcquireExecutionMode;

    /// the time (in mili seconds) to try locking internal commands of this class

    // - this value is used only for AcquireExecutionMode[*]=amLocked

    // - by default, TSQLRestServer.URI() will lock for Write ORM according to

    // AcquireWriteTimeOut  (i.e. AcquireExecutionLockedTimeOut[execORMWrite])

    // and other operations won't be locked nor have any time out set

    property AcquireExecutionLockedTimeOut[Cmd: TSQLRestServerURIContextCommand]: cardinal

      read GetAcquireExecutionLockedTimeOut write SetAcquireExecutionLockedTimeOut;

    /// how this class will handle write access to the database

    // - is a common wrapper to AcquireExecutionMode[execORMWrite] property

    // - default amLocked mode will wait up to AcquireWriteTimeOut mili seconds

    // to have a single access to the server write ORM methods

    // - amBackgroundThread will execute the write methods in a queue, in a

    // dedicated unique thread (which can be convenient, especially for

    // external database transaction process)

    // - amBackgroundORMSharedThread will execute all ORM methods in a queue, in

    // a dedicated unique thread, shared for both execORMWrite and execORMGet,

    // but still dedicated for execSOAByMethod and execSOAByInterface

    // - a slower alternative to amBackgroundThread may be amMainThread

    // - you can set amUnlocked for a concurrent write access, but be aware

    // that it may lead into multi-thread race condition issues, depending on

    // the database engine used

    property AcquireWriteMode: TSQLRestServerAcquireMode index execORMWrite

      read GetAcquireExecutionMode write SetAcquireExecutionMode;

    /// the time (in mili seconds) which the class will wait for acquiring a

    // write acccess to the database, when AcquireWriteMode is amLocked

    // - is a common wrapper to AcquireExecutionLockedTimeOut[execORMWrite]

    // - in order to handle safe transactions and multi-thread safe writing, the

    // server will identify transactions using the client Session ID: this

    // property will set the time out wait period

    // - default value is 2000, i.e. TSQLRestServer.URI will wait up to 2 seconds

    // in order to acquire the right to write on the database before returning

    // a "408 Request Time-out" status error

    property AcquireWriteTimeOut: cardinal index execORMWrite

      read GetAcquireExecutionLockedTimeOut write SetAcquireExecutionLockedTimeOut;



    /// used e.g. by IAdministratedDaemon to implement "pseudo-SQL" commands

    // - this default implementation will handle #time #model #rest commands

    procedure AdministrationExecute(const DatabaseName,SQL: RawUTF8;

      var result: TServiceCustomAnswer); virtual;

    /// access to the interface-based services list

    // - may be nil if no service interface has been registered yet: so be

    // aware that the following line may trigger an access violation if

    // no ICalculator is defined on server side:

    // ! if fServer.Services['Calculator'].Get(Calc)) then

    // !   ...

    // - safer typical use, following the DI/IoC pattern, and which would not

    // trigger any access violation if Services=nil, could be:

    // ! if fServer.Services.Resolve(ICalculator,Calc) then

    // !   ...

    property Services: TServiceContainer read fServices;

    /// access or initialize the internal IoC resolver, used for interface-based

    // remote services, and more generaly any Services.Resolve() call

    // - create and initialize the internal TServiceContainer if no service

    // interface has been registered yet    // - may be used to inject some dependencies, which are not interface-based

    // remote services, but internal IoC, without the ServiceRegister()

    // or ServiceDefine() methods - e.g.

    // ! aRest.ServiceContainer.InjectResolver([TInfraRepoUserFactory.Create(aRest)],true);

    // - overriden methods would return TServiceContainerClient or

    // TServiceContainerServer instances, on TSQLRestClient or TSQLRestServer

    function ServiceContainer: TServiceContainer; virtual; abstract;

    /// the routing classs of the service remote request

    // - by default, will use TSQLRestRoutingREST, i.e. an URI-based

    // layout which is secure (since will use our RESTful authentication scheme),

    // and also very fast

    // - but TSQLRestRoutingJSON_RPC can e.g. be set (on BOTH client and

    // server sides), if the client would rather use JSON/RPC alternative pattern

    // - NEVER set the abstract TSQLRestServerURIContext class on this property

    property ServicesRouting: TSQLRestServerURIContextClass

      read fRoutingClass write SetRoutingClass;

    /// the Database Model associated with this REST Client or Server

    property Model: TSQLModel read fModel;

  published

    /// the current UTC Date and Time, as retrieved from the server

    // - this property will return the timestamp as TTimeLog / Int64

    // after correction from the Server returned time-stamp (if any)

    // - is used e.g. by TSQLRecord.ComputeFieldsBeforeWrite to update TModTime

    // and TCreateTime published fields

    // - default implementation will return the executable UTC time, i.e. NowUTC

    // so that any GUI code should convert this UTC value into local time

    // - on TSQLRestServer, if you use an external database, the TSQLDBConnection

    // ServerTimeStamp value will be set to this property

    // - you can use this value in a WHERE clause for a query, as such:

    // ! aRec.CreateAndFillPrepare(Client,'Datum<=?',[TimeLogToSQL(Client.ServerTimeStamp)]);

    // - or you could use ServerTimeStamp everywhere in your code, when you need

    // a reference time base

    property ServerTimeStamp: TTimeLog read GetServerTimeStamp write SetServerTimeStamp;

    {$ifdef WITHLOG}

    /// the logging class used for this instance

    // - is set by default to SQLite3Log, but could be set to a custom class

    property LogClass: TSynLogClass read GetLogClass write SetLogClass;

    {$endif}

  public

    /// the custom queries parameters for User Interface Query action

    QueryCustom: array of TSQLQueryCustom;

    /// evaluate a basic operation for implementing User Interface Query action

    // - expect both Value and Reference to be UTF-8 encoded (as in TSQLTable

    // or TSQLTableToGrid)

    // - aID parameter is ignored in this function implementation (expect only

    // this parameter to be not equal to 0)

    // - is TSQLQueryEvent prototype compatible

    // - for qoContains and qoBeginWith, the Reference is expected to be

    // already uppercase

    // - for qoSoundsLike* operators, Reference is not a PUTF8Char, but a

    // typecase of a prepared TSynSoundEx object instance (i.e. pointer(@SoundEx))

    class function QueryIsTrue(aTable: TSQLRecordClass; aID: TID;

      FieldType: TSQLFieldType; Value: PUTF8Char; Operator: integer;

      Reference: PUTF8Char): boolean;

    /// add a custom query

    // - one event handler with an enumeration type containing all available

    // query names

    // - and associated operators

    procedure QueryAddCustom(aTypeInfo: pointer; aEvent: TSQLQueryEvent;

      const aOperators: TSQLQueryOperators);

  end;



  {$M+}

  /// a simple TThread for doing some process within the context of a REST instance

  // - also define a Start method for compatibility with older versions of Delphi

  // - inherited classes should override InternalExecute abstract method

  TSQLRestThread = class(TThread)

  protected

    fRest: TSQLRest;

    fOwnRest: boolean;

    fLog: TSynLog;

    fSafe: TSynLocker;

    /// will call BeginCurrentThread/EndCurrentThread and catch exceptions

    procedure Execute; override;

    /// you should override this method with the proper process

    procedure InternalExecute; virtual; abstract;

  public

    /// initialize the thread

    // - if aOwnRest is TRUE, the supplied REST instance would be

    // owned by this thread

    constructor Create(aRest: TSQLRest; aOwnRest, aCreateSuspended: boolean);

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

    /// finalize the thread

    // - and the associated REST instance if OwnRest is TRUE

    destructor Destroy; override;

    /// safe version of Sleep() which won't break the thread process

    // - returns TRUE if the thread was Terminated

    // - returns FALSE if successfully waited up to MS milliseconds

    function SleepOrTerminated(MS: integer): boolean;

    /// read-only access to the associated REST instance

    property Rest: TSQLRest read FRest;

    /// TRUE if the associated REST instance would be owned by this thread

    property OwnRest: boolean read fOwnRest;

    /// a critical section is associated to this thread

    // - could be used to protect shared resources within the internal process

    property Safe: TSynLocker read fSafe;

    /// read-only access to the TSynLog instance of the associated REST instance 

    property Log: TSynLog read fLog;

    /// publishes the thread running state

    property Terminated;

  end;

  {$M-} 



  /// event signature used to notify a client callback

  // - implemented e.g. by TSQLHttpServer.NotifyCallback

  TSQLRestServerNotifyCallback = function(aSender: TSQLRestServer;

    const aInterfaceDotMethodName,aParams: RawUTF8;

    aConnectionID: Int64; aFakeCallID: integer;

    aResult, aErrorMsg: PRawUTF8): boolean of object;



  /// event signature used by TSQLRestServer.OnServiceCreateInstance

  // - as called by TServiceFactoryServer.CreateInstance

  // - the actual Instance class can be quickly retrieved from

  // Sender.ImplementationClass

  TOnServiceCreateInstance = procedure(

    Sender: TServiceFactoryServer; Instance: TInterfacedObject) of object;



{$ifdef MSWINDOWS}

  /// Server thread accepting connections from named pipes

  TSQLRestServerNamedPipe = class(TSQLRestThread)

  private

  protected

    fServer: TSQLRestServer;

    fChild: TList;

    fChildCount: integer;

    fPipeName: TFileName;

    procedure InternalExecute; override;

  public

    /// create the server thread

    constructor Create(aServer: TSQLRestServer; const PipeName: TFileName); reintroduce;

    /// release all associated memory, and wait for all

    // TSQLRestServerNamedPipeResponse children to be terminated

    destructor Destroy; override;

    /// the associated pipe name

    property PipeName: TFileName read fPipeName;

  end;



  /// Server child thread dealing with a connection through a named pipe

  TSQLRestServerNamedPipeResponse = class(TSQLRestThread)

  private

  protected

    fServer: TSQLRestServer;

    fPipe: cardinal;

    fMasterThread: TSQLRestServerNamedPipe;

    fMasterThreadChildIndex: Integer;

    procedure InternalExecute; override;

  public

    /// create the child connection thread

    constructor Create(aServer: TSQLRestServer; aMasterThread: TSQLRestServerNamedPipe;

      aPipe: cardinal); reintroduce;

    /// release all associated memory, and decrement fMasterThread.fChildCount

    destructor Destroy; override;

  end;



{$ifdef FPC}

  TWMCopyData = record

    Msg: UINT;

    From: WPARAM;

    CopyDataStruct: LPARAM;

    Result: LRESULT;

  end;

{$endif}

{$endif}



  /// function prototype for remotely calling a TSQLRestServer

  // - use PUTF8Char instead of string: no need to share a memory manager, and can

  // be used with any language (even C or .NET, thanks to the cdecl calling convention)

  // - you can specify some POST/PUT data in SendData (leave as nil otherwise)

  // - returns in result.Lo the HTTP STATUS integer error or success code

  // - returns in result.Hi the server database internal status

  // - on success, allocate and store the resulting JSON body into Resp^, headers in Head^

  // - use a GlobalFree() function to release memory for Resp and Head responses

  TURIMapRequest = function(url, method, SendData: PUTF8Char; Resp, Head: PPUTF8Char): Int64Rec; cdecl;



  TSQLRestServerAuthentication = class;



  /// structure used to specify custom request paging parameters for TSQLRestServer

  // - default values are the one used for YUI component paging (i.e.

  // PAGINGPARAMETERS_YAHOO constant, as set by TSQLRestServer.Create)

  // - warning: using paging can be VERY expensive on Server side, especially

  // when used with external databases (since all data is retrieved before

  // paging, when SQLite3 works in virtual mode)

  TSQLRestServerURIPagingParameters = record

    /// parameter name used to specify the request sort order

    // - default value is 'SORT='

    Sort: PAnsiChar;

    /// parameter name used to specify the request sort direction

    // - default value is 'DIR='

    Dir: PAnsiChar;

    /// parameter name used to specify the request starting offset

    // - default value is 'STARTINDEX='

    StartIndex: PAnsiChar;

    /// parameter name used to specify the request the page size (LIMIT clause)

    // - default value is 'RESULTS='

    Results: PAnsiChar;

    /// parameter name used to specify the request field names

    // - default value is 'SELECT='

    Select: PAnsiChar;

    /// parameter name used to specify the request WHERE clause

    // - default value is 'WHERE='

    Where: PAnsiChar;

    /// returned JSON field value of optional total row counts

    // - default value is nil, i.e. no total row counts field

    // - computing total row counts can be very expensive, depending on the

    // database back-end used (especially for external databases)

    // - can be set e.g. to ',"totalRows":%' value (note that the initial "," is

    // expected by the produced JSON content, and % will be set with the value)

    SendTotalRowsCountFmt: RawUTF8;

  end;



  ///  used to define how to trigger Events on record update

  // - see TSQLRestServer.OnUpdateEvent property and InternalUpdateEvent() method

  // - returns true on success, false if an error occured (but action must continue)

  // - to be used only server-side, not to synchronize some clients: the framework

  // is designed around a stateless RESTful architecture (like HTTP/1.1), in which

  // clients ask the server for refresh (see TSQLRestClientURI.UpdateFromServer)

  TNotifySQLEvent = function(Sender: TSQLRestServer; Event: TSQLEvent;

    aTable: TSQLRecordClass; const aID: TID; const aSentData: RawUTF8): boolean of object;

  ///  used to define how to trigger Events on record field update

  // - see TSQLRestServer.OnBlobUpdateEvent property and InternalUpdateEvent() method

  // - returns true on success, false if an error occured (but action must continue)

  // - to be used only server-side, not to synchronize some clients: the framework

  // is designed around a stateless RESTful architecture (like HTTP/1.1), in which

  // clients ask the server for refresh (see TSQLRestClientURI.UpdateFromServer)

  TNotifyFieldSQLEvent = function(Sender: TSQLRestServer; Event: TSQLEvent;

    aTable: TSQLRecordClass; const aID: TID; const aAffectedFields: TSQLFieldBits): boolean of object;

  /// session-related callbacks triggered by TSQLRestServer

  // - for OnSessionCreate, returning TRUE will abort the session creation -

  // and you can set Ctxt.Call^.OutStatus to a corresponding error code

  TNotifySQLSession = function(Sender: TSQLRestServer; Session: TAuthSession;

    Ctxt: TSQLRestServerURIContext): boolean of object;

  /// callback allowing to customize the retrieval of an authenticated user

  // - as defined in TSQLRestServer.OnAuthenticationUserRetrieve

  // - and executed by TSQLRestServerAuthentication.GetUser

  // - on call, either aUserID would be <> 0, or aUserName is to be used

  // - if the function returns nil, default Server.SQLAuthUserClass.Create()

  // methods won't be called, and the user will be reported as not found

  TOnAuthenticationUserRetrieve = function(Sender: TSQLRestServerAuthentication;

    Ctxt: TSQLRestServerURIContext; aUserID: TID; const aUserName: RawUTF8): TSQLAuthUser of object;

  /// callback raised in case of authentication failure

  // - as used by TSQLRestServerURIContext.AuthenticationFailed event

  TNotifyAuthenticationFailed = procedure(Sender: TSQLRestServer;

    Reason: TNotifyAuthenticationFailedReason; Session: TAuthSession;

    Ctxt: TSQLRestServerURIContext) of object;

  /// callback raised before TSQLRestServer.URI execution

  // - should return TRUE to execute the command, FALSE to cancel it

  TNotifyBeforeURI = function(Ctxt: TSQLRestServerURIContext): boolean of object;

  /// callback raised after TSQLRestServer.URI execution

  TNotifyAfterURI = procedure(Ctxt: TSQLRestServerURIContext) of object;

  /// callback raised if TSQLRestServer.URI execution failed

  // - should return TRUE to execute Ctxt.Error(E,...), FALSE if returned

  // content has already been set as expected by the client

  TNotifyErrorURI = function(Ctxt: TSQLRestServerURIContext; E: Exception): boolean of object;



  TSQLRestStorageInMemory = class;

  TSQLVirtualTableModule = class;



  /// class-reference type (metaclass) of our abstract table storage

  // - may be e.g. TSQLRestStorageInMemory, TSQLRestStorageInMemoryExternal,

  // TSQLRestStorageExternal or TSQLRestStorageMongoDB

  TSQLRestStorageClass = class of TSQLRestStorage;



  /// class-reference type (metaclass) of our TObjectList memory-stored table storage

  // - may be TSQLRestStorageInMemory or TSQLRestStorageInMemoryExternal

  TSQLRestStorageInMemoryClass = class of TSQLRestStorageInMemory;



  /// table containing the available user access rights for authentication

  // - this class should be added to the TSQLModel, together with TSQLAuthUser,

  // to allow authentication support

  // - you can inherit from it to add your custom properties to each user info:

  // TSQLModel will search for any class inheriting from TSQLAuthGroup to

  // manage per-group authorization data

  // - by default, it won't be accessible remotely by anyone

  TSQLAuthGroup = class(TSQLRecord)

  private

    fIdent: RawUTF8;

    fSessionTimeOut: integer;

    fAccessRights: RawUTF8;

    function GetSQLAccessRights: TSQLAccessRights;

    procedure SetSQLAccessRights(const Value: TSQLAccessRights);

  public

    /// called when the associated table is created in the database

    // - on a new database, if TSQLAuthUser and TSQLAuthGroup tables are defined

    // in the associated TSQLModel, it this will add 'Admin', 'Supervisor',

    // and 'User' rows in the AuthUser table (with 'synopse' as default password),

    // and associated 'Admin', 'Supervisor', 'User' and 'Guest' groups, with the

    // following access rights to the AuthGroup table:

    // $            POSTSQL SELECTSQL Service AuthR AuthW TablesR TablesW

    // $ Admin        Yes     Yes       Yes    Yes   Yes    Yes    Yes

    // $ Supervisor   No      Yes       Yes    Yes   No     Yes    Yes

    // $ User         No      No        Yes    No    No     Yes    Yes

    // $ Guest        No      No        No     No    No     Yes    No

    // - 'Admin' will be the only able to execute remote not SELECT SQL statements

    // for POST commands (reSQL flag in TSQLAccessRights.AllowRemoteExecute) and

    // modify the Auth tables (i.e. AuthUser and AuthGroup)

    // - 'Admin' and 'Supervisor' will allow any SELECT SQL statements to be

    // executed, even if the table can't be retrieved and checked (corresponding

    // to the reSQLSelectWithoutTable flag)

    // - 'User' won't have the reSQLSelectWithoutTable flag, nor the right

    // to retrieve the Auth tables data for other users

    // - 'Guest' won't have access to the interface-based remote JSON-RPC service

    // (no reService flag), nor perform any modification to a table: in short,

    // this is an ORM read-only limited user

    // - you MUST override the default 'synopse' password to a custom value,

    // or at least customize the global AuthAdminDefaultPassword,

    // AuthSupervisorDefaultPassword, AuthUserDefaultPassword variables

    // - of course, you can change and tune the settings of the AuthGroup and

    // AuthUser tables, but only 'Admin' group users will be able to remotely

    // modify the content of those two tables

    class procedure InitializeTable(Server: TSQLRestServer; const FieldName: RawUTF8;

      Options: TSQLInitializeTableOptions); override;

    /// corresponding TSQLAccessRights for this authentication group

    // - content is converted into/from text format via AccessRight DB property

    // (so it will be not fixed e.g. by the binary TSQLFieldTables layout, i.e.

    // the MAX_SQLTABLES constant value)

    property SQLAccessRights: TSQLAccessRights read GetSQLAccessRights write SetSQLAccessRights;

  published

    /// the access right identifier, ready to be displayed

    // - the same identifier can be used only once (this column is marked as

    // unique via a "stored AS_UNIQUE" (i.e. "stored false") attribute)

    // - so you can retrieve a TSQLAuthGroup ID from its identifier, as such:

    // ! UserGroupID := fClient.MainFieldID(TSQLAuthGroup,'User');

    property Ident: RawUTF8 index 50 read fIdent write fIdent stored AS_UNIQUE;

    /// the number of minutes a session is kept alive

    property SessionTimeout: integer read fSessionTimeOut write fSessionTimeOut;

    /// a textual representation of a TSQLAccessRights buffer

    property AccessRights: RawUTF8 index 1600 read fAccessRights write fAccessRights;

  end;



  /// class-reference type (metaclass) of the table containing the available

  // user access rights for authentication, defined as a group

  TSQLAuthGroupClass = class of TSQLAuthGroup;



  /// table containing the Users registered for authentication

  // - this class should be added to the TSQLModel, together with TSQLAuthGroup,

  // to allow authentication support

  // - you can inherit from it to add your custom properties to each user info:

  // TSQLModel will search for any class inheriting from TSQLAuthUser to manage

  // per-user authorization data

  // - by default, it won't be accessible remotely by anyone; to enhance security,

  // you could use the TSynValidatePassWord filter to this table

  TSQLAuthUser = class(TSQLRecord)

  protected

    fLogonName: RawUTF8;

    fPasswordHashHexa: RawUTF8;

    fDisplayName: RawUTF8;

    fGroup: TSQLAuthGroup;

    fData: TSQLRawBlob;

    procedure SetPasswordPlain(const Value: RawUTF8); 

    /// check if the user can authenticate in its current state

    // - called by TSQLRestServerAuthentication.GetUser() method

    // - this default implementation will return TRUE, i.e. allow the user

    // to log on

    // - override this method to disable user authentication, e.g. if the

    // user is disabled via a custom ORM boolean and date/time field

    function CanUserLog(Ctxt: TSQLRestServerURIContext): boolean; virtual;

  public

    /// static function allowing to compute a hashed password

    // - as expected by this class

    // - defined as virtual so that you may use your own hashing class

    // - you may specify your own values in aHashSalt/aHashRound, to enable

    // PBKDF2_HMAC_SHA256() use instead of plain SHA256(): it would increase

    // security on storage side (reducing brute force attack via rainbow tables)

    class function ComputeHashedPassword(const aPasswordPlain: RawUTF8;

      const aHashSalt: RawUTF8=''; aHashRound: integer=20000): RawUTF8; virtual;

    /// able to set the PasswordHashHexa field from a plain password content

    // - in fact, PasswordHashHexa := SHA256('salt'+PasswordPlain) in UTF-8

    // - use SetPassword() method if you want to customize the hash salt value

    property PasswordPlain: RawUTF8 write SetPasswordPlain;

    /// set the PasswordHashHexa field from a plain password content and salt

    // - use this method to specify aHashSalt/aHashRound values, enabling

    // PBKDF2_HMAC_SHA256() use instead of plain SHA256(): it would increase

    // security on storage side (reducing brute force attack via rainbow tables)

    // - you may use an application specific fixed salt, and/or append the

    // user LogonName to make the challenge unique for each TSQLAuthUser

    // - the default aHashRound=20000 is slow but secure - since the hashing

    // process is expected to be done on client side, you may specify your

    // own higher/slower value, depending on the security level you expect

    procedure SetPassword(const aPasswordPlain, aHashSalt: RawUTF8;

      aHashRound: integer=20000);

  published

    /// the User identification Name, as entered at log-in

    // - the same identifier can be used only once (this column is marked as

    // unique via a "stored AS_UNIQUE" - i.e. "stored false" - attribute), and

    // therefore indexed in the database (e.g. hashed in TSQLRestStorageInMemory)

    property LogonName: RawUTF8 index 20 read fLogonName write fLogonName stored AS_UNIQUE;

    /// the User Name, as may be displayed or printed

    property DisplayName: RawUTF8 index 50 read fDisplayName write fDisplayName;

    /// the hexa encoded associated SHA-256 hash of the password

    // - see TSQLAuthUser.ComputeHashedPassword() or SetPassword() methods

    // - store the SHA-256 32 bytes as 64 hexa chars

    property PasswordHashHexa: RawUTF8 index 64 read fPasswordHashHexa write fPasswordHashHexa;

    /// the associated access rights of this user

    // - access rights are managed by group

    // - in TAuthSession.User instance, GroupRights property will contain a

    // REAL TSQLAuthGroup instance for fast retrieval in TSQLRestServer.URI

    // - note that 'Group' field name is not allowed by SQLite

    property GroupRights: TSQLAuthGroup read fGroup write fGroup;

    /// some custom data, associated to the User

    // - Server application may store here custom data

    // - its content is not used by the framework but 'may' be used by your

    // application

    property Data: TSQLRawBlob read fData write fData;

  end;



  /// class-reference type (metaclass) of a table containing the Users

  // registered for authentication

  // - see also TSQLRestServer.OnAuthenticationUserRetrieve custom event

  TSQLAuthUserClass = class of TSQLAuthUser;



  /// class used to maintain in-memory sessions

  // - this is not a TSQLRecord table so won't be remotely accessible, for

  // performance and security reasons

  // - the User field is a true instance, copy of the corresponding database

  // content (for better speed)

  // - you can inherit from this class, to add custom session process

  TAuthSession = class(TSynPersistent)

  protected

    fUser: TSQLAuthUser;

    fLastAccess64: Int64;

    fID: RawUTF8;

    fIDCardinal: cardinal;

    fTimeOutMS: cardinal;

    fAccessRights: TSQLAccessRights;

    fPrivateKey: RawUTF8;

    fPrivateSalt: RawUTF8;

    fSentHeaders: RawUTF8;

    fRemoteIP: RawUTF8;

    fPrivateSaltHash: Cardinal;

    fLastTimeStamp: Cardinal;

    fExpectedHttpAuthentication: RawUTF8;

    fMethods: TSynMonitorInputOutputObjArray;

    fInterfaces: TSynMonitorInputOutputObjArray;

    function GetUserName: RawUTF8;

    function GetUserID: TID;

    function GetGroupID: TID;

    procedure SaveTo(W: TFileBufferWriter); virtual;

    procedure ComputeProtectedValues; virtual;

    constructor CreateFrom(var P: PAnsiChar; Server: TSQLRestServer); virtual;

  public

    /// initialize a session instance with the supplied TSQLAuthUser instance

    // - this aUser instance will be handled by the class until Destroy

    // - raise an exception on any error

    // - on success, will also retrieve the aUser.Data BLOB field content

    constructor Create(aCtxt: TSQLRestServerURIContext; aUser: TSQLAuthUser); reintroduce; virtual;

    /// will release the User and User.GroupRights instances

    destructor Destroy; override;

  public

    /// the session ID number, as numerical value

    // - never equals to 1 (CONST_AUTHENTICATION_NOT_USED, i.e. authentication

    // mode is not enabled), nor 0 (CONST_AUTHENTICATION_SESSION_NOT_STARTED,

    // i.e. session still in handshaking phase)

    property IDCardinal: cardinal read fIDCardinal;

    /// the associated User

    // - this is a true TSQLAuthUser instance, and User.GroupRights will contain

    // also a true TSQLAuthGroup instance

    property User: TSQLAuthUser read fUser;

    /// set by the Access() method to the current GetTickCount64() time stamp

    property LastAccess64: Int64 read fLastAccess64;

    /// copy of the associated user access rights

    // - extracted from User.TSQLAuthGroup.SQLAccessRights

    property AccessRights: TSQLAccessRights read fAccessRights;

    /// the hexadecimal private key as returned to the connected client

    // as 'SessionID+PrivateKey'

    property PrivateKey: RawUTF8 read fPrivateKey;

    /// the transmitted HTTP headers, if any

    // - can contain e.g. 'RemoteIp: 127.0.0.1' or 'User-Agent: Mozilla/4.0'

    property SentHeaders: RawUTF8 read fSentHeaders;

    /// per-session statistics about method-based services

    // - Methods[] follows TSQLRestServer.fPublishedMethod[] array

    // - is initialized and maintained only if mlSessions is defined in

    // TSQLRestServer.StatLevels property

    property Methods: TSynMonitorInputOutputObjArray read fMethods;

    /// per-session statistics about interface-based services

    // - Interfaces[] follows TSQLRestServer.Services.fListInterfaceMethod[] array

    // - is initialized and maintained only if mlSessions is defined in

    // TSQLRestServer.StatLevels property

    property Interfaces: TSynMonitorInputOutputObjArray read fInterfaces;

  published

    /// the session ID number, as text

    property ID: RawUTF8 read fID;

    /// the associated User Name, as in User.LogonName

    property UserName: RawUTF8 read GetUserName;

    /// the associated User ID, as in User.ID

    property UserID: TID read GetUserID;

    /// the associated Group ID, as in User.GroupRights.ID

    property GroupID: TID read GetGroupID;

    /// the number of milliseconds a session is kept alive

    // - extracted from User.TSQLAuthGroup.SessionTimeout

    // - allow direct comparison with GetTickCount64() API call

    property TimeoutMS: cardinal read fTimeOutMS;

    /// the remote IP, if any

    // - is extracted from SentHeaders properties

    property RemoteIP: RawUTF8 read fRemoteIP;

  end;



  /// class-reference type (metaclass) used to define overridden session instances

  // - since all sessions data remain in memory, ensure they are not taking too

  // much resource (memory or process time)

  // - if you plan to use session persistence, ensure you override the

  // TAuthSession.SaveTo/CreateFrom methods in the inherited class

  TAuthSessionClass = class of TAuthSession;



  /// class-reference type (metaclass) used to define an authentication scheme

  TSQLRestServerAuthenticationClass = class of TSQLRestServerAuthentication;



  /// maintain a list of TSQLRestServerAuthentication instances

  TSQLRestServerAuthenticationDynArray = array of TSQLRestServerAuthentication;



  /// define how TSQLRestServerAuthentication.ClientSetUser() should interpret

  // the supplied password

  // - passClear means that the password is not encrypted, e.g. as entered

  // by the user in the login screen

  // - passHashed means that the passwod is already hashed as in

  // TSQLAuthUser.PasswordHashHexa i.e. SHA256('salt'+Value)

  // - passKerberosSPN indicates that the password is the Kerberos SPN domain

  TSQLRestServerAuthenticationClientSetUserPassword = (

    passClear, passHashed, passKerberosSPN);



  /// optional behavior of TSQLRestServerAuthentication class

  // - by default, saoUserByLogonOrID is set, allowing

  // TSQLRestServerAuthentication.GetUser() to retrieve the TSQLAuthUser by

  // logon name or by ID, if the supplied logon name is an integer

  // - if saoHandleUnknownLogonAsStar is defined, any user successfully

  // authenticated could be logged with the same ID (and authorization)

  // than TSQLAuthUser.Logon='*' - of course, this is meaningfull only with

  // an external credential check (e.g. via SSPI or Active Directory)

  TSQLRestServerAuthenticationOption = (

    saoUserByLogonOrID, saoHandleUnknownLogonAsStar);



  /// defines the optional behavior of TSQLRestServerAuthentication class

  TSQLRestServerAuthenticationOptions = set of TSQLRestServerAuthenticationOption;



  /// abstract class used to implement server-side authentication in TSQLRestServer

  // - inherit from this class to implement expected authentication scheme

  TSQLRestServerAuthentication = class

  protected

    fServer: TSQLRestServer;

    fOptions: TSQLRestServerAuthenticationOptions;

    // GET ModelRoot/auth?UserName=...&Session=... -> release session

    function AuthSessionRelease(Ctxt: TSQLRestServerURIContext): boolean;

    /// retrieve an User instance from its logon name

    // - should return nil if not found

    // - this default implementation will retrieve it from ORM, and

    // call TSQLAuthUser.CanUserLog() to ensure authentication is allowed

    // - if aUserName is an integer, it will try to retrieve it from ORM using

    // the supplied value as its TSQLAuthUser.ID: it may be convenient when the

    // client is not an end-user application but a mORMot server (in a cloud

    // architecture), since it would benefit from local ORM cache

    // - you can override this method and return an on-the-fly created value

    // as a TSQLRestServer.SQLAuthUserClass instance (i.e. not persisted

    // in database nor retrieved by ORM), but the resulting TSQLAuthUser

    // must have its ID and LogonName properties set with unique values (which

    // will be used to identify it for a later call and session owner

    // identification), and its GroupRights property must not yet contain a real

    // TSQLAuthGroup instance, just a TSQLAuthGroup(aGroupID) value (as directly

    // retrieved from the ORM) - TAuthSession.Create will retrieve the instance

    // - another possibility, orthogonal to all TSQLRestServerAuthentication

    // classes, may be to define a TSQLRestServer.OnAuthenticationUserRetrieve

    // custom event

    function GetUser(Ctxt: TSQLRestServerURIContext;

      const aUserName: RawUTF8): TSQLAuthUser; virtual;

    /// create a session on the server for a given user

    // - this default implementation will call fServer.SessionCreate() and

    // return a '{"result":"HEXASALT","logonname":"UserName"}' JSON content

    // and will always call User.Free

    // - on failure, will call TSQLRestServerURIContext.AuthenticationFailed()

    // with afSessionAlreadyStartedForThisUser or afSessionCreationAborted reason

    procedure SessionCreate(Ctxt: TSQLRestServerURIContext; var User: TSQLAuthUser); virtual;

    /// abstract method which will be called by ClientSetUser() to process the

    // authentication step on the client side

    // - at call, a TSQLAuthUser instance will be supplied, with LogonName set

    // with aUserName and PasswordHashHexa with a SHA-256 hash of aPassword

    // - override with the expected method, returning the session key on success

    class function ClientComputeSessionKey(Sender: TSQLRestClientURI;

      User: TSQLAuthUser): RawUTF8; virtual; abstract;

    /// is called by ClientComputeSessionKey() overriden method to execute the

    // root/Auth service with the supplied parameters, then retrieve and

    // decode the "result": session key and any other values (e.g. "version")

    class function ClientGetSessionKey(Sender: TSQLRestClientURI;

      User: TSQLAuthUser; const aNameValueParameters: array of const): RawUTF8; virtual;

  public

    /// initialize the authentication method to a specified server

    // - you can define several authentication schemes for the same server

    constructor Create(aServer: TSQLRestServer); virtual;

    /// called by the Server to implement the Auth RESTful method

    // - overridden method shall return TRUE if the request has been handled

    // - returns FALSE to let the next registered TSQLRestServerAuthentication

    // class to try implementing the content

    // - Ctxt.Parameters has been tested to contain an UserName=... value

    // - method execution is protected by TSQLRestServer.fSessions.Lock

    function Auth(Ctxt: TSQLRestServerURIContext): boolean; virtual; abstract;

    /// called by the Server to check if the execution context match a session

    // - returns a session instance corresponding to the remote request

    // - returns nil if this remote request does not match this authentication

    // - method execution is protected by TSQLRestServer.fSessions.Lock

    function RetrieveSession(Ctxt: TSQLRestServerURIContext): TAuthSession; virtual; abstract;

    /// allow to tune the authentication process

    // - default value is [saoUserByLogonOrID]

    property Options: TSQLRestServerAuthenticationOptions read fOptions write fOptions;

    /// class method to be used on client side to create a remote session

    // - call this method instead of TSQLRestClientURI.SetUser() if you need

    // a custom authentication class

    // - if saoUserByLogonOrID is defined in the server Options, aUserName may

    // be a TSQLAuthUser.ID and not a TSQLAuthUser.LogonName

    // - if passClear is used, you may specify aHashSalt and aHashRound,

    // to enable PBKDF2_HMAC_SHA256() use instead of plain SHA256(), and increase

    // security on storage side (reducing brute force attack via rainbow tables)

    // - will call the ModelRoot/Auth service, i.e. call TSQLRestServer.Auth()

    // published method to create a session for this user

    // - returns true on success

    class function ClientSetUser(Sender: TSQLRestClientURI;

      const aUserName, aPassword: RawUTF8;

      aPasswordKind: TSQLRestServerAuthenticationClientSetUserPassword=passClear;

      const aHashSalt: RawUTF8=''; aHashRound: integer=20000): boolean; virtual;

    /// class method to be called on client side to sign an URI

    // - used by TSQLRestClientURI.URI()

    // - shall match the method as expected by RetrieveSession() virtual method

    class procedure ClientSessionSign(Sender: TSQLRestClientURI;

      var Call: TSQLRestURIParams); virtual; abstract;

  end;



  /// weak authentication scheme using URL-level parameter

  TSQLRestServerAuthenticationURI = class(TSQLRestServerAuthentication)

  public

    /// will check URI-level signature

    // - retrieve the session ID from 'session_signature=...' parameter

    function RetrieveSession(Ctxt: TSQLRestServerURIContext): TAuthSession; override;

    /// class method to be called on client side to add the SessionID to the URI

    // - append '&session_signature=SessionID' to the url

    class procedure ClientSessionSign(Sender: TSQLRestClientURI;

      var Call: TSQLRestURIParams); override;

  end;



  /// secure authentication scheme using URL-level digital signature

  // - expected format of session_signature is

  // !Hexa8(SessionID)+

  // !Hexa8(TimeStamp)+

  // !Hexa8(crc32('SessionID+HexaSessionPrivateKey'+Sha256('salt'+PassWord)+

  // !            Hexa8(TimeStamp)+url))

  TSQLRestServerAuthenticationSignedURI = class(TSQLRestServerAuthenticationURI)

  protected

    fNoTimeStampCoherencyCheck: Boolean;

    fTimeStampCoherencySeconds: cardinal;

    procedure SetNoTimeStampCoherencyCheck(value: boolean);

  public

    /// initialize the authentication method to a specified server

    constructor Create(aServer: TSQLRestServer); override;

    /// will check URI-level signature

    // - check session_signature=... parameter to be a valid digital signature

    function RetrieveSession(Ctxt: TSQLRestServerURIContext): TAuthSession; override;

    /// class method to be called on client side to sign an URI

    // - generate the digital signature as expected by overridden RetrieveSession()

    // - timestamp resolution is about 256 ms in the current implementation

    class procedure ClientSessionSign(Sender: TSQLRestClientURI;

      var Call: TSQLRestURIParams); override;

    /// allow any order when creating sessions

    // - by default, signed sessions are expected to be sequential, and new

    // signed session signature can't be older in time than the last one,

    // with a tolerance of TimeStampCoherencySeconds

    // - but if your client is asynchronous (e.g. for AJAX requests), session

    // may be rejected due to the delay involved on the client side: you can set

    // this property to TRUE to enabled a weaker but more tolerant behavior

    // ! (aServer.AuthenticationRegister(TSQLRestServerAuthenticationDefault) as

    // !   TSQLRestServerAuthenticationSignedURI).NoTimeStampCoherencyCheck := true;

    property NoTimeStampCoherencyCheck: Boolean read fNoTimeStampCoherencyCheck

      write SetNoTimeStampCoherencyCheck;

    /// time tolerance in seconds for the signature timestamps coherency check

    // - by default, signed sessions are expected to be sequential, and new

    // signed session signature can't be older in time than the last one,

    // with a tolerance time defined by this property

    // - default value is 5 seconds, which cover most kind of clients (AJAX or

    // WebSockets), even over a slow Internet connection

    property TimeStampCoherencySeconds: cardinal read fTimeStampCoherencySeconds

      write fTimeStampCoherencySeconds;

  end;



  /// mORMot secure RESTful authentication scheme

  // - this method will use a password stored via safe SHA-256 hashing in the

  // TSQLAuthUser ORM table

  TSQLRestServerAuthenticationDefault = class(TSQLRestServerAuthenticationSignedURI)

  protected

    /// check a supplied password content

    // - will match ClientComputeSessionKey() algorithm as overridden here, i.e.

    // a SHA-256 based signature with a 10 minutes activation window

    function CheckPassword(Ctxt: TSQLRestServerURIContext;

      User: TSQLAuthUser; const aClientNonce, aPassWord: RawUTF8): boolean; virtual;

    /// class method used on client side to create a remote session

    // - will call the ModelRoot/Auth service, i.e. call TSQLRestServer.Auth()

    // published method to create a session for this user: so

    // TSQLRestServerAuthenticationDefault should be registered on server side

    // - User.LogonName and User.PasswordHashHexa will be checked

    class function ClientComputeSessionKey(Sender: TSQLRestClientURI;

      User: TSQLAuthUser): RawUTF8; override;

  public

    /// will try to handle the Auth RESTful method with mORMot authentication

    // - to be called in a two pass "challenging" algorithm:

    // $ GET ModelRoot/auth?UserName=...

    // $  -> returns an hexadecimal nonce contents (valid for 5 minutes)

    // $ GET ModelRoot/auth?UserName=...&PassWord=...&ClientNonce=...

    // $ -> if password is OK, will open the corresponding session

    // $    and return 'SessionID+HexaSessionPrivateKey'

    // The Password parameter as sent for the 2nd request will be computed as

    // ! Sha256(ModelRoot+Nonce+ClientNonce+UserName+Sha256('salt'+PassWord))

    // - the returned HexaSessionPrivateKey content will identify the current

    // user logged and its corresponding session (the same user may have several

    // sessions opened at once, each with its own private key)

    // - then the private session key must be added to every query sent to

    // the server as a session_signature=???? parameter, which will be computed

    // as such:

    // $ ModelRoot/url?A=1&B=2&session_signature=012345670123456701234567

    // were the session_signature= parameter will be computed as such:

    // ! Hexa8(SessionID)+Hexa8(TimeStamp)+

    // ! Hexa8(crc32('SessionID+HexaSessionPrivateKey'+Sha256('salt'+PassWord)+

    // !  Hexa8(TimeStamp)+url))

    // ! with url='ModelRoot/url?A=1&B=2'

    // this query authentication uses crc32 for hashing instead of SHA-256 in

    // in order to lower the Server-side CPU consumption; the salted password

    // (i.e. TSQLAuthUser.PasswordHashHexa) and client-side TimeStamp are

    // inserted inside the session_signature calculation to prevent naive

    // man-in-the-middle attack (MITM)

    // - the session ID will be used to retrieve the rights associated with the

    // user which opened the session via a successful call to the Auth service

    // - when you don't need the session any more (e.g. if the TSQLRestClientURI

    // instance is destroyed), you can call the service as such:

    // $ GET ModelRoot/auth?UserName=...&Session=...

    // - for a way of computing SHA-256 in JavaScript, see for instance

    // @http://www.webtoolkit.info/javascript-sha256.html

    function Auth(Ctxt: TSQLRestServerURIContext): boolean; override;

  end;



  /// mORMot weak RESTful authentication scheme

  // - this method will authenticate with a given username, but no signature

  // - on client side, this scheme is not called by TSQLRestClientURI.SetUser()

  // method - so you have to write:

  // ! TSQLRestServerAuthenticationNone.ClientSetUser(Client,'User','');

  TSQLRestServerAuthenticationNone = class(TSQLRestServerAuthenticationURI)

  protected

    /// class method used on client side to create a remote session

    // - will call the ModelRoot/Auth service, i.e. call TSQLRestServer.Auth()

    // published method to create a session for this user: so

    // TSQLRestServerAuthenticationNone should be registered on server side

    // - will check User.LogonName, but User.PasswordHashHexa will be ignored

    class function ClientComputeSessionKey(Sender: TSQLRestClientURI;

      User: TSQLAuthUser): RawUTF8; override;

  public

    /// will try to handle the Auth RESTful method with mORMot authentication

    // - to be called in a weak one pass request:

    // $ GET ModelRoot/auth?UserName=...

    // $ -> if the specified user name exists, will open the corresponding

    // $    session and return 'SessionID+HexaSessionPrivateKey'

    function Auth(Ctxt: TSQLRestServerURIContext): boolean; override;

  end;



  /// abstract class for implementing HTTP authentication

  // - do not use this abstract class, but e.g. TSQLRestServerAuthenticationHttpBasic

  // - this class will transmit the session_signature as HTTP cookie, not at

  // URI level, so is expected to be used only from browsers or old clients

  TSQLRestServerAuthenticationHttpAbstract = class(TSQLRestServerAuthentication)

  protected

    /// should be overriden according to the HTTP authentication scheme

    class function ComputeAuthenticateHeader(

      const aUserName,aPasswordClear: RawUTF8): RawUTF8; virtual; abstract;

  public

    /// will check the caller signature

    // - retrieve the session ID from "Cookie: mORMot_session_signature=..." HTTP header

    function RetrieveSession(Ctxt: TSQLRestServerURIContext): TAuthSession; override;

    /// class method to be called on client side to sign an URI in Auth Basic

    // resolution is about 256 ms in the current implementation

    // - set "Cookie: mORMot_session_signature=..." HTTP header

    class procedure ClientSessionSign(Sender: TSQLRestClientURI;

      var Call: TSQLRestURIParams); override;

    /// class method to be used on client side to create a remote session

    // - call TSQLRestServerAuthenticationHttpBasic.ClientSetUser() instead of

    // TSQLRestClientURI.SetUser(), and never the method of this abstract class

    // - needs the plain aPassword, so aPasswordKind should be passClear

    // - returns true on success

    class function ClientSetUser(Sender: TSQLRestClientURI; const aUserName, aPassword: RawUTF8;

      aPasswordKind: TSQLRestServerAuthenticationClientSetUserPassword=passClear;

      const aHashSalt: RawUTF8=''; aHashRound: integer=20000): boolean; override;

    /// class method to be used on client side to force the HTTP header for

    // the corresponding HTTP authentication, without creating any remote session

    // - call virtual protected method ComputeAuthenticateHeader()

    // - here the password should be given as clear content

    // - potential use case is to use a mORMot client through a HTTPS proxy,

    // e.g. with TSQLRestServerAuthenticationHttpBasic authentication

    // - then you can use TSQLRestServerAuthentication*.ClientSetUser() to

    // define any another "mORMot only" authentication

    // - this method is also called by the ClientSetUser() method of this class

    // for a full client + server authentication via HTTP

    // TSQLRestServerAuthenticationHttp*.ClientSetUser()

    class procedure ClientSetUserHttpOnly(Sender: TSQLRestClientURI;

      const aUserName, aPasswordClear: RawUTF8); virtual;

  end;



  /// authentication using HTTP Basic scheme

  // - this protocol send both name and password as clear (just base-64 encoded)

  // so should only be used over SSL / HTTPS, or for compatibility reasons

  // - will rely on TSQLRestServerAuthenticationNone for authorization

  // - on client side, this scheme is not called by TSQLRestClientURI.SetUser()

  // method - so you have to write:

  // ! TSQLRestServerAuthenticationHttpBasic.ClientSetUser(Client,'User','password');

  // - for a remote proxy-only authentication (without creating any mORMot

  // session), you can write:

  // ! TSQLRestServerAuthenticationHttpBasic.ClientSetUserHttpOnly(Client,'proxyUser','proxyPass');

  TSQLRestServerAuthenticationHttpBasic = class(TSQLRestServerAuthenticationHttpAbstract)

  protected

    /// this overriden method returns "Authorization: Basic ...." HTTP header

    class function ComputeAuthenticateHeader(

      const aUserName,aPasswordClear: RawUTF8): RawUTF8; override;

    /// decode "Authorization: Basic ...." header

    // - you could implement you own password transmission pattern, by

    // overriding both ComputeAuthenticateHeader and GetUserPassFromInHead methods

    class function GetUserPassFromInHead(Ctxt: TSQLRestServerURIContext;

      out userPass,user,pass: RawUTF8): boolean; virtual;

    /// check a supplied password content

    // - this default implementation will use the SHA-256 hash value stored

    // within User.PasswordHashHexa

    // - you can override this method to provide your own password check

    // mechanism, for the given TSQLAuthUser instance

    function CheckPassword(Ctxt: TSQLRestServerURIContext;

      User: TSQLAuthUser; const aPassWord: RawUTF8): boolean; virtual;

  public

    /// will check URI-level signature

    // - retrieve the session ID from 'session_signature=...' parameter

    // - will also check incoming "Authorization: Basic ...." HTTP header

    function RetrieveSession(Ctxt: TSQLRestServerURIContext): TAuthSession; override;

    /// handle the Auth RESTful method with HTTP Basic

    // - will first return HTML_UNAUTHORIZED (401), then expect user and password

    // to be supplied as incoming "Authorization: Basic ...." headers

    function Auth(Ctxt: TSQLRestServerURIContext): boolean; override;

  end;



  {$ifdef SSPIAUTH}



  /// authentication of the current logged user using Windows Security Support

  // Provider Interface (SSPI)

  // - is able to authenticate the currently logged user on the client side,

  // using either NTLM or Kerberos - it would allow to safely authenticate

  // on a mORMot server without prompting the user to enter its password

  // - if ClientSetUser() receives aUserName as '', aPassword should be either

  // '' if you expect NTLM authentication to take place, or contain the SPN

  // registration (e.g. 'mymormotservice/myserver.mydomain.tld') for Kerberos

  // authentication

  // - if ClientSetUser() receives aUserName as 'DomainName\UserName', then

  // authentication will take place on the specified domain, with aPassword

  // as plain password value

  TSQLRestServerAuthenticationSSPI = class(TSQLRestServerAuthenticationSignedURI)

  protected

    /// Windows built-in authentication

    // - holds information between calls to ServerSSPIAuth

    fSSPIAuthContexts: TSecContextDynArray;

    /// class method used on client side to create a remote session

    // - will call the ModelRoot/Auth service, i.e. call TSQLRestServer.Auth()

    // published method to create a session for this user: so

    // TSQLRestServerAuthenticationSSPI should be registered on server side

    // - Windows SSPI authentication will be performed - in this case,

    // table TSQLAuthUser shall contain an entry for the logged Windows user,

    // with the LoginName in form 'DomainName\UserName'

    // - if User.LogonName is '', then User.PasswordHashHexa is '' for

    // NTLM authentication, or the SPN registration for Kerberos authentication

    // - if User.LogonName is set as 'DomainName\UserName', then authentication

    // would take place on the specified domain, with User.PasswordHashHexa as

    // plain password

    class function ClientComputeSessionKey(Sender: TSQLRestClientURI;

      User: TSQLAuthUser): RawUTF8; override;

  public

    /// initialize the authentication method to a specified server

    constructor Create(aServer: TSQLRestServer); override;

    /// finalize internal memory structures

    destructor Destroy; override;

    /// will try to handle the Auth RESTful method with Windows SSPI API

    // - to be called in a two pass algorithm, used to cypher the password

    // - the client-side logged user will be identified as valid, according

    // to a Windows SSPI API secure challenge

    function Auth(Ctxt: TSQLRestServerURIContext): boolean; override;

  end;



  {$endif SSPIAUTH}



  /// supported REST authentication schemes

  // - used by the overloaded TSQLHttpServer.Create(TSQLHttpServerDefinition)

  // constructor in mORMotHttpServer.pas, and also in dddInfraSettings.pas

  // - asSSPI won't be defined under Linux, since it is a Windows-centric feature

  TSQLHttpServerRestAuthentication = (

    adDefault, adHttpBasic, adWeak, adSSPI);



  /// parameters supplied to publish a TSQLRestServer via HTTP

  // - used by the overloaded TSQLHttpServer.Create(TSQLHttpServerDefinition)

  // constructor in mORMotHttpServer.pas, and also in dddInfraSettings.pas

  TSQLHttpServerDefinition = class(TSynPersistentWithPassword)

  protected

    FBindPort: RawByteString;

    FAuthentication: TSQLHttpServerRestAuthentication;

    FEnableCORS: boolean;

    FThreadCount: byte;

    FHttps: boolean;

    FHttpSysQueueName: SynUnicode;

  published

    /// defines the port to be used for REST publishing

    // - may include an optional IP address to bind, e.g. '127.0.0.1:8888'

    property BindPort: RawByteString read FBindPort write FBindPort;

    /// which authentication is expected to be published

    property Authentication: TSQLHttpServerRestAuthentication

      read FAuthentication write FAuthentication;

    /// allow Cross-origin resource sharing (CORS) access

    // - set this property to TRUE if you want to be able to access the

    // REST methods from an HTML5 application hosted in another location

    // - i.e. will set the following HTTP header:

    // ! Access-Control-Allow-Origin: *

    property EnableCORS: boolean read FEnableCORS write FEnableCORS;

    /// how many threads the thread pool associated with this HTTP server

    // should create

    // - if set to 0, will use default value 32

    // - this parameter may be ignored depending on the actual HTTP

    // server used, which may not have any thread pool

    property ThreadCount: byte read fThreadCount write fThreadCount;

    /// defines if https:// protocol should be used

    // - implemented only by http.sys server under Windows, not by socket servers

    property Https: boolean read FHttps write FHttps;

    /// the displayed name in the http.sys queue

    // - used only by http.sys server under Windows, not by socket-based servers

    property HttpSysQueueName: SynUnicode read FHttpSysQueueName write FHttpSysQueueName;

    /// if defined, this HTTP server will use WebSockets, and our secure

    // encrypted binary protocol

    // - when stored in the settings JSON file, the password will be safely

    // encrypted as defined by TSynPersistentWithPassword

    // - use the inherited PlainPassword property to set or read its value

    property WebSocketPassword: RawUTF8 read fPassWord write fPassWord;

  end;



  /// TSynAuthentication* class using TSQLAuthUser/TSQLAuthGroup for credentials

  // - could be used e.g. for SynDBRemote access in conjunction with mORMot

  TSynAuthenticationRest = class(TSynAuthenticationAbstract)

  protected

    fServer: TSQLRestServer;

    fAllowedGroups: TIntegerDynArray;

    function GetPassword(const UserName: RawUTF8; out Password: RawUTF8): boolean; override;

    function GetUsersCount: integer; override;

  public

    /// initialize the authentication scheme

    // - you can optionally set the groups allowing to use SynDBRemote - if none

    // is specify, username/password is enough

    constructor Create(aServer: TSQLRestServer; const aAllowedGroups: array of integer); reintroduce;

    /// add some new groups to validate an user authentication

    procedure RegisterAllowedGroups(const aAllowedGroups: array of integer);

    /// to be used to compute a Hash on the client side, for a given Token

    // - the password will be hashed as expected by the GetPassword() method

    class function ComputeHash(Token: Int64; const UserName,PassWord: RawUTF8): cardinal; override;

  end;



  /// common ancestor for tracking TSQLRecord modifications

  // - e.g. TSQLRecordHistory and TSQLRecordVersion will inherit from this class

  // to track TSQLRecord changes

  TSQLRecordModification = class(TSQLRecord)

  protected

    fModifiedRecord: TID;

    fTimeStamp: TModTime;

  public

    /// returns the modified record table, as stored in ModifiedRecord

    function ModifiedTable(Model: TSQLModel): TSQLRecordClass;

      {$ifdef HASINLINE}inline;{$endif}

    /// returns the record table index in the TSQLModel, as stored in ModifiedRecord

    function ModifiedTableIndex: integer;

      {$ifdef HASINLINE}inline;{$endif}

    /// returns the modified record ID, as stored in ModifiedRecord

    function ModifiedID: TID;

      {$ifdef HASINLINE}inline;{$endif}

  published

    /// identifies the modified record

    // - ID and table index in TSQLModel is stored as one RecordRef integer

    // - you can use ModifiedTable/ModifiedID to retrieve the TSQLRecord item

    // - in case of the record deletion, all matching TSQLRecordHistory won't

    // be touched by TSQLRestServer.AfterDeleteForceCoherency(): so this

    // property is a plain TID/Int64, not a TRecordReference field

    property ModifiedRecord: TID read fModifiedRecord write fModifiedRecord;

    /// when the modification was recorded

    // - even if in most cases, this timestamp may be synchronized over TSQLRest

    // instances (thanks to TSQLRestClientURI.ServerTimeStampSynchronize), it

    // is not safe to use this field as absolute: you should rather rely on

    // pure monotonic ID/RowID increasing values (see e.g. TSQLRecordVersion)

    property TimeStamp: TModTime read fTimeStamp write fTimeStamp;

  end;



  /// common ancestor for tracking changes on TSQLRecord tables

  // - used by TSQLRestServer.TrackChanges() method for simple fields history

  // - TSQLRestServer.InternalUpdateEvent will use this table to store individual

  // row changes as SentDataJSON, then will compress them in History BLOB

  // - note that any layout change of the tracked TSQLRecord table (e.g. adding

  // a new property) would break the internal data format, so will void the table

  TSQLRecordHistory = class(TSQLRecordModification)

  protected

    fEvent: TSQLHistoryEvent;

    fSentData: RawUTF8;

    fHistory: TSQLRawBlob;

    // BLOB storage layout is: RTTIheader + offsets + recordsdata

    fHistoryModel: TSQLModel;

    fHistoryTable: TSQLRecordClass;

    fHistoryTableIndex: integer;

    fHistoryUncompressed: RawByteString;

    fHistoryUncompressedCount: integer;

    fHistoryUncompressedOffset: TIntegerDynArray;

    fHistoryAdd: TFileBufferWriter;

    fHistoryAddCount: integer;

    fHistoryAddOffset: TIntegerDynArray;

  public

    /// load the change history of a given record

    // - then you can use HistoryGetLast, HistoryCount or HistoryGet() to access

    // all previous stored versions

    constructor CreateHistory(aClient: TSQLRest; aTable: TSQLRecordClass; aID: TID);

    /// finalize any internal memory

    destructor Destroy; override;

    /// called when the associated table is created in the database

    // - create index on History(ModifiedRecord,Event) for process speed-up

    class procedure InitializeTable(Server: TSQLRestServer; const FieldName: RawUTF8;

      Options: TSQLInitializeTableOptions); override;

  public

    /// prepare to access the History BLOB content

    // - ModifiedRecord should have been set to a proper value

    // - returns FALSE if the History BLOB is incorrect (e.g. TSQLRecord

    // layout changed): caller shall flush all previous history

    function HistoryOpen(Model: TSQLModel): boolean;

    /// returns how many revisions are stored in the History BLOB

    // - HistoryOpen() or CreateHistory() should have been called before

    // - this method will ignore any previous HistoryAdd() call

    function HistoryCount: integer;

    /// retrieve an historical version

    // - HistoryOpen() or CreateHistory() should have been called before

    // - this method will ignore any previous HistoryAdd() call

    // - if Rec=nil, will only retrieve Event and TimeStamp

    // - if Rec is set, will fill all simple properties of this TSQLRecord

    function HistoryGet(Index: integer; out Event: TSQLHistoryEvent;

      out TimeStamp: TModTime; Rec: TSQLRecord): boolean; overload;

    /// retrieve an historical version

    // - HistoryOpen() or CreateHistory() should have been called before

    // - this method will ignore any previous HistoryAdd() call

    // - will fill all simple properties of the supplied TSQLRecord instance

    function HistoryGet(Index: integer; Rec: TSQLRecord): boolean; overload;

    /// retrieve an historical version

    // - HistoryOpen() or CreateHistory() should have been called before

    // - this method will ignore any previous HistoryAdd() call

    // - will return either nil, or a TSQLRecord with all simple properties set

    function HistoryGet(Index: integer): TSQLRecord; overload;

    /// retrieve the latest stored historical version

    // - HistoryOpen() or CreateHistory() should have been called before

    // - this method will ignore any previous HistoryAdd() call

    // - you should not have to use it, since a TSQLRest.Retrieve() is faster

    function HistoryGetLast(Rec: TSQLRecord): boolean; overload;

    /// retrieve the latest stored historical version

    // - HistoryOpen() or CreateHistory() should have been called before,

    // otherwise it will return nil

    // - this method will ignore any previous HistoryAdd() call

    // - you should not have to use it, since a TSQLRest.Retrieve() is faster

    function HistoryGetLast: TSQLRecord; overload;

    /// add a record content to the History BLOB

    // - HistoryOpen() should have been called before using this method -

    // CreateHistory() won't allow history modification

    // - use then HistorySave() to compress and replace the History field

    procedure HistoryAdd(Rec: TSQLRecord; Hist: TSQLRecordHistory);

    /// update the History BLOB field content

    // - HistoryOpen() should have been called before using this method -

    // CreateHistory() won't allow history modification

    // - if HistoryAdd() has not been used, returns false

    // - ID field should have been set for proper persistence on Server

    // - otherwise compress the data into History BLOB, deleting the oldest

    // versions if resulting size is biggger than expected, and returns true

    // - if Server is set, write save the History BLOB to database

    // - if Server and LastRec are set, its content will be compared with the

    // current record in DB (via a Retrieve() call) and stored: it will allow

    // to circumvent any issue about inconsistent use of tracking, e.g. if the

    // database has been modified directly, by-passing the ORM

    function HistorySave(Server: TSQLRestServer;

      LastRec: TSQLRecord=nil): boolean;

  published

    /// the kind of modification stored

    // - is heArchiveBlob when this record stores the compress BLOB in History

    // - otherwise, SentDataJSON may contain the latest values as JSON

    property Event: TSQLHistoryEvent read fEvent write fEvent;

    /// for heAdd/heUpdate, the data is stored as JSON

    // - note that we defined a default maximum size of 4KB for this column,

    // to avoid using a CLOB here - perhaps it may not be enough for huge

    // records - feedback is welcome...

    property SentDataJSON: RawUTF8 index 4000 read fSentData write fSentData;

    /// after some events are written as individual SentData content, they

    // will be gathered and compressed within one BLOB field

    // - use HistoryOpen/HistoryCount/HistoryGet to access the stored data after

    // a call to CreateHistory() constructor

    // - as any BLOB field, this one won't be retrieved by default: use

    // explicitly TSQLRest.RetrieveBlobFields(aRecordHistory) to get it if you

    // want to access it directly, and not via CreateHistory()

    property History: TSQLRawBlob read fHistory write fHistory;

  end;



  /// class-reference type (metaclass) to specify the storage table to be used

  // for tracking TSQLRecord changes

  // - you can create your custom type from TSQLRecordHistory, even for a

  // particular table, to split the tracked changes storage in several tables:

  // ! type

  // !  TSQLRecordMyHistory = class(TSQLRecordHistory);

  // - as expected by TSQLRestServer.TrackChanges() method

  TSQLRecordHistoryClass = class of TSQLRecordHistory;



  /// ORM table used to store the deleted items of a versioned table

  // - the ID/RowID primary key of this table would be the version number

  // (i.e. value computed by TSQLRestServer.InternalRecordVersionCompute),

  // mapped with the corresponding 'TableIndex shl 58' (so that e.g.

  // TSQLRestServer.RecordVersionSynchronizeToBatch() could easily ask for the

  // deleted rows of a given table with a single WHERE clause on the ID/RowID)

  TSQLRecordTableDeleted = class(TSQLRecord)

  protected

    fDeleted: Int64;

  published

    /// this Deleted published field will track the deleted row

    // - defined as Int64 and not TID, to avoid the generation of the index on

    // this column, which is not needed here (all requests are about ID/RowID)

    property Deleted: Int64 read fDeleted write fDeleted;

  end;



  /// class-reference type (metaclass) to specify the storage table to be used

  // for tracking TSQLRecord deletion

  TSQLRecordTableDeletedClass = class of TSQLRecordTableDeleted;



  /// defines what is stored in a TSQLRestTempStorageItem entry

  TSQLRestTempStorageItemKind = set of (itemInsert,itemFakeID);



  /// used to store an entry in the TSQLRestTempStorage class

  TSQLRestTempStorageItem = record

    /// the ID of this entry

    // - after an AddCopy(ForceID=false), is a "fake" ID, which is > maxInt

    ID: TID;

    /// the stored item, either after adding or updating

    // - equals nil if the item has been deleted

    Value: TSQLRecord;

    /// identify the fields stored in the Value instance

    // - e.g. an Update() - or even an Add() - may only have set only simple or

    // specific fields

    ValueFields: TSQLFieldBits;

    /// what is stored in this entry

    Kind: TSQLRestTempStorageItemKind;

  end;



  /// used to store the entries in the TSQLRestTempStorage class

  TSQLRestTempStorageItemDynArray = array of TSQLRestTempStorageITem;



  /// abstract class used for temporary in-memory storage of TSQLRecord

  // - purpose of this class is to gather write operations (Add/Update/Delete)

  // - inherited implementations may send all updates at once to a server (i.e.

  // "asynchronous write"), or maintain a versioned image of the content

  // - all public methods (AddCopy/AddOwned/Update/Delete/FlushAsBatch) are

  // thread-safe, protected by a mutex lock

  TSQLRestTempStorage = class(TSynPersistentLocked)

  protected

    fStoredClass: TSQLRecordClass;

    fStoredClassRecordProps: TSQLRecordProperties;

    fItem: TSQLRestTempStorageItemDynArray;

    fItems: TDynArray;

    fLastFakeID: TID;

    fCount: integer;

    function InternalSetFields(const FieldNames: RawUTF8; out Fields: TSQLFieldBits): boolean;

    procedure InternalAddItem(const item: TSQLRestTempStorageItem);

  public

    /// initialize the temporary storage for a given class

    constructor Create(aClass: TSQLRecordClass); reintroduce; virtual;

    /// finalize this temporary storage instance

    destructor Destroy; override;

    /// add a copy of a TSQLRecord to the internal storage list

    // - if ForceID is true, Value.ID would be supplied with the ID to add

    // - if ForceID is false, a "fake" ID is returned, which may be used later

    // on for Update() calls - WARNING: but this ID should not be stored as

    // a cross reference in another record, since it is private to this storage;

    // the definitive ID will be returned eventually after proper persistence

    // (e.g. sent as TSQLRestBatch to a mORMot server)

    // - FieldNames can be the CSV list of field names to be set

    // - if FieldNames is '', will set all simple fields, excluding BLOBs

    // - if FieldNames is '*', will set ALL fields, including BLOBs

    // - this method will clone the supplied Value, and make its own copy

    // for its internal storage - consider use AddOwned() if the caller does

    // not need to store the instance afterwards

    function AddCopy(Value: TSQLRecord; ForceID: boolean;

      const FieldNames: RawUTF8=''): TID; overload;

    /// add and own a TSQLRecord in the internal storage list

    // - if ForceID is true, Value.ID would be supplied with the ID to add

    // - if ForceID is false, a "fake" ID is returned, which may be used later

    // on for Update() calls - WARNING: but this ID should not be stored as

    // a cross reference in another record, since it is private to this storage;

    // the definitive ID will be returned eventually after proper persistence

    // (e.g. sent as TSQLRestBatch to a mORMot server)

    // - FieldNames can be the CSV list of field names to be set

    // - if FieldNames is '', will set all simple fields, excluding BLOBs

    // - if FieldNames is '*', will set ALL fields, including BLOBs

    // - this method will store the supplied Value, and let its internal

    // storage owns it and manage its lifetime - consider use AddCopy() if the

    // caller does need to store this instance afterwards

    // - returns 0 in case of error (e.g. ForceID and no or duplicated Value.ID)

    function AddOwned(Value: TSQLRecord; ForceID: boolean;

      const FieldNames: RawUTF8=''): TID; overload;

    /// add, update or delete a TSQLRecord in the internal storage list

    // - could be used from a TNotifySQLEvent/InternalUpdateEvent(seAdd) callback

    // - here the value to be added is supplied as a JSON object and a ID field

    // - returns false in case of error (e.g. duplicated ID or void JSON)

    function FromEvent(Event: TSQLEvent; ID: TID; const JSON: RawUTF8): boolean;

    /// add and own a TSQLRecord in the internal storage list

    // - if ForceID is true, Value.ID would be supplied with the ID to add

    // - if ForceID is false, a "fake" ID is returned, which may be used later

    // on for Update() calls - WARNING: but this ID should not be stored as

    // a cross reference in another record, since it is private to this storage;

    // the definitive ID will be returned eventually after proper persistence

    // (e.g. sent as TSQLRestBatch to a mORMot server)

    // - this overloaded version expects the fields to be specified as bits

    // - this method will store the supplied Value, and let its internal

    // storage owns it and manage its lifetime - consider use AddCopy() if the

    // caller does need to store this instance afterwards

    // - returns 0 in case of error (e.g. ForceID and no or duplicated Value.ID)

    function AddOwned(Value: TSQLRecord; ForceID: boolean;

      const Fields: TSQLFieldBits): TID; overload;

    /// mark a TSQLRecord as deleted in the internal storage list

    procedure Delete(const ID: TID);

    /// update a TSQLRecord and store the new values in the internal storage list

    // - Value.ID is used to identify the record to be updated (which may be

    // a just added "fake" ID)

    // - FieldNames can be the CSV list of field names to be updated

    // - if FieldNames is '', will update all simple fields, excluding BLOBs

    // - if FieldNames is '*', will update ALL fields, including BLOBs

    // - the supplied Value won't be owned by this instance: the caller should

    // release it when Value is no longer needed

    // - returns false in case of error (e.g. unknwown ID or invalid fields)

    function Update(Value: TSQLRecord; const FieldNames: RawUTF8=''): boolean; overload;

    /// update a TSQLRecord and store the new values in the internal storage list

    // - Value.ID is used to identify the record to be updated (which may be

    // a just added "fake" ID)

    // - this overloaded version expects the fields to be specified as bits

    // - the supplied Value won't be owned by this instance: the caller should

    // release it when Value is no longer needed

    // - returns false in case of error (e.g. unknwown ID or no field set)

    function Update(Value: TSQLRecord; const Fields: TSQLFieldBits): boolean; overload;

    /// convert the internal list as a TSQLRestBatch instance, ready to be

    // sent to the server

    function FlushAsBatch(Rest: TSQLRest;

      AutomaticTransactionPerRow: cardinal=1000): TSQLRestBatch;

    /// direct access to the low-level storage list

    // - the Count property is the number of items, length(Item) is the capacity

    // - the list is stored in increasing ID order

    property Item: TSQLRestTempStorageItemDynArray read fItem;

    /// how many entries are stored in the low-level storage list

    property Count: integer read fCount;

  end;



  /// how TSQLRestServer should maintain its statistical information

  // - used by TSQLRestServer.StatLevels property

  TSQLRestServerMonitorLevels = set of (

    mlTables, mlMethods, mlInterfaces, mlSessions, mlSQLite3);



  /// used for high-level statistics in TSQLRestServer.URI()

  TSQLRestServerMonitor = class(TSynMonitorServer)

  protected

    fServer: TSQLRestServer;

    fStartDate: RawUTF8;

    fCurrentThreadCount: TSynMonitorOneCount;

    fSuccess: TSynMonitorCount64;

    fOutcomingFiles: TSynMonitorCount64;

    fServiceMethod: TSynMonitorCount64;

    fServiceInterface: TSynMonitorCount64;

    fCreated: TSynMonitorCount64;

    fRead: TSynMonitorCount64;

    fUpdated: TSynMonitorCount64;

    fDeleted: TSynMonitorCount64;

    // [Write: boolean] per-table statistics

    fPerTable: array[boolean] of TSynMonitorWithSizeObjArray;

    // no overriden Changed: TSQLRestServer.URI would do it in finally block

  public

    /// initialize the instance

    constructor Create(aServer: TSQLRestServer); reintroduce;

    /// finalize the instance

    destructor Destroy; override;

    /// should be called when a task successfully ended

    // - thread-safe method

    procedure ProcessSuccess(IsOutcomingFile: boolean); virtual;

    /// update and returns the CurrentThreadCount property

    // - this method is thread-safe

    function NotifyThreadCount(delta: integer): integer;

    /// update the Created/Read/Updated/Deleted properties

    // - this method is thread-safe

    procedure NotifyORM(aMethod: TSQLURIMethod);

    /// update the per-table statistics

    // - this method is thread-safe

    procedure NotifyORMTable(TableIndex, DataSize: integer; Write: boolean;

       const MicroSecondsElapsed: QWord);

  published

    /// when this monitoring instance (therefore the server) was created

    property StartDate: RawUTF8 read fStartDate;

    /// number of valid responses

    // - i.e. which returned status code 200/HTML_SUCCESS or 201/HTML_CREATED

    // - any invalid request will increase the TSynMonitor.Errors property

    property Success: TSynMonitorCount64 read fSuccess;

    /// count of the remote method-based service calls

    property ServiceMethod: TSynMonitorCount64 read fServiceMethod;

    /// count of the remote interface-based service calls

    property ServiceInterface: TSynMonitorCount64 read fServiceInterface;

    /// count of files transmitted directly (not part of Output size property)

    // - i.e. when the service uses STATICFILE_CONTENT_TYPE/HTTP_RESP_STATICFILE

    // as content type to let the HTTP server directly serve the file content

    property OutcomingFiles: TSynMonitorCount64 read fOutcomingFiles;

    /// number of current declared thread counts

    // - as registered by BeginCurrentThread/EndCurrentThread

    property CurrentThreadCount: TSynMonitorOneCount read fCurrentThreadCount;

    /// how many Create / Add ORM operations did take place

    property Created: TSynMonitorCount64 read fCreated;

    /// how many Read / Get ORM operations did take place

    property Read: TSynMonitorCount64 read fRead;

    /// how many Update ORM operations did take place

    property Updated: TSynMonitorCount64 read fUpdated;

    /// how many Delete ORM operations did take place

    property Deleted: TSynMonitorCount64 read fDeleted;

  end;



  /// ORM table used to store TSynMonitorUsage information

  // - the ID primary field is the TSynMonitorUsageID shifted by 16 bits

  TSQLMonitorUsage = class(TSQLRecord)

  protected

    fGran: TSynMonitorUsageGranularity;

    fProcess: TSynUniqueIdentifierProcess;

    fInfo: variant;

    fComment: RawUTF8;

    function GetUsageID: integer;

    procedure SetUsageID(Value: integer);

  public

    /// compute the corresponding TSynMonitorUsageID.Value

    // - according to the stored Process field 

    property UsageID: integer read GetUsageID write SetUsageID; 

  published

    /// the granularity of the statistics of this entry

    property Gran: TSynMonitorUsageGranularity read fGran write fGran;

    /// identify which application is monitored

    property Process: TSynUniqueIdentifierProcess read fProcess write fProcess;

    /// the actual statistics information, stored as a TDocVariant JSON object

    property Info: variant read fInfo write fInfo;

    /// a custom text, which may be used e.g. by support or developpers

    property Comment: RawUTF8 read fComment write fComment;

  end;

  /// class-reference type (metaclass) of a TSQLMonitorUsage table

  TSQLMonitorUsageClass = class of TSQLMonitorUsage;



  /// would store TSynMonitorUsage information in TSQLMonitorUsage ORM tables

  // - the TSQLRecord.ID would be the TSynMonitorUsageID shifted by 16 bits

  TSynMonitorUsageRest = class(TSynMonitorUsage)

  private

  protected

    fStorage: TSQLRest;

    fProcessID: TSynUniqueIdentifierProcess;

    fStoredClass: TSQLMonitorUsageClass;

    fStoredCache: array[mugHour..mugYear] of TSQLMonitorUsage;

    function SaveDB(ID: integer; const Track: variant; Gran: TSynMonitorUsageGranularity): boolean; override;

    function LoadDB(ID: integer; Gran: TSynMonitorUsageGranularity; out Track: variant): boolean; override;

  public

    /// initialize storage via ORM

    // - if a TSynUniqueIdentifierProcess is supplied, it would be used to

    // identify the generating process by shifting TSynMonitorUsageID values

    // - would use TSQLMonitorUsage table, unless another one is specified

    constructor Create(aStorage: TSQLRest; aProcessID: TSynUniqueIdentifierProcess;

      aStoredClass: TSQLMonitorUsageClass=nil); reintroduce; virtual;

    /// finalize the process

    destructor Destroy; override;

  published

    /// the actual ORM class used for persistence

    property StoredClass: TSQLMonitorUsageClass read fStoredClass;

    /// how the information could be stored for several processes

    // - e.g. when several SOA nodes gather monitoring information in a

    // shared (MongoDB) database     

    property ProcessID: TSynUniqueIdentifierProcess read fProcessID;

  end;





  /// a specialized UTF-8 string type, used for TSQLRestServerURI storage

  // - URI format is 'address:port/root', but port or root are optional

  // - you could use TSQLRestServerURI record to store and process it

  TSQLRestServerURIString = type RawUTF8;



  /// a list of UTF-8 strings, used for TSQLRestServerURI storage

  // - URI format is 'address:port/root', but port or root are optional

  // - you could use TSQLRestServerURI record to store and process each item

  TSQLRestServerURIStringDynArray = array of TSQLRestServerURIString;



  /// used to access a TSQLRestServer from its TSQLRestServerURIString URI

  // - URI format is 'address:port/root', and may be transmitted as

  // TSQLRestServerURIString text instances

  {$ifndef ISDELPHI2010}

  TSQLRestServerURI = object

  {$else}

  TSQLRestServerURI = record

  {$endif}

  private

    function GetURI: TSQLRestServerURIString;

    procedure SetURI(const Value: TSQLRestServerURIString);

  public

    /// the TSQLRestServer IP Address or DNS name

    Address: RawUTF8;

    /// the TSQLRestServer IP port

    Port: RawUTF8;

    /// the TSQLRestServer model Root

    Root: RawUTF8;

    /// returns TRUE if all field values do match, case insensitively

    function Equals(const other: TSQLRestServerURI): boolean;

    /// property which allows to read or set the Address/Port/Root fields as

    // one UTF-8 text field (i.e. a TSQLRestServerURIString instance)

    // - URI format is 'address:port/root', but port or root are optional

    property URI: TSQLRestServerURIString read GetURI write SetURI;

  end;

  /// store a list of TSQLRestServer URIs

  TSQLRestServerURIDynArray = array of TSQLRestServerURI;



  /// used to publish all Services supported by a TSQLRestServer instance

  // - as expected by TSQLRestServer.ServicesPublishedInterfaces

  // - can be serialized as a JSON object via RecordLoadJSON/RecordSaveJSON

  TServicesPublishedInterfaces = object

    /// how this TSQLRestServer could be accessed

    PublicURI: TSQLRestServerURI;

    /// the list of supported services names

    // - in fact this is the Interface name without the initial 'I', e.g.

    // 'Calculator' for ICalculator

    Names: TRawUTF8DynArray;

  end;

  /// store a list of published Services supported by a TSQLRestServer instance

  TServicesPublishedInterfacesDynArray = array of TServicesPublishedInterfaces;



  /// used e.g. by TSQLRestServer to store a list of TServicesPublishedInterfaces

  TServicesPublishedInterfacesList = class(TSynPersistentLocked)

  private

    fDynArray: TDynArray;

    fDynArrayTimeoutTix: TDynArray;

    fTimeoutTix: TInt64DynArray;

    fTimeoutTixCount: integer;

    fLastPublishedJson: cardinal;

    fTimeOut: integer;

  public

    /// the internal list of published services

    // - the list is stored in-order, i.e. it will follow the RegisterFromJSON()

    // execution order: the latest registrations would appear last

    List: TServicesPublishedInterfacesDynArray;

    /// how many items are actually stored in List[]

    Count: Integer;

    /// initialize the storage

    // - an optional time out period, in milliseconds, may be defined - but the

    // clients should ensure that RegisterFromClientJSON() is called in order

    // to refresh the list (e.g. from _contract_ HTTP body)

    constructor Create(aTimeoutMS: integer); reintroduce; virtual;

    /// add the JSON serialized TServicesPublishedInterfaces to the list

    // - called by TSQLRestServerURIContext.InternalExecuteSOAByInterface when

    // the client provides its own services as _contract_ HTTP body

    // - warning: supplied PublishedJson would be parsed in place, so modified

    procedure RegisterFromClientJSON(var PublishedJson: RawUTF8);

    /// set the list from JSON serialized TServicesPublishedInterfacesDynArray

    // - may be used to duplicate the whole TSQLRestServer.AssociatedServices

    // content, as returned from /root/Stat?findservice=*

    // - warning: supplied PublishedJson would be parsed in place, so modified

    procedure RegisterFromServerJSON(var PublishedJson: RawUTF8);

    /// set the list from a remote TSQLRestServer

    // - will call /root/Stat?findservice=* URI, then RegisterFromServerJSON()

    function RegisterFromServer(Client: TSQLRestClientURI): boolean;

    /// search for a public URI in the registration list

    function FindURI(const aPublicURI: TSQLRestServerURI): integer;

    /// search for the latest registrations of a service, by name

    // - will lookup for the Interface name without the initial 'I', e.g.

    // 'Calculator' for ICalculator - warning: research is case-sensitive

    // - if the service name has been registered several times, all

    // registration would be returned, the latest in first position

    function FindService(const aServiceName: RawUTF8): TSQLRestServerURIDynArray;

    /// return all services URI by name, from the registration list, as URIs

    // - will lookup for the Interface name without the initial 'I', e.g.

    // 'Calculator' for ICalculator - warning: research is case-sensitive

    // - the returned string would contain all matching server URI, the latest

    // registration being the first to appear, e.g.

    // $ ["addresslast:port/root","addressprevious:port/root","addressfirst:port/root"]

    function FindServiceAll(const aServiceName: RawUTF8): TSQLRestServerURIStringDynArray; overload;

    /// return all services URI by name, from the registration list, as JSON

    // - will lookup for the Interface name without the initial 'I', e.g.

    // 'Calculator' for ICalculator - warning: research is case-sensitive

    // - the returned JSON array would contain all matching server URI, encoded as

    // a TSQLRestServerURI JSON array, the latest registration being

    // the first to appear, e.g.

    // $ [{"Address":"addresslast","Port":"port","Root":"root"},...]

    // - if aServiceName='*', it will return ALL registration items, encoded as

    // a TServicesPublishedInterfaces JSON array, e.g.

    // $ [{"PublicURI":{"Address":"1.2.3.4","Port":"123","Root":"root"},"Names":['Calculator']},...]

    procedure FindServiceAll(const aServiceName: RawUTF8; aWriter: TTextWriter); overload;

    /// the number of milliseconds after which an entry expires

    // - is 0 by default, meaning no expiration

    // - you can set it to a value so that any service URI registered with

    // RegisterFromJSON() AFTER this property modification may expire

    property TimeOut: integer read fTimeOut write fTimeOut;

  end;



  /// class-reference type (metaclass) of a REST server

  TSQLRestServerClass = class of TSQLRestServer;



  /// some options for TSQLRestServer process

  // - read-only rsoNoAJAXJSON indicates that JSON data is transmitted in "not

  // expanded" format: you should NEVER change this option by including

  // this property in TSQLRestServer.Options, but always call explicitly

  // TSQLRestServer.NoAJAXJSON := true so that the SetNoAJAXJSON virtual

  // method should be called as expected (e.g. to flush TSQLRestServerDB cache)

  // - rsoGetAsJsonNotAsString would let ORM GET return to AJAX (non Delphi)

  // clients JSON objects instead of the JSON text stored in database fields

  // - rsoGetID_str would add a "ID_str": string field to circumvent JavaScript

  // limitation of 53-bit for integers - only for AJAX (non Delphi) clients

  // - unauthenticated requests from browsers (i.e. not Delphi clients) may

  // be redirected to the TSQLRestServer.Auth() method via rsoRedirectForbiddenToAuth

  // (e.g. for TSQLRestServerAuthenticationHttpBasic popup)

  // - some REST/AJAX clients may expect to return status code 204 as

  // instead of 200 in case of a successful operation, but with no returned

  // body (e.g. a DELETE with SAPUI5 / OpenUI5 framework): include

  // rsoHtml200WithNoBodyReturns204 so that any HTML_SUCCESS (200) with no

  // returned body would return a HTML_NOCONTENT (204)

  // - by default, Add() or Update() would return HTML_CREATED (201) or

  // HTML_SUCCESS (200) with no body, unless rsoAddUpdateReturnsContent is set

  // to return as JSON the last inserted/updated record

  // - TModTime / TCreateTime fields are expected to be filled on client side,

  // unless you set rsoComputeFieldsBeforeWriteOnServerSide so that AJAX requests

  // would set the fields on the server side by calling the TSQLRecord

  // ComputeFieldsBeforeWrite virtual method, before writing to the database

  TSQLRestServerOption = (

    rsoNoAJAXJSON,

    rsoGetAsJsonNotAsString,

    rsoGetID_str,

    rsoRedirectForbiddenToAuth,

    rsoHtml200WithNoBodyReturns204,

    rsoAddUpdateReturnsContent,

    rsoComputeFieldsBeforeWriteOnServerSide);

  /// allow to customize the TSQLRestServer process via its Options property

  TSQLRestServerOptions = set of TSQLRestServerOption;



  /// a generic REpresentational State Transfer (REST) server

  // - descendent must implement the protected EngineList() Retrieve() Add()

  // Update() Delete() methods

  // - automatic call of this methods by a generic URI() RESTful function

  // - any published method of descendants must match TSQLRestServerCallBack

  // prototype, and is expected to be thread-safe

  TSQLRestServer = class(TSQLRest)

  protected

    fVirtualTableDirect: boolean;

    fHandleAuthentication: boolean;

    fBypassORMAuthentication: TSQLURIMethods;

    fAfterCreation: boolean;

    fOptions: TSQLRestServerOptions;

    /// the TSQLAuthUser and TSQLAuthGroup classes, as defined in model

    fSQLAuthUserClass: TSQLAuthUserClass;

    fSQLAuthGroupClass: TSQLAuthGroupClass;

    /// how in-memory sessions are handled

    fSessionClass: TAuthSessionClass;

    /// will contain the in-memory representation of some static tables

    // - this array has the same length as the associated Model.Tables[]

    // - fStaticData[] will contain pure in-memory tables, not declared as

    // SQLite3 virtual tables, therefore not available from joined SQL statements

    fStaticData: TSQLRestDynArray;

    /// map TSQLRestStorageInMemory or TSQLRestStorageExternal engines

    // - this array has the same length as the associated Model.Tables[]

    // - fStaticVirtualTable[] will contain in-memory or external tables declared

    // as SQLite3 virtual tables, therefore available from joined SQL statements

    fStaticVirtualTable: TSQLRestDynArray;

    /// in-memory storage of TAuthSession instances

    fSessions: TObjectListLocked;

    /// used to compute genuine TAuthSession.ID cardinal value

    fSessionCounter: cardinal;

    fSessionAuthentication: TSQLRestServerAuthenticationDynArray;

    {$ifdef MSWINDOWS}

    /// thread initialized by ExportServerNamedPipe() to response to client through a pipe

    fExportServerNamedPipeThread: TSQLRestServerNamedPipe;

    /// internal server window handle, initialized by ExportServerMessage() method

    fServerWindow: HWND;

    /// internal server window class name, initialized by ExportServerMessage() method

    // - use "string" type, i.e. UnicodeString for Delphi 2009+, in order

    // to call directly the correct FindWindow?()=FindWindow Win32 API

    fServerWindowName: string;

    {$endif}

    fPublishedMethod: TSQLRestServerMethods;

    fPublishedMethods: TDynArrayHashed;

    fPublishedMethodBatchIndex: integer;

    fPublicURI: TSQLRestServerURI;

    fAssociatedServices: TServicesPublishedInterfacesList;

    fStats: TSQLRestServerMonitor;

    fStatLevels: TSQLRestServerMonitorLevels;

    fStatUsage: TSynMonitorUsage;

    fShutdownRequested: boolean;

    fCreateMissingTablesOptions: TSQLInitializeTableOptions;

    fRootRedirectGet: RawUTF8;

    fRecordVersionMax: TRecordVersion;

    fRecordVersionDeleteIgnore: boolean;

    fOnIdleLastTix: cardinal;

    fSQLRecordVersionDeleteTable: TSQLRecordTableDeletedClass;

    fRecordVersionSlaveCallbacks: array of IServiceRecordVersionCallback;

    // TSQLRecordHistory.ModifiedRecord handles up to 64 (=1 shl 6) tables

    fTrackChangesHistoryTableIndex: TIntegerDynArray;

    fTrackChangesHistoryTableIndexCount: cardinal;

    fTrackChangesHistory: array of record

      CurrentRow: integer;

      MaxSentDataJsonRow: integer;

      MaxRevisionJSON: integer;

      MaxUncompressedBlobSize: integer;

    end;

    constructor RegisteredClassCreateFrom(aModel: TSQLModel;

      aServerHandleAuthentication: boolean; aDefinition: TSynConnectionDefinition); reintroduce; virtual;

    function GetAuthenticationSchemesCount: integer;

    function GetCurrentSessionUserID: TID; override;

    // called by Stat() and Info() method-based services

    procedure InternalStat(Ctxt: TSQLRestServerURIContext; W: TTextWriter); virtual;

    procedure InternalInfo(var info: TDocVariantData); virtual;

    procedure SetStatUsage(usage: TSynMonitorUsage);

    function GetServiceMethodStat(const aMethod: RawUTF8): TSynMonitorInputOutput;

    /// fast get the associated static server, if any

    function GetStaticDataServer(aClass: TSQLRecordClass): TSQLRest;

    /// retrieve a TSQLRestStorage instance associated to a Virtual Table

    // - is e.g. TSQLRestStorageInMemory instance associated to a

    // TSQLVirtualTableBinary or TSQLVirtualTableJSON class

    // - may be a TSQLRestStorageExternal (as defined in mORMotDB unit)

    // for a virtual table giving access to an external database

    function GetVirtualTable(aClass: TSQLRecordClass): TSQLRest;

    /// fast get the associated static server or Virtual table, if any

    // - this can be used to call directly the TSQLRestStorage instance

    // on the server side

    // - same as a dual call to StaticDataServer[aClass] + StaticVirtualTable[aClass]

    // - TSQLRestServer.URI will make a difference between the a static server

    // or a TSQLVirtualTable, but this method won't - you can set a reference

    // to a TSQLRestServerKind variable to retrieve the database server type

    function GetStaticDataServerOrVirtualTable(aClass: TSQLRecordClass): TSQLRest; overload;

       {$ifdef HASINLINE}inline;{$endif}

    /// overloaded method using table index in associated Model

    function GetStaticDataServerOrVirtualTable(aTableIndex: integer): TSQLRest;

      overload; {$ifdef HASINLINE}inline;{$endif}

    function GetStaticDataServerOrVirtualTable(aTableIndex: integer;

      out Kind: TSQLRestServerKind): TSQLRest; overload;

       {$ifdef HASINLINE}inline;{$endif}

    function GetRemoteTable(TableIndex: Integer): TSQLRest;

    function IsInternalSQLite3Table(aTableIndex: integer): boolean;

    /// retrieve a list of members as JSON encoded data - used by OneFieldValue()

    // and MultiFieldValue() public functions

    function InternalAdaptSQL(TableIndex: integer; var SQL: RawUTF8): TSQLRest;

    function InternalListRawUTF8(TableIndex: integer; const SQL: RawUTF8): RawUTF8;

    /// will retrieve the monotonic value of a TRecordVersion field from the DB

    procedure InternalRecordVersionMaxFromExisting(RetrieveNext: PID); virtual;

    procedure InternalRecordVersionDelete(TableIndex: integer; ID: TID;

      Batch: TSQLRestBatch); virtual;

    procedure InternalRecordVersionHandle(Occasion: TSQLOccasion;

      TableIndex: integer; var Decoder: TJSONObjectDecoder;

      RecordVersionField: TSQLPropInfoRTTIRecordVersion); virtual;

    /// will compute the next monotonic value for a TRecordVersion field

    // - you may override this method to customize the returned Int64 value

    // (e.g. to support several synchronization nodes)

    function InternalRecordVersionComputeNext: TRecordVersion; virtual;

    /// this method is overridden for setting the NoAJAXJSON field

    // of all associated TSQLRestStorage servers

    procedure SetNoAJAXJSON(const Value: boolean); virtual;

    function GetNoAJAXJSON: boolean;

    /// add a new session to the internal session list

    // - do not use this method directly: this callback is to be used by

    // TSQLRestServerAuthentication* classes

    // - will check that the logon name is valid

    // - on failure, will call TSQLRestServerURIContext.AuthenticationFailed()

    // with afSessionAlreadyStartedForThisUser or afSessionCreationAborted reason

    procedure SessionCreate(var User: TSQLAuthUser; Ctxt: TSQLRestServerURIContext;

      out Session: TAuthSession); virtual;

    /// fill the supplied context from the supplied aContext.Session ID

    // - returns nil if not found, or fill aContext.User/Group values if matchs

    // - this method will also check for outdated sessions, and delete them

    // - this method is not thread-safe: caller should use fSessions.Lock

    function SessionAccess(Ctxt: TSQLRestServerURIContext): TAuthSession;

    /// delete a session from its index in fSessions[]

    // - will perform any needed clean-up, and log the event

    // - this method is not thread-safe: caller should use fSessions.Lock

    procedure SessionDelete(aSessionIndex: integer; Ctxt: TSQLRestServerURIContext);

    /// returns TRUE if this table is worth caching (e.g. already in memory)

    // - this overridden implementation returns FALSE for TSQLRestStorageInMemory

    function CacheWorthItForTable(aTableIndex: cardinal): boolean; override;

    /// overridden methods which will perform CRUD operations

    // - will call any static TSQLRestStorage, or call MainEngine*() virtual methods

    function EngineAdd(TableModelIndex: integer; const SentData: RawUTF8): TID; override;

    function EngineRetrieve(TableModelIndex: integer; ID: TID): RawUTF8; override;

    function EngineList(const SQL: RawUTF8; ForceAJAX: Boolean=false; ReturnedRowCount: PPtrInt=nil): RawUTF8; override;

    function EngineUpdate(TableModelIndex: integer; ID: TID; const SentData: RawUTF8): boolean; override;

    function EngineDelete(TableModelIndex: integer; ID: TID): boolean; override;

    function EngineDeleteWhere(TableModelIndex: integer; const SQLWhere: RawUTF8;

      const IDs: TIDDynArray): boolean; override;

    function EngineRetrieveBlob(TableModelIndex: integer; aID: TID;

      BlobField: PPropInfo; out BlobData: TSQLRawBlob): boolean; override;

    function EngineUpdateBlob(TableModelIndex: integer; aID: TID;

      BlobField: PPropInfo; const BlobData: TSQLRawBlob): boolean; override;

    function EngineUpdateField(TableModelIndex: integer;

      const SetFieldName, SetValue, WhereFieldName, WhereValue: RawUTF8): boolean; override;

    function EngineUpdateFieldIncrement(TableModelIndex: integer; ID: TID;

      const FieldName: RawUTF8; Increment: Int64): boolean; override;

    function EngineBatchSend(Table: TSQLRecordClass; const Data: RawUTF8;

       var Results: TIDDynArray; ExpectedResultsCount: integer): integer; override;

    /// virtual methods which will perform CRUD operations on the main DB

    function MainEngineAdd(TableModelIndex: integer; const SentData: RawUTF8): TID; virtual; abstract;

    function MainEngineRetrieve(TableModelIndex: integer; ID: TID): RawUTF8; virtual; abstract;

    function MainEngineList(const SQL: RawUTF8; ForceAJAX: Boolean; ReturnedRowCount: PPtrInt): RawUTF8; virtual; abstract;

    function MainEngineUpdate(TableModelIndex: integer; ID: TID; const SentData: RawUTF8): boolean; virtual; abstract;

    function MainEngineDelete(TableModelIndex: integer; ID: TID): boolean; virtual; abstract;

    function MainEngineDeleteWhere(TableModelIndex: integer; const SQLWhere: RawUTF8;

      const IDs: TIDDynArray): boolean; virtual; abstract;

    function MainEngineRetrieveBlob(TableModelIndex: integer; aID: TID;

      BlobField: PPropInfo; out BlobData: TSQLRawBlob): boolean; virtual; abstract;

    function MainEngineUpdateBlob(TableModelIndex: integer; aID: TID;

      BlobField: PPropInfo; const BlobData: TSQLRawBlob): boolean; virtual; abstract;

    function MainEngineUpdateField(TableModelIndex: integer;

      const SetFieldName, SetValue, WhereFieldName, WhereValue: RawUTF8): boolean; virtual; abstract;

    function MainEngineUpdateFieldIncrement(TableModelIndex: integer; ID: TID;

      const FieldName: RawUTF8; Increment: Int64): boolean; virtual; abstract;

  public

    /// this integer property is incremented by the database engine when any SQL

    // statement changes the database contents (i.e. on any not SELECT statement)

    // - its value can be published to the client on every remote request

    // - it may be used by client to avoid retrieve data only if necessary

    // - if its value is 0, this feature is not activated on the server, and the

    // client must ignore it and always retrieve the content

    InternalState: Cardinal;

    /// a method can be specified here to trigger events after any table update

    // - is called BEFORE deletion, and AFTER insertion or update

    // - note that the aSentData parameter does not contain all record fields,

    // but only transmitted information: e.g. if only one field is updated, only

    // this single field (and the ID) is available

    // - to be used only server-side, not to synchronize some clients: the framework

    // is designed around a stateless RESTful architecture (like HTTP/1.1), in which

    // clients ask the server for refresh (see TSQLRestClientURI.UpdateFromServer)

    OnUpdateEvent: TNotifySQLEvent;

    /// a method can be specified here to trigger events after any blob update

    // - is called AFTER update of one or several blobs, never on delete nor insert

    // - to be used only server-side, not to synchronize some clients: the framework

    // is designed around a stateless RESTful architecture (like HTTP/1.1), in which

    // clients ask the server for refresh (see TSQLRestClientURI.UpdateFromServer)

    OnBlobUpdateEvent: TNotifyFieldSQLEvent;

    /// a method can be specified to be notified when a session is created

    // - for OnSessionCreate, returning TRUE will abort the session creation -

    // and you can set Ctxt.Call^.OutStatus to a corresponding error code

    // - it could be used e.g. to limit the number of client sessions

    OnSessionCreate: TNotifySQLSession;

    /// a custom method to retrieve the TSQLAuthUser instance for authentication

    // - will be called by TSQLRestServerAuthentication.GetUser() instead of

    // plain SQLAuthUserClass.Create()

    OnAuthenticationUserRetrieve: TOnAuthenticationUserRetrieve;

    /// this event handler will be executed when a session failed to initialize

    // (DenyOfService attack?) or the request is not valid (ManIntheMiddle attack?)

    // - e.g. if the URI signature is invalid, or OnSessionCreate event handler

    // aborted the session creation by returning TRUE (in this later case,

    // the Session parameter is not nil)

    // - you can access the current execution context from the Ctxt parameter,

    // e.g. to retrieve the caller's IP and ban aggressive users:

    // ! FindIniNameValue(pointer(Ctxt.Call^.InHead),'REMOTEIP: ')

    OnAuthenticationFailed: TNotifyAuthenticationFailed;

    /// a method can be specified to be notified when a session is closed

    // - for OnSessionClosed, the returning boolean value is ignored

    // - Ctxt is nil if the session is closed due to a timeout

    // - Ctxt is not nil if the session is closed explicitly by the client

    OnSessionClosed: TNotifySQLSession;

    /// this event will be executed to push notifications from the server to

    // a remote client, using a (fake) interface parameter

    // - is nil by default, but may point e.g. to TSQLHttpServer.NotifyCallback

    OnNotifyCallback: TSQLRestServerNotifyCallback;

    /// this event will be executed by TServiceFactoryServer.CreateInstance

    // - you may set a callback to customize a server-side service instance,

    // i.e. inject class-level dependencies:

    // !procedure TMyClass.OnCreateInstance(

    // !  Sender: TServiceFactoryServer; Instance: TInterfacedObject);

    // !begin

    // !  if Sender.ImplementationClass=TLegacyStockQuery then

    // !    TLegacyStockQuery(Instance).fDbConnection := fDbConnection;

    // !end;

    // - consider using a TInjectableObjectClass implementation for pure IoC/DI

    OnServiceCreateInstance: TOnServiceCreateInstance;

    /// event trigerred when URI() starts to process a request

    // - the supplied Ctxt parameter would give access to the command about to

    // be executed, e.g. Ctxt.Command=execSOAByInterface would identify a SOA

    // service execution, with the corresponding Service and ServiceMethodIndex

    // parameters as set by TSQLRestServerURIContext.URIDecodeSOAByInterface

    // - should return TRUE if the method can be executed

    // - should return FALSE if the method should not be executed, and the

    // callback should set the corresponding error to the supplied context e.g.

    // ! Ctxt.Error('Unauthorized method',HTML_NOTALLOWED);

    // - since this event would be executed by every TSQLRestServer.URI call,

    // it should better not make any slow process (like writing to a remote DB)

    OnBeforeURI: TNotifyBeforeURI;

    /// event trigerred when URI() finished to process a request

    // - the supplied Ctxt parameter would give access to the command which has

    // been executed, e.g. via Ctxt.Call.OutStatus or Ctxt.MicroSecondsElapsed

    // - since this event would be executed by every TSQLRestServer.URI call,

    // it should better not make any slow process (like writing to a remote DB)

    OnAfterURI: TNotifyAfterURI;

    /// event trigerred when URI() failed to process a request

    // - if Ctxt.ExecuteCommand raised an execption, this callback would be

    // run with all neeed information

    // - should return TRUE to execute Ctxt.Error(E,...), FALSE if returned

    // content has already been set as expected by the client

    OnErrorURI: TNotifyErrorURI;

    /// event trigerred when URI() is called, and at least 128 ms is elapsed

    // - could be used to execute some additional process after a period of time

    // - note that if TSQLRestServer.URI is not called by any client, this

    // callback won't be executed either 

    OnIdle: TNotifyEvent;

    /// this property can be used to specify the URI parmeters to be used

    // for query paging

    // - is set by default to PAGINGPARAMETERS_YAHOO constant by

    // TSQLRestServer.Create() constructor

    URIPagingParameters: TSQLRestServerURIPagingParameters;



    /// implement Server-Side TSQLRest deletion

    // - uses internally EngineDelete() function for calling the database engine

    // - call corresponding fStaticData[] if necessary

    // - this record is also erased in all available TRecordReference properties

    // in the database Model, for relational database coherency

    function Delete(Table: TSQLRecordClass; ID: TID): boolean; override;

    /// implement Server-Side TSQLRest deletion with a WHERE clause

    // - will process all ORM-level validation, coherency checking and

    // notifications together with a low-level SQL deletion work (if possible)

    function Delete(Table: TSQLRecordClass; const SQLWhere: RawUTF8): boolean; override;

    /// overridden method for direct static class call (if any)

    function TableRowCount(Table: TSQLRecordClass): Int64; override;

    /// overridden method for direct static class call (if any)

    function TableHasRows(Table: TSQLRecordClass): boolean; override;

    /// virtual method called when a record is updated

    // - default implementation will call the OnUpdateEvent/OnBlobUpdateEvent

    // methods, if defined

    // - will also handle TSQLRecordHistory tables, as defined by TrackChanges()

    // - returns true on success, false if an error occured (but action must continue)

    // - you can override this method to implement a server-wide notification,

    // but be aware it may be the first step to break the stateless architecture

    // of the framework

    function InternalUpdateEvent(aEvent: TSQLEvent; aTableIndex: integer; aID: TID;

      const aSentData: RawUTF8; aIsBlobFields: PSQLFieldBits): boolean; virtual;

    /// initialize change tracking for the given tables

    // - by default, it will use the TSQLRecordHistory table to store the

    // changes - you can specify a dedicated class as aTableHistory parameter

    // - if aTableHistory is not already part of the TSQLModel, it will be added

    // - note that this setting should be consistent in time: if you disable

    // tracking for a while, or did not enable tracking before adding a record,

    // then the content history won't be consistent (or disabled) for this record

    // - at every change, aTableHistory.SentDataJSON records will be added, up

    // to aMaxHistoryRowBeforeBlob items - then aTableHistory.History will store

    // a compressed version of all previous changes

    // - aMaxHistoryRowBeforeBlob is the maximum number of JSON rows per Table

    // before compression into BLOB is triggerred

    // - aMaxHistoryRowPerRecord is the maximum number of JSON rows per record,

    // above which the versions will be compressed as BLOB

    // - aMaxUncompressedBlobSize is the maximum BLOB size per record

    // - you can specify aMaxHistoryRowBeforeBlob=0 to disable change tracking

    // - you should call this method after the CreateMissingTables call

    // - note that change tracking may slow down the writing process, and

    // may increase storage space a lot (even if BLOB maximum size can be set),

    // so should be defined only when necessary

    procedure TrackChanges(const aTable: array of TSQLRecordClass;

      aTableHistory: TSQLRecordHistoryClass=nil; aMaxHistoryRowBeforeBlob: integer=1000;

      aMaxHistoryRowPerRecord: integer=10; aMaxUncompressedBlobSize: integer=64*1024); virtual;

    /// force compression of all aTableHistory.SentDataJson into History BLOB

    // - by default, this will take place in InternalUpdateEvent() when

    // aMaxHistoryRowBeforeBlob - as set by TrackChanges() method - is reached

    // - you can manually call this method to force History BLOB update, e.g.

    // when the server is in Idle state, and ready for process

    procedure TrackChangesFlush(aTableHistory: TSQLRecordHistoryClass); virtual;

    /// check if OnUpdateEvent or change tracked has been defined for this table

    // - is used internally e.g. by TSQLRestServerDB.MainEngineUpdateField to

    // ensure that the updated ID fields will be computed as expected

    function InternalUpdateEventNeeded(aTableIndex: integer): boolean;

    /// will compute the next monotonic value for a TRecordVersion field

    function RecordVersionCompute: TRecordVersion;

    /// read only access to the current monotonic value for a TRecordVersion field

    function RecordVersionCurrent: TRecordVersion;

    /// synchronous master/slave replication from a slave TSQLRest

    // - apply all the updates from another (distant) master TSQLRest for a given

    // TSQLRecord table, using its TRecordVersion field, to the calling slave

    // - both remote Master and local slave TSQLRestServer should have the supplied

    // Table class in their data model (maybe in diverse order)

    // - by default, all pending updates are retrieved, but you can define a value

    // to ChunkRowLimit, so that the updates would be retrieved by smaller chunks

    // - returns -1 on error, or the latest applied revision number (which may

    // be 0 if there is no data in the table)

    // - this method will use regular REST ORM commands, so will work with any

    // communication channels: for real-time push synchronization, consider using

    // RecordVersionSynchronizeMasterStart and RecordVersionSynchronizeSlaveStart

    // over a bidirectionnal communication channel like WebSockets

    // - you can use RecordVersionSynchronizeSlaveToBatch if your purpose is

    // to access the updates before applying to the current slave storage

    function RecordVersionSynchronizeSlave(Table: TSQLRecordClass;

      Master: TSQLRest; ChunkRowLimit: integer=0; OnWrite: TOnBatchWrite=nil): TRecordVersion;

    /// synchronous master/slave replication from a slave TSQLRest into a Batch

    // - will retrieve all the updates from a (distant) master TSQLRest for a

    // given TSQLRecord table, using its TRecordVersion field, and a supplied

    // TRecordVersion monotonic value, into a TSQLRestBatch instance

    // - both remote Source and local TSQLRestSever should have the supplied

    // Table class in each of their data model

    // - by default, all pending updates are retrieved, but you can define a value

    // to MaxRowLimit, so that the updates would be retrieved by smaller chunks

    // - returns nil if nothing new was found, or a TSQLRestBatch instance

    // containing all modifications since RecordVersion revision

    // - when executing the returned TSQLRestBatch on the database, you should

    // set TSQLRestServer.RecordVersionDeleteIgnore := true so that the

    // TRecordVersion fields would be forced from the supplied value

    // - usually, you should not need to use this method, but rather the more

    // straightforward RecordVersionSynchronizeSlave()

    function RecordVersionSynchronizeSlaveToBatch(Table: TSQLRecordClass;

      Master: TSQLRest; var RecordVersion: TRecordVersion;

      MaxRowLimit: integer=0; OnWrite: TOnBatchWrite=nil): TSQLRestBatch; virtual;

    /// initiate asynchronous master/slave replication on a master TSQLRest

    // - allow synchronization of a TSQLRecord table, using its TRecordVersion

    // field, for real-time master/slave replication on the master side

    // - this method will register the IServiceRecordVersion service on the

    // server side, so that RecordVersionSynchronizeStartSlave() would be able

    // to receive push notifications of any updates

    // - this method expects the communication channel to be bidirectional, e.g.

    // a mORMotHTTPServer's TSQLHttpServer in useBidirSocket mode

    function RecordVersionSynchronizeMasterStart(ByPassAuthentication: boolean=false): boolean;

    /// initiate asynchronous master/slave replication on a slave TSQLRest

    // - start synchronization of a TSQLRecord table, using its TRecordVersion

    // field, for real-time master/slave replication on the slave side

    // - this method will first retrieve any pending modification by regular

    // REST calls to RecordVersionSynchronizeSlave, then create and register a

    // callback instance using RecordVersionSynchronizeSubscribeMaster()

    // - this method expects the communication channel to be bidirectional, e.g.

    // a TSQLHttpClientWebsockets

    // - the modifications will be pushed by the master, then applied to the

    // slave storage, until RecordVersionSynchronizeSlaveStop method is called

    // - an optional OnNotify event may be defined, which will be triggered

    // for all incoming change, supllying the updated TSQLRecord instance

    function RecordVersionSynchronizeSlaveStart(Table: TSQLRecordClass;

      MasterRemoteAccess: TSQLRestClientURI; OnNotify: TOnBatchWrite=nil): boolean;

    /// finalize asynchronous master/slave replication on a slave TSQLRest

    // - stop synchronization of a TSQLRecord table, using its TRecordVersion

    // field, for real-time master/slave replication on the slave side

    // - expect a previous call to RecordVersionSynchronizeSlaveStart

    function RecordVersionSynchronizeSlaveStop(Table: TSQLRecordClass): boolean;

    /// low-level callback registration for asynchronous master/slave replication

    // - you should not have to use this method, but rather

    // RecordVersionSynchronizeMasterStart and RecordVersionSynchronizeSlaveStart

    // RecordVersionSynchronizeSlaveStop methods

    // - register a callback interface on the master side, which will be called

    // each time a write operation is performed on a given TSQLRecord with a

    // TRecordVersion field

    // - the callback parameter could be a TServiceRecordVersionCallback instance,

    // which would perform all update operations as expected

    // - the callback process would be blocking for the ORM write point of view:

    // so it should be as fast as possible, or asynchronous - note that regular

    // callbacks using WebSockets, as implemented by SynBidirSock.pas and

    // mORMotHTTPServer's TSQLHttpServer in useBidirSocket mode, are asynchronous

    // - if the supplied RecordVersion is not the latest on the server side,

    // this method will return FALSE and the caller should synchronize again via

    // RecordVersionSynchronize() to avoid any missing update

    // - if the supplied RecordVersion is the latest on the server side,

    // this method will return TRUE and put the Callback notification in place

    function RecordVersionSynchronizeSubscribeMaster(Table: TSQLRecordClass;

      RecordVersion: TRecordVersion; const SlaveCallback: IServiceRecordVersionCallback): boolean; overload;

    /// this method is called internally after any successfull deletion to

    // ensure relational database coherency

    // - reset all matching TRecordReference properties in the database Model,

    // for database coherency, into 0

    // - delete all records containing a matched TRecordReferenceToBeDeleted

    // property value in the database Model (e.g. TSQLRecordHistory)

    // - reset all matching TSQLRecord properties in the database Model,

    // for database coherency, into 0

    // - important notice: we don't use FOREIGN KEY constraints in this framework,

    // and handle all integrity check within this method (it's therefore less

    // error-prone, and more cross-database engine compatible)

    function AfterDeleteForceCoherency(aTableIndex: integer; aID: TID): boolean; virtual;

    /// update all BLOB fields of the supplied Value

    // - this overridden method will execute the direct static class, if any

    function UpdateBlobFields(Value: TSQLRecord): boolean; override;

    /// get all BLOB fields of the supplied value from the remote server

    // - this overridden method will execute the direct static class, if any

    function RetrieveBlobFields(Value: TSQLRecord): boolean; override;

    /// implement Server-Side TSQLRest unlocking

    // - to be called e.g. after a Retrieve() with forupdate=TRUE

    // - implements our custom UNLOCK REST-like verb

    // - locking is handled by TSQLServer.Model

    // - returns true on success

    function UnLock(Table: TSQLRecordClass; aID: TID): boolean; override;

    /// end a transaction

    // - implements REST END collection

    // - write all pending TSQLVirtualTableJSON data to the disk

    procedure Commit(SessionID: cardinal; RaiseException: boolean); override;



    /// grant access to this database content from a dll using the global

    // URIRequest() function

    // - returns true if the URIRequest() function is set to this TSQLRestServer

    // - returns false if a TSQLRestServer was already exported

    // - client must release all memory acquired by URIRequest() with GlobalFree()

    function ExportServer: boolean; overload;

    {$ifdef MSWINDOWS}

    /// declare the server on the local machine as a Named Pipe: allows

    // TSQLRestClientURINamedPipe local or remote client connection

    // - ServerApplicationName ('DBSERVER' e.g.) will be used to create a named

    // pipe server identifier, it is of UnicodeString type since Delphi 2009

    // (use of Unicode FileOpen() version)

    // - this server identifier is appended to '\\.\pipe\mORMot_' to obtain

    // the full pipe name to initiate ('\\.\pipe\mORMot_DBSERVER' e.g.)

    // - this server identifier may also contain a fully qualified path

    // ('\\.\pipe\ApplicationName' e.g.)

    // - allows only one ExportServer*() by running process

    // - returns true on success, false otherwise (ServerApplicationName already used?)

    function ExportServerNamedPipe(const ServerApplicationName: TFileName): boolean;

    /// end any currently initialized named pipe server

    function CloseServerNamedPipe: boolean;

    /// declare the server on the local machine to be accessible for local

    // client connection, by using Windows messages

    // - the data is sent and received by using the standard and fast WM_COPYDATA message

    // - Windows messages are very fast (faster than named pipe and much faster

    // than HTTP), but only work localy on the same computer

    // - create a new Window Class with the supplied class name (UnicodeString

    // since Delphi 2009 for direct use of Wide Win32 API), and instanciate

    // a window which will handle pending WM_COPYDATA messages

    // - the main server instance has to process the windows messages regularely

    // (e.g. with Application.ProcessMessages)

    // - ServerWindowName ('DBSERVER' e.g.) will be used to create a

    // Window name identifier

    // - allows only one ExportServer*() by running process

    // - returns true on success, false otherwise (ServerWindowName already used?)

    function ExportServerMessage(const ServerWindowName: string): boolean;

    /// implement a message-based server response

    // - this method is called automaticaly if ExportServerMessage() method

    // was initilialized

    // - you can also call this method from the WM_COPYDATA message handler

    // of your main form, and use the TSQLRestClientURIMessage class to access

    // the server instance from your clients

    // - it will answer to the Client with another WM_COPYDATA message

    // - message oriented architecture doesn't need any thread, but will use

    // the main thread of your application

    procedure AnswerToMessage(var Msg: TWMCopyData); message WM_COPYDATA;

    /// end any currently initialized message-oriented server

    function CloseServerMessage: boolean;

    /// returns TRUE if remote connection is possible via named pipes or Windows

    // messages

    function ExportedAsMessageOrNamedPipe: Boolean;

    {$endif}

    /// Server initialization with a specified Database Model

    // - if HandleUserAuthentication is false, will set URI access rights to

    // 'Supervisor' (i.e. all R/W access) by default

    // - if HandleUserAuthentication is true, will add TSQLAuthUser and

    // TSQLAuthGroup to the TSQLModel (if not already there)

    constructor Create(aModel: TSQLModel; aHandleUserAuthentication: boolean=false); reintroduce; virtual;

    /// Server initialization with a temporary Database Model

    // - a Model will be created with supplied tables, and owned by the server

    // - if you instantiate a TSQLRestServerFullMemory or TSQLRestServerDB

    // with this constructor, an in-memory engine will be created, with

    // enough abilities to run regression tests, for instance

    constructor CreateWithOwnModel(const Tables: array of TSQLRecordClass;

      aHandleUserAuthentication: boolean=false; const aRoot: RawUTF8='root');

    /// create a new minimal TSQLRestServer instance, to be used with

    // external SQL or NoSQL storage

    // - will try to instantiate an in-memory TSQLRestServerDB, and if

    // mORMotSQLite3.pas is not linked, fallback to a TSQLRestServerFullMemory

    // - used e.g. by TSQLRestMongoDBCreate() and TSQLRestExternalDBCreate()

    class function CreateInMemoryForAllVirtualTables(aModel: TSQLModel;

      aHandleUserAuthentication: boolean): TSQLRestServer;

    /// release memory and any existing pipe initialized by ExportServer()

    destructor Destroy; override;



    /// you can call this method to prepare the server for shutting down

    // - it will reject any incoming request from now on, and will wait until

    // all pending requests are finished, for proper server termination

    // - you could optionally save the current server state (e.g. user sessions)

    // into a file, ready to be retrieved later on using SessionsLoadFromFile -

    // note that this would work only for ORM sessions, NOT complex SOA state

    // - this method is called by Destroy itself

    procedure Shutdown(const aStateFileName: TFileName=''); virtual;



    /// Missing tables are created if they don't exist yet for every TSQLRecord

    // class of the Database Model

    // - you must call explicitely this before having called StaticDataCreate()

    // - all table description (even Unique feature) is retrieved from the Model

    // - this method should also create additional fields, if the TSQLRecord definition

    // has been modified; only field adding is mandatory, field renaming or

    // field deleting are not allowed in the FrameWork (in such cases, you must

    // create a new TSQLRecord type)

    // - this virtual method do nothing by default - overridden versions should

    // implement it as expected by the underlying storage engine (e.g. SQLite3

    // or TSQLRestServerFullInMemory)

    // - you can tune some options transmitted to the TSQLRecord.InitializeTable

    // virtual methods, e.g. to avoid the automatic create of indexes

    procedure CreateMissingTables(user_version: cardinal=0;

      options: TSQLInitializeTableOptions=[]); virtual;

    /// run the TSQLRecord.InitializeTable methods for all void tables of the model

    // - can be used instead of CreateMissingTables e.g. for MongoDB storage

    // - you can specify the creation options, e.g. INITIALIZETABLE_NOINDEX

    procedure InitializeTables(Options: TSQLInitializeTableOptions);

    /// create an external static in-memory database for a specific class

    // - call it just after Create, before TSQLRestServerDB.CreateMissingTables;

    // warning: if you don't call this method before CreateMissingTable method

    // is called, the table will be created as a regular table by the main

    // database engine, and won't be static

    // - can load the table content from a file if a file name is specified

    // (could be either JSON or compressed Binary format on disk)

    // - you can define a particular external engine by setting a custom class -

    // by default, it will create a TSQLRestStorageInMemory instance

    // - this data handles basic REST commands, since no complete SQL interpreter

    // can be implemented by TSQLRestStorage; to provide full SQL process,

    // you should better use a Virtual Table class, inheriting e.g. from

    // TSQLRecordVirtualTableAutoID associated with TSQLVirtualTableJSON/Binary

    // via a Model.VirtualTableRegister() call before TSQLRestServer.Create

    // - return nil on any error, or an EModelException if the class is not in

    // the database model

    function StaticDataCreate(aClass: TSQLRecordClass;

      const aFileName: TFileName = ''; aBinaryFile: boolean=false;

      aServerClass: TSQLRestStorageInMemoryClass=nil): TSQLRestStorage;

    /// register an external static storage for a given table

    // - will be added to StaticDataServer[] internal list

    // - called e.g. by StaticDataCreate(), RemoteDataCreate() or

    // StaticMongoDBRegister()

    function StaticDataAdd(aStaticData: TSQLRestStorage): boolean;

    /// create an external static redirection for a specific class

    // - call it just after Create, before TSQLRestServerDB.CreateMissingTables;

    // warning: if you don't call this method before CreateMissingTable method

    // is called, the table will be created as a regular table by the main

    // database engine, and won't be static

    // - the specified TSQLRecord will have all its CRUD / ORM methods be

    // redirected to aRemoteRest, which may be a TSQLRestClient or another

    // TSQLRestServer instance (e.g. a fast SQLITE_MEMORY_DATABASE_NAME)

    // - if aRemoteRest is a TSQLRestClient, it should have been authenticated

    // to the remote TSQLRestServer, so that CRUD / ORM operations would pass

    // - this would enable easy creation of proxies, or local servers, with they

    // own cache and data model - e.g. a branch office server which may server

    // its local client over Ethernet, but communicating to a main mORMot

    // server via Internet, storing the corporate data in the main office server

    function RemoteDataCreate(aClass: TSQLRecordClass; aRemoteRest: TSQLRest): TSQLRestStorageRemote; virtual;

    /// call this method when the internal DB content is known to be invalid

    // - by default, all REST/CRUD requests and direct SQL statements are

    // scanned and identified as potentially able to change the internal SQL/JSON

    // cache used at SQLite3 database level; but some virtual tables (e.g.

    // TSQLRestStorageExternal classes defined in mORMotDB) could flush

    // the database content without proper notification

    // - this default implementation will just do nothing, but mORMotSQlite3

    // unit will call TSQLDataBase.CacheFlush method

    procedure FlushInternalDBCache; virtual;

    /// you can call this method in TThread.Execute to ensure that

    // the thread will be taken in account during process

    // - caller must specify the TThread instance running

    // - used e.g. for optExecInMainThread option in TServiceMethodExecute

    // - this default implementation will call the methods of all its internal

    // TSQLRestStorage instances

    // - this method shall be called from the thread just initiated: e.g.

    // if you call it from the main thread, it may fail to prepare resources

    procedure BeginCurrentThread(Sender: TThread); override;

    /// you can call this method just before a thread is finished to ensure

    // e.g. that the associated external DB connection will be released

    // - this default implementation will call the methods of all its internal

    // TSQLRestStorage instances, allowing e.g. TSQLRestStorageExternal

    // instances to clean their thread-specific connections

    // - this method shall be called from the thread about to be terminated: e.g.

    // if you call it from the main thread, it may fail to release resources

    // - it is set e.g. by TSQLite3HttpServer to be called from HTTP threads,

    // or by TSQLRestServerNamedPipeResponse for named-pipe server cleaning

    procedure EndCurrentThread(Sender: TThread); override;



    /// implement a generic local, piped or HTTP/1.1 provider

    // - this is the main entry point of the server, from the client side

    // - default implementation calls protected methods EngineList() Retrieve()

    // Add() Update() Delete() UnLock() EngineExecute() above, which must be overridden by

    // the TSQLRestServer child

    // - for 'GET ModelRoot/TableName', url parameters can be either "select" and

    // "where" (to specify a SQL Query, from the SQLFromSelectWhere function),

    // either "sort", "dir", "startIndex", "results", as expected by the YUI

    // DataSource Request Syntax for data pagination - see

    // http://developer.yahoo.com/yui/datatable/#data

    // - execution of this method could be monitored via OnBeforeURI and OnAfterURI

    // event handlers

    procedure URI(var Call: TSQLRestURIParams); virtual;



    /// create an index for the specific FieldName

    // - will call CreateSQLMultiIndex() internaly

    function CreateSQLIndex(Table: TSQLRecordClass; const FieldName: RawUTF8;

      Unique: boolean; const IndexName: RawUTF8=''): boolean; overload;

    /// create one or multiple index(es) for the specific FieldName(s)

    function CreateSQLIndex(Table: TSQLRecordClass; const FieldNames: array of RawUTF8;

      Unique: boolean): boolean; overload;

    /// create one index for all specific FieldNames at once

    // - will call any static engine for the index creation of such tables, or

    // execute a CREATE INDEX IF NOT EXISTS on the main engine

    // - note that with SQLite3, your database schema should never contain two

    // indices where one index is a prefix of the other, e.g. if you defined:

    // ! aServer.CreateSQLMultiIndex(TEmails, ['Email','GroupID'], True);

    // Then the following index is not mandatory for SQLite3:

    // ! aServer.CreateSQLIndex(TEmails, 'Email', False);

    // see "1.6 Multi-Column Indices" in @http://www.sqlite.org/queryplanner.html

    function CreateSQLMultiIndex(Table: TSQLRecordClass; const FieldNames: array of RawUTF8;

      Unique: boolean; IndexName: RawUTF8=''): boolean; virtual;



    /// call this method to add an authentication method to the server

    // - will return the just created TSQLRestServerAuthentication instance,

    // or the existing instance if it has already been registered

    // - you can use this method to tune the authencation, e.g. if you have

    // troubles with AJAX asynchronous callbacks:

    // ! (aServer.AuthenticationRegister(TSQLRestServerAuthenticationDefault) as

    // !   TSQLRestServerAuthenticationSignedURI).NoTimeStampCoherencyCheck := true;

    function AuthenticationRegister(

      aMethod: TSQLRestServerAuthenticationClass): TSQLRestServerAuthentication; overload;

    /// call this method to add several authentication methods to the server

    // - if TSQLRestServer.Create() constructor is called with aHandleUserAuthentication

    // set to TRUE, it will register the two following classes:

    // ! AuthenticationRegister([TSQLRestServerAuthenticationDefault,TSQLRestServerAuthenticationSSPI]);

    procedure AuthenticationRegister(const aMethods: array of TSQLRestServerAuthenticationClass); overload;

    /// call this method to remove an authentication method to the server

    procedure AuthenticationUnregister(aMethod: TSQLRestServerAuthenticationClass); overload;

    /// call this method to remove several authentication methods to the server

    procedure AuthenticationUnregister(const aMethods: array of TSQLRestServerAuthenticationClass); overload;

    /// call this method to remove all authentication methods to the server

    procedure AuthenticationUnregisterAll;

    /// add all published methods of a given object instance to the method-based

    // list of services

    // - all those published method signature should match TSQLRestServerCallBack

    procedure ServiceMethodRegisterPublishedMethods(const aPrefix: RawUTF8;

      aInstance: TObject);

    /// direct registration of a method for a given low-level event handler

    procedure ServiceMethodRegister(aMethodName: RawUTF8;

      const aEvent: TSQLRestServerCallBack; aByPassAuthentication: boolean=false);

    /// call this method to disable Authentication method check for a given

    // published method-based service name

    // - by default, only Auth and TimeStamp methods do not require the RESTful

    // authentication of the URI; you may call this method to add another method

    // to the list (e.g. for returning some HTML content from a public URI)

    // - if the supplied aMethodName='', all method-based services would

    // bypass the authenticaton process

    procedure ServiceMethodByPassAuthentication(const aMethodName: RawUTF8);

    /// retrieve detailed statistics about a method-based service use

    // - will return a reference to the actual alive item: caller should

    // not free the returned instance

    property ServiceMethodStat[const aMethod: RawUTF8]: TSynMonitorInputOutput

      read GetServiceMethodStat;

    /// used e.g. by IAdministratedDaemon to implement "pseudo-SQL" commands

    procedure AdministrationExecute(const DatabaseName,SQL: RawUTF8;

      var result: TServiceCustomAnswer); override;

    /// compute a JSON description of all available services, and its public URI

    // - the JSON object matches the TServicesPublishedInterfaces record type

    // - used by TSQLRestClientURI.ServicePublishOwnInterfaces to register all

    // the services supportes by the client itself

    // - warning: the public URI should have been set via SetPublicURI()

    function ServicesPublishedInterfaces: RawUTF8;

    /// the HTTP server should call this method so that ServicesPublishedInterfaces

    // registration would be able to work

    procedure SetPublicURI(const Address,Port: RawUTF8);

    /// a list of the services associated by all clients of this server instance

    // - when a client connects to this server, it would publish its own services

    // (when checking its interface contract), so that they may be identified

    property AssociatedServices: TServicesPublishedInterfacesList read fAssociatedServices;

    /// returns a copy of the user associated to a session ID

    // - returns nil if the session does not exist (e.g. if authentication is

    // disabled)

    // - caller MUST release the TSQLAuthUser instance returned (if not nil)

    // - this method IS thread-safe, and call internaly fSessions.Lock

    // (the returned TSQLAuthUser is a private copy from fSessions[].User instance,

    // in order to be really thread-safe)

    // - the returned TSQLAuthUser instance will have GroupRights=nil but will

    // have ID, LogonName, DisplayName, PasswordHashHexa and Data fields available

    function SessionGetUser(aSessionID: Cardinal): TSQLAuthUser;

    /// persist all in-memory sessions into a compressed binary file

    // - you should not call this method it directly, but rather use Shutdown()

    // with a StateFileName parameter - to be used e.g. for a short maintainance

    // server shutdown, without loosing the current logged user sessions

    // - this method IS thread-safe, and call internaly fSessions.Lock

    procedure SessionsSaveToFile(const aFileName: TFileName);

    /// re-create all in-memory sessions from a compressed binary file

    // - typical use is after a server restart, with the file supplied to the

    // Shutdown() method: it could be used e.g. for a short maintainance server

    // shutdown, without loosing the current logged user sessions

    // - WARNING: this method would restore authentication sessions for the ORM,

    // but not any complex state information used by interface-based services,

    // like sicClientDriven class instances - DO NOT use this feature with SOA

    // - this method IS thread-safe, and call internaly fSessions.Lock

    procedure SessionsLoadFromFile(const aFileName: TFileName;

      andDeleteExistingFileAfterRead: boolean);

    /// retrieve all current session information as a JSON array

    function SessionsAsJson: RawJSON;



    /// register a Service class on the server side

    // - this methods expects a class to be supplied, and the exact list of

    // interfaces to be registered to the server (e.g. [TypeInfo(IMyInterface)])

    // and implemented by this class

    // - class can be any TInterfacedObject, but TInterfacedObjectWithCustomCreate

    // can be used if you need an overridden constructor

    // - instance implementation pattern will be set by the appropriate parameter

    // - will return the first of the registered TServiceFactoryServer created

    // on success (i.e. the one corresponding to the first item of the aInterfaces

    // array), or nil if registration failed (e.g. if any of the supplied interfaces

    // is not implemented by the given class)

    // - you can use the returned TServiceFactoryServer instance to set the

    // expected security parameters associated with this interface

    // - the same implementation class can be used to handle several interfaces

    // (just as Delphi allows to do natively)

    function ServiceRegister(aImplementationClass: TInterfacedClass;

      const aInterfaces: array of PTypeInfo;

      aInstanceCreation: TServiceInstanceImplementation=sicSingle;

      const aContractExpected: RawUTF8=''): TServiceFactoryServer; overload; virtual;

    /// register a Service instance on the server side

    // - this methods expects a class instance to be supplied, and the exact list

    // of interfaces to be registered to the server (e.g. [TypeInfo(IMyInterface)])

    // and implemented by this shared instance

    // - as a consequence, instance implementation pattern will always be sicShared

    // - will return the first of the registered TServiceFactoryServer created

    // on success (i.e. the one corresponding to the first item of the aInterfaces

    // array), or nil if registration failed (e.g. if any of the supplied interfaces

    // is not implemented by the given class)

    // - you can use the returned TServiceFactoryServer instance to set the

    // expected security parameters associated with this interface

    // - the same implementation class can be used to handle several interfaces

    // (just as Delphi allows to do natively)

    function ServiceRegister(aSharedImplementation: TInterfacedObject;

      const aInterfaces: array of PTypeInfo; const aContractExpected: RawUTF8=''): TServiceFactoryServer; overload; virtual;

    /// register a remote Service via its interface

    // - this overloaded method will register a remote Service, accessed via the

    // supplied TSQLRest(ClientURI) instance: it can be available in the main

    // TSQLRestServer.Services property, but execution will take place on a

    // remote server - may be used e.g. for dedicated hosting of services (in

    // a DMZ for instance)

    // - this methods expects a list of interfaces to be registered to the client

    // (e.g. [TypeInfo(IMyInterface)])

    // - instance implementation pattern will be set by the appropriate parameter

    // - will return true on success, false if registration failed (e.g. if any of

    // the supplied interfaces is not correct or is not available on the server)

    // - that is, server side will be called to check for the availability of

    // each interface

    // - you can specify an optional custom contract for the first interface

    function ServiceRegister(aClient: TSQLRest; const aInterfaces: array of PTypeInfo;

      aInstanceCreation: TServiceInstanceImplementation=sicSingle;

      const aContractExpected: RawUTF8=''): boolean; overload; virtual;

    /// register a Service class on the server side

    // - this method expects the interface(s) to have been registered previously:

    // ! TInterfaceFactory.RegisterInterfaces([TypeInfo(IMyInterface),...]);

    function ServiceDefine(aImplementationClass: TInterfacedClass;

      const aInterfaces: array of TGUID;

      aInstanceCreation: TServiceInstanceImplementation=sicSingle;

      const aContractExpected: RawUTF8=''): TServiceFactoryServer; overload;

    /// register a Service instance on the server side

    // - this method expects the interface(s) to have been registered previously:

    // ! TInterfaceFactory.RegisterInterfaces([TypeInfo(IMyInterface),...]);

    // - the supplied aSharedImplementation will be owned by this Server instance

    function ServiceDefine(aSharedImplementation: TInterfacedObject;

      const aInterfaces: array of TGUID; const aContractExpected: RawUTF8=''): TServiceFactoryServer; overload;

    /// register a remote Service via its interface

    // - this method expects the interface(s) to have been registered previously:

    // ! TInterfaceFactory.RegisterInterfaces([TypeInfo(IMyInterface),...]);

    function ServiceDefine(aClient: TSQLRest; const aInterfaces: array of TGUID;

      aInstanceCreation: TServiceInstanceImplementation=sicSingle;

      const aContractExpected: RawUTF8=''): boolean; overload;

    /// access or initialize the internal IoC resolver, used for interface-based

    // remote services, and more generaly any Services.Resolve() call

    // - create and initialize the internal TServiceContainerServer if no

    // service interface has been registered yet

    // - may be used to inject some dependencies, which are not interface-based

    // remote services, but internal IoC, without the ServiceRegister()

    // or ServiceDefine() methods - e.g.

    // ! aRest.ServiceContainer.InjectResolver([TInfraRepoUserFactory.Create(aRest)],true);

    // - this overriden method would return a TServiceContainerServer instance

    // - you may enable SOA audit trail for all methods execution:

    // ! (aRestSOAServer.ServiceContainer as TServiceContainerServer).SetServiceLog(

    // !   aRestLogServer,TSQLRecordServiceLog);

    function ServiceContainer: TServiceContainer; override;



    /// compute the full statistics about this server, as JSON

    // - is a wrapper around the Stats() method-based service, setting withall=1

    function FullStatsAsJson: RawUTF8; virtual;

    /// compute the full statistics about this server, as a TDocVariant document

    // - is a wrapper around the Stats() method-based service, setting withall=1

    function FullStatsAsDocVariant: variant;



    /// read-only access to the list of registered server-side authentication

    // methods, used for session creation

    // - note that the exact number or registered services in this list is

    // stored in the AuthenticationSchemesCount property

    property AuthenticationSchemes: TSQLRestServerAuthenticationDynArray

      read fSessionAuthentication;

    /// how many authentication methods are registered in AuthenticationSchemes

    property AuthenticationSchemesCount: integer

      read GetAuthenticationSchemesCount;

    /// retrieve the TSQLRestStorage instance used to store and manage

    // a specified TSQLRecordClass in memory

    // - has been associated by the StaticDataCreate method

    property StaticDataServer[aClass: TSQLRecordClass]: TSQLRest

      read GetStaticDataServer;

    /// retrieve a running TSQLRestStorage virtual table

    // - associated e.g. to a 'JSON' or 'Binary' virtual table module, or may

    // return a TSQLRestStorageExternal instance (as defined in mORMotDB)

    // - this property will return nil if there is no Virtual Table associated

    // or if the corresponding module is not a TSQLVirtualTable

    // (e.g. "pure" static tables registered by StaticDataCreate would be

    // accessible only via StaticDataServer[], not via StaticVirtualTable[])

    // - has been associated by the TSQLModel.VirtualTableRegister method or

    // the VirtualTableExternalRegister() global function

    property StaticVirtualTable[aClass: TSQLRecordClass]: TSQLRest

      read GetVirtualTable;

    /// the options specified to TSQLRestServer.CreateMissingTables

    // - as expected by TSQLRecord.InitializeTable methods

    property CreateMissingTablesOptions: TSQLInitializeTableOptions

      read fCreateMissingTablesOptions;

    /// the URI to redirect any plain GET on root URI, without any method

    // - could be used to ease access from web browsers URI

    property RootRedirectGet: RawUTF8 read fRootRedirectGet write fRootRedirectGet;

    /// you can force this property to TRUE so that any Delete() would not

    // write to the TSQLRecordTableDelete table for TRecordVersion tables

    // - to be used when applying a TSQLRestBatch instance as returned by

    // RecordVersionSynchronizeToBatch()

    property RecordVersionDeleteIgnore: boolean

      read fRecordVersionDeleteIgnore write fRecordVersionDeleteIgnore;

  published

    /// set this property to true to transmit the JSON data in a "not expanded" format

    // - not directly compatible with Javascript object list decode: not to be

    // used in AJAX environnement (like in TSQLite3HttpServer)

    // - but transmitted JSON data is much smaller if set it's set to FALSE, and

    // if you use a Delphi Client, parsing will be also faster and memory usage

    // will be lower

    // - By default, the NoAJAXJSON property is set to TRUE in

    // TSQLRestServer.ExportServerNamedPipe: if you use named pipes for communication,

    // you probably won't use javascript because browser communicates via HTTP!

    // - But otherwise, NoAJAXJSON property is set to FALSE. You could force its

    // value to TRUE and you'd save some bandwidth if you don't use javascript:

    // even the parsing of the JSON Content will be faster with Delphi client

    // if JSON content is not expanded

    // - the "expanded" or standard/AJAX layout allows you to create pure JavaScript

    // objects from the JSON content, because the field name / JavaScript object

    // property name is supplied for every value

    // - the "not expanded" layout, NoAJAXJSON property is set to TRUE,

    // reflects exactly the layout of the SQL request - first line contains the

    // field names, then all next lines are the field content

    // - is in fact stored in rsoNoAJAXJSON item in Options property

    property NoAJAXJSON: boolean read GetNoAJAXJSON write SetNoAJAXJSON;

    /// allow to customize how TSQLRestServer.URI process the requests

    // - e.g. if HTML_SUCCESS with no body should be translated into HTML_NOCONTENT

    property Options: TSQLRestServerOptions read fOptions write fOptions;

    /// set to true if the server will handle per-user authentication and

    // access right management

    // - i.e. if the associated TSQLModel contains TSQLAuthUser and

    // TSQLAuthGroup tables (set by constructor)

    property HandleAuthentication: boolean read fHandleAuthentication;

    /// allow to by-pass Authentication for a given set of HTTP verbs

    // - by default, RESTful access to the ORM would follow HandleAuthentication

    /// setting: but you could define some HTTP verb to this property, which

    // would by-pass the authentication - may be used e.g. for public GET

    // of the content by an AJAX client 

    property BypassORMAuthentication: TSQLURIMethods read fBypassORMAuthentication write fBypassORMAuthentication;

    /// read-only access to the high-level Server statistics

    // - see ServiceMethodStat[] for information about method-based services,

    // or TServiceFactoryServer.Stats / Stat[] for interface-based services

    // - statistics are available remotely as JSON from the Stat() method

    property Stats: TSQLRestServerMonitor read fStats;

    /// which level of detailed information is gathered

    // - by default, contains SERVERDEFAULTMONITORLEVELS, i.e.

    // ! [mlTables,mlMethods,mlInterfaces,mlSQLite3]

    // - you can add mlSessions to maintain per-session statistics: this would

    // lead into a slightly higher memory consumption, for each session

    property StatLevels: TSQLRestServerMonitorLevels read fStatLevels write fStatLevels;

    /// could be set to track statistic from Stats information

    // - it may be e.g. a TSynMonitorUsageRest instance for REST storage

    property StatUsage: TSynMonitorUsage read fStatUsage write SetStatUsage;

    /// this property can be left to its TRUE default value, to handle any

    // TSQLVirtualTableJSON static tables (module JSON or BINARY) with direct

    // calls to the storage instance

    // - is set to TRUE by default to enable faster Direct mode

    // - in Direct mode, GET/POST/PUT/DELETE of individual records (or BLOB fields)

    // from URI() will call directly the corresponding TSQLRestStorage

    // instance, for better speed for most used RESTful operations; but complex

    // SQL requests (e.g. joined SELECT) will rely on the main SQL engine

    // - if set to false, will use the main SQLite3 engine for all statements

    // (should not to be used normaly, because it will add unnecessary overhead)

    property StaticVirtualTableDirect: boolean read fVirtualTableDirect

      write fVirtualTableDirect;

    /// the class inheriting from TSQLAuthUser, as defined in the model

    // - during authentication, this class will be used for every TSQLAuthUser

    // table access

    // - see also the OnAuthenticationUserRetrieve optional event handler

    property SQLAuthUserClass: TSQLAuthUserClass read fSQLAuthUserClass;

    /// the class inheriting from TSQLAuthGroup, as defined in the model

    // - during authentication, this class will be used for every TSQLAuthGroup

    // table access

    property SQLAuthGroupClass: TSQLAuthGroupClass read fSQLAuthGroupClass;

    /// the class inheriting from TSQLRecordTableDeleted, as defined in the model

    // - during authentication, this class will be used for storing a trace of

    // every deletion of table rows containing a TRecordVersion published field

    property SQLRecordVersionDeleteTable: TSQLRecordTableDeletedClass

      read fSQLRecordVersionDeleteTable;

    /// the class inheriting from TAuthSession to handle in-memory sessions

    // - since all sessions data remain in memory, ensure they are not taking

    // too much resource (memory or process time)

    property SessionClass: TAuthSessionClass read fSessionClass write fSessionClass;

  published { standard method-based services }

    /// REST service accessible from ModelRoot/Stat URI to gather detailed information

    // - returns the current execution statistics of this server, as a JSON object

    // - this method would require an authenticated client, for safety

    // - by default, will return the high-level information of this server

    // - will return human-readable JSON layout if ModelRoot/Stat/json is used, or

    // the corresponding XML content if ModelRoot/Stat/xml is used

    // - you can define withtables, withmethods, withinterfaces, withsessions or

    // withsqlite3 additional parameters to return detailed information about

    // method-based services, interface-based services, per session statistics,

    // or prepared SQLite3 SQL statement timing (for a TSQLRestServerDB instance)

    // ! Client.CallBackGet('stat',['withtables',true,'withmethods',true,

    // !   'withinterfaces',true,'withsessions',true,'withsqlite3',true],stats);

    // - defining a 'withall' parameter will retrieve all available statistics

    // - note that TSQLRestServer.StatLevels property will enable statistics

    // gathering for tables, methods, interfaces, sqlite3 or sessions

    // - a specific findservice=ServiceName parameter would not return any

    // statistics, but matching URIs from the server AssociatedServices list

    procedure Stat(Ctxt: TSQLRestServerURIContext);

    /// REST service accessible from ModelRoot/Auth URI

    // - called by the clients for authentication and session management

    // - this method would require an authenticated client, by design

    // - this global callback method is thread-safe

    procedure Auth(Ctxt: TSQLRestServerURIContext);

    /// REST service accessible from the ModelRoot/TimeStamp URI

    // - returns the server time stamp TTimeLog/Int64 value as UTF-8 text

    // - this method would not require an authenticated client

    // - hidden ModelRoot/TimeStamp/info command would return basic execution

    // information, less verbose (and sensitive) than Stat(), calling virtual

    // InternalInfo() protected method

    procedure TimeStamp(Ctxt: TSQLRestServerURIContext);

    /// REST service accessible from the ModelRoot/CacheFlush URI

    // - it will flush the server result cache

    // - this method shall be called by the clients when the Server cache may be

    // not consistent any more (e.g. after a direct write to an external database)

    // - this method would require an authenticated client, for safety

    // - GET ModelRoot/CacheFlush URI will flush the whole Server cache,

    // for all tables

    // - GET ModelRoot/CacheFlush/TableName URI will flush the specified

    // table cache

    // - GET ModelRoot/CacheFlush/TableName/TableID URI will flush the content

    // of the specified record

    // - in addition, POST ModelRoot/CacheFlush/_callback_ URI will be called

    // automatically by the client, to notify the server that an interface

    // callback instance has been released

    procedure CacheFlush(Ctxt: TSQLRestServerURIContext);

    /// REST service accessible from the ModelRoot/Batch URI

    // - will execute a set of RESTful commands, in a single step, with optional

    // automatic SQL transaction generation

    // - this method would require an authenticated client, for safety

    // - expect input as JSON commands:

    // & '{"Table":["cmd":values,...]}'

    // or for multiple tables:

    // & '["cmd@Table":values,...]'

    // with cmd in POST/PUT with {object} as value or DELETE with ID

    // - returns an array of integers: '[200,200,...]' or '["OK"]' if all

    // returned status codes are 200 (HTML_SUCCESS)

    // - URI are either 'ModelRoot/TableName/Batch' or 'ModelRoot/Batch'

    procedure Batch(Ctxt: TSQLRestServerURIContext);

  end;



  /// REST class with direct access to an external database engine

  // - you can set an alternate per-table database engine by using this class

  // - this abstract class is to be overridden with a proper implementation

  // (e.g. TSQLRestStorageInMemory in this unit, or TSQLRestStorageExternal

  // from mORMotDB unit, or TSQLRestStorageMongoDB from mORMotMongoDB unit)

  TSQLRestStorage = class(TSQLRest)

  protected

    fStoredClass: TSQLRecordClass;

    fStoredClassProps: TSQLModelRecordProperties;

    fStoredClassRecordProps: TSQLRecordProperties;

    fStorageLockShouldIncreaseOwnerInternalState: boolean;

    fStorageLockLogTrace: boolean;

    fModified: boolean;

    fOwner: TSQLRestServer;

    fStorageCriticalSection: TRTLCriticalSection;

    fStorageCriticalSectionCount: integer;

    fBasicSQLCount: RawUTF8;

    fBasicSQLHasRows: array[boolean] of RawUTF8;

    /// any set bit in this field indicates UNIQUE field value

    fIsUnique: TSQLFieldBits;

    /// allow to force refresh for a given Static table

    // - default FALSE means to return the main TSQLRestServer.InternalState

    // - TRUE indicates that OutInternalState := cardinal(-1) will be returned

    fOutInternalStateForcedRefresh: boolean;

    procedure RecordVersionFieldHandle(Occasion: TSQLOccasion;

      var Decoder: TJSONObjectDecoder);

    /// override this method if you want to update the refresh state

    // - returns FALSE if the static table content was not modified (default

    // method implementation is to always return FALSE)

    // - returns TRUE if the table has been refreshed and its content was modified:

    // therefore the client will know he'll need to refresh some content

    function RefreshedAndModified: boolean; virtual;

    /// TSQLRestServer.URI use it for Static.EngineList to by-pass virtual table

    // - this default implementation will return TRUE and replace SQL with

    // SQLSelectAll[true] if it SQL equals SQLSelectAll[false] (i.e. 'SELECT *')

    // - this method is called only if the WHERE clause of SQL refers to the

    // static table name only (not needed to check it twice)

    function AdaptSQLForEngineList(var SQL: RawUTF8): boolean; virtual;

    function GetStoredClassName: RawUTF8;

    function GetCurrentSessionUserID: TID; override;

  public

    /// initialize the abstract storage data

    constructor Create(aClass: TSQLRecordClass; aServer: TSQLRestServer); reintroduce; virtual;

    /// finalize the storage instance

    destructor Destroy; override;

    /// should be called before any access to the storage content

    // - and protected with a try ... finally StorageUnLock; end section

    procedure StorageLock(WillModifyContent: boolean); virtual;

    /// should be called after any StorageLock-protected access to the content

    // - e.g. protected with a try ... finally StorageUnLock; end section

    procedure StorageUnLock; virtual;

    /// you can call this method in TThread.Execute to ensure that

    // the thread will be taken in account during process

    // - this overridden method will do nothing (should have been already made

    // at TSQLRestServer caller level)

    // - children classes may inherit from this method to notify e.g.

    // a third party process (like proper OLE initialization)

    procedure BeginCurrentThread(Sender: TThread); override;

    /// you can call this method just before a thread is finished to ensure

    // e.g. that the associated external DB connection will be released

    // - this overridden method will do nothing (should have been already made

    // at TSQLRestServer caller level)

    // - children classes may inherit from this method to notify e.g.

    // a third party process (like proper OLE initialization)

    procedure EndCurrentThread(Sender: TThread); override;



    /// implement TSQLRest unlocking (UNLOCK verb)

    // - to be called e.g. after a Retrieve() with forupdate=TRUE

    // - locking is handled at (Owner.)Model level

    // - returns true on success

    function UnLock(Table: TSQLRecordClass; aID: TID): boolean; override;

    /// overridden method calling the owner (if any) to guess if this record

    // can be updated or deleted

    function RecordCanBeUpdated(Table: TSQLRecordClass; ID: TID; Action: TSQLEvent;

      ErrorMsg: PRawUTF8 = nil): boolean; override;

    /// create one index for all specific FieldNames at once

    // - do nothing method: will return FALSE (aka error)

    function CreateSQLMultiIndex(Table: TSQLRecordClass; const FieldNames: array of RawUTF8;

      Unique: boolean; IndexName: RawUTF8=''): boolean; virtual;

    /// search for a numerical field value

    // - return true on success (i.e. if some values have been added to ResultID)

    // - store the results into the ResultID dynamic array

    // - faster than OneFieldValues method, which creates a temporary JSON content

    // - this default implementation will call the overloaded SearchField()

    // value after conversion of the FieldValue into RawUTF8

    function SearchField(const FieldName: RawUTF8; FieldValue: Int64;

      out ResultID: TIDDynArray): boolean; overload; virtual;

    /// search for a field value, according to its SQL content representation

    // - return true on success (i.e. if some values have been added to ResultID)

    // - store the results into the ResultID dynamic array

    // - faster than OneFieldValues method, which creates a temporary JSON content

    function SearchField(const FieldName, FieldValue: RawUTF8;

      out ResultID: TIDDynArray): boolean; overload; virtual; abstract;

    /// access or initialize the internal IoC resolver

    // - this overriden method would return always nil, since IoC only makes

    // sense at TSQLRestClient and TSQLRestServer level

    function ServiceContainer: TServiceContainer; override;



    /// read only access to a boolean value set to true if table data was modified

    property Modified: boolean read fModified write fModified;

    /// read only access to the ORM properties of the associated record type

    // - may be nil if this instance is not associated with a TSQLModel

    property StoredClassProps: TSQLModelRecordProperties read fStoredClassProps;

    /// read only access to the RTTI properties of the associated record type

    property StoredClassRecordProps: TSQLRecordProperties read fStoredClassRecordProps;

    /// read only access to the TSQLRestServer using this storage engine

    property Owner: TSQLRestServer read fOwner;

    /// enable low-level trace of StorageLock/StorageUnlock methods

    // - may be used to resolve low-level race conditions

    property StorageLockLogTrace: boolean read fStorageLockLogTrace write fStorageLockLogTrace;

    /// read only access to the class defining the record type stored in this

    // REST storage

    property StoredClass: TSQLRecordClass read fStoredClass;

  published

    /// name of the class defining the record type stored in this REST storage

    property StoredClassName: RawUTF8 read GetStoredClassName;

  end;



  /// event prototype called by TSQLRestStorageInMemory.FindWhereEqual() or

  // TSQLRestStorageInMemory.ForEach() methods

  // - aDest is an opaque pointer, as supplied to FindWhereEqual(), which may

  // point e.g. to a result list, or a shared variable to apply the process

  // - aRec will point to the corresponding item

  // - aIndex will identify the item index in the internal list

  TFindWhereEqualEvent = procedure(aDest: pointer; aRec: TSQLRecord; aIndex: integer) of object;



  /// abstract REST storage exposing some internal TSQLRecord-based methods

  TSQLRestStorageRecordBased = class(TSQLRestStorage)

  protected

    function EngineAdd(TableModelIndex: integer; const SentData: RawUTF8): TID; override;

    function EngineUpdate(TableModelIndex: integer; ID: TID; const SentData: RawUTF8): boolean; override;

  public

    /// manual Add of a TSQLRecord

    // - returns the ID created on success

    // - returns -1 on failure (not UNIQUE field value e.g.)

    // - on success, the Rec instance is added to the Values[] list: caller

    // doesn't need to Free it

    function AddOne(Rec: TSQLRecord; ForceID: boolean; const SentData: RawUTF8): TID; virtual; abstract;

    /// manual Retrieval of a TSQLRecord field values

    // - an instance of the associated static class is created

    // - and all its properties are filled from the Items[] values

    // - caller can modify these properties, then use UpdateOne() if the changes

    // have to be stored inside the Items[] list

    // - calller must always free the returned instance

    // - returns NIL if any error occured, e.g. if the supplied aID was incorrect

    // - method available since a TSQLRestStorage instance may be created

    // stand-alone, i.e. without any associated Model/TSQLRestServer

    function GetOne(aID: TID): TSQLRecord; virtual; abstract;

    /// manual Update of a TSQLRecord field values

    // - Rec.ID specifies which record is to be updated

    // - will update all properties, including BLOB fields and such

    // - returns TRUE on success, FALSE on any error (e.g. invalid Rec.ID)

    // - method available since a TSQLRestStorage instance may be created

    // stand-alone, i.e. without any associated Model/TSQLRestServer

    function UpdateOne(Rec: TSQLRecord; const SentData: RawUTF8): boolean; overload; virtual; abstract;

    /// manual Update of a TSQLRecord field values from an array of TSQLVar

    // - will update all properties, including BLOB fields and such

    // - returns TRUE on success, FALSE on any error (e.g. invalid Rec.ID)

    // - method available since a TSQLRestStorage instance may be created

    // stand-alone, i.e. without any associated Model/TSQLRestServer

    // - this default implementation will create a temporary TSQLRecord instance

    // with the supplied Values[], and will call overloaded UpdateOne() method

    function UpdateOne(ID: TID; const Values: TSQLVarDynArray): boolean; overload; virtual;

  end;



  /// class able to handle a O(1) hashed-based search of a property in a TList

  // - used e.g. to hash TSQLRestStorageInMemory field values

  TListFieldHash = class(TObjectHash)

  protected

    fValues: TList;

    fField: integer;

    fProp: TSQLPropInfo;

    fCaseInsensitive: boolean;

    /// overridden method to hash an item

    function Hash(Item: TObject): cardinal; override;

    /// overridden method to compare two items

    function Compare(Item1,Item2: TObject): boolean; override;

    /// overridden method to get an item

    // - shall return nil if Index is out of range (e.g. >= Count)

    // - will be called e.g. by Find() with Compare() to avoid collision

    function Get(Index: integer): TObject; override;

    /// overridden method to retrieve the number of items

    function Count: integer; override;

  public

    /// initialize a hash for a record array field

    // - aFieldIndex/aField parameters correspond to the indexed field (e.g.

    // "stored AS_UNIQUE" published property)

    // - if CaseInsensitive is TRUE, will apply NormToUpper[] 8 bits uppercase,

    // handling RawUTF8 properties just like the SYSTEMNOCASE collation

    constructor Create(aValues: TList; aField: TSQLPropInfo; aCaseInsensitive: boolean);

    /// search one item using slow list browsing

    function Scan(Item: TObject; ListCount: integer): integer; override;

    /// the corresponding field index in the TSQLRecord

    property FieldIndex: integer read fField;

    /// the corresponding field RTTI

    property Field: TSQLPropInfo read fProp;

    /// if the string comparison shall be case-insensitive

    property CaseInsensitive: boolean read fCaseInsensitive;

  end;



  /// REST storage with direct access to a TObjectList memory-stored table

  // - store the associated TSQLRecord values in a TObjectList

  // - handle one TSQLRecord per TSQLRestStorageInMemory instance

  // - must be registered individualy in a TSQLRestServer to access data from a

  // common client, by using the TSQLRestServer.StaticDataCreate method:

  // it allows an unique access for both SQLite3 and Static databases

  // - handle basic REST commands, no SQL interpreter is implemented: only

  // valid SQL command is "SELECT Field1,Field2 FROM Table WHERE ID=120;", i.e

  // a one Table SELECT with one optional "WHERE fieldname = value" statement;

  // if used within a TSQLVirtualTableJSON, you'll be able to handle any kind of

  // SQL statement (even joined SELECT or such) with this memory-stored database

  // - our TSQLRestStorage database engine is very optimized and is a lot

  // faster than SQLite3 for such queries - but its values remain in RAM,

  // therefore it is not meant to deal with more than 100,000 rows

  // - data can be stored and retrieved from a file (JSON format is used by

  // default, if BinaryFile parameter is left to false; a proprietary compressed

  // binary format can be used instead) if a file name is supplied at creating

  // the TSQLRestStorageInMemory instance

  TSQLRestStorageInMemory = class(TSQLRestStorageRecordBased)

  protected

    fValue: TObjectList;

    fFileName: TFileName;

    /// true if IDs are sorted (which is the default behavior of this class),

    // for fastest ID2Index() by using a binary search algorithm

    fIDSorted: boolean;

    fCommitShouldNotUpdateFile: boolean;

    fBinaryFile: boolean;

    fExpandedJSON: boolean;

    fSearchRec: TSQLRecord; // temporary record to store the searched value 

    fBasicUpperSQLSelect: array[boolean] of RawUTF8;

    fUniqueFields: TObjectList;

    function UniqueFieldsUpdateOK(aRec: TSQLRecord; aUpdateIndex: integer): boolean;

    function UniqueFieldHash(aFieldIndex: integer): TListFieldHash;

    function GetCount: integer;

    function GetItem(Index: integer): TSQLRecord; {$ifdef HASINLINE}inline;{$endif}

    function GetListPtr: PPointerArray; {$ifdef HASINLINE}inline;{$endif}

    function GetID(Index: integer): TID;

    procedure SetFileName(const aFileName: TFileName);

    procedure SetBinaryFile(aBinary: boolean);

    procedure GetJSONValuesEvent(aDest: pointer; aRec: TSQLRecord; aIndex: integer);

    procedure AddIntegerDynArrayEvent(aDest: pointer; aRec: TSQLRecord; aIndex: integer);

    procedure DoNothingEvent(aDest: pointer; aRec: TSQLRecord; aIndex: integer);

    procedure DoInstanceEvent(aDest: pointer; aRec: TSQLRecord; aIndex: integer);

    procedure DoIndexEvent(aDest: pointer; aRec: TSQLRecord; aIndex: integer);

    procedure DoCopyEvent(aDest: pointer; aRec: TSQLRecord; aIndex: integer);

    /// used to create the JSON content from a SELECT parsed command

    // - WhereField index follows FindWhereEqual / TSynTableStatement.WhereField

    // - returns the number of data row added (excluding field names)

    // - this method is very fast and optimized (for search and JSON serializing)

    function GetJSONValues(Stream: TStream; Expand: boolean;

      Stmt: TSynTableStatement): PtrInt;

    /// TSQLRestServer.URI use it for Static.EngineList to by-pass virtual table

    // - overridden method to handle basic queries as handled by EngineList()

    function AdaptSQLForEngineList(var SQL: RawUTF8): boolean; override;

    /// overridden methods for direct in-memory database engine thread-safe process

    function EngineRetrieve(TableModelIndex: Integer; ID: TID): RawUTF8; override;

    function EngineList(const SQL: RawUTF8; ForceAJAX: Boolean=false; ReturnedRowCount: PPtrInt=nil): RawUTF8; override;

    function EngineUpdate(TableModelIndex: integer; ID: TID; const SentData: RawUTF8): boolean; override;

    function EngineRetrieveBlob(TableModelIndex: integer; aID: TID;

      BlobField: PPropInfo; out BlobData: TSQLRawBlob): boolean; override;

    function EngineUpdateBlob(TableModelIndex: integer; aID: TID;

      BlobField: PPropInfo; const BlobData: TSQLRawBlob): boolean; override;

    function EngineDeleteWhere(TableModelIndex: integer; const SQLWhere: RawUTF8;

      const IDs: TIDDynArray): boolean; override;

    function EngineExecute(const aSQL: RawUTF8): boolean; override;

  public

    /// initialize the table storage data, reading it from a file if necessary

    // - data encoding on file is UTF-8 JSON format by default, or

    // should be some binary format if aBinaryFile is set to true

    constructor Create(aClass: TSQLRecordClass; aServer: TSQLRestServer;

      const aFileName: TFileName = ''; aBinaryFile: boolean=false); reintroduce; virtual;

    /// free used memory

    // - especially release all fValue[] instances

    destructor Destroy; override;



    /// clear all the values of this table

    // - will reset the associated database file, if any

    procedure DropValues;

    /// load the values from JSON data

    procedure LoadFromJSON(const aJSON: RawUTF8); overload;

    /// load the values from JSON data

    procedure LoadFromJSON(JSONBuffer: PUTF8Char; JSONBufferLen: integer); overload;

    /// save the values into JSON data

    function SaveToJSON(Expand: Boolean): RawUTF8; overload;

    /// save the values into JSON data

    procedure SaveToJSON(Stream: TStream; Expand: Boolean); overload;

    /// load the values from binary file/stream

    // - the binary format is a custom compressed format (using our SynLZ fast

    // compression algorithm), with variable-length record storage

    // - the binary content is first checked for consistency, before loading

    // - warning: the field layout should be the same at SaveToBinary call;

    // for instance, it won't be able to read a file content with a renamed

    // or modified field type

    // - will return false if the binary content is invalid

    function LoadFromBinary(Stream: TStream): boolean; overload;

    /// load the values from binary data

    // - uses the same compressed format as the overloaded stream/file method

    // - will return false if the binary content is invalid

    function LoadFromBinary(const Buffer: RawByteString): boolean; overload;

    /// load the values from binary resource

    // - the resource name is expected to be the TSQLRecord class name,

    // with a resource type of 10

    // - uses the same compressed format as the overloaded stream/file method

    procedure LoadFromResource(ResourceName: string='');

    /// save the values into a binary file/stream

    // - the binary format is a custom compressed format (using our SynLZ fast

    // compression algorithm), with variable-length record storage: e.g. a 27 KB

    // Dali1.json content is stored into a 6 KB Dali2.data file

    // (this data has a text redundant field content in its FirstName field);

    // 502 KB People.json content is stored into a 92 KB People.data file

    // - returns the number of bytes written into Stream

    function SaveToBinary(Stream: TStream): integer; overload;

    /// save the values into a binary buffer

    // - uses the same compressed format as the overloaded stream/file method

    function SaveToBinary: RawByteString; overload;

    /// if file was modified, the file is updated on disk

    // - this method is called automaticaly when the TSQLRestStorage

    // instance is destroyed: should should want to call in in some cases,

    // in order to force the data to be saved regularly

    // - do nothing if the table content was not modified

    // - will write JSON content by default, or binary content if BinaryFile

    // property was set to true

    procedure UpdateFile;

    /// will reload all content from the current disk file

    // - any not saved modification will be lost (e.g. if Updatefile has not

    // been called since)

    procedure ReloadFromFile;

    /// retrieve the index in Items[] of a particular ID

    // - return -1 if this ID was not found

    // - use fast binary search algorithm (since Items[].ID should be increasing)

    function IDToIndex(ID: TID): integer;

    /// manual Add of a TSQLRecord

    // - returns the ID created on success

    // - returns -1 on failure (not UNIQUE field value e.g.)

    // - on success, the Rec instance is added to the Values[] list: caller

    // doesn't need to Free it

    // - warning: this method should be protected via StorageLock/StorageUnlock

    function AddOne(Rec: TSQLRecord; ForceID: boolean; const SentData: RawUTF8): TID; override;

    /// manual Retrieval of a TSQLRecord field values

    // - an instance of the associated static class is created, and filled with

    // the actual properties values

    // - and all its properties are filled from the Items[] values

    // - caller can modify these properties, then use UpdateOne() if the changes

    // have to be stored inside the Items[] list

    // - calller must always free the returned instance

    // - returns NIL if any error occured, e.g. if the supplied aID was incorrect

    // - method available since a TSQLRestStorage instance may be created

    // stand-alone, i.e. without any associated Model/TSQLRestServer

    function GetOne(aID: TID): TSQLRecord; override;

    /// manual Update of a TSQLRecord field values

    // - Rec.ID specifies which record is to be updated

    // - will update all properties, including BLOB fields and such

    // - returns TRUE on success, FALSE on any error (e.g. invalid Rec.ID)

    // - method available since a TSQLRestStorage instance may be created

    // stand-alone, i.e. without any associated Model/TSQLRestServer

    function UpdateOne(Rec: TSQLRecord; const SentData: RawUTF8): boolean; override;

    /// manual Update of a TSQLRecord field values from a TSQLVar array

    // - will update all properties, including BLOB fields and such

    // - returns TRUE on success, FALSE on any error (e.g. invalid Rec.ID)

    // - method available since a TSQLRestStorage instance may be created

    // stand-alone, i.e. without any associated Model/TSQLRestServer

    function UpdateOne(ID: TID; const Values: TSQLVarDynArray): boolean; override;

    /// direct deletion of a TSQLRecord, from its index in Values[]

    // - warning: this method should be protected via StorageLock/StorageUnlock

    function DeleteOne(aIndex: integer): boolean; virtual;

    /// overridden method for direct in-memory database engine call

    // - made public since a TSQLRestStorage instance may be created

    // stand-alone, i.e. without any associated Model/TSQLRestServer

    function EngineDelete(TableModelIndex: integer; ID: TID): boolean; override;

    /// overridden method for direct in-memory database engine call

    // - made public since a TSQLRestStorage instance may be created

    // stand-alone, i.e. without any associated Model/TSQLRestServer

    function EngineUpdateField(TableModelIndex: integer;

      const SetFieldName, SetValue, WhereFieldName, WhereValue: RawUTF8): boolean; override;

    /// overridden method for direct in-memory database engine call

    // - made public since a TSQLRestStorage instance may be created

    // stand-alone, i.e. without any associated Model/TSQLRestServer

    function EngineUpdateFieldIncrement(TableModelIndex: integer; ID: TID;

      const FieldName: RawUTF8; Increment: Int64): boolean; override;

    /// overridden method for direct in-memory database engine call

    function UpdateBlobFields(Value: TSQLRecord): boolean; override;

    /// overridden method for direct in-memory database engine call

    function RetrieveBlobFields(Value: TSQLRecord): boolean; override;

    /// overridden method for direct in-memory database engine call

    function TableRowCount(Table: TSQLRecordClass): Int64; override;

    /// overridden method for direct in-memory database engine call

    function TableHasRows(Table: TSQLRecordClass): boolean; override;

    /// search for a field value, according to its SQL content representation

    // - return true on success (i.e. if some values have been added to ResultID)

    // - store the results into the ResultID dynamic array

    // - faster than OneFieldValues method, which creates a temporary JSON content

    function SearchField(const FieldName, FieldValue: RawUTF8;

      out ResultID: TIDDynArray): boolean; override;

    /// search for a field value, according to its SQL content representation

    // - return the found TSQLRecord on success, nil if none did match

    // - warning: it returns a reference to one item of the unlocked internal

    // list, so you should NOT use this on a read/write table, but rather

    // use the slightly slower but safer SearchCopy() method or make explicit

    // ! StorageLock ... try ... SearchInstance ... finally StorageUnlock end 

    function SearchInstance(const FieldName, FieldValue: RawUTF8): pointer;

    /// search for a field value, according to its SQL content representation

    // - return the found TSQLRecord index on success, -1 if none did match

    // - warning: it returns a reference to the current index of the unlocked

    // internal list, so you should NOT use without StorageLock/StorageUnlock

    function SearchIndex(const FieldName, FieldValue: RawUTF8): integer;

    /// search for a field value, according to its SQL content representation

    // - return a copy of the found TSQLRecord on success, nil if no match

    // - you should use SearchCopy() instead of SearchInstance(), unless you

    // are sure that the internal TSQLRecord list won't change

    function SearchCopy(const FieldName, FieldValue: RawUTF8): pointer;

    /// search and count for a field value, according to its SQL content representation

    // - return the number of found entries on success, 0 if it was not found

    function SearchCount(const FieldName, FieldValue: RawUTF8): integer;

    /// search for a field value, according to its SQL content representation

    // - call the supplied OnFind event on match

    // - returns the number of found entries

    // - is just a wrapper around FindWhereEqual() with StorageLock protection

    function SearchEvent(const FieldName, FieldValue: RawUTF8;

      OnFind: TFindWhereEqualEvent; Dest: pointer; FoundLimit,FoundOffset: integer): integer;

    /// optimized search of WhereValue in WhereField (0=RowID,1..=RTTI)

    // - will use fast O(1) hash for fUniqueFields[] fields

    // - will use SYSTEMNOCASE case-insensitive search for text values, unless

    // CaseInsensitive is set to FALSE

    // - warning: this method should be protected via StorageLock/StorageUnlock

    function FindWhereEqual(WhereField: integer; const WhereValue: RawUTF8;

      OnFind: TFindWhereEqualEvent; Dest: pointer; FoundLimit,FoundOffset: integer;

      CaseInsensitive: boolean=true): PtrInt; overload;

    /// optimized search of WhereValue in a field, specified by name

    // - will use fast O(1) hash for fUniqueFields[] fields

    // - will use SYSTEMNOCASE case-insensitive search for text values, unless

    // CaseInsensitive is set to FALSE

    // - warning: this method should be protected via StorageLock/StorageUnlock

    function FindWhereEqual(const WhereFieldName, WhereValue: RawUTF8;

      OnFind: TFindWhereEqualEvent; Dest: pointer; FoundLimit,FoundOffset: integer;

      CaseInsensitive: boolean=true): PtrInt; overload;

    /// search the maximum value of a given column

    // - would only handle integer/Int64 kind of column

    function FindMax(WhereField: integer; out max: Int64): boolean;

    /// execute a method on every TSQLRecord item

    // - the loop execution will be protected via StorageLock/StorageUnlock 

    procedure ForEach(WillModifyContent: boolean;

      OnEachProcess: TFindWhereEqualEvent; Dest: pointer);

    /// read-only access to the TSQLRecord values, storing the data

    // - this returns directly the item class instance stored in memory: if you

    // change the content, it will affect the internal data - so for instance

    // DO NOT change the ID values, unless you may have unexpected behavior

    // - warning: this method should be protected via StorageLock/StorageUnlock

    property Items[Index: integer]: TSQLRecord read GetItem; default;

    /// direct access to the memory of the internal fValues[] array

    // - Items[] is preferred, since it would check the index, but is slightly

    // slower, e.g. in a loop or after a IDToIndex() call

    // - warning: this method should be protected via StorageLock/StorageUnlock

    property ListPtr: PPointerArray read GetListPtr;

    /// read-only access to the ID of a TSQLRecord values

    property ID[Index: integer]: TID read GetID;

  published

    /// read only access to the file name specified by constructor

    // - you can call the TSQLRestServer.StaticDataCreate method to

    // update the file name of an already instanciated static table

    // - if you change manually the file name from this property, the storage

    // would be marked as "modified" so that UpdateFile would save the content

    property FileName: TFileName read fFileName write SetFileName;

    /// if set to true, file content on disk will expect binary format

    // - default format on disk is JSON but can be overridden at constructor call

    // - binary format should be more efficient in term of speed and disk usage,

    // but can be proprietary

    // - if you change manually the file format from this property, the storage

    // would be marked as "modified" so that UpdateFile would save the content

    property BinaryFile: boolean read fBinaryFile write SetBinaryFile;

    // JSON writing, can set if the format should be expanded or not

    // - by default, the JSON will be in the custom non-expanded format,

    // to save disk space and time

    // - you can force the JSON to be emitted as an array of objects,

    // e.g. for better human friendliness (reading and modification)

    property ExpandedJSON: boolean read fExpandedJSON write fExpandedJSON;

    /// set this property to TRUE if you want the COMMIT statement not to

    // update the associated TSQLVirtualTableJSON

    property CommitShouldNotUpdateFile: boolean read fCommitShouldNotUpdateFile

      write fCommitShouldNotUpdateFile;

    /// read-only access to the number of TSQLRecord values

    property Count: integer read GetCount;

  end;



  /// a dynamic array of TSQLRestStorageInMemory instances

  // - used e.g. by TSQLRestServerFullMemory

  TSQLRestStorageInMemoryDynArray = array of TSQLRestStorageInMemory;



  /// REST storage with direct access to a memory database, to be used as

  // an external SQLite3 Virtual table

  // - this is the kind of in-memory table expected by TSQLVirtualTableJSON,

  // in order to be consistent with the internal DB cache

  TSQLRestStorageInMemoryExternal = class(TSQLRestStorageInMemory)

  public

    /// initialize the table storage data, reading it from a file if necessary

    // - data encoding on file is UTF-8 JSON format by default, or

    // should be some binary format if aBinaryFile is set to true

    constructor Create(aClass: TSQLRecordClass; aServer: TSQLRestServer;

      const aFileName: TFileName = ''; aBinaryFile: boolean=false); override;

    /// this overridden method will notify the Owner when the internal DB content

    // is known to be invalid

    // - by default, all REST/CRUD requests and direct SQL statements are

    // scanned and identified as potentially able to change the internal SQL/JSON

    // cache used at SQLite3 database level; but TSQLVirtualTableJSON virtual

    // tables could flush the database content without proper notification

    // - this overridden implementation will call Owner.FlushInternalDBCache

    procedure StorageLock(WillModifyContent: boolean); override;

  end;



  /// REST storage with redirection to another REST instance

  // - allows redirection of all CRUD operations for a table to another

  // TSQLRest instance, may be a remote TSQLRestClient or a TSQLRestServer

  // - will be used by TSQLRestServer.RemoteDataCreate() method

  TSQLRestStorageRemote = class(TSQLRestStorage)

  protected

    fRemoteRest: TSQLRest;

    fRemoteTableIndex: integer;

    function EngineRetrieve(TableModelIndex: integer; ID: TID): RawUTF8; override;

    function EngineList(const SQL: RawUTF8; ForceAJAX: Boolean=false; ReturnedRowCount: PPtrInt=nil): RawUTF8; override;

    function EngineExecute(const aSQL: RawUTF8): boolean; override;

    function EngineAdd(TableModelIndex: integer; const SentData: RawUTF8): TID; override;

    function EngineUpdate(TableModelIndex: integer; ID: TID; const SentData: RawUTF8): boolean; override;

    function EngineDelete(TableModelIndex: integer; ID: TID): boolean; override;

    function EngineDeleteWhere(TableModelIndex: integer; const SQLWhere: RawUTF8;

      const IDs: TIDDynArray): boolean; override;

    function EngineRetrieveBlob(TableModelIndex: integer; aID: TID;

      BlobField: PPropInfo; out BlobData: TSQLRawBlob): boolean; override;

    function EngineUpdateBlob(TableModelIndex: integer; aID: TID;

      BlobField: PPropInfo; const BlobData: TSQLRawBlob): boolean; override;

    function EngineUpdateField(TableModelIndex: integer;

      const SetFieldName, SetValue, WhereFieldName, WhereValue: RawUTF8): boolean; override;

    function EngineUpdateFieldIncrement(TableModelIndex: integer; ID: TID;

      const FieldName: RawUTF8; Increment: Int64): boolean; override;

  public

    /// initialize the table storage redirection

    // - you should not have to use this constructor, but rather the

    // TSQLRestServer.RemoteDataCreate() method which will create and register

    // one TSQLRestStorageRemote instance

    constructor Create(aClass: TSQLRecordClass; aServer: TSQLRestServer;

      aRemoteRest: TSQLRest); reintroduce; virtual;

    /// the remote ORM instance used for data persistence

    // - may be a TSQLRestClient or a TSQLRestServer instance

    property RemoteRest: TSQLRest read fRemoteRest;

  end;



  /// defines how TSQLRestStorageShard would handle its partioned process

  TSQLRestStorageShardOption = (ssoNoUpdate, ssoNoUpdateButLastShard,

    ssoNoDelete, ssoNoDeleteButLastShard, ssoNoBatch,

    ssoNoList, ssoNoExecute, ssoNoUpdateField, ssoNoConsolidateAtDestroy);

  /// how TSQLRestStorageShard would handle its partioned process

  TSQLRestStorageShardOptions = set of TSQLRestStorageShardOption;



  /// abstract REST storage with redirection to several REST instances, implementing

  // range ID partitioning for horizontal scaling

  // - such database shards would allow to scale with typical BigData storage

  // - this storage would add items on a server, initializing a new server

  // when the ID reached a defined range

  // - it would maintain a list of previous storages, then redirect reading and

  // updates to the server managing this ID (if possible - older shards may

  // be deleted/ignored to release resources)

  // - inherited class should override InitShards/InitNewShard to customize the

  // kind of TSQLRest instances to be used for each shard (which may be local

  // or remote, a SQLite3 engine or an external SQL/NoSQL database)

  // - see inherited TSQLRestStorageShardDB as defined in mORMotSQLite3.pas

  TSQLRestStorageShard = class(TSQLRestStorage)

  protected

    fShardRange: TID;

    fLastID: TID;

    fOptions: TSQLRestStorageShardOptions;

    fShards: array of TSQLRest;

    fShardLast: cardinal;

    fShardLastID: TID;

    fShardNextID: TID;

    fShardTableIndex: TIntegerDynArray;

    fShardBatch: array of TSQLRestBatch;

    // would set Shards[],fShardLast,fShardLastID, nil if not available any more

    procedure InitShards; virtual; abstract;

    // should always return non nil shard to contain new added IDs

    function InitNewShard: TSQLRest; virtual; abstract;

    procedure InternalAddNewShard;

    function InternalShardBatch(ShardIndex: integer): TSQLRestBatch;

    // overriden methods which would handle all ORM process

    function EngineRetrieve(TableModelIndex: integer; ID: TID): RawUTF8; override;

    function EngineList(const SQL: RawUTF8; ForceAJAX: Boolean=false; ReturnedRowCount: PPtrInt=nil): RawUTF8; override;

    function EngineExecute(const aSQL: RawUTF8): boolean; override;

    function EngineAdd(TableModelIndex: integer; const SentData: RawUTF8): TID; override;

    function EngineUpdate(TableModelIndex: integer; ID: TID; const SentData: RawUTF8): boolean; override;

    function EngineDelete(TableModelIndex: integer; ID: TID): boolean; override;

    function EngineDeleteWhere(TableModelIndex: integer; const SQLWhere: RawUTF8;

      const IDs: TIDDynArray): boolean; override;

    function EngineRetrieveBlob(TableModelIndex: integer; aID: TID;

      BlobField: PPropInfo; out BlobData: TSQLRawBlob): boolean; override;

    function EngineUpdateBlob(TableModelIndex: integer; aID: TID;

      BlobField: PPropInfo; const BlobData: TSQLRawBlob): boolean; override;

    function EngineUpdateField(TableModelIndex: integer;

      const SetFieldName, SetValue, WhereFieldName, WhereValue: RawUTF8): boolean; override;

    function EngineUpdateFieldIncrement(TableModelIndex: integer; ID: TID;

      const FieldName: RawUTF8; Increment: Int64): boolean; override;

    function InternalBatchStart(Method: TSQLURIMethod;

      BatchOptions: TSQLRestBatchOptions): boolean; override;

    procedure InternalBatchStop; override;

  public

    /// initialize the table storage redirection for sharding

    // - you should not have to use this constructor, but e.g.

    // TSQLRestStorageShardDB.Create on a main TSQLRestServer.StaticDataAdd()

    // - the supplied aShardRange should be < 1000 - and once set, you should NOT

    // change this value on an existing shard, unless process would be broken

    constructor Create(aClass: TSQLRecordClass; aServer: TSQLRestServer;

      aShardRange: TID; aOptions: TSQLRestStorageShardOptions); reintroduce; virtual;

    /// finalize the table storage, including Shards[] instances

    destructor Destroy; override;

    /// you may call this method sometimes to consolidate the sharded data

    // - may e.g. merge/compact shards, depending on scaling expectations

    // - also called by Destroy - do nothing by default

    procedure ConsolidateShards; virtual;

    /// remove a shard database from the current set

    // - it would allow e.g. to delete a *.dbs file at runtime, without

    // restarting the server

    // - this default implementation would free and nil fShard[aShardIndex]

    procedure RemoveShard(aShardIndex: integer); virtual;

    /// retrieve the ORM shard instance corresponding to an ID

    // - may return false if the correspondig shard is not available any more

    // - may return true, and a TSQLRestHookClient or a TSQLRestHookServer instance

    // with its associated index in TSQLRest.Model.Tables[]

    function ShardFromID(aID: TID; out aShardTableIndex: integer;

      out aShard: TSQLRest; aOccasion: TSQLOccasion=soSelect;

      aShardIndex: PInteger=nil): boolean; virtual;

    /// get the row count of a specified table

    function TableRowCount(Table: TSQLRecordClass): Int64; override;

    /// check if there is some data rows in a specified table

    function TableHasRows(Table: TSQLRecordClass): boolean; override;

  published

    /// how much IDs should store each ORM shard instance

    // - once set, you should NEVER change this value on an existing shard,

    // otherwise the whole ID partition would fail

    // - each shard would hold [ShardIndex*ShardRange..(ShardIndex+1)*ShardRange-1] IDs

    property ShardRange: TID read fShardRange;

    /// defines how this instance would handle its sharding process

    // - by default, update/delete operations or per ID retrieval would take

    // place on all shards, whereas EngineList and EngineExecute would only run

    // only on the latest shard (to save resources)

    property Options: TSQLRestStorageShardOptions read fOptions write fOptions;

  end;



  /// class metadata of a Sharding storage engine

  TSQLRestStorageShardClass = class of TSQLRestStorageShard;



  /// a REST server using only in-memory tables

  // - this server will use TSQLRestStorageInMemory instances to handle

  // the data in memory, and optionally persist the data on disk as JSON or

  // binary files

  // - so it will not handle all SQL requests, just basic CRUD commands on

  // separated tables

  // - at least, it will compile as a TSQLRestServer without complaining for

  // pure abstract methods; it can be used to host some services if database

  // and ORM needs are basic (e.g. if only authentication and CRUD are needed),

  // without the need to link the SQLite3 engine

  TSQLRestServerFullMemory = class(TSQLRestServer)

  protected

    fFileName: TFileName;

    fBinaryFile: Boolean;

    fStaticDataCount: cardinal;

    fStorage: TSQLRestStorageInMemoryDynArray;

    function GetStorage(aTable: TSQLRecordClass): TSQLRestStorageInMemory;

    /// overridden methods which will call fStorage[TableModelIndex] directly

    function EngineAdd(TableModelIndex: integer; const SentData: RawUTF8): TID; override;

    function EngineRetrieve(TableModelIndex: integer; ID: TID): RawUTF8; override;

    function EngineUpdate(TableModelIndex: integer; ID: TID; const SentData: RawUTF8): boolean; override;

    function EngineDelete(TableModelIndex: integer; ID: TID): boolean; override;

    function EngineDeleteWhere(TableModelIndex: integer; const SQLWhere: RawUTF8;

      const IDs: TIDDynArray): boolean; override;

    function EngineRetrieveBlob(TableModelIndex: integer; aID: TID;

      BlobField: PPropInfo; out BlobData: TSQLRawBlob): boolean; override;

    function EngineUpdateBlob(TableModelIndex: integer; aID: TID;

      BlobField: PPropInfo; const BlobData: TSQLRawBlob): boolean; override;

    function EngineUpdateField(TableModelIndex: integer;

      const SetFieldName, SetValue, WhereFieldName, WhereValue: RawUTF8): boolean; override;

    function EngineUpdateFieldIncrement(TableModelIndex: integer; ID: TID;

      const FieldName: RawUTF8; Increment: Int64): boolean; override;

    /// overridden methods which will return error (no main DB here)

    function MainEngineAdd(TableModelIndex: integer; const SentData: RawUTF8): TID; override;

    function MainEngineRetrieve(TableModelIndex: integer; ID: TID): RawUTF8; override;

    function MainEngineList(const SQL: RawUTF8; ForceAJAX: Boolean; ReturnedRowCount: PPtrInt): RawUTF8; override;

    function MainEngineUpdate(TableModelIndex: integer; aID: TID; const SentData: RawUTF8): boolean; override;

    function MainEngineDelete(TableModelIndex: integer; ID: TID): boolean; override;

    function MainEngineDeleteWhere(TableModelIndex: integer; const SQLWhere: RawUTF8;

      const IDs: TIDDynArray): boolean; override;

    function MainEngineRetrieveBlob(TableModelIndex: integer; aID: TID;

      BlobField: PPropInfo; out BlobData: TSQLRawBlob): boolean; override;

    function MainEngineUpdateBlob(TableModelIndex: integer; aID: TID;

      BlobField: PPropInfo; const BlobData: TSQLRawBlob): boolean; override;

    function MainEngineUpdateField(TableModelIndex: integer;

      const SetFieldName, SetValue, WhereFieldName, WhereValue: RawUTF8): boolean; override;

    function MainEngineUpdateFieldIncrement(TableModelIndex: integer; ID: TID;

      const FieldName: RawUTF8; Increment: Int64): boolean; override;

    // method not implemented: always return false

    function EngineExecute(const aSQL: RawUTF8): boolean; override;

    constructor RegisteredClassCreateFrom(aModel: TSQLModel;

      aServerHandleAuthentication: boolean; aDefinition: TSynConnectionDefinition); override;

  public

    /// initialize an in-memory REST server with no database file

    constructor Create(aModel: TSQLModel; aHandleUserAuthentication: boolean=false); overload; override;

    /// initialize an in-memory REST server with a database file

    // - all classes of the model will be created as TSQLRestStorageInMemory

    // - then data persistence will be initialized using aFileName, but no

    // file will be written to disk, unless you call explicitly UpdateToFile

    // - if aFileName is left void (''), data will not be persistent

    constructor Create(aModel: TSQLModel; const aFileName: TFileName;

      aBinaryFile: boolean=false; aHandleUserAuthentication: boolean=false); reintroduce; overload; virtual;

    /// initialize an in-memory REST server with a temporary Database Model,

    // and optional authentication by a single user

    // - a Model will be created with supplied tables, and owned by the server

    // - if aUserName is set, authentication will be enabled, and the supplied

    // credentials will be used to authenticate a single user, member of the

    // 'Supervisor' group - in this case, aHashedPassword value should match

    // TSQLAuthUser.PasswordHashHexa expectations

    constructor CreateWithOwnedAuthenticatedModel(

      const Tables: array of TSQLRecordClass; const aUserName, aHashedPassword: RawUTF8;

      aRoot: RawUTF8='root');

    /// finalize the REST server

    // - this overridden destructor will write any modification on file (if

    // needed), and release all used memory

    destructor Destroy; override;

    /// save the TSQLRestFullMemory properties into a persistent storage object

    // - CreateFrom() will expect Definition.ServerName to store the FileName,

    // and use binary storage if Definition.DatabaseName is not void

    procedure DefinitionTo(Definition: TSynConnectionDefinition); override;

    /// Missing tables are created if they don't exist yet for every TSQLRecord

    // class of the Database Model

    // - you must call explicitely this before having called StaticDataCreate()

    // - all table description (even Unique feature) is retrieved from the Model

    // - this method also create additional fields, if the TSQLRecord definition

    // has been modified; only field adding is available, field renaming or

    // field deleting are not allowed in the FrameWork (in such cases, you must

    // create a new TSQLRecord type)

    procedure CreateMissingTables(user_version: cardinal=0;

      Options: TSQLInitializeTableOptions=[]); override;

    /// load the content from the specified file name

    // - do nothing if file name was not assigned

    procedure LoadFromFile; virtual;

    /// load the content from the supplied resource

    procedure LoadFromStream(aStream: TStream); virtual;

    /// write any modification into file

    // - do nothing if file name was not assigned

    procedure UpdateToFile; virtual;

    /// clear all internal TObjectList content

    procedure DropDatabase; virtual;

    /// direct access to the storage TObjectList storage instances

    // - you can then access to Storage[Table].Count and Storage[Table].Items[]

    property Storage[aTable: TSQLRecordClass]: TSQLRestStorageInMemory read GetStorage;

    /// direct access to the storage TObjectList storage instances

    // - you can then access via Storage[TableIndex].Count and Items[]

    property Storages: TSQLRestStorageInMemoryDynArray read fStorage;

  published

    /// the file name used for data persistence

    property FileName: TFileName read fFileName write fFileName;

    /// set if the file content is to be compressed binary, or standard JSON

    // - it will use TSQLRestStorageInMemory LoadFromJSON/LoadFromBinary

    // SaveToJSON/SaveToBinary methods for optimized storage

    property BinaryFile: Boolean read fBinaryFile write fBinaryFile;

  published

    /// this method-base service will be accessible from ModelRoot/Flush URI,

    // and will write any modification into file

    // - method parameters signature matches TSQLRestServerCallBack type

    // - do nothing if file name was not assigned

    // - can be used from a remote client to ensure that any Add/Update/Delete

    // will be stored to disk, via

    // ! aClient.CallBackPut('Flush','',dummy)

    procedure Flush(Ctxt: TSQLRestServerURIContext);

  end;



  /// a REST server using another TSQLRest instance for all its ORM process

  // - this server will use an internal TSQLRest instance to handle all ORM

  // operations (i.e. access to objects) - e.g. TSQLRestClient for remote access

  // - it can be used e.g. to host some services on a stand-alone server, with

  // all ORM and data access retrieved from another server: it will allow to

  // easily implement a proxy architecture (for instance, as a DMZ for

  // publishing services, but letting ORM process stay out of scope)

  // - for per-table redirection, consider using the TSQLRestStorageRemote class

  // via a call to the TSQLRestServer.RemoteDataCreate() method

  TSQLRestServerRemoteDB = class(TSQLRestServer)

  protected

    fRemoteRest: TSQLRest;

    fRemoteTableIndex: TIntegerDynArray;

    function EngineRetrieve(TableModelIndex: integer; ID: TID): RawUTF8; override;

    function EngineList(const SQL: RawUTF8; ForceAJAX: Boolean=false; ReturnedRowCount: PPtrInt=nil): RawUTF8; override;

    function EngineExecute(const aSQL: RawUTF8): boolean; override;

    function EngineAdd(TableModelIndex: integer; const SentData: RawUTF8): TID; override;

    function EngineUpdate(TableModelIndex: integer; ID: TID; const SentData: RawUTF8): boolean; override;

    function EngineDelete(TableModelIndex: integer; ID: TID): boolean; override;

    function EngineDeleteWhere(TableModelIndex: integer; const SQLWhere: RawUTF8;

      const IDs: TIDDynArray): boolean; override;

    function EngineRetrieveBlob(TableModelIndex: integer; aID: TID;

      BlobField: PPropInfo; out BlobData: TSQLRawBlob): boolean; override;

    function EngineUpdateBlob(TableModelIndex: integer; aID: TID;

      BlobField: PPropInfo; const BlobData: TSQLRawBlob): boolean; override;

    function EngineUpdateField(TableModelIndex: integer;

      const SetFieldName, SetValue, WhereFieldName, WhereValue: RawUTF8): boolean; override;

    function EngineUpdateFieldIncrement(TableModelIndex: integer; ID: TID;

      const FieldName: RawUTF8; Increment: Int64): boolean; override;

  public

    /// initialize a REST server associated to a given TSQLRest instance

    // - the specified TSQLRest will be used for all ORM and data process

    // - you could use a TSQLRestClient or a TSQLRestServer instance

    // - the supplied TSQLRest.Model will be used for TSQLRestServerRemoteDB

    // - note that the TSQLRest instance won't be freed - caller shall ensure

    // that it will stay available at least until TSQLRestServerRemoteDB.Free

    constructor Create(aRemoteRest: TSQLRest;

      aHandleUserAuthentication: boolean=false); reintroduce; virtual;

    /// this method is called internally after any successfull deletion to

    // ensure relational database coherency

    // - this overridden method will just return TRUE: in this remote access,

    // true coherency will be performed on the ORM server side

    function AfterDeleteForceCoherency(TableIndex: integer; aID: TID): boolean; override;

  published

    /// the remote ORM instance used for data persistence

    // - may be a TSQLRestClient or a TSQLRestServer instance

    property RemoteRest: TSQLRest read fRemoteRest;

  end;





  /// possible call parameters for TOnTableUpdate Event

  TOnTableUpdateState = (tusPrepare, tusChanged, tusNoChange);



  /// used by TSQLRestClientURI.UpdateFromServer() to let the client

  // perform the rows update (for Marked[] e.g.)

  TOnTableUpdate = procedure(aTable: TSQLTableJSON; State: TOnTableUpdateState) of object;



  /// used by TSQLRestClientURI.Update() to let the client

  // perform the record update (refresh associated report e.g.)

  TOnRecordUpdate = procedure(Value: TSQLRecord) of object;



  /// a generic REpresentational State Transfer (REST) client

  // - is RESTful (i.e. URI) remotely implemented (TSQLRestClientURI e.g.)

  // - is implemented for direct access to a database (TSQLRestClientDB e.g.)

  TSQLRestClient = class(TSQLRest)

  protected

    fForceBlobTransfert: array of boolean;

    fOnTableUpdate: TOnTableUpdate;

    fOnRecordUpdate: TOnRecordUpdate;

    function GetForceBlobTransfert: Boolean;

    procedure SetForceBlobTransfert(Value: boolean);

    function GetForceBlobTransfertTable(aTable: TSQLRecordClass): Boolean;

    procedure SetForceBlobTransfertTable(aTable: TSQLRecordClass; aValue: Boolean);

    /// get a member from its ID

    // - implements REST GET collection

    // - returns the data of this object as JSON

    // - override this method for proper data retrieval from the database engine

    // - this method must be implemented in a thread-safe manner

    function ClientRetrieve(TableModelIndex: integer; ID: TID;

      ForUpdate: boolean; var InternalState: cardinal; var Resp: RawUTF8): boolean; virtual; abstract;

    /// this method is called before updating any record

    // - should return FALSE to force no update

    // - can be use to update some field values just before saving to the database

    // (e.g. for digital signing purpose)

    // - this default method just return TRUE (i.e. OK to update)

    function BeforeUpdateEvent(Value: TSQLRecord): Boolean; virtual;

    /// overridden method which will call ClientRetrieve()

    function EngineRetrieve(TableModelIndex: integer; ID: TID): RawUTF8; override;

    /// create a new member

    // - implements REST POST collection

    // - URI is 'ModelRoot/TableName' with POST method

    // - if SendData is true, content of Value is sent to the server as JSON

    // - if ForceID is true, client sends the Value.ID field to use this ID

    // - server must return Status 201/HTML_CREATED on success

    // - server must send on success an header entry with

    // $ Location: ModelRoot/TableName/TableID

    // - on success, returns the new ROWID value; on error, returns 0

    // - on success, Value.ID is updated with the new ROWID

    // - if aValue is TSQLRecordFTS3, Value.ID is stored to the virtual table

    // - this overridden method will send BLOB fields, if ForceBlobTransfert is set

    function InternalAdd(Value: TSQLRecord; SendData: boolean; CustomFields: PSQLFieldBits;

      ForceID, DoNotAutoComputeFields: boolean): TID; override; 

  public

    /// update a member

    // - implements REST PUT collection

    // - URI is 'ModelRoot/TableName/TableID' with PUT method

    // - server must return Status 200/HTML_SUCCESS OK on success

    // - this overridden method will call BeforeUpdateEvent and also update BLOB

    // fields, if any ForceBlobTransfert is set and CustomFields=[]

    function Update(Value: TSQLRecord; const CustomFields: TSQLFieldBits=[];

      DoNotAutoComputeFields: boolean=false): boolean; override;

    /// get a member from its ID

    // - implements REST GET collection

    // - URI is 'ModelRoot/TableName/TableID' with GET method

    // - server must return Status 200/HTML_SUCCESS OK on success

    // - if ForUpdate is true, the REST method is LOCK and not GET: it tries to lock

    // the corresponding record, then retrieve its content; caller has to call

    // UnLock() method after Value usage, to release the record

    function Retrieve(aID: TID; Value: TSQLRecord; ForUpdate: boolean=false): boolean; override;

    /// get a member from its ID

    // - implements REST GET collection

    // - URI is 'ModelRoot/TableName/TableID' with GET method

    // - returns true on server returned 200/HTML_SUCCESS OK success, false on error

    // - set Refreshed to true if the content changed

    function Refresh(aID: TID; Value: TSQLRecord; var Refreshed: boolean): boolean;



    /// retrieve a list of members as a TSQLTable

    // - implements REST GET collection

    // - default SQL statement is 'SELECT ID FROM TableName;' (i.e. retrieve

    // the list of all ID of this collection members)

    // - optional SQLSelect parameter to change the returned fields

    // as in 'SELECT SQLSelect FROM TableName;'

    // - optional SQLWhere parameter to change the search range or ORDER

    // as in 'SELECT SQLSelect FROM TableName WHERE SQLWhere;'

    // - using inlined parameters via :(...): in SQLWhere is always a good idea

    // - for one TClass, you should better use TSQLRest.MultiFieldValues()

    function List(const Tables: array of TSQLRecordClass; const SQLSelect: RawUTF8 = 'RowID';

      const SQLWhere: RawUTF8 = ''): TSQLTableJSON; virtual; abstract;

    /// retrieve a list of members as a TSQLTable

    // - implements REST GET collection

    // - in this version, the WHERE clause can be created with the same format

    // as FormatUTF8() function, replacing all '%' chars with Args[] values

    // - using inlined parameters via :(...): in SQLWhereFormat is always a good idea

    // - for one TClass, you should better use TSQLRest.MultiFieldValues()

    // - will call the List virtual method internaly

    function ListFmt(const Tables: array of TSQLRecordClass;

      const SQLSelect, SQLWhereFormat: RawUTF8; const Args: array of const): TSQLTableJSON; overload;

    /// retrieve a list of members as a TSQLTable

    // - implements REST GET collection

    // - in this version, the WHERE clause can be created with the same format

    // as FormatUTF8() function, replacing all '%' chars with Args[], and all '?'

    // chars with Bounds[] (inlining them with :(...): and auto-quoting strings)

    // - example of use:

    // ! Table := ListFmt([TSQLRecord],'Name','ID=?',[],[aID]);

    // - for one TClass, you should better use TSQLRest.MultiFieldValues()

    // - will call the List virtual method internaly

    function ListFmt(const Tables: array of TSQLRecordClass;

      const SQLSelect, SQLWhereFormat: RawUTF8; const Args, Bounds: array of const): TSQLTableJSON; overload;

    /// dedicated method used to retrieve matching IDs using a fast R-Tree index

    // - a TSQLRecordRTree is associated to a TSQLRecord with a specified BLOB

    // field, and will call TSQLRecordRTree BlobToCoord and ContainedIn virtual

    // class methods to execute an optimized SQL query

    // - will return all matching DataTable IDs in DataID[]

    // - will generate e.g. the following statement

    // $ SELECT MapData.ID From MapData, MapBox WHERE MapData.ID=MapBox.ID

    // $  AND minX>=:(-81.0): AND maxX<=:(-79.6): AND minY>=:(35.0): AND :(maxY<=36.2):

    // $  AND MapBox_in(MapData.BlobField,:('\uFFF0base64encoded-81,-79.6,35,36.2'):);

    // when the following Delphi code is executed:

    // ! aClient.RTreeMatch(TSQLRecordMapData,'BlobField',TSQLRecordMapBox,

    // !   aMapData.BlobField,ResultID);

    function RTreeMatch(DataTable: TSQLRecordClass;

      const DataTableBlobFieldName: RawUTF8; RTreeTable: TSQLRecordRTreeClass;

      const DataTableBlobField: RawByteString; var DataID: TIDDynArray): boolean;

    /// begin a transaction (calls REST BEGIN Member)

    // - by default, Client transaction will use here a pseudo session

    // - in aClient-Server environment with multiple Clients connected at the

    // same time, you should better use BATCH process, specifying a positive

    // AutomaticTransactionPerRow parameter to BatchStart()

    function TransactionBegin(aTable: TSQLRecordClass;

  	  SessionID: cardinal=CONST_AUTHENTICATION_NOT_USED): boolean; override;

    /// end a transaction (calls REST END Member)

    // - by default, Client transaction will use here a pseudo session

    procedure Commit(SessionID: cardinal=CONST_AUTHENTICATION_NOT_USED;

      RaiseException: boolean=false); override;

    /// abort a transaction (calls REST ABORT Member)

    // - by default, Client transaction will use here a pseudo session

    procedure RollBack(SessionID: cardinal=CONST_AUTHENTICATION_NOT_USED); override;

    /// access or initialize the internal IoC resolver, used for interface-based

    // remote services, and more generaly any Services.Resolve() call

    // - create and initialize the internal TServiceContainerClient if no

    // service interface has been registered yet

    // - may be used to inject some dependencies, which are not interface-based

    // remote services, but internal IoC, without the ServiceRegister()

    // or ServiceDefine() methods - e.g.

    // ! aRest.ServiceContainer.InjectResolver([TInfraRepoUserFactory.Create(aRest)],true);

    function ServiceContainer: TServiceContainer; override;



    /// if set to TRUE, all BLOB fields of all tables will be transferred

    // between the Client and the remote Server

    // - i.e. Add() Update() will use Blob-related RESTful PUT/POST request

    // - i.e. Retrieve() will use Blob-related RESTful GET request

    // - note that the Refresh method won't handle BLOB fields, even if this

    // property setting is set to TRUE

    // - by default, this property is set to FALSE, which setting will spare

    // bandwidth and CPU

    // - this property is global to all tables of the model - you can also use

    // ForceBlobTransfertTable[] to force it for a particular table

    property ForceBlobTransfert: boolean read GetForceBlobTransfert write SetForceBlobTransfert;

    /// if set to TRUE for a specified table of the model, all BLOB fields of

    // this tables will be transferred between the Client and the remote Server

    // - i.e. Add() Update() will use BLOB-related RESTful PUT/POST request for

    // this table

    // - i.e. Retrieve() will use BLOB-related RESTful GET request for

    // this table

    // - note that the Refresh method won't handle BLOB fields, even if this

    // property setting is set to TRUE

    // - by default, all items of this property are set to FALSE, which

    // setting will spare bandwidth and CPU

    // - this property is particular to a given tables of the model - you can

    // also use ForceBlobTransfert to force it for a all tables of this model

    property ForceBlobTransfertTable[aTable: TSQLRecordClass]: Boolean

      read GetForceBlobTransfertTable write SetForceBlobTransfertTable;

    /// this Event is called by UpdateFromServer() to let the Client adapt to

    // some rows update (for Marked[] e.g.)

    property OnTableUpdate: TOnTableUpdate read fOnTableUpdate write fOnTableUpdate;

    /// this Event is called by Update() to let the client

    // perform the record update (refresh associated report e.g.)

    property OnRecordUpdate: TOnRecordUpdate read fOnRecordUpdate write fOnRecordUpdate;

  end;



  /// used by TSQLRestClientURI.URI() to let the client ask for an User name

  // and password, in order to retry authentication to the server

  // - should return TRUE if aUserName and aPassword both contain some entered

  // values to be sent for remote secure authentication

  // - should return FALSE if the user pressed cancel or the number of Retry

  // reached a defined limit

  TOnAuthentificationFailed = function(Retry: integer;

    var aUserName, aPassword: string; out aPasswordHashed: boolean): boolean of object;

  /// called by TSQLRestClientURI.URI() when an error occurred

  // - so that you may have a single entry point for all client-side issues

  // - information would be available in Sender's LastErrorCode and

  // LastErrorMessage properties

  // - if the error comes from an Execption, it would be supplied as parameter

  // - the REST context (if any) would be supplied within the Call parameter

  TOnClientFailed = procedure(Sender: TSQLRestClientURI; E: Exception;

    Call: PSQLRestURIParams) of object;



  /// store information about registered interface callbacks

  TSQLRestClientCallbackItem = record

    /// the identifier of the callback, as sent to the server side

    // - computed from TSQLRestClientURICallbacks.fCurrentID counter

    ID: integer;

    /// pointer typecast to the associated IInvokable variable

    Instance: pointer;

    //// information about the associated IInvokable

    Factory: TInterfaceFactory;

    /// set to TRUE if the instance was released from the server

    ReleasedFromServer: boolean;

  end;

  /// points to information about registered interface callbacks

  PSQLRestClientCallbackItem = ^TSQLRestClientCallbackItem;



  /// store the references to active interface callbacks on a REST Client

  TSQLRestClientCallbacks = class(TSynPersistentLocked)

  protected

    fCurrentID: integer;

    function UnRegisterByIndex(index: integer): boolean;

  public

    /// the associated REST instance

    Owner: TSQLRestClientURI;

    /// how many callbacks are registered

    Count: integer;

    /// list of registered interface callbacks

    List: array of TSQLRestClientCallbackItem;

    /// initialize the storage list

    constructor Create(aOwner: TSQLRestClientURI); reintroduce;

    /// register a callback event interface instance from a new computed ID

    function DoRegister(aInstance: pointer; aFactory: TInterfaceFactory): integer; overload;

    /// register a callback event interface instance from its supplied ID

    procedure DoRegister(aID: Integer; aInstance: pointer; aFactory: TInterfaceFactory); overload;

    /// delete all callback events from the internal list, as specified by its instance

    // - note that the same IInvokable instance may be registered for several IDs

    function UnRegister(aInstance: pointer): boolean; overload;

    /// find the index of the ID in the internal list

    // - warning: this method should be called within Safe.Lock/Safe.Unlock

    function FindIndex(aID: integer): integer;

    /// find a matching callback

    // - will call FindIndex(aItem.ID) within Safe.Lock/Safe.Unlock

    // - returns TRUE if aItem.ID was found and aItem filled, FALSE otherwise

    function FindEntry(var aItem: TSQLRestClientCallbackItem): boolean;

    /// find a matching entry

    // - will call FindIndex(aID) within Safe.Lock/Safe.Unlock

    // - returns TRUE if aID was found and aInstance/aFactory set, FALSE otherwise

    function FindAndRelease(aID: integer): boolean;

  end;



  /// a generic REpresentational State Transfer (REST) client with URI

  // - URI are standard Collection/Member implemented as ModelRoot/TableName/TableID

  // - handle RESTful commands GET POST PUT DELETE LOCK UNLOCK

  TSQLRestClientURI = class(TSQLRestClient)

  protected

    fOnAuthentificationFailed: TOnAuthentificationFailed;

    fOnSetUser: TNotifyEvent;

    fMaximumAuthentificationRetry: Integer;

    fRetryOnceOnTimeout: boolean;

    fLastErrorCode: integer;

    fLastErrorMessage: RawUTF8;

    fLastErrorException: ExceptClass;

    fBatchCurrent: TSQLRestBatch;

    /// private values created by sucessfull SetUser() method

    fSessionUser: TSQLAuthUser;

    fSessionID: cardinal;

    fSessionIDHexa8: RawUTF8;

    fSessionPrivateKey: cardinal;

    fSessionLastTick64: Int64;

    fSessionAuthentication: TSQLRestServerAuthenticationClass;

    fSessionHttpHeader: RawUTF8; // e.g. for TSQLRestServerAuthenticationHttpBasic

    fSessionServer: RawUTF8;

    fSessionVersion: RawUTF8;

    fSessionData: RawByteString;

    /// used to make the internal client-side process reintrant

    fSafe: IAutoLocker;

    fRemoteLogClass: TSynLog;

    fRemoteLogOwnedByFamily: boolean;

    fServicePublishOwnInterfaces: RawUTF8;

    {$ifdef MSWINDOWS}

    fServiceNotificationMethodViaMessages: record

      Wnd: HWND;

      Msg: UINT;

    end;

    {$endif}

{$ifndef LVCL} // SyncObjs.TEvent not available in LVCL yet

    fBackgroundThread: TSynBackgroundThreadEvent;

    fOnIdle: TOnIdleSynBackgroundThread;

    fOnFailed: TOnClientFailed;

    fRemoteLogThread: TObject; // private TRemoteLogThread

    fFakeCallbacks: TSQLRestClientCallbacks;

    function FakeCallbackRegister(Sender: TServiceFactoryClient;

      const Method: TServiceMethod; const ParamInfo: TServiceMethodArgument;

      ParamValue: Pointer): integer; virtual;

    function FakeCallbackUnregister(Factory: TInterfaceFactory;

      FakeCallbackID: integer; Instance: pointer): boolean; virtual;

    procedure OnBackgroundProcess(Sender: TSynBackgroundThreadEvent;

      ProcessOpaqueParam: pointer);

    function GetOnIdleBackgroundThreadActive: boolean;

{$endif}

    constructor RegisteredClassCreateFrom(aModel: TSQLModel;

      aDefinition: TSynConnectionDefinition); override;

    function GetCurrentSessionUserID: TID; override;

    function InternalRemoteLogSend(const aText: RawUTF8): boolean;

    procedure InternalNotificationMethodExecute(var Ctxt: TSQLRestURIParams); virtual;

    procedure SetLastException(E: Exception=nil; ErrorCode: integer=HTML_BADREQUEST;

      Call: PSQLRestURIParams=nil);

    // register the user session to the TSQLRestClientURI instance

    function SessionCreate(aAuth: TSQLRestServerAuthenticationClass;

      var aUser: TSQLAuthUser; const aSessionKey: RawUTF8): boolean;

    /// abstract method to be implemented with a local, piped or HTTP/1.1 provider

    // - you can specify some POST/PUT data in Call.OutBody (leave '' otherwise)

    // - return the execution result in Call.OutStatus

    // - for clients, RestAccessRights is never used

    procedure InternalURI(var Call: TSQLRestURIParams); virtual; abstract;

    /// overridden protected method shall check if not connected to reopen it

    // - shall return TRUE on success, FALSE on any connection error

    function InternalCheckOpen: boolean; virtual; abstract;

    /// overridden protected method shall force the connection to be closed,

    // - a next call to InternalCheckOpen method shall re-open the connection

    procedure InternalClose; virtual; abstract;

    /// calls 'ModelRoot/TableName/TableID' with appropriate REST method

    // - uses GET method if ForUpdate is false

    // - uses LOCK method if ForUpdate is true

    function URIGet(Table: TSQLRecordClass; ID: TID; var Resp: RawUTF8;

      ForUpdate: boolean=false): Int64Rec;

    // overridden methods

    function ClientRetrieve(TableModelIndex: integer; ID: TID; ForUpdate: boolean;

      var InternalState: cardinal; var Resp: RawUTF8): boolean; override;

    function EngineList(const SQL: RawUTF8; ForceAJAX: Boolean=false; ReturnedRowCount: PPtrInt=nil): RawUTF8; override;

    function EngineExecute(const SQL: RawUTF8): boolean; override;

    function EngineAdd(TableModelIndex: integer; const SentData: RawUTF8): TID; override;

    function EngineUpdate(TableModelIndex: integer; ID: TID; const SentData: RawUTF8): boolean; override;

    function EngineDelete(TableModelIndex: integer; ID: TID): boolean; override;

    function EngineDeleteWhere(TableModelIndex: integer; const SQLWhere: RawUTF8;

      const IDs: TIDDynArray): boolean; override;

    function EngineRetrieveBlob(TableModelIndex: integer; aID: TID;

      BlobField: PPropInfo; out BlobData: TSQLRawBlob): boolean; override;

    function EngineUpdateBlob(TableModelIndex: integer; aID: TID;

      BlobField: PPropInfo; const BlobData: TSQLRawBlob): boolean; override;

    function EngineUpdateField(TableModelIndex: integer;

      const SetFieldName, SetValue, WhereFieldName, WhereValue: RawUTF8): boolean; override;

    function EngineBatchSend(Table: TSQLRecordClass; const Data: RawUTF8;

       var Results: TIDDynArray; ExpectedResultsCount: integer): integer; override;

  public

    /// initialize REST client instance

    constructor Create(aModel: TSQLModel); override;

    /// release memory and close client connection

    // - also unlock all still locked records by this client

    destructor Destroy; override;

    /// authenticate an User to the current connected Server

    // - will call the ModelRoot/Auth service, i.e. call TSQLRestServer.Auth()

    // published method to create a session for this user, with our secure

    // TSQLRestServerAuthenticationDefault authentication scheme

    // - returns true on success

    // - calling this method is optional, depending on your user right policy:

    // your Server need to handle authentication

    // - if saoUserByLogonOrID is defined in the server Options, aUserName may

    // be a TSQLAuthUser.ID integer value and not a TSQLAuthUser.LogonName

    // - on success, the SessionUser property map the logged user session on the

    // server side

    // - if aHashedPassword is TRUE, the aPassword parameter is expected to

    // contain the already-hashed value, just as stored in PasswordHashHexa

    // (i.e. SHA256('salt'+Value) as in TSQLAuthUser.SetPasswordPlain method)

    // - if SSPIAUTH conditional is defined, and aUserName='', a Windows

    // authentication will be performed via TSQLRestServerAuthenticationSSPI -

    // in this case, aPassword will contain the SPN domain for Kerberos

    // (otherwise NTLM will be used), and table TSQLAuthUser shall contain

    // an entry for the logged Windows user, with the LoginName in form

    // 'DomainName\UserName'

    // - you can directly create the class method ClientSetUser() of a given

    // TSQLRestServerAuthentication inherited class, if neither

    // TSQLRestServerAuthenticationDefault nor TSQLRestServerAuthenticationSSPI

    // match your need

    function SetUser(const aUserName, aPassword: RawUTF8;

      aHashedPassword: Boolean=false): boolean;

    /// save the TSQLRestClientURI properties into a persistent storage object

    // - CreateFrom() will expect Definition.UserName/Password to store the

    // credentials which would be used by SetUser()

    procedure DefinitionTo(Definition: TSynConnectionDefinition); override;

    /// clear session and call the /auth service on the server to notify shutdown

    // - is called by Destroy and SetUser/ClientSetUser methods, so you should

    // not have usually to call this method directly

    procedure SessionClose;

    /// method calling the remote Server via a RESTful command

    // - calls the InternalURI abstract method, which should be overridden with a

    // local, piped or HTTP/1.1 provider

    // - this method will add sign the url with the appropriate digital signature

    // according to the current SessionUser property

    // - this method will retry the connection in case of authentication failure

    // (i.e. if the session was closed by the remote server, for any reason -

    // mostly a time out) if the OnAuthentificationFailed event handler is set

    function URI(const url, method: RawUTF8; Resp: PRawUTF8=nil;

      Head: PRawUTF8=nil; SendData: PRawUTF8=nil): Int64Rec;

    /// retrieve a list of members as a TSQLTable

    // - implements REST GET collection

    // - URI is 'ModelRoot/TableName' with GET method

    // - SQLSelect and SQLWhere are encoded as 'select=' and 'where=' URL parameters

    // (using inlined parameters via :(...): in SQLWhere is always a good idea)

    // - server must return Status 200/HTML_SUCCESS OK on success

    function List(const Tables: array of TSQLRecordClass; const SQLSelect: RawUTF8 = 'RowID';

      const SQLWhere: RawUTF8 = ''): TSQLTableJSON; override;

    /// unlock the corresponding record

    // - URI is 'ModelRoot/TableName/TableID' with UNLOCK method

    // - returns true on success

    function UnLock(Table: TSQLRecordClass; aID: TID): boolean; override;

    /// Execute directly a SQL statement, expecting a list of resutls

    // - URI is 'ModelRoot' with GET method, and SQL statement sent as UTF-8

    // - return a result table on success, nil on failure

    function ExecuteList(const Tables: array of TSQLRecordClass;

      const SQL: RawUTF8): TSQLTableJSON; override;

    /// ask the server for its current internal state revision counter

    // - this counter is incremented every time the database is modified

    // - the returned value is 0 if the database doesn't support this feature

    // - TSQLTable does compare this value with its internal one to check if

    // its content must be updated

    function ServerInternalState: cardinal;

    /// check if the data may have changed of the server for this objects, and

    // update it if possible

    // - only working types are TSQLTableJSON and TSQLRecord descendants

    // - make use of the InternalState function to check the data content revision

    // - return true if Data is updated successfully, or false on any error

    // during data retrieval from server (e.g. if the TSQLRecord has been deleted)

    // - if Data contains only one TSQLTableJSON, PCurrentRow can point to the

    // current selected row of this table, in order to refresh its value

    // - use this method to refresh the client UI, e.g. via a timer

    function UpdateFromServer(const Data: array of TObject; out Refreshed: boolean;

      PCurrentRow: PInteger=nil): boolean; virtual;

    /// send a flush command to the remote Server cache

    // - this method will remotely call the Cache.Flush() methods of the server

    // instance, to force cohesion of the data

    // - ServerCacheFlush() with no parameter will flush all stored JSON content

    // - ServerCacheFlush(aTable) will flush the cache for a given table

    // - ServerCacheFlush(aTable,aID) will flush the cache for a given record

    function ServerCacheFlush(aTable: TSQLRecordClass=nil; aID: TID=0): boolean; virtual;

    /// you can call this method to call the remote URI root/TimeStamp

    // - this can be an handy way of testing the connection, since this method

    // is always available, even without authentication

    // - returns TRUE if the client time correction has been retrieved

    // - returns FALSE on any connection error - check LastErrorMessage and

    // LastErrorException to find out the exact connection error

    function ServerTimeStampSynchronize: boolean;

    /// asynchronous call a 'RemoteLog' remote logging method on the server

    // - as implemented by mORMot's LogView tool in server mode

    // - to be used via ServerRemoteLogStart/ServerRemoteLogStop methods

    // - a dedicated background thread will run the transmission process without

    // blocking the main program execution, gathering log rows in chunks in case

    // of high activity

    // - map TOnTextWriterEcho signature, so that you would be able to set e.g.:

    // ! TSQLLog.Family.EchoCustom := aClient.ServerRemoteLog;

    function ServerRemoteLog(Sender: TTextWriter; Level: TSynLogInfo;

      const Text: RawUTF8): boolean; overload; virtual;

    /// internal method able to emulate a call to TSynLog.Add.Log()

    // - will compute timestamp and event text, than call the overloaded

    // ServerRemoteLog() method

    function ServerRemoteLog(Level: TSynLogInfo; FormatMsg: PUTF8Char;

      const Args: array of const): boolean; overload;

    /// start to send all logs to the server 'RemoteLog' method-based service

    // - will associate the EchoCustom callback of the running log class to the

    // ServerRemoteLog() method

    // - if aClientOwnedByFamily is TRUE, this TSQLRestClientURI instance

    // lifetime will be managed by TSynLogFamily - which is mostly wished

    // - if aClientOwnedByFamily is FALSE, you should manage this instance

    // life time, and may call ServerRemoteLogStop to stop remote logging

    // - warning: current implementation will disable all logging for this

    // TSQLRestClientURI instance, to avoid any potential concern (e.g. for

    // multi-threaded process, or in case of communication error): you should

    // therefore use this TSQLRestClientURI connection only for the remote log

    // server, e.g. via TSQLHttpClientGeneric.CreateForRemoteLogging() - do

    // not call ServerRemoteLogStart() from a high-level business client!

    procedure ServerRemoteLogStart(aLogClass: TSynLogClass;

      aClientOwnedByFamily: boolean);

    /// stop sending all logs to the server 'RemoteLog' method-based service

    // - do nothing if aClientOwnedByFamily was TRUE for ServerRemoteLogStart

    procedure ServerRemoteLogStop;



    /// begin a transaction

    // - implements REST BEGIN collection

    // - in aClient-Server environment with multiple Clients connected at the

    // same time, you should better use BATCH process, specifying a positive

    // AutomaticTransactionPerRow parameter to BatchStart()

    // - may be used to speed up some SQL statements as Add/Update/Delete methods

    // - must be ended with Commit on success

    // - in the current implementation, the aTable parameter is not used yet

    // - must be aborted with Rollback if any SQL statement failed

    // - return true if no transaction is active, false otherwise

    // !if Client.TransactionBegin(TSQLRecordPeopleObject) then

    // !try

    // !  // .... modify the database content, raise exceptions on error

    // !  Client.Commit;

    // !except

    // !  Client.RollBack; //  in case of error

    // !end;

    // - you may use the dedicated TransactionBeginRetry() method in case of

    // potential Client concurrent access

    function TransactionBegin(aTable: TSQLRecordClass; SessionID: cardinal=1): boolean; override;

    /// begin a transaction

    // - implements REST BEGIN collection

    // - in aClient-Server environment with multiple Clients connected at the

    // same time, you should better use BATCH process, specifying a positive

    // AutomaticTransactionPerRow parameter to BatchStart()

    // - this version retries a TranslationBegin() to be successfull within

    // a supplied number of times

    // - will retry every 100 ms for "Retries" times (excluding the connection

    // time in this 100 ms time period

    // - default is to retry 10 times, i.e. within 2 second timeout

    // - in the current implementation, the aTable parameter is not used yet

    // - typical usage should be for instance:

    // !if Client.TransactionBeginRetry(TSQLRecordPeopleObject,20) then

    // !try

    // !  // .... modify the database content, raise exceptions on error

    // !  Client.Commit;

    // !except

    // !  Client.RollBack; //  in case of error

    // !end;

    function TransactionBeginRetry(aTable: TSQLRecordClass; Retries: integer=10): boolean;

    /// end a transaction

    // - implements REST END collection

    // - write all pending SQL statements to the disk }

    procedure Commit(SessionID: cardinal=CONST_AUTHENTICATION_NOT_USED;

      RaiseException: boolean=false); override;

    /// abort a transaction

    // - implements REST ABORT collection

    // - restore the previous state of the database, before the call to TransactionBegin }

    procedure RollBack(SessionID: cardinal=CONST_AUTHENTICATION_NOT_USED); override;



    /// begin a BATCH sequence to speed up huge database change for a given table

    // - is a wrapper around TSQLRestBatch.Create() which will be stored in this

    // TSQLRestClientURI instance - be aware that this won't be thread-safe

    // - if you need a thread-safe "Unit Of Work" process, please use a private

    // TSQLRestBatch instance and the overloaded TSQLRest.BatchSend() method

    // - call BatchStartAny() or set the aTable parameter to nil if you want to

    // use any kind of TSQLRecord objects within the process, not a single one

    function BatchStart(aTable: TSQLRecordClass;

      AutomaticTransactionPerRow: cardinal=0; Options: TSQLRestBatchOptions=[]): boolean; virtual;

    /// begin a BATCH sequence to speed up huge database change for any table

    // - will call the BatchStart() method with aTable = nil so that you may be

    // able to use any kind of TSQLRecord class within the process

    // - is a wrapper around TSQLRestBatch.Create() which will be stored in this

    // TSQLRestClientURI instance - be aware that this won't be thread-safe

    function BatchStartAny(AutomaticTransactionPerRow: cardinal;

      Options: TSQLRestBatchOptions=[]): boolean;

    /// create a new member in current BATCH sequence

    // - is a wrapper around TSQLRestBatch.Add() which will be stored in this

    // TSQLRestClientURI instance - be aware that this won't be thread safe

    function BatchAdd(Value: TSQLRecord; SendData: boolean; ForceID: boolean=false;

      const CustomFields: TSQLFieldBits=[]): integer;

    /// update a member in current BATCH sequence

    // - is a wrapper around TSQLRestBatch.Update() which will be stored in this

    // TSQLRestClientURI instance - be aware that this won't be thread safe

    // - this method will call BeforeUpdateEvent before TSQLRestBatch.Update

    function BatchUpdate(Value: TSQLRecord; const CustomFields: TSQLFieldBits=[];

      DoNotAutoComputeFields: boolean=false): integer;

    /// delete a member in current BATCH sequence

    // - is a wrapper around TSQLRestBatch.Update() which will be stored in this

    // TSQLRestClientURI instance - be aware that this won't be thread safe

    function BatchDelete(ID: TID): integer; overload;

    /// delete a member in current BATCH sequence

    // - is a wrapper around TSQLRestBatch.Update() which will be stored in this

    // TSQLRestClientURI instance - be aware that this won't be thread safe

    function BatchDelete(Table: TSQLRecordClass; ID: TID): integer; overload;

    /// retrieve the current number of pending transactions in the BATCH sequence

    // - every call to BatchAdd/Update/Delete methods increases this count

    function BatchCount: integer;

    /// execute a BATCH sequence started by BatchStart method

    // - send all pending BatchAdd/Update/Delete statements to the remote server

    // - URI is 'ModelRoot/TableName/0' with POST (or PUT) method

    // - will return the URI Status value, i.e. 200/HTML_SUCCESS OK on success

    // - a dynamic array of integers will be created in Results,

    // containing all ROWDID created for each BatchAdd call, 200 (=HTML_SUCCESS)

    // for all successfull BatchUpdate/BatchDelete, or 0 on error

    // - any error during server-side process MUST be checked against Results[]

    // (the main URI Status is 200 if about communication success, and won't

    // imply that all statements in the BATCH sequence were successfull

    function BatchSend(var Results: TIDDynArray): integer; overload;

    /// abort a BATCH sequence started by BatchStart method

    // - in short, nothing is sent to the remote server, and current BATCH

    // sequence is closed

    // - will Free the TSQLRestBatch stored in this TSQLRestClientURI instance

    procedure BatchAbort;



    /// wrapper to the protected URI method to call a method on the server, using

    // a ModelRoot/[TableName/[ID/]]MethodName RESTful GET request

    // - returns the HTTP error code (e.g. 200/HTML_SUCCESS on success)

    // - this version will use a GET with supplied parameters (which will be encoded

    // with the URL)

    function CallBackGet(const aMethodName: RawUTF8;

      const aNameValueParameters: array of const;

      out aResponse: RawUTF8; aTable: TSQLRecordClass=nil; aID: TID=0;

      aResponseHead: PRawUTF8=nil): integer;

    /// wrapper to the protected URI method to call a method on the server, using

    // a ModelRoot/[TableName/[ID/]]MethodName RESTful GET request

    // - returns the UTF-8 decoded JSON result (server must reply with one

    // "result":"value" JSON object)

    // - this version will use a GET with supplied parameters (which will be encoded

    // with the URL)

    function CallBackGetResult(const aMethodName: RawUTF8;

      const aNameValueParameters: array of const;

      aTable: TSQLRecordClass=nil; aID: TID=0): RawUTF8;

    /// wrapper to the protected URI method to call a method on the server, using

    //  a ModelRoot/[TableName/[ID/]]MethodName RESTful PUT request

    // - returns the HTTP error code (e.g. 200/HTML_SUCCESS on success)

    // - this version will use a PUT with the supplied raw UTF-8 data

    function CallBackPut(const aMethodName, aSentData: RawUTF8;

      out aResponse: RawUTF8; aTable: TSQLRecordClass=nil; aID: TID=0;

      aResponseHead: PRawUTF8=nil): integer;

    /// wrapper to the protected URI method to call a method on the server, using

    //  a ModelRoot/[TableName/[ID/]]MethodName RESTful with any kind of request

    // - returns the HTTP error code (e.g. 200/HTML_SUCCESS on success)

    // - for GET/PUT methods, you should better use CallBackGet/CallBackPut

    function CallBack(method: TSQLURIMethod; const aMethodName,aSentData: RawUTF8;

      out aResponse: RawUTF8; aTable: TSQLRecordClass=nil; aID: TID=0;

      aResponseHead: PRawUTF8=nil): integer;

    /// register one or several Services on the client side via their interfaces

    // - this methods expects a list of interfaces to be registered to the client

    // (e.g. [TypeInfo(IMyInterface)])

    // - instance implementation pattern will be set by the appropriate parameter

    // - will return true on success, false if registration failed (e.g. if any of

    // the supplied interfaces is not correct or is not available on the server)

    // - that is, server side will be called to check for the availability of

    // each interface

    // - you can specify an optional custom contract for the first interface

    function ServiceRegister(const aInterfaces: array of PTypeInfo;

      aInstanceCreation: TServiceInstanceImplementation=sicSingle;

      const aContractExpected: RawUTF8=''): boolean; overload; virtual;

    /// register a Service on the client side via its interface

    // - this methods expects one interface to be registered to the client, as

    // ! Client.ServiceRegister(TypeInfo(IMyInterface),sicShared);

    // - instance implementation pattern will be set by the appropriate parameter

    // - will return the corresponding fake class factory on success, nil if

    // registration failed (e.g. if any of supplied interfaces is not correct or

    // is not available on the server)

    // - that is, server side will be called to check for the availability of

    // each interface

    // - you can specify an optional custom contract for the first interface

    function ServiceRegister(aInterface: PTypeInfo;

      aInstanceCreation: TServiceInstanceImplementation=sicSingle;

      const aContractExpected: RawUTF8=''): TServiceFactory; overload;

    /// register and retrieve the sicClientDriven Service instance

    // - will return TRUE on success, filling Obj output variable with the

    // corresponding interface instance

    // - will return FALSE on error

    function ServiceRegisterClientDriven(aInterface: PTypeInfo; out Obj;

      const aContractExpected: RawUTF8=''): boolean; overload;

    /// register one or several Services on the client side via their interfaces

    // - this method expects the interface(s) to have been registered previously:

    // ! TInterfaceFactory.RegisterInterfaces([TypeInfo(IMyInterface),...]);

    function ServiceDefine(const aInterfaces: array of TGUID;

      aInstanceCreation: TServiceInstanceImplementation=sicSingle;

      const aContractExpected: RawUTF8=''): boolean; overload;

    /// register a Service on the client side via its interface

    // - this method expects the interface(s) to have been registered previously:

    // ! TInterfaceFactory.RegisterInterfaces([TypeInfo(IMyInterface),...]);

    function ServiceDefine(const aInterface: TGUID;

      aInstanceCreation: TServiceInstanceImplementation=sicSingle;

      const aContractExpected: RawUTF8=''): TServiceFactoryClient; overload;

    /// register and retrieve the sicClientDriven Service instance

    // - this method expects the interface(s) to have been registered previously:

    // ! TInterfaceFactory.RegisterInterfaces([TypeInfo(IMyInterface),...]);

    function ServiceDefineClientDriven(const aInterface: TGUID; out Obj;

      const aContractExpected: RawUTF8=''): boolean; overload;

    /// allow to notify a server the services this client may be actually capable

    // - when this client will connect to a remote server to access its services,

    // it will register its own services, supplying its TSQLRestServer instance,

    // and its corresponding public URI, within its '_contract_' internal call

    // - it will allow automatic service discovery of Peer To Peer Servers,

    // without the need of an actual centralized SOA catalog service: any

    // client could retrieve an associated REST server for a given service,

    // via the ServiceRetrieveAssociated method

    procedure ServicePublishOwnInterfaces(OwnServer: TSQLRestServer);

    /// return all REST server URI associated to this client, for a given

    // service name, the latest registered in first position

    // - will lookup for the Interface name without the initial 'I', e.g.

    // 'Calculator' for ICalculator - warning: research is case-sensitive

    // - this methods is the reverse from ServicePublishOwnInterfaces: it allows

    // to guess an associated REST server which may implement a given service 

    function ServiceRetrieveAssociated(const aServiceName: RawUTF8;

      out URI: TSQLRestServerURIDynArray): boolean; overload;

    /// return all REST server URI associated to this client, for a given service

    // - here the service is specified as its TGUID, e.g. IMyInterface

    // - this method expects the interface to have been registered previously:

    // ! TInterfaceFactory.RegisterInterfaces([TypeInfo(IMyInterface),...]);

    // - the URI[] output array contains the matching server URIs, the latest

    // registered in first position 

    // - this methods is the reverse from ServicePublishOwnInterfaces: it allows

    // to guess an associated REST server which may implement a given service

    function ServiceRetrieveAssociated(const aInterface: TGUID;

      out URI: TSQLRestServerURIDynArray): boolean; overload;

    {$ifdef MSWINDOWS}

    /// set a HWND/WM_* pair to let interface-based services notification

    // callbacks be processed safely in the main UI thread, via Windows messages

    // - by default callbacks are executed in the transmission thread, e.g.

    // the WebSockets client thread: using VCL Synchronize() method may

    // trigger some unexpected race conditions, e.g. when asynchronous

    // notifications are received during a blocking REST command - this

    // message-based mechanism would allow safe and easy notification for

    // any VCL client application

    // - the associated ServiceNotificationMethodExecute() method shall be

    // called in the client HWND TForm for the defined WM_* message

    procedure ServiceNotificationMethodViaMessages(hWnd: HWND; Msg: UINT);

    /// event to be triggered when a WM_* message is received from

    // the internal asynchronous notification system, to run the callback

    // in the main UI thread

    // - WM_* message identifier should have been set e.g. via the associated

    // ServiceNotificationMethodViaMessages(Form.Handle,WM_USER)

    // - message would be sent for any interface-based service method callback

    // which expects no result (i.e. no out parameter nor function result),

    // so is safely handled as asynchronous notification

    // - is defines as a class procedure, since the underlying TSQLRestClientURI

    // instance has no impact here: a single WM_* handler is enough for

    // several TSQLRestClientURI instances

    class procedure ServiceNotificationMethodExecute(var Msg : TMessage);

    {$endif MSWINDOWS}

  published

    /// low-level error code, as returned by server

    // - check this value about HTML_* constants

    // - HTML_SUCCESS or HTML_CREATED mean no error

    // - otherwise, check LastErrorMessage property for additional information

    // - this property value will record status codes returned by URI() method

    property LastErrorCode: integer read fLastErrorCode;

    /// low-level error message, as returned by server

    // - this property value will record content returned by URI() method in

    // case of an error, or '' if LastErrorCode is HTML_SUCCESS or HTML_CREATED

    property LastErrorMessage: RawUTF8 read fLastErrorMessage;

    /// low-level exception class, if any

    // - will record any Exception class raised within URI() method

    // - contains nil if URI() execution did not raise any exception (which

    // is the most expected behavior, since server-side errors are trapped

    // into LastErrorCode/LastErrorMessage properties

    property LastErrorException: ExceptClass read fLastErrorException;



    /// maximum additional retry occurence

    // - defaut is 0, i.e. will retry once

    // - set OnAuthentificationFailed to nil in order to avoid any retry

    property MaximumAuthentificationRetry: Integer

      read fMaximumAuthentificationRetry write fMaximumAuthentificationRetry;

    /// if the client shall retry once in case of "408 REQUEST TIMEOUT" error

    property RetryOnceOnTimeout: Boolean

      read fRetryOnceOnTimeout write fRetryOnceOnTimeout;

    /// the current session ID as set after a successfull SetUser() method call

    // - equals 0 (CONST_AUTHENTICATION_SESSION_NOT_STARTED) if the session

    // is not started yet - i.e. if SetUser() call failed

    // - equals 1 (CONST_AUTHENTICATION_NOT_USED) if authentication mode

    // is not enabled - i.e. after a fresh Create() without SetUser() call

    property SessionID: cardinal read fSessionID;

    /// the remote server executable name, as retrieved after a SetUser() success

    property SessionServer: RawUTF8 read fSessionServer;

    /// the remote server version, as retrieved after a SetUser() success

    property SessionVersion: RawUTF8 read fSessionVersion;

  public

    /// the current user as set by SetUser() method

    // - contans nil if no User is currently authenticated

    // - once authenticated, a TSQLAuthUser instance is set, with its ID,

    // LogonName, DisplayName, PasswordHashHexa and GroupRights (filled with a

    // TSQLAuthGroup ID casted as a pointer) properties - you can retrieve any

    // optional binary data associated with this user via RetrieveBlobFields()

    property SessionUser: TSQLAuthUser read fSessionUser;

{$ifndef LVCL}

    /// set a callback event to be executed in loop during remote blocking

    // process, e.g. to refresh the UI during a somewhat long request

    // - if not set, the request will be executed in the current thread,

    // so may block the User Interface

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

    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;

{$endif}

    /// this Event is called in case of remote authentication failure

    // - client software can ask the user to enter a password and user name

    // - if no event is specified, the URI() method will return directly

    // an HTML_FORBIDDEN "403 Forbidden" error code

    property OnAuthentificationFailed: TOnAuthentificationFailed

      read fOnAuthentificationFailed write fOnAuthentificationFailed;

    /// this Event is called if URI() was not successfull

    // - the callback would have all needed information

    property OnFailed: TOnClientFailed read fOnFailed write fOnFailed;

    /// this Event is called when a user is authenticated

    // - is called always, on each TSQLRestClientURI.SetUser call

    // - you can check the SessionUser property to retrieve the current

    // authenticated user, or nil if authentication failed

    // - could be used to refresh the User Interface layout according to

    // current authenticated user rights

    property OnSetUser: TNotifyEvent read fOnSetUser write fOnSetUser;

  end;



  /// Rest client with remote access to a server through a dll

  // - use only one TURIMapRequest function for the whole communication

  // - the data is stored in Global system memory, and freed by GlobalFree()

  TSQLRestClientURIDll = class(TSQLRestClientURI)

  private

    /// used by Create(from dll) constructor

    fLibraryHandle: cardinal;

  protected

    Func: TURIMapRequest;

    /// method calling the RESTful server through a DLL or executable, using

    // direct memory

    procedure InternalURI(var Call: TSQLRestURIParams); override;

    /// overridden protected method do nothing (direct DLL access has no connection)

    function InternalCheckOpen: boolean; override;

    /// overridden protected method do nothing (direct DLL access has no connection)

    procedure InternalClose; override;

  public

    /// connect to a server from a remote function

    constructor Create(aModel: TSQLModel; aRequest: TURIMapRequest); reintroduce; overload;

    /// connect to a server contained in a shared library

    // - this dll must contain at least a URIRequest entry

    // - raise an exception if the shared library is not found or invalid

    constructor Create(aModel: TSQLModel; const DllName: TFileName); reintroduce; overload;

    /// release memory and handles

    destructor Destroy; override;

  end;



  /// Rest client with redirection to another TSQLRest instance

  TSQLRestClientRedirect = class(TSQLRestClientURI)

  protected

    fRedirectedServer: TSQLRestServer;

    fRedirectedClient: TSQLRestClientURI;

    /// method calling the associated RESTful instance

    procedure InternalURI(var Call: TSQLRestURIParams); override;

    /// overridden protected method which returns TRUE if redirection is enabled

    function InternalCheckOpen: boolean; override;

    /// this overridden protected method does nothing 

    procedure InternalClose; override;

  public

    /// prepare the redirection, to be enabled later via RedirectTo()

    // - the supplied aModel instance would be owned by this class

    constructor Create(aModel: TSQLModel); overload; override;

    /// would pass all client commands to the supplied TSQLRest instance

    // - aRedirected is expected to be either a TSQLRestClientURI or

    // a TSQLRestServer

    // - will make a copy of the aRedirected.Model, and own it

    constructor Create(aRedirected: TSQLRest); reintroduce; overload;

    /// would pass all client commands to the supplied TSQLRestServer instance

    // - aRedirected would be owned by this TSQLRestClientRedirect

    constructor CreateOwned(aRedirected: TSQLRestServer); reintroduce;

    /// allows to change redirection to a client on the fly

    // - if aRedirected is nil, redirection would be disabled and any URI() call

    // would return an HTML_GATEWAYTIMEOUT 504 error status

    procedure RedirectTo(aRedirected: TSQLRest);

  end;



  {$ifdef MSWINDOWS}



  /// Rest client with remote access to a server through Windows messages

  // - use only one TURIMapRequest function for the whole communication

  // - the data is sent and received by using the standard and fast WM_COPYDATA message

  // - named pipes seems to be somewhat better for bigger messages under XP

  // - this class is thread-safe, since its URI() method is protected by a lock

  TSQLRestClientURIMessage = class(TSQLRestClientURI)

  protected

    /// the HWND of the server process, retrieved by InternalCheckOpen() method

    fServerWindow: HWND;

    /// the Window name used of the server process

    fServerWindowName: string;

    /// the HWND of the client process, as set by Create() method

    fClientWindow: HWND;

    /// the Window name used, if created internaly

    fClientWindowName: string;

    /// the time out to be used, in mili seconds

    fTimeOutMS: cardinal;

    /// if InternalURI will process the Windows Messages loop

    fDoNotProcessMessages: boolean;

    /// the expected current response

    // - this value is set from the incoming WM_COPYDATA

    // - this value is set to #0 (i.e. string of one #0 char) while waiting

    // for a WM_COPYDATA message in URI() method

    fCurrentResponse: RawUTF8;

    constructor RegisteredClassCreateFrom(aModel: TSQLModel;

      aDefinition: TSynConnectionDefinition); override;

    /// method calling the RESTful server by using Windows WM_COPYDATA messages

    procedure InternalURI(var Call: TSQLRestURIParams); override;

    /// overridden protected method to handle Windows Message loop connection

    function InternalCheckOpen: boolean; override;

    /// overridden protected method to close Windows Message

    procedure InternalClose; override;

  public

    /// connect to a server from its window name

    // - ServerWindowName is of UnicodeString type since Delphi 2009

    // (direct use of FindWindow()=FindWindowW() Win32 API)

    // - this version must supply a Client Window handle

    constructor Create(aModel: TSQLModel; const ServerWindowName: string;

      ClientWindow: HWND; TimeOutMS: cardinal); reintroduce; overload;

    /// connect to a server from its window name

    // - ServerWindowName is of UnicodeString type since Delphi 2009

    // (direct use of FindWindow()=FindWindowW() Win32 API)

    // - this version will instanciante and create a Client Window from

    // a Window Name, by using low level Win32 API: therefore, the Forms unit

    // is not needed with this constructor (save some KB)

    constructor Create(aModel: TSQLModel; const ServerWindowName,

      ClientWindowName: string; TimeOutMS: cardinal); reintroduce; overload;

    /// release the internal Window class created, if any

    destructor Destroy; override;

    /// save the TSQLRestClientURIMessage properties into a persistent storage object

    // - CreateFrom() will expect Definition.ServerName to store the

    // ServerWindowName, and Definition.DatabaseName to be the ClientWindowName

    procedure DefinitionTo(Definition: TSynConnectionDefinition); override;

    /// event to be triggered when a WM_COPYDATA message is received from the server

    // - to be called by the corresponding "message WM_COPYDATA;" method in the

    // client TForm instance

    procedure WMCopyData(var Msg : TWMCopyData); message WM_COPYDATA;

    /// define if the client will process the Windows Messages loop

    // - set to TRUE if the client is used outside the main GUI application thread

    property DoNotProcessMessages: boolean read fDoNotProcessMessages write fDoNotProcessMessages;

  end;



  /// Rest client with remote access to a server through a Named Pipe

  // - named pipe is fast and optimized under Windows

  // - can be accessed localy or remotely

  // - this class is thread-safe, since its URI() method is protected by a lock

  TSQLRestClientURINamedPipe = class(TSQLRestClientURI)

  private

    /// handle for '\\.\pipe\mORMot_TEST' e.g.

    fServerPipe: THandle;

    /// the pipe name

    fPipeName: TFileName;

{$ifndef ANONYMOUSNAMEDPIPE}

  {$ifndef NOSECURITYFORNAMEDPIPECLIENTS}

    fPipeSecurityAttributes: TSecurityAttributes;

    fPipeSecurityDescriptor: array[0..SECURITY_DESCRIPTOR_MIN_LENGTH] of byte;

  {$endif}

{$endif}

  protected

    constructor RegisteredClassCreateFrom(aModel: TSQLModel;

      aDefinition: TSynConnectionDefinition); override;

    /// method calling the RESTful server through a DLL or executable, by using

    // a named pipe (faster than TCP/IP or HTTP connection)

    // - return status code in result.Lo

    // - return database internal state in result.Hi

    // - status code 501 HTML_NOTIMPLEMENTED if no server is available

    procedure InternalURI(var Call: TSQLRestURIParams); override;

    /// overridden protected method to handle named-pipe connection

    function InternalCheckOpen: boolean; override;

    /// overridden protected method to close named-pipe connection

    procedure InternalClose; override;

  public

    /// connect to a server contained in a running application

    // - the server must have been declared by a previous

    // TSQLRestServer.ExportServer(ApplicationName) call

    // with ApplicationName as user-defined server identifier ('DBSERVER' e.g.)

    // - ApplicationName is of UnicodeString type since Delphi 2009

    // (direct use of Wide Win32 API version)

    // - this server identifier is appended to '\\.\pipe\mORMot_' to obtain

    // the full pipe name to connect to ('\\.\pipe\mORMot__DBSERVER' e.g.)

    // - this server identifier may also contain a remote computer name, and

    // must be fully qualified ('\\ServerName\pipe\ApplicationName' e.g.)

    // - raise an exception if the server is not running or invalid

    constructor Create(aModel: TSQLModel; const ApplicationName: TFileName); reintroduce;

    /// save the TSQLRestClientURIMessage properties into a persistent storage object

    // - CreateFrom() will expect Definition.ServerName to store the

    // expected ApplicationName

    procedure DefinitionTo(Definition: TSynConnectionDefinition); override;

  end;

{$endif Win32}



  /// will define a validation to be applied to a TSQLRecord field, using

  // if necessary an associated TSQLRest instance and a TSQLRecord class

  // - a typical usage is to validate a value to be unique in the table

  // (implemented in the TSynValidateUniqueField class)

  // - the optional associated parameters are to be supplied JSON-encoded

  // - ProcessRest and ProcessRec properties will be filled before Process

  // method call by TSQLRecord.Validate()

  TSynValidateRest = class(TSynValidate)

  protected

    fProcessRest: TSQLRest;

    fProcessRec: TSQLRecord;

  public

    /// the associated TSQLRest instance

    // - this value is updated by TSQLRecord.Validate with the current

    // TSQLRest used for the validation

    // - it can be used in the overridden Process method

    property ProcessRest: TSQLRest read fProcessRest;

    /// the associated TSQLRecord instance

    // - this value is updated by TSQLRecord.Validate with the current

    // TSQLRecord instance to be validated

    // - it can be used in the overridden Process method

    property ProcessRec: TSQLRecord read fProcessRec;

  end;



  /// will define a validation for a TSQLRecord Unique text field

  // - this class will handle only textual fields, not numeric values

  // - it will check that the field value is not void

  // - it will check that the field value is not a duplicate

  TSynValidateUniqueField = class(TSynValidateRest)

  public

    /// perform the unique field validation action to the specified value

    // - duplication value check will use ProcessRest and ProcessRec properties,

    // as set by TSQLRecord.Validate

    function Process(aFieldIndex: integer; const Value: RawUTF8; var ErrorMsg: string): boolean; override;

  end;



  /// will define an unicity validation for a set of TSQLRecord text fields

  // - field names should be specified as CSV in the JSON "FieldNames" property

  // in the constructor, or the Parameters field, e.g. like

  // ! TSQLSampleRecord.AddFilterOrValidate('propA',

  // !   TSynValidateUniqueFields.Create('{"FieldNames":"propA,propB"}'));

  // - this class will handle only textual fields, not numeric values

  // - it will check that the field values are not a duplicate

  TSynValidateUniqueFields = class(TSynValidateRest)

  protected

    fFieldNames: TRawUTF8DynArray;

    procedure SetParameters(const Value: RawUTF8); override;

  public

    /// perform the unique fields validation action to the specified value

    // - duplication value check will use ProcessRest and ProcessRec properties,

    // as set by TSQLRecord.Validate

    function Process(aFieldIndex: integer; const Value: RawUTF8; var ErrorMsg: string): boolean; override;

    /// the validated field names

    property FieldNames: TRawUTF8DynArray read fFieldNames;

  end;





  /// a WHERE constraint as set by the TSQLVirtualTable.Prepare() method

  TSQLVirtualTablePreparedConstraint = packed record

    /// Column on left-hand side of constraint

    // - The first column of the virtual table is column 0

    // - The ROWID of the virtual table is column -1

    // - Hidden columns are counted when determining the column index

    // - if this field contains VIRTUAL_TABLE_IGNORE_COLUMN (-2), TSQLVirtualTable.

    // Prepare() should ignore this entry

    Column: integer;

    /// The associated expression

    // - TSQLVirtualTable.Prepare() must set Value.VType to not svtUnknown

    // (e.g. to svtNull), if an expression is expected at vt_BestIndex() call

    // - TSQLVirtualTableCursor.Search() will receive an expression value,

    // to be retrieved e.g. via sqlite3_value_*() functions

    Value: TSQLVar;

    /// Constraint operator

    // - MATCH keyword is parsed into soBeginWith, and should be handled as

    // soBeginWith, soContains or soSoundsLike* according to the effective

    // expression text value ('text*', '%text'...)

    Operation: TCompareOperator;

    /// If true, the constraint is assumed to be fully handled

    // by the virtual table and is not checked again by SQLite

    // - By default (OmitCheck=false), the SQLite core double checks all

    // constraints on each row of the virtual table that it receives

    // - TSQLVirtualTable.Prepare() can set this property to true

    OmitCheck: boolean;

  end;

  PSQLVirtualTablePreparedConstraint = ^TSQLVirtualTablePreparedConstraint;



  /// an ORDER BY clause as set by the TSQLVirtualTable.Prepare() method

  // - warning: this structure should match exactly TSQLite3IndexOrderBy as

  // defined in SynSQLite3 

  TSQLVirtualTablePreparedOrderBy = record

    /// Column number

    // - The first column of the virtual table is column 0

    // - The ROWID of the virtual table is column -1

    // - Hidden columns are counted when determining the column index.

    Column: Integer;

    /// True for DESCending order, false for ASCending order.

    Desc: boolean;

  end;



  /// abstract planning execution of a query, as set by TSQLVirtualTable.Prepare

  TSQLVirtualTablePreparedCost = (

    costFullScan, costScanWhere, costSecondaryIndex, costPrimaryIndex);



  /// the WHERE and ORDER BY statements as set by TSQLVirtualTable.Prepare

  // - Where[] and OrderBy[] are fixed sized arrays, for fast and easy code

  TSQLVirtualTablePrepared = {$ifndef ISDELPHI2010}object{$else}record{$endif}

  public

    /// number of WHERE statement parameters in Where[] array

    WhereCount: integer;

    /// numver of ORDER BY statement parameters in OrderBy[]

    OrderByCount: integer;

    /// if true, the ORDER BY statement is assumed to be fully handled

    // by the virtual table and is not checked again by SQLite

    // - By default (OmitOrderBy=false), the SQLite core sort all rows of the

    // virtual table that it receives according in order

    OmitOrderBy: boolean;

    ///  Estimated cost of using this prepared index

    // - SQLite uses this value to make a choice between several calls to

    // the TSQLVirtualTable.Prepare() method with several expressions

    EstimatedCost: TSQLVirtualTablePreparedCost;

    ///  Estimated number of rows of using this prepared index

    // - does make sense only if EstimatedCost=costFullScan

    // - SQLite uses this value to make a choice between several calls to

    // the TSQLVirtualTable.Prepare() method with several expressions

    // - is used only starting with SQLite 3.8.2

    EstimatedRows: Int64;

    /// WHERE statement parameters, in TSQLVirtualTableCursor.Search() order

    Where: array[0..MAX_SQLFIELDS-1] of TSQLVirtualTablePreparedConstraint;

    /// ORDER BY statement parameters

    OrderBy: array[0..MAX_SQLFIELDS-1] of TSQLVirtualTablePreparedOrderBy;

    /// returns TRUE if there is only one ID=? statement in this search

    function IsWhereIDEquals(CalledFromPrepare: Boolean): boolean;

       {$ifdef HASINLINE}inline;{$endif}

    /// returns TRUE if there is only one FieldName=? statement in this search

    function IsWhereOneFieldEquals: boolean;

       {$ifdef HASINLINE}inline;{$endif}

  end;



  PSQLVirtualTablePrepared = ^TSQLVirtualTablePrepared;



  TSQLVirtualTableCursor = class;



  /// class-reference type (metaclass) of a cursor on an abstract Virtual Table

  TSQLVirtualTableCursorClass = class of TSQLVirtualTableCursor;



  /// the possible features of a Virtual Table

  // - vtWrite is to be set if the table is not Read/Only

  // - vtTransaction if handles vttBegin, vttSync, vttCommit, vttRollBack

  // - vtSavePoint if handles vttSavePoint, vttRelease, vttRollBackTo

  // - vtWhereIDPrepared if the ID=? WHERE statement will be handled in

  // TSQLVirtualTableCursor.Search()

  TSQLVirtualTableFeature = (vtWrite, vtTransaction, vtSavePoint,

    vtWhereIDPrepared);



  /// a set of features of a Virtual Table

  TSQLVirtualTableFeatures = set of TSQLVirtualTableFeature;



  /// used to store and handle the main specifications of a TSQLVirtualTableModule

  TVirtualTableModuleProperties = record

    /// a set of features of a Virtual Table

    Features: TSQLVirtualTableFeatures;

    /// the associated cursor class

    CursorClass: TSQLVirtualTableCursorClass;

    /// the associated TSQLRecord class

    // - used to retrieve the field structure with all collations

    RecordClass: TSQLRecordClass;

    /// the associated TSQLRestStorage class used for storage

    // - is e.g. TSQLRestStorageInMemory for TSQLVirtualTableJSON,

    // TSQLRestStorageExternal for TSQLVirtualTableExternal, or nil for

    // TSQLVirtualTableLog

    StaticClass: TSQLRestStorageClass;

    /// can be used to customize the extension of the filename

    // - the '.' is not to be included

    FileExtension: TFileName;

  end;



  /// parent class able to define a Virtual Table module

  // - in order to implement a new Virtual Table type, you'll have to define a so

  // called "Module" to handle the fields and data access and an associated

  // TSQLVirtualTableCursorClass for handling the SELECT statements

  // - for our framework, the SQLite3 unit will inherit from this class to define

  // a TSQLVirtualTableModuleSQLite3 class, which will register the associated

  // virtual table definition into a SQLite3 connection, on the server side

  // - children should override abstract methods in order to implement the

  // association with the database engine itself

  TSQLVirtualTableModule = class

  protected

    fModuleName: RawUTF8;

    fTableClass: TSQLVirtualTableClass;

    fServer: TSQLRestServer;

    fFeatures: TVirtualTableModuleProperties;

    fFilePath: TFileName;

  public

    /// create the Virtual Table instance according to the supplied class

    // - inherited constructors may register the Virtual Table to the specified

    // database connection

    constructor Create(aTableClass: TSQLVirtualTableClass;

      aServer: TSQLRestServer); virtual;

    /// retrieve the file name to be used for a specific Virtual Table

    // - returns by default a file located in the executable folder, with the

    // table name as file name, and module name as extension

    function FileName(const aTableName: RawUTF8): TFileName; virtual;

    /// the Virtual Table module features

    property Features: TSQLVirtualTableFeatures read fFeatures.Features;

    /// the associated virtual table class

    property TableClass: TSQLVirtualTableClass read fTableClass;

    /// the associated virtual table cursor class

    property CursorClass: TSQLVirtualTableCursorClass read fFeatures.CursorClass;

    /// the associated TSQLRestStorage class used for storage

    // - e.g. returns TSQLRestStorageInMemory for TSQLVirtualTableJSON,

    // or TSQLRestStorageExternal for TSQLVirtualTableExternal, or

    // either nil for TSQLVirtualTableLog

    property StaticClass: TSQLRestStorageClass read fFeatures.StaticClass;

    /// the associated TSQLRecord class

    // - is mostly nil, e.g. for TSQLVirtualTableJSON

    // - used to retrieve the field structure for TSQLVirtualTableLog e.g.

    property RecordClass: TSQLRecordClass read fFeatures.RecordClass;

    /// the extension of the filename (without any left '.')

    property FileExtension: TFileName read fFeatures.FileExtension;

    /// the full path to be used for the filename

    // - is '' by default, i.e. will use the executable path

    // - you can specify here a custom path, which will be used by the FileName

    // method to retrieve the .json/.data full file

    property FilePath: TFileName read fFilePath write fFilePath;

    /// the associated Server instance

    // - may be nil, in case of direct access to the virtual table

    property Server: TSQLRestServer read fServer;

    /// the corresponding module name

    property ModuleName: RawUTF8 read fModuleName;

  end;



  /// the available transaction levels

  TSQLVirtualTableTransaction = (

    vttBegin, vttSync, vttCommit, vttRollBack,

    vttSavePoint, vttRelease, vttRollBackTo);



  /// abstract class able to access a Virtual Table content

  // - override the Prepare/Structure abstract virtual methods for reading

  // access to the virtual table content

  // - you can optionaly override Drop/Delete/Insert/Update/Rename/Transaction

  // virtual methods to allow content writing to the virtual table

  // - the same virtual table mechanism can be used with several database module,

  // with diverse database engines

  TSQLVirtualTable = class

  protected

    fModule: TSQLVirtualTableModule;

    fTableName: RawUTF8;

    fStatic: TSQLRest;

    fStaticStorage: TSQLRestStorage;

    fStaticTable: TSQLRecordClass;

    fStaticTableIndex: integer;

  public

    /// create the virtual table access instance

    // - the created instance will be released when the virtual table will be

    // disconnected from the DB connection (e.g. xDisconnect method for SQLite3)

    // - shall raise an exception in case of invalid parameters (e.g. if the

    // supplied module is not associated to a TSQLRestServer instance)

    // - aTableName will be checked against the current aModule.Server.Model

    // to retrieve the corresponding TSQLRecordVirtualTableAutoID class and

    // create any associated Static: TSQLRestStorage instance

    constructor Create(aModule: TSQLVirtualTableModule; const aTableName: RawUTF8;

      FieldCount: integer; Fields: PPUTF8CharArray); virtual;

    /// release the associated memory, especially the Static instance

    destructor Destroy; override;

    /// retrieve the corresponding module name

    // - will use the class name, triming any T/TSQL/TSQLVirtual/TSQLVirtualTable*

    // - when the class is instanciated, it will be faster to retrieve the same

    // value via Module.ModuleName

    class function ModuleName: RawUTF8;

    /// a generic method to get a 'CREATE TABLE' structure from a supplied

    // TSQLRecord class

    // - is called e.g. by the Structure method

    class function StructureFromClass(aClass: TSQLRecordClass;

      const aTableName: RawUTF8): RawUTF8;

    /// the associated Virtual Table module

    property Module: TSQLVirtualTableModule read fModule;

    /// the name of the Virtual Table, as specified following the TABLE keyword

    // in the CREATE VIRTUAL TABLE statement

    property TableName: RawUTF8 read fTableName;

  public { virtual methods to be overridden }

    /// should return the main specifications of the associated TSQLVirtualTableModule

    class procedure GetTableModuleProperties(

      var aProperties: TVirtualTableModuleProperties); virtual; abstract;

    /// called to determine the best way to access the virtual table

    // - will prepare the request for TSQLVirtualTableCursor.Search()

    // - in Where[], Expr must be set to not 0 if needed for Search method,

    // and OmitCheck to true if double check is not necessary

    // - OmitOrderBy must be set to true if double sort is not necessary

    // - EstimatedCost and EstimatedRows should receive the estimated cost

    // - default implementation will let the DB engine perform the search,

    // and prepare for ID=? statement if vtWhereIDPrepared was set

    function Prepare(var Prepared: TSQLVirtualTablePrepared): boolean; virtual;

    /// should retrieve the format (the names and datatypes of the columns) of

    // the virtual table, as expected by sqlite3_declare_vtab()

    // - default implementation is to retrieve the structure for the associated

    // Module.RecordClass property (as set by GetTableModuleProperties) or

    // the Static.StoredClass: in both cases, column numbering will follow

    // the TSQLRecord published field order (TSQLRecord.RecordProps.Fields[])

    function Structure: RawUTF8; virtual;

    /// called when a DROP TABLE statement is executed against the virtual table

    // - should return true on success, false otherwise

    // - does nothing by default, and returns false, i.e. always fails

    function Drop: boolean; virtual;

    /// called to delete a virtual table row

    // - should return true on success, false otherwise

    // - does nothing by default, and returns false, i.e. always fails

    function Delete(aRowID: Int64): boolean; virtual;

    /// called to insert a virtual table row content from an array of TSQLVar

    // - should return true on success, false otherwise

    // - should return the just created row ID in insertedRowID on success

    // - does nothing by default, and returns false, i.e. always fails

    function Insert(aRowID: Int64; var Values: TSQLVarDynArray;

      out insertedRowID: Int64): boolean; virtual;

    /// called to update a virtual table row content from an array of TSQLVar

    // - should return true on success, false otherwise

    // - does nothing by default, and returns false, i.e. always fails

    function Update(oldRowID, newRowID: Int64; var Values: TSQLVarDynArray): boolean; virtual;

    /// called to begin a transaction to the virtual table row

    // - do nothing by default, and returns false in case of RollBack/RollBackto

    // - aSavePoint is used for vttSavePoint, vttRelease and vttRollBackTo only

    // - note that if you don't nest your writing within a transaction, SQLite

    // will call vttCommit for each INSERT/UPDATE/DELETE, just like a regular

    // SQLite database - it could make bad written code slow even with Virtual

    // Tables

    function Transaction(aState: TSQLVirtualTableTransaction; aSavePoint: integer): boolean; virtual;

    /// called to rename the virtual table

    // - by default, returns false, i.e. always fails

    function Rename(const NewName: RawUTF8): boolean; virtual;

    /// the associated virtual table storage instance

    // - can be e.g. a TSQLRestStorageInMemory for TSQLVirtualTableJSON,

    // or a TSQLRestStorageExternal for TSQLVirtualTableExternal, or nil

    // for TSQLVirtualTableLog

    property Static: TSQLRest read fStatic;

    /// the associated virtual table storage instance, if is a TSQLRestStorage

    property StaticStorage: TSQLRestStorage read fStaticStorage;

    /// the associated virtual table storage table

    property StaticTable: TSQLRecordClass read fStaticTable;

    /// the associated virtual table storage index in its Model.Tables[] array

    property StaticTableIndex: integer read fStaticTableIndex;

  end;



  /// abstract class able to define a Virtual Table cursor

  // - override the Search/HasData/Column/Next abstract virtual methods to

  // implement the search process

  TSQLVirtualTableCursor = class

  protected

    fTable: TSQLVirtualTable;

    /// used internaly between two Column() method calls for GetFieldSQLVar()

    fColumnTemp: RawByteString;

    /// easy set a TSQLVar content for the Column() method

    procedure SetColumn(var aResult: TSQLVar; aValue: Int64); overload;

      {$ifdef HASINLINE}inline;{$endif}

    procedure SetColumn(var aResult: TSQLVar; const aValue: double); overload;

      {$ifdef HASINLINE}inline;{$endif}

    procedure SetColumn(var aResult: TSQLVar; const aValue: RawUTF8); overload;

      {$ifdef HASINLINE}inline;{$endif}

    procedure SetColumn(var aResult: TSQLVar; aValue: PUTF8Char; aValueLength: integer); overload;

      {$ifdef HASINLINE}inline;{$endif}

    procedure SetColumnBlob(var aResult: TSQLVar; aValue: pointer; aValueLength: integer);

      {$ifdef HASINLINE}inline;{$endif}

  public

    /// create the cursor instance

    // - it will be destroyed when by the DB engine (e.g. via xClose in SQLite3)

    constructor Create(aTable: TSQLVirtualTable); virtual;

    /// the associated Virtual Table class instance

    property Table: TSQLVirtualTable read fTable;

  public { abstract methods to be overridden }

    /// called to begin a search in the virtual table

    // - the TSQLVirtualTablePrepared parameters were set by

    // TSQLVirtualTable.Prepare and will contain both WHERE and ORDER BY statements

    // (retrieved e.g. by x_BestIndex() from a TSQLite3IndexInfo structure)

    // - Prepared will contain all prepared constraints and the corresponding

    // expressions in the Where[].Value field

    // - should move cursor to first row of matching data

    // - should return false on low-level database error (but true in case of a

    // valid call, even if HasData will return false, i.e. no data match)

    function Search(const Prepared: TSQLVirtualTablePrepared): boolean; virtual; abstract;

    /// called after Search() to check if there is data to be retrieved

    // - should return false if reached the end of matching data

    function HasData: boolean; virtual; abstract;

    /// called to retrieve a column value of the current data row into a TSQLVar

    // - if aColumn=-1, should return the row ID as varInt64 into aResult

    // - should return false in case of an error, true on success

    function Column(aColumn: integer; var aResult: TSQLVar): boolean; virtual; abstract;

    /// called to go to the next row of matching data

    // - should return false on low-level database error (but true in case of a

    // valid call, even if HasData will return false, i.e. no data match)

    function Next: boolean; virtual; abstract;

  end;



  /// A generic Virtual Table cursor associated to Current/Max index properties

  TSQLVirtualTableCursorIndex = class(TSQLVirtualTableCursor)

  protected

    fCurrent: integer;

    fMax: integer;

  public

    /// called after Search() to check if there is data to be retrieved

    // - will return false if reached the end of matching data, according to

    // the fCurrent/fMax protected properties values

    function HasData: boolean; override;

    /// called to go to the next row of matching data

    // - will return false on low-level database error (but true in case of a

    // valid call, even if HasData will return false, i.e. no data match)

    // - will check the fCurrent/fMax protected properties values

    function Next: boolean; override;

    /// called to begin a search in the virtual table

    // - this no-op version will mark EOF, i.e. fCurrent=0 and fMax=-1

    function Search(const Prepared: TSQLVirtualTablePrepared): boolean; override;

  end;



  /// A Virtual Table cursor for reading a TSQLRestStorageInMemory content

  // - this is the cursor class associated to TSQLVirtualTableJSON

  TSQLVirtualTableCursorJSON = class(TSQLVirtualTableCursorIndex)

  public

    /// called to begin a search in the virtual table

    // - the TSQLVirtualTablePrepared parameters were set by

    // TSQLVirtualTable.Prepare and will contain both WHERE and ORDER BY statements

    // (retrieved by x_BestIndex from a TSQLite3IndexInfo structure)

    // - Prepared will contain all prepared constraints and the corresponding

    // expressions in the Where[].Value field

    // - will move cursor to first row of matching data

    // - will return false on low-level database error (but true in case of a

    // valid call, even if HasData will return false, i.e. no data match)

    // - only handled WHERE clause is for "ID = value" - other request will

    // return all records in ID order, and let the database engine handle it

    function Search(const Prepared: TSQLVirtualTablePrepared): boolean; override;

    /// called to retrieve a column value of the current data row into a TSQLVar

    // - if aColumn=-1, will return the row ID as varInt64 into aResult

    // - will return false in case of an error, true on success

    function Column(aColumn: integer; var aResult: TSQLVar): boolean; override;

  end;



  /// A TSQLRestStorageInMemory-based virtual table using JSON storage

  // - for ORM access, you should use TSQLModel.VirtualTableRegister method to

  // associated this virtual table module to a TSQLRecordVirtualTableAutoID class

  // - transactions are not handled by this module

  // - by default, no data is written on disk: you will need to call explicitly

  // aServer.StaticVirtualTable[aClass].UpdateToFile for file creation or refresh

  // - file extension is set to '.json'

  TSQLVirtualTableJSON = class(TSQLVirtualTable)

  protected

    fStaticInMemory: TSQLRestStorageInMemory;

  public { overridden methods }

    /// create the virtual table access instance

    // - the created instance will be released when the virtual table will be

    // disconnected from the DB connection (e.g. xDisconnect method for SQLite3)

    // - shall raise an exception in case of invalid parameters (e.g. if the

    // supplied module is not associated to a TSQLRestServer instance)

    // - aTableName will be checked against the current aModule.Server.Model

    // to retrieve the corresponding TSQLRecordVirtualTableAutoID class and

    // create any associated Static: TSQLRestStorage instance

    constructor Create(aModule: TSQLVirtualTableModule; const aTableName: RawUTF8;

      FieldCount: integer; Fields: PPUTF8CharArray); override;

    /// returns the main specifications of the associated TSQLVirtualTableModule

    // - this is a read/write table, without transaction, associated to the

    // TSQLVirtualTableCursorJSON cursor type, with 'JSON' as module name

    // - no particular class is supplied here, since it will depend on the

    // associated Static instance

    class procedure GetTableModuleProperties(

      var aProperties: TVirtualTableModuleProperties); override;

    /// called to determine the best way to access the virtual table

    // - will prepare the request for TSQLVirtualTableCursor.Search()

    // - only prepared WHERE statement is for "ID = value"

    // - only prepared ORDER BY statement is for ascending IDs

    function Prepare(var Prepared: TSQLVirtualTablePrepared): boolean; override;

    /// called when a DROP TABLE statement is executed against the virtual table

    // - returns true on success, false otherwise

    function Drop: boolean; override;

    /// called to delete a virtual table row

    // - returns true on success, false otherwise

    function Delete(aRowID: Int64): boolean; override;

    /// called to insert a virtual table row content from a TSQLVar array

    // - column order follows the Structure method, i.e.

    // StoredClassRecordProps.Fields[] order

    // - returns true on success, false otherwise

    // - returns the just created row ID in insertedRowID on success

    // - does nothing by default, and returns false, i.e. always fails

    function Insert(aRowID: Int64; var Values: TSQLVarDynArray;

      out insertedRowID: Int64): boolean; override;

    /// called to update a virtual table row content from a TSQLVar array

    // - column order follows the Structure method, i.e.

    // StoredClassRecordProps.Fields[] order

    // - returns true on success, false otherwise

    // - does nothing by default, and returns false, i.e. always fails

    function Update(oldRowID, newRowID: Int64; var Values: TSQLVarDynArray): boolean; override;

  end;



  /// A TSQLRestStorageInMemory-based virtual table using Binary storage

  // - for ORM access, you should use TSQLModel.VirtualTableRegister method to

  // associated this virtual table module to a TSQLRecordVirtualTableAutoID class

  // - transactions are not handled by this module

  // - by default, no data is written on disk: you will need to call explicitly

  // aServer.StaticVirtualTable[aClass].UpdateToFile for file creation or refresh

  // - binary format is more efficient in term of speed and disk usage than

  // the JSON format implemented by TSQLVirtualTableJSON

  // - binary format will be set by TSQLVirtualTableJSON.CreateTableInstance

  // - file extension is set to '.data'

  TSQLVirtualTableBinary = class(TSQLVirtualTableJSON);



  /// Implements a read/only virtual table able to access a .log file, as created

  // by TSynLog

  // - to be used e.g. by a TSQLRecordLog_Log ('Log_' will identify this 'Log' module)

  // - the .log file name will be specified by the Table Name, to which a '.log'

  // file extension will be appended before loading it from the current directory

  TSQLVirtualTableLog = class(TSQLVirtualTable)

  protected

    fLogFile: TSynLogFile;

  public

    /// returns the main specifications of the associated TSQLVirtualTableModule

    // - this is a read only table, with transaction, associated to the

    // TSQLVirtualTableCursorLog cursor type, with 'Log' as module name,

    // and associated to TSQLRecordLog_Log table field layout

    class procedure GetTableModuleProperties(

      var aProperties: TVirtualTableModuleProperties); override;

    /// creates the TSQLVirtualTable according to the supplied parameters

    // - aTableName will be checked against the current aModule.Server.Model

    // to retrieve the corresponding TSQLRecordVirtualTableAutoID class

    constructor Create(aModule: TSQLVirtualTableModule; const aTableName: RawUTF8;

      FieldCount: integer; Fields: PPUTF8CharArray); override;

    /// release the associated .log file mapping and all internal structures

    destructor Destroy; override;

  end;



  /// A Virtual Table cursor for reading a TSynLogFile content

  // - this is the cursor class associated to TSQLVirtualTableLog

  TSQLVirtualTableCursorLog = class(TSQLVirtualTableCursorIndex)

  public

    /// called to begin a search in the virtual table

    function Search(const Prepared: TSQLVirtualTablePrepared): boolean; override;

    /// called to retrieve a column value of the current data row as TSQLVar

    function Column(aColumn: integer; var aResult: TSQLVar): boolean; override;

  end;



  /// Record associated to a Virtual Table implemented in Delphi, with ID

  // forced at INSERT

  // - will use TSQLVirtualTableModule / TSQLVirtualTable / TSQLVirtualTableCursor

  // classes for a generic Virtual table mechanism on the Server side

  // - call Model.VirtualTableRegister() before TSQLRestServer.Create on the

  // Server side (not needed for Client) to associate such a record with a

  // particular Virtual Table module, otherwise an exception will be raised:

  // ! Model.VirtualTableRegister(TSQLRecordDali1,TSQLVirtualTableJSON);

  TSQLRecordVirtualTableForcedID = class(TSQLRecordVirtual);



  /// Record associated to Virtual Table implemented in Delphi, with ID

  // generated automatically at INSERT

  // - will use TSQLVirtualTableModule / TSQLVirtualTable / TSQLVirtualTableCursor

  // classes for a generic Virtual table mechanism

  // - call Model.VirtualTableRegister() before TSQLRestServer.Create on the

  // Server side (not needed for Client) to associate such a record with a

  // particular Virtual Table module, otherwise an exception will be raised:

  // ! Model.VirtualTableRegister(TSQLRecordDali1,TSQLVirtualTableJSON);

  TSQLRecordVirtualTableAutoID = class(TSQLRecordVirtual);



/// special comparaison function for sorting ftRecord (TRecordReference/RecordRef)

// UTF-8 encoded values in the SQLite3 database or JSON content

function UTF8CompareRecord(P1,P2: PUTF8Char): PtrInt;



/// special comparaison function for sorting sftBoolean

// UTF-8 encoded values in the SQLite3 database or JSON content

function UTF8CompareBoolean(P1,P2: PUTF8Char): PtrInt;



/// special comparaison function for sorting sftEnumerate, sftSet or sftID

// UTF-8 encoded values in the SQLite3 database or JSON content

function UTF8CompareUInt32(P1,P2: PUTF8Char): PtrInt;



/// special comparaison function for sorting sftInteger, sftTID, sftRecordVersion

// or sftTimeLog / sftModTime / sftCreateTime UTF-8 encoded values in the SQLite3

// database or JSON content

function UTF8CompareInt64(P1,P2: PUTF8Char): PtrInt;



/// special comparaison function for sorting sftCurrency

// UTF-8 encoded values in the SQLite3 database or JSON content

function UTF8CompareCurr64(P1,P2: PUTF8Char): PtrInt;



/// special comparaison function for sorting sftFloat

// UTF-8 encoded values in the SQLite3 database or JSON content

function UTF8CompareDouble(P1,P2: PUTF8Char): PtrInt;



/// special comparaison function for sorting sftDateTime

// UTF-8 encoded values in the SQLite3 database or JSON content

function UTF8CompareISO8601(P1,P2: PUTF8Char): PtrInt;



{$ifndef NOVARIANTS}

/// low-level function used to convert a JSON Value into a variant,

// according to the property type

// - for sftObject, sftVariant, sftBlobDynArray and sftUTF8Custom, the

// JSON buffer may be an array or an object, so createValueTempCopy can

// create a temporary copy before parsing it in-place, to preserve the buffer

// - sftUnknown and sftMany would set a varEmpty (Unassigned) value

// - typeInfo may be used for sftBlobDynArray conversion to a TDocVariant array

procedure ValueVarToVariant(Value: PUTF8Char; fieldType: TSQLFieldType;

  var result: TVarData; createValueTempCopy: boolean; typeInfo: pointer;

  options: TDocVariantOptions=JSON_OPTIONS_FAST);



/// read an object properties from a TDocVariant object document

// - ObjectInstance must be an existing TObject instance

// - will return TRUE on success, or FALSE if the supplied aDocVariant was

// not a TDocVariant object

function ObjectLoadVariant(var ObjectInstance; const aDocVariant: variant;

  TObjectListItemClass: TClass=nil; Options: TJSONToObjectOptions=[]): boolean;

{$endif NOVARIANTS}



/// may be used by DatabaseExecute/AdministrationExecute methods to serve

// a folder content for remote administration

procedure AdministrationExecuteGetFiles(const Folder, Mask: TFileName; const Param: RawUTF8;

  var Answer: TServiceCustomAnswer);



const

  /// if a TSQLVirtualTablePreparedConstraint.Column is to be ignored

  VIRTUAL_TABLE_IGNORE_COLUMN = -2;

  /// if a TSQLVirtualTablePreparedConstraint.Column points to the RowID

  VIRTUAL_TABLE_ROWID_COLUMN = -1;



  /// if the TSQLRecordVirtual table kind is a FTS3/FTS4 virtual table

  IS_FTS = [rFTS3, rFTS4];



  /// if the TSQLRecordVirtual table kind is not an embedded type

  // - can be set for a TSQLRecord after a VirtualTableExternalRegister call

  IS_CUSTOM_VIRTUAL = [rCustomForcedID, rCustomAutoID];



  /// if the TSQLRecordVirtual table kind expects the ID to be set on INSERT

  INSERT_WITH_ID = [rFTS3, rFTS4, rRTree, rCustomForcedID];



  /// Supervisor Table access right, i.e. alllmighty over all fields

  ALL_ACCESS_RIGHTS = [0..MAX_SQLTABLES-1];



  /// Complete Database access right, i.e. allmighty over all Tables

  // - WITH the possibility to remotely execute any SQL statement (reSQL right)

  // - is used by default by TSQLRestClientDB.URI() method, i.e. for direct

  // local/in-process access

  // - is used as reference to create TSQLAuthUser 'Admin' access policy

  FULL_ACCESS_RIGHTS: TSQLAccessRights =

    (AllowRemoteExecute:

      [reSQL,reSQLSelectWithoutTable,reService,reUrlEncodedSQL,reUrlEncodedDelete];

     GET: ALL_ACCESS_RIGHTS; POST: ALL_ACCESS_RIGHTS;

     PUT: ALL_ACCESS_RIGHTS; DELETE: ALL_ACCESS_RIGHTS);



  /// Supervisor Database access right, i.e. allmighty over all Tables

  // - but WITHOUT the possibility to remotely execute any SQL statement (reSQL)

  // - is used as reference to create TSQLAuthUser 'Supervisor' access policy

  SUPERVISOR_ACCESS_RIGHTS: TSQLAccessRights =

    (AllowRemoteExecute:

      [reSQLSelectWithoutTable,reService,reUrlEncodedSQL,reUrlEncodedDelete];

     GET: ALL_ACCESS_RIGHTS; POST: ALL_ACCESS_RIGHTS;

     PUT: ALL_ACCESS_RIGHTS; DELETE: ALL_ACCESS_RIGHTS);



  /// special TSQLFieldBits value containing all field bits set to 1

  ALL_FIELDS: TSQLFieldBits = [0..MAX_SQLFIELDS-1];



  // contains TSQLAuthUser.ComputeHashedPassword('synopse')

  DEFAULT_HASH_SYNOPSE = '67aeea294e1cb515236fd7829c55ec820ef888e8e221814d24d83b3dc4d825dd';



  /// the Server-side instance implementation patterns without any ID

  SERVICE_IMPLEMENTATION_NOID = [sicSingle,sicShared];



  /// typical TJSONSerializerSQLRecordOptions values for AJAX clients

  JSONSERIALIZEROPTIONS_AJAX = [jwoAsJsonNotAsString,jwoID_str];



var

  /// default hashed password set by TSQLAuthGroup.InitializeTable for 'Admin' user

  // - you can override this value to follow your own application expectations

  AuthAdminDefaultPassword: RawUTF8 = DEFAULT_HASH_SYNOPSE;

  /// default hashed password set by TSQLAuthGroup.InitializeTable for 'Supervisor' user

  // - you can override this value to follow your own application expectations

  AuthSupervisorDefaultPassword: RawUTF8 = DEFAULT_HASH_SYNOPSE;

  /// default hashed password set by TSQLAuthGroup.InitializeTable for 'User' user

  // - you can override this value to follow your own application expectations

  AuthUserDefaultPassword: RawUTF8 = DEFAULT_HASH_SYNOPSE;



const

  /// timer identifier which indicates we must refresh the current Page

  // - used for User Interface generation

  // - is associated with the TSQLRibbonTabParameters.AutoRefresh property,

  // and is handled in TSQLRibbon.RefreshClickHandled

  WM_TIMER_REFRESH_SCREEN = 1;

  /// timer identifier which indicates we must refresh the Report content

  // - used for User Interface generation

  // - is handled in TSQLRibbon.RefreshClickHandled

  WM_TIMER_REFRESH_REPORT = 2;



  /// the default URI parameters for query paging

  // - those values are the one expected by YUI components

  PAGINGPARAMETERS_YAHOO: TSQLRestServerURIPagingParameters = (

    Sort: 'SORT=';

    Dir: 'DIR=';

    StartIndex: 'STARTINDEX=';

    Results: 'RESULTS=';

    Select: 'SELECT=';

    Where: 'WHERE=';

    SendTotalRowsCountFmt: '');



  /// options to specify no index createon for TSQLRestServer.CreateMissingTables

  // and TSQLRecord.InitializeTable methods

  INITIALIZETABLE_NOINDEX: TSQLInitializeTableOptions =

    [itoNoIndex4ID..itoNoIndex4RecordVersion];



  /// default value of TSQLRestServer.StatLevels property

  // - i.e. gather all statistics, but mlSessions

  SERVERDEFAULTMONITORLEVELS: TSQLRestServerMonitorLevels =

    [mlTables,mlMethods,mlInterfaces,mlSQLite3];



/// wrapper to search for a given TSQLRecord by ID in an array of TSQLRecord

function ObjArraySearch(const aSQLRecordObjArray; aID: TID): TSQLRecord;



/// wrapper to return all TID values of an array of TSQLRecord

procedure ObjArrayRecordIDs(const aSQLRecordObjArray; out result: TInt64DynArray);



/// safe deletion of a T*InterfaceArray dynamic array item

// - similar to InterfaceArrayDelete, but with a safe try .. except block

// during the entry deletion (since the system may be unstable)

// - will also log a warning with the Interface name (from aLogMsg) and aInstance

procedure InterfaceArrayDeleteAfterException(var aInterfaceArray;

  const aItemIndex: integer; aLog: TSynLogFamily; const aLogMsg: RawUTF8; aInstance: TObject);



/// create a TRecordReference with the corresponding parameters

function RecordReference(Model: TSQLModel; aTable: TSQLRecordClass; aID: TID): TRecordReference; overload;



/// create a TRecordReference with the corresponding parameters

function RecordReference(aTableIndex: cardinal; aID: TID): TRecordReference; overload;

  {$ifdef HASINLINE}inline;{$endif}



/// convert a dynamic array of TRecordReference into its corresponding IDs

procedure RecordRefToID(var aArray: TInt64DynArray);



/// get the order table name from a SQL statement

// - return the word following any 'ORDER BY' statement

// - return 'RowID' if none found

function SQLGetOrder(const SQL: RawUTF8): RawUTF8;



{$ifdef PUREPASCAL}{$ifdef HASINLINE}

/// this function is published only for class function TSQLRecord.RecordProps()

// internal call after inlining

function PropsCreate(aTable: TSQLRecordClass): TSQLRecordProperties;

{$endif}{$endif}



/// low-level function to retrieve the class instance implementing a given

// interface

// - this will work with interfaces stubs generated by the compiler, but also

// with TInterfaceFactory.CreateFakeInstance kind of classes

function ObjectFromInterface(const aValue: IInterface): TObject;



/// low-level function to check if a class instance, retrieved from its

// interface variable, does in fact implement a given interface 

// - this will call ObjectFromInterface(), so will work with interfaces

// stubs generated by the compiler, but also with

// TInterfaceFactory.CreateFakeInstance kind of classes

function ObjectFromInterfaceImplements(const aValue: IInterface;

  const aInterface: TGUID): boolean;



/// assign a Weak interface reference, to be used for circular references

// - by default setting aInterface.Field := aValue will increment the internal

// reference count of the implementation object: when underlying objects reference

// each other via interfaces (e.g. as parent and children), what causes the

// reference count to never reach zero, therefore resulting in memory links

// - to avoid this issue, use this procedure instead

procedure SetWeak(aInterfaceField: PIInterface; const aValue: IInterface);

 // {$ifdef HASINLINE}inline;{$endif} raise compilation Internal Error C2170



/// assign a Weak interface reference, which will be ZEROed (set to nil) when

// the corresponding object will be released

// - this function is bit slower than SetWeak, but will avoid any GPF, by

// maintaining a list of per-instance weak interface field reference, and

// hook the FreeInstance virtual method in order to reset any reference to nil:

// FreeInstance will be overridden for this given class VMT only (to avoid

// unnecessary slowdown of other classes), calling the previous method afterward

// (so will work even with custom FreeInstance implementations)

// - for faster possible retrieval, it will assign the unused vmtAutoTable VMT

// entry trick (just like TSQLRecord.RecordProps) - note that it will be

// compatible also with interfaces implemented via TSQLRecord children

// - thread-safe implementation, using a per-class fast lock

procedure SetWeakZero(aObject: TObject; aObjectInterfaceField: PIInterface;

  const aValue: IInterface);



{$ifdef ISDELPHIXE} // class helper requires Delphi 2006 or newer but are buggy before XE :(

type

  /// TWeakZeroInterfaceHelper is a class helper that allows you to use

  // SetWeakZero() in any class without specifying the Self parameter

  TWeakZeroInterfaceHelper = class helper for TObject

  protected

    /// Use SetWeak0 to assign an interface to a weak interface field

    // - this is just a wrapper around the global SetWeakZero() function

    procedure SetWeak0(aObjectInterfaceField: PIInterface; const aValue: IInterface);

  end;

{$endif}



var

  /// if this variable is TRUE, the URIRequest() function won't use

  // Win32 API GlobalAlloc() function, but fastest native Getmem()

  // - can be also useful for debugg

  USEFASTMM4ALLOC: boolean = false;



/// this function can be exported from a DLL to remotely access to a TSQLRestServer

// - use TSQLRestServer.ExportServer to assign a server to this function

// - return 501 HTML_NOTIMPLEMENTED if no TSQLRestServer.ExportServer has been assigned

// - memory for Resp and Head are allocated with GlobalAlloc(): client must release

// this pointers with GlobalFree() after having retrieved their content

// - simply use TSQLRestClientURIDll to access to an exported URIRequest() function

function URIRequest(url, method, SendData: PUTF8Char; Resp, Head: PPUTF8Char): Int64Rec; cdecl;





threadvar

  /// this thread-specific variable will be set with the currently running

  // service context (on the server side)

  // - note that in case of direct server side execution of the service, this

  // information won't be filled, so the safest (and slightly faster) access

  // to the TSQLRestServer instance associated with a service is to inherit your

  // implementation class from TInjectableObjectRest, and not use this threadvar

  // - is set by TServiceFactoryServer.ExecuteMethod() just before calling the

  // implementation method of a service, allowing to retrieve the current

  // execution context - Request member is set from a client/server execution:

  // Request.Server is the safe access point to the underlying TSQLRestServer,

  // in such context - also consider the CurrentServiceContextServer function to

  // retrieve directly the running TSQLRestServer (if any)

  // - its content is reset to zero out of the scope of a method execution

  // - when used, a local copy or a PServiceRunningContext pointer should better

  // be created, since accessing a threadvar has a non negligible performance

  // cost - for instance, if you want to use a "with" statement:

  // ! with PServiceRunningContext(@ServiceContext)^ do

  // !   ... access TServiceRunningContext members

  // or as a local variable:

  // !var context: PServiceRunningContext;

  // !    inContentType: RawUTF8;

  // !begin

  // !  context := @ServiceContext; // threadvar access once

  // !  ...

  // !  inContentType := FindIniNameValue(pointer(context.Request.Call^.InHead),

  // !    HEADER_CONTENT_TYPE_UPPER);

  // !end;

  // - when accessed from a package, use function CurrentServiceContext()

  // instead, to circumvent a Delphi RTL/compiler restriction (bug?)

  ServiceContext: TServiceRunningContext;



/// wrapper function to retrieve the global ServiceContext threadvar value

// - to be used when accessing the value from a package, to circumvent a

// Delphi RTL/compiler restriction (bug?)

function CurrentServiceContext: TServiceRunningContext;



/// wrapper function to retrieve the current REST server instance from

// the global ServiceContext threadvar value

// - may return nil if ServiceContext.Request is nil: in this case,

// you should better implement your service by inheriting the implementation

// class from TInjectableObjectRest

function CurrentServiceContextServer: TSQLRestServer;



function ToText(ft: TSQLFieldType): PShortString; overload;

function ToText(tk: TTypeKind): PShortString; overload;

function ToText(e: TSQLEvent): PShortString; overload;

function ToText(he: TSQLHistoryEvent): PShortString; overload;

function ToText(o: TSQLOccasion): PShortString; overload;

function ToText(dft: TSQLDBFieldType): PShortString; overload;

function ToText(si: TServiceInstanceImplementation): PShortString; overload;

function ToText(cmd: TSQLRestServerURIContextCommand): PShortString; overload;

function ToText(op: TSQLQueryOperator): PShortString; overload;

function ToText(V: TInterfaceMockSpyCheck): PShortString; overload;

function ToText(m: TSQLURIMethod): PShortString; overload;

function ToText(o: TSynTableStatementOperator): PShortString; overload;

function ToText(t: TSQLVirtualTableTransaction): PShortString; overload;



{ ************ Logging classes and functions }



type

  /// logging class with enhanced RTTI

  // - will write TObject/TSQLRecord, enumerations and sets content as JSON

  // - is the default logging family used by the mORMot framework

  // - mORMotDB.pas unit will set SynDBLog := TSQLLog

  // - mORMotSQLite3.pas unit will set SynSQLite3Log := TSQLLog

  TSQLLog = class(TSynLog)

  protected

    procedure CreateLogWriter; override;

  end;



{$ifdef WITHLOG}

var

  /// TSQLLog class is used for logging for all our ORM related functions

  // - this global variable can be used to customize it for the whole process

  // - each TSQLRest.LogClass property is set by default to this SQLite3Log

  // - you can override the TSQLRest.LogClass property value to customize it

  // for a given REST instance

  SQLite3Log: TSynLogClass = TSQLLog;



  /// TSQLogClass used by overriden SetThreadName() function to name the thread 

  SetThreadNameLog: TSynLogClass = TSQLLog; 

{$endif}





implementation



uses

  {$ifdef FPC}

  {$ifndef MSWINDOWS}

  SynFPCLinux,

  BaseUnix,

  Unix,

  dynlibs,

  {$endif}

  {$endif}

  SynCrypto; // for TSQLRecordSigned and authentication





// ************ some RTTI and SQL mapping routines



procedure SetID(P: PUTF8Char; var result: TID);

{$ifdef HASINLINE}

{$ifdef CPU64}

begin // PtrInt is already int64 -> call PtrInt version

  result := GetInteger(P);

{$else}

begin

  {$ifdef VER3_0} // FPC issue woraround

  SetInt64(P,result);

  {$else}

  SetInt64(P,PInt64(@result)^);

  {$endif}

{$endif}

{$else}

asm

  jmp SynCommons.SetInt64

{$endif}

end;



procedure SetID(const U: RawByteString; var result: TID); overload;

{$ifdef HASINLINE}

{$ifdef CPU64}

begin // PtrInt is already int64 -> call PtrInt version

  result := GetInteger(pointer(U));

{$else}

begin

  SetID(pointer(U),result);

{$endif}

{$else}

asm

  jmp SynCommons.SetInt64

{$endif}

end;



{$ifdef HASDIRECTTYPEINFO}

type

  Deref = PTypeInfo;

{$else}

function Deref(Info: PPTypeInfo): PTypeInfo;

{$ifdef HASINLINE} inline;

begin

  if Info=nil then

    result := pointer(Info) else

    result := Info^;

end;

{$else}

asm // Delphi is so bad at compiling above code...

    test eax,eax

    jz @z

    mov eax,[eax]

    ret

@z: db $f3 // rep ret

end;

{$endif HASINLINE}

{$endif HASDIRECTTYPEINFO}





{$ifndef FPC}



type

  /// used to map a TPropInfo.GetProc/SetProc and retrieve its kind

  PropWrap = packed record

    FillBytes: array [0..SizeOf(Pointer)-2] of byte;

    /// = $ff for a field address, or =$fe for a virtual method

    Kind: byte;

  end;

  /// no Rtti alignment under Delphi

  AlignToPtr = pointer;

  UnalignToDouble = Double;



const

  NO_INDEX = Integer($80000000);



{$endif FPC}



function GetInterfaceFromEntry(Instance: TObject; Entry: PInterfaceEntry; out Obj): boolean;

  {$ifndef FPC}

  procedure UseImplGetter(Instance: TObject; ImplGetter: PtrInt; var result: IInterface);

  type // function(Instance: TObject) trick does not work with CPU64 :(

    TGetProc = function: IInterface of object;

  var Call: TMethod;

  begin // sub-procedure to avoid try..finally for TGetProc(): Interface result

    if PropWrap(ImplGetter).Kind=$FE then

      Call.Code := PPointer(PPtrInt(Instance)^+SmallInt(ImplGetter))^ else

      Call.Code := Pointer(ImplGetter);

    Call.Data := Instance;

    result := TGetProc(Call);

  end;

  {$endif}

begin

  Pointer(Obj) := nil;

  if Entry<>nil then

    if Entry^.IOffset <> 0 then begin

      Pointer(Obj) := Pointer(PtrInt(Instance)+Entry^.IOffset);

      if Pointer(Obj)<>nil then

        IInterface(Obj)._AddRef;

    end

  {$ifndef FPC} else

    if PropWrap(Entry^.ImplGetter).Kind=$FF then

      IInterface(Obj) := IInterface(PPointer(PtrUInt(Instance)+PtrUInt(Entry^.ImplGetter and $00FFFFFF))^) else

      UseImplGetter(Instance,Entry^.ImplGetter,IInterface(Obj)){$endif};

  Result := Pointer(Obj)<>nil;

end;



function InternalMethodInfo(aClassType: TClass; const aMethodName: ShortString): PMethodInfo;

var Count, i: integer;

begin

  while aClassType<>nil do begin

    result := PPointer(PtrInt(aClassType)+vmtMethodTable)^;

    if result<>nil then begin

      {$ifdef FPC}

      Count := PCardinal(result)^;

      inc(PCardinal(result));

      {$else}

      Count := PWord(result)^;

      inc(PWord(result));

      {$endif}

      for i := 0 to Count-1 do

      if IdemPropName(result^.Name{$ifdef FPC}^{$endif},aMethodName) then

        Exit else

        {$ifdef FPC}

        inc(result);

        {$else}

        inc(PByte(result),result^.Len);

        {$endif}

    end;

    {$ifdef FPC}

    aClassType := aClassType.ClassParent;

    if aClassType=nil then

    {$else}

    if PPointer(PtrInt(aClassType)+vmtParent)^<>nil then

      aClassType := PPointer(PPointer(PtrInt(aClassType)+vmtParent)^)^ else

    {$endif}

      break;

  end;

  result := nil;

end;



function TMethodInfo.MethodAddr: Pointer;

begin

  if @self<>nil then

    result := Addr else

    result := @self;

end;



function TMethodInfo.ReturnInfo: PReturnInfo;

begin // see http://hallvards.blogspot.fr/2006/09/extended-class-rtti.html

  if @self<>nil then begin

    {$ifdef FPC}

    result := pointer(PtrUInt(@Addr)+sizeof(Pointer));

    {$else}

    result := @Name[ord(Name[0])+1];

    if PtrUInt(result)-PtrUInt(@self)=Len then

      result := nil; // no method details available

    {$endif}

  end else

      result := @self;

end;



function TReturnInfo.Param: PParamInfo;

begin

  result := Pointer(PtrUInt(@self)+sizeof(TReturnInfo));

end;



function TParamInfo.Next: PParamInfo;

begin

  result := AlignToPtr(@Name[ord(Name[0])+1]);

  {$ifdef ISDELPHI2010}

  Inc(PByte(result),PWord(result)^); // attributes

  {$endif}

end;



function InternalClassProp(ClassType: TClass): PClassProp;

{$ifdef FPC}

begin

  with GetFPCTypeData(ClassType.ClassInfo)^ do

    result := AlignToPtr(@UnitName[ord(UnitName[0])+1]);

{$else}

{$ifdef PUREPASCAL}

var PTI: PTypeInfo;

begin // code is a bit abstract, but compiles very well

  PTI := PPointer(PtrInt(ClassType)+vmtTypeInfo)^;

  if PTI<>nil then // avoid GPF if no RTTI available for this class

    with PTI^, PClassType(@Name[ord(Name[0])+1])^ do

      result := PClassProp(@UnitName[ord(UnitName[0])+1]) else

    result := nil;

{$else}

asm // this code is the fastest possible

  mov eax,[eax+vmtTypeInfo]

  test eax,eax; jz @z // avoid GPF if no RTTI available for this class

  movzx edx,byte ptr [eax].TTypeInfo.Name

  lea eax,[eax+edx].TTypeInfo.Name[1]

  movzx edx,byte ptr [eax].TClassType.UnitName

  lea eax,[eax+edx].TClassType.UnitName[1].TClassProp

@z:

{$endif PUREPASCAL}

{$endif FPC}

end;



function InternalClassPropInfo(ClassType: TClass; out PropInfo: PPropInfo): integer;

{$ifdef FPC}

var CP: PClassProp;

{$endif}

begin

  if ClassType<>nil then begin

    {$ifdef FPC}

    CP := InternalClassProp(ClassType);

    if CP<>nil then begin // no more RTTI information available

      PropInfo := AlignToPtr(@CP^.PropList);

      result := CP^.PropCount;

    {$else} // code is a bit abstract, but compiles very well for Delphi/Kylix

    inc(PByte(ClassType),vmtTypeInfo);

    if PPointer(ClassType)^<>nil then // avoid GPF if no RTTI available

      with PTypeInfo(PPointer(ClassType)^)^, PClassType(@Name[ord(Name[0])+1])^,

        PClassProp(@UnitName[ord(UnitName[0])+1])^ do begin

      PropInfo := @PropList;

      result := PropCount;

    {$endif}

      exit;

    end;

  end;

  result := 0;

end;



function ClassFieldCountWithParents(ClassType: TClass;

  onlyWithoutGetter: boolean): integer;

var CP: PClassProp;

    P: PPropInfo;

    i: integer;

begin

  result := 0;

  while ClassType<>nil do begin

    CP := InternalClassProp(ClassType);

    if CP=nil then

      break; // no RTTI information (e.g. reached TObject level)

    if onlyWithoutGetter then begin

      P := AlignToPtr(@CP^.PropList);

      for i := 1 to CP^.PropCount do begin

        if P^.GetterIsField then

          inc(result);

        P := P^.Next;

      end;

    end else

      inc(result,CP^.PropCount);

    ClassType := ClassType.ClassParent;

  end;

end;



function ClassHasPublishedFields(ClassType: TClass): boolean;

var CP: PClassProp;

begin

  while ClassType<>nil do begin

    CP := InternalClassProp(ClassType);

    if CP=nil then

      break; // no RTTI information (e.g. reached TObject level)

    if CP^.PropCount>0 then begin

      result := true;

      exit;

    end;

    ClassType := ClassType.ClassParent;

  end;

  result := false;

end;



function ClassHierarchyWithField(ClassType: TClass): TClassDynArray;

procedure InternalAdd(C: TClass; var list: TClassDynArray);

var P: PClassProp;

begin

  if C=nil then

    exit;

  InternalAdd(C.ClassParent,list);

  P := InternalClassProp(C);

  if (P<>nil) and (P^.PropCount>0) then

    ObjArrayAdd(list,pointer(C));

end;

begin

  result := nil;

  InternalAdd(ClassType,result);

end;



function ClassFieldAllProps(ClassType: TClass; Types: TTypeKinds): PPropInfoDynArray;

var CP: PClassProp;

    P: PPropInfo;

    i,n: integer;

begin

  n := 0;

  result := nil;

  while ClassType<>nil do begin

    CP := InternalClassProp(ClassType);

    if CP=nil then

      break; // no RTTI information (e.g. reached TObject level)

    if CP^.PropCount>0 then begin

      SetLength(result,n+CP^.PropCount);

      P := AlignToPtr(@CP^.PropList);

      for i := 1 to CP^.PropCount do begin

        if P^.PropType^.Kind in Types then begin

          result[n] := P;

          inc(n);

        end;

        {$ifdef HASINLINE}

        P := P^.Next;

        {$else}

        with P^ do P := @Name[ord(Name[0])+1];

        {$endif}

      end;

    end;

    ClassType := ClassType.ClassParent;

  end;

  SetLength(result,n);

end;



function ClassFieldNamesAllProps(ClassType: TClass; IncludePropType: boolean;

  Types: TTypeKinds): TRawUTF8DynArray;

var props: PPropInfoDynArray;

    n,i: integer;

begin

  props := ClassFieldAllProps(ClassType,Types);

  n := length(props);

  SetLength(result,n);

  for i := 0 to n-1 do

    if IncludePropType then

      FormatUTF8('%: %',[props[i]^.Name,props[i]^.PropType^.Name],result[i]) else

      ShortStringToAnsi7String(props[i]^.Name,result[i]);

end;



function ClassFieldNamesAllPropsAsText(ClassType: TClass; IncludePropType: boolean;

  Types: TTypeKinds): RawUTF8;

begin

  result := RawUTF8ArrayToCSV(

    ClassFieldNamesAllProps(ClassType,IncludePropType,Types),', ');

end;



function ClassFieldProp(ClassType: TClass; const PropName: shortstring): PPropInfo;

begin

  if ClassType<>nil then

    result := InternalClassProp(ClassType)^.FieldProp(PropName) else

    result := nil;

end;



function ClassFieldPropWithParents(aClassType: TClass; const PropName: shortstring): PPropInfo;

var i: integer;

begin

  while aClassType<>nil do begin

    for i := 1 to InternalClassPropInfo(aClassType,result) do

      if (result^.Name[0]=PropName[0]) and

         IdemPropNameUSameLen(@result^.Name[1],@PropName[1],ord(PropName[0])) then

        exit else

        {$ifdef HASINLINE}

        result := result^.Next;

        {$else}

        with result^ do result := @Name[ord(Name[0])+1];

        {$endif}

    aClassType := aClassType.ClassParent;

  end;

  result := nil;

end;



function ClassFieldPropWithParentsFromUTF8(aClassType: TClass; PropName: PUTF8Char;

  PropNameLen: integer): PPropInfo;

{$ifndef FPC}

var i: integer;

{$endif}

begin

  {$ifdef FPC}

  result := pointer(GetFPCPropInfo(aClassType,PropName));

  {$else}

  while (PropNameLen<>0) and (aClassType<>nil) do begin

    for i := 1 to InternalClassPropInfo(aClassType,result) do

      if IdemPropName(result^.Name,PropName,PropNameLen) then

        exit else

        result := result^.Next;

    aClassType := aClassType.ClassParent;

  end;

  result := nil;

  {$endif}

end;



function ClassFieldPropWithParentsFromClassType(aClassType,aSearchedClassType: TClass): PPropInfo;

var i: integer;

begin

  if aSearchedClassType<>nil then

  while aClassType<>nil do begin

    for i := 1 to InternalClassPropInfo(aClassType,result) do

      if (result^.PropType^.Kind=tkClass) and

         (result^.PropType^.ClassType^.ClassType=aSearchedClassType) then

        exit else

        result := result^.Next;

    aClassType := aClassType.ClassParent;

  end;

  result := nil;

end;



function ClassFieldInstance(Instance: TObject; const PropName: shortstring;

  PropClassType: TClass; out PropInstance): boolean;

var P: PPropInfo;

begin

  result := false;

  if Instance=nil then

    exit;

  P := ClassFieldPropWithParents(Instance.ClassType,PropName);

  if (P=nil) or (P^.PropType^.Kind<>tkClass) or

     not P^.PropType^.InheritsFrom(PropClassType) then

    exit;

  TObject(PropInstance) := P^.GetObjProp(Instance);

  result := true;

end;



function ClassFieldInstance(Instance: TObject; PropClassType: TClass;

  out PropInstance): boolean; overload;

var P: PPropInfo;

begin

  result := false;

  if Instance=nil then

    exit;

  P := ClassFieldPropWithParentsFromClassType(Instance.ClassType,PropClassType);

  if P=nil then

    exit;

  TObject(PropInstance) := P^.GetObjProp(Instance);

  result := true;

end;



function GetObjectComponent(Obj: TPersistent; const ComponentName: shortstring;

  ComponentClass: TClass): pointer;

var P: PPropInfo;

begin

  result := nil;

  if Obj=nil then

    exit;

  P := ClassFieldPropWithParents(Obj.ClassType,ComponentName);

  if (P<>nil) and (P^.PropType^.Kind=tkClass) then

    if P^.PropType^.InheritsFrom(ComponentClass) then

      result := P^.GetObjProp(Obj);

end;



function GetEnumCaption(aTypeInfo: PTypeInfo; const aIndex): string;

begin

  if (aTypeInfo=nil) or (aTypeInfo^.Kind<>tkEnumeration) then

    result := '' else

    result := aTypeInfo^.EnumBaseType^.GetCaption(PByte(@aIndex)^);

end;



function GetEnumNameTrimed(aTypeInfo: PTypeInfo; const aIndex): RawUTF8;

begin

  if (aTypeInfo=nil) or (aTypeInfo^.Kind<>tkEnumeration) then

    result := '' else

    result := aTypeInfo^.EnumBaseType^.GetEnumNameTrimed(aIndex);

end;



function GetSetNameCSV(aTypeInfo: PTypeInfo; const aValue): RawUTF8;

begin

  if (aTypeInfo=nil) or (aTypeInfo^.Kind<>tkSet) then

    result := '' else

    result := aTypeInfo^.SetEnumType^.GetSetNameCSV(integer(aValue));

end;



function DocVariantToObject(var doc: TDocVariantData; obj: TObject): boolean;

var p: integer;

    prop: PPropInfo;

begin

  if (doc.Kind=dvObject) and (doc.Count>0) and (obj<>nil) then begin

    for p := 0 to doc.Count-1 do begin

      prop := ClassFieldPropWithParentsFromUTF8(

        PPointer(obj)^,pointer(doc.Names[p]),length(doc.Names[p]));

      if prop<>nil then

        prop^.SetFromVariant(obj,doc.Values[p]);

    end;

    result := true;

  end else

    result := false;

end;



procedure DocVariantToObjArray(var arr: TDocVariantData; var objArray;

  objClass: TClass);

var instance: TClassInstance;

begin

  instance.Init(objClass);

  DocVariantToObjArray(arr,objArray,@instance);

end;



procedure DocVariantToObjArray(var arr: TDocVariantData; var objArray;

  objClass: PClassInstance);

var i: integer;

    obj: TObjectDynArray absolute objArray;

begin

  if objClass=nil then

    exit;

  ObjArrayClear(obj);

  if (arr.Kind<>dvArray) or (arr.Count=0) then

    exit;

  SetLength(obj,arr.Count);

  for i := 0 to arr.Count-1 do begin

    obj[i] := objClass^.CreateNew;

    DocVariantToObject(_Safe(arr.Values[i])^,obj[i]);

  end;

end;





type // those classes will be used to register globally some classes for JSON

  TJSONSerializerRegisteredClassAbstract = class(TList)

  protected

    fLastClass: TClass;

    fSafe: TSynLocker;

  public

    constructor Create;

    destructor Destroy; override;

  end;



  TJSONSerializerRegisteredClass = class(TJSONSerializerRegisteredClassAbstract)

  protected

  public

    procedure AddOnce(aItemClass: TClass);

    function Find(JSON: PUTF8Char; AndRegisterClass: boolean): TClass; overload;

    function Find(aClassName: PUTF8Char; aClassNameLen: integer): TClass; overload;

  end;



var

  JSONSerializerRegisteredClass: TJSONSerializerRegisteredClass=nil;





{ TSQLPropInfo }



const

  NULL_SHORTSTRING: string[1] = '';



function TSQLPropInfo.GetSQLFieldTypeName: PShortString;

begin

  if self=nil then

    result := @NULL_SHORTSTRING else

    result := ToText(fSQLFieldType);

end;



function TSQLPropInfo.GetSQLFieldRTTITypeName: RawUTF8;

begin

  result := GetDisplayNameFromClass(ClassType);

  if IdemPChar(pointer(result),'PROPINFO') then

    delete(result,1,8);

end;



function TSQLPropInfo.GetNameDisplay: string;

begin

  GetCaptionFromPCharLen(pointer(fName),result);

end;



procedure TSQLPropInfo.TextToBinary(Value: PUTF8Char; var result: RawByteString);

begin

  result := BlobToTSQLRawBlob(Value);

end;



procedure TSQLPropInfo.BinaryToText(var Value: RawUTF8; ToSQL: boolean;

  wasSQLString: PBoolean);

begin

  if Value='' then begin

    if wasSQLString<>nil then

      wasSQLString^ := false;

    Value := 'null';

  end else begin

    if wasSQLString<>nil then

      wasSQLString^ := true;

    if ToSQL then

      // encode as BLOB literals (e.g. "X'53514C697465'")

      Value := TSQLRawBlobToBlob(TSQLRawBlob(Value)) else

      // JSON content is e.g. '\uFFF0base64encodedbinary'

      Value := BinToBase64WithMagic(Value);

  end;

end;



{$ifndef NOVARIANTS}

function NullableTypeToSQLFieldType(aType: pointer): TSQLFieldType;

begin

  if aType<>nil then

    if aType<>TypeInfo(TNullableInteger) then

      if aType<>TypeInfo(TNullableUTF8Text) then

        if aType<>TypeInfo(TNullableBoolean) then

          if aType<>TypeInfo(TNullableFloat) then

            if aType<>TypeInfo(TNullableCurrency) then

              if aType<>TypeInfo(TNullableDateTime) then

                if aType<>TypeInfo(TNullableTimeLog) then begin

                  result := sftUnknown;

                  exit;

                end else

                result := sftTimeLog else

              result := sftDateTime else

            result := sftCurrency else

          result := sftFloat else

        result := sftBoolean else

      result := sftUTF8Text else

    result := sftInteger else

  result := sftUnknown;

end;

{$endif}



const

  SQLFIELDTYPETODBFIELDTYPE: array[TSQLFieldType] of TSQLDBFieldType =

    (ftUnknown,   // sftUnknown

     ftUTF8,      // sftAnsiText

     ftUTF8,      // sftUTF8Text

     ftInt64,     // sftEnumerate

     ftInt64,     // sftSet

     ftInt64,     // sftInteger

     ftInt64,     // sftID = TSQLRecord(aID)

     ftInt64,     // sftRecord = TRecordReference = RecordRef

     ftInt64,     // sftBoolean

     ftDouble,    // sftFloat

     ftDate,      // sftDateTime

     ftInt64,     // sftTimeLog

     ftCurrency,  // sftCurrency

     ftUTF8,      // sftObject

{$ifndef NOVARIANTS}

     ftUTF8,      // sftVariant

     ftNull,      // sftNullable

{$endif}

     ftBlob,      // sftBlob

     ftBlob,      // sftBlobDynArray

     ftBlob,      // sftBlobCustom

     ftUTF8,      // sftUTF8Custom

     ftUnknown,   // sftMany

     ftInt64,     // sftModTime

     ftInt64,     // sftCreateTime

     ftInt64,     // sftTID

     ftInt64,     // sftRecordVersion = TRecordVersion

     ftInt64);    // sftSessionUserID



function SQLFieldTypeToDBField(aSQLFieldType: TSQLFieldType; aTypeInfo: pointer): TSQLDBFieldType;

  {$ifdef HASINLINE}inline;{$endif}

begin

  {$ifndef NOVARIANTS}

  if aSQLFieldType=sftNullable then

    result := SQLFIELDTYPETODBFIELDTYPE[NullableTypeToSQLFieldType(aTypeInfo)] else

  {$endif}

    result := SQLFIELDTYPETODBFIELDTYPE[aSqlFieldType];

end;



constructor TSQLPropInfo.Create(const aName: RawUTF8; aSQLFieldType: TSQLFieldType;

  aAttributes: TSQLPropInfoAttributes; aFieldWidth, aPropertyIndex: integer);

begin

  if aName='' then

    EORMException.CreateUTF8('Void name for %.Create',[self]);

  fName := aName;

  fNameUnflattened := aName;

  fSQLFieldType := aSQLFieldType;

  fSQLFieldTypeStored := aSQLFieldType;

  fSQLDBFieldType := SQLFIELDTYPETODBFIELDTYPE[fSQLFieldTypeStored];

  fAttributes := aAttributes;

  fFieldWidth := aFieldWidth;

  fPropertyIndex := aPropertyIndex;

end;



function TSQLPropInfo.GetHash(Instance: TObject; CaseInsensitive: boolean): cardinal;

var tmp: RawUTF8;

begin

  GetValueVar(Instance,false,tmp,nil);

  result := crc32c(0,pointer(tmp),length(tmp));

end;



procedure TSQLPropInfo.GetJSONValues(Instance: TObject; W: TJSONSerializer);

var wasString: boolean;

    tmp: RawUTF8;

begin

  GetValueVar(Instance,false,tmp,@wasString);

  if wasString then begin

    W.Add('"');

    if PtrUInt(tmp)<>0 then

      W.AddJSONEscape(pointer(tmp),

        {$ifdef FPC}length(tmp){$else}PInteger(PtrUInt(tmp)-4)^{$endif});

    W.Add('"');

  end else

    if PtrUInt(tmp)<>0 then

      W.AddNoJSONEscape(pointer(tmp),

        {$ifdef FPC}length(tmp){$else}PInteger(PtrUInt(tmp)-4)^{$endif});

end;



function TSQLPropInfo.GetValue(Instance: TObject; ToSQL: boolean;

  wasSQLString: PBoolean): RawUTF8;

begin

  GetValueVar(Instance,ToSQL,Result,wasSQLString);

end;



procedure TSQLPropInfo.SetValueVar(Instance: TObject; const Value: RawUTF8; wasString: boolean);

begin

  SetValue(Instance,pointer(Value),wasString);

end;



function TSQLPropInfo.SQLDBFieldTypeName: PShortString;

begin

  result := ToText(fSQLDBFieldType);

end;



procedure TSQLPropInfo.GetFieldSQLVar(Instance: TObject; var aValue: TSQLVar;

  var temp: RawByteString);

begin

  GetValueVar(Instance,true,RawUTF8(temp),nil);

  aValue.VType := fSQLDBFieldType;

  case aValue.VType of

    ftInt64:

      SetInt64(pointer(temp),aValue.VInt64);

    ftCurrency:

      aValue.VInt64 := StrToCurr64(pointer(temp));

    ftDouble:

      aValue.VDouble := GetExtended(pointer(temp));

    ftDate:

      aValue.VDateTime := Iso8601ToDateTime(temp);

    ftBlob: begin

      temp := BlobToTSQLRawBlob(temp);

      aValue.VBlob := pointer(temp);

      aValue.VBlobLen := length(temp);

    end;

    ftUTF8:

      aValue.VText := pointer(temp);

    else

      aValue.VInt64 := 0;

  end;

end;



function TSQLPropInfo.SetFieldSQLVar(Instance: TObject; const aValue: TSQLVar): boolean;

begin

  case aValue.VType of

    ftInt64:

      SetValueVar(Instance,Int64ToUtf8(aValue.VInt64),false);

    ftCurrency:

      SetValueVar(Instance,Curr64ToStr(aValue.VInt64),false);

    ftDouble:

      SetValueVar(Instance,DoubleToStr(aValue.VDouble),false);

    ftDate:

      SetValueVar(Instance,DateTimeToIso8601Text(aValue.VDateTime),true);

    ftBlob:

      SetValueVar(Instance,TSQLRawBlobToBlob(aValue.VBlob,aValue.VBlobLen),true);

    ftUTF8:

      SetValue(Instance,aValue.VText,true);

    else

      SetValue(Instance,nil,false);

  end;

  result := true;

end;



const

  NULL_LOW = ord('n')+ord('u')shl 8+ord('l')shl 16+ord('l')shl 24;

  FALSE_LOW = ord('f')+ord('a')shl 8+ord('l')shl 16+ord('s')shl 24;

  TRUE_LOW  = ord('t')+ord('r')shl 8+ord('u')shl 16+ord('e')shl 24;



{$ifndef NOVARIANTS}

procedure ValueVarToVariant(Value: PUTF8Char; fieldType: TSQLFieldType;

  var result: TVarData; createValueTempCopy: boolean; typeInfo: pointer;

  options: TDocVariantOptions);

const

  /// map our available types for any SQL field property into variant values

  // - varNull will be used to store a true variant instance from JSON

  SQL_ELEMENTTYPES: array[TSQLFieldType] of word = (

 // sftUnknown, sftAnsiText, sftUTF8Text, sftEnumerate, sftSet,   sftInteger,

    varEmpty,    varString,  varString,   varInteger,   varInt64, varInt64,

 // sftID, sftRecord, sftBoolean, sftFloat, sftDateTime, sftTimeLog, sftCurrency,

    varInt64,varInt64,varBoolean, varDouble, varDate,    varInt64,   varCurrency,

 //sftObject,{$NOVARIANTS}sftVariant,sftNullable{$endif} sftBlob,sftBlobDynArray,

    varNull,{$ifndef NOVARIANTS} varNull, varNull, {$endif} varString, varNull,

 // sftBlobCustom, sftUTF8Custom, sftMany, sftModTime, sftCreateTime, sftTID,

    varString,      varString,    varEmpty, varInt64,  varInt64,     varInt64,

 // sftRecordVersion, sftSessionUserID

    varInt64, varInt64);

var tempCopy: RawByteString;

    err: integer;

begin

  if result.VType and VTYPE_STATIC<>0 then

    VarClear(variant(result));

  result.VType := SQL_ELEMENTTYPES[fieldType];

  case fieldType of

  sftCurrency:

    result.VInt64 := StrToCurr64(Value);

  sftFloat: begin

    result.VDouble := GetExtended(Value,err);

    if err<>0 then begin

      result.VType := varString;

      result.VAny := nil; // avoid GPF

      RawUTF8(result.VAny) := Value;

    end;

  end;

  sftDateTime:

    result.VDate := Iso8601ToDateTimePUTF8Char(Value,0);

  sftBoolean:

    result.VBoolean :=

      not((Value=nil) or (PWord(Value)^=ord('0')) or (PInteger(Value)^=FALSE_LOW));

  sftEnumerate:

    result.VInteger := GetInteger(Value);

  sftInteger, sftID, sftTID, sftRecord, sftSet, sftRecordVersion, sftSessionUserID,

  sftTimeLog, sftModTime, sftCreateTime:

    SetInt64(Value,result.VInt64);

  sftAnsiText, sftUTF8Text: begin

    pointer(result.VAny) := nil;

    RawUTF8(result.VAny) := Value;

  end;

  sftBlobCustom, sftBlob: begin

    pointer(result.VAny) := nil;

    RawByteString(result.VAny) := BlobToTSQLRawBlob(Value);

  end;

  sftBlobDynArray, sftObject, sftVariant, sftUTF8Custom, sftNullable: begin

    if (fieldType=sftBlobDynArray) and (typeInfo<>nil) and

       (Value<>nil) and (Value^<>'[') then begin

      tempCopy := BlobToTSQLRawBlob(Value);

      if tempCopy<>'' then begin

        Value := pointer(DynArraySaveJSON(typeInfo,tempCopy));

        createValueTempCopy := false;

      end;

    end;

    if createValueTempCopy then begin

      SetString(tempCopy,PAnsiChar(Value),StrLen(Value));

      Value := pointer(tempCopy);

    end;

    GetVariantFromJSON(Value,false,variant(result),@options);

  end;

  end;

end;



function ObjectLoadVariant(var ObjectInstance; const aDocVariant: variant;

  TObjectListItemClass: TClass=nil; Options: TJSONToObjectOptions=[]): boolean;

var tmp: RawUTF8;

begin

  if _Safe(aDocVariant)^.Kind<>dvObject then

    result := false else begin

    VariantSaveJSON(aDocVariant,twJSONEscape,tmp);

    JSONToObject(ObjectInstance,pointer(tmp),result,TObjectListItemClass,Options);

  end;

end;



procedure TSQLPropInfo.GetVariant(Instance: TObject; var Dest: Variant);

var temp: RawUTF8;

begin

  GetValueVar(Instance,true,temp,nil);

  ValueVarToVariant(pointer(temp),fSQLFieldTypeStored,TVarData(Dest),false,nil);

end;



procedure TSQLPropInfo.SetVariant(Instance: TObject; const Source: Variant);

begin

  SetValueVar(Instance,VariantToUTF8(Source),TVarData(Source).VType and VTYPE_STATIC<>0);

end;



{$endif NOVARIANTS}



function TSQLPropInfo.CompareValue(Item1, Item2: TObject; CaseInsensitive: boolean): PtrInt;

var tmp1,tmp2: RawUTF8;

begin

  if Item1=Item2 then

    result := 0 else

  if Item1=nil then

    result := -1 else

  if Item2=nil then

    result := 1 else begin

    GetValueVar(Item1,false,tmp1,nil);

    GetValueVar(Item2,false,tmp2,nil);

    if CaseInsensitive then // slow, always working implementation

      result := StrIComp(pointer(tmp1),pointer(tmp2)) else

      result := StrComp(pointer(tmp1),pointer(tmp2));

  end;

end;



procedure TSQLPropInfo.CopyProp(Source: TObject; DestInfo: TSQLPropInfo; Dest: TObject);



  procedure GenericCopy;

  var tmp: RawUTF8;

      wasString: boolean;

  begin

    GetValueVar(Source,false,tmp,@wasString);

    DestInfo.SetValueVar(Dest,tmp,wasString);

  end;



var i: integer;

begin

  if (Source=nil) or (DestInfo=nil) or (Dest=nil) then

    exit; // avoid GPF

  with TSQLPropInfoRTTI(self) do

    if fFromRTTI and (fFlattenedProps<>nil) then

    for i := 0 to length(fFlattenedProps)-1 do

      Source := fFlattenedProps[i].GetObjProp(Source);

  with TSQLPropInfoRTTI(DestInfo) do

    if fFromRTTI and (fFlattenedProps<>nil) then

    for i := 0 to length(fFlattenedProps)-1 do

      Dest := fFlattenedProps[i].GetObjProp(Dest);

  if DestInfo.ClassType=ClassType then

    CopySameClassProp(Source,DestInfo,Dest) else

    GenericCopy;

end;



procedure TSQLPropInfo.CopyValue(Source, Dest: TObject);

begin

  CopySameClassProp(Source,self,Dest);

end;



procedure TSQLPropInfo.CopySameClassProp(Source: TObject; DestInfo: TSQLPropInfo;

  Dest: TObject);

var tmp: RawUTF8;

    wasString: boolean;

begin

  GetValueVar(Source,false,tmp,@wasString);

  DestInfo.SetValueVar(Dest,tmp,wasString);

end;





{ TSQLPropInfoRTTI }



class function TSQLPropInfoRTTI.CreateFrom(aPropInfo: PPropInfo; aPropIndex: integer;

  aOptions: TSQLPropInfoListOptions; const aFlattenedProps: PPropInfoDynArray): TSQLPropInfo;

var aSQLFieldType: TSQLFieldType;

    aType: PTypeInfo;

    C: TSQLPropInfoRTTIClass;

procedure FlattenedPropNameSet;

var i,max: Integer;

begin // Address.Street1 -> Address_Street1

  (result as TSQLPropInfoRTTI).fFlattenedProps := aFlattenedProps;

  result.fNameUnflattened := result.fName;

  max := high(aFlattenedProps);

  for i := max downto 0 do

    result.fNameUnflattened := ToUTF8(aFlattenedProps[i]^.Name)+'.'+result.fNameUnflattened;

  if (max>=0) and (aFlattenedProps[max]^.PropType^.

     ClassFieldCount(pilIgnoreIfGetter in aOptions)=1) then begin

    // Birth.Date -> Birth or Address.Country.Iso -> Address_Country

    result.fName := ToUTF8(aFlattenedProps[max]^.Name);

    dec(max);

  end;

  for i := max downto 0 do

    result.fName := ToUTF8(aFlattenedProps[i]^.Name)+'_'+result.fName;

end;

begin

  if aPropInfo=nil then

    raise EORMException.CreateUTF8('Invalid %.CreateFrom(nil) call',[self]);

  result := nil;

  aSQLFieldType := sftUnknown;

  aType := aPropInfo^.TypeInfo;

  {$ifndef NOVARIANTS}

  if aType^.Kind=tkVariant then begin

    aSQLFieldType := NullableTypeToSQLFieldType(aType);

    if aSQLFieldType<>sftUnknown then // handle sftNullable type

      result := TSQLPropInfoRTTIVariant.Create(aPropInfo,aPropIndex,aSQLFieldType);

  end;

  {$endif}

  if result=nil then begin

    aSQLFieldType := aType^.GetSQLFieldType;

    C := nil;

    case aSQLFieldType of

      sftUnknown, sftBlobCustom:

        ; // will raise an EORMException

      sftBoolean, sftEnumerate:

        C := TSQLPropInfoRTTIEnum;

      sftTimeLog, sftModTime, sftCreateTime: // specific class for further use

        C := TSQLPropInfoRTTITimeLog;

      sftCurrency:

        C := TSQLPropInfoRTTICurrency;

      sftDateTime:

        C := TSQLPropInfoRTTIDateTime;

      sftID: // = TSQLRecord(aID)

        C := TSQLPropInfoRTTIID;

      sftTID: // = TID or T*ID

        C := TSQLPropInfoRTTITID;

      sftSessionUserID:

        C := TSQLPropInfoRTTIInt64;

      sftRecord: // = TRecordReference/TRecordReferenceToBeDeleted

        C := TSQLPropInfoRTTIRecordReference;

      sftRecordVersion:

        C := TSQLPropInfoRTTIRecordVersion;

      sftMany:

        C := TSQLPropInfoRTTIMany;

      sftObject:

        C := TSQLPropInfoRTTIObject;

      {$ifndef NOVARIANTS}

      sftVariant:

        C := TSQLPropInfoRTTIVariant;  // sftNullable already handle above

      {$endif}

      sftBlob:

        C := TSQLPropInfoRTTIRawBlob;

      sftBlobDynArray:

        C := TSQLPropInfoRTTIDynArray;

      sftUTF8Custom: // will happen only for DELPHI XE5 and up

        result := TSQLPropInfoCustomJSON.Create(aPropInfo,aPropIndex);

      else

      case aType^.Kind of // retrieve exact type at binary level

        tkInteger:

          C := TSQLPropInfoRTTIInt32;

        tkSet:

          C := TSQLPropInfoRTTISet;

        tkChar, tkWChar:

          C := TSQLPropInfoRTTIChar;

        tkInt64 {$ifdef FPC}, tkQWord{$endif}:

          C := TSQLPropInfoRTTIInt64;

        tkFloat:

          if aType^.FloatType=ftDoub then

            C := TSQLPropInfoRTTIDouble;

        tkLString {$ifdef FPC},tkAString{$endif}:

          case aType^.AnsiStringCodePage of // recognize optimized UTF-8/UTF-16

            CP_UTF8:  C := TSQLPropInfoRTTIRawUTF8;

            CP_UTF16: C := TSQLPropInfoRTTIRawUnicode;

            else C := TSQLPropInfoRTTIAnsi; // will use the right TSynAnsiConvert

          end;

        {$ifdef HASVARUSTRING}

        tkUString:

          C := TSQLPropInfoRTTIUnicode;

        {$endif}

        tkWString:

          C := TSQLPropInfoRTTIWide;

      end;

    end;

    if C<>nil then

      result := C.Create(aPropInfo,aPropIndex,aSQLFieldType);

  end;

  if result<>nil then begin

    if aFlattenedProps<>nil then

      FlattenedPropNameSet;

  end else

    if pilRaiseEORMExceptionIfNotHandled in aOptions then

      raise EORMException.CreateUTF8('%.CreateFrom: Unhandled %/% type for property %',

        [self,ToText(aSQLFieldType)^,ToText(aType^.Kind)^,aPropInfo^.Name]);

end;



function TSQLPropInfoRTTI.GetSQLFieldRTTITypeName: RawUTF8;

begin

  result := ToUTF8(fPropType^.Name);

end;



function TSQLPropInfoRTTI.GetFieldAddr(Instance: TObject): pointer;

begin

  if Instance=nil then

    result := nil else

    result := fPropInfo^.GetFieldAddr(Instance);

end;



function TSQLPropInfoRTTI.Flattened(Instance: TObject): TObject;

var i: integer;

begin

  result := Instance;

  for i := 0 to length(fFlattenedProps)-1 do

    result := fFlattenedProps[i].GetObjProp(result);

end;



{$ifndef NOVARIANTS}

procedure TSQLPropInfoRTTI.GetVariant(Instance: TObject; var Dest: Variant);

var temp: RawUTF8;

begin

  GetValueVar(Instance,true,temp,nil);

  ValueVarToVariant(pointer(temp),fSQLFieldTypeStored,TVarData(Dest),false,fPropInfo);

end;

{$endif NOVARIANTS}



constructor TSQLPropInfoRTTI.Create(aPropInfo: PPropInfo; aPropIndex: integer;

  aSQLFieldType: TSQLFieldType);

var attrib: TSQLPropInfoAttributes;

begin

  byte(attrib) := 0;

  if aPropInfo^.IsStored(nil)=AS_UNIQUE then

    Include(attrib,aIsUnique); // property MyProperty: RawUTF8 stored AS_UNIQUE;

  inherited Create(ToUTF8(aPropInfo^.Name),aSQLFieldType,attrib,

    aPropInfo^.Index,aPropIndex); // property MyProperty: RawUTF8 index 10; -> FieldWidth=10

  fPropInfo := aPropInfo;

  fPropType := aPropInfo^.TypeInfo;

  if aPropInfo.GetterIsField then begin

    fGetterIsFieldPropOffset := aPropInfo.GetProc{$ifndef FPC} and $00FFFFFF{$endif};

    if (aPropInfo.SetProc=0) or (aPropInfo.SetProc=fPropInfo.GetProc) then

      fInPlaceCopySameClassPropOffset := fGetterIsFieldPropOffset;

  end;

  fFromRTTI := true;

end;





{ TSQLPropInfoRTTIInt32 }



procedure TSQLPropInfoRTTIInt32.CopySameClassProp(Source: TObject; DestInfo: TSQLPropInfo;

  Dest: TObject);

begin

  TSQLPropInfoRTTIInt32(DestInfo).fPropInfo.SetOrdProp(Dest,fPropInfo.GetOrdProp(Source));

end;



procedure TSQLPropInfoRTTIInt32.GetBinary(Instance: TObject; W: TFileBufferWriter);

begin

   W.WriteVarUInt32(cardinal(fPropInfo.GetOrdProp(Instance)));

end;



function TSQLPropInfoRTTIInt32.GetHash(Instance: TObject; CaseInsensitive: boolean): cardinal;

begin

  result := fPropInfo.GetOrdProp(Instance);

end;



procedure TSQLPropInfoRTTIInt32.GetJSONValues(Instance: TObject; W: TJSONSerializer);

begin

  W.Add(fPropInfo.GetOrdProp(Instance));

end;



procedure TSQLPropInfoRTTIInt32.GetValueVar(Instance: TObject;

  ToSQL: boolean; var result: RawUTF8; wasSQLString: PBoolean);

begin

  if wasSQLString<>nil then

    wasSQLString^ := false;

  Int32ToUtf8(fPropInfo.GetOrdProp(Instance),result);

end;



procedure TSQLPropInfoRTTIInt32.NormalizeValue(var Value: RawUTF8);

var err, VInt: integer;

begin

  VInt := GetInteger(pointer(Value),err);

  if err<>0 then

    Value := '' else

    Int32ToUtf8(VInt,Value);

end;



function TSQLPropInfoRTTIInt32.CompareValue(Item1, Item2: TObject; CaseInsensitive: boolean): PtrInt;

begin

  if Item1=Item2 then

    result := 0 else

  if Item1=nil then

    result := -1 else

  if Item2=nil then

    result := 1 else

    result := fPropInfo.GetOrdProp(Item1)-fPropInfo.GetOrdProp(Item2);

end;



function TSQLPropInfoRTTIInt32.SetBinary(Instance: TObject; P: PAnsiChar): PAnsiChar;

begin

  if P<>nil then

    fPropInfo.SetOrdProp(Instance,integer(FromVarUInt32(PByte(P))));

  result := P;

end;



procedure TSQLPropInfoRTTIInt32.SetValue(Instance: TObject; Value: PUTF8Char;

  wasString: boolean);

begin

  fPropInfo.SetOrdProp(Instance,GetInteger(Value));

end;



function TSQLPropInfoRTTIInt32.SetFieldSQLVar(Instance: TObject; const aValue: TSQLVar): boolean;

begin

  if aValue.VType=ftInt64 then begin

    fPropInfo.SetOrdProp(Instance,aValue.VInt64);

    result := true;

  end else

    result := inherited SetFieldSQLVar(Instance,aValue);

end;



procedure TSQLPropInfoRTTIInt32.GetFieldSQLVar(Instance: TObject; var aValue: TSQLVar;

  var temp: RawByteString);

begin

  aValue.VType := ftInt64;

  aValue.VInt64 := fPropInfo.GetOrdProp(Instance);

end;





{ TSQLPropInfoRTTISet }



constructor TSQLPropInfoRTTISet.Create(aPropInfo: PPropInfo; aPropIndex: integer;

  aSQLFieldType: TSQLFieldType);

begin

  inherited;

  fSetEnumType := fPropType^.SetEnumType;

end;





{ TSQLPropInfoRTTIEnum }



constructor TSQLPropInfoRTTIEnum.Create(aPropInfo: PPropInfo; aPropIndex: integer;

  aSQLFieldType: TSQLFieldType);

begin

  inherited;

  fEnumType := fPropType^.EnumBaseType;

end;



procedure TSQLPropInfoRTTIEnum.GetJSONValues(Instance: TObject; W: TJSONSerializer);

var i: integer;

begin

  i := fPropInfo.GetOrdProp(Instance);

  if fSQLFieldType=sftBoolean then

    W.Add(i<>0) else

    W.Add(i);

end;



function TSQLPropInfoRTTIEnum.GetCaption(Value: RawUTF8; out IntValue: integer): string;

begin

  NormalizeValue(Value);

  IntValue := GetInteger(pointer(Value));

  if Value='' then

    result := '' else

    result := EnumType^.GetCaption(IntValue);

end;



procedure TSQLPropInfoRTTIEnum.GetValueVar(Instance: TObject;

  ToSQL: boolean; var result: RawUTF8; wasSQLString: PBoolean);

var i: integer;

begin

  if wasSQLString<>nil then

    wasSQLString^ := false;

  i := fPropInfo.GetOrdProp(Instance);

  if (fSQLFieldType=sftBoolean) and not ToSQL then

    JSONBoolean(i<>0,result) else

    Int32ToUtf8(i,result);

end;



procedure TSQLPropInfoRTTIEnum.NormalizeValue(var Value: RawUTF8);

var i,err: integer;

begin

  i := GetInteger(pointer(Value),err);

  if err<>0 then  // we allow a value stated as text

    if fSQLFieldType=sftBoolean then

      i := Ord(IdemPropNameU(Value,'TRUE') or IdemPropNameU(Value,'YES')) else

      i := fEnumType^.GetEnumNameValue(pointer(Value),length(Value)) else

    if fSQLFieldType=sftBoolean then // normalize boolean values range to 0,1

      if i<>0 then

        i := 1;

  if cardinal(i)>cardinal(fEnumType^.MaxValue) then

    Value := '' else // only set a valid value

    Int32ToUtf8(i,Value);

end;



procedure TSQLPropInfoRTTIEnum.SetValue(Instance: TObject; Value: PUTF8Char;

  wasString: boolean);

var i,err,len: integer;

begin

  if Value=nil then

    i := 0 else begin

    i := GetInteger(Value,err);

    if err<>0 then begin // we allow a value stated as text

      if fSQLFieldType=sftBoolean then begin

        len := StrLen(Value);

        i := Ord(IdemPropName('TRUE',Value,len) or IdemPropName('YES',Value,len));

      end else

        i := fEnumType^.GetEnumNameValue(Value); // -> convert into integer

      if cardinal(i)>cardinal(fEnumType^.MaxValue) then

        i := 0;  // only set a valid text value

    end else

    if fSQLFieldType=sftBoolean then // normalize boolean values range to 0,1

      if i<>0 then

        i := 1;

  end;

  fPropInfo.SetOrdProp(Instance,i);

end;





{ TSQLPropInfoRTTIChar }



procedure TSQLPropInfoRTTIChar.GetValueVar(Instance: TObject;

  ToSQL: boolean; var result: RawUTF8; wasSQLString: PBoolean);

var w: WideChar;

begin

  w := WideChar(fPropInfo.GetOrdProp(Instance));

  if ToSQL and (w=#0) then begin

    // 'null' and not #0 to avoid end of SQL text - JSON will escape #0

    result := 'null';

    if wasSQLString<>nil then

      wasSQLString^ := false;

   end else begin

    RawUnicodeToUtf8(@w,1,result);

    if wasSQLString<>nil then

      wasSQLString^ := true;

  end;

end;



procedure TSQLPropInfoRTTIChar.NormalizeValue(var Value: RawUTF8);

begin // do nothing: should already be UTF-8 encoded

end;



procedure TSQLPropInfoRTTIChar.SetValue(Instance: TObject; Value: PUTF8Char;

  wasString: boolean);

var i: integer;

begin

  if (Value=nil) or (PInteger(Value)^=NULL_LOW) then

    i := 0 else

    i := GetUTF8Char(Value);

  fPropInfo.SetOrdProp(Instance,i);

end;





{ TSQLPropInfoRTTIInt64 }



procedure TSQLPropInfoRTTIInt64.CopySameClassProp(Source: TObject; DestInfo: TSQLPropInfo;

  Dest: TObject);

begin

  TSQLPropInfoRTTIInt64(DestInfo).fPropInfo.SetInt64Prop(Dest,

    fPropInfo.GetInt64Prop(Source));

end;



procedure TSQLPropInfoRTTIInt64.GetBinary(Instance: TObject;

  W: TFileBufferWriter);

var V64: Int64;

begin

  V64 := fPropInfo.GetInt64Prop(Instance);

  W.Write(@V64,SizeOf(Int64));

end;



function TSQLPropInfoRTTIInt64.GetHash(Instance: TObject; CaseInsensitive: boolean): cardinal;

var I64: Int64;

begin

  if fPropInfo.GetterIsField then

    I64 := PInt64(fPropInfo.GetterAddr(Instance))^ else

    I64 := fPropInfo.GetInt64Prop(Instance);

  result := Int64Rec(I64).Lo xor Int64Rec(I64).Hi;

end;



procedure TSQLPropInfoRTTIInt64.GetJSONValues(Instance: TObject; W: TJSONSerializer);

begin

  W.Add(fPropInfo.GetInt64Prop(Instance));

end;



procedure TSQLPropInfoRTTIInt64.GetValueVar(Instance: TObject;

  ToSQL: boolean; var result: RawUTF8; wasSQLString: PBoolean);

begin

  if wasSQLString<>nil then

    wasSQLString^ := false;

  Int64ToUtf8(fPropInfo.GetInt64Prop(Instance),result);

end;



procedure TSQLPropInfoRTTIInt64.NormalizeValue(var Value: RawUTF8);

var err: integer;

    VInt64: Int64;

begin

  VInt64 := GetInt64(pointer(Value),err);

  if err<>0 then

    Value := '' else

    Int64ToUtf8(VInt64,Value);

end;



function TSQLPropInfoRTTIInt64.CompareValue(Item1, Item2: TObject; CaseInsensitive: boolean): PtrInt;

var res64: Int64;

begin

  if Item1=Item2 then

    result := 0 else

  if Item1=nil then

    result := -1 else

  if Item2=nil then

    result := 1 else begin

    if fGetterIsFieldPropOffset<>0 then

      res64 := PInt64(PtrUInt(Item1)+fGetterIsFieldPropOffset)^-

        PInt64(PtrUInt(Item2)+fGetterIsFieldPropOffset)^ else

      res64 := fPropinfo.GetInt64Prop(Item1)-fPropinfo.GetInt64Prop(Item2);

    if res64>0 then

      result := 1 else

    if res64<0 then

      result := -1 else

      result := 0;

  end;

end;



function TSQLPropInfoRTTIInt64.SetBinary(Instance: TObject; P: PAnsiChar): PAnsiChar;

begin

  if P=nil then

    result := nil else begin

    fPropInfo.SetInt64Prop(Instance,PInt64(P)^);

    result := P+sizeof(Int64);

  end;

end;



procedure TSQLPropInfoRTTIInt64.SetValue(Instance: TObject; Value: PUTF8Char;

  wasString: boolean);

begin

  fPropInfo.SetInt64Prop(Instance,GetInt64(Value));

end;



function TSQLPropInfoRTTIInt64.SetFieldSQLVar(Instance: TObject; const aValue: TSQLVar): boolean;

begin

  if aValue.VType=ftInt64 then begin

    fPropInfo.SetInt64Prop(Instance,aValue.VInt64);

    result := true;

  end else

    result := inherited SetFieldSQLVar(Instance,aValue);

end;



procedure TSQLPropInfoRTTIInt64.GetFieldSQLVar(Instance: TObject; var aValue: TSQLVar;

  var temp: RawByteString);

begin

  aValue.VType := ftInt64;

  aValue.VInt64 := fPropInfo.GetInt64Prop(Instance);

end;





{ TSQLPropInfoRTTIDouble }



procedure TSQLPropInfoRTTIDouble.CopySameClassProp(Source: TObject; DestInfo: TSQLPropInfo;

  Dest: TObject);

begin

  TSQLPropInfoRTTIDouble(DestInfo).fPropInfo.SetDoubleProp(Dest,

    fPropInfo.GetDoubleProp(Source));

end;



procedure TSQLPropInfoRTTIDouble.GetJSONValues(Instance: TObject; W: TJSONSerializer);

begin

  W.AddDouble(fPropInfo.GetDoubleProp(Instance));

end;



procedure TSQLPropInfoRTTIDouble.GetValueVar(Instance: TObject;

  ToSQL: boolean; var result: RawUTF8; wasSQLString: PBoolean);

begin

  if wasSQLString<>nil then

    wasSQLString^ := false;

  ExtendedToStr(fPropInfo.GetDoubleProp(Instance),DOUBLE_PRECISION,result);

end;



procedure TSQLPropInfoRTTIDouble.NormalizeValue(var Value: RawUTF8);

var VFloat: TSynExtended;

    err: integer;

begin

  VFloat := GetExtended(pointer(Value),err);

  if err<>0 then

    Value := '' else

    ExtendedToStr(VFloat,DOUBLE_PRECISION,Value);

end;



procedure TSQLPropInfoRTTIDouble.SetValue(Instance: TObject; Value: PUTF8Char;

  wasString: boolean);

var V: double;

    err: integer;

begin

  if Value=nil then

    V := 0 else begin

    V := GetExtended(pointer(Value),err);

    if err<>0 then

      V := 0;

  end;

  fPropInfo.SetDoubleProp(Instance,V);

end;



function TSQLPropInfoRTTIDouble.CompareValue(Item1,Item2: TObject; CaseInsensitive: boolean): PtrInt;

var V1, V2: double;

begin

  if Item1=Item2 then

    result := 0 else

  if Item1=nil then

    result := -1 else

  if Item2=nil then

    result := 1 else begin

    V1 := fPropInfo.GetDoubleProp(Item1);

    V2 := fPropInfo.GetDoubleProp(Item2);

    if SynCommons.SameValue(V1,V2) then

      result := 0 else

    if V1>V2 then

      result := 1 else

      result := -1;

  end;

end;



procedure TSQLPropInfoRTTIDouble.GetBinary(Instance: TObject;

  W: TFileBufferWriter);

var V: double;

begin

  V := fPropInfo.GetDoubleProp(Instance);

  W.Write(@V,SizeOf(V));

end;



{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}

type

  unaligned = Double;

{$endif}



function TSQLPropInfoRTTIDouble.SetBinary(Instance: TObject; P: PAnsiChar): PAnsiChar;

begin

  if P=nil then

    result := nil else begin

    fPropInfo.SetDoubleProp(Instance,unaligned(PDouble(P)^));

    result := P+sizeof(double);

  end;

end;



function TSQLPropInfoRTTIDouble.SetFieldSQLVar(Instance: TObject; const aValue: TSQLVar): boolean;

var V: double;

begin

  case aValue.VType of

  ftCurrency:       V := aValue.VCurrency;

  ftDouble, ftDate: V := aValue.VDouble;

  ftInt64:          V := aValue.VInt64;

  else begin

    result := inherited SetFieldSQLVar(Instance,aValue);

    exit;

  end;

  end;

  fPropInfo.SetDoubleProp(Instance,V);

  result := true;

end;



procedure TSQLPropInfoRTTIDouble.GetFieldSQLVar(Instance: TObject; var aValue: TSQLVar;

  var temp: RawByteString);

begin

  aValue.VType := ftDouble;

  aValue.VDouble := fPropInfo.GetDoubleProp(Instance);

end;





{ TSQLPropInfoRTTICurrency }



procedure TSQLPropInfoRTTICurrency.CopySameClassProp(Source: TObject; DestInfo: TSQLPropInfo;

  Dest: TObject);

begin

  TSQLPropInfoRTTICurrency(DestInfo).fPropInfo.SetCurrencyProp(Dest,

    fPropInfo.GetCurrencyProp(Source));

end;



procedure TSQLPropInfoRTTICurrency.GetJSONValues(Instance: TObject; W: TJSONSerializer);

begin

  W.AddCurr64(fPropInfo.GetCurrencyProp(Instance));

end;



procedure TSQLPropInfoRTTICurrency.GetValueVar(Instance: TObject;

  ToSQL: boolean; var result: RawUTF8; wasSQLString: PBoolean);

begin

  if wasSQLString<>nil then

    wasSQLString^ := false;

  result := CurrencyToStr(fPropInfo.GetCurrencyProp(Instance));

end;



procedure TSQLPropInfoRTTICurrency.NormalizeValue(var Value: RawUTF8);

begin

  Value := Curr64ToStr(StrToCurr64(pointer(Value)));

end;



procedure TSQLPropInfoRTTICurrency.SetValue(Instance: TObject; Value: PUTF8Char;

  wasString: boolean);

var tmp: Int64;

begin

  tmp := StrToCurr64(Value,nil);

  fPropInfo.SetCurrencyProp(Instance,PCurrency(@tmp)^);

end;



function TSQLPropInfoRTTICurrency.CompareValue(Item1,Item2: TObject; CaseInsensitive: boolean): PtrInt;

var V1, V2: currency;

begin

  if Item1=Item2 then

    result := 0 else

  if Item1=nil then

    result := -1 else

  if Item2=nil then

    result := 1 else begin

    V1 := fPropInfo.GetCurrencyProp(Item1);

    V2 := fPropInfo.GetCurrencyProp(Item2);

    Result := PInt64(@V1)^-PInt64(@V2)^;

  end;

end;



procedure TSQLPropInfoRTTICurrency.GetFieldSQLVar(Instance: TObject; var aValue: TSQLVar;

  var temp: RawByteString);

begin

  aValue.VType := ftCurrency;

  aValue.VCurrency := fPropInfo.GetCurrencyProp(Instance);

end;



function TSQLPropInfoRTTICurrency.SetFieldSQLVar(Instance: TObject; const aValue: TSQLVar): boolean;

var V: Currency;

begin

  case aValue.VType of

  ftDouble, ftDate: V := aValue.VDouble;

  ftInt64:          V := aValue.VInt64;

  ftCurrency:       V := aValue.VCurrency;

  else begin

    result := inherited SetFieldSQLVar(Instance,aValue);

    exit;

  end;

  end;

  fPropInfo.SetCurrencyProp(Instance,V);

  result := true;

end;



procedure TSQLPropInfoRTTICurrency.GetBinary(Instance: TObject;

  W: TFileBufferWriter);

var V: Currency;

begin

  V := fPropInfo.GetCurrencyProp(Instance);

  W.Write(@V,SizeOf(V));

end;



function TSQLPropInfoRTTICurrency.SetBinary(Instance: TObject; P: PAnsiChar): PAnsiChar;

begin

  if P=nil then

    result := nil else begin

    fPropInfo.SetCurrencyProp(Instance,PCurrency(P)^);

    result := P+sizeof(Currency);

  end;

end;





{ TSQLPropInfoRTTIDateTime }



procedure TSQLPropInfoRTTIDateTime.GetJSONValues(Instance: TObject; W: TJSONSerializer);

begin

  W.Add('"');

  W.AddDateTime(fPropInfo.GetDoubleProp(Instance));

  W.Add('"');

end;



function TSQLPropInfoRTTIDateTime.CompareValue(Item1,Item2: TObject; CaseInsensitive: boolean): PtrInt;

var Date1,Date2: TTimeLogBits;

begin // force second resolution, as in our JSON content

  if Item1=Item2 then

    result := 0 else

  if Item1=nil then

    result := -1 else

  if Item2=nil then

    result := 1 else begin

    Date1.From(fPropInfo.GetDoubleProp(Item1));

    Date2.From(fPropInfo.GetDoubleProp(Item2));

    result := Date1.Value-Date2.Value;

  end;

end;



procedure TSQLPropInfoRTTIDateTime.GetValueVar(Instance: TObject;

  ToSQL: boolean; var result: RawUTF8; wasSQLString: PBoolean);

begin

  if wasSQLString<>nil then

    wasSQLString^ := true;

  DateTimeToIso8601TextVar(fPropInfo.GetDoubleProp(Instance),'T',result);

end;



procedure TSQLPropInfoRTTIDateTime.NormalizeValue(var Value: RawUTF8);

begin

  DateTimeToIso8601TextVar(Iso8601ToDateTime(Value),'T',Value);

end;



procedure TSQLPropInfoRTTIDateTime.SetValue(Instance: TObject; Value: PUTF8Char;

  wasString: boolean);

var V: TDateTime;

begin

  Iso8601ToDateTimePUTF8CharVar(Value,0,V);

  fPropInfo.SetDoubleProp(Instance,V);

end;



procedure TSQLPropInfoRTTIDateTime.GetFieldSQLVar(Instance: TObject; var aValue: TSQLVar;

  var temp: RawByteString);

begin

  aValue.VType := ftDate;

  aValue.VDouble := fPropInfo.GetDoubleProp(Instance);

end;





{ TSQLPropInfoRTTIMany }



// TSQLRecordMany stores nothing within the table



procedure TSQLPropInfoRTTIMany.GetValueVar(Instance: TObject;

  ToSQL: boolean; var result: RawUTF8; wasSQLString: PBoolean);

begin

  result := '';

end;



procedure TSQLPropInfoRTTIMany.SetValue(Instance: TObject; Value: PUTF8Char;

  wasString: boolean);

begin

end;



procedure TSQLPropInfoRTTIMany.GetBinary(Instance: TObject; W: TFileBufferWriter);

begin

end;



function TSQLPropInfoRTTIMany.SetBinary(Instance: TObject; P: PAnsiChar): PAnsiChar;

begin

  result := P;

end;





{ TSQLPropInfoRTTIInstance }



constructor TSQLPropInfoRTTIInstance.Create(aPropInfo: PPropInfo; aPropIndex: integer;

  aSQLFieldType: TSQLFieldType);

begin

  inherited Create(aPropInfo,aPropIndex,aSQLFieldType);

  fObjectClass := fPropType^.ClassType^.ClassType;

end;



function TSQLPropInfoRTTIInstance.GetInstance(Instance: TObject): TObject;

begin

  result := fPropInfo.GetObjProp(Instance);

end;



procedure TSQLPropInfoRTTIInstance.SetInstance(Instance, Value: TObject);

begin

  fPropInfo.SetOrdProp(Instance,PtrInt(Value));

end;





{ TSQLPropInfoRTTIRecordReference }



constructor TSQLPropInfoRTTIRecordReference.Create(aPropInfo: PPropInfo;

  aPropIndex: integer; aSQLFieldType: TSQLFieldType);

begin

  inherited Create(aPropInfo,aPropIndex,aSQLFieldType);

  fCascadeDelete := IdemPropName(fPropType^.Name,'TRecordReferenceToBeDeleted')

end;





{ TSQLPropInfoRTTITID }



constructor TSQLPropInfoRTTITID.Create(aPropInfo: PPropInfo; aPropIndex: integer;

  aSQLFieldType: TSQLFieldType);

var TypeName: PShortString;

    ItemClass: TClass;

begin

  inherited Create(aPropInfo,aPropIndex,aSQLFieldType);

  TypeName := @fPropType^.Name;

  if IdemPropName(TypeName^,'TID') or

     (ord(TypeName^[1]) and $df<>ord('T')) or // expect T...ID pattern

     (PWord(@TypeName^[ord(TypeName^[0])-1])^ and $dfdf<>ord('I')+ord('D') shl 8) or

     (JSONSerializerRegisteredClass=nil) then

    exit;

  if (ord(TypeName^[0])>13) and

     IdemPropName('ToBeDeletedID',@TypeName^[ord(TypeName^[0])-12],13) then begin

    // 'TSQLRecordClientToBeDeletedID' -> TSQLRecordClient + CascadeDelete=true

    fCascadeDelete := true;

    ItemClass := JSONSerializerRegisteredClass.Find(@TypeName^[1],ord(TypeName^[0])-13);

  end else

    // 'TSQLRecordClientID' -> TSQLRecordClient

    ItemClass := JSONSerializerRegisteredClass.Find(@TypeName^[1],ord(TypeName^[0])-2);

  if (ItemClass<>nil) and ItemClass.InheritsFrom(TSQLRecord) then

    fRecordClass := pointer(ItemClass);

end;





{ TSQLPropInfoRTTIID }



procedure TSQLPropInfoRTTIID.SetValue(Instance: TObject; Value: PUTF8Char;

  wasString: boolean);

begin

  if TSQLRecord(Instance).fFill.JoinedFields then

    raise EORMException.CreateUTF8('%(%).SetValue after Create*Joined',[self,Name]);

  inherited SetValue(Instance,Value,wasString);

end;



procedure TSQLPropInfoRTTIID.GetJSONValues(Instance: TObject; W: TJSONSerializer);

var ID: PtrUInt;

begin

  ID := fPropInfo.GetOrdProp(Instance);

  if TSQLRecord(Instance).fFill.JoinedFields then

    ID := TSQLRecord(ID).fID;

  W.AddU(ID);

end;







{ TSQLPropInfoRTTIIObject }



procedure TSQLPropInfoRTTIObject.CopySameClassProp(Source: TObject;

  DestInfo: TSQLPropInfo; Dest: TObject);

var S,D: TObject;

begin

  // generic case: copy also class content (create instances)

  S := GetInstance(Source);

  D := TSQLPropInfoRTTIObject(DestInfo).GetInstance(Dest);

{$ifndef LVCL}

  if S.InheritsFrom(TCollection) then

    CopyCollection(TCollection(S),TCollection(D)) else

{$endif}

  if S.InheritsFrom(TStrings) and D.InheritsFrom(TStrings) then

    CopyStrings(TStrings(S),TStrings(D)) else begin

    D.Free; // release previous instance

    TSQLPropInfoRTTIObject(DestInfo).SetInstance(Dest,CopyObject(S));

  end;

end;



procedure TSQLPropInfoRTTIObject.SetValue(Instance: TObject; Value: PUTF8Char;

  wasString: boolean);

var valid: boolean;

    ValueLocalCopy: RawUTF8;

begin

  ValueLocalCopy := Value; // private copy since the buffer will be modified

  PropInfo^.ClassFromJSON(Instance,pointer(ValueLocalCopy),valid);

end;



procedure TSQLPropInfoRTTIObject.GetValueVar(Instance: TObject;

  ToSQL: boolean; var result: RawUTF8; wasSQLString: PBoolean);

begin

  if wasSQLString<>nil then

    wasSQLString^ := true;

  result := ObjectToJSON(GetInstance(Instance));

end;



procedure TSQLPropInfoRTTIObject.GetBinary(Instance: TObject; W: TFileBufferWriter);

begin

  // serialize object as JSON UTF-8 TEXT - not fast, but works

  W.Write(ObjectToJSON(GetInstance(Instance)));

end;



function TSQLPropInfoRTTIObject.SetBinary(Instance: TObject; P: PAnsiChar): PAnsiChar;

var valid: boolean;

begin

  // unserialize object from JSON UTF-8 TEXT - not fast, but works

  PropInfo^.ClassFromJSON(Instance,pointer(FromVarString(PByte(P))),valid);

  if valid then

    result := P else

    result := nil;

end;



function TSQLPropInfoRTTIObject.GetHash(Instance: TObject; CaseInsensitive: boolean): cardinal;

var tmp: RawUTF8;

begin // JSON is case-sensitive by design -> ignore CaseInsensitive parameter

  tmp := ObjectToJSON(GetInstance(Instance));

  result := crc32c(0,pointer(tmp),length(tmp));

end;



procedure TSQLPropInfoRTTIObject.NormalizeValue(var Value: RawUTF8);

begin // do nothing: should already be normalized

end;



procedure TSQLPropInfoRTTIObject.GetJSONValues(Instance: TObject; W: TJSONSerializer);

begin

  if jwoAsJsonNotAsString in W.fSQLRecordOptions then

    W.WriteObject(GetInstance(Instance)) else

    W.WriteObjectAsString(GetInstance(Instance));

end;





{ TSQLPropInfoRTTIAnsi }



constructor TSQLPropInfoRTTIAnsi.Create(aPropInfo: PPropInfo; aPropIndex: integer;

  aSQLFieldType: TSQLFieldType);

begin

  inherited;

  fEngine := TSynAnsiConvert.Engine(aPropInfo^.PropType^.AnsiStringCodePage);

end;



procedure TSQLPropInfoRTTIAnsi.CopySameClassProp(Source: TObject;

  DestInfo: TSQLPropInfo; Dest: TObject);

var Value: RawByteString;

begin

  if (TSQLPropInfoRTTIAnsi(DestInfo).fEngine=fEngine) then begin

    fPropInfo.GetLongStrProp(Source,Value);

    TSQLPropInfoRTTIAnsi(DestInfo).fPropInfo.SetLongStrProp(Dest,Value);

  end else begin

    GetValueVar(Source,false,RawUTF8(Value),nil);

    DestInfo.SetValueVar(Dest,Value,true);

  end;

end;



procedure TSQLPropInfoRTTIAnsi.GetBinary(Instance: TObject; W: TFileBufferWriter);

var Value: RawByteString;

begin

  fPropInfo.GetLongStrProp(Instance,Value);

  W.Write(Value);

end;



function TSQLPropInfoRTTIAnsi.GetHash(Instance: TObject; CaseInsensitive: boolean): cardinal;

var Up: array[byte] of AnsiChar; // avoid slow heap allocation

    Value: RawByteString;

begin

  fPropInfo.GetLongStrProp(Instance,Value);

  if CaseInsensitive then

    if fEngine.CodePage=CODEPAGE_US then

      result := crc32c(0,Up,UpperCopyWin255(Up,Value)-Up) else

      result := crc32c(0,Up,UpperCopy255Buf(Up,pointer(Value),length(Value))-Up) else

    result := crc32c(0,pointer(Value),length(Value));

end;



procedure TSQLPropInfoRTTIAnsi.GetValueVar(Instance: TObject;

  ToSQL: boolean; var result: RawUTF8; wasSQLString: PBoolean);

var tmp: RawByteString;

begin

  if wasSQLString<>nil then

    wasSQLString^ := true;

  fPropInfo.GetLongStrProp(Instance,tmp);

  result := fEngine.AnsiBufferToRawUTF8(pointer(tmp),length(tmp));

end;



procedure TSQLPropInfoRTTIAnsi.NormalizeValue(var Value: RawUTF8);

begin // do nothing: should already be UTF-8 encoded

end;



function TSQLPropInfoRTTIAnsi.CompareValue(Item1, Item2: TObject; CaseInsensitive: boolean): PtrInt;

var tmp1,tmp2: RawByteString;

begin

  if Item1=Item2 then

    result := 0 else

  if Item1=nil then

    result := -1 else

  if Item2=nil then

    result := 1 else begin

    fPropInfo.GetLongStrProp(Item1,tmp1);

    fPropInfo.GetLongStrProp(Item2,tmp2);

    if CaseInsensitive then

      if fEngine.CodePage=CODEPAGE_US then

        result := AnsiIComp(pointer(tmp1),pointer(tmp2)) else

        result := StrIComp(pointer(tmp1),pointer(tmp2)) else

      result := StrComp(pointer(tmp1),pointer(tmp2));

  end;

end;



function TSQLPropInfoRTTIAnsi.SetBinary(Instance: TObject; P: PAnsiChar): PAnsiChar;

var tmp: RawByteString;

begin

  FromVarString(PByte(P),tmp,fEngine.CodePage);

  fPropInfo.SetLongStrProp(Instance,tmp);

  result := P;

end;



procedure TSQLPropInfoRTTIAnsi.SetValue(Instance: TObject; Value: PUTF8Char;

  wasString: boolean);

begin

  if Value=nil then

    fPropInfo.SetLongStrProp(Instance,'') else

    fPropInfo.SetLongStrProp(Instance,fEngine.UTF8BufferToAnsi(Value,StrLen(Value)));

end;



procedure TSQLPropInfoRTTIAnsi.SetValueVar(Instance: TObject; const Value: RawUTF8;

  wasString: boolean);

begin

  fPropInfo.SetLongStrProp(Instance,fEngine.UTF8ToAnsi(Value));

end;



procedure TSQLPropInfoRTTIAnsi.GetJSONValues(Instance: TObject; W: TJSONSerializer);

var tmp: RawByteString;

begin

  W.Add('"');

  fPropInfo.GetLongStrProp(Instance,tmp);

  if PtrUInt(tmp)<>0 then

    W.AddAnyAnsiString(tmp,twJSONEscape,fEngine.CodePage);

  W.Add('"');

end;



function TSQLPropInfoRTTIAnsi.SetFieldSQLVar(Instance: TObject; const aValue: TSQLVar): boolean;

var tmp: RawByteString;

begin

  case aValue.VType of

  ftNull: ; // leave tmp=''

  ftUTF8: fEngine.UTF8BufferToAnsi(aValue.VText,StrLen(aValue.VText),tmp);

  else begin

    result := inherited SetFieldSQLVar(Instance,aValue);

    exit;

  end;

  end;

  fPropInfo.SetLongStrProp(Instance,tmp);

  result := True;

end;



procedure TSQLPropInfoRTTIAnsi.GetFieldSQLVar(Instance: TObject; var aValue: TSQLVar;

  var temp: RawByteString);

begin

  fPropInfo.GetLongStrProp(Instance,temp);

  temp := fEngine.AnsiToUTF8(temp);

  aValue.VType := ftUTF8;

  aValue.VText := pointer(temp);

end;



procedure TSQLPropInfoRTTIAnsi.CopyValue(Source, Dest: TObject);

begin // avoid temporary variable use, for simple fields with no getter/setter

  if fInPlaceCopySameClassPropOffset=0 then

    fPropInfo.CopyLongStrProp(Source,Dest) else

    PRawByteString(PtrUInt(Dest)+fInPlaceCopySameClassPropOffset)^ :=

      PRawByteString(PtrUInt(Source)+fInPlaceCopySameClassPropOffset)^;

end;





{ TSQLPropInfoRTTIRawUTF8 }



procedure TSQLPropInfoRTTIRawUTF8.CopySameClassProp(Source: TObject;

  DestInfo: TSQLPropInfo; Dest: TObject);

var Value: RawByteString;

begin

  fPropInfo.GetLongStrProp(Source,Value);

  TSQLPropInfoRTTIRawUTF8(DestInfo).fPropInfo.SetLongStrProp(Dest,Value);

end;



function TSQLPropInfoRTTIRawUTF8.GetHash(Instance: TObject; CaseInsensitive: boolean): cardinal;

var Up: array[byte] of AnsiChar; // avoid slow heap allocation

    Value: RawByteString;

begin

  fPropInfo.GetLongStrProp(Instance,Value);

  if CaseInsensitive then

    result := crc32c(0,Up,UTF8UpperCopy255(Up,Value)-Up) else

    result := crc32c(0,pointer(Value),length(Value));

end;



procedure TSQLPropInfoRTTIRawUTF8.GetJSONValues(Instance: TObject; W: TJSONSerializer);

var tmp: RawByteString;

begin

  W.Add('"');

  fPropInfo.GetLongStrProp(Instance,tmp);

  if PtrUInt(tmp)<>0 then

    W.AddJSONEscape(pointer(tmp),

      {$ifdef FPC}length(tmp){$else}PInteger(PtrUInt(tmp)-4)^{$endif});

  W.Add('"');

end;



procedure TSQLPropInfoRTTIRawUTF8.GetValueVar(Instance: TObject;

  ToSQL: boolean; var result: RawUTF8; wasSQLString: PBoolean);

begin

  if wasSQLString<>nil then

    wasSQLString^ := true;

  fPropInfo.GetLongStrProp(Instance,RawByteString(result));

end;



function TSQLPropInfoRTTIRawUTF8.SetFieldSQLVar(Instance: TObject; const aValue: TSQLVar): boolean;

var tmp: RawByteString;

begin

  case aValue.VType of

  ftNull: ; // leave tmp=''

  ftUTF8: SetString(tmp,PAnsiChar(aValue.VText),StrLen(aValue.VText));

  else begin

    result := inherited SetFieldSQLVar(Instance,aValue);

    exit;

  end;

  end;

  fPropInfo.SetLongStrProp(Instance,tmp);

  result := True;

end;



procedure TSQLPropInfoRTTIRawUTF8.GetFieldSQLVar(Instance: TObject; var aValue: TSQLVar;

  var temp: RawByteString);

begin

  fPropInfo.GetLongStrProp(Instance,temp);

  aValue.VType := ftUTF8;

  aValue.VText := Pointer(temp);

end;



function TSQLPropInfoRTTIRawUTF8.CompareValue(Item1, Item2: TObject;

  CaseInsensitive: boolean): PtrInt;



  procedure Generic;

  var tmp1,tmp2: RawByteString;

  begin

    fPropInfo.GetLongStrProp(Item1,tmp1);

    fPropInfo.GetLongStrProp(Item2,tmp2);

    if CaseInsensitive then

      result := UTF8IComp(pointer(tmp1),pointer(tmp2)) else

      result := StrComp(pointer(tmp1),pointer(tmp2));

  end;



begin

  if Item1=Item2 then

    result := 0 else

  if Item1=nil then

    result := -1 else

  if Item2=nil then

    result := 1 else

    if fGetterIsFieldPropOffset<>0 then // avoid any temporary variable

      if CaseInsensitive then

        result := UTF8IComp(PPointer(PtrUInt(Item1)+fGetterIsFieldPropOffset)^,

          PPointer(PtrUInt(Item2)+fGetterIsFieldPropOffset)^) else

        result := StrComp(PPointer(PtrUInt(Item1)+fGetterIsFieldPropOffset)^,

          PPointer(PtrUInt(Item2)+fGetterIsFieldPropOffset)^) else

    Generic;

end;



procedure TSQLPropInfoRTTIRawUTF8.SetValue(Instance: TObject; Value: PUTF8Char;

  wasString: boolean);

var tmp: RawUTF8;

begin

  if Value<>nil then

    SetString(tmp,PAnsiChar(Value),StrLen(Value));

  fPropInfo.SetLongStrProp(Instance,tmp);

end;



procedure TSQLPropInfoRTTIRawUTF8.SetValueVar(Instance: TObject; const Value: RawUTF8; wasString: boolean);

begin

  fPropInfo.SetLongStrProp(Instance,Value);

end;





{ TSQLPropInfoRTTIRawUnicode }



procedure TSQLPropInfoRTTIRawUnicode.CopySameClassProp(Source: TObject;

  DestInfo: TSQLPropInfo; Dest: TObject);

var Value: RawByteString;

begin

  fPropInfo.GetLongStrProp(Source,Value);

  TSQLPropInfoRTTIRawUnicode(DestInfo).fPropInfo.SetLongStrProp(Dest,Value);

end;



function TSQLPropInfoRTTIRawUnicode.GetHash(Instance: TObject; CaseInsensitive: boolean): cardinal;

var Up: array[byte] of AnsiChar; // avoid slow heap allocation

    Value: RawByteString;

begin

  fPropInfo.GetLongStrProp(Instance,Value);

  if CaseInsensitive then

    result := crc32c(0,Up,UpperCopy255W(Up,pointer(Value),length(Value)shr 1)-Up) else

    result := crc32c(0,pointer(Value),length(Value));

end;



procedure TSQLPropInfoRTTIRawUnicode.GetValueVar(Instance: TObject;

  ToSQL: boolean; var result: RawUTF8; wasSQLString: PBoolean);

var tmp: RawByteString;

begin

  if wasSQLString<>nil then

    wasSQLString^ := true;

  fPropInfo.GetLongStrProp(Instance,tmp);

  RawUnicodeToUTF8(pointer(tmp),length(tmp)shr 1,result);

end;



function TSQLPropInfoRTTIRawUnicode.CompareValue(Item1, Item2: TObject;

  CaseInsensitive: boolean): PtrInt;

var tmp1,tmp2: RawByteString;

begin

  if Item1=Item2 then

    result := 0 else

  if Item1=nil then

    result := -1 else

  if Item2=nil then

    result := 1 else begin

    fPropInfo.GetLongStrProp(Item1,tmp1);

    fPropInfo.GetLongStrProp(Item2,tmp2);

    if CaseInsensitive then

      result := AnsiICompW(pointer(tmp1),pointer(tmp2)) else

      result := StrCompW(pointer(tmp1),pointer(tmp2));

  end;

end;



procedure TSQLPropInfoRTTIRawUnicode.SetValue(Instance: TObject; Value: PUTF8Char;

  wasString: boolean);

begin

  if Value=nil then

    fPropInfo.SetLongStrProp(Instance,'') else

    fPropInfo.SetLongStrProp(Instance,Utf8DecodeToRawUnicode(Value,StrLen(Value)));

end;



procedure TSQLPropInfoRTTIRawUnicode.SetValueVar(Instance: TObject; const Value: RawUTF8; wasString: boolean);

begin

  fPropInfo.SetLongStrProp(Instance,Utf8DecodeToRawUnicode(Value));

end;





{ TSQLPropInfoRTTIRawBlob }



procedure TSQLPropInfoRTTIRawBlob.CopySameClassProp(Source: TObject;

  DestInfo: TSQLPropInfo; Dest: TObject);

var Value: RawByteString;

begin

  fPropInfo.GetLongStrProp(Source,Value);

  TSQLPropInfoRTTIRawBlob(DestInfo).fPropInfo.SetLongStrProp(Dest,Value);

end;



function TSQLPropInfoRTTIRawBlob.GetHash(Instance: TObject; CaseInsensitive: boolean): cardinal;

var Value: RawByteString;

begin

  fPropInfo.GetLongStrProp(Instance,Value);

  result := crc32c(0,pointer(Value),length(Value)); // binary -> case sensitive

end;



procedure TSQLPropInfoRTTIRawBlob.GetJSONValues(Instance: TObject; W: TJSONSerializer);

var tmp: RawByteString;

begin

  fPropInfo.GetLongStrProp(Instance,tmp);

  W.WrBase64(pointer(tmp),length(tmp),true);

end;



procedure TSQLPropInfoRTTIRawBlob.GetBlob(Instance: TObject;

  var Blob: RawByteString);

begin

  fPropInfo.GetLongStrProp(Instance,Blob);

end;



procedure TSQLPropInfoRTTIRawBlob.SetBlob(Instance: TObject;

  const Blob: RawByteString);

begin

  fPropInfo.SetLongStrProp(Instance,Blob);

end;



function TSQLPropInfoRTTIRawBlob.IsNull(Instance: TObject): Boolean;

var Blob: RawByteString;

begin

  fPropInfo.GetLongStrProp(Instance,Blob);

  result := (Blob='');

end;



procedure TSQLPropInfoRTTIRawBlob.GetValueVar(Instance: TObject;

  ToSQL: boolean; var result: RawUTF8; wasSQLString: PBoolean);

begin

  fPropInfo.GetLongStrProp(Instance,RawByteString(result));

  BinaryToText(result,ToSQL,wasSQLString);

end;



function TSQLPropInfoRTTIRawBlob.CompareValue(Item1, Item2: TObject;

  CaseInsensitive: boolean): PtrInt;

var tmp1,tmp2: RawByteString;

begin

  if Item1=Item2 then

    result := 0 else

  if Item1=nil then

    result := -1 else

  if Item2=nil then

    result := 1 else begin

    fPropInfo.GetLongStrProp(Item1,tmp1);

    fPropInfo.GetLongStrProp(Item2,tmp2);

    // BLOB is binary so always case sensitive

    result := StrComp(pointer(tmp1),pointer(tmp2));

  end;

end;



procedure TSQLPropInfoRTTIRawBlob.SetValue(Instance: TObject; Value: PUTF8Char;

  wasString: boolean);

begin

  fPropInfo.SetLongStrProp(Instance,BlobToTSQLRawBlob(Value));

end;



procedure TSQLPropInfoRTTIRawBlob.SetValueVar(Instance: TObject; const Value: RawUTF8; wasString: boolean);

begin

  fPropInfo.SetLongStrProp(Instance,BlobToTSQLRawBlob(Value));

end;



function TSQLPropInfoRTTIRawBlob.SetFieldSQLVar(Instance: TObject; const aValue: TSQLVar): boolean;

var tmp: RawByteString;

begin

  case aValue.VType of

  ftBlob: begin

    SetString(tmp,PAnsiChar(aValue.VBlob),aValue.VBlobLen);

    fPropInfo.SetLongStrProp(Instance,tmp);

    result := true;

  end;

  ftNull: begin

    fPropInfo.SetLongStrProp(Instance,'');

    result := true;

  end;

  else result := inherited SetFieldSQLVar(Instance,aValue);

  end;

end;



procedure TSQLPropInfoRTTIRawBlob.GetFieldSQLVar(Instance: TObject; var aValue: TSQLVar;

  var temp: RawByteString);

begin

  fPropInfo.GetLongStrProp(Instance,temp);

  if temp='' then

    aValue.VType := ftNull else begin

    aValue.VType := ftBlob;

    aValue.VBlob := pointer(temp);

    aValue.VBlobLen := length(temp);

  end;

end;





{ TSQLPropInfoRTTIWide }



procedure TSQLPropInfoRTTIWide.CopySameClassProp(Source: TObject;

  DestInfo: TSQLPropInfo; Dest: TObject);

var Value: WideString;

begin

  fPropInfo.GetWideStrProp(Source,Value);

  TSQLPropInfoRTTIWide(DestInfo).fPropInfo.SetWideStrProp(Dest,Value);

end;



procedure TSQLPropInfoRTTIWide.GetBinary(Instance: TObject; W: TFileBufferWriter);

var Value: WideString;

begin

  fPropInfo.GetWideStrProp(Instance,Value);

  W.Write(WideStringToUTF8(Value));

end;



function TSQLPropInfoRTTIWide.GetHash(Instance: TObject; CaseInsensitive: boolean): cardinal;

var Up: array[byte] of AnsiChar; // avoid slow heap allocation

    Value: WideString;

begin

  fPropInfo.GetWideStrProp(Instance,Value);

  if CaseInsensitive then

    result := crc32c(0,Up,UpperCopy255W(Up,pointer(Value),length(Value))-Up) else

    result := crc32c(0,pointer(Value),length(Value)*2);

end;



procedure TSQLPropInfoRTTIWide.GetJSONValues(Instance: TObject; W: TJSONSerializer);

var Value: WideString;

begin

  W.Add('"');

  fPropInfo.GetWideStrProp(Instance,Value);

  if pointer(Value)<>nil then

    W.AddJSONEscapeW(pointer(Value),0);

  W.Add('"');

end;



procedure TSQLPropInfoRTTIWide.GetValueVar(Instance: TObject;

  ToSQL: boolean; var result: RawUTF8; wasSQLString: PBoolean);

var Value: WideString;

begin

  fPropInfo.GetWideStrProp(Instance,Value);

  result := WideStringToUTF8(Value);

  if wasSQLString<>nil then

    wasSQLString^ := true;

end;



procedure TSQLPropInfoRTTIWide.CopyValue(Source, Dest: TObject);

begin // avoid temporary variable use, for simple fields with no getter/setter

  if fInPlaceCopySameClassPropOffset=0 then

    CopySameClassProp(Source,self,Dest) else

    PWideString(PtrUInt(Dest)+fInPlaceCopySameClassPropOffset)^ :=

      PWideString(PtrUInt(Source)+fInPlaceCopySameClassPropOffset)^;

end;



function TSQLPropInfoRTTIWide.CompareValue(Item1, Item2: TObject;

  CaseInsensitive: boolean): PtrInt;

var tmp1,tmp2: WideString;

begin

  if Item1=Item2 then

    result := 0 else

  if Item1=nil then

    result := -1 else

  if Item2=nil then

    result := 1 else begin

    fPropInfo.GetWideStrProp(Item1,tmp1);

    fPropInfo.GetWideStrProp(Item2,tmp2);

    if CaseInsensitive then

      result := AnsiICompW(pointer(tmp1),pointer(tmp2)) else

      result := StrCompW(pointer(tmp1),pointer(tmp2));

  end;

end;



function TSQLPropInfoRTTIWide.SetBinary(Instance: TObject; P: PAnsiChar): PAnsiChar;

begin

  fPropInfo.SetWideStrProp(Instance,UTF8ToWideString(FromVarString(PByte(P))));

  result := P;

end;



procedure TSQLPropInfoRTTIWide.SetValue(Instance: TObject; Value: PUTF8Char;

  wasString: boolean);

var Wide: WideString;

begin

  if Value<>nil then

    UTF8ToWideString(Value,StrLen(Value),Wide);

  fPropInfo.SetWideStrProp(Instance,Wide);

end;





{$ifdef HASVARUSTRING}



{ TSQLPropInfoRTTIUnicode }



procedure TSQLPropInfoRTTIUnicode.CopySameClassProp(Source: TObject;

  DestInfo: TSQLPropInfo; Dest: TObject);

begin

  TSQLPropInfoRTTIUnicode(DestInfo).fPropInfo.SetUnicodeStrProp(Dest,

    fPropInfo.GetUnicodeStrProp(Source));

end;



procedure TSQLPropInfoRTTIUnicode.GetBinary(Instance: TObject; W: TFileBufferWriter);

begin

  W.Write(UnicodeStringToUtf8(fPropInfo.GetUnicodeStrProp(Instance)));

end;



procedure TSQLPropInfoRTTIUnicode.CopyValue(Source, Dest: TObject);

begin // avoid temporary variable use, for simple fields with no getter/setter

  if fInPlaceCopySameClassPropOffset=0 then

    CopySameClassProp(Source,self,Dest) else

    PUnicodeString(PtrUInt(Dest)+fInPlaceCopySameClassPropOffset)^ :=

      PUnicodeString(PtrUInt(Source)+fInPlaceCopySameClassPropOffset)^;

end;



function TSQLPropInfoRTTIUnicode.GetHash(Instance: TObject; CaseInsensitive: boolean): cardinal;

var Up: array[byte] of AnsiChar; // avoid slow heap allocation

    Value: UnicodeString;

begin

  Value := fPropInfo.GetUnicodeStrProp(Instance);

  if CaseInsensitive then

    result := crc32c(0,Up,UpperCopy255W(Up,pointer(Value),length(Value))-Up) else

    result := crc32c(0,pointer(Value),length(Value)*2);

end;



procedure TSQLPropInfoRTTIUnicode.GetValueVar(Instance: TObject;

  ToSQL: boolean; var result: RawUTF8; wasSQLString: PBoolean);

begin

  result := UnicodeStringToUtf8(fPropInfo.GetUnicodeStrProp(Instance));

  if wasSQLString<>nil then

    wasSQLString^ := true;

end;



procedure TSQLPropInfoRTTIUnicode.GetJSONValues(Instance: TObject; W: TJSONSerializer);

var tmp: UnicodeString;

begin

  W.Add('"');

  tmp := fPropInfo.GetUnicodeStrProp(Instance);

  if PtrUInt(tmp)<>0 then

    W.AddJSONEscapeW(pointer(tmp),0);

  W.Add('"');

end;



function TSQLPropInfoRTTIUnicode.CompareValue(Item1, Item2: TObject;

  CaseInsensitive: boolean): PtrInt;

var tmp1,tmp2: UnicodeString;

begin

  if Item1=Item2 then

    result := 0 else

  if Item1=nil then

    result := -1 else

  if Item2=nil then

    result := 1 else begin

    tmp1 := fPropInfo.GetUnicodeStrProp(Item1);

    tmp2 := fPropInfo.GetUnicodeStrProp(Item2);

    if CaseInsensitive then

      result := AnsiICompW(pointer(tmp1),pointer(tmp2)) else

      result := StrCompW(pointer(tmp1),pointer(tmp2));

  end;

end;



function TSQLPropInfoRTTIUnicode.SetBinary(Instance: TObject; P: PAnsiChar): PAnsiChar;

begin

  fPropInfo.SetUnicodeStrProp(Instance,UTF8DecodeToUnicodeString(FromVarString(PByte(P))));

  result := P;

end;



procedure TSQLPropInfoRTTIUnicode.SetValue(Instance: TObject; Value: PUTF8Char;

  wasString: boolean);

var tmp: UnicodeString;

begin

  if Value<>nil then

    UTF8DecodeToUnicodeString(Value,StrLen(Value),tmp);

  fPropInfo.SetUnicodeStrProp(Instance,tmp);

end;



procedure TSQLPropInfoRTTIUnicode.SetValueVar(Instance: TObject; const Value: RawUTF8; wasString: boolean);

begin

  fPropInfo.SetUnicodeStrProp(Instance,UTF8DecodeToUnicodeString(Value));

end;



function TSQLPropInfoRTTIUnicode.SetFieldSQLVar(Instance: TObject; const aValue: TSQLVar): boolean;

var tmp: UnicodeString;

begin

  case aValue.VType of

  ftNull: ; // leave tmp=''

  ftUTF8: UTF8DecodeToUnicodeString(aValue.VText,StrLen(aValue.VText),tmp);

  else begin

    result := inherited SetFieldSQLVar(Instance,aValue);

    exit;

  end;

  end;

  fPropInfo.SetUnicodeStrProp(Instance,tmp);

  result := True;

end;



procedure TSQLPropInfoRTTIUnicode.GetFieldSQLVar(Instance: TObject; var aValue: TSQLVar;

  var temp: RawByteString);

begin

  temp := UnicodeStringToUtf8(fPropInfo.GetUnicodeStrProp(Instance));

  aValue.VType := ftUTF8;

  aValue.VText := Pointer(temp);

end;



{$endif HASVARUSTRING}





{ TObjArraySerializer}



type

  TObjArraySerializer = class(TPointerClassHashed)

  public

    Instance: TClassInstance;

    procedure CustomWriter(const aWriter: TTextWriter; const aValue);

    function CustomReader(P: PUTF8Char; var aValue; out aValid: Boolean): PUTF8Char;

  end;

  PTObjArraySerializer = ^TObjArraySerializer;



procedure TObjArraySerializer.CustomWriter(const aWriter: TTextWriter; const aValue);

var options: TTextWriterWriteObjectOptions;

begin

  if twoEnumSetsAsTextInRecord in aWriter.CustomOptions then

    options := [woDontStoreDefault,woSQLRawBlobAsBase64,woEnumSetsAsText] else

    options := [woDontStoreDefault,woSQLRawBlobAsBase64];

  aWriter.WriteObject(TObject(aValue), options);

end;



function TObjArraySerializer.CustomReader(P: PUTF8Char; var aValue;

  out aValid: Boolean): PUTF8Char;

begin

  if TObject(aValue)=nil then

    TObject(aValue) := Instance.CreateNew;

  result := JSONToObject(aValue,P,aValid,nil,JSONTOOBJECT_TOLERANTOPTIONS);

end;



function InternalIsObjArray(aDynArrayTypeInfo: pointer): boolean;

begin

  result := ObjArraySerializers.Find(aDynArrayTypeInfo)<>nil;

end;





{ TSQLPropInfoRTTIDynArray }



constructor TSQLPropInfoRTTIDynArray.Create(aPropInfo: PPropInfo;

  aPropIndex: integer; aSQLFieldType: TSQLFieldType);

begin

  inherited Create(aPropInfo,aPropIndex,aSQLFieldType);

  fObjArray := aPropInfo^.DynArrayIsObjArrayInstance;

  if fGetterIsFieldPropOffset=0 then

    raise EORMException.CreateUTF8('%.Create(%) getter!',[self,fPropType^.Name]);

end;



function TSQLPropInfoRTTIDynArray.GetDynArray(Instance: TObject): TDynArray;

begin

  GetDynArray(Instance,result);

end;



procedure TSQLPropInfoRTTIDynArray.GetDynArray(Instance: TObject; var result: TDynArray);

begin

  result.Init(fPropType,pointer(PtrUInt(Instance)+fGetterIsFieldPropOffset)^);

  result.IsObjArray := fObjArray<>nil; // no need to search

end;



procedure TSQLPropInfoRTTIDynArray.Serialize(Instance: TObject;

  var data: RawByteString; ExtendedJson: boolean);

var da: TDynArray;

begin

  GetDynArray(Instance,da);

  if fObjArray<>nil then

    with TJSONSerializer.CreateOwnedStream(8192) do

    try

      if ExtendedJson then

        include(fCustomOptions,twoForceJSONExtended); // smaller content

      AddDynArrayJSON(da);

      SetText(RawUTF8(data));

    finally

      Free;

    end else

    data := da.SaveTo;

end;



procedure TSQLPropInfoRTTIDynArray.CopySameClassProp(Source: TObject;

  DestInfo: TSQLPropInfo; Dest: TObject);

var SourceArray,DestArray: TDynArray;

begin

  GetDynArray(Source,SourceArray);

  TSQLPropInfoRTTIDynArray(DestInfo).GetDynArray(Dest,DestArray);

  if (fObjArray<>nil) or (TSQLPropInfoRTTIDynArray(DestInfo).fObjArray<>nil) or

     (SourceArray.ArrayType<>DestArray.ArrayType) then

    DestArray.LoadFromJSON(pointer(SourceArray.SaveToJSON)) else

    DestArray.Copy(SourceArray);

end;



procedure TSQLPropInfoRTTIDynArray.GetBinary(Instance: TObject; W: TFileBufferWriter);

var Value: RawByteString;

begin

  Serialize(Instance,Value,true);

  if fObjArray<>nil then

    W.Write(Value) else

    W.WriteBinary(Value);

end;



function TSQLPropInfoRTTIDynArray.GetHash(Instance: TObject; CaseInsensitive: boolean): cardinal;

var tmp: RawByteString;

begin

  Serialize(Instance,tmp,true);

  result := crc32c(0,pointer(tmp),length(tmp));

end;



procedure TSQLPropInfoRTTIDynArray.GetValueVar(Instance: TObject;

  ToSQL: boolean; var result: RawUTF8; wasSQLString: PBoolean);

begin

  Serialize(Instance,RawByteString(result),false);

  if fObjArray=nil then

    BinaryToText(result,ToSQL,wasSQLString);

end;



{$ifndef NOVARIANTS}



procedure TSQLPropInfoRTTIDynArray.GetVariant(Instance: TObject; var Dest: Variant);

var json: RawUTF8;

begin

  VarClear(Dest);

  json := GetDynArray(Instance).SaveToJSON;

  TDocVariantData(Dest).InitJSONInPlace(pointer(json),JSON_OPTIONS_FAST);

end;



procedure TSQLPropInfoRTTIDynArray.SetVariant(Instance: TObject; const Source: Variant);

var json: RawUTF8;

begin

  VariantSaveJSON(Source,twJSONEscape,json);

  GetDynArray(Instance).LoadFromJSON(pointer(json));

end;



{$endif NOVARIANTS}



procedure TSQLPropInfoRTTIDynArray.NormalizeValue(var Value: RawUTF8);

begin // do nothing: should already be normalized

end;



function TSQLPropInfoRTTIDynArray.CompareValue(Item1, Item2: TObject; CaseInsensitive: boolean): PtrInt;

var da1,da2: TDynArray;

begin

  if Item1=Item2 then

    result := 0 else

  if Item1=nil then

    result := -1 else

  if Item2=nil then

    result := 1 else begin

    GetDynArray(Item1,da1);

    GetDynArray(Item2,da2);

    if da1.Equals(da2) then

      result := 0 else

      result := PtrInt(Item1)-PtrInt(Item2); // pseudo comparison

  end;

end;



function TSQLPropInfoRTTIDynArray.SetBinary(Instance: TObject; P: PAnsiChar): PAnsiChar;

var tmp: TSynTempBuffer; // LoadFromJSON() may change the input buffer

    da: TDynArray;

begin

  GetDynArray(Instance,da);

  if fObjArray<>nil then begin

    FromVarString(PByte(P),tmp);

    da.LoadFromJSON(tmp.buf);

    tmp.Done;

    result := P;

  end else

    result := da.LoadFrom(P);

end;



procedure TSQLPropInfoRTTIDynArray.SetValue(Instance: TObject;

  Value: PUTF8Char; wasString: boolean);

var tmp: TSynTempBuffer;

    da: TDynArray;

begin

  GetDynArray(Instance,da);

  if Value=nil then

    da.Clear else

    try

      if (fObjArray=nil) and Base64MagicCheckAndDecode(Value,tmp) then

        da.LoadFrom(tmp.buf) else begin

        tmp.Init(Value);

        da.LoadFromJSON(tmp.buf);

      end;

    finally

      tmp.Done;

    end;

end;



function TSQLPropInfoRTTIDynArray.SetFieldSQLVar(Instance: TObject;

  const aValue: TSQLVar): boolean;

begin

  if aValue.VType=ftBlob then

    result := GetDynArray(Instance).LoadFrom(aValue.VBlob)<>nil else

    result := inherited SetFieldSQLVar(Instance,aValue);

end;



procedure TSQLPropInfoRTTIDynArray.GetJSONValues(Instance: TObject;

  W: TJSONSerializer);

var tmp: RawByteString;

begin

  if jwoAsJsonNotAsString in W.fSQLRecordOptions then

    W.AddDynArrayJSON(fPropType,GetFieldAddr(Instance)^) else

    if fObjArray<>nil then

      W.AddDynArrayJSONAsString(fPropType,GetFieldAddr(Instance)^) else begin

      Serialize(Instance,tmp,false);

      W.WrBase64(pointer(tmp),Length(tmp),true); // withMagic=true -> add ""

    end;

end;



procedure TSQLPropInfoRTTIDynArray.GetFieldSQLVar(Instance: TObject;

  var aValue: TSQLVar; var temp: RawByteString);

begin

  Serialize(Instance,temp,false);

  if fObjArray<>nil then begin

    aValue.VType := ftUTF8; // JSON

    aValue.VText := pointer(temp);

  end else begin

    aValue.VType := ftBlob; // binary

    aValue.VBlob := pointer(temp);

    aValue.VBlobLen := length(temp);

  end;

end;



function TSQLPropInfoRTTIDynArray.GetDynArrayElemType: PTypeInfo;

begin

  result := GetDynArray(nil).ElemType;

end;





{$ifndef NOVARIANTS}



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)^,Int64(Value));

end;



function NullableTimeLogToValue(const V: TNullableTimeLog): TTimeLog;

begin

  VariantToInt64(PVariant(@V)^,Int64(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() would return 'null'

    result := '' else

    VariantToUTF8(PVariant(@V)^,result,dummy);

end;





{ TSQLPropInfoRTTIVariant }



constructor TSQLPropInfoRTTIVariant.Create(aPropInfo: PPropInfo; aPropIndex: integer;

  aSQLFieldType: TSQLFieldType);

begin

  inherited;

  if aSQLFieldType=sftVariant then

    fDocVariantOptions := JSON_OPTIONS_FAST else

    fSQLFieldType := sftNullable; // TNullable* will use fSQLFieldTypeStored

end;



procedure TSQLPropInfoRTTIVariant.CopySameClassProp(Source: TObject;

  DestInfo: TSQLPropInfo; Dest: TObject);

var value: Variant;

begin

  fPropInfo.GetVariantProp(Source,value);

  TSQLPropInfoRTTIVariant(DestInfo).fPropInfo.SetVariantProp(Dest,value);

end;



procedure TSQLPropInfoRTTIVariant.GetBinary(Instance: TObject;

  W: TFileBufferWriter);

var value: Variant;

begin

  fPropInfo.GetVariantProp(Instance,value);

  W.Write(value);

end;



function TSQLPropInfoRTTIVariant.GetHash(Instance: TObject;

  CaseInsensitive: boolean): cardinal;

var Up: array[byte] of AnsiChar; // avoid slow heap allocation

    value: Variant;

  procedure ComplexType;

  var tmp: RawUTF8;

  begin // slow but always working conversion to string

    tmp := VariantSaveJSON(value,twNone);

    if CaseInsensitive then

      result := crc32c(0,Up,UpperCopy255(Up,tmp)-Up) else

      result := crc32c(0,pointer(tmp),length(tmp));

  end;

begin

  fPropInfo.GetVariantProp(Instance,value);

  with TVarData(value) do

  case VType of

    varNull, varEmpty:

      result := 0;

    varSmallint, varWord, varBoolean:

      result := VWord;

    varShortInt, varByte:

      result := VByte;

    varLongWord, varInteger, varSingle:

      result := varLongWord;

    varInt64, varDouble, varDate, varCurrency:

      result := crc32c(0,@VInt64,sizeof(Int64));

    varString:

      if CaseInsensitive then

        result := crc32c(0,Up,UpperCopy255Buf(Up,VString,length(RawUTF8(VString)))-Up) else

        result := crc32c(0,VString,length(RawUTF8(VString)));

    varOleStr {$ifdef HASVARUSTRING}, varUString{$endif}:

      if CaseInsensitive then

        result := crc32c(0,Up,UpperCopy255W(Up,VOleStr,StrLenW(VOleStr))-Up) else

        result := crc32c(0,VAny,StrLenW(VOleStr)*2);

  else

    ComplexType;

  end;

end;



procedure TSQLPropInfoRTTIVariant.GetJSONValues(Instance: TObject;

  W: TJSONSerializer);

var value: Variant;

    backup: TTextWriterOptions;

begin

  fPropInfo.GetVariantProp(Instance,value);

  backup := W.CustomOptions;

  if jwoAsJsonNotAsString in W.fSQLRecordOptions then

    W.CustomOptions := backup+[twoForceJSONStandard]-[twoForceJSONExtended];

  W.AddVariant(value,twJSONEscape); // even sftNullable should escape strings

  W.CustomOptions := backup;

end;



procedure TSQLPropInfoRTTIVariant.GetValueVar(Instance: TObject;

  ToSQL: boolean; var result: RawUTF8; wasSQLString: PBoolean);

var wasString: boolean;

    value: Variant;

begin

  fPropInfo.GetVariantProp(Instance,value);

  VariantToUTF8(value,result,wasString);

  if wasSQLString<>nil then

    if fSQLFieldType=sftNullable then

      // only TNullableUTF8Text and TNullableDateTime would be actual text

      wasSQLString^ := (fSQLDBFieldType in TEXT_DBFIELDS) and

                        not VarIsEmptyOrNull(value) else

      // from SQL point of view, variant columns are TEXT or NULL

      wasSQLString^ := not VarIsEmptyOrNull(value);

end;



procedure TSQLPropInfoRTTIVariant.GetVariant(Instance: TObject;

  var Dest: Variant);

begin

  fPropInfo.GetVariantProp(Instance,Dest);

end;



procedure TSQLPropInfoRTTIVariant.NormalizeValue(var Value: RawUTF8);

begin // content should be already normalized

end;



function TSQLPropInfoRTTIVariant.CompareValue(Item1, Item2: TObject;

  CaseInsensitive: boolean): PtrInt;



  procedure Generic;

  var V1,V2: variant;

  begin

    fPropInfo.GetVariantProp(Item1,V1);

    fPropInfo.GetVariantProp(Item2,V2);

    result := SortDynArrayVariantComp(TVarData(V1),TVarData(V2),CaseInsensitive);

  end;



begin

  if Item1=Item2 then

    result := 0 else

  if Item1=nil then

    result := -1 else

  if Item2=nil then

    result := 1 else

    if fGetterIsFieldPropOffset<>0 then // avoid any temporary variable

      result := SortDynArrayVariantComp(PVarData(PtrUInt(Item1)+fGetterIsFieldPropOffset)^,

          PVarData(PtrUInt(Item2)+fGetterIsFieldPropOffset)^,CaseInsensitive) else

      Generic;

end;



function TSQLPropInfoRTTIVariant.SetBinary(Instance: TObject; P: PAnsiChar): PAnsiChar;

var value: Variant;

begin

  if fSQLFieldType=sftNullable then

    result := VariantLoad(value,P,nil) else

    result := VariantLoad(value,P,@DocVariantOptions);

  fPropInfo.SetVariantProp(Instance,value);

end;



procedure TSQLPropInfoRTTIVariant.SetValue(Instance: TObject; Value: PUTF8Char;

  wasString: boolean);

begin

  SetValuePtr(Instance,Value,StrLen(Value),wasString);

end;



procedure TSQLPropInfoRTTIVariant.SetValueVar(Instance: TObject;

  const Value: RawUTF8; wasString: boolean);

begin

  SetValuePtr(Instance,pointer(Value),length(Value),wasString);

end;



procedure TSQLPropInfoRTTIVariant.SetValuePtr(Instance: TObject; Value: PUTF8Char;

  ValueLen: integer; wasString: boolean);

var tmp: TSynTempBuffer;

    V: Variant;

begin

  if ValueLen>0 then begin

    tmp.Init(Value,ValueLen);

    try

      if fSQLFieldType=sftNullable then

        GetVariantFromJSON(tmp.buf,wasString,V,nil) else

        GetVariantFromJSON(tmp.buf,wasString,V,@DocVariantOptions);

      fPropInfo.SetVariantProp(Instance,V);

    finally

      tmp.Done;

    end;

  end else begin

    TVarData(V).VType := varNull; // TEXT or NULL: see GetValueVar()

    fPropInfo.SetVariantProp(Instance,V);

  end;

end;



procedure TSQLPropInfoRTTIVariant.SetVariant(Instance: TObject;

  const Source: Variant);

begin

  fPropInfo.SetVariantProp(Instance,Source);

end;



{$endif NOVARIANTS}





{ TSQLPropInfoCustom }



function TSQLPropInfoCustom.GetFieldAddr(Instance: TObject): pointer;

begin

  if Instance=nil then

    result := nil else

    result := PAnsiChar(Instance)+fOffset;

end;



constructor TSQLPropInfoCustom.Create(const aName: RawUTF8;

  aSQLFieldType: TSQLFieldType; aAttributes: TSQLPropInfoAttributes;

  aFieldWidth, aPropIndex: integer; aProperty: pointer;

  aData2Text: TOnSQLPropInfoRecord2Text; aText2Data: TOnSQLPropInfoRecord2Data);

begin

  inherited Create(aName,aSQLFieldType,aAttributes,aFieldWidth,aPropIndex);

  fOffset := PtrUInt(aProperty);

  if (Assigned(aData2Text) and not Assigned(aText2Data)) or

     (Assigned(aText2Data) and not Assigned(aData2Text)) then

    raise EORMException.CreateUTF8(

      'Invalid %.Create: expecting both Data2Text/Text2Data',[self]);

  fData2Text := aData2Text;

  fText2Data := aText2Data;

end;



procedure TSQLPropInfoCustom.TextToBinary(Value: PUTF8Char; var result: RawByteString);

begin

  if Assigned(fText2Data) then

    fText2Data(Value,result) else

    result := BlobToTSQLRawBlob(Value);

end;



procedure TSQLPropInfoCustom.BinaryToText(var Value: RawUTF8; ToSQL: boolean;

  wasSQLString: PBoolean);

begin

  if Assigned(fData2Text) then

    fData2Text(UniqueRawUTF8(Value),length(Value),Value) else

    inherited BinaryToText(Value,ToSQL,wasSQLString);

end;





{ TSQLPropInfoRecordRTTI }



procedure TSQLPropInfoRecordRTTI.CopySameClassProp(Source: TObject;

  DestInfo: TSQLPropInfo; Dest: TObject);

begin

  if TSQLPropInfoRecordRTTI(DestInfo).fTypeInfo=fTypeInfo then

    RecordCopy(TSQLPropInfoRecordRTTI(DestInfo).GetFieldAddr(Dest)^,

      GetFieldAddr(Source)^,fTypeInfo) else

    inherited CopySameClassProp(Source,DestInfo,Dest);

end;



function TSQLPropInfoRecordRTTI.GetSQLFieldRTTITypeName: RawUTF8;

begin

  if fTypeInfo=nil then

    result := inherited GetSQLFieldRTTITypeName else

    result := ToUTF8(fTypeInfo^.Name);

end;



constructor TSQLPropInfoRecordRTTI.Create(aRecordInfo: PTypeInfo;

  const aName: RawUTF8; aPropertyIndex: integer; aPropertyPointer: pointer;

  aAttributes: TSQLPropInfoAttributes; aFieldWidth: integer;

  aData2Text: TOnSQLPropInfoRecord2Text; aText2Data: TOnSQLPropInfoRecord2Data);

begin

  if (aRecordInfo=nil) or not(aRecordInfo^.Kind in tkRecordTypes) then

    raise EORMException.CreateUTF8('%.Create: Invalid type information for %',[self,aName]);

  inherited Create(aName,sftBlobCustom,aAttributes,aFieldWidth,aPropertyIndex,

    aPropertyPointer,aData2Text,aText2Data);

  fTypeInfo := aRecordInfo;

end;



procedure TSQLPropInfoRecordRTTI.GetBinary(Instance: TObject; W: TFileBufferWriter);

var Value: RawByteString;

begin

  Value := RecordSave(GetFieldAddr(Instance)^,fTypeInfo);

  W.Write(pointer(Value),length(Value));

end;



function TSQLPropInfoRecordRTTI.GetHash(Instance: TObject;

  CaseInsensitive: boolean): cardinal;

var Value: RawByteString;

begin

  Value := RecordSave(GetFieldAddr(Instance)^,fTypeInfo);

  result := crc32c(0,pointer(Value),length(Value));

end;



{$ifndef NOVARIANTS}

procedure TSQLPropInfoRecordRTTI.GetVariant(Instance: TObject; var Dest: Variant);

begin

  Dest := RecordSave(GetFieldAddr(Instance)^,fTypeInfo);

end;



procedure TSQLPropInfoRecordRTTI.SetVariant(Instance: TObject; const Source: Variant);

begin

  if TVarData(Source).VType=varString then

    RecordLoad(GetFieldAddr(Instance)^,TVarData(Source).VAny,fTypeInfo) else

    RecordClear(GetFieldAddr(Instance)^,fTypeInfo);

end;

{$endif NOVARIANTS}



procedure TSQLPropInfoRecordRTTI.NormalizeValue(var Value: RawUTF8);

begin // a BLOB should already be normalized

end;



function TSQLPropInfoRecordRTTI.CompareValue(Item1, Item2: TObject;

  CaseInsensitive: boolean): PtrInt;

begin

  if RecordEquals(GetFieldAddr(Item1)^,GetFieldAddr(Item2)^,fTypeInfo) then

    result := 0 else

    result := PtrInt(Item1)-PtrInt(Item2); // pseudo comparison

end;



function TSQLPropInfoRecordRTTI.SetBinary(Instance: TObject; P: PAnsiChar): PAnsiChar;

begin

  result := RecordLoad(GetFieldAddr(Instance)^,P,fTypeInfo);

end;



procedure TSQLPropInfoRecordRTTI.SetValue(Instance: TObject; Value: PUTF8Char;

  wasString: boolean);

var data: RawByteString;

begin

  TextToBinary(Value,data);

  RecordLoad(GetFieldAddr(Instance)^,pointer(data),fTypeInfo);

end;



procedure TSQLPropInfoRecordRTTI.GetValueVar(Instance: TObject;

  ToSQL: boolean; var result: RawUTF8; wasSQLString: PBoolean);

begin

  result := RecordSave(GetFieldAddr(Instance)^,fTypeInfo);

  BinaryToText(result,ToSQL,wasSQLString);

end;



function TSQLPropInfoRecordRTTI.SetFieldSQLVar(Instance: TObject; const aValue: TSQLVar): boolean;

begin

  if aValue.VType=ftBlob then

    result := RecordLoad(GetFieldAddr(Instance)^,aValue.VBlob,fTypeInfo)<>nil else

    result := inherited SetFieldSQLVar(Instance,aValue);

end;



procedure TSQLPropInfoRecordRTTI.GetFieldSQLVar(Instance: TObject; var aValue: TSQLVar;

  var temp: RawByteString);

begin

  temp := RecordSave(GetFieldAddr(Instance)^,fTypeInfo);

  aValue.VType := ftBlob;

  aValue.VBlob := pointer(temp);

  aValue.VBlobLen := length(temp);

end;





{ TSQLPropInfoRecordFixedSize }



procedure TSQLPropInfoRecordFixedSize.CopySameClassProp(Source: TObject;

  DestInfo: TSQLPropInfo; Dest: TObject);

begin

  if TSQLPropInfoRecordFixedSize(DestInfo).fTypeInfo=fTypeInfo then

    MoveFast(GetFieldAddr(Source)^,

      TSQLPropInfoRecordFixedSize(DestInfo).GetFieldAddr(Dest)^,fRecordSize) else

    inherited CopySameClassProp(Source,DestInfo,Dest);

end;



function TSQLPropInfoRecordFixedSize.GetSQLFieldRTTITypeName: RawUTF8;

begin

  if fTypeInfo=nil then

    result := inherited GetSQLFieldRTTITypeName else

    result := ToUTF8(fTypeInfo^.Name);

end;



constructor TSQLPropInfoRecordFixedSize.Create(aRecordSize: cardinal;

  const aName: RawUTF8; aPropertyIndex: integer;

  aPropertyPointer: pointer; aAttributes: TSQLPropInfoAttributes;

  aFieldWidth: integer; aData2Text: TOnSQLPropInfoRecord2Text;

  aText2Data: TOnSQLPropInfoRecord2Data);

begin

  if integer(aRecordSize)<=0 then

    raise EORMException.CreateUTF8('%.Create: invalid % record size',[self,aRecordSize]);

  fRecordSize := aRecordSize;

  inherited Create(aName,sftBlobCustom,aAttributes,aFieldWidth,aPropertyIndex,

    aPropertyPointer,aData2Text,aText2Data);

end;



procedure TSQLPropInfoRecordFixedSize.GetBinary(Instance: TObject; W: TFileBufferWriter);

begin

  W.Write(GetFieldAddr(Instance),fRecordSize);

end;



function TSQLPropInfoRecordFixedSize.GetHash(Instance: TObject; CaseInsensitive: boolean): cardinal;

begin

  result := crc32c(0,GetFieldAddr(Instance),fRecordSize);

end;



procedure TSQLPropInfoRecordFixedSize.GetValueVar(Instance: TObject;

  ToSQL: boolean; var result: RawUTF8; wasSQLString: PBoolean);

begin

  SetRawUTF8(result,GetFieldAddr(Instance),fRecordSize);

  BinaryToText(result,ToSQL,wasSQLString);

end;



{$ifndef NOVARIANTS}

procedure TSQLPropInfoRecordFixedSize.GetVariant(Instance: TObject;

  var Dest: Variant);

var tmp: RawByteString;

begin

  SetString(tmp,PAnsiChar(GetFieldAddr(Instance)),fRecordSize);

  Dest := tmp;

end;



procedure TSQLPropInfoRecordFixedSize.SetVariant(Instance: TObject;

  const Source: Variant);

begin

  if TVarData(Source).VType=varString then

    MoveFast(TVarData(Source).VAny^,GetFieldAddr(Instance)^,fRecordSize) else

    FillcharFast(GetFieldAddr(Instance)^,fRecordSize,0);

end;

{$endif NOVARIANTS}



procedure TSQLPropInfoRecordFixedSize.NormalizeValue(var Value: RawUTF8);

begin // a BLOB should already be normalized

end;



function TSQLPropInfoRecordFixedSize.CompareValue(Item1, Item2: TObject;

  CaseInsensitive: boolean): PtrInt;

var i: Integer;

    P1,P2: PByteArray;

begin

  if (Item1=Item2) or (fRecordSize=0) then

    result := 0 else

  if Item1=nil then

    result := -1 else

  if Item2=nil then

    result := 1 else begin

    result := 0;

    P1 := GetFieldAddr(Item1);

    P2 := GetFieldAddr(Item2);

    for i := 0 to fRecordSize-1 do begin

      result := P1^[i]-P2^[i];

      if result<>0 then

        exit;

    end;

  end;

end;



function TSQLPropInfoRecordFixedSize.SetBinary(Instance: TObject; P: PAnsiChar): PAnsiChar;

begin

  if P=nil then

    FillcharFast(GetFieldAddr(Instance)^,fRecordSize,0) else

    MoveFast(P^,GetFieldAddr(Instance)^,fRecordSize);

  result := P+fRecordSize;

end;



procedure TSQLPropInfoRecordFixedSize.SetValue(Instance: TObject; Value: PUTF8Char;

  wasString: boolean);

var data: RawByteString;

begin

  TextToBinary(Value,data);

  Value := pointer(data);

  if Value=nil then

    FillcharFast(GetFieldAddr(Instance)^,fRecordSize,0) else

    MoveFast(Value^,GetFieldAddr(Instance)^,fRecordSize);

end;



function TSQLPropInfoRecordFixedSize.SetFieldSQLVar(Instance: TObject; const aValue: TSQLVar): boolean;

begin

  if aValue.VType=ftBlob then begin

    result := aValue.VBlobLen=fRecordSize;

    if result then

      MoveFast(aValue.VBlob^,GetFieldAddr(Instance)^,fRecordSize)

  end else

    result := inherited SetFieldSQLVar(Instance,aValue);

end;



procedure TSQLPropInfoRecordFixedSize.GetFieldSQLVar(Instance: TObject; var aValue: TSQLVar;

  var temp: RawByteString);

begin

  SetString(temp,PAnsiChar(GetFieldAddr(Instance)),fRecordSize);

  aValue.VType := ftBlob;

  aValue.VBlob := pointer(temp);

  aValue.VBlobLen := length(temp);

end;





{ TSQLPropInfoCustomJSON }



constructor TSQLPropInfoCustomJSON.Create(aPropInfo: PPropInfo; aPropIndex: integer);

var attrib: TSQLPropInfoAttributes;

begin

  byte(attrib) := 0;

  if aPropInfo^.IsStored(nil)=AS_UNIQUE then

    Include(attrib,aIsUnique); // property MyProperty: RawUTF8 stored AS_UNIQUE;ieldWidth=10

  Create(aPropInfo^.TypeInfo,ToUTF8(aPropInfo^.Name),

    aPropIndex,aPropInfo^.GetFieldAddr(nil),attrib,aPropInfo^.Index);

end;



constructor TSQLPropInfoCustomJSON.Create(aTypeInfo: PTypeInfo;

  const aName: RawUTF8; aPropertyIndex: integer; aPropertyPointer: pointer;

  aAttributes: TSQLPropInfoAttributes; aFieldWidth: integer);

begin

  inherited Create(aName,sftUTF8Custom,aAttributes,aFieldWidth,aPropertyIndex,

    aPropertyPointer,nil,nil);

  fTypeInfo := aTypeInfo;

  SetCustomParser(TJSONCustomParserRTTI.CreateFromRTTI(aName,aTypeInfo,0));

end;



constructor TSQLPropInfoCustomJSON.Create(const aTypeName, aName: RawUTF8;

  aPropertyIndex: integer; aPropertyPointer: pointer;

  aAttributes: TSQLPropInfoAttributes; aFieldWidth: integer);

begin

  inherited Create(aName,sftUTF8Custom,aAttributes,aFieldWidth,aPropertyIndex,

    aPropertyPointer,nil,nil);

  SetCustomParser(TJSONCustomParserRTTI.CreateFromTypeName(aName,aTypeName));

end;



function TSQLPropInfoCustomJSON.GetSQLFieldRTTITypeName: RawUTF8;

begin

  if fTypeInfo=nil then

    result := inherited GetSQLFieldRTTITypeName else

    result := ToUTF8(fTypeInfo^.Name);

end;



procedure TSQLPropInfoCustomJSON.SetCustomParser(

  aCustomParser: TJSONCustomParserRTTI);

begin

  if aCustomParser=nil then

    raise EORMException.CreateUTF8('%.SetCustomParser: Invalid type information for %',

      [self,Name]);

  fCustomParser := aCustomParser;

end;



destructor TSQLPropInfoCustomJSON.Destroy;

begin

  inherited;

  fCustomParser.Free;

end;



procedure TSQLPropInfoCustomJSON.GetBinary(Instance: TObject;

  W: TFileBufferWriter);

var JSON: RawUTF8;

begin

  GetValueVar(Instance,false,JSON,nil);

  W.Write(JSON);

end;



function TSQLPropInfoCustomJSON.SetBinary(Instance: TObject;

  P: PAnsiChar): PAnsiChar;

begin

  SetValue(Instance,pointer(FromVarString(PByte(P))),false);

  result := P;

end;



procedure TSQLPropInfoCustomJSON.NormalizeValue(var Value: RawUTF8);

begin // do nothing: should already be normalized

end;



procedure TSQLPropInfoCustomJSON.GetJSONValues(Instance: TObject;

  W: TJSONSerializer);

var Data: PByte;

begin

  Data := GetFieldAddr(Instance);

  fCustomParser.WriteOneLevel(W,Data,

    [soReadIgnoreUnknownFields,soCustomVariantCopiedByReference]);

end;



procedure TSQLPropInfoCustomJSON.GetValueVar(Instance: TObject;

  ToSQL: boolean; var result: RawUTF8; wasSQLString: PBoolean);

var W: TJSONSerializer;

begin

  W := TJSONSerializer.CreateOwnedStream;

  try

    GetJSONValues(Instance,W);

    W.SetText(result);

    if wasSQLString<>nil then

      wasSQLString^ := (result<>'') and (result[1]='"');

  finally

    W.Free;

  end;

end;



procedure TSQLPropInfoCustomJSON.SetValue(Instance: TObject;

  Value: PUTF8Char; wasString: boolean);

var Data: PByte;

    tmp: RawUTF8;

begin

  Data := GetFieldAddr(Instance);

  if Value<>nil then

  if ((Value[0]<>'{')or(Value[StrLen(Value)-1]<>'}')) and

     ((Value[0]<>'[')or(Value[StrLen(Value)-1]<>']')) then begin

    QuotedStr(Value,'"',tmp);

    Value := pointer(tmp);

  end;

  fCustomParser.ReadOneLevel(Value,Data,

    [soReadIgnoreUnknownFields,soCustomVariantCopiedByReference]);

end;





{ TSQLPropInfoList }



constructor TSQLPropInfoList.Create(aTable: TClass; aOptions: TSQLPropInfoListOptions);

begin

  fTable := aTable;

  fOptions := aOptions;

  if pilSubClassesFlattening in fOptions then

    InternalAddParentsFirst(aTable,nil) else

    InternalAddParentsFirst(aTable);

end;



destructor TSQLPropInfoList.Destroy;

var i: integer;

begin

  for i := 0 to fCount-1 do

    fList[i].Free;

  inherited;

end;



procedure TSQLPropInfoList.InternalAddParentsFirst(aClassType: TClass;

  aFlattenedProps: PPropInfoDynArray);

var P: PPropInfo;

    i,prev: Integer;

begin

  if aClassType=nil then

    exit; // no RTTI information (e.g. reached TObject level)

  if not (pilSingleHierarchyLevel in fOptions) then

    InternalAddParentsFirst(aClassType.ClassParent,aFlattenedProps);

  for i := 1 to InternalClassPropInfo(aClassType,P) do begin

    if (P^.PropType^.Kind=tkClass) and

       (P^.PropType^.ClassSQLFieldType in [sftObject,sftUnknown]) then begin

      prev := PtrArrayAdd(aFlattenedProps,P);

      InternalAddParentsFirst(P^.PropType^.ClassType^.ClassType,aFlattenedProps);

      SetLength(aFlattenedProps,prev);

    end else

      if (pilIgnoreIfGetter in fOptions) and not P^.GetterIsField then

        continue else

        Add(TSQLPropInfoRTTI.CreateFrom(P,Count,fOptions,aFlattenedProps));

    P := P^.Next;

  end;

end;



procedure TSQLPropInfoList.InternalAddParentsFirst(aClassType: TClass);

var P: PPropInfo;

    i: Integer;

begin

  if aClassType=nil then

    exit; // no RTTI information (e.g. reached TObject level)

  if not (pilSingleHierarchyLevel in fOptions) then

    InternalAddParentsFirst(aClassType.ClassParent);

  for i := 1 to InternalClassPropInfo(aClassType,P) do begin

    Add(TSQLPropInfoRTTI.CreateFrom(P,Count,fOptions,nil));

    P := P^.Next;

  end;

end;



function TSQLPropInfoList.Add(aItem: TSQLPropInfo): integer;

var f: integer;

begin

  if aItem=nil then begin

    result := -1;

    exit;

  end;

  // check that this property is not an ID/RowID (handled separately)

  if IsRowID(pointer(aItem.Name)) and not (pilAllowIDFields in fOptions) then

    raise EModelException.CreateUTF8(

      '%.Add: % should not include a "%" published property',[self,fTable,aItem.Name]);

  // check that this property name is not already defined

  for f := 0 to fCount-1 do

    if IdemPropNameU(fList[f].Name,aItem.Name) then

      raise EModelException.CreateUTF8('%.Add: % has duplicated name "%"',

        [self,fTable,aItem.Name]);

  // add to the internal list

  result := fCount;

  if result>=length(fList) then

    SetLength(fList,result+result shr 3+32);

  inc(fCount);

  fList[result] := aItem;

  fOrderedByName := nil; // force recompute sorted name array

end;



function TSQLPropInfoList.GetItem(aIndex: integer): TSQLPropInfo;

begin

  if cardinal(aIndex)>=Cardinal(fCount) then

    EORMException.Create('Invalid TSQLPropInfoList index');

  result := fList[aIndex];

end;



procedure TSQLPropInfoList.QuickSortByName(L,R: PtrInt);

var I,J,P,Tmp: PtrInt;

    pivot: PUTF8Char;

begin

  if L<R then

  repeat

    I := L; J := R;

    P := (L+R) shr 1;

    repeat

      pivot := pointer(fList[fOrderedByName[P]].fName);

      while StrIComp(pointer(fList[fOrderedByName[I]].fName),pivot)<0 do inc(I);

      while StrIComp(pointer(fList[fOrderedByName[J]].fName),pivot)>0 do dec(J);

      if I <= J then begin

        Tmp := fOrderedByName[J];

        fOrderedByName[J] := fOrderedByName[I];

        fOrderedByName[I] := Tmp;

        if P=I then P := J else if P=J then P := I;

        inc(I); dec(J);

      end;

    until I>J;

    if L<J then

      QuickSortByName(L,J);

    L := I;

  until I >= R;

end;



function TSQLPropInfoList.ByRawUTF8Name(const aName: RawUTF8): TSQLPropInfo;

var i: integer;

begin

  i := IndexByName(pointer(aName));

  if i<0 then

    result := nil else

    result := fList[i];

end;



function TSQLPropInfoList.ByName(aName: PUTF8Char): TSQLPropInfo;

var i: integer;

begin

  i := IndexByName(aName);

  if i<0 then

    result := nil else

    result := fList[i];

end;



function TSQLPropInfoList.IndexByName(aName: PUTF8Char): integer;

var cmp,L,R: integer;

begin

  if (self<>nil) and (aName<>nil) and (fCount>0) then

  if fCount<5 then begin

    for result := 0 to fCount-1 do

      if StrIComp(pointer(fList[result].fName),aName)=0 then

        exit;

  end else begin

    if fOrderedByName=nil then begin

      SetLength(fOrderedByName,fCount);

      FillIncreasing(pointer(fOrderedByName),0,fCount);

      QuickSortByName(0,fCount-1);

    end;

    L := 0;

    R := fCount-1;

    repeat

      result := (L+R)shr 1;

      cmp := StrIComp(pointer(fList[fOrderedByName[result]].fName),aName);

      if cmp=0 then begin

        result := fOrderedByName[result];

        exit;

      end;

      if cmp<0 then

        L := result+1 else

        R := result-1;

    until L>R;

  end;

  result := -1;

end;



function TSQLPropInfoList.IndexByName(const aName: RawUTF8): integer;

begin

  result := IndexByName(pointer(aName));

end;



function TSQLPropInfoList.IndexByNameOrExcept(const aName: RawUTF8): integer;

begin

  if IsRowID(pointer(aName)) then

    result := -1 else begin

    result := IndexByName(pointer(aName)); // fast binary search

    if result<0 then

      raise EORMException.CreateUTF8(

        '%.IndexByNameOrExcept(%): unkwnown field in %',[self,aName,fTable]);

  end;

end;



procedure TSQLPropInfoList.IndexesByNamesOrExcept(const aNames: array of RawUTF8;

  const aIndexes: array of PInteger);

var i: integer;

begin

  if high(aNames)<>high(aIndexes) then

    raise EORMException.CreateUTF8('%.IndexesByNamesOrExcept(?)',[self]);

  for i := 0 to high(aNames) do

    if aIndexes[i]=nil then

      raise EORMException.CreateUTF8('%.IndexesByNamesOrExcept(aIndexes[%]=nil)',[self,aNames[i]]) else

      aIndexes[i]^ := IndexByNameOrExcept(aNames[i]);

end;



procedure TSQLPropInfoList.NamesToRawUTF8DynArray(var Names: TRawUTF8DynArray);

var i: integer;

begin

  SetLength(Names,Count);

  for i := 0 to Count-1 do

    Names[i] := fList[i].Name;

end;



function TSQLPropInfoList.IndexByNameUnflattenedOrExcept(const aName: RawUTF8): integer;

begin

  if pilSubClassesFlattening in fOptions then begin

    for result := 0 to Count-1 do

      if IdemPropNameU(List[result].NameUnflattened,aName) then

        exit;

  end else begin

    result := IndexByName(pointer(aName)); // faster binary search

    if result>=0 then

      exit;

  end;

  raise EORMException.CreateUTF8(

    '%.IndexByNameUnflattenedOrExcept(%): unkwnown field in %',[self,aName,fTable]);

end;





procedure StatusCodeToErrorMsg(Code: integer; var result: RawUTF8);

begin // see http://www.w3.org/Protocols/rfc2616/rfc2616-sec10.html

  case Code of

    HTML_CONTINUE:            result := 'Continue';

    HTML_SWITCHINGPROTOCOLS:  result := 'Switching Protocols';

    HTML_SUCCESS:             result := 'OK';

    HTML_CREATED:             result := 'Created';

    HTML_ACCEPTED:            result := 'Accepted';

    HTML_NONAUTHORIZEDINFO:   result := 'Non-Authoritative Information';

    HTML_NOCONTENT:           result := 'No Content';

    HTML_MULTIPLECHOICES:     result := 'Multiple Choices';

    HTML_MOVEDPERMANENTLY:    result := 'Moved Permanently';

    HTML_FOUND:               result := 'Found';

    HTML_SEEOTHER:            result := 'See Other';

    HTML_NOTMODIFIED:         result := 'Not Modified';

    HTML_USEPROXY:            result := 'Use Proxy';

    HTML_TEMPORARYREDIRECT:   result := 'Temporary Redirect';

    HTML_BADREQUEST:          result := 'Bad Request';

    HTML_UNAUTHORIZED:        result := 'Unauthorized';

    HTML_FORBIDDEN:           result := 'Forbidden';

    HTML_NOTFOUND:            result := 'Not Found';

    HTML_NOTALLOWED:          result := 'Method Not Allowed';

    HTML_NOTACCEPTABLE:       result := 'Not Acceptable';

    HTML_PROXYAUTHREQUIRED:   result := 'Proxy Authentication Required';

    HTML_TIMEOUT:             result := 'Request Timeout';

    HTML_SERVERERROR:         result := 'Internal Server Error';

    HTML_BADGATEWAY:          result := 'Bad Gateway';

    HTML_GATEWAYTIMEOUT:      result := 'Gateway Timeout';

    HTML_UNAVAILABLE:         result := 'Service Unavailable';

    HTML_HTTPVERSIONNONSUPPORTED: result := 'HTTP Version Not Supported';

    else                      result := 'Invalid Request';

  end;

end;



function StatusCodeToErrorMsg(Code: integer): RawUTF8;

begin

  StatusCodeToErrorMsg(Code,result);

  result := FormatUTF8('HTTP Error % - %',[Code,result]);

end;



function StatusCodeIsSuccess(Code: integer): boolean;

begin

  case Code of

  HTML_SUCCESS, HTML_NOCONTENT, HTML_CREATED,

  HTML_NOTMODIFIED, HTML_TEMPORARYREDIRECT:

    result := true;

  else

    result := false;

  end;

end;



function StringToMethod(const method: RawUTF8): TSQLURIMethod;

const NAME: array[mGET..high(TSQLURIMethod)] of string[11] = ( // sorted by occurence

  'GET','POST','PUT','DELETE','HEAD','BEGIN','END','ABORT','LOCK','UNLOCK','STATE',

  'OPTIONS','PROPFIND','PROPPATCH','TRACE','COPY','MKCOL','MOVE','PURGE','REPORT',

  'MKACTIVITY','MKCALENDAR','CHECKOUT','MERGE','NOTIFY','PATCH','SEARCH','CONNECT');

var URIMethodUp: string[11];

begin

  if Length(method)<11 then begin

    URIMethodUp[0] := AnsiChar(UpperCopy(@URIMethodUp[1],method)-@URIMethodUp[1]);

    for result := low(NAME) to high(NAME) do

      if URIMethodUp=NAME[result] then

        exit;

  end;

  result := mNone;

end;







{ ******************* process monitoring / statistics }



{ TSynMonitorUsage }



function MonitorPropUsageValue(info: PPropInfo): TSynMonitorType;

var typ: pointer;

begin

  typ := info^.TypeInfo;

  if typ=TypeInfo(TSynMonitorTotalMicroSec) then

    result := smvMicroSec else

  if typ=TypeInfo(TSynMonitorOneMicroSec) then

    result := smvOneMicroSec else

  if typ=TypeInfo(TSynMonitorTotalBytes) then

    result := smvBytes else

  if typ=TypeInfo(TSynMonitorOneBytes) then

    result := smvOneBytes else

  if typ=TypeInfo(TSynMonitorBytesPerSec) then

    result := smvBytesPerSec else

  if typ=TypeInfo(TSynMonitorCount) then

    result := smvCount else

  if typ=TypeInfo(TSynMonitorCount64) then

    result := smvCount64 else

    result := smvUndefined;

end;



function TSynMonitorUsage.Track(Instance: TObject; const Name: RawUTF8): integer;



  procedure ClassTrackProps(ClassType: TClass; var Props: TSynMonitorUsageTrackPropDynArray);

  var i,n: integer;

      nfo: PPropInfo;

      k: TSynMonitorType;

      g: TSynMonitorUsageGranularity;

      p: PSynMonitorUsageTrackProp;

      parent: TClass;

  begin

    n := length(Props);

    while ClassType<>nil do begin

      parent := ClassType.ClassParent;

      for i := 1 to InternalClassPropInfo(ClassType,nfo) do begin

        k := MonitorPropUsageValue(nfo);

        if k<>smvUndefined then begin

          SetLength(Props,n+1);

          p := @Props[n];

          p^.Info := nfo;

          p^.Kind := k;

          ShortStringToAnsi7String(nfo^.Name,p^.Name);

          if (parent<>nil) and (FindPropName(['Bytes','MicroSec'],p^.Name)>=0) then

            p^.Name := RawUTF8(parent.ClassName); // meaningful property name

          for g := mugHour to mugYear do

            SetLength(p^.Values[g],USAGE_VALUE_LEN[g]);

          if k in SYNMONITORVALUE_CUMULATIVE then

            p^.CumulativeLast := nfo^.GetInt64Value(Instance);

          inc(n);

        end;

        nfo := nfo^.Next;

      end;

      ClassType := parent;

    end;

  end;



var i,n: integer;

    instanceName: RawUTF8;

begin

  result := -1;

  if Instance=nil then

    exit; // nothing to track

  if (Name='') and Instance.InheritsFrom(TSynMonitor) then

    instanceName := TSynMonitor(Instance).Name else

    instanceName := Name;

  if instanceName='' then

    instanceName := RawUTF8(Instance.ClassName);

  fSafe.Lock;

  try

    n := length(fTracked);

    for i := 0 to n-1 do

      if fTracked[i].Instance=Instance then

        exit else

      if IdemPropNameU(fTracked[i].Name,instanceName) then

        raise ESynException.CreateUTF8('%.Track("%") name already exists',[self,instanceName]);

    SetLength(fTracked,n+1);

    fTracked[n].Instance := Instance;

    fTracked[n].Name := instanceName;

    ClassTrackProps(Instance.ClassType,fTracked[n].Props);

    if fTracked[n].Props=nil then

      // nothing to track

      SetLength(fTracked,n) else begin

      result := n; // returns the index of the added item

      if fPrevious.Value<>0 then

        LoadTrack(fTracked[n]);

    end;

  finally

    fSafe.UnLock;

  end;

end;



procedure TSynMonitorUsage.Track(const Instances: array of TSynMonitor);

var i: integer;

begin

  if self<>nil then

    for i := 0 to high(Instances) do

      Track(Instances[i],Instances[i].Name);

end;



function TSynMonitorUsage.TrackPropLock(Instance: TObject;

  Info: PPropInfo): PSynMonitorUsageTrackProp;

var i,j: integer;

begin

  fSafe.Lock;

  for i := 0 to length(fTracked)-1 do

    if fTracked[i].Instance=Instance then

    with fTracked[i] do begin

      for j := 0 to length(Props)-1 do

        if Props[j].Info=Info then begin

          result := @Props[j];

          exit; // returned found entry locked

        end;

      break;

    end;

  fSafe.UnLock;

  result := nil;

end;



const

  // maps TTimeLogbits mask

  TL_MASK_SECONDS = pred(1 shl 6);

  TL_MASK_MINUTES = pred(1 shl 12);

  TL_MASK_HOURS = pred(1 shl 17);

  TL_MASK_DAYS = pred(1 shl 22);

  TL_MASK_MONTHS = pred(1 shl 26);

  // truncates a TTimeLogbits value to a granularity

  AS_MINUTES = not TL_MASK_SECONDS;

  AS_HOURS = not TL_MASK_MINUTES;

  AS_DAYS = not TL_MASK_HOURS;

  AS_MONTHS = not TL_MASK_DAYS;

  AS_YEARS = not TL_MASK_MONTHS;



procedure TSynMonitorUsage.Modified(Instance: TObject);

begin

  if self<>nil then

    Modified(Instance,[]);

end;



procedure TSynMonitorUsage.SetCurrentUTCTime(out minutes: TTimeLogBits);

begin

  minutes.FromUTCTime;

end;



procedure TSynMonitorUsage.Modified(Instance: TObject;

  const PropNames: array of RawUTF8);

  procedure save(const track: TSynMonitorUsageTrack);

    function scope(var prev,current: Int64): TSynMonitorUsageGranularity;

    begin

      if prev and AS_YEARS<>current and AS_YEARS then

        result := mugYear else

      if prev and AS_MONTHS<>current and AS_MONTHS then

        result := mugMonth else

      if prev and AS_DAYS<>current and AS_DAYS then

        result := mugDay else

      if prev and AS_HOURS<>current and AS_HOURS then

        result := mugHour else

      if prev<>current then

        result := mugMinute else

        result := mugUndefined;

    end;

  var j,k,min: integer;

      time: TTimeLogBits;

      v,diff: Int64;

  begin

    SetCurrentUTCTime(time);

    time.Value := time.Value and AS_MINUTES; // save every minute

    if fPrevious.Value<>time.Value then begin

      if fPrevious.Value=0 then // startup?

        Load(time) else

        SavePrevious(scope(fPrevious.Value,time.Value));

      fPrevious.Value := time.Value;

    end;

    min := time.Minute;

    for j := 0 to length(track.Props)-1 do

      with track.Props[j] do

      if (high(PropNames)<0) or (FindPropName(PropNames,Name)>=0) then begin

        v := Info^.GetInt64Value(Instance);

        if Kind in SYNMONITORVALUE_CUMULATIVE then begin

          diff := v-CumulativeLast;

          if diff<>0 then begin

            CumulativeLast := v;

            inc(Values[mugHour][min],diff);

            inc(Values[mugDay][time.Hour],diff); // propagate

            inc(Values[mugMonth][time.Day],diff);

            inc(Values[mugYear][time.Month],diff);

          end;

        end else

          for k := min to 59 do // make instant values continous

            Values[mugHour][min] := v;

      end;

  end;

var i: integer;

begin

  if Instance=nil then

    exit;

  fSafe.Lock;

  try

    for i := 0 to length(fTracked)-1 do

    if fTracked[i].Instance=Instance then begin

      save(fTracked[i]);

      exit;

    end;

    if Instance.InheritsFrom(TSynMonitor) and

       (TSynMonitor(Instance).Name<>'') then begin

      i := Track(Instance,TSynMonitor(Instance).Name);

      if i>=0 then

        save(fTracked[i]);

      exit;

    end;

  finally

    fSafe.UnLock;

  end;

end;



destructor TSynMonitorUsage.Destroy;

begin

  SavePrevious(mugUndefined); // save pending values for all granularities

  inherited Destroy;

end;



procedure TSynMonitorUsage.SavePrevious(Scope: TSynMonitorUsageGranularity);

var g: TSynMonitorUsageGranularity;

    id: TSynMonitorUsageID;

begin

  id.FromTimeLog(fPrevious.Value);

  Save(id,mugHour,Scope); // always save current minutes values

  for g := mugDay to mugYear do

    if (Scope<>mugUndefined) and (g>Scope) then

      break else // mugUndefined from Destroy

      Save(id,g,Scope);

end;



procedure TSynMonitorUsage.Save(ID: TSynMonitorUsageID;

  Gran,Scope: TSynMonitorUsageGranularity);

var t,n,p: Integer;

    track: PSynMonitorUsageTrack;

    data,val: TDocVariantData;

begin

  TDocVariant.IsOfTypeOrNewFast(fValues[Gran]);

  for t := 0 to length(fTracked)-1 do begin

    track := @fTracked[t];

    n := length(track^.Props);

    data.InitFast(n,dvObject);

    for p := 0 to n-1 do

    with track^.Props[p] do

      if not IsZero(Values[Gran]) then begin

        // save non void values

        val.InitArrayFrom(Values[Gran],JSON_OPTIONS_FAST);

        data.AddValue(Name,Variant(val));

        val.Clear;

        // handle local cache

        if Kind in SYNMONITORVALUE_CUMULATIVE then begin

          if Gran<=Scope then // reset of cumulative values

            FillZero(Values[Gran]);

        end else begin

          if Gran<mugYear then // propagate instant values

            // e.g. Values[mugDay][hour] := Values[mugHour][minute] (=v)

            Values[succ(Gran)][ID.GetTime(Gran)] :=

              Values[Gran][ID.GetTime(pred(Gran))];

        end;

      end;

    _Safe(fValues[Gran]).AddOrUpdateValue(track^.Name,variant(data));

    data.Clear;

  end;

  _Safe(fValues[Gran]).SortByName;

  ID.Truncate(Gran);

  if not SaveDB(ID.Value,fValues[Gran],Gran) then

    fLog.SynLog.Log(sllWarning,'%.Save(ID=%=%,%) failed',

      [ClassType,ID.Value,ID.Text(true),ToText(Gran)^]);

end;



procedure TSynMonitorUsage.LoadTrack(var Track: TSynMonitorUsageTrack);

var p,v: Integer;

    g: TSynMonitorUsageGranularity;

    val,int: PDocVariantData;

begin // fValues[] variants -> fTracked[].Props[].Values[]

  for g := low(fValues) to high(fValues) do

    with _Safe(fValues[g])^ do begin

      val := GetAsDocVariantSafe(Track.Name);

      if val<>nil then

      for p := 0 to length(Track.Props)-1 do

        with Track.Props[p] do

        if val^.GetAsDocVariant(Name,int) and

           (int^.Count>0) and (int^.Kind=dvArray) then begin

          for v := 0 to length(Values[g])-1 do

            if v<int^.Count then

              Values[g][v] := VariantToInt64Def(int^.Values[v],0);

        end;

    end;

end;



function TSynMonitorUsage.Load(const Time: TTimeLogBits): boolean;

var g: TSynMonitorUsageGranularity;

    id: TSynMonitorUsageID;

    t: integer;

begin

  // load fValues[] variants

  result := true;

  id.FromTimeLog(Time.Value);

  for g := low(fValues) to high(fValues) do begin

    id.Truncate(g);

    if not LoadDB(id.Value,g,fValues[g]) then

      result := false;

  end;

  // fill fTracked[].Props[].Values[]

  for t := 0 to length(fTracked)-1 do

    LoadTrack(fTracked[t]);

end;





{ TSynMonitorUsageID }



procedure TSynMonitorUsageID.From(Y, M, D, H: integer);

begin

  Value := H+(D-1) shl USAGE_ID_SHIFT[mugDay]+

    (M-1) shl USAGE_ID_SHIFT[mugMonth]+(Y-USAGE_ID_YEAROFFSET)shl USAGE_ID_SHIFT[mugYear];

end;



procedure TSynMonitorUsageID.From(Y, M, D: integer);

begin

  Value := USAGE_ID_HOURMARKER[mugDay]+(D-1) shl USAGE_ID_SHIFT[mugDay]+

    (M-1) shl USAGE_ID_SHIFT[mugMonth]+(Y-USAGE_ID_YEAROFFSET)shl USAGE_ID_SHIFT[mugYear];

end;



procedure TSynMonitorUsageID.From(Y, M: integer);

begin

  Value := USAGE_ID_HOURMARKER[mugMonth]+(M-1) shl USAGE_ID_SHIFT[mugMonth]+

    (Y-USAGE_ID_YEAROFFSET)shl USAGE_ID_SHIFT[mugYear];

end;



procedure TSynMonitorUsageID.From(Y: integer);

begin

  Value := USAGE_ID_HOURMARKER[mugYear]+(Y-USAGE_ID_YEAROFFSET)shl USAGE_ID_SHIFT[mugYear];

end;



procedure TSynMonitorUsageID.FromTimeLog(const TimeLog: TTimeLog);

var bits: TTimeLogBits absolute TimeLog;

begin

  Value := bits.Hour+(bits.Day-1) shl USAGE_ID_SHIFT[mugDay]+

    (bits.Month-1) shl USAGE_ID_SHIFT[mugMonth]+

    (bits.Year-USAGE_ID_YEAROFFSET)shl USAGE_ID_SHIFT[mugYear];

end;



procedure TSynMonitorUsageID.FromNowUTC;

var now: TTimeLogBits;

begin

  now.FromUTCTime;

  From(now.Value);

end;



function TSynMonitorUsageID.GetTime(gran: TSynMonitorUsageGranularity): integer;

begin

  if not (gran in [low(USAGE_ID_SHIFT)..high(USAGE_ID_SHIFT)]) then

    result := 0 else begin

    result := (Value shr USAGE_ID_SHIFT[gran]) and USAGE_ID_MASK[gran];

    case gran of

    mugYear:

      inc(result,USAGE_ID_YEAROFFSET);

    mugDay, mugMonth:

      inc(result);

    mugHour:

      if cardinal(result)>USAGE_ID_MAX[mugHour] then

        result := 0; // stored fake USAGE_ID_HOURMARKER[mugDay..mugYear] value

    end;

  end;

end;



function TSynMonitorUsageID.Granularity: TSynMonitorUsageGranularity;

var h: integer;

begin

  h := Value and USAGE_ID_MASK[mugHour];

  if cardinal(h)>USAGE_ID_MAX[mugHour] then begin

    for result := mugDay to mugYear do

      if USAGE_ID_HOURMARKER[result]=h then

        exit;

    result := mugUndefined; // should not happen

  end else

    result := mugHour;

end;



procedure TSynMonitorUsageID.Truncate(gran: TSynMonitorUsageGranularity);

begin

  if gran>mugHour then

    Value := Value and (not USAGE_ID_MASK[mugHour]) or USAGE_ID_HOURMARKER[gran];

end;



procedure TSynMonitorUsageID.SetTime(gran: TSynMonitorUsageGranularity; aValue: integer);

begin

  case gran of

  mugYear: dec(aValue,USAGE_ID_YEAROFFSET);

  mugDay, mugMonth: dec(aValue);

  mugHour: ;

  else raise ERangeError.CreateFmt('SetValue(%s)',[ToText(gran)^]);

  end;

  if cardinal(aValue)>USAGE_ID_MAX[gran] then

    raise ERangeError.CreateFmt('%s should be 0..%d',[ToText(gran)^,USAGE_ID_MAX[gran]]);

  Value := (Value and (not (USAGE_ID_MASK[gran] shl USAGE_ID_SHIFT[gran])))

     or (aValue shl USAGE_ID_SHIFT[gran]);

end;



function TSynMonitorUsageID.Text(Expanded: boolean;

  FirstTimeChar: AnsiChar): RawUTF8;

var bits: TTimeLogBits;

begin

  bits.Value := ToTimeLog;

  result := bits.Text(Expanded,FirstTimeChar);

end;



function TSynMonitorUsageID.ToTimeLog: TTimeLog;

begin

  PTimeLogBits(@result)^.From(

    GetTime(mugYear),GetTime(mugMonth),GetTime(mugDay),GetTime(mugHour),0,0);

end;







{ ************ main ORM / SOA classes and types }



{ TSQLTable }



function TSQLTable.FieldIndex(FieldName: PUTF8Char): integer;

begin

  if (self<>nil) and (fResults<>nil) and (FieldName<>nil) and (FieldCount>0) then

    if IsRowID(FieldName) then begin // will work for both 'ID' or 'RowID'

      result := fFieldIndexID;

      exit;

    end else

    if FieldCount<4 then begin

      for result := 0 to FieldCount-1 do

        if StrIComp(fResults[result],FieldName)=0 then

          exit;

    end else begin

      if fFieldNameOrder=nil then

        QuickSortIndexedPUTF8Char(fResults,FieldCount,fFieldNameOrder);

      result := FastFindIndexedPUTF8Char(fResults,FieldCount-1,fFieldNameOrder,

        FieldName,@StrIComp);

      exit;

    end;

  result := -1;

end;



function TSQLTable.FieldIndex(const FieldName: RawUTF8): integer;

begin

  result := FieldIndex(Pointer(FieldName));

end;



function TSQLTable.FieldIndexExisting(const FieldName: RawUTF8): integer;

begin

  result := FieldIndex(Pointer(FieldName));

  if result<0 then

    raise ESQLTableException.CreateUTF8('%.FieldIndexExisting("%")',[self,FieldName]);

end;



procedure TSQLTable.FieldIndex(const FieldNames: array of RawUTF8;

  const FieldIndexes: array of PInteger);

var i: integer;

begin

  if high(FieldNames)<0 then

    exit;

  if high(FieldNames)<>high(FieldIndexes) then

    raise ESQLTableException.CreateUTF8('%.FieldIndex() argument count',[self]);

  for i := 0 to high(FieldNames) do

    if FieldIndexes[i]=nil then

      raise ESQLTableException.CreateUTF8(

        '%.FieldIndex() FieldIndexes["%"]=nil',[self,FieldNames[i]]) else

      FieldIndexes[i]^ := FieldIndex(pointer(FieldNames[i]));

end;



procedure TSQLTable.FieldIndexExisting(const FieldNames: array of RawUTF8;

  const FieldIndexes: array of PInteger);

var i: integer;

begin

  if high(FieldNames)<0 then

    exit;

  if high(FieldNames)<>high(FieldIndexes) then

    raise ESQLTableException.CreateUTF8('%.FieldIndexExisting() argument count',[self]);

  for i := 0 to high(FieldNames) do

    if FieldIndexes[i]=nil then

      raise ESQLTableException.CreateUTF8(

        '%.FieldIndexExisting() FieldIndexes["%"]=nil',[self,FieldNames[i]]) else

      FieldIndexes[i]^ := FieldIndexExisting(FieldNames[i]);

end;



function TSQLTable.FieldNames: TRawUTF8DynArray;

begin

  if length(fFieldNames)<>fFieldCount then

    InitFieldNames;

  result := fFieldNames;

end;



function TSQLTable.FieldValue(const FieldName: RawUTF8; Row: integer): PUTF8Char;

var Index: integer;

begin

  Index := FieldIndex(pointer(FieldName));

  if (Index<0) or (cardinal(Row-1)>=cardinal(fRowCount)) then

    result := nil else

    result := fResults[Index+Row*FieldCount];

end;



procedure TSQLTable.SortBitsFirst(var Bits);

var oldIDColumn, oldResults: array of PUTF8Char;

    i, j, nSet, n: integer;

    R: PPUTF8Char;

begin

  if fIDColumn<>nil then begin

    n := length(fIDColumn);

    SetLength(oldIDColumn,n);

    MoveFast(fIDColumn[0],oldIDColumn[0],n*sizeof(PUTF8Char));

  end;

  i := (fRowCount+1)*FieldCount;

  SetLength(oldResults,i);

  MoveFast(fResults[0],oldResults[0],i*sizeof(PUTF8Char));

  // put marked IDs first

  n := 1; // copy row data (first row=0 i.e. idents is left as it is)

  R := @fResults[FieldCount];

  j := FieldCount;

  for i := 1 to fRowCount do begin

    if GetBit(Bits,i-1) then begin

      if fIDColumn<>nil then

        fIDColumn[n] := oldIDColumn[i];

      MoveFast(oldResults[j],R^,FieldCount*sizeof(PUTF8Char));

      inc(n);

      inc(R,FieldCount);

    end;

    inc(j,FieldCount);

  end;

  nSet := n-1;

  // put unmarked IDs

  j := FieldCount;

  for i := 1 to fRowCount do begin

    if not GetBit(Bits,i-1) then begin

      if fIDColumn<>nil then

        fIDColumn[n] := oldIDColumn[i];

      MoveFast(oldResults[j],R^,FieldCount*sizeof(PUTF8Char));

      inc(n);

      inc(R,FieldCount);

    end;

    inc(j,FieldCount);

  end;

  assert(n-1=fRowCount);

  // recalcultate Bits[]

  FillcharFast(Bits,(fRowCount shr 3)+1,0);

  for i := 0 to nSet-1 do

    SetBit(Bits,i); // slow but accurate

  {$ifdef FPC}

  Finalize(oldIDColumn); // alf: to circumvent FPC issues

  Finalize(oldResults);

  {$endif}

end;



function TSQLTable.IDColumnHide: boolean;

var FID,R,F: integer;

    S,D1,D2: PPUTF8Char;

begin

  // 1. check if possible

  result := false;

  if (self=nil) or Assigned(fIDColumn) or (FieldCount<=1) then

    exit; // already hidden or not possible

  FID := fFieldIndexID;

  if FID<0 then

    exit; // no 'ID' field

  // 2. alloc new arrays of PUTF8Char

  dec(fFieldCount);

  R := fRowCount+1;

  SetLength(fIDColumn,R);               // will contain the ID column data

  SetLength(fNotIDColumn,R*FieldCount); // will be the new fResults[]

  // 3. copy fResults[] into new arrays

  S := @fResults[0];

  D1 := @fNotIDColumn[0];

  D2 := @fIDColumn[0];

  for R := 0 to fRowCount do

    for F := 0 to FieldCount do begin // we have FieldCount := FieldCount-1

      if F<>FID then begin

        D1^ := S^; // copy not ID column into fNotIDColumn[]

        inc(D1);

      end else begin

        D2^ := S^; // copy ID column into fIDColumn[]

        inc(D2);

      end;

      inc(S);

    end;

  // 4. TSQLTable data now points to new values without ID field

  result := true;

  fResults := @fNotIDColumn[0];

end;



function TSQLTable.IDColumnHiddenValue(Row: integer): TID;

begin

  if (self=nil) or (fResults=nil) or (Row<=0) or (Row>fRowCount) then

    result := 0 else

    if Assigned(fIDColumn) then // get hidden ID column UTF-8 content

      SetID(fIDColumn[Row],result) else

      if fFieldIndexID>=0 then // get ID column field index

        SetID(fResults[Row*FieldCount+fFieldIndexID],result) else

        result := 0;

end;



procedure TSQLTable.IDArrayFromBits(const Bits; var IDs: TIDDynArray);

var n, i, FID: integer;

begin

  if not Assigned(fIDColumn) then begin

    FID := fFieldIndexID; // get ID column field index

    if FID<0 then

      exit;

  end else

    FID := 0; // make compiler happy

  n := GetBitsCount(Bits,fRowCount);

  if n=fRowCount then begin

    IDColumnHiddenValues(IDs); // all selected -> direct get all IDs

    exit;

  end;

  SetLength(IDs,n);

  if n=0 then

    exit;

  n := 0;

  if Assigned(fIDColumn) then begin

    for i := 1 to fRowCount do

    if GetBit(Bits,i-1) then begin

      IDs[n] := GetInt64(fIDColumn[i]); // get hidden ID column UTF-8 content

      inc(n);

    end;

  end else begin

    inc(FID,FieldCount); // [i*FieldCount+FID] = [(i+1)*FieldCount+FID] below

    for i := 0 to fRowCount-1 do

    if GetBit(Bits,i) then begin

      IDs[n] := GetInt64(fResults[i*FieldCount+FID]); // get ID column UTF-8 content

      inc(n);

    end;

  end;

end;



procedure TSQLTable.IDColumnHiddenValues(var IDs: TIDDynArray);

var n, i, FID: integer;

    U: PPUTF8Char;

begin

  n := fRowCount;

  if not Assigned(fIDColumn) then begin

    FID := fFieldIndexID; // get ID column field index

    if FID<0 then

      n := 0;

  end else

    FID := 0;

  SetLength(IDs,n);

  if n=0 then

    exit;

  if Assigned(fIDColumn) then begin

    for i := 1 to fRowCount do

      IDs[i-1] := GetInt64(fIDColumn[i]); // get hidden ID column UTF-8 content

  end else begin

    U := @fResults[FID+FieldCount];  // U^ = ID column UTF-8 content

    for i := 0 to fRowCount-1 do begin

      IDs[i] := GetInt64(U^);

      inc(U,FieldCount);

    end;

  end;

end;



procedure TSQLTable.IDArrayToBits(var Bits; var IDs: TIDDynArray);

var i,FID: integer;

    U: PPUTF8Char;

    ID: Pointer;

    IDn: integer;

//    AllID: : TIDDynArray;

begin

  if length(IDs)=RowCount then begin

    FillcharFast(Bits,(RowCount shr 3)+1,255); // all selected -> all bits set to 1

    exit;

  end;

  FillcharFast(Bits,(RowCount shr 3)+1,0);

  if IDs=nil then

    exit; // no selected -> all bits left to 0

  // we sort IDs to use FastFindIntegerSorted() and its fast binary search

  ID := @IDs[0];

  IDn := high(IDs);

  QuickSortInt64(ID,0,IDn);

  if not Assigned(fIDColumn) then begin

    FID := fFieldIndexID; // get ID column field index

    if FID<0 then

      exit; // no ID column -> unable to get bit index

  end else

    FID := 0; // make compiler happy

  if Assigned(fIDColumn) then begin

    for i := 1 to RowCount do

      if FastFindInt64Sorted(ID,IDn,GetInt64(fIDColumn[i]))>=0 then

        SetBit(Bits,i-1);

  end else begin

    U := @fResults[FID+FieldCount];  // U^ = ID column UTF-8 content

    for i := 0 to RowCount-1 do begin

      if FastFindInt64Sorted(ID,IDn,GetInt64(U^))>=0 then

        SetBit(Bits,i);

      inc(U,FieldCount);

    end;

  end;

{  // debugg:

  IDArrayFromBits(Bits,AllID);

  assert(length(AllID)=length(IDs));

  QuickSortInteger(@AllID[0],0,high(AllID));

  QuickSortInteger(@IDs[0],0,high(IDs));

  assert(comparemem(@AllID[0],@IDs[0],length(AllID)*sizeof(TID))); }

end;



function TSQLTable.RowFromID(aID: TID): integer;

var ID: RawUTF8;

    FID: integer;

    U: PPUTF8Char;

begin

  if self=nil then begin

    result := -1;

    exit;

  end;

  if (fResults<>nil) and (aID>0) then begin

    // search aID as UTF-8 in fIDColumn[] or fResults[]

    Int64ToUtf8(aID,ID);

    if Assigned(fIDColumn) then begin // get hidden ID column UTF-8 content

      for result := 1 to fRowCount do

        if StrComp(fIDColumn[result],pointer(ID))=0 then

          exit;

    end else begin

      FID := fFieldIndexID;  // get ID column field index

      if FID>=0 then begin

        U := @fResults[FID+FieldCount];  // U^ = ID column UTF-8 content

        for result := 1 to fRowCount do

          if StrComp(U^,pointer(ID))=0 then

            exit else

            inc(U,FieldCount);

      end;

    end;

  end;

  result := fRowCount; // not found -> return last row index

end;



procedure TSQLTable.DeleteRow(Row: integer);

begin

  if (self=nil) or (Row<1) or (Row>fRowCount) then

    exit; // out of range

  if Assigned(fIDColumn) then

    if Row<fRowCount then

      MoveFast(fIDColumn[Row+1],fIDColumn[Row],(fRowCount-Row)*sizeof(PUTF8Char));

  if Row<fRowCount then begin

    Row := Row*FieldCount; // convert row index into position in fResults[]

    MoveFast(fResults[Row+FieldCount],fResults[Row],(fRowCount*FieldCount-Row)*sizeof(pointer));

  end;

  dec(fRowCount);

end;



procedure TSQLTable.InitFieldNames;

var f: integer;

    P: PUTF8Char;

begin

  SetLength(fFieldNames,fFieldCount); // share one TRawUTF8DynArray

  for f := 0 to fFieldCount-1 do begin

    P := Get(0,f);

    if IsRowID(P) then // normalize RowID field name to ID

      fFieldNames[f] := 'ID' else

      fFieldNames[f] := P;

  end;

end;



{$ifndef NOVARIANTS}



var

  SQLTableRowVariantType: TCustomVariantType = nil;



procedure TSQLTable.GetAsVariant(row,field: integer; out value: variant;

  expandTimeLogAsText,expandEnumsAsText,expandHugeIDAsUniqueIdentifier: boolean;

  options: TDocVariantOptions);

const JAN2015_UNIX = 1420070400;

var t: TTimeLogBits;

    id: TSynUniqueIdentifierBits;

    V: PUtf8Char;

    enum,err: integer;

begin

  if (self=nil) or (row<1) or (row>fRowCount) or

     (cardinal(field)>=cardinal(fFieldCount)) then

    exit; // out of range

  if not Assigned(fFieldType) then

    InitFieldTypes;

  V := fResults[row*fFieldCount+field];

  with fFieldType[field] do

    if expandHugeIDAsUniqueIdentifier and (field=fFieldIndexID) then begin

      SetInt64(V,PInt64(@id)^);

      if id.CreateTimeUnix>JAN2015_UNIX then

        value := id.AsVariant else

        value := id.Value;

    end else begin

    if expandEnumsAsText and (ContentType=sftEnumerate) then begin

      enum := GetInteger(V,err);

      if (err=0) and (ContentTypeInfo<>nil) then begin

        value := PEnumType(ContentTypeInfo)^.GetEnumNameOrd(enum)^;

        exit;

      end;

    end else

    if expandTimeLogAsText and (ContentType in [sftTimeLog,sftModTime,sftCreateTime]) then begin

      SetInt64(V,t.Value);

      value := _ObjFast(['Time',t.Text(true),'Value',PInt64(@t)^]);

      exit;

    end;

    ValueVarToVariant(V,ContentType,TVarData(value),true,ContentTypeInfo,options);

  end;

end;



procedure TSQLTable.ToDocVariant(Row: integer; out doc: variant;

  options: TDocVariantOptions; expandTimeLogAsText,expandEnumsAsText,

  expandHugeIDAsUniqueIdentifier: boolean);

var Values: TVariantDynArray;

    f: integer;

begin

  if (self=nil) or (Row<1) or (Row>fRowCount) then

    exit; // out of range

  SetLength(Values,fFieldCount);

  for f := 0 to fFieldCount-1 do

    GetAsVariant(Row,f,Values[f],expandTimeLogAsText,expandEnumsAsText,

      expandHugeIDAsUniqueIdentifier,options);

  if length(fFieldNames)<>fFieldCount then

    InitFieldNames;

  TDocVariantData(doc).InitObjectFromVariants(fFieldNames,Values,options);

end;



procedure TSQLTable.ToDocVariant(out docs: TVariantDynArray; readonly: boolean);

var r: integer;

begin

  if (self=nil) or (fRowCount=0) then

    exit;

  SetLength(docs,fRowCount);

  if readonly then begin

    if SQLTableRowVariantType=nil then

      SQLTableRowVariantType := SynRegisterCustomVariantType(TSQLTableRowVariant);

    for r := 0 to fRowCount-1 do

    with TSQLTableRowVariantData(docs[r]) do begin

      VType := SQLTableRowVariantType.VarType;

      VTable := self;

      VRow := r+1;

    end;

  end else

    for r := 0 to fRowCount-1 do

      ToDocVariant(r+1,docs[r]);

end;



procedure TSQLTable.ToDocVariant(out docarray: variant; readonly: boolean);

var Values: TVariantDynArray;

begin

  ToDocVariant(Values,readonly);

  TDocVariantData(docarray).InitArrayFromVariants(Values,JSON_OPTIONS_FAST);

end;



{$endif NOVARIANTS}



procedure TSQLTable.DeleteColumnValues(Field: integer);

var i: integer;

    U: PPUTF8Char;

begin

  if cardinal(Field)>=cardinal(FieldCount) then

    exit; // out of range

  U := @fResults[Field+FieldCount];  // U^ = column UTF-8 content for this field

  for i := 1 to fRowCount do begin

    U^ := nil; // just void UTF-8 content text

    inc(U,FieldCount);

  end;

end;



function TSQLTable.GetQueryTableNameFromSQL: RawUTF8;

begin

  if (fQueryTableNameFromSQL='') and (fQuerySQL<>'') then

    fQueryTableNameFromSQL := GetTableNameFromSQLSelect(fQuerySQL,true);

  result := fQueryTableNameFromSQL;

end;



function TSQLTable.FieldPropFromTables(const PropName: RawUTF8;

  out PropInfo: TSQLPropInfo; out TableIndex: integer): TSQLFieldType;

  procedure SearchInQueryTables(aPropName: PUTF8Char; aTableIndex: integer);

  begin

    if IsRowID(aPropName) then begin

      result := sftInteger;

      PropInfo := nil;

      TableIndex := aTableIndex;

      exit;

    end else

    if fQueryTables[aTableIndex]<>nil then begin

      PropInfo := fQueryTables[aTableIndex].RecordProps.Fields.ByName(aPropName);

      if PropInfo<>nil then begin

        result := PropInfo.SQLFieldTypeStored;

        if result<>sftUnknown then 

          TableIndex := aTableIndex;

        exit;

      end;

      result := sftUnknown;

    end;

  end;

var i,t: integer;

begin

  TableIndex := -1;

  if fQueryTableIndexFromSQL=-2 then begin

    fQueryTableIndexFromSQL := -1;

    if (fQueryTables<>nil) and (QueryTableNameFromSQL<>'') then

      for i := 0 to length(fQueryTables)-1 do

        if IdemPropNameU(fQueryTables[i].SQLTableName,fQueryTableNameFromSQL) then begin

          fQueryTableIndexFromSQL := i;

          break;

        end;

  end;

  if fQueryTableIndexFromSQL>=0 then begin

    SearchInQueryTables(pointer(PropName),fQueryTableIndexFromSQL);

    if result<>sftUnknown then

      exit;

  end;

  if length(fQueryTables)=1 then

    SearchInQueryTables(pointer(PropName),0)

  else begin

    i := PosEx('.',PropName)-1;

    if i<0 then // no 'ClassName.PropertyName' format: find first exact property name

      for t := 0 to high(fQueryTables) do begin

        SearchInQueryTables(pointer(PropName),t);

        if result<>sftUnknown then

          exit;

      end

    else // handle property names as 'ClassName.PropertyName'

      for t := 0 to high(fQueryTables) do

        if fQueryTables[t]<>nil then // avoid GPF

        if IdemPropNameU(fQueryTables[t].RecordProps.SQLTableName,pointer(PropName),i) then begin

          SearchInQueryTables(@PropName[i+2],t);

          exit;

        end;

    result := sftUnknown;

  end;

end;



procedure TSQLTable.SetFieldType(Field: integer; FieldType: TSQLFieldType;

   FieldTypeInfo: pointer; FieldSize,FieldTableIndex: integer);

begin

  if (self=nil) or (cardinal(Field)>=cardinal(FieldCount)) then

    exit;

  if fFieldType=nil then

    InitFieldTypes;

  with fFieldType[Field] do begin

    ContentType := FieldType;

    ContentSize := FieldSize;

    ContentTypeInfo := nil;

    if FieldTypeInfo<>nil then

      case FieldType of

      sftEnumerate:

        if (PTypeInfo(FieldTypeInfo)^.Kind=tkEnumeration) then

          ContentTypeInfo := PTypeInfo(FieldTypeInfo)^.EnumBaseType;

      sftSet:

        if (PTypeInfo(FieldTypeInfo)^.Kind=tkSet) then

          ContentTypeInfo := PTypeInfo(FieldTypeInfo)^.SetEnumType;

      sftBlobDynArray:

        ContentTypeInfo := FieldTypeInfo;

      sftNullable: begin

        ContentTypeInfo := FieldTypeInfo;

        ContentType := NullableTypeToSQLFieldType(FieldTypeInfo);

        if ContentType=sftUnknown then

          ContentType := sftNullable;

      end;

      end;

    TableIndex := FieldTableIndex;

  end;

end;



procedure TSQLTable.SetFieldType(const FieldName: RawUTF8; FieldType: TSQLFieldType;

   FieldTypeInfo: pointer=nil; FieldSize: integer=-1);

begin

  SetFieldType(FieldIndex(FieldName),FieldType,FieldTypeInfo,FieldSize);

end;



function TSQLTable.GetRowCount: integer;

begin

  if self=nil then

    result := 0 else

    result := fRowCount;

end;



procedure TSQLTable.InitFieldTypes;

var f,i,len: integer;

    FieldType: TSQLFieldType;

    FieldTypeInfo: pointer;

    FieldPropInfo: TSQLPropInfo;

    FieldSize,FieldTableIndex: integer;

    U: PPUTF8Char;

    tlog: TTimeLog;

begin

  if Assigned(fQueryColumnTypes) and (FieldCount<>length(fQueryColumnTypes)) then

    raise ESQLTableException.CreateUTF8('%.CreateWithColumnTypes() called with % '+

      'column types, whereas the result has % columns',

      [self,length(fQueryColumnTypes),FieldCount]);

  SetLength(fFieldType,FieldCount);

  for f := 0 to FieldCount-1 do begin

    FieldPropInfo := nil;

    FieldTypeInfo := nil;

    FieldSize := -1;

    FieldTableIndex := -1;

    // init fFieldType[] from fQueryTables/fQueryColumnTypes[]

    if Assigned(fQueryColumnTypes) then

      FieldType := fQueryColumnTypes[f] else

    if Assigned(QueryTables) then begin // retrieve column info from field name

      FieldType := FieldPropFromTables(fResults[f],FieldPropInfo,FieldTableIndex);

      if FieldPropInfo<>nil then begin

        if FieldPropInfo.InheritsFrom(TSQLPropInfoRTTI) then

          FieldTypeInfo := TSQLPropInfoRTTI(FieldPropInfo).PropType;

        FieldSize := FieldPropInfo.FieldWidth;

      end;

    end else

      FieldType := sftUnknown;

    if FieldType=sftUnknown then

      // not found in fQueryTables/fQueryColumnTypes[]: guess from content

      if IsRowID(fResults[f]) then

        FieldType := sftInteger else

      if f in fFieldParsedAsString then  begin

        // the parser identified string values -> check if was sftDateTime

        FieldType := sftUTF8Text;

        U := @fResults[FieldCount+f];

        for i := 1 to fRowCount do

          if U^=nil then  // search for a non void column

            inc(U,FieldCount) else begin

            len := StrLen(U^);

            tlog := Iso8601ToTimeLogPUTF8Char(U^,len);

            if tlog<>0 then

              if (len in [8,10]) and (cardinal(tlog shr 26)-1800<300) then

                FieldType := sftDateTime else // e.g. YYYYMMDD date (Y=1800..2100)

              if len>=15 then

                FieldType := sftDateTime; // e.g. YYYYMMDDThhmmss date/time value

            break;

          end;

      end else begin

        U := @fResults[FieldCount+f];

        for i := 1 to fRowCount do begin

          FieldType := UTF8ContentNumberType(U^);

          inc(U,FieldCount);

          if FieldType=sftUnknown then

            continue else // null -> search for a non void column

          if FieldType=sftInteger then // may be a floating point with no decimal

            if FieldTypeIntegerDetectionOnAllRows then

              continue else

              // we only checked the first field -> best guess...

              FieldType := sftCurrency;

          break; // found a non-integer content (e.g. sftFloat/sftUtf8Text)

        end;

      end;

    SetFieldType(f,FieldType,FieldTypeInfo,FieldSize,FieldTableIndex);

  end;

end;



function TSQLTable.FieldType(Field: integer): TSQLFieldType;

begin

  if (self<>nil) and (cardinal(Field)<cardinal(FieldCount)) then begin

    if not Assigned(fFieldType) then

      InitFieldTypes;

    result := fFieldType[Field].ContentType;

  end else

    result := sftUnknown;

end;



function TSQLTable.FieldType(Field: integer; OutFieldTypeInfo: PPointer): TSQLFieldType;

begin

  if (self<>nil) and (cardinal(Field)<cardinal(FieldCount)) then begin

    if not Assigned(fFieldType) then

      InitFieldTypes;

    result := fFieldType[Field].ContentType;

    if OutFieldTypeInfo<>nil then

      OutFieldTypeInfo^ := fFieldType[Field].ContentTypeInfo;

  end else

    result := sftUnknown;

end;



function TSQLTable.Get(Row, Field: integer): PUTF8Char;

begin

  if (self=nil) or (fResults=nil) or (cardinal(Row)>cardinal(fRowCount)) or

     (cardinal(Field)>=cardinal(FieldCount)) then // cardinal() -> test <0

    result := nil else

    result := fResults[Row*FieldCount+Field];

end;



function TSQLTable.GetU(Row,Field: integer): RawUTF8;

var P: PUTF8Char;

begin

  if (self=nil) or (fResults=nil) or (cardinal(Row)>cardinal(fRowCount)) or

     (cardinal(Field)>=cardinal(FieldCount)) then // cardinal() -> test <0

    result := '' else begin

    P := fResults[Row*FieldCount+Field];

    SetString(Result,PAnsiChar(P),StrLen(P));

  end;

end;



function TSQLTable.Get(Row: integer; const FieldName: RawUTF8): PUTF8Char;

begin

  result := Get(Row,FieldIndex(FieldName));

end;



function TSQLTable.GetU(Row: integer; const FieldName: RawUTF8): RawUTF8;

begin

  result := GetU(Row,FieldIndex(FieldName));

end;



function TSQLTable.GetA(Row, Field: integer): WinAnsiString;

begin

  result := Utf8ToWinAnsi(Get(Row,Field));

end;



function TSQLTable.GetAsInteger(Row, Field: integer): integer;

begin

  result := GetInteger(Get(Row,Field));

end;



function TSQLTable.GetAsInteger(Row: integer; const FieldName: RawUTF8): integer;

begin

  result := GetInteger(Get(Row,FieldIndex(FieldName)));

end;



function TSQLTable.GetAsInt64(Row, Field: integer): Int64;

begin

  SetInt64(Get(Row,Field),result);

end;



function TSQLTable.GetAsInt64(Row: integer; const FieldName: RawUTF8): Int64;

begin

  SetInt64(Get(Row,FieldIndex(FieldName)),result);

end;



function TSQLTable.GetAsFloat(Row,Field: integer): TSynExtended;

begin

  result := GetExtended(Get(Row,Field));

end;



function TSQLTable.GetAsFloat(Row: integer; const FieldName: RawUTF8): TSynExtended;

begin

  result := GetExtended(Get(Row,FieldIndex(FieldName)));

end;



function TSQLTable.GetAsCurrency(Row,Field: integer): currency;

begin

  result := StrToCurrency(Get(Row,Field));

end;



function TSQLTable.GetAsCurrency(Row: integer; const FieldName: RawUTF8): currency;

begin

  result := StrToCurrency(Get(Row,FieldIndex(FieldName)));

end;



function TSQLTable.GetAsDateTime(Row,Field: integer): TDateTime;

var P: PUTF8Char;

begin

  result := 0;

  if Row=0 then

    exit; // header

  P := Get(Row,Field);

  if P=nil then

    exit;

  case FieldType(Field) of

  sftCurrency,sftFloat:

    result := GetExtended(P);

  sftInteger, // TSQLTable.InitFieldTypes may have recognized an integer

  sftTimeLog, sftModTime, sftCreateTime:

    result := TimeLogToDateTime(GetInt64(P));

  else // sftDateTime and any other kind will try from ISO-8601 text

    result := Iso8601ToDateTimePUTF8Char(P);

  end;

end;



function TSQLTable.GetAsDateTime(Row: integer; const FieldName: RawUTF8): TDateTime;

begin

  result := GetAsDateTime(Row,FieldIndex(FieldName));

end;



function TSQLTable.GetS(Row, Field: integer): shortstring;

begin

  UTF8ToShortString(result,Get(Row,Field));

end;



function TSQLTable.GetString(Row, Field: integer): string;

var U: PUTF8Char;

begin

  U := Get(Row,Field);

  if U=nil then

    result := '' else

    {$ifdef UNICODE}

    UTF8DecodeToUnicodeString(U,StrLen(U),result);

    {$else}

    CurrentAnsiConvert.UTF8BufferToAnsi(U,StrLen(U),RawByteString(result));

    {$endif}

end;



function TSQLTable.GetSynUnicode(Row,Field: integer): SynUnicode;

var U: PUTF8Char;

begin

  result := '';

  U := Get(Row,Field);

  if U<>nil then

    UTF8ToSynUnicode(U,StrLen(U),result);

end;



function TSQLTable.GetCaption(Row, Field: integer): string;

begin

  GetCaptionFromPCharLen(Get(Row,Field),result);

end;



function BlobToTSQLRawBlob(P: PUTF8Char): TSQLRawBlob;

var Len, LenHex: integer;

begin

  result := '';

  if P=nil then

    exit;

  Len := StrLen(P);

  if Len=0 then

    exit;

  if (P[0] in ['x','X']) and (P[1]='''') and (P[Len-1]='''') then begin

    // BLOB literals are string literals containing hexadecimal data and

    // preceded by a single "x" or "X" character. For example: X'53514C697465'

    LenHex := (Len-3) shr 1;

    SetLength(result,LenHex);

    if SynCommons.HexToBin(@P[2],pointer(result),LenHex) then

      exit; // valid hexa data

  end else

  if (PInteger(P)^ and $00ffffff=JSON_BASE64_MAGIC) and IsBase64(@P[3],Len-3) then begin

    // Base-64 encoded content ('\uFFF0base64encodedbinary')

    result := Base64ToBin(@P[3],Len-3);

    exit;

  end;

  // TEXT format

  SetString(result,PAnsiChar(P),Len);

end;



function BlobToTSQLRawBlob(const Blob: RawByteString): TSQLRawBlob;

var Len, LenHex: integer;

    P: PUTF8Char;

begin

  result := '';

  if Blob='' then

    exit;

  Len := length(Blob);

  P := pointer(Blob);

  if (P[0] in ['x','X']) and (P[1]='''') and (P[Len-1]='''') then begin

    // BLOB literals are string literals containing hexadecimal data and

    // preceded by a single "x" or "X" character. For example: X'53514C697465'

    LenHex := (Len-3) shr 1;

    SetLength(result,LenHex);

    if SynCommons.HexToBin(@P[2],pointer(result),LenHex) then

      exit; // valid hexa data

  end else

  if (PInteger(P)^ and $00ffffff=JSON_BASE64_MAGIC) and IsBase64(@P[3],Len-3) then begin

    // Base-64 encoded content ('\uFFF0base64encodedbinary')

    result := Base64ToBin(@P[3],Len-3);

    exit;

  end;

  // TEXT format

  result := Blob;

end;



function BlobToStream(P: PUTF8Char): TStream;

begin

  Result := TRawByteStringStream.Create(BlobToTSQLRawBlob(P));

end;



function BlobToBytes(P: PUTF8Char): TBytes;

var Len, LenResult: integer;

begin

  result := nil;

  Len := StrLen(P);

  if Len=0 then

    exit;

  if (P[0] in ['x','X']) and (P[1]='''') and (P[Len-1]='''') then begin

    // BLOB literals format

    LenResult := (Len-3)shr 1;

    SetLength(Result,LenResult);

    if SynCommons.HexToBin(@P[2],pointer(Result),LenResult) then

      exit; // valid hexa data

  end else

  if (PInteger(P)^ and $00ffffff=JSON_BASE64_MAGIC) and IsBase64(@P[3],Len-3) then begin

    // Base-64 encoded content ('\uFFF0base64encodedbinary')

    inc(P,3);

    dec(Len,3);

    LenResult := Base64ToBinLength(pointer(P),len);

    SetLength(Result,LenResult);

    if LenResult>0 then

      Base64Decode(pointer(P),pointer(Result),Len shr 2);

    exit;

  end;

  // TEXT format

  SetLength(Result,Len);

  MoveFast(P^,pointer(Result)^,Len);

end;



function TSQLRawBlobToBlob(const RawBlob: TSQLRawBlob): RawUTF8;

// BLOB literals are string literals containing hexadecimal data and

//  preceded by a single "x" or "X" character. For example: X'53514C697465'

begin

  result := TSQLRawBlobToBlob(pointer(RawBlob),length(RawBlob));

end;



function TSQLRawBlobToBlob(RawBlob: pointer; RawBlobLength: integer): RawUTF8; overload;

// BLOB literals are string literals containing hexadecimal data and

//  preceded by a single "x" or "X" character. For example: X'53514C697465'

var P: PAnsiChar;

begin

  result := '';

  if RawBlobLength<>0 then begin

    SetLength(result,RawBlobLength*2+3);

    P := pointer(result);

    P[0] := 'X';

    P[1] := '''';

    BinToHex(RawBlob,P+2,RawBlobLength);

    P[RawBlobLength*2+2] := '''';

  end;

end;



function isBlobHex(P: PUTF8Char): boolean;

// BLOB literals are string literals containing hexadecimal data and

// preceded by a single "x" or "X" character. For example: X'53514C697465'

var Len: integer;

begin

  if P=nil then begin

    result := false;

    exit;

  end;

  while P^ in [#1..' '] do inc(P);

  if (P[0] in ['x','X']) and (P[1]='''') then begin

    Len := (StrLen(P)-3) shr 1;

    result := (P[Len-1]='''') and SynCommons.HexToBin(@P[2],nil,Len);

    exit;

  end else begin

    result := false;

    exit;

  end;

end;



function TSQLTable.GetBlob(Row, Field: integer): TSQLRawBlob;

begin

  result := BlobToTSQLRawBlob(Get(Row,Field));

end;



function TSQLTable.GetBytes(Row,Field: integer): TBytes;

begin

  result := BlobToBytes(Get(Row,Field));

end;



function TSQLTable.GetStream(Row,Field: integer): TStream;

begin

  result := BlobToStream(Get(Row,Field));

end;



{$ifdef PUREPASCAL}

function TSQLTable.GetDateTime(Row, Field: integer): TDateTime;

begin

  result := Iso8601ToDateTimePUTF8Char(Get(Row,Field),0)

end;

{$else}

function TSQLTable.GetDateTime(Row, Field: integer): TDateTime;

asm

  call TSQLTable.Get

  xor edx,edx // L=0 -> will call strlen()

  jmp Iso8601ToDateTimePUTF8Char

end;

{$endif}



procedure TSQLTable.GetRowValues(Field: integer; out Values: TRawUTF8DynArray);

var i: integer;

    U: PPUTF8Char;

begin

  Finalize(Values);

  if (self=nil) or (cardinal(Field)>cardinal(FieldCount)) then

    exit;

  SetLength(Values,fRowCount);

  U := @fResults[FieldCount+Field]; // start reading after first Row (= Field Names)

  for i := 0 to fRowCount-1 do begin

    SetString(Values[i],PAnsiChar(U^),StrLen(U^));

    inc(U,FieldCount); // go to next row

  end;

end;



procedure TSQLTable.GetRowValues(Field: integer; out Values: TInt64DynArray);

var i: integer;

    U: PPUTF8Char;

begin

  Finalize(Values);

  if (self=nil) or (cardinal(Field)>cardinal(FieldCount)) then

    exit;

  SetLength(Values,fRowCount);

  U := @fResults[FieldCount+Field]; // start reading after first Row (= Field Names)

  for i := 0 to fRowCount-1 do begin

    SetInt64(U^,Values[i]);

    inc(U,FieldCount); // go to next row

  end;

end;



function TSQLTable.GetRowValues(Field: integer; Sep: AnsiChar): RawUTF8;

var i, L: integer;

    U: PPUTF8Char;

    P: PUTF8Char;

begin

  result := '';

  if (self=nil) or (cardinal(Field)>cardinal(FieldCount)) or (fRowCount=0) then

    exit;

  L := 0;

  U := @fResults[FieldCount+Field]; // start reading after first Row (= Field Names)

  for i := 1 to fRowCount do begin

    inc(L,StrLen(U^)+1);

    inc(U,FieldCount); // go to next row

  end;

  if L=0 then

    exit;

  SetLength(result,L-1); // L-1 = don't add a last ','

  P := pointer(result);

  U := @fResults[FieldCount+Field]; // start reading after first Row (= Field Names)

  for i := 1 to fRowCount do begin

    L := StrLen(U^);

    MoveFast(U^^,P^,L);

    if i=fRowCount then // don't add a last ','

      break;

    P[L] := Sep;

    inc(P,L+1);

    inc(U,FieldCount); // go to next row

  end;

end;



procedure TSQLTable.GetJSONValues(JSON: TStream; Expand: boolean;

  RowFirst: integer=0; RowLast: integer=0);

var W: TJSONWriter;

    F,R: integer;

    U: PPUTF8Char;

    directWrites: set of 0..255;

begin

  W := TJSONWriter.Create(JSON,Expand,false);

  try

    if (self=nil) or (FieldCount<=0) or (fRowCount<=0) then begin

      W.CancelAllVoid;

      exit;

    end;

    // check range

    if RowLast=0 then

      RowLast := fRowCount else

    if RowLast>fRowCount then

      RowLast := fRowCount;

    if RowFirst<=0 then

      RowFirst := 1; // start reading after first Row (Row 0 = Field Names)

    // get col names and types

    if QueryTables<>nil then

      InitFieldTypes;

    SetLength(W.ColNames,FieldCount);

    FillCharFast(directWrites,(FieldCount shr 3)+1,0);

    for F := 0 to FieldCount-1 do begin

      W.ColNames[F] := fResults[F]; // first Row is field Names

      if (QueryTables<>nil) and not Assigned(OnExportValue) then

        with fFieldType[F] do

        if SQLFieldTypeToDBField(ContentType,ContentTypeInfo) in

           [ftInt64,ftDouble,ftCurrency] then

          include(directWrites,F);

    end;

    W.AddColumns(RowLast-RowFirst+1); // write or init field names (see JSON Expand)

    if Expand then

      W.Add('[');

    // write rows data

    U := @fResults[FieldCount*RowFirst];

    for R := RowFirst to RowLast do begin

      if Expand then

        W.Add('{');

      for F := 0 to FieldCount-1 do begin

        if Expand then

          W.AddString(W.ColNames[F]); // '"'+ColNames[]+'":'

        if Assigned(OnExportValue) then

          W.AddString(OnExportValue(self,R,F)) else

        if U^=nil then

          W.AddShort('null') else

        // IsStringJSON() is fast and safe: no need to guess exact value type

        if (F in directWrites) or not IsStringJSON(U^) then

          W.AddNoJSONEscape(U^,StrLen(U^)) else begin

          W.Add('"');

          W.AddJSONEscape(U^,StrLen(U^));

          W.Add('"');

        end;

        W.Add(',');

        inc(U); // points to next value

      end;

      W.CancelLastComma; // cancel last ','

      if Expand then begin

        W.Add('}',',');

        if R<>RowLast then

          W.AddCR; // make expanded json more human readable

      end else

        W.Add(',');

    end;

    W.EndJSONObject(1,0); // "RowCount": set by W.AddColumns(RowLast-RowFirst+1)

  finally

    W.Free;

  end;

end;



procedure TSQLTable.GetJSONValues(W: TTextWriter; Expand: boolean;

  RowFirst: integer=0; RowLast: integer=0);

begin

  if (self=nil) or (FieldCount<=0) or (fRowCount<=0) then

    W.Add('[',']') else begin

    W.FlushToStream;

    GetJSONValues(W.Stream,Expand,RowFirst,RowLast);

  end;

end;



procedure TSQLTable.GetCSVValues(Dest: TStream; Tab: boolean; CommaSep: AnsiChar=',';

  AddBOM: boolean=false; RowFirst: integer=0; RowLast: integer=0);

var U: PPUTF8Char;

    F,R,FMax: integer;

    W: TTextWriter;

begin

  if (self=nil) or (FieldCount<=0) or (fRowCount<=0) then

    exit;

  if (RowLast=0) or (RowLast>fRowCount) then

    RowLast := fRowCount;

  if RowFirst<0 then

    RowFirst := 0;

  W := TTextWriter.Create(Dest,16384);

  try

    if AddBOM then

      W.AddShort(#$ef#$bb#$bf); // add UTF-8 Byte Order Mark

    if Tab then

      CommaSep := #9;

    FMax := FieldCount-1;

    U := @fResults[RowFirst*FieldCount];

    for R := RowFirst to RowLast do

      for F := 0 to FMax do begin

        if Assigned(OnExportValue) then

          W.AddString(OnExportValue(self,R,F)) else

        if Tab or (not IsStringJSON(U^)) then

          W.AddNoJSONEscape(U^,StrLen(U^)) else begin

          W.Add('"');

          W.AddNoJSONEscape(U^,StrLen(U^));

          W.Add('"');

        end;

        if F=FMax then

          W.AddCR else

          W.Add(CommaSep);

        inc(U); // points to next value

      end;

    W.FlushFinal;

  finally

    W.Free;

  end;

end;



function TSQLTable.GetCSVValues(Tab: boolean; CommaSep: AnsiChar=',';

  AddBOM: boolean=false; RowFirst: integer=0; RowLast: integer=0): RawUTF8;

var MS: TRawByteStringStream;

begin

  MS := TRawByteStringStream.Create;

  try

    GetCSVValues(MS,Tab,CommaSep,AddBOM,RowFirst,RowLast);

    result := MS.DataString;

  finally

    MS.Free;

  end;

end;



procedure TSQLTable.GetMSRowSetValues(Dest: TStream; RowFirst,RowLast: integer);

const FIELDTYPE_TOXML: array[TSQLDBFieldType] of RawUTF8 = (

  // ftUnknown, ftNull, ftInt64, ftDouble, ftCurrency,

     '','',' dt:type="i8"',' dt:type="float"',' dt:type="number" rs:dbtype="currency"',

  // ftDate, ftUTF8, ftBlob

     ' dt:type="dateTime"',' dt:type="string"',' dt:type="bin.hex"');

var W: TJSONWriter;

    f,r: integer;

    U: PPUTF8Char;

    fieldType: TSQLDBFieldTypeDynArray;

begin

  W := TJSONWriter.Create(Dest,16384);

  try

    W.AddShort('<xml xmlns:s="uuid:BDC6E3F0-6DA3-11d1-A2A3-00AA00C14882" '+

      'xmlns:dt="uuid:C2F41010-65B3-11d1-A29F-00AA00C14882" '+

      'xmlns:rs="urn:schemas-microsoft-com:rowset" xmlns:z="#RowsetSchema">');

    if (self<>nil) and (FieldCount>0) or (fRowCount>0) then begin

      // retrieve normalized field names and types

      if length(fFieldNames)<>fFieldCount then

        InitFieldNames;

      if not Assigned(fFieldType) then

        InitFieldTypes;

      SetLength(fieldType,FieldCount);

      for f := 0 to FieldCount-1 do

        with fFieldType[F] do

          fieldType[f] := SQLFieldTypeToDBField(ContentType,ContentTypeInfo);

      // check range

      if RowLast=0 then

        RowLast := fRowCount else

      if RowLast>fRowCount then

        RowLast := fRowCount;

      if RowFirst<=0 then

        RowFirst := 1; // start reading after first Row (Row 0 = Field Names)

      // write schema from col names and types

      W.AddShort('<s:Schema id="RowsetSchema"><s:ElementType name="row" content="eltOnly">');

      for f := 0 to FieldCount-1 do begin

        W.AddShort('<s:AttributeType name="f');

        W.Add(f);

        W.AddShort('" rs:name="');

        W.AddString(fFieldNames[f]);

        W.Add('"');

        W.AddString(FIELDTYPE_TOXML[fieldType[f]]);

        W.Add('/','>');

      end;

      W.AddShort('</s:ElementType></s:Schema>');

      // write rows data

      U := @fResults[FieldCount*RowFirst];

      W.AddShort('<rs:data>');

      for r := RowFirst to RowLast do begin

        W.AddShort('<z:row ');

        for f := 0 to FieldCount-1 do begin

          if U^<>nil then begin

            W.Add('f');

            W.Add(f);

            W.Add('=','"');

            case fieldType[f] of

            ftUnknown:

              if IsStringJSON(U^) then // no need to guess exact value type here

                W.AddXmlEscape(U^) else

                W.AddNoJSONEscape(U^,StrLen(U^));

            ftInt64, ftDouble, ftCurrency:

              W.AddNoJSONEscape(U^,StrLen(U^));

            ftDate, ftUTF8, ftBlob:

              W.AddXmlEscape(U^);

            end;

            W.Add('"',' ');

          end;

          inc(U); // points to next value

        end;

        W.Add('/','>');

      end;

      W.AddShort('</rs:data>');

    end;

    W.AddShort('</xml>');

    W.FlushFinal;

  finally

    W.Free;

  end;

end;



function TSQLTable.GetMSRowSetValues: RawUTF8;

var MS: TRawByteStringStream;

begin

  MS := TRawByteStringStream.Create;

  try

    GetMSRowSetValues(MS,1,RowCount);

    result := MS.DataString;

  finally

    MS.Free;

  end;

end;



function TSQLTable.GetODSDocument: RawByteString;

const

  ODSmimetype: RawUTF8 = 'application/vnd.oasis.opendocument.spreadsheet';

  ODSContentHeader: RawUTF8 = '<office:document-content office:version="1.2" xmlns:office="urn:oasis:names:tc:opendocument:xmlns:office:1.0"'+

  ' xmlns:text="urn:oasis:names:tc:opendocument:xmlns:text:1.0" xmlns:table="urn:oasis:names:tc:opendocument:xmlns:table:1.0"'+

  ' xmlns:meta="urn:oasis:names:tc:opendocument:xmlns:meta:1.0" ><office:body><office:spreadsheet><table:table table:name="Sheet1" >'+

  '<table:table-column table:number-columns-repeated="';

  ODSContentFooter = '</table:table><table:named-expressions/></office:spreadsheet></office:body></office:document-content>';

  ODSstyles: RawUTF8 = XMLUTF8_HEADER+'<office:document-styles xmlns:office="urn:oasis:names:tc:opendocument:xmlns:office:1.0" office:version="1.2"></office:document-styles>';

  ODSmeta: RawUTF8 = XMLUTF8_HEADER+'<office:document-meta xmlns:office="urn:oasis:names:tc:opendocument:xmlns:office:1.0" office:version="1.2"></office:document-meta>';

  ODSsettings: RawUTF8 = XMLUTF8_HEADER+'<office:document-settings xmlns:office="urn:oasis:names:tc:opendocument:xmlns:office:1.0" office:version="1.2"></office:document-settings>';

  ODSmanifest: RawUTF8 = XMLUTF8_HEADER+'<manifest:manifest xmlns:manifest="urn:oasis:names:tc:opendocument:xmlns:manifest:1.0"'+

  ' manifest:version="1.2"><manifest:file-entry manifest:full-path="/" manifest:version="1.2" manifest:media-type="application/vnd.oasis.opendocument.spreadsheet"/>'+

  '<manifest:file-entry manifest:full-path="meta.xml" manifest:media-type="text/xml"/><manifest:file-entry manifest:full-path="settings.xml" manifest:media-type="text/xml"/>'+

  '<manifest:file-entry manifest:full-path="content.xml" manifest:media-type="text/xml"/><manifest:file-entry manifest:full-path="styles.xml" manifest:media-type="text/xml"/></manifest:manifest>';

var Zip: TZipWriteToStream;

    Dest: TRawByteStringStream;

    content: RawUTF8;

    W: TTextWriter;

    U: PPUTF8Char;

    R,F: integer;

begin

  Dest := TRawByteStringStream.Create;

  try

    Zip := TZipWriteToStream.Create(Dest);

    try

      Zip.AddStored('mimetype',pointer(ODSmimetype),length(ODSmimetype));

      Zip.AddDeflated('styles.xml',pointer(ODSstyles),length(ODSstyles));

      Zip.AddDeflated('meta.xml',pointer(ODSmeta),length(ODSmeta));

      Zip.AddDeflated('settings.xml',pointer(ODSsettings),length(ODSsettings));

      Zip.AddDeflated('META-INF/manifest.xml',pointer(ODSmanifest),length(ODSmanifest));

      W := TTextWriter.CreateOwnedStream(65536);

      try

        W.AddShort(XMLUTF8_HEADER);

        W.AddString(ODSContentHeader);

        W.Add(FieldCount);

        W.AddShort('" />');

        U := pointer(fResults);

        for R := 0 to fRowCount do begin

          W.AddShort('<table:table-row>');

          for F := 1 to FieldCount do begin

            W.AddShort('<table:table-cell office:value-type="string"><text:p>');

            W.AddXmlEscape(U^);

            W.AddShort('</text:p></table:table-cell>');

            inc(U); // points to next value

          end;

          W.AddShort('</table:table-row>');

        end;

        W.AddShort(ODSContentFooter);

        W.SetText(content);

      finally

        W.Free;

      end;

      Zip.AddDeflated('content.xml',pointer(content),length(content));

    finally

      Zip.Free;

    end;

    result := Dest.DataString;

  finally

    Dest.Free;

  end;

end;



function TSQLTable.GetJSONValues(Expand: boolean): RawUTF8;

var MS: TRawByteStringStream;

begin

  MS := TRawByteStringStream.Create;

  try

    GetJSONValues(MS,Expand); // create JSON data in MS

    result := MS.DataString;

  finally

    MS.Free;

  end;

end;



procedure TSQLTable.GetHtmlTable(Dest: TTextWriter);

var R,F: integer;

    U: PPUTF8Char;

begin

  Dest.AddShort('<table>'#10);

  U := pointer(fResults);

  for R := 0 to fRowCount do begin

    Dest.AddShort('<tr>');

    for F := 0 to FieldCount-1 do begin

      if R=0 then

        Dest.AddShort('<th>') else

        Dest.AddShort('<td>');

      if Assigned(OnExportValue) and (R>0) then

        Dest.AddHtmlEscapeUTF8(OnExportValue(self,R,F),hfOutsideAttributes) else

        Dest.AddHtmlEscape(U^,hfOutsideAttributes);

      if R=0 then

        Dest.AddShort('</th>') else

        Dest.AddShort('</td>');

      inc(U); // points to next value

    end;

    Dest.AddShort('</tr>'#10);

  end;

  Dest.AddShort('</table>');

end;



function TSQLTable.GetHtmlTable(const Header: RawUTF8): RawUTF8;

var W: TTextWriter;

begin

  W := TTextWriter.CreateOwnedStream(16384);

  try

    W.AddShort('<html>');

    W.AddString(Header);

    W.AddShort('<body>'#10);

    GetHtmlTable(W);

    W.AddShort(#10'</body></html>');

    W.SetText(result);

  finally

    W.Free;

  end;

end;

  

function TSQLTable.GetW(Row, Field: integer): RawUnicode;

begin

  result := UTF8DecodeToRawUnicode(Get(Row,Field),0);

end;



function TSQLTable.GetWP(Row, Field: integer; Dest: PWideChar; MaxDestChars: cardinal): integer;

var P: PUTF8Char;

begin

  P := Get(Row,Field);

  result := UTF8ToWideChar(Dest,P,MaxDestChars,0) shr 1; // bytes div 2

end;



function TSQLTable.LengthW(Row, Field: integer): integer;

begin // nil -> fast calculate unicode length, without any memory allocation

  result := Utf8ToUnicodeLength(Get(Row,Field));

end;



function UTF8CompareCurr64(P1,P2: PUTF8Char): PtrInt;

var V1,V2: Int64;

begin // faster than UTF8CompareDouble() for pure decimal (no exponent) values

  V1 := StrToCurr64(P1);

  V2 := StrToCurr64(P2);

  if V1<V2 then

    result := -1 else

    if V1=V2 then

      result := 0 else

      result := +1;

end;



function UTF8CompareBoolean(P1,P2: PUTF8Char): PtrInt;

label Z,P,N;

begin // assume 0 is FALSE, anything else is true

  if P1=P2  then goto Z else

  if P1=nil then goto P else

  if P2=nil then goto N else

  if (P1^=#0) or (PWord(P1)^=ord('0')) then

    if (P2^=#0) or (PWord(P2)^=ord('0')) then begin

Z:    result := 0;  // P1=false P2=false

      exit;

    end else begin

N:    result := -1; // P1=false P2=true

      exit;

    end else

    if (P2^<>#0) and (PWord(P2)^<>ord('0')) then

      goto Z        // P1=true P2=true

    else begin

P:    result := 1;  // P1=true P2=false

      exit;

    end;

end;



function UTF8CompareInt32(P1,P2: PUTF8Char): PtrInt;

var V1,V2: PtrInt;

begin

  if P1=P2 then begin

    result := 0;

    exit;

  end;

  V1 := GetInteger(P1);

  V2 := GetInteger(P2);

  if V1<V2 then

    result := -1 else

    if V1=V2 then

      result := 0 else

      result := +1;

end;



function UTF8CompareUInt32(P1,P2: PUTF8Char): PtrInt;

var V1,V2: PtrUInt;

begin

  if P1=P2 then begin

    result := 0;

    exit;

  end;

  V1 := GetCardinal(P1);

  V2 := GetCardinal(P2);

  if V1<V2 then

    result := -1 else

    if V1=V2 then

      result := 0 else

      result := +1;

end;



function UTF8CompareRecord(P1,P2: PUTF8Char): PtrInt;

var V1,V2: Int64;

    T1,T2: cardinal;

label er;

begin

  if P1=P2 then begin

    result := 0;

    exit;

  end;

  SetInt64(P1,V1);

  SetInt64(P2,V2);

  if V1=V2 then

    result := 0 else begin

    // special RecordRef / TRecordReference INTEGER sort

    T1 := V1 and 63;  // first sort by Table order

    T2 := V2 and 63;

    if T1<T2 then

      result := -1 else

      if T1>T2 then

        result := +1 else

        // we have T1=T2 -> same Table -> sort by ID

        if V1<V2 then

          result := -1 else

          if V1=V2 then

            result := 0 else

            result := +1;

  end;

end;



function UTF8CompareInt64(P1,P2: PUTF8Char): PtrInt;

var V1,V2: Int64;

begin

  if P1=P2 then begin

    result := 0;

    exit;

  end;

  SetInt64(P1,V1);

  SetInt64(P2,V2);

  if V1<V2 then

    result := -1 else

    if V1=V2 then

      result := 0 else

      result := +1;

end;



function UTF8CompareDouble(P1,P2: PUTF8Char): PtrInt;

var V1,V2: TSynExtended;

    Err: integer;

label er;

begin

  if P1=P2 then begin

    result := 0;

    exit;

  end;

  v1 := GetExtended(P1,Err);

  if Err<>0 then begin

er: result := UTF8IComp(P1,P2);

    exit;

  end;

  V2 := GetExtended(P2,Err);

  if Err<>0 then goto er;

  if V1<V2 then // we don't care about exact = for a sort: Epsilon check is slow

    result := -1 else

    result := +1;

end;



function UTF8CompareISO8601(P1,P2: PUTF8Char): PtrInt;

var V1,V2: Int64; // faster than Iso8601ToDateTimePUTF8Char: uses integer math

begin

  if P1=P2 then begin

    result := 0;

    exit;

  end;

  V1 := Iso8601ToTimeLogPUTF8Char(P1,0);

  V2 := Iso8601ToTimeLogPUTF8Char(P2,0);

  if (V1=0) or (V2=0) then // any invalid date -> compare as strings

    result := UTF8IComp(P1,P2) else

    if V1<V2 then

      result := -1 else

      if V1=V2 then

        result := 0 else

        result := +1;

end;



var

  /// simple wrapper to UTF-8 compare function for the SQLite3 field datatypes

  // - used internaly for field sorting (see TSQLTable.SortFields() method)

  // and for default User Interface Query (see TSQLRest.QueryIsTrue() method)

  SQLFieldTypeComp: array[TSQLFieldType] of TUTF8Compare  =

   (nil,                  // unknown

    nil,    // AnsiText will be set to AnsiIComp in initialization block below

    {$ifdef USENORMTOUPPER}

    UTF8IComp,           // UTF8Text, 8 bits case insensitive compared

    {$else}

    nil,    // UTF8Text will be set to AnsiIComp in initialization block below

    {$endif}

    UTF8CompareUInt32,   // Enumerate

    UTF8CompareUInt32,   // Set

    UTF8CompareInt64,    // Integer

    UTF8CompareInt64,    // ID

    UTF8CompareRecord,   // Record

    UTF8CompareBoolean,  // Boolean

    UTF8CompareDouble,   // Float

    UTF8CompareISO8601,  // TDateTime

    UTF8CompareInt64,    // TTimeLog

    UTF8CompareCurr64,   // Currency

    nil,                 // Object (TEXT serialization)

    {$ifndef NOVARIANTS}

    nil,                 // Variant (TEXT serialization)

    nil,                 // TNullable*

    {$endif}

    nil,                 // Blob

    nil,                 // BlobDynArray

    nil,                 // BlobCustom

    nil,                 // UTF8Custom

    nil,

    UTF8CompareInt64,    // TModTime

    UTF8CompareInt64,    // TCreateTime

    UTF8CompareInt64,    // TID

    UTF8CompareInt64,    // TRecordVersion

    UTF8CompareInt64);   // TSessionUserID



type

  /// a static object is used for smaller recursive stack size and faster code

  // - these special sort implementation do the comparaison first by the

  // designed field, and, if the field value is identical, the ID value is

  // used (it will therefore sort by time all identical values)

  // - code generated is very optimized: stack and memory usage, CPU registers

  // prefered, multiplication avoided to calculate memory position from index,

  // hand tuned assembler...

  TUTF8QuickSort = {$ifndef ISDELPHI2010}object{$else}record{$endif}

  public

    // sort parameters

    fComp: TUTF8Compare;

    Results: PPUtf8CharArray;

    IDColumn: PPUtf8CharArray;

    Params: TSQLTableSortParams;

    CurrentRow: integer;

    // used to avoid multiplications to calculate data memory position from index

    // - CPU64 ready

    FieldCountNextPtr, FieldIndexNextPtr: PtrInt;

    // temp vars (avoid stack usage):

    PID: Int64;

    PP, CI, CJ: PPUTF8Char;

    I, J: PtrInt;

{$ifdef PUREPASCAL}

    Tmp: PUTF8Char;

{$endif}

    /// recursively perform the sort

    procedure QuickSort(L, R: Integer);

    /// compare value at index I with pivot value

    // - sort by ID if values are identical

    function CompI: integer; {$ifdef HASINLINE}inline;{$endif}

    /// compare value at index J with pivot value

    // - sort by ID if values are identical

    function CompJ: integer; {$ifdef HASINLINE}inline;{$endif}

    /// set the pivot value

    procedure SetPP(aPP: PPUTF8Char; aP: PtrInt);

  end;



procedure TUTF8QuickSort.SetPP(aPP: PPUTF8Char; aP: PtrInt);

begin

  PP := aPP;

  // PID must be updated every time PP is modified

  if Assigned(IDColumn) then

    SetInt64(IDColumn[aP],PID) else

    SetInt64(PPUTF8Char(PtrInt(aPP)-FieldIndexNextPtr)^,PID);

end;



function TUTF8QuickSort.CompI: integer;

begin

  result := fComp(CI^,PP^);

  if result=0 then

    // same value -> sort by ID

    if Assigned(IDColumn) then

      result := GetInt64(IDColumn[I])-PID else

      result := GetInt64(PPUTF8Char(PtrInt(CI)-FieldIndexNextPtr)^)-PID;

end;



function TUTF8QuickSort.CompJ: integer;

begin

  result := fComp(CJ^,PP^);

  if result=0 then

    // same value -> sort by ID

    if Assigned(IDColumn) then

      result := GetInt64(IDColumn[J])-PID else

      result := GetInt64(PPUTF8Char(PtrInt(CJ)-FieldIndexNextPtr)^)-PID;

end;



procedure ExchgPtrUInt(P1,P2: PtrUInt; FieldCount: integer);

{$ifdef PUREPASCAL}  // CPU64 will call this version e.g.

var B: PtrUInt;

    i: PtrUInt;

begin

  for i := 1 to FieldCount do begin

    B := PPtrUInt(P1)^;

    PPtrUInt(P1)^ := PPtrUInt(P2)^;

    PPtrUInt(P2)^ := B;

    inc(PPtrUInt(P1));

    inc(PPtrUInt(P2));

  end;

end;

{$else}

asm // eax=P1 edx=P2 ecx=FieldCount

    push esi

    push edi

@1: dec ecx

    mov esi,[eax]

    mov edi,[edx]

    mov [edx],esi

    mov [eax],edi

    lea eax,[eax+4]

    lea edx,[edx+4]

    jnz @1

    pop edi

    pop esi

end;

{$endif}



procedure TUTF8QuickSort.QuickSort(L, R: Integer);

  {$ifndef PUREPASCAL}

  procedure Exchg32(P: pointer; I,J: integer);

  asm // eax=P edx=I ecx=J

    push ebx

    lea edx,[eax+edx*4]

    lea ecx,[eax+ecx*4]

    mov eax,[edx]

    mov ebx,[ecx]

    mov [ecx],eax

    mov [edx],ebx

    pop ebx

  end;

  {$endif}

// code below is very fast and optimized

var P: PtrInt;

begin

  if @fComp<>nil then

  repeat

    I := L;

    CI := @Results[I*Params.FieldCount+Params.FieldIndex];

    J := R;

    CJ := @Results[J*Params.FieldCount+Params.FieldIndex];

    P := ((I+J) shr 1);

    SetPP(@Results[P*Params.FieldCount+Params.FieldIndex],P);

    repeat

      // this loop has no multiplication -> most of the time is spent in comp()

      if Params.Asc then begin // ascending order comparaison

        while compI<0 do begin

          inc(I);

          inc(PByte(CI),FieldCountNextPtr); // next row

        end;

        while compJ>0 do begin

          dec(J);

          dec(PByte(CJ),FieldCountNextPtr); // previous row

        end;

      end else begin // descending order comparaison

        while compI>0 do begin

          inc(I);

          inc(PByte(CI),FieldCountNextPtr); // next row

        end;

        while compJ<0 do begin

          dec(J);

          dec(PByte(CJ),FieldCountNextPtr); // previous row

        end;

      end;

      if I<=J then begin

        if I<>J then begin // swap elements

          if CurrentRow=J then // update current row number

            CurrentRow := I else

          if CurrentRow=I then

            CurrentRow := J;

          // full row exchange

          ExchgPtrUInt(PtrInt(CI)-FieldIndexNextPtr,PtrInt(CJ)-FieldIndexNextPtr,

            Params.FieldCount); // exchange PUTF8Char for whole I,J rows

          if Assigned(IDColumn) then begin // update hidden ID column also

          {$ifdef PUREPASCAL}

            Tmp := IDColumn[I];

            IDColumn[I] := IDColumn[J];

            IDColumn[J] := Tmp;

          {$else}

            Exchg32(IDColumn,I,J);

          {$endif}

          end;

        end;

        if PP=CI then

          SetPP(CJ,J) else

        if PP=CJ then

          SetPP(CI,I);

        inc(I);

        dec(J);

        inc(PByte(CI),FieldCountNextPtr);

        dec(PByte(CJ),FieldCountNextPtr);

      end else

        break;

    until I>J;

    P := I; // save I which will be overwritten by QuickSort() below

    if L<J then

      QuickSort(L, J);

    I := P;

    L := P;

  until I>=R;

end;



procedure TSQLTable.SortFields(const FieldName: RawUTF8; Asc: boolean=true;

  PCurrentRow: PInteger=nil; FieldType: TSQLFieldType=sftUnknown;

  CustomCompare: TUTF8Compare=nil);

begin

  SortFields(FieldIndex(FieldName),Asc,PCurrentRow,FieldType,CustomCompare);

end;



procedure TSQLTable.SortFields(Field: integer; Asc: boolean=true;

  PCurrentRow: PInteger=nil; FieldType: TSQLFieldType=sftUnknown;

  CustomCompare: TUTF8Compare=nil);

var Sort: TUTF8QuickSort; // fast static object for sorting

begin

  if (FieldCount=0) or (Cardinal(Field)>=cardinal(FieldCount)) then

    exit;

  if FieldType=sftUnknown then // guess the field type from first row

    FieldType := self.FieldType(Field,nil);

  if Assigned(CustomCompare) then

    Sort.fComp := CustomCompare else begin

    Sort.fComp := SQLFieldTypeComp[FieldType];

    if @Sort.fComp=nil then

      exit;

  end;

  // store sorting parameters for resort in TSQLTableJSON.FillFrom()

  fSortParams.FieldType := FieldType;

  fSortParams.FieldCount := FieldCount;

  fSortParams.FieldIndex := Field;

  fSortParams.Asc := Asc;

  // this sort routine is very fast, thanks to the dedicated static object

  Sort.Params := fSortParams;

  Sort.Results := fResults;

  Sort.IDColumn := @fIDColumn[0];

  Sort.FieldCountNextPtr := FieldCount*sizeof(PtrInt);

  Sort.FieldIndexNextPtr := Field*sizeof(PtrInt);

  if PCurrentRow=nil then

    Sort.CurrentRow := -1 else

    Sort.CurrentRow := PCurrentRow^;

  if fRowCount>1 then

    Sort.QuickSort(1,fRowCount); // ignore first row = field names -> (1,RowCount)

  if PCurrentRow<>nil then

    PCurrentRow^ := Sort.CurrentRow;

end;



type

  TUTF8QuickSortMulti = {$ifndef ISDELPHI2010}object{$else}record{$endif}

  public

    Results: PPUtf8CharArray;

    IDColumn: PPUtf8CharArray;

    FieldCount: integer;

    IndexMax: integer;

    Index: array of record

      ndx: integer;

      Comp: TUTF8Compare;

      Desc: boolean;

    end;

    // used for row content comparison

    function Compare(A,B: integer): integer;

    /// recursively perform the sort

    procedure QuickSort(L, R: Integer);

  end;



function TUTF8QuickSortMulti.Compare(A,B: integer): integer;

var i: integer;

begin

  result := 0;

  for i := 0 to IndexMax do

   with Index[i] do begin

     if ndx>=0 then

       result := Comp(Results[A*FieldCount+ndx],Results[B*FieldCount+ndx]) else

       // Fields[].ndx=-1 for hidden ID column

       result := GetInt64(IDColumn[A])-GetInt64(IDColumn[B]);

     if result<>0 then begin

       if Desc then

         result := -result; // descending order -> inverse comparison

       exit;

     end;

   end;

end;



procedure TUTF8QuickSortMulti.QuickSort(L, R: Integer);

var I,J,P: integer;

    Tmp: PUTF8Char;

begin

  if L<R then

  repeat

    I := L;

    J := R;

    P := (L+R) shr 1;

    repeat

      while Compare(I,P)<0 do inc(I);

      while Compare(J,P)>0 do dec(J);

      if I<=J then begin

        if I<>J then begin // swap elements

          ExchgPtrUInt(PtrUInt(@Results[I*FieldCount]),

            PtrUInt(@Results[J*FieldCount]),FieldCount);

          if Assigned(IDColumn) then begin // update hidden ID column also

            Tmp := IDColumn[I];

            IDColumn[I] := IDColumn[J];

            IDColumn[J] := Tmp;

          end;

        end;

        if P=I then

          P := J else

        if P=J then

          P := I;

        inc(I);

        dec(J);

      end;

    until I>J;

    if L<J then

      QuickSort(L,J);

    L := I;

  until I >= R;

end;



procedure TSQLTable.SortFields(const Fields: array of integer;

  const Asc: array of boolean);

var Sort: TUTF8QuickSortMulti;

    i: integer;

begin

  if (self=nil) or (fRowCount<=1) or (FieldCount<=0) or (length(Fields)=0) then

    exit;

  Sort.FieldCount := FieldCount;

  Sort.IndexMax := high(Fields);

  SetLength(Sort.Index,Sort.IndexMax+1);

  for i := 0 to Sort.IndexMax do

  with Sort.Index[i] do begin

    ndx := Fields[i];

    if ndx<0 then begin // Fields[]=-1 for ID column

      if not Assigned(fIDColumn) then begin // leave ndx<0 for hidden ID

        ndx := fFieldIndexID;  // use the ID column

        if ndx<0 then

          exit; // no ID column available

        Comp := @UTF8CompareInt64;

      end;

      continue;

    end;

    Comp := SortCompare(ndx);

    if @Comp=nil then

      exit; // impossible to sort this kind of field (or invalid field index)

  end;

  for i := 0 to high(Asc) do

    if (i<=Sort.IndexMax) and not Asc[i] then

      Sort.Index[i].Desc := true;

  Sort.Results := fResults;

  Sort.IDColumn := @fIDColumn[0];

  Sort.QuickSort(1,fRowCount); // ignore first row = field names -> (1,RowCount)

end;



function TSQLTable.SortCompare(Field: integer): TUTF8Compare;

begin

  result := SQLFieldTypeComp[FieldType(Field,nil)];

end;



procedure TSQLTable.Assign(source: TSQLTable);

begin

  fResults := source.fResults;

  fRowCount := source.fRowCount;

  fFieldCount := source.fFieldCount;

end;



constructor TSQLTable.Create(const aSQL: RawUTF8);

begin

  fQuerySQL := aSQL;

  fFieldIndexID := -1;

  fQueryTableIndexFromSQL := -2; // indicates not searched

end;



constructor TSQLTable.CreateFromTables(const Tables: array of TSQLRecordClass;

  const aSQL: RawUTF8);

var n: integer;

begin

  Create(aSQL);

  n := length(Tables);

  if n>0 then begin

    SetLength(fQueryTables,n);

    MoveFast(Tables[0],fQueryTables[0],n*sizeof(TClass));

  end;

end;



constructor TSQLTable.CreateWithColumnTypes(const ColumnTypes: array of TSQLFieldType;

  const aSQL: RawUTF8);

begin

  Create(aSQL);

  SetLength(fQueryColumnTypes,length(ColumnTypes));

  MoveFast(ColumnTypes[0],fQueryColumnTypes[0],length(ColumnTypes)*sizeof(TSQLFieldType));

end;



destructor TSQLTable.Destroy;

begin

  fOwnedRecords.Free;

  inherited;

end;



function TSQLTable.QueryRecordType: TSQLRecordClass;

begin

  if (self<>nil) and (pointer(fQueryTables)<>nil) then

      result := fQueryTables[0] else

      result := nil;

end;



function TSQLTable.NewRecord(RecordType: TSQLRecordClass=nil): TSQLRecord;

begin

  result := nil;

  if self=nil then

    exit;

  if RecordType=nil then begin

    RecordType := QueryRecordType;

    if RecordType=nil then

      exit;

  end;

  result := RecordType.Create;

  if fOwnedRecords=nil then

    fOwnedRecords := TObjectList.Create;

  fOwnedRecords.Add(result);

end;



{$ifdef ISDELPHI2010} // Delphi 2009 generics are buggy

function TSQLTable.ToObjectList<T>: TObjectList<T>;

var R,Item: TSQLRecord;

    Row: PPUtf8Char;

    i: integer;

begin

  result := TObjectList<T>.Create; // TObjectList<T> will free each T instance

  if (self=nil) or (fRowCount=0) then

    exit;

  R := TSQLRecordClass(T).Create;

  try

    R.FillPrepare(self);

    Row := @fResults[FieldCount];     // Row^ points to first row of data

    {$ifdef ISDELPHIXE3}

    result.Count := fRowCount;         // faster than manual Add()

    for i := 0 to fRowCount-1 do begin

      Item := TSQLRecordClass(T).Create;

      PPointerArray(result.List)[i] := Item;

    {$else}

    for i := 0 to fRowCount-1 do begin

      Item := TSQLRecordClass(T).Create;

      Result.Add(Item);

    {$endif}

      R.fFill.Fill(pointer(Row),Item);

      Inc(Row,FieldCount); // next data row

    end;

  finally

    R.Free;

  end;

end;

{$endif}



procedure TSQLTable.ToObjectList(DestList: TObjectList; RecordType: TSQLRecordClass=nil);

var R: TSQLRecord;

    Row: PPUtf8Char;

    i: integer;

begin

  if DestList=nil then

    exit;

  DestList.Clear;

  if (self=nil) or (fRowCount=0) then

    exit;

  if RecordType=nil then begin

    RecordType := QueryRecordType;

    if RecordType=nil then

      exit;

  end;

  R := RecordType.Create;

  try

    R.FillPrepare(self);

    DestList.Count := fRowCount;       // faster than manual Add()

    Row := @fResults[FieldCount];     // Row^ points to first row of data

    for i := 0 to fRowCount-1 do begin // TObjectList will free each instance

      DestList.List[i] := RecordType.Create;

      R.fFill.Fill(pointer(Row),TSQLRecord(DestList.List[i]));

      Inc(Row,FieldCount); // next data row

    end;

  finally

    R.Free;

  end;

end;



function TSQLTable.ToObjArray(var ObjArray; RecordType: TSQLRecordClass=nil): boolean;

var R: TSQLRecord;

    Row: PPUtf8Char;

    i: integer;

    arr: array of TSQLRecord absolute ObjArray;

begin

  result := false;

  ObjArrayClear(ObjArray);

  if self=nil then

    exit;

  if RecordType=nil then begin

    RecordType := QueryRecordType;

    if RecordType=nil then

      exit;

  end;

  result := true;

  if fRowCount=0 then

    exit;

  R := RecordType.Create;

  try

    R.FillPrepare(self);

    SetLength(arr,fRowCount);       // faster than manual Add()

    Row := @fResults[FieldCount];   // Row^ points to first row of data

    for i := 0 to fRowCount-1 do begin

      arr[i] := RecordType.Create;

      R.fFill.Fill(pointer(Row),arr[i]);

      Inc(Row,FieldCount); // next data row

    end;

  finally

    R.Free;

  end;

end;



function TSQLTable.ToObjectList(RecordType: TSQLRecordClass=nil): TObjectList;

begin

  result := TObjectList.Create;

  ToObjectList(result,RecordType);

end;



function TSQLTable.Step(SeekFirst: boolean=false; RowVariant: PVariant=nil): boolean;

begin

  result := false;

  if (self=nil) or (fRowCount<=0) then

    exit; // nothing to iterate over

  if SeekFirst then

    fStepRow := 1 else

    if fStepRow>=fRowCount then

      exit else

      inc(fStepRow);

  result := true;

{$ifndef NOVARIANTS}

  if RowVariant=nil then

    exit;

  if SQLTableRowVariantType=nil then

    SQLTableRowVariantType := SynRegisterCustomVariantType(TSQLTableRowVariant);

  if (PVarData(RowVariant)^.VType=SQLTableRowVariantType.VarType) and

     (PSQLTableRowVariantData(RowVariant)^.VTable=self) and

     (PSQLTableRowVariantData(RowVariant)^.VRow<0) then

    exit; // already initialized -> quick exit

  VarClear(RowVariant^);

  PSQLTableRowVariantData(RowVariant)^.VType := SQLTableRowVariantType.VarType;

  PSQLTableRowVariantData(RowVariant)^.VTable := self;

  PSQLTableRowVariantData(RowVariant)^.VRow := -1; // follow fStepRow

{$endif NOVARIANTS}

end;



function TSQLTable.FieldBuffer(FieldIndex: Integer): PUTF8Char;

begin

  if (self=nil) or (cardinal(FieldIndex)>=cardinal(fFieldCount)) then

    raise ESQLTableException.CreateUTF8('%.FieldBuffer(%): invalid index',

      [self,FieldIndex]);

  if (fStepRow=0) or (fStepRow>fRowCount) then

    raise ESQLTableException.CreateUTF8('%.FieldBuffer(%): no previous Step',

      [self,FieldIndex]);

  result := fResults[fStepRow*FieldCount+FieldIndex];

end;



function TSQLTable.FieldBuffer(const FieldName: RawUTF8): PUTF8Char;

var i: integer;

begin

  i := FieldIndex(FieldName);

  if i<0 then

    raise ESQLTableException.CreateUTF8('%.FieldBuffer(%): unknown field',

      [self,FieldName]);

  if (fStepRow=0) or (fStepRow>fRowCount) then

    raise ESQLTableException.CreateUTF8('%.FieldBuffer(%): no previous Step',

      [self,FieldName]);

  result := fResults[fStepRow*FieldCount+i];

end;



function TSQLTable.FieldAsInteger(FieldIndex: Integer): Int64;

begin

  SetInt64(FieldBuffer(FieldIndex),result);

end;



function TSQLTable.FieldAsInteger(const FieldName: RawUTF8): Int64;

begin

  SetInt64(FieldBuffer(FieldName),result);

end;



function TSQLTable.FieldAsFloat(FieldIndex: Integer): TSynExtended;

begin

  result := GetExtended(FieldBuffer(FieldIndex));

end;



function TSQLTable.FieldAsFloat(const FieldName: RawUTF8): TSynExtended;

begin

  result := GetExtended(FieldBuffer(FieldName));

end;



{$ifndef NOVARIANTS}

function TSQLTable.Field(FieldIndex: integer): variant;

begin

  if (self=nil) or (cardinal(FieldIndex)>=cardinal(fFieldCount)) then

    raise ESQLTableException.CreateUTF8('%.Field(%): invalid index',

      [self,FieldIndex]);

  if (fStepRow=0) or (fStepRow>fRowCount) then

    raise ESQLTableException.CreateUTF8('%.Field(%): no previous Step',

      [self,FieldIndex]);

  GetVariant(fStepRow,FieldIndex,nil,result);

end;



function TSQLTable.Field(const FieldName: RawUTF8): variant;

var i: integer;

begin

  i := FieldIndex(FieldName);

  if i<0 then

    raise ESQLTableException.CreateUTF8('%.Field(%): unknown field',

      [self,FieldName]);

  result := Field(i);

end;

{$endif}



function TSQLTable.CalculateFieldLengthMean(var aResult: TIntegerDynArray;

  FromDisplay: boolean=false): integer;

procedure CalculateEnumerates(F: integer; P: PEnumType);

var R, i, n: integer;

    EnumCounts: array of integer; // slow GetCaption() will be called once

    U: PPUTF8Char;

begin

  if P=nil then

    exit; // no a true enumerate field

  // 1. count of every possible enumerated value into EnumCounts[]

  SetLength(EnumCounts,P^.MaxValue+1);

  U := @fResults[FieldCount+F]; // start reading after first Row (= Field Names)

  for R := 1 to fRowCount do begin

    n := GetInteger(U^);

    if n<=P^.MaxValue then

      // update count of every enumerated value

      inc(EnumCounts[n]) else

      // GetCaption(invalid index) displays first one

      inc(EnumCounts[0]);

    inc(U,FieldCount); // points to next row

  end;

  // 2. update aResult[F] with displayed caption text length

  n := 0;

  for i := 0 to P^.MaxValue do

    if EnumCounts[i]<>0 then

      inc(n,length(P^.GetCaption(i))*EnumCounts[i]);

  aResult[F] := n; // store displayed total length

end;

var R,F,n: integer;

    U: PPUTF8Char;

    Tot: cardinal;

begin

  SetLength(aResult,FieldCount);

  if FromDisplay and (length(fFieldLengthMean)=FieldCount) then begin

    MoveFast(fFieldLengthMean[0],aResult[0],FieldCount*sizeof(integer));

    result := fFieldLengthMeanSum;

    exit;

  end;

  if fRowCount=0 then begin

    // no data: calculate field length from first row (i.e. Field Names)

    U := @fResults[0];

    for F := 0 to FieldCount-1 do begin

      inc(aResult[F],Utf8FirstLineToUnicodeLength(U^));  // count

      inc(U); // points to next value

    end;

    Tot := 1;

  end else begin

    if not Assigned(fFieldType) then

      InitFieldTypes;

    U := @fResults[FieldCount]; // start reading after first Row

    for R := 1 to fRowCount do // sum all lengths by field

      for F := 0 to FieldCount-1 do begin

        case fFieldType[F].ContentType of

        sftInteger, sftBlob, sftBlobCustom, sftUTF8Custom, sftRecord,

        sftRecordVersion, sftID, sftTID, sftSet, sftCurrency:

          inc(aResult[F],8);

        else inc(aResult[F],Utf8FirstLineToUnicodeLength(U^));

        end;

        inc(U); // points to next value

      end;

    if Assigned(fQueryTables) then begin

      // aResult[] must be recalculated from captions, if exists

      for F := 0 to FieldCount-1 do

      with fFieldType[F] do

        case ContentType of

        sftEnumerate:

          CalculateEnumerates(F,ContentTypeInfo);

        end;

    end;

    Tot := fRowCount;

  end;

  result := 0;

  for F := 0 to FieldCount-1 do begin

    n := cardinal(aResult[F]) div Tot; // Mean = total/count

    if n=0 then n := 1;  // none should be 0

    aResult[F] := n;

    inc(result,n); // fast calculate mean sum

  end;

end;



function TSQLTable.FieldLengthMean(Field: integer): cardinal;

begin

  if (self=nil) or (cardinal(Field)>=cardinal(FieldCount)) or (fResults=nil) then

    result := 0 else begin

    if fFieldLengthMean=nil then

      // if not already calculated, do it now

      fFieldLengthMeanSum := CalculateFieldLengthMean(fFieldLengthMean);

    result := fFieldLengthMean[Field];

  end;

end;



function TSQLTable.FieldLengthMeanSum: cardinal;

begin

  if self=nil then

    result := 0 else begin

    if fFieldLengthMean=nil then

      FieldLengthMean(0); // initialize fFieldLengthMean[] and fFieldLengthMeanSum

    result := fFieldLengthMeanSum;

  end;

end;



function TSQLTable.FieldLengthMax(Field: integer; NeverReturnsZero: boolean): cardinal;

var i: integer;

    len: cardinal;

    U: PPUTF8Char;

begin

  result := 0;

  if (self<>nil) and (cardinal(Field)<cardinal(FieldCount)) then begin

    if not Assigned(fFieldType) then

      InitFieldTypes;

    with fFieldType[Field] do

    if ContentSize>=0 then

      // return already computed value

      result := ContentSize else begin

      if (ContentTypeInfo<>nil) and (ContentType=sftEnumerate) then begin

        // compute maximum size from available captions

        for i := 0 to PEnumType(ContentTypeInfo)^.MaxValue do begin

          len := length(PEnumType(ContentTypeInfo)^.GetCaption(i));

          if len>result then

            result := len;

        end;

      end else begin

        // compute by reading all data rows

        U := @fResults[FieldCount+Field];

        for i := 1 to fRowCount do begin

          len := StrLen(U^);

          if len>result then

            result := len;

          inc(U,FieldCount);

        end;

      end;

      ContentSize := result;

    end;

  end;

  if (result=0) and NeverReturnsZero then

    result := 1; // minimal not null length

end;



function TSQLTable.FieldTable(Field: integer): TSQLRecordClass;

begin

  if (self=nil) or (cardinal(Field)>=cardinal(FieldCount)) or (fQueryTables=nil) then

    result := nil else begin

    if not Assigned(fFieldType) then

       InitFieldTypes;

    Field := fFieldType[Field].TableIndex;

    if Field<0 then

      result := nil else

      result := fQueryTables[Field];

  end;

end;



procedure TSQLTable.SetFieldLengthMean(const Lengths: array of cardinal);

var F: integer;

    n: cardinal;

begin

  if (self=nil) or (length(Lengths)<>FieldCount) then

    exit;

  if fFieldLengthMean=nil then // if not already calculated, allocate array

    SetLength(fFieldLengthMean,FieldCount);

  fFieldLengthMeanSum := 0;

  for F := 0 to FieldCount-1 do begin

    n := Lengths[F];

    if n=0 then n := 1;  // none should be 0

    fFieldLengthMean[F] := n;

    inc(fFieldLengthMeanSum,n); // fast calculate mean sum

  end;

end;



procedure TSQLTable.FieldLengthMeanIncrease(aField, aIncrease: integer);

begin

  if (self=nil) or (cardinal(aField)>=cardinal(FieldCount)) then

    exit; // avoid GPF

  if fFieldLengthMean=nil then

    FieldLengthMean(0); // initialize fFieldLengthMean[] and fFieldLengthMeanSum

  inc(fFieldLengthMean[aField],aIncrease);

  inc(fFieldLengthMeanSum,aIncrease);

end;



function TSQLTable.SearchValue(const aUpperValue: RawUTF8;

  StartRow, FieldIndex: integer; Client: TObject; Lang: TSynSoundExPronunciation;

  UnicodeComparison: boolean): integer;

var U: PPUTF8Char;

    Kind: TSQLFieldType;

    Search: PAnsiChar;

    UpperUnicode: RawUnicode;

    UpperUnicodeLen: integer;

    EnumType: PEnumType;

    Val64: Int64;

    i,err: integer;

    EnumValue: RawUTF8;

    s: string;

    P: PShortString;

    EnumValues: set of 0..63;

    Soundex: TSynSoundEx;

    CL: TSQLRest absolute Client;

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

begin

  result := 0;

  if (self=nil) or (StartRow<=0) or (StartRow>fRowCount) or (aUpperValue='') or

     (cardinal(FieldIndex)>=cardinal(FieldCount)) then

    exit;

  Search := pointer(aUpperValue);

  if Search^='%' then begin

    inc(Search);

    if Search^='%' then begin

      inc(Search);

      if Search^='%' then begin

        inc(Search);

        Lang := sndxSpanish;

      end else

        Lang := sndxFrench;

    end else

      Lang := sndxEnglish;

  end;

  if ((Lang<>sndxNone) and not Soundex.Prepare(Search,Lang)) then

    exit;

  result := StartRow;

  Kind := FieldType(FieldIndex,@EnumType);

  U := @fResults[FieldCount*StartRow+FieldIndex];

  // search in one specified field value

  if (Kind=sftEnumerate) and (EnumType<>nil) then begin

    // for enumerates: first search in all available values

    Int64(EnumValues) := 0;

    P := @EnumType^.NameList;

    for i := 0 to EnumType^.MaxValue do begin

      EnumValue := TrimLeftLowerCaseShort(P);

      GetCaptionFromPCharLen(pointer(EnumValue),s);

      StringToUTF8(s,EnumValue);

      if ((Lang<>sndxNone) and SoundEx.UTF8(pointer(EnumValue))) or

         ((Lang=sndxNone) and FindUTF8(pointer(EnumValue),Search)) then

        include(EnumValues,i);

      inc(PByte(P),ord(P^[0])+1);

      // {$ifdef FPC}P := AlignToPtr(P);{$endif} enum values seem to be not aligned

    end;

    // then search directly from the INTEGER value

    if Int64(EnumValues)<>0 then

    while cardinal(result)<=cardinal(fRowCount) do begin

      i := GetInteger(U^,err);

      if (err=0) and (i in EnumValues) then

        exit; // we found a matching field

      inc(U,FieldCount); // ignore all other fields -> jump to next row data

      inc(Result);

    end;

    result := 0; // not found

    exit;

  end;

  // special cases: conversion from INTEGER to text before search

  if Kind in [sftTimeLog,sftModTime,sftCreateTime] then

    while cardinal(result)<=cardinal(fRowCount) do begin

      SetInt64(U^,Val64);

      if Val64<>0 then begin

        tmp[TTimeLogBits(Val64).Text(tmp,true,' ')] := #0;

        if FindAnsi(tmp,Search) then

          exit;

      end;

      inc(U,FieldCount); // ignore all other fields -> jump to next row data

      inc(Result);

    end

  else

  if ((Kind in [sftRecord,sftID,sftTID,sftSessionUserID]) and

     (Client<>nil) and Client.InheritsFrom(TSQLRest) and (CL.Model<>nil)) then

    while cardinal(result)<=cardinal(fRowCount) do begin

      SetInt64(U^,Val64);

      if Val64<>0 then begin

        if Kind=sftRecord then

          EnumValue := RecordRef(Val64).Text(CL.Model) else

          EnumValue := U^; // sftID/sftTID -> display ID number -> no sounded

        if Lang=sndxNone then begin

          if FindUTF8(pointer(EnumValue),Search) then exit;

        end else

          if SoundEx.UTF8(pointer(EnumValue)) then exit;

      end;

      inc(U,FieldCount); // ignore all other fields -> jump to next row data

      inc(Result);

    end

  else

  // by default, search as UTF-8 encoded text

  if Lang<>sndxNone then begin

    while cardinal(result)<=cardinal(fRowCount) do

    if SoundEx.UTF8(U^) then

      exit else begin

      inc(U,FieldCount); // ignore all other fields -> jump to next row data

      inc(Result);

    end;

  end else

  if UnicodeComparison then begin

    // slowest but always accurate Unicode comparison

    UpperUnicode := UTF8DecodeToRawUnicodeUI(RawUTF8(Search),@UpperUnicodeLen);

    while cardinal(result)<=cardinal(fRowCount) do

    if FindUnicode(pointer(Utf8DecodeToRawUnicode(U^,0)),

       pointer(UpperUnicode),UpperUnicodeLen) then

      exit else begin

      inc(U,FieldCount); // ignore all other fields -> jump to next row data

      inc(Result);

    end

  end else

    // default fast Win1252 search

    while cardinal(result)<=cardinal(fRowCount) do

    if FindUTF8(U^,Search) then

      exit else begin

      inc(U,FieldCount); // ignore all other fields -> jump to next row data

      inc(Result);

    end;

  result := 0; // not found

end;



function TSQLTable.SearchValue(const aUpperValue: RawUTF8;

  StartRow: integer; FieldIndex: PInteger; Client: TObject; Lang: TSynSoundExPronunciation;

  UnicodeComparison: boolean): integer;

var F, Row: integer;

begin

  result := 0;

  if (self=nil) or (StartRow<=0) or (StartRow>fRowCount) or (aUpperValue='') then

    exit;

  // search in all fields values

  for F := 0 to FieldCount-1 do begin

    Row := SearchValue(aUpperValue,StartRow,F,Client,Lang,UnicodeComparison);

    if (Row<>0) and ((result=0) or (Row<result)) then begin

      if FieldIndex<>nil then

        FieldIndex^ := F;

      result := Row;

    end;

  end;

end;



function TSQLTable.SearchFieldEquals(const aValue: RawUTF8; FieldIndex: integer): integer;

begin

  result := 0;

  if (self=nil) or (aValue='') or (cardinal(FieldIndex)>cardinal(fFieldCount)) then

    exit;

  for result := 1 to fRowCount do

    if UTF8IComp(Get(result,FieldIndex),pointer(aValue))=0 then

      exit;

  result := 0;

end;



{$ifndef NOVARIANTS}



function TSQLTable.GetVariant(Row, Field: integer; Client: TObject): Variant;

begin

  GetVariant(Row,Field,Client,result);

end;



procedure TSQLTable.GetVariant(Row,Field: integer; Client: TObject; var result: variant);

var aType: TSQLFieldType;

    aTypeInfo: pointer;

begin

  if Row=0 then // Field Name

    RawUTF8ToVariant(GetU(0,Field),result) else begin

    aType := FieldType(Field,@aTypeInfo);

    ValueVarToVariant(Get(Row,Field),aType,TVarData(result),true,aTypeInfo);

  end;

end;



function TSQLTable.GetValue(const aLookupFieldName,aLookupValue,aValueFieldName: RawUTF8): variant;

var f,r,v: integer;

begin

  SetVariantNull(result);

  f := FieldIndex(aLookupFieldName);

  v := FieldIndex(aValueFieldName);

  if (f<0) or (v<0) then

    exit;

  r := SearchFieldEquals(aLookupValue,f);

  if r>0 then

    GetVariant(r,v,nil,Result);

end;



{$endif NOVARIANTS}



function TSQLTable.ExpandAsString(Row, Field: integer; Client: TObject;

  out Text: string; const CustomFormat: string): TSQLFieldType;

var EnumType: PEnumType;

    err: integer;

    Value: Int64;

    Ref: RecordRef absolute Value;

label IsDateTime;

begin // Text was already forced to '' because was defined as "out" parameter

  if Row=0 then begin // Field Name

    result := sftUnknown;

    Text := GetCaption(0,Field);

    exit;

  end;

  result := FieldType(Field,@EnumType);

  case result of

  sftDateTime: begin

   Value := Iso8601ToTimeLogPUTF8Char(Get(Row,Field),0);

IsDateTime:

    if Value<>0 then begin

      {$ifndef LVCL}

      if CustomFormat<>'' then begin

        Text := FormatDateTime(CustomFormat,TTimeLogBits(Value).ToDateTime);

        if Text<>CustomFormat then

          exit; // valid conversion

      end;

      {$endif LVCL}

      Text := TTimeLogBits(Value).i18nText;

      exit;

    end;

  end;

  sftBlob:

    Text := '???';

  sftFloat:

    if CustomFormat<>'' then

    try

      if pos('%',CustomFormat)>0 then

        Text := Format(CustomFormat,[GetExtended(Get(Row,Field))])

        {$ifndef LVCL} else

        Text := FormatFloat(CustomFormat,GetExtended(Get(Row,Field)))

        {$endif LVCL};

      exit;

    except

      on {$ifdef LVCL}Exception{$else}EConvertError{$endif} do

        Text := '';

    end;

  sftCurrency:

    if CustomFormat<>'' then

    try

      if pos('%',CustomFormat)>0 then

        Text := Format(CustomFormat,[StrToCurrency(Get(Row,Field))])

        {$ifndef LVCL} else

        Text := FormatCurr(CustomFormat,StrToCurrency(Get(Row,Field)))

        {$endif};

      exit;

    except

      on {$ifdef LVCL}Exception{$else}EConvertError{$endif} do

        Text := '';

    end;

  sftEnumerate, sftSet, sftRecord, sftID, sftTID, sftRecordVersion, sftSessionUserID,

  sftTimeLog, sftModTime, sftCreateTime: begin

    Value := GetInt64(Get(Row,Field),err);

    if err<>0 then

      // not an integer -> to be displayed as sftUTF8Text

      result := sftUTF8Text else

    case result of

      sftEnumerate: begin

        Text := EnumType^.GetCaption(Value);

        exit;

      end;

      sftTimeLog, sftModTime, sftCreateTime:

        goto IsDateTime;

{      sftID, sftTID, sftSet, sftRecordVersion:

        result := sftUTF8Text; // will display INTEGER field as number }

      sftRecord:

        if (Value<>0) and

           (Client<>nil) and Client.InheritsFrom(TSQLRest) then // 'TableName ID'

          Text := {$ifdef UNICODE}Ansi7ToString{$endif}(Ref.Text(TSQLRest(Client).Model)) else

          result := sftUTF8Text; // display ID number if no table model

    end;

  end;

  end;

  if Text='' then

    // returns the value as text by default

    Text := GetString(Row,Field);

end;



function TSQLTable.ExpandAsSynUnicode(Row,Field: integer; Client: TObject; out Text: SynUnicode): TSQLFieldType;

var s: string;

begin

  result := ExpandAsString(Row,Field,Client,s);

  Text := StringToSynUnicode(s);

end;



function TSQLTable.GetTimeLog(Row, Field: integer; Expanded: boolean;

  FirstTimeChar: AnsiChar): RawUTF8;

var Value: TTimeLogBits;

begin

  SetInt64(Get(Row,Field),Value.Value);

  result := Value.Text(Expanded,FirstTimeChar);

end;





{$ifndef NOVARIANTS}



{ TSQLTableRowVariant }



procedure TSQLTableRowVariant.IntGet(var Dest: TVarData;

  const V: TVarData; Name: PAnsiChar);

var r,f: integer;

begin

  if (TSQLTableRowVariantData(V).VTable=nil) or (Name=nil) then

    ESQLTableException.CreateUTF8('Invalid %.% call',[self,Name]);

  r := TSQLTableRowVariantData(V).VRow;

  if r<0 then begin

    r := TSQLTableRowVariantData(V).VTable.fStepRow;

    if (r=0) or (r>TSQLTableRowVariantData(V).VTable.fRowCount) then

      raise ESQLTableException.CreateUTF8('%.%: no previous Step',[self,Name]);

  end;

  f := TSQLTableRowVariantData(V).VTable.FieldIndex(PUTF8Char(Name));

  if cardinal(f)>=cardinal(TSQLTableRowVariantData(V).VTable.fFieldCount) then

    raise ESQLTableException.CreateUTF8('%.%: unknown field',[self,Name]);

  TSQLTableRowVariantData(V).VTable.GetVariant(r,f,nil,Variant(Dest));

end;



procedure TSQLTableRowVariant.IntSet(const V, Value: TVarData; Name: PAnsiChar);

begin

  ESQLTableException.CreateUTF8('% is read-only',[self]);

end;



procedure TSQLTableRowVariant.Cast(var Dest: TVarData; const Source: TVarData);

begin

  CastTo(Dest,Source,VarType);

end;



procedure TSQLTableRowVariant.CastTo(var Dest: TVarData;

  const Source: TVarData; const AVarType: TVarType);

var r: integer;

    tmp: variant; // use a temporary TDocVariant for the conversion

begin

  if AVarType=VarType then begin

    RaiseCastError;

  end else begin

    if Source.VType<>VarType then

      RaiseCastError;

    r := TSQLTableRowVariantData(Source).VRow;

    if r<0 then

      r := TSQLTableRowVariantData(Source).VTable.fStepRow;

    TSQLTableRowVariantData(Source).VTable.ToDocVariant(r,tmp);

    RawUTF8ToVariant(VariantSaveJSON(tmp),Dest,AVarType);

  end;

end;



procedure TSQLTableRowVariant.ToJSON(W: TTextWriter; const Value: variant;

  Escape: TTextWriterKind);

var r: integer;

    tmp: variant; // write row via a TDocVariant

begin

  r := TSQLTableRowVariantData(Value).VRow;

  if r<0 then

    r := TSQLTableRowVariantData(Value).VTable.fStepRow;

  TSQLTableRowVariantData(Value).VTable.ToDocVariant(r,tmp);

  W.AddVariant(tmp,Escape);

end;



{$endif NOVARIANTS}





procedure Base64MagicToBlob(Base64: PUTF8Char; var result: RawUTF8);

begin

  // do not escape the result: returns e.g. X'53514C697465'

  result := TSQLRawBlobToBlob(Base64ToBin(PAnsiChar(Base64),StrLen(Base64)));

end;





{ TJSONObjectDecoder }



const

  EndOfJSONField = [',',']','}',':'];



function GetJSONArrayOrObject(P: PUTF8Char; out PDest: PUTF8Char;

  EndOfObject: PUTF8Char): RawUTF8;

var Beg: PUTF8Char;

begin

  PDest := nil;

  Beg := P;

  P := GotoNextJSONObjectOrArray(P); // quick go to end of array of object

  if P=nil then begin

    result := '';

    exit;

  end;

  if EndOfObject<>nil then

    EndOfObject^ := P^;

  PDest := P+1;

  SetString(result,PAnsiChar(Beg),P-Beg);

end;



function GetJSONArrayOrObjectAsQuotedStr(P: PUTF8Char; out PDest: PUTF8Char;

  EndOfObject: PUTF8Char): RawUTF8;

var Beg: PUTF8Char;

begin

  result := '';

  PDest := nil;

  Beg := P;

  P := GotoNextJSONObjectOrArray(P); // quick go to end of array of object

  if P=nil then

    exit;

  if EndOfObject<>nil then

    EndOfObject^ := P^;

  P^ := #0; // so Beg will be a valid ASCIIZ string

  PDest := P+1;

  result := QuotedStr(Beg,'''');

end;



procedure TJSONObjectDecoder.Decode(var P: PUTF8Char; const Fields: TRawUTF8DynArray;

  Params: TJSONObjectDecoderParams; const RowID: TID; ReplaceRowIDWithID: boolean);

var EndOfObject: AnsiChar;



  procedure GetSQLValue(ndx: integer);

  var wasString: boolean;

      res: PUTF8Char;

      c: integer;

  begin

    res := P;

    if res=nil then begin

      FieldValues[ndx] := ''; // avoid GPF, but will return invalid SQL

      exit;

    end;

    while res^ in [#1..' '] do inc(res);

    if (PInteger(res)^=NULL_LOW) and

       (res[4] in [#0,#9,#10,#13,' ',',','}',']'])  then begin

      /// GetJSONField('null') returns '' -> check here to make a diff with '""'

      FieldTypeApproximation[ndx] := ftaNull;

      FieldValues[ndx] := 'null';

      inc(res,4);

      while res^ in [#1..' '] do inc(res);

      if res^=#0 then

        P := nil else begin

        EndOfObject := res^;

        res^ := #0;

        P := res+1;

      end;

    end else begin

      // first check if nested object or array

      case res^ of // handle JSON {object} or [array] in P

      '{': begin // will work e.g. for custom variant types

        FieldTypeApproximation[ndx] := ftaObject;

        if params=pNonQuoted then

          FieldValues[ndx] := GetJSONArrayOrObject(res,P,@EndOfObject) else

          FieldValues[ndx] := GetJSONArrayOrObjectAsQuotedStr(res,P,@EndOfObject);

      end;

      '[': begin // will work e.g. for custom variant types

        FieldTypeApproximation[ndx] := ftaArray;

        if params=pNonQuoted then

          FieldValues[ndx] := GetJSONArrayOrObject(res,P,@EndOfObject) else

          FieldValues[ndx] := GetJSONArrayOrObjectAsQuotedStr(res,P,@EndOfObject);

      end;

      else begin

        // handle JSON string, number or false/true in P

        res := GetJSONField(res,P,@wasString,@EndOfObject);

        if wasString then begin

          c := PInteger(res)^ and $00ffffff;

          if c=JSON_BASE64_MAGIC then begin

            FieldTypeApproximation[ndx] := ftaBlob;

            case Params of

            pInlined: // untouched -> recognized as BLOB in SQLParamContent()

              QuotedStr(res,'''',FieldValues[ndx]);

{            pQuoted: // \uFFF0base64encodedbinary -> 'X''hexaencodedbinary'''

              // if not inlined, it can be used directly in INSERT/UPDATE statements

              Base64MagicToBlob(res+3,FieldValues[ndx]);

            pNonQuoted:}

            else // returned directly as RawByteString

              FieldValues[ndx] := Base64ToBin(res+3);

            end;

          end else begin

            if c=JSON_SQLDATE_MAGIC then begin

              FieldTypeApproximation[ndx] := ftaDate;

              inc(res,3); // ignore \uFFF1 magic marker

            end else

              FieldTypeApproximation[ndx] := ftaString;

            // regular string content

            if Params=pNonQuoted then

              // returned directly as RawUTF8

              SetString(FieldValues[ndx],PAnsiChar(res),StrLen(res)) else

              { escape SQL strings, cf. the official SQLite3 documentation:

                "A string 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." }

              QuotedStr(res,'''',FieldValues[ndx]);

          end;

        end else

          if res=nil then begin

            FieldValues[ndx] := ''; // avoid GPF, but will return invalid SQL

            exit;

          end else

          // non string params (numeric or false/true) are passed untouched

          if PInteger(res)^=FALSE_LOW then begin

            FieldValues[ndx] := '0';

            FieldTypeApproximation[ndx] := ftaBoolean;

          end else

          if PInteger(res)^=TRUE_LOW then begin

            FieldValues[ndx] := '1';

            FieldTypeApproximation[ndx] := ftaBoolean;

          end else begin

            FieldValues[ndx] := res;

            FieldTypeApproximation[ndx] := ftaNumber;

          end;

      end;

      end;

    end;

  end;



var FN: PUTF8Char;

    F: integer;

    FieldIsRowID: Boolean;

begin

  FieldCount := 0;

  DecodedRowID := 0;

  FillcharFast(FieldTypeApproximation,sizeof(FieldTypeApproximation),0);

  InlinedParams := Params=pInlined;

  if pointer(Fields)=nil then begin

    // get "COL1"="VAL1" pairs, stopping at '}' or ']'

    DecodedFieldNames := @FieldNames;

    if RowID>0 then begin // insert explicit RowID

      if ReplaceRowIDWithID then

        FieldNames[0] := 'ID' else

        FieldNames[0] := 'RowID';

      FieldValues[0] := Int64ToUtf8(RowID); // Int64ToUtf8(RowID,FieldValues[0]) fails on D2007

      FieldCount := 1;

      DecodedRowID := RowID;

    end;

    repeat

      if P=nil then

        break;

      FN := GetJSONPropName(P);

      if (FN=nil) or (P=nil) then

        break; // invalid JSON field name

      FieldIsRowID := IsRowId(FN);

      if FieldIsRowID then

        if RowID>0 then begin

          GetJSONField(P,P,nil,@EndOfObject); // ignore this if explicit RowID

          if EndOfObject in [#0,'}',']'] then

            break else continue;

        end else

        if ReplaceRowIDWithID then

          FN := 'ID';

      SetString(FieldNames[FieldCount],PAnsiChar(FN),StrLen(FN));

      GetSQLValue(FieldCount); // update EndOfObject

      if FieldIsRowID then

        SetID(FieldValues[FieldCount],DecodedRowID);

      inc(FieldCount);

      if FieldCount=MAX_SQLFIELDS then

        raise EParsingException.Create('Too many inlines in TJSONObjectDecoder');

    until EndOfObject in [#0,'}',']'];

  end else begin

    // get "VAL1","VAL2"...

    if P=nil then

      exit;

    if RowID>0 then

      raise EParsingException.Create('TJSONObjectDecoder(expanded) won''t handle RowID');

    if length(Fields)>MAX_SQLFIELDS then

      raise EParsingException.Create('Too many inlines in TJSONObjectDecoder');

    DecodedFieldNames := pointer(Fields);

    FieldCount := length(Fields);

    for F := 0 to FieldCount-1 do

      GetSQLValue(F); // update EndOfObject

  end;

end;



procedure TJSONObjectDecoder.Decode(const JSON: RawUTF8; const Fields: TRawUTF8DynArray;

  Params: TJSONObjectDecoderParams; const RowID: TID=0; ReplaceRowIDWithID: Boolean=false);

var tmp: TSynTempBuffer;

    P: PUTF8Char;

begin

  tmp.Init(JSON);

  try

    P := tmp.buf;

    if P<>nil then

      while P^ in [#1..' ','{','['] do inc(P);

    Decode(P,Fields,Params,RowID,ReplaceRowIDWithID);

  finally

    tmp.Done;

  end;

end;



function TJSONObjectDecoder.SameFieldNames(const Fields: TRawUTF8DynArray): boolean;

var i: integer;

begin

  result := false;

  if length(Fields)<>FieldCount then

    exit;

  for i := 0 to FieldCount-1 do

    if not IdemPropNameU(Fields[i],FieldNames[i]) then

      exit;

  result := true;

end;



procedure TJSONObjectDecoder.AssignFieldNamesTo(var Fields: TRawUTF8DynArray);

var i: integer;

begin

  SetLength(Fields,FieldCount);

  for i := 0 to FieldCount-1 do

    Fields[i] := FieldNames[i];

end;



function TJSONObjectDecoder.EncodeAsSQLPrepared(const TableName: RawUTF8;

  Occasion: TSQLOccasion; const UpdateIDFieldName: RawUTF8;

  BatchOptions: TSQLRestBatchOptions): RawUTF8;

var F: integer;

    W: TTextWriter;

begin

  W := TTextWriter.CreateOwnedStream(1024);

  try

    case Occasion of

    soUpdate: begin

      if FieldCount=0 then

        raise EORMException.Create('Invalid EncodeAsSQLPrepared(0)');

      W.AddShort('update ');

      W.AddString(TableName);

      W.AddShort(' set ');

      for F := 0 to FieldCount-1 do begin // append 'COL1=?,COL2=?'

        W.AddString(DecodedFieldNames^[F]);

        W.AddShort('=?,');

      end;

      W.CancelLastComma;

      W.AddShort(' where ');

      W.AddString(UpdateIDFieldName);

      W.Add('=','?');

    end;

    soInsert: begin

      if boInsertOrIgnore in BatchOptions then

        W.AddShort('insert or ignore into ') else

      if boInsertOrReplace in BatchOptions then

        W.AddShort('insert or replace into ') else

        W.AddShort('insert into ');

      W.AddString(TableName);

      if FieldCount=0 then

        W.AddShort(' default values') else begin

        W.Add(' ','(');

        for F := 0 to FieldCount-1 do begin // append 'COL1,COL2'

          W.AddString(DecodedFieldNames^[F]);

          W.Add(',');

        end;

        W.CancelLastComma;

        W.AddShort(') values (');

        W.AddStrings('?,',FieldCount);

        W.CancelLastComma;

        W.Add(')');

      end;

    end;

    else

      raise EORMException.Create('Invalid EncodeAsSQLPrepared() call');

    end;

    W.SetText(result);

  finally

    W.Free;

  end;

end;



function TJSONObjectDecoder.EncodeAsSQL(Update: boolean): RawUTF8;

var F: integer;

    W: TTextWriter;

procedure AddValue;

begin

  if InlinedParams then

    W.AddShort(':(');

  W.AddString(FieldValues[F]);

  if InlinedParams then

    W.AddShort('):,') else

    W.Add(',');

end;

begin

  result := '';

  if FieldCount=0 then

    exit;

  W := TTextWriter.CreateOwnedStream(2048);

  try

    if Update then begin

      for F := 0 to FieldCount-1 do // append 'COL1=...,COL2=...'

      if not IsRowID(pointer(DecodedFieldNames^[F])) then begin

        W.AddString(DecodedFieldNames^[F]);

        W.Add('=');

        AddValue;

      end;

      W.CancelLastComma;

    end else begin // returns ' (COL1,COL2) VALUES ('VAL1',VAL2)'

      W.Add(' ','(');

      for F := 0 to FieldCount-1 do begin // append 'COL1,COL2'

        W.AddString(DecodedFieldNames^[F]);

        W.Add(',');

      end;

      W.CancelLastComma;

      W.AddShort(') VALUES (');

      for F := 0 to FieldCount-1 do

        AddValue;

      W.CancelLastComma;

      W.Add(')');

    end;

    W.SetText(result);

  finally

    W.Free;

  end;

end;



procedure TJSONObjectDecoder.EncodeAsJSON(out result: RawUTF8);

var F: integer;

    W: TTextWriter;

begin

  if FieldCount=0 then

    exit;

  W := TTextWriter.CreateOwnedStream(2048);

  try

    W.Add('{');

    for F := 0 to FieldCount-1 do begin

      W.AddFieldName(DecodedFieldNames^[F]);

      W.AddQuotedStringAsJSON(FieldValues[F]);

      W.Add(',');

    end;

    W.CancelLastComma;

    W.Add('}');

    W.SetText(result);

  finally

    W.Free;

  end;

end;



function TJSONObjectDecoder.FindFieldName(const FieldName: RawUTF8): integer;

begin

  for result := 0 to FieldCount-1 do

    if IdemPropNameU(FieldNames[result],FieldName) then

      exit;

  result := -1;

end;



procedure TJSONObjectDecoder.AddFieldValue(const FieldName,FieldValue: RawUTF8;

  FieldType: TJSONObjectDecoderFieldType);

begin

  if FieldCount=MAX_SQLFIELDS then

    raise EParsingException.CreateUTF8(

      'Too many fields for TJSONObjectDecoder.AddField(%)',[FieldName]);

  FieldNames[FieldCount] := FieldName;

  FieldValues[FieldCount] := FieldValue;

  FieldTypeApproximation[FieldCount] := FieldType;

  inc(FieldCount);

end;



const

  FROMINLINED: array[boolean] of TJSONObjectDecoderParams = (

    pQuoted, pInlined);



function GetJSONObjectAsSQL(var P: PUTF8Char; const Fields: TRawUTF8DynArray;

  Update, InlinedParams: boolean; RowID: TID=0; ReplaceRowIDWithID: Boolean=false): RawUTF8;

var Decoder: TJSONObjectDecoder;

begin

  Decoder.Decode(P,Fields,FROMINLINED[InlinedParams],RowID,ReplaceRowIDWithID);

  result := Decoder.EncodeAsSQL(Update);

end;



function GetJSONObjectAsSQL(const JSON: RawUTF8; Update, InlinedParams: boolean;

 RowID: TID=0; ReplaceRowIDWithID: Boolean=false): RawUTF8; overload;

var Decoder: TJSONObjectDecoder;

begin

  Decoder.Decode(JSON,nil,FROMINLINED[InlinedParams],RowID,ReplaceRowIDWithID);

  result := Decoder.EncodeAsSQL(Update);

end;



function Expect(var P: PUTF8Char; const Value: RawUTF8): boolean;

  {$ifdef HASINLINE}inline;{$endif}

var L: integer;

begin

  if P=nil then

    result := false else begin

    while P^ in [#1..' '] do inc(P);

    if Value='' then

      result := false else begin

      L := length(Value);

      result := CompareMem(P,pointer(Value),L);

      if result then

        inc(P,L);

    end;

  end;

end;



function GetJSONIntegerVar(var P: PUTF8Char): PtrInt;

var c: PtrUInt;

begin

  if P^ in [#1..' '] then repeat inc(P) until not(P^ in [#1..' ']);

  c := byte(P^)-48;

  if c>9 then

    result := 0 else begin

    result := c;

    inc(P);

    repeat

      c := byte(P^)-48;

      if c>9 then

        break;

      result := result*10+PtrInt(c);

      inc(P);

    until false;

  end;

end;



function GetJSONInt64Var(var P: PUTF8Char): Int64;

var c: PtrUInt;

begin

  if P^ in [#1..' '] then repeat inc(P) until not(P^ in [#1..' ']);

  c := byte(P^)-48;

  if c>9 then

    result := 0 else begin

    result := c;

    inc(P);

    repeat

      c := byte(P^)-48;

      if c>9 then

        break;

      result := result*10+Int64(c);

      inc(P);

    until false;

  end;

end;



const

  FIELDCOUNT_PATTERN: RawUTF8 = '{"fieldCount":';

  ROWCOUNT_PATTERN: RawUTF8 = ',"rowCount":';

  VALUES_PATTERN: RawUTF8 = ',"values":[';



function UnJSONFirstField(var P: PUTF8Char): RawUTF8;

// expand=true: [ {"col1":val11} ] -> val11

// expand=false: { "fieldCount":1,"values":["col1",val11] } -> vall11

begin

  result := '';

  if P=nil then exit;

  if Expect(P,FIELDCOUNT_PATTERN) then begin

    // not expanded format

    if GetJSONIntegerVar(P)<>1 then

      exit; // wrong field count

    while P^<>'[' do if P^=#0 then exit else inc(P); // go to ["col1"

    inc(P); // go to "col1"

  end else begin

    // expanded format

    while P^<>'[' do if P^=#0 then exit else inc(P); // need an array of objects

    repeat inc(P); if P^=#0 then exit; until P^='{'; // go to object begining

  end;

  GetJSONPropName(P); // ignore field name

  result := GetJSONField(P,P); // get field value

end;



function IsNotAjaxJSON(P: PUTF8Char): Boolean;

begin

  result := Expect(P,FIELDCOUNT_PATTERN);

end;



function NotExpandedBufferRowCountPos(P,PEnd: PUTF8Char): PUTF8Char;

var i: integer;

begin

  result := nil;

  if (PEnd<>nil) and (PEnd-P>24) then

    for i := 1 to 24 do // search for "rowCount": at the end of the JSON buffer

    case PEnd[-i] of

    ']',',':

      exit;

    ':': begin

      if CompareMem(PEnd-i-11,pointer(ROWCOUNT_PATTERN),11) then

        result := PEnd-i+1;

      exit;

    end;

    end;

end;



function IsNotExpandedBuffer(var P: PUTF8Char; PEnd: PUTF8Char;

  var FieldCount,RowCount: integer): boolean;

  procedure GetRowCountNotExpanded(P: PUTF8Char);

  begin

    RowCount := 0;

    repeat

      // get a row

      P := GotoNextJSONItem(P,FieldCount);

      if P=nil then exit; // unexpected end

      inc(RowCount);

    until P[-1]=']'; // end of array

    if P^ in ['}',','] then begin // expected formated JSON stream

      if RowCount>0 then

        dec(RowCount); // first Row = field names -> data in rows 1..RowCount

    end else

      RowCount := -1; // bad format -> no data

  end;

var RowCountPos: PUTF8Char;

begin

  if not Expect(P,FIELDCOUNT_PATTERN) then begin

    result := false;

    exit;

  end;

  FieldCount := GetJSONIntegerVar(P);

  if Expect(P,ROWCOUNT_PATTERN) then

    RowCount := GetJSONIntegerVar(P) else begin

    RowCountPos := NotExpandedBufferRowCountPos(P,PEnd);

    if RowCountPos=nil then

      RowCount := -1 else // mark "rowCount":.. not available

      RowCount := GetCardinal(RowCountPos);

  end;

  result := (FieldCount<>0) and Expect(P,VALUES_PATTERN);

  if result and (RowCount<0) then

    GetRowCountNotExpanded(P); // returns RowCount=-1 if P^ is invalid

end;



function StartWithQuotedID(P: PUTF8Char; out ID: TID): boolean;

begin

  if PCardinal(P)^ and $ffffdfdf=

      ord('I')+ord('D')shl 8+ord('"')shl 16+ord(':')shl 24 then begin

    SetID(P+4,ID);

    result := true;

    exit;

  end else

  if (PCardinalArray(P)^[0] and $dfdfdfdf=

       ord('R')+ord('O')shl 8+ord('W')shl 16+ord('I')shl 24) and

     (PCardinalArray(P)^[1] and $ffffdf=

       ord('D')+ord('"')shl 8+ord(':')shl 16) then begin

    SetID(P+7,ID);

    result := true;

    exit;

  end;

  ID := 0;

  result := false;

end;



function StartWithID(P: PUTF8Char; out ID: TID): boolean;

begin

  if PCardinal(P)^ and $ffdfdf=

      ord('I')+ord('D')shl 8+ord(':')shl 16 then begin

    SetID(P+3,ID);

    result := true;

    exit;

  end else

  if (PCardinalArray(P)^[0] and $dfdfdfdf=

       ord('R')+ord('O')shl 8+ord('W')shl 16+ord('I')shl 24) and

     (PCardinalArray(P)^[1] and $ffdf=ord('D')+ord(':')shl 8) then begin

    SetID(P+6,ID);

    result := true;

    exit;

  end;

  ID := 0;

  result := false;

end;



function JSONGetID(P: PUTF8Char; out ID: TID): Boolean;

begin

  if (P<>nil) and

     NextNotSpaceCharIs(P,'{') then

     if NextNotSpaceCharIs(P,'"') then

       result := StartWithQuotedID(P,ID) else

       result := StartWithID(P,ID) else begin

    ID := 0;

    result := false;

  end;

end;



function JSONGetObject(var P: PUTF8Char; ExtractID: PID;

  var EndOfObject: AnsiChar; KeepIDField: boolean): RawUTF8;

var Beg, PC: PUTF8Char;

begin

  result := '';

  if P=nil then

    exit;

  if P^ in [#1..' '] then repeat inc(P) until not(P^ in [#1..' ']);

  if P^<>'{' then

    exit;

  Beg := P;

  P := GotoNextJSONObjectOrArray(Beg);

  if (P<>nil) and not (P^ in EndOfJSONField) then

    P := nil;

  if P<>nil then begin

    EndOfObject := P^;

    inc(P); // ignore end of object, i.e. ',' or ']'

    if ExtractID<>nil then

      if JSONGetID(Beg,ExtractID^) and not KeepIDField then begin

        PC := PosChar(Beg,','); // ignore the '"ID":203,' pair

        PC^ := '{';

        SetString(result,PAnsiChar(PC),P-PC-1);

        exit;

      end;

    SetString(result,PAnsiChar(Beg),P-Beg-1);

  end;

end;





{ TSQLTableJSON }



function TSQLTableJSON.PrivateCopyChanged(aJSON: PUTF8Char; aLen: integer): boolean;

var Hash: cardinal;

begin

  Hash := crc32c(0,pointer(aJSON),aLen);

  result := (fPrivateCopyHash=0) or (Hash=0) or (Hash<>fPrivateCopyHash);

  if not result then

    exit;

  SetString(fPrivateCopy,PAnsiChar(aJSON),aLen);

  fPrivateCopyHash := Hash;

end;



function TSQLTableJSON.ParseAndConvert(Buffer: PUTF8Char; BufferLen: integer): boolean;

function GetFieldCountExpanded(P: PUTF8Char): integer;

var EndOfObject: AnsiChar;

begin

  result := 0;

  repeat

    P := GotoNextJSONItem(P,2,@EndOfObject); // ignore Name+Value items

    if P=nil then begin // unexpected end

      result := 0;

      exit;

    end;

    inc(result);

    if EndOfObject='}' then break; // end of object

  until false;

end;

var i, max, nfield, nrow, resmax, f: integer;

    EndOfObject: AnsiChar;

    P: PUTF8Char;

    wasString: Boolean;

begin

  result := false; // error on parsing

  fFieldIndexID := -1;

  if (self=nil) or (Buffer=nil) then

    exit;

  // go to start of object

  P := GotoNextNotSpace(Buffer);

  if IsNotExpandedBuffer(P,Buffer+BufferLen,fFieldCount,fRowCount) then begin

    // A. Not Expanded format

(* {"fieldCount":9,"values":["ID","Int","Test","Unicode","Ansi","ValFloat","ValWord",

    "ValDate","Next",0,0,"abcde+¬ef+á+¬","abcde+¬ef+á+¬","abcde+¬ef+á+¬",

    3.14159265300000E+0000,1203,"2009-03-10T21:19:36",0,..],"rowCount":20} *)

    // 1. check RowCount and DataLen

    if fRowCount<0 then begin // IsNotExpanded() notified wrong input

      fRowCount := 0; // may occur if P^ content was invalid

      exit;

    end;

    // 2. initialize and fill fResults[] PPUTF8CharArray memory

    max := (fRowCount+1)*FieldCount;

    SetLength(fJSONResults,max);

    fResults := @fJSONResults[0];

    // unescape+zeroify JSONData + fill fResults[] to proper place

    dec(max);

    f := 0;

    for i := 0 to max do begin

      // get a field

      fJSONResults[i] := GetJSONFieldOrObjectOrArray(P,@wasString,nil,true);

      if (P=nil) and (i<>max) then

        exit; // failure (GetRowCountNotExpanded should have detected it)

      if i>=FieldCount then begin

        if wasString then

          Include(fFieldParsedAsString,f); // mark column was "string"

        inc(f);

        if f=FieldCount then

          f := 0; // check all rows

      end;

    end;

  end else begin

    // B. Expanded format

(* [{"ID":0,"Int":0,"Test":"abcde+¬ef+á+¬","Unicode":"abcde+¬ef+á+¬","Ansi":

    "abcde+¬ef+á+¬","ValFloat": 3.14159265300000E+0000,"ValWord":1203,

    "ValDate":"2009-03-10T21:19:36","Next":0},{..}] *)

    // 1. get fields count from first row

    while P^<>'[' do if P^=#0 then exit else inc(P); // need an array of objects

    repeat inc(P); if P^=#0 then exit; until P^ in ['{',']']; // go to object beginning

    if P^=']' then begin // [] -> void data

      result := true;

      exit;

    end;

    inc(P);

    nfield := GetFieldCountExpanded(P);

    if nField=0 then

      exit; // invalid data for first row

    // 2. get values (assume fields are always the same as in the first object)

    max := nfield; // index to start storing values in fResults[]

    resmax := nfield*2;

    SetLength(fJSONResults,resmax); // space for field names + 1 data row

    nrow := 0;

    repeat // let fJSONResults[] point to unescaped+zeroified JSON values

      f := 0;

      for i := 0 to nfield-1 do begin

        if nrow=0 then // get field name from 1st Row

          fJSONResults[i] := GetJSONPropName(P) else

          P := GotoNextJSONItem(P);  // ignore field name for later rows

        if max>=resmax then begin // check space inside loop for GPF security

          inc(resmax,resmax shr 3+nfield shl 8);

          SetLength(fJSONResults,resmax); // enough space for 256 more rows

        end;

        if P=nil then break; // normal end: no more field name

        fJSONResults[max] := GetJSONFieldOrObjectOrArray(

          P,@wasString,@EndOfObject,true);

        if P=nil then begin

          nfield := 0;

          break; // unexpected end

        end;

        if wasString then // mark column was "string"

          Include(fFieldParsedAsString,f);

        inc(f);

        inc(max);

        if f=nField then

          f := 0; // check all rows

      end;

      if P=nil then

        break; // unexpected end

      if EndOfObject<>'}' then

        break; // data field layout is not consistent: should never happen

      inc(nrow);

      while (P^<>'{') and (P^<>']') do // go to next object beginning

        if P^=#0 then

          exit else

          inc(P);

      if P^=']' then

        break else

        inc(P); // jmp '{'

    until false;

    if max<>(nrow+1)*nfield then begin // field count must be the same for all objects

      fFieldCount := 0;

      fRowCount := 0;

      exit; // data field layout is not consistent: should never happen

    end;

    // 3. save field pointers to fResults[]

    SetLength(fJSONResults,max); // resize to exact size

    fResults := @fJSONResults[0];

    fFieldCount := nfield;

    fRowCount := nrow;

  end;

  for i := 0 to fFieldCount-1 do

    if IsRowID(fResults[i]) then begin

      fFieldIndexID := i;

      break;

    end;

  result := true; // if we reached here, means successfull conversion from P^

end;



function TSQLTableJSON.UpdateFrom(const aJSON: RawUTF8; var Refreshed: boolean;

  PCurrentRow: PInteger): boolean;

var len: Integer;

begin

  len := length(aJSON);

  if PrivateCopyChanged(pointer(aJSON),len) then

    if ParseAndConvert(pointer(fPrivateCopy),len) then begin

     // parse success from new aJSON data -> need some other update?

     if Assigned(fIDColumn) then begin

       // ID column was hidden -> do it again

       Finalize(fIDColumn);

       IDColumnHide;

     end;

     with fSortParams do

       if FieldCount<>0 then

         // TSQLTable.SortFields() was called -> do it again

         SortFields(FieldIndex,Asc,PCurrentRow,FieldType);

     Refreshed := true;

     result := true;

    end else

      // parse error

      result := false else

    // data didn't change (fPrivateCopyHash checked)

    result := true;

end;



constructor TSQLTableJSON.Create(const aSQL: RawUTF8; JSONBuffer: PUTF8Char; JSONBufferLen: integer);

begin // don't raise exception on error parsing

  inherited Create(aSQL);

  ParseAndConvert(JSONBuffer,JSONBufferLen);

end;



constructor TSQLTableJSON.Create(const aSQL, aJSON: RawUTF8);

var len: integer;

begin

  len := length(aJSON);

  SetString(fPrivateCopy,PAnsiChar(pointer(aJSON)),len);

  Create(aSQL,pointer(fPrivateCopy),len);

end;



constructor TSQLTableJSON.CreateFromTables(const Tables: array of TSQLRecordClass;

  const aSQL: RawUTF8; JSONBuffer: PUTF8Char; JSONBufferLen: integer);

begin // don't raise exception on error parsing

  inherited CreateFromTables(Tables,aSQL);

  ParseAndConvert(JSONBuffer,JSONBufferLen);

end;



constructor TSQLTableJSON.CreateFromTables(const Tables: array of TSQLRecordClass; const aSQL,

  aJSON: RawUTF8);

var len: integer;

begin

  len := length(aJSON);

  SetString(fPrivateCopy,PAnsiChar(pointer(aJSON)),len);

  CreateFromTables(Tables,aSQL,pointer(fPrivateCopy),len);

end;



constructor TSQLTableJSON.CreateWithColumnTypes(const ColumnTypes: array of TSQLFieldType;

  const aSQL: RawUTF8; JSONBuffer: PUTF8Char; JSONBufferLen: integer);

begin // don't raise exception on error parsing

  inherited CreateWithColumnTypes(ColumnTypes,aSQL);

  ParseAndConvert(JSONBuffer,JSONBufferLen);

end;



constructor TSQLTableJSON.CreateWithColumnTypes(const ColumnTypes: array of TSQLFieldType;

  const aSQL, aJSON: RawUTF8);

var len: integer;

begin

  len := length(aJSON);

  SetString(fPrivateCopy,PAnsiChar(pointer(aJSON)),len);

  CreateWithColumnTypes(ColumnTypes,aSQL,pointer(fPrivateCopy),len);

end;





{ TINIWriter }



procedure TINIWriter.WriteObject(Value: TObject; const SubCompName: RawUTF8='';

  WithSection: boolean=true);

var P: PPropInfo;

    i, V: integer;

    VT: shortstring; // for str()

    Obj: TObject;

    tmp: RawUTF8;

    {$ifndef NOVARIANTS}

    VV: Variant;

    {$endif}

begin

  if Value<>nil then begin

    if WithSection then

      // new TObject.ClassName is UnicodeString (Delphi 20009) -> inline code with

      // vmtClassName = UTF-8 encoded text stored in a shortstring = -44

      Add(#13'[%]'#13,[PShortString(PPointer(PPtrInt(Value)^+vmtClassName)^)^]);

    for i := 1 to InternalClassPropInfo(Value.ClassType,P) do begin

      case P^.PropType^.Kind of

        tkInt64{$ifdef FPC}, tkQWord{$endif}:

          Add('%%=%'#13,[SubCompName,P^.Name,P^.GetInt64Prop(Value)]);

        {$ifdef FPC}tkBool,{$endif}

        tkEnumeration, tkInteger, tkSet: begin

          V := P^.GetOrdProp(Value);

          if V<>P^.Default then

            Add('%%=%'#13,[SubCompName,P^.Name,V]);

        end;

        {$ifdef FPC}tkAString,{$endif} tkLString, tkWString

        {$ifdef HASVARUSTRING},tkUString{$endif}: begin

          P^.GetLongStrValue(Value,tmp);

          Add('%%=%'#13,[SubCompName,P^.Name,tmp]);

        end;

        tkFloat: begin

          VT[0] := AnsiChar(ExtendedToString(VT,P^.GetFloatProp(Value),DOUBLE_PRECISION));

          Add('%%=%'#13,[SubCompName,P^.Name,VT]);

        end;

        tkDynArray: begin

          Add('%%=%'#13,[SubCompName,P^.Name]);

          AddDynArrayJSON(P^.GetDynArray(Value));

          Add(#13);

        end;

        {$ifdef PUBLISHRECORD}

        tkRecord{$ifdef FPC},tkObject{$endif}:

          Add('%%=%'#13,[SubCompName,P^.Name,BinToBase64WithMagic(

            RecordSave(P^.GetFieldAddr(Value)^,P^.PropType^))]);

        {$endif}

        tkClass: begin

          Obj := P^.GetObjProp(Value);

          if (Obj<>nil) and ClassHasPublishedFields(PPointer(Obj)^) then

             WriteObject(Obj,SubCompName+ToUTF8(P^.Name)+'.',false);

        end;

        {$ifndef NOVARIANTS}

        tkVariant: begin // stored as JSON, e.g. '1.234' or '"text"'

          P^.GetVariantProp(Value,VV);

          Add('%%=%'#13,[SubCompName,P^.Name,VariantSaveJSON(VV)]);

        end;

        {$endif}

      end; // tkString (shortstring) and tkInterface is not handled

      P := P^.Next;

    end;

  end;

end;



function UTF8ContentNumberType(P: PUTF8Char): TSQLFieldType;

begin

  if (P=nil) or ((PInteger(P)^=ord('n')+ord('u')shl 8+ord('l')shl 16+

                 ord('l')shl 24) and (P[4]=#0)) then

    result := sftUnknown else

    case TextToVariantNumberType(P) of

    varInt64:    result := sftInteger;

    varDouble:   result := sftFloat;

    varCurrency: result := sftCurrency;

    else         result := sftUTF8Text;

    end;

end;



function UTF8ContentType(P: PUTF8Char): TSQLFieldType;

var c,len: integer;

begin

  if P<>nil then begin

    if P^ in [#1..' '] then repeat inc(P) until not(P^ in [#1..' ']);

    if (PInteger(P)^=NULL_LOW) and (P[4]=#0) then

       result := sftUnknown else

      // don't check for 'false' or 'true' here, since their UTF-8 value is 0/1

      if P^ in ['-','0'..'9'] then

      case TextToVariantNumberType(P) of

      varInt64:    result := sftInteger;

      varDouble:   result := sftFloat;

      varCurrency: result := sftCurrency;

      else begin

        len := StrLen(P);

        if (len>15) and (Iso8601ToTimeLogPUTF8Char(P,len)<>0) then

          result := sftDateTime else

          result := sftUTF8Text;

      end;

      end else begin

        c := PInteger(P)^ and $00ffffff;

        if (c=JSON_BASE64_MAGIC) or ((P^='''') and isBlobHex(P)) then

          result := sftBlob else

        if c=JSON_SQLDATE_MAGIC then

          result := sftDateTime else

          result := sftUTF8Text;

      end;

  end else

    result := sftUnknown;

end;





{ TPropInfo }



function TPropInfo.ClassFromJSON(Instance: TObject; From: PUTF8Char;

  var Valid: boolean; Options: TJSONToObjectOptions): PUTF8Char;

var Field: ^TObject;

    tmp: TObject;

begin

  valid := false;

  result := nil;

  if (@self=nil) or (PropType^.Kind<>tkClass) or (Instance=nil) then

    exit;

  if SetterIsField then

    // setter to field -> direct in-memory access

    Field := SetterAddr(Instance) else

  {$ifndef FPC}

  if SetProc<>0  then begin

    // it is a setter method -> create a temporary object

    tmp := PropType^.ClassCreate;

    try

      result := JSONToObject(tmp,From,Valid,nil,Options);

      if not Valid then

        FreeAndNil(tmp) else begin

        SetOrdProp(Instance,PtrInt(tmp)); // PtrInt(tmp) is OK for CPU64

        if j2oSetterExpectsToFreeTempInstance in Options then

          FreeAndNil(tmp);

      end;

    except

      on Exception do

        tmp.Free;

    end;

    exit;

  end else

  {$endif}

  if GetterIsField then

    // no setter -> use direct in-memory access from getter (if available)

    Field := GetterAddr(Instance) else

    // no setter, nor direct field offset -> impossible to set the instance

    exit;

  result := JSONToObject(Field^,From,Valid,nil,Options);

end;



function TPropInfo.GetOrdValue(Instance: TObject): PtrInt;

begin

  if (Instance<>nil) and (@self<>nil) and

     (PropType^.Kind in [

       tkInteger,tkEnumeration,tkSet,{$ifdef FPC}tkBool,{$endif}tkClass]) then

    result := GetOrdProp(Instance) else

    result := -1;

end;



function TPropInfo.GetInt64Value(Instance: TObject): Int64;

begin

  if (Instance<>nil) and (@self<>nil) then

  case PropType^.Kind of

    tkInteger,tkEnumeration,tkSet,tkChar,tkWChar,tkClass{$ifdef FPC},tkBool{$endif}:

      result := GetOrdProp(Instance);

    tkInt64{$ifdef FPC},tkQWord{$endif}:

      result := GetInt64Prop(Instance);

    else result := 0;

  end else

    result := 0;

end;



function TPropInfo.GetCurrencyValue(Instance: TObject): Currency;

begin

  if (Instance<>nil) and (@self<>nil) and (PropType^.Kind=tkFloat) and

     (PropType^.FloatType=ftCurr) then

    result := GetCurrencyProp(Instance) else

    result := 0;

end;



function TPropInfo.GetExtendedValue(Instance: TObject): TSynExtended;

begin

  if (Instance<>nil) and (@self<>nil) and (PropType^.Kind=tkFloat) then

     result := GetFloatProp(Instance) else

     result := 0;

end;



procedure TPropInfo.SetExtendedValue(Instance: TObject; const Value: TSynExtended);

begin

  if (Instance<>nil) and (@self<>nil) and (PropType^.Kind=tkFloat) then

    SetFloatProp(Instance,Value);

end;



function TPropInfo.GetDynArray(Instance: TObject): TDynArray;

begin

  result.Init(TypeInfo,GetFieldAddr(Instance)^);

end;



procedure TPropInfo.GetDynArray(Instance: TObject; var result: TDynArray);

begin

  result.Init(TypeInfo,GetFieldAddr(Instance)^);

end;



function TPropInfo.DynArrayIsObjArray: boolean;

begin

  if PropType^.Kind=tkDynArray then

    result := ObjArraySerializers.Find(TypeInfo)<>nil else

    result := false;

end;



function TPropInfo.DynArrayIsObjArrayInstance: PClassInstance;

begin

  if PropType^.Kind<>tkDynArray then

    result := nil else

    result := TJSONSerializer.RegisterObjArrayFindType(TypeInfo);

end;



procedure TPropInfo.GetLongStrValue(Instance: TObject; var result: RawUTF8);

var tmp: RawByteString;

    tmpWS: WideString;

    cp: integer;

begin

  if (Instance<>nil) and (@self<>nil) then

  case PropType^.Kind of

  {$ifdef FPC}tkAString,{$endif} tkLString: begin

    GetLongStrProp(Instance,tmp);

    if tmp='' then

      result := '' else begin

      cp := PropType^.AnsiStringCodePage;

      case cp of

        CP_UTF8:       result := tmp;

        CP_SQLRAWBLOB: result := TSQLRawBlobToBlob(TSQLRawBlob(tmp));

        else           result := TSynAnsiConvert.Engine(cp).AnsiToUTF8(tmp);

      end;

    end;

  end;

  {$ifdef HASVARUSTRING}

  tkUString:

    result := UnicodeStringToUTF8(GetUnicodeStrProp(Instance));

  {$endif}

  tkWString: begin

    GetWideStrProp(Instance,tmpWS);

    RawUnicodeToUtf8(pointer(tmpWS),length(tmpWS),result);

  end;

  else result := '';

  end

  else result := '';

end;



procedure TPropInfo.GetRawByteStringValue(Instance: TObject; var Value: RawByteString);

begin

  if (Instance<>nil) and (@self<>nil) and

     (PropType^.Kind in [{$ifdef FPC}tkAString,{$endif}tkLString]) then

    GetLongStrProp(Instance,Value) else

    Value := '';

end;



procedure TPropInfo.SetLongStrValue(Instance: TObject; const Value: RawUTF8);

  procedure HandleAnsiString(Instance: TObject; const Value: RawUTF8; cp: integer);

  var tmp: RawByteString;

  begin

    if cp=CP_SQLRAWBLOB then

      tmp := BlobToTSQLRawBlob(Value) else

      tmp := TSynAnsiConvert.Engine(cp).UTF8ToAnsi(Value);

    SetLongStrProp(Instance,tmp);

  end;

  {$ifdef HASVARUSTRING}

  procedure HandleUnicode(Instance: TObject; const Value: RawUTF8);

  begin

    SetUnicodeStrProp(Instance,UTF8DecodeToUnicodeString(Value));

  end;

  {$endif}

  procedure HandleWideString(Instance: TObject; const Value: RawUTF8);

  begin

    SetWideStrProp(Instance,UTF8ToWideString(Value));

  end;

var cp: integer;

begin

  if (Instance<>nil) and (@self<>nil) then

  case PropType^.Kind of

  {$ifdef FPC}tkAString,{$endif}tkLString: begin

    if Value<>'' then begin

      cp := PropType^.AnsiStringCodePage;

      if cp=CP_UTF8 then

        SetLongStrProp(Instance,Value) else

        HandleAnsiString(Instance,Value,cp);

    end else

      SetLongStrProp(Instance,'');

  end;

  {$ifdef HASVARUSTRING}

  tkUString:

    HandleUnicode(Instance,Value);

  {$endif}

  tkWString:

    HandleWideString(Instance,Value);

  end;

end;



const null_vardata: TVarData = (VType: varNull);



{$ifndef NOVARIANTS}

procedure TPropInfo.SetFromVariant(Instance: TObject; const Value: variant);

var i: integer;

    i64: Int64;

    u: RawUTF8;

    d: double;

begin

  if (Instance<>nil) and (@self<>nil) then

  case PropType^.Kind of

  tkInteger,tkEnumeration,tkSet,tkChar,tkWChar{$ifdef FPC},tkBool{$endif}:

    if VariantToInteger(Value,i) then

      SetOrdProp(Instance,i) else

    if (PropType^.Kind=tkEnumeration) and VariantToUTF8(Value,u) then begin

      i := PropType^.EnumBaseType^.GetEnumNameValue(pointer(u),length(u));

      if i>=0 then

        SetOrdProp(Instance,i)

    end;

  tkInt64{$ifdef FPC},tkQWord{$endif}:

    if VariantToInt64(Value,i64) then

      SetInt64Prop(Instance,i64);

  {$ifdef HASVARUSTRING}tkUString,{$endif}

  tkLString, tkWString {$ifdef FPC},tkAString{$endif}:

    if VariantToUTF8(Value,u) then

      SetLongStrValue(Instance,u);

  tkFloat:

    if VariantToDouble(Value,d) then

      SetFloatProp(Instance,d);

  tkVariant:

    SetVariantProp(Instance,Value);

  tkClass:

    DocVariantToObject(_Safe(Value)^,GetObjProp(Instance));

  tkDynArray:

    DocVariantToObjArray(_Safe(Value)^,GetFieldAddr(Instance)^,

      TJSONSerializer.RegisterObjArrayFindType(TypeInfo));

  {$ifdef PUBLISHRECORD}

  tkRecord{$ifdef FPC},tkObject{$endif}: begin

    VariantSaveJSON(Value,twJSONEscape,u);

    RecordLoadJSON(GetFieldAddr(Instance)^,pointer(u),TypeInfo);

  end;

  {$endif}

  end;

end;

{$endif NOVARIANTS}



procedure TPropInfo.SetDefaultValue(Instance: TObject; FreeAndNilNestedObjects: boolean);

var Item: TObject;

    da: TDynArray;

    {$ifdef PUBLISHRECORD}

    addr: pointer;

    {$endif}

begin

  if (Instance<>nil) and (@self<>nil) then

  case PropType^.Kind of

  tkInteger,tkEnumeration,tkSet,tkChar,tkWChar{$ifdef FPC},tkBool{$endif}:

    SetOrdProp(Instance,0);

  tkInt64{$ifdef FPC},tkQWord{$endif}:

    SetInt64Prop(Instance,0);

  tkLString{$ifdef FPC},tkAString{$endif}:

    SetLongStrProp(Instance,'');

  {$ifdef HASVARUSTRING}

  tkUString:

    SetUnicodeStrProp(Instance,'');

  {$endif}

  tkWString:

    SetWideStrProp(Instance,'');

  tkFloat:

    SetFloatProp(Instance,0);

  {$ifndef NOVARIANTS}

  tkVariant:

    SetVariantProp(Instance,variant(null_vardata));

  {$endif}

  tkClass:

  begin

    Item := GetObjProp(Instance);

    if Item<>nil then

      if FreeAndNilNestedObjects then begin

        SetOrdProp(Instance,0); // mimic FreeAndNil()

        Item.Free;

      end else

        ClearObject(Item,false);

  end;

  tkDynArray: begin

    GetDynArray(Instance,da);

    da.Count := 0; // will handle also any T*ObjArray

  end;

  {$ifdef PUBLISHRECORD}

  tkRecord{$ifdef FPC},tkObject{$endif}: begin

    addr := GetFieldAddr(Instance);

    RecordClear(addr^,TypeInfo);

    FillcharFast(addr^,TypeInfo^.RecordType^.Size,0);

  end;

  {$endif}

  end;

end;



function TPropInfo.GetGenericStringValue(Instance: TObject): string;

var tmp: RawUTF8;

begin

  if (Instance=nil) or (@self=nil) then

    result := '' else

    case PropType^.Kind of

      {$ifdef FPC}tkAString,{$endif} tkLString, tkWString: begin

        GetLongStrValue(Instance,tmp);

        result := UTF8ToString(tmp);

      end;

      {$ifdef HASVARUSTRING}

      tkUString:

        result := string(GetUnicodeStrProp(Instance));

      {$endif}else result := '';

     end;

end;



procedure TPropInfo.SetGenericStringValue(Instance: TObject; const Value: string);

begin

  if (Instance<>nil) and (@self<>nil) then

    case PropType^.Kind of

      {$ifdef FPC}tkAString,{$endif}tkLString, tkWString:

         SetLongStrValue(Instance,StringToUtf8(Value));

      {$ifdef HASVARUSTRING}

       tkUString:

         SetUnicodeStrProp(Instance,UnicodeString(Value));

      {$endif}

    end;

end;



{$ifdef HASVARUSTRING}

function TPropInfo.GetUnicodeStrValue(Instance: TObject): UnicodeString;

begin

  if (Instance<>nil) and (@self<>nil) and

     (PropType^.Kind=tkUString) then

    result := GetUnicodeStrProp(Instance);

end;



procedure TPropInfo.SetUnicodeStrValue(Instance: TObject; const Value: UnicodeString);

begin

  if (Instance<>nil) and (@self<>nil) and

     (PropType^.Kind=tkUString) then

    SetUnicodeStrProp(Instance,Value);

end;

{$endif HASVARUSTRING}



procedure TPropInfo.SetOrdValue(Instance: TObject; Value: PtrInt);

begin

  if (Instance<>nil) and (@self<>nil) and

     (PropType^.Kind in [

       tkInteger,tkEnumeration,tkSet,{$ifdef FPC}tkBool,{$endif}tkClass]) then

    SetOrdProp(Instance,Value);

end;



procedure TPropInfo.SetInt64Value(Instance: TObject; Value: Int64);

begin

  if (Instance<>nil) and (@self<>nil) then

  case PropType^.Kind of

    tkInteger,tkEnumeration,tkSet,tkChar,tkWChar,tkClass{$ifdef FPC},tkBool{$endif}:

      SetOrdProp(Instance,Value);

    tkInt64{$ifdef FPC}, tkQWord{$endif}:

      SetInt64Prop(Instance,Value);

  end;

end;



function TPropInfo.SameValue(Source: TObject; DestInfo: PPropInfo; Dest: TObject): boolean;



  {$ifndef NOVARIANTS}

  function CompareVariants: boolean;

  var VS,VD: Variant;

  begin

    GetVariantProp(Source,VS);

    DestInfo^.GetVariantProp(Dest,VD);

    result := VS=VD; // rely on Variants.pas comparison

  end;

  {$endif}

  function CompareStrings: Boolean;

  var US,UD: RawUTF8;

  begin

    GetLongStrValue(Source,US);

    DestInfo^.GetLongStrValue(Dest,UD);

    result := US=UD;

  end;



var kS,kD: TTypeKind;

    daS,daD: TDynArray;

    i: integer;

begin

  if Source=Dest then begin

    result := true;

    exit;

  end;

  result := false;

  if (Source=nil) or (Dest=nil) or (@self=nil) or (DestInfo=nil) then

    exit;

  kS := PropType^.Kind;

  kD := DestInfo^.PropType^.Kind;

  if kS in tkStringTypes then

    if kD in tkStringTypes then

      result := CompareStrings else

      exit else

  if kS in tkOrdinalTypes then

    if kD in tkOrdinalTypes then

      result := GetInt64Value(Source)=DestInfo^.GetInt64Value(Dest) else

      exit else

  if kS=kD then

    case KS of

    tkClass:

      result := ObjectEquals(GetObjProp(Source),DestInfo^.GetObjProp(Dest));

    tkFloat: begin

      if DestInfo^.PropType^.FloatType=PropType^.FloatType then

      case PropType^.FloatType of

      ftCurr: begin

        if GetterIsField and ((@self=DestInfo) or DestInfo^.GetterIsField) then

          result := GetInt64Value(Source)=DestInfo^.GetInt64Value(Dest) else

          result := GetCurrencyProp(Source)=DestInfo^.GetCurrencyProp(Dest);

        exit;

      end;

      ftDoub: begin

        if GetterIsField and ((@self=DestInfo) or DestInfo^.GetterIsField) then

          result := GetInt64Value(Source)=DestInfo^.GetInt64Value(Dest) else

          result := SynCommons.SameValue(GetDoubleProp(Source),DestInfo^.GetDoubleProp(Dest));

        exit;

      end;

      end;

      result := SynCommons.SameValueFloat(GetFloatProp(Source),DestInfo^.GetFloatProp(Dest));

    end;

    tkDynArray: begin

      GetDynArray(Source,daS);

      DestInfo^.GetDynArray(Dest,daD);

      if daS.Count=daD.Count then

        if DynArrayIsObjArray and

           ((@self=DestInfo) or DestInfo^.DynArrayIsObjArray) then begin

          for i := 0 to daS.Count-1 do

            if not ObjectEquals(PObjectArray(daS.Value)[i],PObjectArray(daD.Value)[i]) then

              exit;

          result := true;

        end else

          result := daD.Equals(daS);

    end;

    {$ifndef NOVARIANTS}

    tkVariant:

      result := CompareVariants;

    {$endif}

  end;

end;



function ClassFieldPropInstanceMatchingClass(

  aSearchedInstance: TObject; aSearchedClassType: TClass): TObject;

var P: PPropInfo;

begin

  result := aSearchedInstance;

  if (aSearchedInstance=nil) or

     aSearchedInstance.InheritsFrom(aSearchedClassType) then

    exit;

  P := ClassFieldPropWithParentsFromClassType(PPointer(aSearchedInstance)^,aSearchedClassType);

  if P<>nil then begin

    result := P^.GetObjProp(aSearchedInstance);

    if result=nil then

      result := aSearchedInstance;

  end;

end;



function TPropInfo.CopyToNewObject(aFrom: TObject): TObject;

var aClass: TClass;

    aInstance: TClassInstance;

begin

  if aFrom=nil then begin

    result := nil;

    exit;

  end;

  aClass := PropType^.ClassType^.ClassType;

  aInstance.Init(aClass);

  result := aInstance.CreateNew;

  try

    CopyObject(ClassFieldPropInstanceMatchingClass(aFrom,aClass),result);

  except

    FreeAndNil(result); // avoid memory leak if error during new instance copy

  end;

end;



procedure TPropInfo.CopyValue(Source, Dest: TObject; DestInfo: PPropInfo);

var Value: RawByteString;

    WS: WideString;

    {$ifndef NOVARIANTS}

    V: variant;

    {$endif}

    S,D: TObject;

    kS,kD: TTypeKind;

    ft: TSQLFieldType;

label i64, int, dst, obj, str;

begin

  if DestInfo=nil then

    DestInfo := @self;

  if (@self=nil) or (Source=nil) or (Dest=Source) or (Dest=nil) then

    exit;

  kS := PropType^.Kind;

  kD := DestInfo^.PropType^.Kind;

  case kS of

    {$ifdef FPC}tkBool,{$endif}

    tkEnumeration, tkInteger, tkSet, tkChar, tkWChar:

int:  if DestInfo=@Self then

        SetOrdProp(Dest,GetOrdProp(Source)) else

dst:  if kD in tkOrdinalTypes then // use Int64 to handle e.g. cardinal

        DestInfo^.SetInt64Value(Dest,GetInt64Value(Source));

    tkClass: begin

      ft := PropType^.ClassSQLFieldType;

      case ft of

        sftID: // TSQLRecord published properties (sftID)

          if TSQLRecord(Source).fFill.JoinedFields then

            // -> pre-allocated fields by Create*Joined()

            goto obj else

            // -> these are not class instances, but INTEGER reference to records

            goto int;

        sftMany, sftObject: begin

          // generic case: copy also class content (create instances)

  obj:    S := GetObjProp(Source);

          if (DestInfo=@self) or

             ((kD=tkClass) and (DestInfo^.PropType^.ClassSQLFieldType=ft)) then begin

            D := DestInfo.GetObjProp(Dest);

{$ifndef LVCL}

            if S.InheritsFrom(TCollection) then

              CopyCollection(TCollection(S),TCollection(D)) else

{$endif}    begin

              D.Free; // release previous D instance then set a new copy of S

              DestInfo.SetOrdProp(Dest,PtrInt(DestInfo^.CopyToNewObject(S)));

            end;

          end;

        end;

      end;

    end;

    tkInt64{$ifdef FPC}, tkQWord{$endif}:

      if DestInfo=@self then

        // works also with TID, TTimeLog, Double and Currency

i64:    SetInt64Prop(Dest,GetInt64Prop(Source)) else

        goto dst;

    tkFloat:

    if DestInfo=@self then

      if (PropType^.FloatType in [ftDoub,ftCurr]) and

         GetterIsField and SetterIsField then

        goto I64 else

        SetFloatProp(Dest,GetFloatProp(Source)) else

      if kD=tkFloat then

        DestInfo.SetFloatProp(Dest,GetFloatProp(Source));

    {$ifdef FPC}tkAString,{$endif}

    tkLString:

      if kD=tkLString then begin

        GetLongStrProp(Source,Value);

        DestInfo.SetLongStrProp(Dest,Value);

      end else

str:  if kD in tkStringTypes then begin

        GetLongStrValue(Source,RawUTF8(Value));

        DestInfo.SetLongStrValue(Dest,RawUTF8(Value));

      end;

    {$ifdef HASVARUSTRING}

    tkUString:

      if kD=tkUString then

        DestInfo.SetUnicodeStrProp(Dest,GetUnicodeStrProp(Source)) else

        goto str;

    {$endif}

    tkWString:

      if kD=tkWString then begin

        GetWideStrProp(Source,WS);

        DestInfo.SetWideStrProp(Dest,WS);

      end else

        goto str;

    tkDynArray:

      if (DestInfo=@self) or (TypeInfo=DestInfo.TypeInfo) then

        DestInfo.GetDynArray(Dest).Copy(GetDynArray(Source));

    tkRecord{$ifdef FPC},tkObject{$endif}:

      if (DestInfo=@self) or (TypeInfo=DestInfo.TypeInfo) then

        RecordCopy(DestInfo.GetFieldAddr(Dest)^,GetFieldAddr(Source)^,TypeInfo);

    {$ifndef NOVARIANTS}

    tkVariant:

      if kD=tkVariant then begin

        GetVariantProp(Source,V);

        DestInfo.SetVariantProp(Dest,V);

      end;

    {$endif}

  end; // note: tkString (shortstring) and tkInterface not handled

end;



function TPropInfo.GetFieldAddr(Instance: TObject): pointer;

begin

  if not GetterIsField then

    if not SetterIsField then

      // both are methods -> returns nil

      result := nil else

      //  field - Setter is the field offset in the instance data

      result := SetterAddr(Instance) else

    // field - Getter is the field offset in the instance data

    result := GetterAddr(Instance);

end;



function TPropInfo.IsBlob: boolean;

begin

  result := (@self<>nil) and (TypeInfo=system.TypeInfo(TSQLRawBlob));

end;



function TPropInfo.IsStored(Instance: TObject): boolean;

type // function(Instance: TObject) trick does not work with CPU64 :(

  TStoredProc = function: Boolean of object;

var Call: TMethod;

begin

{$ifdef FPC} // extracted from IsStoredProp() function in typinfo.pp

  result := ((PropProcs shr 4) and 3=ptconst) and LongBool(StoredProc);

{$else}      // Delphi version

  if (StoredProc and (not PtrInt($ff)))=0 then

    result := boolean(StoredProc) else

  if Instance=nil then

    // field or method without Instance specified -> assume "stored true"

    result := true else

  if PropWrap(StoredProc).Kind=$ff then

    result := PBoolean(PtrInt(Instance)+StoredProc and $00FFFFFF)^ else begin

    if PropWrap(StoredProc).Kind=$fe then

      Call.Code := pointer((PPtrUInt(PPtrInt(Instance)^+SmallInt(StoredProc))^)) else

      Call.Code := pointer(StoredProc);

    Call.Data := Instance;

    result := TStoredProc(Call);

  end;

{$endif}

end;



function TPropInfo.GetterIsField: boolean;

begin

  {$ifdef FPC}

  result := PropProcs and 3=ptField;

  {$else}

  result := PropWrap(GetProc).Kind=$FF;

  {$endif}

end;



function TPropInfo.SetterIsField: boolean;

begin

  {$ifdef FPC}

  result := (PropProcs shr 2) and 3=ptField;

  {$else}

  result := PropWrap(SetProc).Kind=$FF;

  {$endif}

end;



function TPropInfo.WriteIsDefined: boolean;

begin

  result := SetProc<>0;

end;



function TPropInfo.GetterAddr(Instance: pointer): pointer;

{$ifdef HASINLINE}

begin

  result := Pointer(PtrInt(Instance)+GetProc{$ifndef FPC} and $00FFFFFF{$endif});

end;

{$else}

asm

  mov eax,[eax].TPropInfo.GetProc

  and eax,$00ffffff

  add eax,edx

end;

{$endif}



function TPropInfo.SetterAddr(Instance: pointer): pointer;

begin

  result := Pointer(PtrInt(Instance)+SetProc{$ifndef FPC} and $00FFFFFF{$endif});

end;



function TPropInfo.TypeInfo: PTypeInfo;

{$ifdef HASINLINE}

begin

  {$ifndef HASDIRECTTYPEINFO}

  if PropType<>nil then

    result := PropType^ else

  {$endif}

    result := pointer(PropType);

end;

{$else}

asm // Delphi is so bad at compiling above code...

    mov eax,[eax].TPropInfo.PropType

    test eax,eax

    jz @z

    mov eax,[eax]

    ret

@z: rep ret

end;

{$endif HASINLINE}

      

{$ifdef FPC_OR_PUREPASCAL}

function TPropInfo.Next: PPropInfo;

begin

  result := AlignToPtr(@Name[ord(Name[0])+1]);

end;

{$else}

{$ifdef HASINLINE}

function TPropInfo.Next: PPropInfo;

begin

  result := @Name[ord(Name[0])+1];

end;

{$else}

function TPropInfo.Next: PPropInfo;

asm // very fast code

  movzx edx,byte ptr [eax].TPropInfo.Name

  lea eax,[eax+edx].TPropInfo.Name[1]

end;

{$endif HASINLINE}

{$endif FPC_OR_PUREPASCAL}



{$ifdef USETYPEINFO}



function TPropInfo.GetOrdProp(Instance: TObject): PtrInt;

begin

  result := TypInfo.GetOrdProp(Instance,@self);

end;



function TPropInfo.GetObjProp(Instance: TObject): TObject;

begin

  if GetterIsField then

    result := PObject(GetterAddr(Instance))^ else

    result := pointer(TypInfo.GetOrdProp(Instance,@self));

end;



procedure TPropInfo.SetOrdProp(Instance: TObject; Value: PtrInt);

begin

  if {$ifndef FPC}(PropType^.Kind=tkClass) and {$endif}

     (SetProc=0) and GetterIsField then

    // allow setting a class instance even if there is no "write ..." attribute

    PPtrInt(GetterAddr(Instance))^ := Value else

    TypInfo.SetOrdProp(Instance,@self,Value);

end;



function TPropInfo.GetInt64Prop(Instance: TObject): Int64;

begin

  if GetterIsField then

    result := PInt64(GetterAddr(Instance))^ else

    result := TypInfo.GetInt64Prop(Instance,@self);

end;



procedure TPropInfo.SetInt64Prop(Instance: TObject; const Value: Int64);

begin

  if SetterIsField then

    PInt64(SetterAddr(Instance))^ := Value else

  if (SetProc=0) and GetterIsField then

    PInt64(GetterAddr(Instance))^ := Value else

    TypInfo.SetInt64Prop(Instance,@self,Value);

end;



procedure TPropInfo.GetLongStrProp(Instance: TObject; var Value: RawByteString);

begin

  {$ifdef UNICODE}

  Value := TypInfo.GetAnsiStrProp(Instance,@self);

  {$else}

  Value := TypInfo.GetStrProp(Instance,@self);

  {$endif}

end;



procedure TPropInfo.SetLongStrProp(Instance: TObject; const Value: RawByteString);

begin

  {$ifdef UNICODE}

  TypInfo.SetAnsiStrProp(Instance,@self,Value);

  {$else}

  TypInfo.SetStrProp(Instance,@self,Value);

  {$endif}

end;



procedure TPropInfo.CopyLongStrProp(Source,Dest: TObject);

begin

  {$ifdef UNICODE}

  TypInfo.SetAnsiStrProp(Dest,@self,TypInfo.GetAnsiStrProp(Source,@self));

  {$else}

  SetStrProp(Dest,@self,TypInfo.GetStrProp(Source,@self));

  {$endif}

end;



procedure TPropInfo.GetWideStrProp(Instance: TObject; var Value: WideString);

begin

  Value := TypInfo.GetWideStrProp(Instance,@self);

end;



procedure TPropInfo.SetWideStrProp(Instance: TObject; const Value: WideString);

begin

  TypInfo.SetWideStrProp(Instance,@self,Value);

end;



{$ifdef HASVARUSTRING}

function TPropInfo.GetUnicodeStrProp(Instance: TObject): UnicodeString;

begin

  result := TypInfo.GetUnicodeStrProp(Instance,@self);

end;



procedure TPropInfo.SetUnicodeStrProp(Instance: TObject; const Value: UnicodeString);

begin

  TypInfo.SetUnicodeStrProp(Instance,@self,Value);

end;

{$endif HASVARUSTRING}



function TPropInfo.GetCurrencyProp(Instance: TObject): currency;

begin

  if GetterIsField then

    result := PCurrency(GetterAddr(Instance))^ else

    result := TypInfo.GetFloatProp(Instance,@self);

end;



procedure TPropInfo.SetCurrencyProp(Instance: TObject; const Value: Currency);

begin

  if SetterIsField then

    PCurrency(SetterAddr(Instance))^ := Value else

  if (SetProc=0) and GetterIsField then

    PCurrency(GetterAddr(Instance))^ := Value else

    TypInfo.SetFloatProp(Instance,@self,value);

end;



function TPropInfo.GetDoubleProp(Instance: TObject): double;

begin

  if GetterIsField then

    result := PDouble(GetterAddr(Instance))^ else

    result := TypInfo.GetFloatProp(Instance,@self);

end;



procedure TPropInfo.SetDoubleProp(Instance: TObject; Value: Double);

begin

  if SetterIsField then

    PDouble(SetterAddr(Instance))^ := Value else

  if (SetProc=0) and GetterIsField then

    PDouble(GetterAddr(Instance))^ := Value else

    TypInfo.SetFloatProp(Instance,@self,value);

end;



function TPropInfo.GetFloatProp(Instance: TObject): double;

begin

  result := TypInfo.GetFloatProp(Instance,@self);

end;



procedure TPropInfo.SetFloatProp(Instance: TObject; Value: TSynExtended);

begin

  TypInfo.SetFloatProp(Instance,@self,value);

end;



{$ifndef NOVARIANTS}

procedure TPropInfo.GetVariantProp(Instance: TObject; var result: Variant);

begin

  result := TypInfo.GetVariantProp(Instance,@self);

end;



procedure TPropInfo.SetVariantProp(Instance: TObject; const Value: Variant);

begin

  if (SetProc=0) and GetterIsField then

    PVariant(GetterAddr(Instance))^ := Value else

    TypInfo.SetVariantProp(Instance,@self,Value);

end;

{$endif}



{$else USETYPEINFO}



function TPropInfo.GetOrdProp(Instance: TObject): PtrInt;

type // function(Instance: TObject) trick does not work with CPU64 :(

  TGetProc = function: PtrInt of object;

  TIndexedGetProc = function(Index: Integer): PtrInt of object;

var value: PtrInt;

    Call: TMethod;

    P: pointer;

begin

  if GetProc=0 then  // no read attribute -> use write offset

    if PropWrap(SetProc).Kind<>$FF then begin

      result := 0;

      exit;

    end else // we only allow setting if we know the field address

      P := Pointer(PtrInt(Instance)+SetProc and $00FFFFFF) else

    if PropWrap(GetProc).Kind=$FF then

      P := Pointer(PtrInt(Instance)+GetProc and $00FFFFFF) else begin

      if PropWrap(GetProc).Kind=$FE then

        Call.Code := PPointer(PPtrInt(Instance)^+SmallInt(GetProc))^ else

        Call.Code := Pointer(GetProc);

      Call.Data := Instance;

      if Index=NO_INDEX then

        value := TGetProc(Call) else

        value := TIndexedGetProc(Call)(Index);

      P := @value;

    end;

  with TypeInfo^ do

  if Kind=tkClass then

    result := PPtrInt(P)^ else

    case TOrdType(PByte(AlignToPtr(@Name[ord(Name[0])+1]))^) of // OrdType of

    otSByte: result := PShortInt(P)^;

    otSWord: result := PSmallInt(P)^;

    otSLong: result := PInteger(P)^;

    otUByte: result := PByte(P)^;

    otUWord: result := PWord(P)^;

    otULong: result := PCardinal(P)^;

    else result := 0; // should not happen

    end;

end;



procedure TPropInfo.SetOrdProp(Instance: TObject; Value: PtrInt);

type // procedure(Instance: TObject) trick does not work with CPU64 :(

  TSetProp = procedure(Value: PtrInt) of object;

  TIndexedProp = procedure(Index: integer; Value: PtrInt) of object;

var P: pointer;

    Call: TMethod;

begin

  if SetProc=0 then  // no write attribute -> use read offset

    if PropWrap(GetProc).Kind<>$FF then

      exit else // we only allow setting if we know the field address

      P := Pointer(PtrInt(Instance)+GetProc and $00FFFFFF) else

    if PropWrap(SetProc).Kind=$FF then

      P := Pointer(PtrInt(Instance)+SetProc and $00FFFFFF) else begin

      if PropWrap(SetProc).Kind=$FE then

        Call.Code := PPointer(PPtrInt(Instance)^+SmallInt(SetProc))^ else

        Call.Code := Pointer(SetProc);

      Call.Data := Instance;

      if Index=NO_INDEX then

        TSetProp(Call)(Value) else

        TIndexedProp(Call)(Index,Value);

      exit;

    end;

  with PropType^^ do

  if Kind=tkClass then

    PPtrInt(P)^ := Value else

    case TOrdType(PByte(AlignToPtr(@Name[ord(Name[0])+1]))^) of // OrdType of

    otSByte: PShortInt(P)^ := Value;

    otSWord: PSmallInt(P)^ := Value;

    otSLong: PInteger(P)^ := Value;

    otUByte: PByte(P)^ := Value;

    otUWord: PWord(P)^ := Value;

    otULong: PCardinal(P)^ := Value;

    end;

end;



function TPropInfo.GetObjProp(Instance: TObject): TObject;

begin

  if GetterIsField then

    result := PObject(GetterAddr(Instance))^ else

    result := pointer(GetOrdProp(Instance));

end;



function TPropInfo.GetInt64Prop(Instance: TObject): Int64;

type // function(Instance: TObject) trick does not work with CPU64 :(

  TGetProc = function: Int64 of object;

  TIndexedGetProc = function(Index: Integer): Int64 of object;

var Call: TMethod;

begin

  if PropWrap(GetProc).Kind=$FF then

    // field - Getter is the field offset in the instance data

    result := PInt64(PtrInt(Instance)+GetProc and $00FFFFFF)^

  else begin

    if PropWrap(GetProc).Kind=$FE then

      Call.Code := PPointer(PPtrInt(Instance)^+SmallInt(GetProc))^ else

      Call.Code := Pointer(GetProc);

    Call.Data := Instance;

    if Index=NO_INDEX then

      result := TGetProc(Call) else

      result := TIndexedGetProc(Call)(Index);

  end;

end;



procedure TPropInfo.SetInt64Prop(Instance: TObject; const Value: Int64);

type // procedure(Instance: TObject) trick does not work with CPU64 :(

  TSetProp = procedure(const Value: Int64) of object;

  TIndexedProp = procedure(Index: integer; const Value: Int64) of object;

var Call: TMethod;

begin

  if SetProc=0 then  // no write attribute -> use read offset

    if PropWrap(GetProc).Kind<>$FF then

      exit else // we only allow setting if we know the field address

      PInt64(PtrInt(Instance)+GetProc and $00FFFFFF)^ := Value else

    if PropWrap(SetProc).Kind=$FF then

      PInt64(PtrInt(Instance)+SetProc and $00FFFFFF)^ := Value else begin

      if PropWrap(SetProc).Kind=$FE then

        Call.Code := PPointer(PPtrInt(Instance)^+SmallInt(SetProc))^ else

        Call.Code := Pointer(SetProc);

      Call.Data := Instance;

      if Index=NO_INDEX then

        TSetProp(Call)(Value) else

        TIndexedProp(Call)(Index,Value);

  end;

end;



procedure TPropInfo.GetLongStrProp(Instance: TObject; var Value: RawByteString);

procedure CallMethod(Instance: TObject; var Value: RawByteString);

type // function(Instance: TObject) trick does not work with CPU64 :(

  TAStringGetProc = function: RawByteString of object;

  TAStringIndexedGetProc = function(Index: Integer): RawByteString of object;

var Call: TMethod;

begin

  if PropWrap(GetProc).Kind=$FE then

    // virtual method  - Getter is a signed 2 byte integer VMT offset

    Call.Code := PPointer(PPtrInt(Instance)^+SmallInt(GetProc))^ else

    // static method - Getter is the actual address

    Call.Code := Pointer(GetProc);

  Call.Data := Instance;

  if Index=NO_INDEX then  // no index

    Value := TAStringGetProc(Call) else

    Value := TAStringIndexedGetProc(Call)(Index);

end;

begin // caller must check that PropType^.Kind = tkWString

  if PropWrap(GetProc).Kind=$FF then

    // field - Getter is the field offset in the instance data

    Value := PRawByteString(PtrInt(Instance)+GetProc and $00FFFFFF)^ else

    CallMethod(Instance,Value);

end;



procedure TPropInfo.SetLongStrProp(Instance: TObject; const Value: RawByteString);

type // procedure(Instance: TObject) trick does not work with CPU64 :(

  TSetProp = procedure(const Value: RawByteString) of object;

  TIndexedProp = procedure(Index: integer; const Value: RawByteString) of object;

var Call: TMethod;

begin // caller must check that PropType^.Kind = tkLString

  if SetProc=0 then  // no setter ?

    if PropWrap(GetProc).Kind<>$FF then

      exit else  // we only allow setting if we know the field address

      PRawByteString(PtrInt(Instance)+GetProc and $00FFFFFF)^ := Value else

  if PropWrap(SetProc).Kind=$FF then

    // field - Setter is the field offset in the instance data

    PRawByteString(PtrInt(Instance)+SetProc and $00FFFFFF)^ := Value else begin

      if PropWrap(SetProc).Kind=$FE then

        Call.Code := PPointer(PPtrInt(Instance)^+SmallInt(SetProc))^ else

        Call.Code := Pointer(SetProc);

      Call.Data := Instance;

      if Index=NO_INDEX then

        TSetProp(Call)(Value) else

        TIndexedProp(Call)(Index,Value);

  end;

end;



procedure TPropInfo.CopyLongStrProp(Source,Dest: TObject);

var tmp: RawByteString;

begin

  GetLongStrProp(Source,tmp);

  SetLongStrProp(Dest,tmp);

end;



procedure TPropInfo.GetWideStrProp(Instance: TObject; var Value: WideString);

type

  TUStringGetProc = function: WideString of object;

  TUStringIndexedGetProc = function(Index: Integer): WideString of object;

var M: TMethod;

begin // caller must check that PropType^.Kind = tkWString

  if PropWrap(GetProc).Kind=$FF then

    // field - Getter is the field offset in the instance data

    Value := PWideString(PtrInt(Instance)+GetProc and $00FFFFFF)^

  else begin

    if PropWrap(GetProc).Kind=$FE then

      // virtual method  - Getter is a signed 2 byte integer VMT offset

      M.Code := PPointer(PPtrInt(Instance)^+SmallInt(GetProc))^ else

      // static method - Getter is the actual address

      M.Code := Pointer(GetProc);

    M.Data := Instance;

    if Index=NO_INDEX then  // no index

      Value := TUStringGetProc(M)() else

      Value := TUStringIndexedGetProc(M)(Index);

  end;

end;



procedure TPropInfo.SetWideStrProp(Instance: TObject; const Value: WideString);

type

  TUStringSetProc = procedure(const Value: WideString) of object;

  TUStringIndexedSetProc = procedure(Index: Integer; const Value: WideString) of object;

var M: TMethod;

begin // caller must check that PropType^.Kind = tkWString

  if SetProc=0 then  // no setter ?

    if PropWrap(GetProc).Kind<>$FF then

      exit else begin  // we only allow setting if we know the field address

      PWideString(PtrInt(Instance)+GetProc and $00FFFFFF)^ := Value;

      exit;

    end;

  if PropWrap(SetProc).Kind=$FF then

    // field - Setter is the field offset in the instance data

    PWideString(PtrInt(Instance)+SetProc and $00FFFFFF)^ := Value else begin

    if PropWrap(SetProc).Kind=$FE then

      // virtual method  - Setter is a signed 2 byte integer VMT offset

      M.Code := PPointer(PPtrInt(Instance)^+SmallInt(SetProc))^ else

      // static method - Setter is the actual address

      M.Code := Pointer(SetProc);

    M.Data := Instance;

    if Index=NO_INDEX then  // no index

      TUStringSetProc(M)(Value) else

      TUStringIndexedSetProc(M)(Index, Value);

  end;

end;



{$ifdef HASVARUSTRING}

function TPropInfo.GetUnicodeStrProp(Instance: TObject): UnicodeString;

type

  TUStringGetProc = function: UnicodeString of object;

  TUStringIndexedGetProc = function(Index: Integer): UnicodeString of object;

var M: TMethod;

begin // caller must check that PropType^.Kind = tkUString

  if PropWrap(GetProc).Kind=$FF then

    // field - Getter is the field offset in the instance data

    result := PUnicodeString(PtrInt(Instance)+GetProc and $00FFFFFF)^

  else begin

    if PropWrap(GetProc).Kind=$FE then

      // virtual method  - Getter is a signed 2 byte integer VMT offset

      M.Code := PPointer(PPtrInt(Instance)^+SmallInt(GetProc))^ else

      // static method - Getter is the actual address

      M.Code := Pointer(GetProc);

    M.Data := Instance;

    if Index=NO_INDEX then  // no index

      result := TUStringGetProc(M)() else

      result := TUStringIndexedGetProc(M)(Index);

  end;

end;



procedure TPropInfo.SetUnicodeStrProp(Instance: TObject; const Value: UnicodeString);

type

  TUStringSetProc = procedure (const Value: UnicodeString) of object;

  TUStringIndexedSetProc = procedure (Index: Integer; const Value: UnicodeString) of object;

var M: TMethod;

begin // caller must check that PropType^.Kind = tkUString

  if SetProc=0 then  // no setter ?

    if PropWrap(GetProc).Kind<>$FF then

      exit else begin  // we only allow setting if we know the field address

      PUnicodeString(PtrInt(Instance)+GetProc and $00FFFFFF)^ := Value;

      exit;

    end;

  if PropWrap(SetProc).Kind=$FF then

    // field - Setter is the field offset in the instance data

    PUnicodeString(PtrInt(Instance)+SetProc and $00FFFFFF)^ := Value else begin

    if PropWrap(SetProc).Kind=$FE then

      // virtual method  - Setter is a signed 2 byte integer VMT offset

      M.Code := PPointer(PPtrInt(Instance)^+SmallInt(SetProc))^ else

      // static method - Setter is the actual address

      M.Code := Pointer(SetProc);

    M.Data := Instance;

    if Index=NO_INDEX then // no index

      TUStringSetProc(M)(Value) else

      TUStringIndexedSetProc(M)(Index, Value);

  end;

end;

{$endif HASVARUSTRING}



function TPropInfo.GetCurrencyProp(Instance: TObject): currency;

type // function(Instance: TObject) trick does not work with CPU64 :(

  TGetProc = function: currency of object;

  TIndexedGetProc = function(Index: Integer): currency of object;

var P: Pointer;

    Call: TMethod;

begin // faster code by AB

  if PropWrap(GetProc).Kind=$FF then begin

    // field - GetProc is the field offset in the instance data

    P := Pointer(PtrInt(Instance)+GetProc and $00FFFFFF);

    Result := PCurrency(P)^;

  end

  else begin

    if PropWrap(GetProc).Kind=$FE then

      Call.Code := PPointer(PPtrInt(Instance)^+SmallInt(GetProc))^ else

      Call.Code := Pointer(GetProc);

    Call.Data := Instance;

    if Index=NO_INDEX then

      result := TGetProc(Call) else

      result := TIndexedGetProc(Call)(Index);

  end;

end;



procedure TPropInfo.SetCurrencyProp(Instance: TObject; const Value: Currency);

begin

  if SetterIsField then

    PCurrency(SetterAddr(Instance))^ := Value else

  if (SetProc=0) and GetterIsField then

    PCurrency(GetterAddr(Instance))^ := Value else

    SetFloatProp(Instance,value);

end;



function TPropInfo.GetDoubleProp(Instance: TObject): double;

type // function(Instance: TObject) trick does not work with CPU64 :(

  TGetProc = function: double of object;

  TIndexedGetProc = function(Index: Integer): double of object;

var P: Pointer;

    Call: TMethod;

begin // faster code by AB

  if PropWrap(GetProc).Kind=$FF then begin

    // field - GetProc is the field offset in the instance data

    P := Pointer(PtrInt(Instance)+GetProc and $00FFFFFF);

    Result := PDouble(P)^;

  end

  else begin

    if PropWrap(GetProc).Kind=$FE then

      Call.Code := PPointer(PPtrInt(Instance)^+SmallInt(GetProc))^ else

      Call.Code := Pointer(GetProc);

    Call.Data := Instance;

    if Index=NO_INDEX then

      result := TGetProc(Call) else

      result := TIndexedGetProc(Call)(Index);

  end;

end;



procedure TPropInfo.SetDoubleProp(Instance: TObject; Value: Double);

begin

  if SetterIsField then

    PDouble(SetterAddr(Instance))^ := Value else

  if (SetProc=0) and GetterIsField then

    PDouble(GetterAddr(Instance))^ := Value else

    SetFloatProp(Instance,value);

end;



function TPropInfo.GetFloatProp(Instance: TObject): double;

type // function(Instance: TObject) trick does not work with CPU64 :(

  TGetProc = function: extended of object;

  TIndexedGetProc = function(Index: Integer): extended of object;

var P: Pointer;

    Call: TMethod;

begin // faster code by AB

  if PropWrap(GetProc).Kind=$FF then begin

    // field - GetProc is the field offset in the instance data

    P := Pointer(PtrInt(Instance)+GetProc and $00FFFFFF);

    case PropType^.FloatType of

      ftSingle:    Result := PSingle(P)^;

      ftDoub:      Result := PDouble(P)^;

      ftExtended:  Result := PExtended(P)^;

      ftComp:      Result := PComp(P)^;

      ftCurr:      Result := PCurrency(P)^; // use GetInt64Prop() to avoid rounding

    else Result := 0;

    end;

  end

  else begin

    if PropWrap(GetProc).Kind=$FE then

      Call.Code := PPointer(PPtrInt(Instance)^+SmallInt(GetProc))^ else

      Call.Code := Pointer(GetProc);

    Call.Data := Instance;

    if Index=NO_INDEX then

      result := TGetProc(Call) else

      result := TIndexedGetProc(Call)(Index);

    if PropType^.FloatType = ftCurr then

      Result := Result / 10000;

  end;

end;



procedure TPropInfo.SetFloatProp(Instance: TObject; Value: TSynExtended);

type // procedure(Instance: TObject) trick does not work with CPU64 :(

  TSingleSetProc = procedure(const Value: Single) of object;

  TDoubleSetProc = procedure(const Value: Double) of object;

  TExtendedSetProc = procedure(const Value: Extended) of object;

  TCompSetProc = procedure(const Value: Comp) of object;

  TCurrencySetProc = procedure(const Value: Currency) of object;

var P: Pointer;

    Call: TMethod;

label St;

begin

  if SetProc=0 then  // no setter ?

    if PropWrap(GetProc).Kind<>$FF then

      exit else begin  // we only allow setting if we know the field address

      P := Pointer(PtrInt(Instance)+GetProc and $00FFFFFF);

      goto St;  // use the field address to set its value

    end;

  if PropWrap(SetProc).Kind=$FF then begin

    // field - SetProc is the field offset in the instance data

    P := Pointer(PtrInt(Instance)+SetProc and $00FFFFFF);

St: case PropType^^.FloatType of

      ftSingle:    PSingle(P)^ := Value;

      ftDoub:      PDouble(P)^ := Value;

      ftExtended:  PExtended(P)^ := Value;

      ftComp:      PComp(P)^ := Value;

      ftCurr:      PCurrency(P)^ := Value;

    end;

  end

  else begin

    if PropWrap(SetProc).Kind=$FE then

      Call.Code := PPointer(PPtrInt(Instance)^+SmallInt(SetProc))^ else

      Call.Code := Pointer(SetProc);

    Call.Data := Instance;

    if Index=NO_INDEX then begin // no index

      case PropType^^.FloatType of

        ftSingle  :  TSingleSetProc(Call)(Value);

        ftDoub :     TDoubleSetProc(Call)(Value);

        ftExtended:  TExtendedSetProc(Call)(Value);

        ftComp    :  TCompSetProc(Call)(Value);

        ftCurr    :  TCurrencySetProc(Call)(Value);

      end;

    end;  // indexed methods not handled here, since not used in TSQLRecord

  end;

end;



{$ifndef NOVARIANTS}

procedure TPropInfo.GetVariantProp(Instance: TObject; var result: Variant);

  procedure ByMethod; // sub proc for faster execution of simple types

  type // function(Instance: TObject) trick does not work with CPU64 :(

    TGetProc = function: Variant of object;

    TIndexedGetProc = function(Index: Integer): Variant of object;

  var Call: TMethod;

  begin

    if PropWrap(GetProc).Kind=$FE then

      Call.Code := PPointer(PPtrInt(Instance)^+SmallInt(GetProc))^ else

      Call.Code := Pointer(GetProc);

    Call.Data := Instance;

    if Index=NO_INDEX then

      result := TGetProc(Call) else

      result := TIndexedGetProc(Call)(Index);

  end;

begin

  if PropWrap(GetProc).Kind=$FF then

    // field - Getter is the field offset in the instance data

    SetVariantByValue(PVariant(PtrInt(Instance)+GetProc and $00FFFFFF)^,result) else

    ByMethod;

end;



procedure TPropInfo.SetVariantProp(Instance: TObject; const Value: Variant);

  procedure ByMethod; // sub proc for faster execution of simple types

  type // procedure(Instance: TObject) trick does not work with CPU64 :(

    TSetProp = procedure(const Value: Variant) of object;

    TIndexedProp = procedure(Index: integer; const Value: Variant) of object;

  var Call: TMethod;

  begin

    if PropWrap(SetProc).Kind=$FE then

      Call.Code := PPointer(PPtrInt(Instance)^+SmallInt(SetProc))^ else

      Call.Code := Pointer(SetProc);

    Call.Data := Instance;

    if Index=NO_INDEX then

      TSetProp(Call)(Value) else

      TIndexedProp(Call)(Index,Value);

  end;

begin

  if SetProc=0 then  // no write attribute -> use read offset

    if PropWrap(GetProc).Kind<>$FF then

      exit else // we only allow setting if we know the field address

      PVariant(PtrInt(Instance)+GetProc and $00FFFFFF)^ := Value else

    if PropWrap(SetProc).Kind=$FF then

      PVariant(PtrInt(Instance)+SetProc and $00FFFFFF)^ := Value else

      ByMethod;

end;

{$endif}



{$endif USETYPEINFO}





type

  TIntfFlag = (ifHasGuid,ifDispInterface,ifDispatch{$ifdef FPC},ifHasStrGUID{$endif});

  TIntfFlags = set of TIntfFlag;



  {$ifdef FPC}

  {$PACKRECORDS C}

  {$endif}



  PInterfaceTypeData = ^TInterfaceTypeData;

  TInterfaceTypeData =

    {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}packed{$endif} record

    IntfParent: PPTypeInfo; // ancestor

    IntfFlags: TIntfFlags;

    IntfGuid: TGUID;

    IntfUnit: ShortString;

  end;



  {$ifdef FPC}

  PRawInterfaceTypeData = ^TRawInterfaceTypeData;

  TRawInterfaceTypeData =

    {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}packed{$endif} record

    RawIntfParent: PTypeInfo;

    RawIntfFlags : TIntfFlagsBase;

    IID: TGUID;

    RawIntfUnit: ShortString;

    IIDStr: ShortString;

  end;

  {$endif}



  {$ifdef FPC}

  {$PACKRECORDS DEFAULT}

  {$endif}





  TMethodKind = (mkProcedure, mkFunction, mkConstructor, mkDestructor,

    mkClassProcedure, mkClassFunction, { Obsolete } mkSafeProcedure, mkSafeFunction);



  TIntfMethodEntryTail =

    {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}packed{$endif} record

    {$ifdef FPC}

    Version: Byte; // alwyas 3 at the moment

    {$else}

    Kind: TMethodKind;

    {$endif}

    CC: TCallingConvention;

    {$ifdef FPC}

    ResultType: PTypeInfo;

    StackSize: Word;

    {$endif}

    ParamCount: Byte;

    {Params: array[0..ParamCount - 1] of TVmtMethodParam;}

  end;



{ TTypeInfo }



{$ifdef HASINLINE}

function TTypeInfo.ClassType: PClassType;

begin

  result := AlignToPtr(@Name[ord(Name[0])+1]);

end;

{$else}

function TTypeInfo.ClassType: PClassType;

asm // very fast code

  movzx edx,byte ptr [eax].TTypeInfo.Name

  lea eax,[eax+edx].TTypeInfo.Name[1]

end;

{$endif}



function TTypeInfo.ClassCreate: TObject;

var instance: TClassInstance;

begin

  instance.Init(ClassType^.ClassType);

  result := instance.CreateNew;

end;



function TTypeInfo.RecordType: PRecordType;

{$ifdef HASINLINE}

begin

  result := AlignToPtr(@Name[ord(Name[0])+1]);

{$else}

asm // very fast code

  movzx edx,byte ptr [eax].TTypeInfo.Name

  lea eax,[eax+edx].TTypeInfo.Name[1]

{$endif}

end;



function TTypeInfo.ClassFieldCount(onlyWithoutGetter: boolean): integer;

begin

  result := ClassFieldCountWithParents(ClassType^.ClassType,onlyWithoutGetter);

end;



function TTypeInfo.ClassSQLFieldType: TSQLFieldType;

var CT: PClassType;

    C,C2: TClass;

begin

  CT := AlignToPtr(@Name[ord(Name[0])+1]); // inlined ClassType

  C := CT^.ClassType;

  C2 := C;

  while true do // unrolled several InheritsFrom() calls

    if C<>TSQLRecordMany then

    if C<>TSQLRecord then

    if (C<>TRawUTF8List) and (C<>TStrings) and

       (C<>TObjectList) {$ifndef LVCL}and (C<>TCollection){$endif} then

      if CT^.ParentInfo<>nil then begin

        with Deref(CT^.ParentInfo)^ do

          CT := AlignToPtr(@Name[ord(Name[0])+1]); // get parent ClassType

        C := CT^.ClassType;

        if C<>TObject then

          continue else

          break;

      end else break

    else begin

      result := sftObject; // TStrings, TRawUTF8List or TCollection

      exit;

    end else begin

      result := sftID; // TSQLRecord field is pointer(RecordID), not an Instance

      exit;

    end else begin

      result := sftMany; // no data is stored here, but in a pivot table

      exit;

    end;

  if ClassHasPublishedFields(C2) then

    result := sftObject else // identify any class with published properties

    result := sftUnknown;

end;



function TTypeInfo.EnumBaseType: PEnumType;

{$ifdef HASINLINE}

begin

{$ifdef FPC}

  result := pointer(GetFPCTypeData(@Self));

{$else}

  with PEnumType(@Name[ord(Name[0])+1])^.BaseType^^ do

    result := @Name[ord(Name[0])+1];

{$endif}

{$else}

asm // very fast code

  movzx edx,byte ptr [eax].TTypeInfo.Name

  mov eax,[eax+edx].TTypeInfo.Name[1].TEnumType.BaseType

  mov eax,[eax]

  movzx edx,byte ptr [eax].TTypeInfo.Name

  lea eax,[eax+edx].TTypeInfo.Name[1]

{$endif}

end;



function TTypeInfo.InheritsFrom(AClass: TClass): boolean;

{$ifdef FPC_OR_PUREPASCAL}

var CT: PClassType;

begin

  CT := ClassType;

  repeat

    if CT^.ClassType={$ifndef FPC}pointer{$endif}(AClass) then begin

      result := true;

      exit;

    end;

    if CT^.ParentInfo = nil then

      break else

      CT := CT^.ParentInfo^.ClassType;

  until CT = nil;

  result := false;

end;

{$else}

asm // eax=PClassType edx=AClass

@1:movzx ecx,byte ptr [eax].TTypeInfo.Name

   lea eax,[eax+ecx].TTypeInfo.Name[1]

   cmp edx,[eax].TClassType.ClassType

   jz @2

   mov eax,[eax].TClassType.ParentInfo

   test eax,eax

   jz @3 // no parent

   mov eax,[eax] // get parent type info

   jmp @1

@3:rep ret

@2:mov eax,1

end;

{$endif}



function TTypeInfo.GetSQLFieldType: TSQLFieldType;

begin // very fast, thanks to the TypeInfo() compiler-generated function

  case Kind of

    tkInteger: begin

      result := sftInteger;

      exit; // direct exit is faster in generated asm code (Delphi 7 at least)

    end;

    tkInt64:

      if (@self=TypeInfo(TRecordReference)) or

         (@self=TypeInfo(TRecordReferenceToBeDeleted)) then begin

        result := sftRecord;

        exit;

      end else

      if @self=TypeInfo(TCreateTime) then begin

        result := sftCreateTime;

        exit;

      end else

      if @self=TypeInfo(TModTime) then begin

        result := sftModTime;

        exit;

      end else

      if @self=TypeInfo(TTimeLog) then begin

        result := sftTimeLog;

        exit;

      end else

      if @self=TypeInfo(TID) then begin

        result := sftTID;

        exit;

      end else

      if @self=TypeInfo(TSessionUserID) then begin

        result := sftSessionUserID;

        exit;

      end else

      if @self=TypeInfo(TRecordVersion) then begin

        result := sftRecordVersion;

        exit;

      end else

      if (ord(Name[1]) and $df=ord('T')) and // T...ID pattern in type name -> TID

         (PWord(@Name[ord(Name[0])-1])^ and $dfdf=ord('I')+ord('D') shl 8) then begin

        result := sftTID;

        exit;

      end else begin

        result := sftInteger;

        exit;

      end;

    {$ifdef FPC}

    tkBool: begin

      result := sftBoolean;

      exit;

    end;

    {$endif}

    tkSet: begin

      result := sftSet;

      exit;

    end;

    tkEnumeration:

      {$ifndef FPC}

      if @self=TypeInfo(Boolean) then begin

        result := sftBoolean;

        exit;

      end else

      {$endif}

      if @self=TypeInfo(WordBool) then begin // circumvent a Delphi RTTI bug

        result := sftBoolean;

        exit;

      end else

      begin

        result := sftEnumerate;

        exit;

      end;

    tkFloat:

      if @self=TypeInfo(Currency) then begin

        result := sftCurrency;

        exit;

      end else

      if @self=TypeInfo(TDateTime) then begin

        result := sftDateTime;

        exit;

      end else begin

        result := sftFloat;

        exit;

      end;

      {$ifdef FPC}tkAString,{$endif} tkLString:

      // do not use AnsiStringCodePage since AnsiString = GetAcp may change

      if (@self=TypeInfo(TSQLRawBlob)) or

         (@self=TypeInfo(RawByteString)) then begin

        result := sftBlob;

        exit;

      end else

      if @self=TypeInfo(WinAnsiString) then begin

        result := sftAnsiText;

        exit;

      end else begin

        result := sftUTF8Text; // CP_UTF8,CP_UTF16 and any other to UTF-8 text

        exit; 

      end;

    {$ifdef HASVARUSTRING}tkUString,{$endif} tkChar, tkWChar, tkWString: begin

      result := sftUTF8Text;

      exit;

    end;

    tkDynArray: begin

      result := sftBlobDynArray;

      exit;

    end;

    {$ifdef PUBLISHRECORD}

    tkRecord{$ifdef FPC},tkObject{$endif}: begin

      result := sftUTF8Custom;

      exit;

    end;

    {$endif}

    {$ifndef NOVARIANTS}

    tkVariant: begin // this function does not need to handle sftNullable

      result := sftVariant;

      exit;

    end;

    {$endif}

    tkClass: begin

      result := ClassSQLFieldType;

      exit;

    end;

    // note: tkString (shortstring) and tkInterface not handled

    else begin

      result := sftUnknown;

      exit;

    end;

  end;

end;



function TTypeInfo.FloatType: TFloatType;

{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}

var

  td: PTypeData;

{$endif}

begin

  {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}

  td := GetTypeData(@Self);

  result := TFloatType(PByte(td)^);

  {$else}

  result := TFloatType(PByte(@Name[ord(Name[0])+1])^);

  {$endif}

end;



function TTypeInfo.OrdType: TOrdType;

{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}

var

  td: PTypeData;

{$endif}

begin

  {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}

  td := GetTypeData(@Self);

  result := TOrdType(PByte(td)^);

  {$else}

  result := TOrdType(PByte(@Name[ord(Name[0])+1])^);

  {$endif}

end;



function TTypeInfo.SetEnumType: PEnumType;

{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}

var p: pointer;

begin

  if (@self=nil) or (Kind<>tkSet) then

    result := nil else begin

    p := pointer(GetTypeData(@Self));

    inc(p,sizeof(TOrdType));

    p := AlignToPtr(p);

    result := PPTypeInfo(PPointer(p)^)^.EnumBaseType;

  end;

{$else}

begin

  if (@self=nil) or (Kind<>tkSet) then

    result := nil else

    result := PPTypeInfo(PPointer(PtrUInt(@Name[ord(Name[0])+1])+sizeof(TOrdType))^)^.

      EnumBaseType;

{$endif}

end;



function TTypeInfo.DynArrayItemType(aDataSize: PInteger): PTypeInfo;

begin

  if @self=nil then

    result := nil else

    result := DynArrayTypeInfoToRecordInfo(@self,aDataSize);

end;



function TTypeInfo.DynArrayItemSize: integer;

begin

  if @self=nil then

    result := 0 else

    DynArrayTypeInfoToRecordInfo(@self,@result);

end;



function TTypeInfo.AnsiStringCodePage: integer;

{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}

var

  td: PTypeData;

{$endif}

begin

  {$ifdef HASCODEPAGE}

  if @self=TypeInfo(TSQLRawBlob) then

    result := CP_SQLRAWBLOB else

    if Kind in [{$ifdef FPC}tkAString,{$endif} tkLString] then

    {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}

    begin

      td := GetTypeData(@Self);

      result := PWORD(td)^;

    end else

    {$else}

      result := PWord(@Name[ord(Name[0])+1])^ else // from RTTI

    {$endif}

  {$else}

  if @self=TypeInfo(RawUTF8) then

    result := CP_UTF8 else

  if @self=TypeInfo(WinAnsiString) then

    result := CODEPAGE_US else

  if @self=TypeInfo(RawUnicode) then

    result := CP_UTF16 else

  if @self=TypeInfo(TSQLRawBlob) then

    result := CP_SQLRAWBLOB else

  if @self=TypeInfo(RawByteString) then

    result := CP_RAWBYTESTRING else

  if (@self=TypeInfo(AnsiString)) or IdemPropName(Name,'TCaption') then

    result := 0 else

  {$endif}

    result := CP_UTF8; // default is UTF-8

end;



function TTypeInfo.InterfaceGUID: PGUID;

{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}

var

  td:PTypeData;

{$endif}

begin

  if (@self=nil) or (Kind<>tkInterface) then result := nil else

  {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}

  begin

    td := GetTypeData(@Self);

    result := @td^.GUID;

  end;

  {$else}

    result := @PInterfaceTypeData(@Name[ord(Name[0])+1])^.IntfGuid;

  {$endif}

end;



function TTypeInfo.InterfaceUnitName: PShortString;

{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}

var

  td: PTypeData;

{$endif}

begin

  if (@self=nil) or (Kind<>tkInterface) then

    result := @NULL_SHORTSTRING else

    {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}

    begin

      td := GetTypeData(@Self);

      result := @td^.IntfUnit;

    end;

    {$else}

      result := @PInterfaceTypeData(@Name[ord(Name[0])+1])^.IntfUnit;

    {$endif}

end;



function TTypeInfo.InterfaceAncestor: PTypeInfo;

{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}

var

  td: PTypeData;

{$endif}

begin

  if (@self=nil) or (Kind<>tkInterface) then

    result := nil else

    begin

      {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}

      td := GetTypeData(@Self);

      with td^ do

      {$else}

      with PInterfaceTypeData(@Name[ord(Name[0])+1])^ do

      {$endif}

      if IntfParent=nil then

        result := nil else

          result := mORMot.PTypeInfo(Deref(IntfParent));

    end;

end;



procedure TTypeInfo.InterfaceAncestors(out Ancestors: PTypeInfoDynArray;

  OnlyImplementedBy: TInterfacedObjectClass;

  out AncestorsImplementedEntry: TPointerDynArray);

var n: integer;

    nfo: PTypeInfo;

    typ: PInterfaceTypeData;

    entry: pointer;

begin

  if (@self=nil) or (Kind<>tkInterface) then

    exit;

  n := 0;

  {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}

  typ := PInterfaceTypeData(GetTypeData(@Self));

  {$else}

  typ := @Name[ord(Name[0])+1];

  {$endif}

  repeat

    if typ^.IntfParent=nil then

      exit;

    nfo := Deref(typ^.IntfParent);

    if nfo=TypeInfo(IInterface) then

      exit;

    {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}

    typ := AlignToPtr(@nfo^.Name[ord(nfo^.Name[0])+1]);

    {$else}

    typ := @nfo^.Name[ord(nfo^.Name[0])+1];

    {$endif}

    if ifHasGuid in typ^.IntfFlags then begin

      if OnlyImplementedBy<>nil then begin

        entry := OnlyImplementedBy.GetInterfaceEntry(typ^.IntfGuid);

        if entry=nil then

          continue;

        Setlength(AncestorsImplementedEntry,n+1);

        AncestorsImplementedEntry[n] := entry;

      end;

      SetLength(Ancestors,n+1);

      Ancestors[n] := nfo;

      inc(n);

    end;

  until false;

end;





{ TClassProp }



function TClassProp.FieldProp(const PropName: shortstring): PPropInfo;

var i: integer;

begin

  if @self<>nil then begin

    result := @PropList;

    for i := 1 to PropCount do

      if IdemPropName(result^.Name,PropName) then

        exit else

        result := result^.Next;

  end;

  result := nil;

end;





{ TClassType }



{$ifdef FPC}

function TClassType.ClassProp: PClassProp;

begin

  if pointer(@self)<>nil then

    result := AlignToPtr(@UnitName[ord(UnitName[0])+1]) else

    result := nil; // avoid GPF

end;

{$else}

function TClassType.ClassProp: PClassProp;

begin

  if pointer(@self)<>nil then

    result := pointer(@UnitName[ord(UnitName[0])+1]) else

    result := nil; // avoid GPF

end;

{$endif}



function TClassType.RTTISize: integer;

var C: PClassProp;

    P: PPropInfo;

    i: Integer;

begin

  result := 0;

  C := ClassProp;

  if C=nil then

    exit;

  P := @C^.PropList;

  for i := 1 to C^.PropCount do

    P := P^.Next;

  result := PtrUInt(P)-PtrUInt(@self);

end;



{$ifdef PUREPASCAL}

function TClassType.InheritsFrom(AClass: TClass): boolean;

var P: PTypeInfo;

begin

  result := true;

  if ClassType=AClass then

    exit;

  P := DeRef(ParentInfo);

  while P<>nil do

    with P^.ClassType^ do

    if ClassType=AClass then

      exit else

      P := DeRef(ParentInfo);

  result := false;

end;

{$else}

function TClassType.InheritsFrom(AClass: TClass): boolean;

asm // eax=PClassType edx=AClass

    cmp [eax].TClassType.ClassType,edx

    jz @3

@2: mov eax,[eax].TClassType.ParentInfo

    test eax,eax

    jz @0

@1: mov eax,[eax]

    movzx ecx,byte ptr [eax].TTypeInfo.Name

    lea eax,[eax+ecx].TTypeInfo.Name[1]

    cmp edx,[eax].TClassType.ClassType

    jnz @2

@3: mov eax,1

@0:

end;

{$endif}





{ TEnumType }



{$ifdef FPC_ENUMHASINNER}

function TEnumType.MinValue: Longint;

begin

  result := inner.iMinValue;

end;



function TEnumType.MaxValue: Longint;

begin

  result := inner.iMaxValue;

end;



function TEnumType.BaseType: PPTypeInfo;

begin

  result := inner.iBaseType;

end;

{$endif FPC_ENUMHASINNER}



function TEnumType.GetEnumName(const Value): PShortString;

var Ordinal: integer;

begin

  case OrdType of // MaxValue does not work e.g. with WordBool

  otSByte, otUByte: Ordinal := byte(Value);

  otSWord, otUWord: Ordinal := word(Value);

  else              Ordinal := integer(Value);

  end;

  result := GetEnumNameOrd(Ordinal);

end;



function TEnumType.GetEnumNameOrd(Value: Integer): PShortString;

// note: FPC doesn't align NameList (cf. GetEnumName() function in typinfo.pp)

{$ifdef PUREPASCAL}

begin

  result := @NameList;

  if cardinal(Value)<=cardinal(MaxValue) then

    while Value>0 do begin

      dec(Value);

      inc(PByte(result),ord(result^[0])+1);

    end else

    result := @NULL_SHORTSTRING;

end;

{$else}

asm // eax=PEnumType edx=Value

    xor    ecx,ecx

    {$ifdef FPC_ENUMHASINNER}

    cmp    edx,[eax].TEnumType.inner.iMaxValue

    {$else}

    cmp    edx,[eax].TEnumType.MaxValue

    {$endif}

    lea    eax,[eax].TEnumType.NameList

    ja     @0

    test   edx,edx

    jz     @z

    push   edx

    shr    edx,2 // fast pipelined by-four scanning

    jz     @1

@4: dec    edx

    movzx  ecx,byte ptr [eax]

    lea    eax,[eax+ecx+1]

    movzx  ecx,byte ptr [eax]

    lea    eax,[eax+ecx+1]

    movzx  ecx,byte ptr [eax]

    lea    eax,[eax+ecx+1]

    movzx  ecx,byte ptr [eax]

    lea    eax,[eax+ecx+1]

    jnz    @4

    pop    edx

    and    edx,3

    jnz    @s

@z: ret

@1: pop    edx

@s: movzx  ecx,byte ptr [eax]

    dec    edx

    lea    eax,[eax+ecx+1] // next short string

    jnz    @s

    ret

@0: lea    eax,NULL_SHORTSTRING

end;

{$endif}



function TEnumType.GetSetNameCSV(Value: integer; SepChar: AnsiChar;

  FullSetsAsStar: boolean): RawUTF8;

var W: TTextWriter;

begin

  W := TTextWriter.CreateOwnedStream(1024);

  try

    GetSetNameCSV(W,Value,SepChar,FullSetsAsStar);

    W.SetText(result);

  finally

    W.Free;

  end;

end;



procedure TEnumType.GetSetNameCSV(W: TTextWriter; Value: integer; SepChar: AnsiChar;

  FullSetsAsStar: boolean);

var j: integer;

    PS: PShortString;

begin

  W.Add('[');

  if FullSetsAsStar and (MaxValue<32) and

     GetAllBits(Value,MaxValue+1) then

    W.AddShort('"*"') else begin

    PS := @NameList;

    for j := MinValue to MaxValue do begin

      if GetBit(Value,j) then begin

        W.Add('"');

        if twoTrimLeftEnumSets in W.CustomOptions then

          W.AddTrimLeftLowerCase(PS) else

          W.AddShort(PS^);

        W.Add('"',SepChar);

      end;

      inc(PByte(PS),ord(PS^[0])+1); // next item

    end;

  end;

  W.CancelLastComma;

  W.Add(']');

end;



function TEnumType.GetSetNameAsDocVariant(Value: integer; FullSetsAsStar: boolean): variant;

var j: integer;

    PS: PShortString;

    arr: TDocVariantData;

begin

  arr.InitFast;

  if FullSetsAsStar and (MaxValue<32) and

     GetAllBits(Value,MaxValue+1) then

    arr.AddItem('*') else begin

    PS := @NameList;

    for j := MinValue to MaxValue do begin

      if GetBit(Value,j) then

        arr.AddItem(PS^);

      inc(PByte(PS),ord(PS^[0])+1); // next item

    end;

  end;

  result := variant(arr);

end;



function TEnumType.GetEnumNameValue(Value: PUTF8Char; ValueLen: integer;

  AlsoTrimLowerCase: boolean): Integer;

begin

  if (Value<>nil) and (ValueLen>0) then begin

    result := FindShortStringListExact(@NameList,

      MaxValue,Value,ValueLen);

    if (result<0) and AlsoTrimLowerCase then

      result := FindShortStringListTrimLowerCase(@NameList,

        MaxValue,Value,ValueLen);

  end else

    result := -1;

end;



function TEnumType.GetEnumNameValue(const EnumName: ShortString): Integer;

begin

  result := GetEnumNameValue(@EnumName[1],ord(EnumName[0]));

end;



function TEnumType.GetEnumNameValue(Value: PUTF8Char): Integer;

begin

  result := GetEnumNameValue(Value,StrLen(Value));

end;



{$ifdef HASINLINE}

function TEnumType.GetEnumNameTrimed(const Value): RawUTF8;

begin

  result := TrimLeftLowerCaseShort(GetEnumName(Value));

end;

{$else}

{$ifdef PUREPASCAL}

function TEnumType.GetEnumNameTrimed(const Value): RawUTF8;

begin

  result := TrimLeftLowerCaseShort(GetEnumName(Value));

end;

{$else}

function TEnumType.GetEnumNameTrimed(const Value): RawUTF8;

asm

  push ecx

  call TEnumType.GetEnumName

  pop edx

  jmp TrimLeftLowerCaseShort

end;

{$endif}

{$endif}



function TEnumType.GetCaption(const Value): string;

// GetCaptionFromPCharLen() expect ASCIIz -> use temp RawUTF8

begin

  GetCaptionFromPCharLen(pointer(GetEnumNameTrimed(Value)),result);

end;



procedure TEnumType.GetEnumNameTrimedAll(var result: RawUTF8; const Prefix: RawUTF8;

  quotedValues: boolean);

var i: integer;

    V: PShortString;

begin

  with TTextWriter.CreateOwnedStream(1024) do

  try

    AddString(Prefix);

    V := @NameList;

    for i := MinValue to MaxValue do begin

      if quotedValues then

        Add('"');

      AddTrimLeftLowerCase(V);

      if quotedValues then

        Add('"');

      Add(',');

      inc(PByte(V),length(V^)+1);

    end;

    CancelLastComma;

    SetText(result);

  finally

    Free;

  end;

end;



procedure TEnumType.GetEnumNameAll(var result: RawUTF8; const Prefix: RawUTF8;

  quotedValues: boolean);

var i: integer;

    V: PShortString;

begin

  with TTextWriter.CreateOwnedStream(1024) do

  try

    AddString(Prefix);

    V := @NameList;

    for i := MinValue to MaxValue do begin

      if quotedValues then

        Add('"');

      if twoTrimLeftEnumSets in CustomOptions then

        AddTrimLeftLowerCase(V) else

        AddShort(V^);

      if quotedValues then

        Add('"');

      Add(',');

      inc(PByte(V),length(V^)+1);

    end;

    CancelLastComma;

    SetText(result);

  finally

    Free;

  end;

end;



procedure TEnumType.GetEnumNameAll(var result: TRawUTF8DynArray;

  TrimLeftLowerCase: boolean);

var max,i: integer;

    V: PShortString;

begin

  max := MaxValue-MinValue;

  SetLength(result,max+1);

  V := @NameList;

  for i := 0 to max do begin

    if TrimLeftLowerCase then

      result[i] := TrimLeftLowerCaseShort(V) else

      result[i] := RawUTF8(V^);

    inc(PByte(V),length(V^)+1);

  end;

end;



function TEnumType.GetEnumNameAllAsJSONArray(TrimLeftLowerCase: boolean): RawUTF8;

var i: integer;

    V: PShortString;

begin

  with TTextWriter.CreateOwnedStream(1024) do

  try

    Add('[');

    V := @NameList;

    for i := MinValue to MaxValue do begin

      Add('"');

      if TrimLeftLowerCase then

        AddTrimLeftLowerCase(V) else

        AddShort(V^);

      Add('"',',');

      inc(PByte(V),length(V^)+1);

    end;

    CancelLastComma;

    Add(']');

    SetText(result);

  finally

    Free;

  end;

end;



procedure TEnumType.AddCaptionStrings(Strings: TStrings; UsedValuesBits: Pointer=nil);

var i, L: integer;

    Line: array[byte] of AnsiChar;

    P: PAnsiChar;

    V: PShortString;

    s: string;

begin

  if @self=nil then

    exit;

  {$ifndef LVCL}

  Strings.BeginUpdate;

  try

  {$endif}

    V := @NameList;

    for i := MinValue to MaxValue do begin

      if (UsedValuesBits=nil) or

         GetBit(UsedValuesBits^,i) then begin

        L := ord(V^[0]);

        P := @V^[1];

        while (L>0) and (P^ in ['a'..'z']) do begin // ignore left lowercase chars

          inc(P);

          dec(L);

        end;

        if L=0 then begin

          L := ord(V^[0]);

          P := @V^[1];

        end;

        Line[L] := #0; // GetCaptionFromPCharLen() expect it as ASCIIZ

        MoveFast(P^,Line,L);

        GetCaptionFromPCharLen(Line,s);

        Strings.AddObject(s,pointer(i));

      end;

      inc(PByte(V),length(V^)+1);

    end;

  {$ifndef LVCL}

  finally

    Strings.EndUpdate;

  end;

  {$endif}

end;



function TEnumType.GetCaptionStrings(UsedValuesBits: Pointer=nil): string;

var List: TStringList;

begin

  List := TStringList.Create;

  try

    AddCaptionStrings(List,UsedValuesBits);

    result := List.Text;

  finally

    List.Free;

  end;

end;



function TEnumType.GetEnumNameTrimedValue(const EnumName: ShortString): Integer;

begin

  result := FindShortStringListTrimLowerCase(@NameList,MaxValue,@EnumName[1],ord(EnumName[0]));

  if result<0 then

    result := FindShortStringListExact(@NameList,MaxValue,@EnumName[1],ord(EnumName[0]));

end;



function TEnumType.GetEnumNameTrimedValue(Value: PUTF8Char): Integer;

var ValueLen: integer;

begin

  if Value=nil then

    result := -1 else begin

    ValueLen := StrLen(Value);

    result := FindShortStringListTrimLowerCase(@NameList,MaxValue,Value,ValueLen);

    if result<0 then

      result := FindShortStringListExact(@NameList,MaxValue,Value,ValueLen);

  end;

end;



function TEnumType.SizeInStorageAsEnum: Integer;

begin

  case OrdType of // MaxValue does not work e.g. with WordBool

  otSByte, otUByte: result := 1;

  otSWord, otUWord: result := 2;

  else              result := 4;

  end;

end;



procedure TEnumType.SetEnumFromOrdinal(out Value; Ordinal: Integer);

begin

  case OrdType of // MaxValue does not work e.g. with WordBool

  otSByte, otUByte: byte(Value) := Ordinal;

  otSWord, otUWord: word(Value) := Ordinal;

  else              integer(Value) := Ordinal;

  end;

end;



function TEnumType.SizeInStorageAsSet: Integer;

begin

  case MaxValue of

  0..7:   result := 1;

  8..15:  result := 2;

  16..31: result := 4;

  else    result := 0;

  end;

end;



function SQLWhereIsEndClause(const Where: RawUTF8): boolean;

begin

  result := IdemPCharArray(pointer(Where),['ORDER BY ','GROUP BY ',

    'LIMIT ','OFFSET ','LEFT ','RIGHT ','INNER ','OUTER ','JOIN '])>=0;

end;



function SQLFromWhere(const Where: RawUTF8): RawUTF8;

begin

  if Where='' then

    result := '' else

  if SQLWhereIsEndClause(Where) then

    result := ' '+Where else

    result := ' WHERE '+Where;

end;



function SQLFromSelect(const TableName, Select, Where, SimpleFields: RawUTF8): RawUTF8;

begin

  if Select='*' then

     // don't send BLOB values to query: retrieve all other fields

    result := 'SELECT '+SimpleFields  else

    result := 'SELECT '+Select;

  result := result+' FROM '+TableName+SQLFromWhere(Where);

end;





{ TSQLRecordFill }



function TSQLRecordFill.GetJoinedFields: boolean;

begin

  if self=nil then

    result := false else

    result := fJoinedFields;

end;



function TSQLRecordFill.TableMapFields: TSQLFieldBits;

begin

  if self=nil then

    FillZero(result) else

    result := fTableMapFields;

end;



procedure TSQLRecordFill.AddMap(aRecord: TSQLRecord; aField: TSQLPropInfo;

  aIndex: integer);

begin

  if (self=nil) or (aRecord=nil) then

    exit;

  if fTableMapCount>=length(fTableMap) then

    SetLength(fTableMap,fTableMapCount+fTableMapCount shr 1+16);

  with fTableMap[fTableMapCount] do begin

    Dest := aRecord;

    DestField := aField;

    TableIndex := aIndex;

    inc(fTableMapCount);

  end;

end;



procedure TSQLRecordFill.AddMap(aRecord: TSQLRecord; const aFieldName: RawUTF8;

  aIndex: integer);

var aFieldIndex: integer;

begin

  if (self<>nil) and (aRecord<>nil) then

    if IsRowID(pointer(aFieldName)) then

      AddMap(aRecord,nil,aIndex) else

      with aRecord.RecordProps do begin

        aFieldIndex := Fields.IndexByName(aFieldName);

        if aFieldIndex>=0 then begin // only map if column name is a valid field

          include(fTableMapFields,aFieldIndex);

          AddMap(aRecord,Fields.List[aFieldIndex],aIndex);

        end;

      end;

end;



procedure TSQLRecordFill.AddMapSimpleFields(aRecord: TSQLRecord;

  const aProps: array of TSQLPropInfo; var aIndex: integer);

var i: integer;

begin

  AddMap(aRecord,nil,aIndex);

  inc(aIndex);

  for i := 0 to high(aProps) do

  if aProps[i].SQLFieldTypeStored<>sftID then begin

    AddMap(aRecord,aProps[i],aIndex);

    inc(aIndex);

  end;

end;



destructor TSQLRecordFill.Destroy;

begin

  try

    UnMap; // release fTable instance if necessary

  finally

    inherited;

  end;

end;



function TSQLRecordFill.Fill(aRow: integer): Boolean;

begin

  if (self=nil) or (Table=nil) or (cardinal(aRow)>cardinal(Table.fRowCount)) then

    Result := False else begin

    Fill(@Table.fResults[aRow*Table.FieldCount]);

    Result := True;

  end;

end;



function TSQLRecordFill.Fill(aRow: integer; aDest: TSQLRecord): Boolean;

begin

  if (self=nil) or (aDest=nil) or

     (Table=nil) or (cardinal(aRow)>cardinal(Table.fRowCount)) then

    Result := False else begin

    Fill(@Table.fResults[aRow*Table.FieldCount],aDest);

    Result := True;

  end;

end;



procedure TSQLRecordFill.Fill(aTableRow: PPUtf8CharArray);

var f: integer;

begin

  if (self<>nil) and (aTableRow<>nil) then

    for f := 0 to fTableMapCount-1 do

      with fTableMap[f] do

        if DestField=nil then

          SetID(aTableRow[TableIndex],Dest.fID) else

          DestField.SetValue(Dest,aTableRow[TableIndex],false);

end;



procedure TSQLRecordFill.Fill(aTableRow: PPUtf8CharArray; aDest: TSQLRecord);

var f: integer;

begin

  if (self<>nil) and (aTableRow<>nil) then

  for f := 0 to fTableMapCount-1 do

    with fTableMap[f] do

      if DestField=nil then

        SetID(aTableRow[TableIndex],aDest.fID) else

        DestField.SetValue(aDest,aTableRow[TableIndex],false);

end;



procedure TSQLRecordFill.ComputeSetUpdatedFieldBits(Props: TSQLRecordProperties;

  out Bits: TSQLFieldBits);

begin

  if (self<>nil) and (fTable<>nil) and (fTableMapRecordManyInstances=nil) then

    // within FillPrepare/FillOne loop: update ID, TModTime and mapped fields

    Bits := fTableMapFields+Props.ComputeBeforeUpdateFieldsBits else

    // update all simple/custom fields (also for FillPrepareMany)

    Bits := Props.SimpleFieldsBits[soUpdate];

end;



procedure TSQLRecordFill.Map(aRecord: TSQLRecord; aTable: TSQLTable;

  aCheckTableName: TSQLCheckTableName);

var f: integer;

    ColumnName: PUTF8Char;

    FieldName: shortstring;

    Props: TSQLRecordProperties;

begin

  if aTable=nil then // avoid any GPF

    exit;

  fTable := aTable;

  if aTable.fResults=nil then

    exit; // void content

  Props := aRecord.RecordProps;

  for f := 0 to aTable.FieldCount-1 do begin

    ColumnName := aTable.fResults[f];

    if aCheckTableName=ctnNoCheck then

      FieldName := ColumnName else

      if IdemPChar(ColumnName,pointer(Props.SQLTableNameUpperWithDot)) then

        FieldName := ColumnName+length(Props.SQLTableNameUpperWithDot) else

        if aCheckTableName=ctnMustExist then

          continue else

          FieldName := ColumnName;

    AddMap(aRecord,FieldName,f);

  end;

  fFillCurrentRow := 1; // point to first data row (0 is field names)

end;



procedure TSQLRecordFill.UnMap;

var i: integer;

begin

  if self=nil then

    exit;

  fTableMapCount := 0;

  fFillCurrentRow :=  0;

  // release TSQLRecordMany.fDestID^ instances set by TSQLRecord.FillPrepareMany()

  for i := 0 to high(fTableMapRecordManyInstances) do

  with fTableMapRecordManyInstances[i] do begin

    TObject(fDestID^).Free;

    fDestID^ := 0;

    fSourceID^ := 0;

  end;

  fTableMapRecordManyInstances := nil;

  FillZero(fTableMapFields);

  // free any previous fTable if necessary

  if Table<>nil then

  try

    if Table.OwnerMustFree then

      Table.Free;

  finally

    fTable := nil;

  end;

end;





{ TSQLRecord }



constructor TSQLRecord.Create;

var i: integer;

begin

  // auto-instanciate any TSQLRecordMany instance

  with RecordProps do

    if pointer(ManyFields)<>nil then

    for i := 0 to high(ManyFields) do

      ManyFields[i].SetInstance(self,TSQLRecordClass(ManyFields[i].ObjectClass).Create);

end;



constructor TSQLRecord.Create(const aSimpleFields: array of const; aID: TID);

begin

  Create;

  fID := aID;

  if not SimplePropertiesFill(aSimpleFields) then

    raise EORMException.CreateUTF8('Incorrect %.Create(aSimpleFields) call',[self]);

end;



function TSQLRecord.CreateCopy: TSQLRecord;

var f: integer;

begin

  // create new instance

  result := RecordClass.Create;

  // copy properties content

  result.fID := fID;

  with RecordProps do

    for f := 0 to high(CopiableFields) do

      CopiableFields[f].CopyValue(self,result);

end;



function TSQLRecord.CreateCopy(const CustomFields: TSQLFieldBits): TSQLRecord;

var f: integer;

begin

  result := RecordClass.Create;

  // copy properties content

  result.fID := fID;

  with RecordProps do

    for f := 0 to Fields.Count-1 do

    with Fields.List[f] do

      if (f in CustomFields) and (SQLFieldType in COPIABLE_FIELDS) then

        CopyValue(self,result);

end;



constructor TSQLRecord.Create(aClient: TSQLRest; aID: TID; ForUpdate: boolean=false);

begin

  Create;

  if aClient<>nil then

    aClient.Retrieve(aID,self,ForUpdate);

end;



constructor TSQLRecord.Create(aClient: TSQLRest; aPublishedRecord: TSQLRecord; ForUpdate: boolean);

begin

  Create;

  if aClient<>nil then

    aClient.Retrieve(aPublishedRecord.ID,self,ForUpdate);

end;



constructor TSQLRecord.Create(aClient: TSQLRest; const aSQLWhere: RawUTF8);

begin

  Create;

  if aClient<>nil then

    aClient.Retrieve(aSQLWhere,self);

end;



constructor TSQLRecord.Create(aClient: TSQLRest; const FormatSQLWhere: RawUTF8;

  const BoundsSQLWhere: array of const);

begin

  Create;

  if aClient<>nil then

    aClient.Retrieve(FormatUTF8(FormatSQLWhere,[],BoundsSQLWhere),self);

end;



constructor TSQLRecord.Create(aClient: TSQLRest; const FormatSQLWhere: RawUTF8;

  const ParamsSQLWhere, BoundsSQLWhere: array of const);

begin

  Create;

  if aClient<>nil then

    aClient.Retrieve(FormatUTF8(FormatSQLWhere,ParamsSQLWhere,BoundsSQLWhere),self);

end;



constructor TSQLRecord.CreateFrom(const JSONRecord: RawUTF8);

begin

  Create;

  FillFrom(JSONRecord);

end;



constructor TSQLRecord.CreateFrom(P: PUTF8Char);

begin

  Create;

  FillFrom(P);

end;



{$ifndef NOVARIANTS}

constructor TSQLRecord.CreateFrom(const aDocVariant: variant);

begin

  Create;

  FillFrom(aDocVariant);

end;

{$endif}



class procedure TSQLRecord.InitializeTable(Server: TSQLRestServer;

  const FieldName: RawUTF8; Options: TSQLInitializeTableOptions);

var f: integer;

begin // is not part of TSQLRecordProperties because has been declared as virtual

  if (self<>nil) and (Server<>nil) and

     (Options*INITIALIZETABLE_NOINDEX<>INITIALIZETABLE_NOINDEX) then begin

    // ensure ID/RowID column is indexed

    if not (itoNoIndex4ID in Options) then

      if (FieldName='') or IsRowID(pointer(FieldName)) then

        Server.CreateSQLIndex(self,'ID',true); // for external tables

    // automatic column indexation of fields which are commonly searched by value

    with RecordProps do

    for f := 0 to Fields.Count-1 do

      with Fields.List[f] do

      if (FieldName='') or IdemPropNameU(FieldName,Name) then

        if ((aIsUnique in Attributes) and not (itoNoIndex4UniqueField in Options)) or

           ((SQLFieldType=sftRecord) and not (itoNoIndex4RecordReference in Options)) or

           ((SQLFieldType=sftRecordVersion) and not (itoNoIndex4RecordVersion in Options)) or

           ((SQLFieldType=sftID) and not (itoNoIndex4NestedRecord in Options)) or

           ((SQLFieldType=sftTID) and not (itoNoIndex4TID in Options)) then

            Server.CreateSQLIndex(self,Name,false);

  end; // failure in Server.CreateSQLIndex() above is ignored (may already exist)

end;



procedure TSQLRecord.FillFrom(aRecord: TSQLRecord);

var i, f: integer;

    S, D: TSQLRecordProperties;

    SP: TSQLPropInfo;

    wasString: boolean;

    tmp: RawUTF8;

begin

  if (self=nil) or (aRecord=nil) then

    exit;

  D := RecordProps;

  if PSQLRecordClass(aRecord)^.InheritsFrom(PSQLRecordClass(self)^) then begin

    if PSQLRecordClass(aRecord)^=PSQLRecordClass(self)^ then

      fID := aRecord.fID; // same class -> ID values will match

    for f := 0 to high(D.CopiableFields) do

      D.CopiableFields[f].CopyValue(aRecord,self);

    exit;

  end;

  S := aRecord.RecordProps; // two diverse tables -> don't copy ID

  for i := 0 to high(S.CopiableFields) do begin

    SP := S.CopiableFields[i];

    if D.Fields.List[SP.PropertyIndex].Name=SP.Name then // optimistic match

      f := SP.PropertyIndex else

      f := D.Fields.IndexByName(S.CopiableFields[i].Name);

    if f>=0 then begin

      SP.GetValueVar(aRecord,False,tmp,@wasString);

      D.Fields.List[f].SetValueVar(Self,tmp,wasString);

    end;

  end;

end;



procedure TSQLRecord.FillFrom(aRecord: TSQLRecord; const aRecordFieldBits: TSQLFieldBits);

var i, f: integer;

    S, D: TSQLRecordProperties;

    SP: TSQLPropInfo;

    wasString: boolean;

    tmp: RawUTF8;

begin

  if (self=nil) or (aRecord=nil) then

    exit;

  D := RecordProps;

  if PSQLRecordClass(aRecord)^.InheritsFrom(PSQLRecordClass(self)^) then begin

    if PSQLRecordClass(aRecord)^=PSQLRecordClass(self)^ then

      fID := aRecord.fID; // same class -> ID values will match

    for f := 0 to D.Fields.Count-1 do

      if f in aRecordFieldBits then

        D.Fields.List[f].CopyValue(aRecord,self);

    exit;

  end;

  S := aRecord.RecordProps; // two diverse tables -> don't copy ID

  for i := 0 to S.Fields.Count-1 do

  if i in aRecordFieldBits then begin

    SP := S.Fields.List[i];

    if D.Fields.List[i].Name=SP.Name then // optimistic match

      f := i else

      f := D.Fields.IndexByName(SP.Name);

    if f>=0 then begin

      SP.GetValueVar(aRecord,False,tmp,@wasString);

      D.Fields.List[f].SetValueVar(Self,tmp,wasString);

    end;

  end;

end;



procedure TSQLRecord.FillFrom(Table: TSQLTable; Row: integer);

begin

  try

    FillPrepare(Table);

    if Table.InternalState<>fInternalState then

      fInternalState := Table.InternalState;

    FillRow(Row);

  finally

    FillClose; // avoid GPF in TSQLRecord.Destroy

  end;

end;



procedure TSQLRecord.FillFrom(const JSONTable: RawUTF8; Row: integer);

var Table: TSQLTableJSON;

    tmp: TSynTempBuffer;

begin

  tmp.Init(JSONTable);

  Table := TSQLTableJSON.Create('',tmp.buf,tmp.len);

  try

    FillFrom(Table,Row);

  finally

    Table.Free;

    tmp.Done;

  end;

end;



procedure TSQLRecord.FillFrom(const JSONRecord: RawUTF8; FieldBits: PSQLFieldBits);

var tmp: TSynTempBuffer; // work on a private copy

begin

  tmp.Init(JSONRecord);

  try

    FillFrom(tmp.buf,FieldBits); // now we can safely call FillFrom()

  finally

    tmp.Done;

  end;

end;



procedure TSQLRecord.FillFrom(P: PUTF8Char; FieldBits: PSQLFieldBits);

(* two possible formats = first not expanded, 2nd is expanded (most useful)

 {"fieldCount":9,"values":["ID","Int","Test","Unicode","Ansi","ValFloat","ValWord",

  "ValDate","Next",0,0,"abcde+¬ef+á+¬","abcde+¬ef+á+¬","abcde+¬ef+á+¬",

  3.14159265300000E+0000,1203,"2009-03-10T21:19:36",0]}

 {"ID":0,"Int":0,"Test":"abcde+¬ef+á+¬","Unicode":"abcde+¬ef+á+¬","Ansi":

 "abcde+¬ef+á+¬","ValFloat": 3.14159265300000E+0000,"ValWord":1203,

 "ValDate":"2009-03-10T21:19:36","Next":0} *)

var F: array[0..MAX_SQLFIELDS-1] of PUTF8Char; // store field/property names

    wasString: boolean;

    i, n: integer;

    Prop, Value: PUTF8Char;

begin

  if FieldBits<>nil then

    FillZero(FieldBits^);

  // go to start of object

  if P=nil then

    exit;

  while P^<>'{' do

    if P^=#0 then exit else inc(P);

  if Expect(P,FIELDCOUNT_PATTERN) then begin

    // not expanded format

    n := GetJSONIntegerVar(P)-1;

    if cardinal(n)>high(F) then

      exit;

    if Expect(P,ROWCOUNT_PATTERN) then

      GetJSONIntegerVar(P); // just ignore "rowCount":.. here

    if not Expect(P,VALUES_PATTERN) then

      exit;

    for i := 0 to n do

      F[i] := GetJSONField(P,P);

    for i := 0 to n do begin

      Value := GetJSONFieldOrObjectOrArray(P,@wasString,nil,true);

      FillValue(F[i],Value,wasString,FieldBits); // set properties from values

    end;

  end else

  if P^='{' then begin

    // expanded format

    inc(P);

    repeat

      Prop := GetJSONPropName(P);

      if (Prop=nil) or (P=nil) then break;

      Value := GetJSONFieldOrObjectOrArray(P,@wasString,nil,true);

      FillValue(Prop,Value,wasString,FieldBits); // set property from value

    until P=nil;

  end;

end;



{$ifndef NOVARIANTS}

procedure TSQLRecord.FillFrom(const aDocVariant: variant);

var json: RawUTF8;

begin

  if _Safe(aDocVariant)^.Kind=dvObject then begin

    VariantSaveJSON(aDocVariant,twJSONEscape, json);

    FillFrom(pointer(json));

  end;

end;

{$endif}



procedure TSQLRecord.FillPrepare(Table: TSQLTable; aCheckTableName: TSQLCheckTableName);

begin

  if self=nil then

    exit;

  if fFill=nil then

    fFill := TSQLRecordFill.Create else

    fFill.UnMap;

  fFill.Map(self,Table,aCheckTableName);

end;



function TSQLRecord.FillPrepare(aClient: TSQLRest; const aSQLWhere: RawUTF8;

  const aCustomFieldsCSV: RawUTF8; aCheckTableName: TSQLCheckTableName): boolean;

var T: TSQLTable;

begin

  result := false;

  FillClose; // so that no further FillOne will work

  if (self=nil) or (aClient=nil) then

    exit;

  T := aClient.MultiFieldValues(RecordClass,aCustomFieldsCSV,aSQLWhere);

  if T=nil then

    exit;

  T.OwnerMustFree := true;

  FillPrepare(T,aCheckTableName);

  result := true;

end;



function TSQLRecord.FillPrepare(aClient: TSQLRest; const FormatSQLWhere: RawUTF8;

  const BoundsSQLWhere: array of const; const aCustomFieldsCSV: RawUTF8=''): boolean;

begin

  result := FillPrepare(aClient,FormatUTF8(FormatSQLWhere,[],BoundsSQLWhere),

    aCustomFieldsCSV);

end;



function TSQLRecord.FillPrepare(aClient: TSQLRest;

  const FormatSQLWhere: RawUTF8; const ParamsSQLWhere, BoundsSQLWhere: array of const;

  const aCustomFieldsCSV: RawUTF8): boolean;

begin

  result := FillPrepare(aClient,

    FormatUTF8(FormatSQLWhere,ParamsSQLWhere,BoundsSQLWhere),aCustomFieldsCSV);

end;



function TSQLRecord.FillPrepare(aClient: TSQLRest; const aIDs: array of Int64;

  const aCustomFieldsCSV: RawUTF8=''): boolean;

begin

  if high(aIDs)<0 then

    result := false else

    result := FillPrepare(aClient,

      Int64DynArrayToCSV(aIDs,length(aIDs),'ID in (',')'),aCustomFieldsCSV);

end;



function TSQLRecord.FillRow(aRow: integer; aDest: TSQLRecord): boolean;

begin

  if self<>nil then

    if aDest=nil then

      result := fFill.Fill(aRow) else

      if fFill.fTableMapRecordManyInstances=nil then

        result := fFill.Fill(aRow,aDest) else

        raise EBusinessLayerException.CreateUTF8(

          '%.FillRow() forbidden after FillPrepareMany',[self]) else

    result := false;

end;



function TSQLRecord.FillOne: boolean;

begin

  if (self=nil) or (fFill=nil) or (fFill.Table=nil) or

     (fFill.Table.fRowCount=0) or // also check if FillTable is emtpy

     (cardinal(fFill.FillCurrentRow)>cardinal(fFill.Table.fRowCount)) then

    result := false else begin

    FillRow(fFill.FillCurrentRow);

    inc(fFill.fFillCurrentRow);

    result := true;

  end;

end;



function TSQLRecord.FillRewind: boolean;

begin

  if (self=nil) or (fFill=nil) or (fFill.Table=nil) or (fFill.Table.fRowCount=0) then

    result := false else begin

    fFill.fFillCurrentRow := 1;

    result := true;

  end;

end;



procedure TSQLRecord.FillClose;

begin

  if self<>nil then

    fFill.UnMap;

end;



procedure TSQLRecord.AppendFillAsJsonValues(W: TJSONSerializer);

begin

  W.Add('[');

  while FillOne do begin

    GetJSONValues(W);

    W.Add(',');

  end;

  W.CancelLastComma;

  W.Add(']');

end;



procedure TSQLRecord.FillValue(PropName: PUTF8Char; Value: PUTF8Char;

  wasString: boolean; FieldBits: PSQLFieldBits);

var field: TSQLPropInfo;

begin

  if self<>nil then

    if IsRowID(PropName) then

      SetID(Value,fID) else begin

      field := RecordProps.Fields.ByName(PropName);

      if field<>nil then begin

        field.SetValue(self,Value,wasString);

        if FieldBits<>nil then

          Include(FieldBits^,field.PropertyIndex);

      end;

    end;

end;



function TSQLRecord.SetFieldSQLVars(const Values: TSQLVarDynArray): boolean;

var max, field: integer;

begin

  result := false;

  max := high(Values);

  with RecordProps do begin

    // expect exact Values[] type match with FieldType[]

    if max<>Fields.Count-1 then // must match field count

      exit else

    for field := 0 to max do

      if Fields.List[field].SQLDBFieldType<>Values[field].VType then

        exit;

    // now we can safely update field values

    for field := 0 to max do

      Fields.List[field].SetFieldSQLVar(self,Values[field]);

  end;

  result := true;

end;



procedure TSQLRecord.GetBinaryValues(W: TFileBufferWriter);

var f: integer;

begin

  with RecordProps do

    for f := 0 to Fields.Count-1 do

      Fields.List[f].GetBinary(self,W);

end;



procedure TSQLRecord.GetBinaryValuesSimpleFields(W: TFileBufferWriter);

var f: integer;

begin

  with RecordProps do

    for f := 0 to SimpleFieldCount-1 do

      SimpleFields[f].GetBinary(self,W);

end;



procedure TSQLRecord.GetBinaryValues(W: TFileBufferWriter;

  const aFields: TSQLFieldBits);

var f: integer;

begin

  with RecordProps do

    for f := 0 to Fields.Count-1 do

      if f in aFields then

        Fields.List[f].GetBinary(self,W);

end;



function TSQLRecord.GetBinary: RawByteString;

var W: TFileBufferWriter;

begin

  W := TFileBufferWriter.Create(TRawByteStringStream);

  try

    W.WriteVarUInt64(fID);

    GetBinaryValues(W);

    W.Flush;

    result := (W.Stream as TRawByteStringStream).DataString;

  finally

    W.Free;

  end;

end;



function TSQLRecord.SetBinary(P: PAnsiChar): Boolean;

begin

  fID := FromVarUInt64(PByte(P));

  result := SetBinaryValues(P);

end;



function TSQLRecord.SetBinaryValues(var P: PAnsiChar): boolean;

var f: integer;

begin

  result := false;

  with RecordProps do

    for f := 0 to Fields.Count-1 do begin

      P := Fields.List[f].SetBinary(self,P);

      if P=nil then

        exit; // on error

    end;

  result := true;

end;



function TSQLRecord.SetBinaryValuesSimpleFields(var P: PAnsiChar): Boolean;

var f: integer;

begin

  result := false;

  with RecordProps do

    for f := 0 to SimpleFieldCount-1 do begin

      P := SimpleFields[f].SetBinary(self,P);

      if P=nil then

        exit; // on error

    end;

  result := true;

end;



procedure TSQLRecord.GetJSONValues(W: TJSONSerializer);

var i,n: integer;

    Props: TSQLPropInfoList;

begin

  if self=nil then

    exit;

  // write the row data

  if W.Expand then begin

    W.Add('{');

    if W.WithID then

      W.AddString(W.ColNames[0]);

  end;

  if W.WithID then begin

    W.Add(fID);

    W.Add(',');

    if (jwoID_str in W.fSQLRecordOptions) and W.Expand then begin

      W.AddShort('"ID_str":"');

      W.Add(fID);

      W.Add('"',',');

    end;

    n := 1;

  end else

    n := 0;

  if W.Fields<>nil then begin

    Props := RecordProps.Fields;

    for i := 0 to length(W.Fields)-1 do begin

      if W.Expand then begin

        W.AddString(W.ColNames[n]); // '"'+ColNames[]+'":'

        inc(n);

      end;

      Props.List[W.Fields[i]].GetJSONValues(Self,W);

      W.Add(',');

    end;

  end;

  W.CancelLastComma; // cancel last ','

  if W.Expand then

    W.Add('}');

end;



procedure TSQLRecord.AppendAsJsonObject(W: TJSONSerializer; Fields: TSQLFieldBits);

var i: integer;

    Props: TSQLPropInfoList;

begin

  if Self=nil then begin

    W.AddShort('null');

    exit;

  end;

  W.AddShort('{"ID":');

  W.Add(fID);

  if IsZero(Fields) then

    Fields := RecordProps.SimpleFieldsBits[soSelect];

  Props := RecordProps.Fields;

  for i := 0 to Props.Count-1 do

    if i in Fields then begin

      W.Add(',','"');

      W.AddNoJSONEscape(pointer(Props.List[i].Name),length(Props.List[i].Name));

      W.Add('"',':');

      Props.List[i].GetJSONValues(Self,W);

    end;

  W.Add('}');

end;



procedure TSQLRecord.AppendFillAsJsonArray(const FieldName: RawUTF8;

   W: TJSONSerializer; Fields: TSQLFieldBits=[]);

begin

  if FieldName<>'' then

    W.AddFieldName(FieldName);

  W.Add('[');

  while FillOne do begin

    AppendAsJsonObject(W,Fields);

    W.Add(',');

  end;

  W.CancelLastComma;

  W.Add(']');

  if FieldName<>'' then

    W.Add(',');

end;



procedure TSQLRecord.ForceVariantFieldsOptions(aOptions: TDocVariantOptions);

var i: integer;

begin

  if self<>nil then

  with RecordProps do

  if sftVariant in HasTypeFields then

  for i := 0 to Fields.Count-1 do

    with TSQLPropInfoRTTIVariant(Fields.List[i]) do

    if (SQLFieldType=sftVariant) and InheritsFrom(TSQLPropInfoRTTIVariant) then

      if PropInfo.GetterIsField then

        with _Safe(PVariant(PropInfo.GetterAddr(self))^)^ do

          if Count>0 then

            Options := aOptions;

end;



procedure TSQLRecord.GetJSONValuesAndFree(JSON : TJSONSerializer);

begin

  if JSON<>nil then

  try

    // write the row data

    GetJSONValues(JSON);

    // end the JSON object

    if not JSON.Expand then

      JSON.AddNoJSONEscape(PAnsiChar(']}'),2);

    JSON.FlushFinal;

  finally

    JSON.Free;

  end;

end;



procedure TSQLRecord.GetJSONValues(JSON: TStream; Expand: boolean; withID: boolean;

  Occasion: TSQLOccasion; SQLRecordOptions: TJSONSerializerSQLRecordOptions);

var serializer: TJSONSerializer;

begin

  if self=nil then

    exit;

  with RecordProps do

    serializer := CreateJSONWriter(JSON,Expand,withID,SimpleFieldsBits[Occasion],0);

  serializer.SQLRecordOptions := SQLRecordOptions;

  GetJSONValuesAndFree(serializer);

end;



function TSQLRecord.GetJSONValues(Expand: boolean; withID: boolean;

  const Fields: TSQLFieldBits; SQLRecordOptions: TJSONSerializerSQLRecordOptions): RawUTF8;

var J: TRawByteStringStream;

    serializer: TJSONSerializer;

begin

  J := TRawByteStringStream.Create;

  try

    serializer := RecordProps.CreateJSONWriter(J,Expand,withID,Fields,0);

    serializer.SQLRecordOptions := SQLRecordOptions;

    GetJSONValuesAndFree(serializer);

    result := J.DataString;

  finally

    J.Free;

  end;

end;



function TSQLRecord.GetJSONValues(Expand: boolean; withID: boolean;

  const FieldsCSV: RawUTF8; SQLRecordOptions: TJSONSerializerSQLRecordOptions): RawUTF8;

var bits: TSQLFieldBits;

begin

  if RecordProps.FieldBitsFromCSV(FieldsCSV,bits) then

    result := GetJSONValues(Expand,withID,bits,SQLRecordOptions) else

    result := '';

end;



function TSQLRecord.GetJSONValues(Expand: boolean; withID: boolean;

  Occasion: TSQLOccasion; UsingStream: TCustomMemoryStream;

  SQLRecordOptions: TJSONSerializerSQLRecordOptions): RawUTF8;

var J: TRawByteStringStream;

begin

  if (not withID) and IsZero(RecordProps.SimpleFieldsBits[Occasion]) then

    // no simple field to write -> quick return

    result := '' else

  if UsingStream<>nil then begin

    UsingStream.Seek(0,soFromBeginning);

    GetJSONValues(UsingStream,Expand,withID,Occasion,SQLRecordOptions);

    SetString(result,PAnsiChar(UsingStream.Memory),UsingStream.Seek(0,soFromCurrent));

  end else begin

    J := TRawByteStringStream.Create;

    try

      GetJSONValues(J,Expand,withID,Occasion,SQLRecordOptions);

      result := J.DataString;

    finally

      J.Free;

    end;

  end;

end;



function GetVirtualTableSQLCreate(Props: TSQLRecordProperties): RawUTF8;

var i: integer;

    SQL: RawUTF8;

begin

  result := ''; // RowID is added by sqlite3_declare_vtab() for a Virtual Table

  for i := 0 to Props.Fields.Count-1 do

  with Props.Fields.List[i] do begin

    SQL := Props.SQLFieldTypeToSQL(i); // = '' for field with no matching DB column

    if SQL<>'' then

      result := result+Name+SQL;

  end;

  if result='' then

    result := ');' else

    pWord(@result[length(result)-1])^ := ord(')')+ord(';')shl 8;

end;



class function TSQLRecord.GetSQLCreate(aModel: TSQLModel): RawUTF8;

// not implemented in TSQLRecordProperties since has been made virtual

var i: integer;

    SQL: RawUTF8;

    M: TSQLVirtualTableClass;

    Props: TSQLModelRecordProperties;

begin

  if aModel=nil then

    raise EModelException.CreateUTF8('Invalid %.GetSQLCreate(nil) call',[self]);

  Props := aModel.Props[self];

  if Props.Kind<>rSQLite3 then begin

    // create a FTS3/FTS4/RTREE virtual table

    result := 'CREATE VIRTUAL TABLE '+SQLTableName+' USING ';

    case Props.Kind of

    rFTS3:

      result := result+'fts3(';

    rFTS4:

      result := result+'fts4(';

    rRTree: result := result+'rtree(RowID,';

    rCustomForcedID, rCustomAutoID: begin

      M := aModel.VirtualTableModule(self);

      if M=nil then

        raise EModelException.CreateUTF8('No registered module for %',[self]);

      if Props.Props.Fields.Count=0 then

        raise EModelException.CreateUTF8(

          'Virtual % class % should have published properties',[M.ModuleName,self]);

      result := result+M.ModuleName+'(';

      result := result+GetVirtualTableSQLCreate(Props.Props);

    end;

    end;

    with Props.Props.Fields do

    case Props.Kind of

    rFTS3, rFTS4: begin

      if (Props.fFTSWithoutContentFields<>'') and (Props.fFTSWithoutContentTableIndex>=0) then

        result := result+'content="'+aModel.Tables[Props.fFTSWithoutContentTableIndex].

          SQLTableName+'",';

      if Count=0 then

        raise EModelException.CreateUTF8(

          'Virtual FTS class % should have published properties',[self]);

      for i := 0 to Count-1 do

        with List[i] do

        if SQLFieldTypeStored<>sftUTF8Text then

          raise EModelException.CreateUTF8('%.%: FTS3/FTS4 field must be RawUTF8',

            [self,Name]) else

          result := result+Name+',';

      if InheritsFrom(TSQLRecordFTS3Porter) or

         InheritsFrom(TSQLRecordFTS4Porter) then

        result := result+' tokenize=porter)' else

      if InheritsFrom(TSQLRecordFTS3Unicode61) or

         InheritsFrom(TSQLRecordFTS4Unicode61) then

        result := result+' tokenize=unicode61)' else

        result := result+' tokenize=simple)';

    end;

    rRTree: begin

      if (Count<2) or (Count>RTREE_MAX_DIMENSION*2) or

         (Count and 2<>0) then

        raise EModelException.CreateUTF8('% has % fields: RTREE expects 2,4,6..%',

          [self,Count,RTREE_MAX_DIMENSION*2]);

      for i := 0 to Count-1 do

        with List[i] do

        if SQLFieldTypeStored<>sftFloat then

          raise EModelException.CreateUTF8('%.%: RTREE field must be double',[self,Name]) else

          result := result+Name+',';

      result[length(result)] := ')';

    end;

    end;

  end else begin

    // inherits from TSQLRecord: create a "normal" SQLite3 table

    result := 'CREATE TABLE '+SQLTableName+

      '(ID INTEGER PRIMARY KEY AUTOINCREMENT, ';

    // we always add an ID field which is an INTEGER PRIMARY KEY

    // column, as it is always created (as hidden ROWID) by the SQLite3 engine

    with Props.Props do

    for i := 0 to Fields.Count-1 do

    with Fields.List[i] do begin

      SQL := SQLFieldTypeToSQL(i); // = '' for field with no matching DB column

      if SQL<>'' then begin

        result := result+Name+SQL;

        if i in IsUniqueFieldsBits then

          insert(' UNIQUE',result,length(result)-1);

      end;

    end;

    pWord(@result[length(result)-1])^ := ord(')')+ord(';')shl 8;

  end;

end;



function TSQLRecord.GetSQLSet: RawUTF8;

var i: integer;

    V: RawUTF8;

    wasString: boolean;

begin

  result := '';

  if self=nil then

    exit;

  with RecordProps do

    for i := 0 to High(SimpleFields) do

    with SimpleFields[i] do begin

      // format is 'COL1='VAL1', COL2='VAL2'' }

      GetValueVar(self,true,V,@wasString);

      if wasString then

        V := QuotedStr(V);

      result := result+Name+'='+V+', ';

    end;

  if result<>'' then

    SetLength(result,length(result)-2);

end;



function TSQLRecord.GetSQLValues: RawUTF8;

var i: integer;

    V: RawUTF8;

    wasString: boolean;

begin

  result := '';

  if self<>nil then

  with RecordProps do

    if SimpleFields=nil then

      exit else begin

    if HasNotSimpleFields then // get 'COL1,COL2': no 'ID,' for INSERT (false below)

      result := SQLTableSimpleFieldsNoRowID; // always <> '*'

    result := result+' VALUES (';

    for i := 0 to high(SimpleFields) do

    with SimpleFields[i] do begin

      GetValueVar(self,true,V,@wasString);

      if wasString then

        V := QuotedStr(V);

      result := result+V+',';

    end;

    result[length(result)] := ')';

  end;

end;



class function TSQLRecord.CaptionName(Action: PRawUTF8=nil; ForHint: boolean=false): string;

begin

  if Action=nil then

    GetCaptionFromPCharLen(pointer(RecordProps.SQLTableName),result) else

    GetCaptionFromPCharLen(TrimLeftLowerCase(Action^),result);

end;



class function TSQLRecord.CaptionNameFromRTTI(Action: PShortString): string;

var tmp: RawUTF8;

begin

  if Action=nil then

    result := CaptionName(nil) else begin

    SetString(tmp,PAnsiChar(@Action^[1]),ord(Action^[0]));

    result := CaptionName(@tmp);

  end;

end;



function TSQLRecord.SameValues(Reference: TSQLRecord): boolean;

var O: TSQLPropInfo;

    i: integer;

    This,Ref: TSQLRecordProperties;

begin

  result := false;

  if (self=nil) or (Reference=nil) or

     (Reference.fID<>fID) then // ID field must be tested by hand

    exit;

  if self<>Reference then

  if (PSQLRecordClass(Reference)^=PSQLRecordClass(self)^) then begin

    // faster comparison on same exact class

    with RecordProps do

    for i := 0 to high(SimpleFields) do

      // compare not TSQLRawBlob/TSQLRecordMany fields

      with SimpleFields[i] do

        if CompareValue(self,Reference,false)<>0 then

          exit; // properties don't have the same value

  end else begin

    // comparaison of all properties of Reference against self

    This := RecordProps;

    Ref := Reference.RecordProps;

    for i := 0 to high(Ref.SimpleFields) do

    with Ref.SimpleFields[i] do begin

      // compare not TSQLRawBlob/TSQLRecordMany fields

      O := This.Fields.ByRawUTF8Name(Name);

      if O=nil then

        exit; // this Reference property doesn't exist in current object

      if GetValue(Reference,false,nil)<>O.GetValue(self,false,nil) then

        exit; // properties don't have the same value

    end;

  end;

  result := true;

end;



function TSQLRecord.SameRecord(Reference: TSQLRecord): boolean;

var i: integer;

begin

  result := false;

  if (self=nil) or (Reference=nil) or

     (PSQLRecordClass(Reference)^<>PSQLRecordClass(Self)^) or (Reference.fID<>fID) then

    exit;

  with RecordProps do

    for i := 0 to high(SimpleFields) do

      // compare not TSQLRawBlob/TSQLRecordMany fields

      with SimpleFields[i] do

        if CompareValue(self,Reference,false)<>0 then

          exit; // properties don't have the same value

  result := true;

end;



procedure TSQLRecord.ClearProperties;

var i: integer;

begin

  if self=nil then

    exit;

  fInternalState := 0;

  fID := 0;

  with RecordProps do

    if fFill.JoinedFields then begin

      for i := 0 to high(CopiableFields) do

        if CopiableFields[i].SQLFieldType<>sftID then

          CopiableFields[i].SetValue(self,nil,false) else

          TSQLRecord(TSQLPropInfoRTTIInstance(CopiableFields[i]).GetInstance(Self)).

            ClearProperties; // clear nested allocated TSQLRecord

    end else

    for i := 0 to high(CopiableFields) do

      CopiableFields[i].SetValue(self,nil,false);

end;



procedure TSQLRecord.ClearProperties(const aFieldsCSV: RawUTF8);

var bits: TSQLFieldBits;

    f: integer;

begin

  if (self=nil) or (aFieldsCSV='') then

    exit;

  with RecordProps do begin

    if aFieldsCSV='*' then

      bits := SimpleFieldsBits[soInsert] else

      if not FieldBitsFromCSV(aFieldsCSV,bits) then

        exit;

    for f := 0 to Fields.Count-1 do

      if (f in bits) and (Fields.List[f].SQLFieldType in COPIABLE_FIELDS) then

        Fields.List[f].SetValue(self,nil,false); // clear field value

  end;

end;



{$IFDEF PUREPASCAL}

function TSQLRecord.RecordClass: TSQLRecordClass;

begin

  if self=nil then

    Result := nil else

    Result := PSQLRecordClass(Self)^;

end;

{$else}

function TSQLRecord.RecordClass: TSQLRecordClass;

asm

  test eax,eax; jz @z

  mov eax,[eax]

@z:

end;

{$endif}



{$IFDEF PUREPASCAL}

function TSQLRecord.ClassProp: PClassProp;

begin

  if self<>nil then

    result := InternalClassProp(ClassType) else

    result := nil; // avoid GPF

end;

{$else}

function TSQLRecord.ClassProp: PClassProp;

asm

  test eax,eax; jz @z // avoid GPF

  mov eax,[eax] // get ClassType of this TSQLRecord instance

  test eax,eax; jz @z // avoid GPF

  mov eax,[eax+vmtTypeInfo]

  test eax,eax; jz @z // avoid GPF

  movzx edx,byte ptr [eax].TTypeInfo.Name

  lea eax,[eax+edx].TTypeInfo.Name[1]

  movzx edx,byte ptr [eax].TClassType.UnitName

  lea eax,[eax+edx].TClassType.UnitName[1].TClassProp

@z:

end;

{$endif}



function TSQLRecord.RecordReference(Model: TSQLModel): TRecordReference;

begin

  if (self=nil) or (fID<=0) then

    result := 0 else begin

    result := Model.GetTableIndexExisting(PSQLRecordClass(Self)^);

    if result>63 then // TRecordReference handle up to 64=1 shl 6 tables

      result := 0 else

      inc(result,fID shl 6);

  end;

end;



destructor TSQLRecord.Destroy;

var i: integer;

    props: TSQLRecordProperties;

begin

  props := RecordProps;

  if fFill<>nil then begin

    if fFill.fJoinedFields then

      // free all TSQLRecord instances created by TSQLRecord.CreateJoined

      for i := 0 to length(props.JoinedFields)-1 do

        props.JoinedFields[i].GetInstance(self).Free;

    fFill.Free; // call UnMap -> release fTable instance if necessary

  end;

  // free all TSQLRecordMany instances created by TSQLRecord.Create

  if props.ManyFields<>nil then

    for i := 0 to length(props.ManyFields)-1 do

      props.ManyFields[i].GetInstance(self).Free;

  // free any registered T*ObjArray

  if props.DynArrayFieldsHasObjArray then

    for i := 0 to length(props.DynArrayFields)-1 do

      with props.DynArrayFields[i] do

      if ObjArray<>nil then

        ObjArrayClear(fPropInfo^.GetFieldAddr(self)^);

  inherited;

end;



function TSQLRecord.SimplePropertiesFill(const aSimpleFields: array of const): boolean;

var i: integer;

    tmp: RawUTF8;

begin

  if self=nil then

    result := false else // means error

    with RecordProps do

    if length(SimpleFields)<>length(aSimpleFields) then

      result := false else begin

      for i := 0 to high(aSimpleFields) do begin

        VarRecToUTF8(aSimpleFields[i],tmp); // will work for every handled type

        SimpleFields[i].SetValueVar(self,tmp,false);

      end;

      result := True;

    end;

end;



constructor TSQLRecord.CreateAndFillPrepare(aClient: TSQLRest;

  const aSQLWhere: RawUTF8; const aCustomFieldsCSV: RawUTF8='');

var aTable: TSQLTable;

begin

  Create;

  aTable := aClient.MultiFieldValues(RecordClass,aCustomFieldsCSV,aSQLWhere);

  if aTable=nil then

    exit;

  aTable.OwnerMustFree := true;

  FillPrepare(aTable);

end;



constructor TSQLRecord.CreateAndFillPrepare(aClient: TSQLRest;

  const FormatSQLWhere: RawUTF8; const BoundsSQLWhere: array of const;

  const aCustomFieldsCSV: RawUTF8='');

var where: RawUTF8;

begin

  where := FormatUTF8(FormatSQLWhere,[],BoundsSQLWhere);

  CreateAndFillPrepare(aClient,where,aCustomFieldsCSV);

end;



constructor TSQLRecord.CreateAndFillPrepare(aClient: TSQLRest;

  const FormatSQLWhere: RawUTF8; const ParamsSQLWhere,

  BoundsSQLWhere: array of const; const aCustomFieldsCSV: RawUTF8);

var where: RawUTF8;

begin

  where := FormatUTF8(FormatSQLWhere,ParamsSQLWhere,BoundsSQLWhere);

  CreateAndFillPrepare(aClient,where,aCustomFieldsCSV);

end;



constructor TSQLRecord.CreateAndFillPrepare(aClient: TSQLRest;

  const aIDs: array of Int64; const aCustomFieldsCSV: RawUTF8='');

begin

  Create;

  FillPrepare(aClient,aIDs,aCustomFieldsCSV);

end;



constructor TSQLRecord.CreateAndFillPrepare(const aJSON: RawUTF8);

var aTable: TSQLTable;

begin

  Create;

  aTable := TSQLTableJSON.CreateFromTables([RecordClass],'',aJSON);

  aTable.OwnerMustFree := true;

  FillPrepare(aTable);

end;



constructor TSQLRecord.CreateAndFillPrepareJoined(aClient: TSQLRest;

  const aFormatSQLJoin: RawUTF8; const aParamsSQLJoin, aBoundsSQLJoin: array of const);

var i,n: integer;

    props: TSQLModelRecordProperties;

    T: TSQLTableJSON;

    instance: TSQLRecord;

    SQL: RawUTF8;

begin

  Create;

  props := aClient.Model.Props[PSQLRecordClass(Self)^];

  if props.props.JoinedFields=nil then

    raise EORMException.CreateUTF8('No nested TSQLRecord to JOIN in %',[self]);

  SQL := props.SQL.SelectAllJoined;

  if aFormatSQLJoin<>'' then

    SQL := SQL+FormatUTF8(SQLFromWhere(aFormatSQLJoin),aParamsSQLJoin,aBoundsSQLJoin);

  T := aClient.ExecuteList(props.props.JoinedFieldsTable,SQL);

  if T=nil then

    exit;

  fFill := TSQLRecordFill.Create;

  fFill.fJoinedFields := True;

  fFill.fTable := T;

  fFill.fTable.OwnerMustFree := true;

  n := 0;

  with props.props do begin // follow SQL.SelectAllJoined columns

    fFill.AddMapSimpleFields(Self,SimpleFields,n);

    for i := 1 to high(JoinedFieldsTable) do begin

      instance := JoinedFieldsTable[i].Create;

      JoinedFields[i-1].SetInstance(self,instance);

      fFill.AddMapSimpleFields(instance,JoinedFieldsTable[i].RecordProps.SimpleFields,n);

    end;

  end;

  fFill.fFillCurrentRow := 1; // point to first data row (0 is field names)

end;



constructor TSQLRecord.CreateJoined(aClient: TSQLRest; aID: TID);

begin

  CreateAndFillPrepareJoined(aClient,'%.RowID=?',[RecordProps.SQLTableName],[aID]);

  FillOne;

end;



constructor TSQLRecord.CreateAndFillPrepareMany(aClient: TSQLRest;

  const aFormatSQLJoin: RawUTF8; const aParamsSQLJoin, aBoundsSQLJoin: array of const);

begin

  Create;

  if Length(RecordProps.ManyFields)=0 then

    raise EModelException.CreateUTF8(

      '%.CreateAndFillPrepareMany() with no many-to-many fields',[self]);

  if not FillPrepareMany(aClient,aFormatSQLJoin,aParamsSQLJoin,aBoundsSQLJoin) then

    raise EModelException.CreateUTF8(

      '%.CreateAndFillPrepareMany(): FillPrepareMany() failure',[self]);

end;



function TSQLRecord.EnginePrepareMany(aClient: TSQLRest; const aFormatSQLJoin: RawUTF8;

  const aParamsSQLJoin, aBoundsSQLJoin: array of const;

  out ObjectsClass: TSQLRecordClassDynArray; out SQL: RawUTF8): RawUTF8;

var aSQLFields, aSQLFrom, aSQLWhere, aSQLJoin: RawUTF8;

    aField: string[3];

    aMany: RawUTF8;

    f, n, i, SQLFieldsCount: Integer;

    Props: TSQLRecordProperties;

    SQLFields: array of record

      SQL: string[3];

      Prop: TSQLPropInfo;

      Instance: TSQLRecord;

    end;

    M: TSQLRecordMany;

    D: TSQLRecord;

    J,JBeg: PUTF8Char;

    Objects: array of TSQLRecord;



  function AddField(aProp: TSQLPropInfo): Boolean;

  begin

    if SQLFieldsCount>=MAX_SQLFIELDS then

      result := false else

      with SQLFields[SQLFieldsCount] do begin

        SQL := aField;

        Prop := aProp;

        Instance := Objects[f];

        inc(SQLFieldsCount);

        result := true;

      end;

  end;

  function ProcessField(var P: PUTF8Char): RawUTF8;

  var B: PUTF8Char;

      field: TSQLPropInfo;

      i: integer;

      M: TSQLRecordMany;

      aManyField: string[63];

    function GetManyField(F: PUTF8Char): boolean;

    var B: PUTF8Char;

    begin

      result := true;

      B := F;

      while ord(F^) in IsIdentifier do inc(F); // go to end of sub-field name

      if B=F then begin

        result := false;

        exit;

      end;

      dec(B,2); // space for 'C.'

      SetString(aManyField,B,F-B);

      aManyField[2] := '.';

      P := F;

    end;

  begin

    B := P;

    while ord(P^) in IsIdentifier do inc(P); // go to end of field name

    SetString(result,B,P-B);

    if (result='') or IdemPropNameU(result,'AND') or IdemPropNameU(result,'OR') or

       IdemPropNameU(result,'LIKE') or IdemPropNameU(result,'NOT') or

       IdemPropNameU(result,'NULL') then

      exit;

    if not IsRowID(pointer(result)) then begin

      i := Props.Fields.IndexByName(result);

      if i<0 then

        exit;

      field := Props.Fields.List[i];

      if field.SQLFieldType=sftMany then begin

        M := TSQLPropInfoRTTIInstance(field).GetInstance(self) as TSQLRecordMany;

        for i := 0 to n-1 do

        if Objects[i*2+1]=M then begin

          if IdemPChar(P,'.DEST.') then begin // special case of Many.Dest.*

            if GetManyField(P+6) then begin

              aManyField[1] := AnsiChar(i*2+67);

              result := RawUTF8(aManyField);

              exit; // Categories.Dest.Name=? -> C.Name=?

            end;

          end else

          if (P^='.') and GetManyField(P+1) then begin

            aManyField[1] := AnsiChar(i*2+66);

            result := RawUTF8(aManyField);

            exit;  // Categories.Kind=? -> CC.Kind=?

          end;

        end;

        exit;

      end;

    end;

    result := 'A.'+result; // Owner=? -> A.Owner=?

  end;

begin

  result := '';

  FillClose; // so that no further FillOne will work

  if (self=nil) or (aClient=nil) then

    exit;

  // reset TSQLRecordFill object

  if fFill=nil then

    fFill := TSQLRecordFill.Create else

    fFill.UnMap;

  // compute generic joined SQL statement and initialize Objects*[]+SQLFields[]

  SetLength(SQLFields,MAX_SQLFIELDS);

  Props := RecordProps;

  n := Length(Props.ManyFields);

  if n=0 then

    exit;

  SetLength(Objects,n*2+1);

  SetLength(ObjectsClass,n*2+1);

  Objects[0] := self;

  ObjectsClass[0] := PSQLRecordClass(self)^;

  SetLength(fFill.fTableMapRecordManyInstances,n);  // fFill.UnMap will release memory

  aSQLWhere := '';  // alf: to circumvent FPC issues

  aSQLFields := '';

  aSQLFrom := '';

  for f := 0 to n-1 do begin

    M := TSQLRecordMany(Props.ManyFields[f].GetInstance(self));

    if M=nil then

      raise EORMException.CreateUTF8('%.Create should have created %:% for EnginePrepareMany',

        [self,Props.ManyFields[f].Name,Props.ManyFields[f].ObjectClass]);

    fFill.fTableMapRecordManyInstances[f] := M;

    Objects[f*2+1] := M;

    ObjectsClass[f*2+1] := PSQLRecordClass(M)^;

    with M.RecordProps do begin

      if (fRecordManySourceProp.ObjectClass<>PClass(self)^) or

         (fRecordManyDestProp.ObjectClass=nil) then

        raise EORMException.CreateUTF8('%.EnginePrepareMany %:% mismatch',

          [self,Props.ManyFields[f].Name,Props.ManyFields[f].ObjectClass]);

      ObjectsClass[f*2+2] := TSQLRecordClass(fRecordManyDestProp.ObjectClass);

      D := TSQLRecordClass(fRecordManyDestProp.ObjectClass).Create;

      // let TSQLRecordMany.Source and Dest point to real instances

      M.fSourceID^ := PtrInt(self);

      M.fDestID^ := PtrInt(D);

    end;

    Objects[f*2+2] := TSQLRecord(M.fDestID^);

    if Props.fSQLFillPrepareMany='' then begin

      aMany := AnsiChar(f*2+66); // Many=B,D,F...

      if aSQLWhere<>'' then

        aSQLWhere := aSQLWhere+' and ';

      aSQLWhere := FormatUTF8('%%.Source=A.RowID and %.Dest=%.RowID',

        [aSQLWhere,aMany,aMany,AnsiChar(f*2+67){Dest=C,E,G..}]);

    end;

  end;

  SQLFieldsCount := 0;

  aField := 'A00';

  for f := 0 to high(ObjectsClass) do

    with ObjectsClass[f].RecordProps do begin

      PWord(@aField[2])^ := ord('I')+ord('D')shl 8;

      if not AddField(nil) then

        Exit; // try to add the ID field

      if Props.fSQLFillPrepareMany='' then begin

        if aSQLFields<>'' then

          aSQLFields := aSQLFields+',';

          aSQLFields := FormatUTF8('%%.RowID %',[aSQLFields,aField[1],aField]);

      end;

      for i := 0 to high(SimpleFields) do

      with SimpleFields[i] do begin

        if (f and 1=0) {self/dest} or

           not(IdemPropNameU(Name,'SOURCE') or

               IdemPropNameU(Name,'DEST')) {many} then begin

          PWord(@aField[2])^ := TwoDigitLookupW[i];

          if not AddField(SimpleFields[i]) then

            Exit; // try to add this simple field

          if Props.fSQLFillPrepareMany='' then

            aSQLFields := FormatUTF8('%,%.% %',[aSQLFields,aField[1],Name,aField]);

        end;

      end;

      if Props.fSQLFillPrepareMany='' then begin

        if aSQLFrom<>'' then

          aSQLFrom := aSQLFrom+',';

        aSQLFrom := aSQLFrom+SQLTableName+' '+ToUTF8(aField[1]);

      end;

      inc(aField[1]);

    end;

  if Props.fSQLFillPrepareMany<>'' then

    SQL := Props.fSQLFillPrepareMany else begin

    FormatUTF8('select % from % where %',[aSQLFields,aSQLFrom,aSQLWhere],SQL);

    Props.fSQLFillPrepareMany := SQL;

  end;

  // process aFormatSQLJoin,aParamsSQLJoin and aBoundsSQLJoin parameters

  if aFormatSQLJoin<>'' then begin

    aSQLWhere := '';

    aSQLJoin := FormatUTF8(aFormatSQLJoin, aParamsSQLJoin);

    JBeg := pointer(aSQLJoin);

    repeat

      J := JBeg;

      while not (ord(J^) in IsIdentifier) do begin

        case J^ of

        '"':  repeat inc(J) until J^ in [#0,'"'];

        '''': repeat inc(J) until J^ in [#0,''''];

        end;

        if J^=#0 then break;

        inc(J);

      end;

      if J<>JBeg then begin // append ' ',')'..

        SetString(aSQLFrom,PAnsiChar(JBeg),J-JBeg);

        aSQLWhere := aSQLWhere+aSQLFrom;

        JBeg := J;

      end;

      if J^=#0 then break;

      aSQLWhere := aSQLWhere+ProcessField(JBeg);

    until JBeg^=#0;

    SQL := SQL+' and ('+FormatUTF8(aSQLWhere,[],aBoundsSQLJoin)+')';

  end;

  // execute SQL statement and retrieve the matching data

  result := aClient.EngineList(SQL);

  if result<>'' then // prepare Fill mapping on success - see FillPrepareMany()

    for i := 0 to SQLFieldsCount-1 do

      with SQLFields[i] do

        fFill.AddMap(Instance,Prop,i);

end;



function TSQLRecord.FillPrepareMany(aClient: TSQLRest;

  const aFormatSQLJoin: RawUTF8; const aParamsSQLJoin, aBoundsSQLJoin: array of const): boolean;

var JSON,SQL: RawUTF8;

    ObjectsClass: TSQLRecordClassDynArray;

    T: TSQLTable;

begin

  result := false;

  JSON := EnginePrepareMany(aClient,aFormatSQLJoin,aParamsSQLJoin,aBoundsSQLJoin,

    ObjectsClass,SQL);

  if JSON='' then

    exit;

  T := TSQLTableJSON.CreateFromTables(ObjectsClass,SQL,JSON);

  if (T=nil) or (T.fResults=nil) then begin

    T.Free;

    exit;

  end;

{  assert(T.FieldCount=SQLFieldsCount);

  for i := 0 to SQLFieldsCount-1 do

    assert(IdemPropName(SQLFields[i].SQL,T.fResults[i],StrLen(T.fResults[i]))); }

  fFill.fTable := T;

  T.OwnerMustFree := true;

  fFill.fFillCurrentRow := 1; // point to first data row (0 is field names)

  result := true;

end;



function TSQLRecord.GetID: TID;

begin

  {$ifdef MSWINDOWS}

  if PtrUInt(self)<PtrUInt(SystemInfo.lpMinimumApplicationAddress) then

    // was called from a TSQLRecord property (sftID type)

    // (will return 0 if current instance is nil)

    result := PtrUInt(self) else

    result := fID;

    // was called from a real TSQLRecord instance

  {$else}

  if PtrUInt(self)<$100000 then // rough estimation, but works in practice

    result := PtrUInt(self) else

  try

    result := fID;

  except

    result := PtrUInt(self);

  end;

  {$endif}

end;



function TSQLRecord.GetIDAsPointer: pointer;

begin

  {$ifdef MSWINDOWS}

  if PtrUInt(self)<PtrUInt(SystemInfo.lpMinimumApplicationAddress) then

    // was called from a TSQLRecord property (sftID type)

    // (will return 0 if current instance is nil)

    result := self else

    // was called from a real TSQLRecord instance

    {$ifndef CPU64}

    if fID>MaxInt then

      raise EORMException.CreateUTF8('%.GetIDAsPointer is storing ID=%, which '+

        'cannot be stored in a pointer/TSQLRecord 32 bit instance: use '+

        'a TID/T*ID published field for 64-bit IDs',[self,fID]) else

    {$endif}

      result := pointer(fID);

  {$else}

  if PtrUInt(self)<$100000 then // rough estimation, but works in practice

    result := self else

  try

    result := pointer(fID);

  except

    result := self;

  end;

  {$endif}

end;



class procedure TSQLRecord.InternalRegisterCustomProperties(Props: TSQLRecordProperties);

begin // do nothing by default

end;



class procedure TSQLRecord.InternalDefineModel(Props: TSQLRecordProperties);

begin // do nothing by default

end;



function TSQLRecord.GetHasBlob: boolean;

begin

  if Self=nil then

    result := false else

    result := RecordProps.BlobFields<>nil;

end;



function TSQLRecord.GetSimpleFieldCount: integer;

begin

  if Self=nil then

    result := 0 else

    result := length(RecordProps.SimpleFields);

end;



function TSQLRecord.GetFillCurrentRow: integer;

begin

  if (self=nil) or (fFill=nil) then

    result := 0 else

    result := fFill.FillCurrentRow;

end;



function TSQLRecord.GetTable: TSQLTable;

begin

  if (self=nil) or (fFill=nil) then

    result := nil else

    result := fFill.Table;

end;



function TSQLRecord.GetFieldValue(const PropName: RawUTF8): RawUTF8;

var P: TSQLPropInfo;

begin

  result := '';

  if self=nil then

    exit;

  P := RecordProps.Fields.ByName(pointer(PropName));

  if P<>nil then

    P.GetValueVar(self,False,result,nil);

end;



procedure TSQLRecord.SetFieldValue(const PropName: RawUTF8; Value: PUTF8Char);

var P: TSQLPropInfo;

begin

  if self=nil then

    exit;

  P := RecordProps.Fields.ByName(pointer(PropName));

  if P<>nil then

    P.SetValue(self,Value,false);

end;



{$ifndef NOVARIANTS}



function TSQLRecord.GetAsDocVariant(withID: boolean;

  const withFields: TSQLFieldBits; options: PDocVariantOptions): variant;

begin

  GetAsDocVariant(withID,withFields,result,options);

end;



procedure TSQLRecord.GetAsDocVariant(withID: boolean;

  const withFields: TSQLFieldBits; var result: variant; options: PDocVariantOptions);

var f: integer;

    Fields: TSQLPropInfoList;

    doc: TDocVariantData absolute result;

begin

  VarClear(result);

  if self=nil then

    exit;

  Fields := RecordProps.Fields;

  doc.InitFast(Fields.Count+1,dvObject);

  if options<>nil then // force options

    PDocVariantData(@result)^.Options := options^;

  if withID then

    doc.Values[doc.InternalAdd('RowID')] := fID;

  for f := 0 to Fields.Count-1 do

  if f in withFields then

    Fields.List[f].GetVariant(self,doc.Values[doc.InternalAdd(Fields.List[f].Name)]);

end;



function TSQLRecord.GetSimpleFieldsAsDocVariant(withID: boolean;

  options: PDocVariantOptions): variant;

begin

  if self=nil then

    VarClear(result) else

    GetAsDocVariant(withID,RecordProps.SimpleFieldsBits[soSelect],result,options);

end;



function TSQLRecord.GetFieldVariant(const PropName: string): Variant;

var P: TSQLPropInfo;

begin

  if self=nil then

    P := nil else

    P := RecordProps.Fields.ByRawUTF8Name({$ifdef UNICODE}StringToUTF8{$endif}(PropName));

  if P=nil then

    VarClear(result) else

    P.GetVariant(self,result);

end;



procedure TSQLRecord.SetFieldVariant(const PropName: string;

  const Source: Variant);

var P: TSQLPropInfo;

begin

  if self=nil then

    P := nil else

    P := RecordProps.Fields.ByRawUTF8Name({$ifdef UNICODE}StringToUTF8{$endif}(PropName));

  if P<>nil then

    P.SetVariant(self,Source);

end;



{$endif NOVARIANTS}



function PropsCreate(aTable: TSQLRecordClass): TSQLRecordProperties;

var PVMT: pointer;

begin // private sub function makes the code faster in most case

  if not aTable.InheritsFrom(TSQLRecord) then begin

    result := nil; // invalid call

    exit;

  end;

  // create the properties information from RTTI

  result := TSQLRecordProperties.Create(aTable);

  // store the TSQLRecordProperties instance into AutoTable unused VMT entry

  PVMT := pointer(PtrInt(aTable)+vmtAutoTable);

  if PPointer(PVMT)^<>nil then

    raise ESynException.CreateUTF8('%.AutoTable VMT entry already set',[aTable]);

  PatchCodePtrUInt(PVMT,PtrUInt(result),true); // LeaveUnprotected=true

  // register to the internal garbage collection (avoid memory leak)

  GarbageCollectorFreeAndNil(PVMT^,result); // set to nil at finalization

  // overriden method may use RecordProps -> do it after the VMT is set

  aTable.InternalDefineModel(result);

end;



// since "var class" are not available in Delphi 6-7, and is inherited by

// the children classes under latest Delphi versions (i.e. the "var class" is

// shared by all inherited classes, whereas we want one var per class), we reused

// one of the unused magic VMT slots (i.e. the one for automated methods,

// AutoTable, a relic from Delphi 2 that is generally not used anymore) - see

// http://hallvards.blogspot.com/2007/05/hack17-virtual-class-variables-part-ii.html



{$ifdef FPC_OR_PUREPASCAL}

class function TSQLRecord.RecordProps: TSQLRecordProperties;

begin

  if Self<>nil then begin

    result := PPointer(PtrInt(Self)+vmtAutoTable)^;

    if result=nil then

      result := PropsCreate(self);

  end else

    result := nil;

end;

{$else}

class function TSQLRecord.RecordProps: TSQLRecordProperties;

asm

  test eax,eax

  jz @null

  mov edx,[eax+vmtAutoTable]

  test edx,edx

  jz PropsCreate

  mov eax,edx

@null:

end;

{$endif}



function TSQLRecord.Filter(const aFields: TSQLFieldBits): boolean;

var f, i: integer;

    Value, Old: RawUTF8;

begin

  result := IsZero(aFields);

  if (self=nil) or result then

    // avoid GPF and handle case if no field was selected

    exit;

  with RecordProps do

  if Filters=nil then

    // no filter set yet -> process OK

    result := true else begin

    for f := 0 to Fields.Count-1 do

      if (Fields.List[f].SQLFieldType in COPIABLE_FIELDS) then

        for i := 0 to length(Filters[f])-1 do

        if Filters[f,i].InheritsFrom(TSynFilter) then begin

          Fields.List[f].GetValueVar(self,false,Value,nil);

          Old := Value;

          TSynFilter(Filters[f,i]).Process(f,Value);

          if Old<>Value then

            // value was changed -> store modified

            Fields.List[f].SetValueVar(self,Value,false);

        end;

  end;

end;



function TSQLRecord.Filter(const aFields: array of RawUTF8): boolean;

var F: TSQLFieldBits;

begin

  if RecordProps.FieldBitsFromRawUTF8(aFields,F) then

    // must always call the virtual Filter() method

    result := Filter(F) else

    result := false;

end;



class function TSQLRecord.SQLTableName: RawUTF8;

begin

  if self=nil then

    result := '' else

    result := RecordProps.SQLTableName;

end;



class function TSQLRecord.AutoFree(varClassPairs: array of pointer): IAutoFree;

var n,i: integer;

begin

  n := length(varClassPairs);

  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 // convert TSQLRecordClass into TSQLRecord instances

    varClassPairs[i*2+1] := TSQLRecordClass(varClassPairs[i*2+1]).Create;

  result := TAutoFree.Create(varClassPairs);

end;



class function TSQLRecord.AutoFree(var localVariable): IAutoFree;

begin

  result := TAutoFree.Create(localVariable,Create);

end;



class function TSQLRecord.AutoFree(var localVariable; Rest: TSQLRest; ID: TID): IAutoFree;

begin

  result := TAutoFree.Create(localVariable,Create(Rest,ID));

end;



class procedure TSQLRecord.AddFilterOrValidate(const aFieldName: RawUTF8;

  aFilter: TSynFilterOrValidate);

begin

  RecordProps.AddFilterOrValidate(aFieldName,aFilter);

end;



class procedure TSQLRecord.AddFilterNotVoidText(const aFieldNames: array of RawUTF8);

var i,f: Integer;

begin

  with RecordProps do

    for i := 0 to high(aFieldNames) do begin

      f := Fields.IndexByNameOrExcept(aFieldNames[i]);

      AddFilterOrValidate(f,TSynFilterTrim.Create);

      AddFilterOrValidate(f,TSynValidateNonVoidText.Create);

    end;

end;



class procedure TSQLRecord.AddFilterNotVoidAllTextFields;

var f: Integer;

begin

  with RecordProps,Fields do

    for f := 0 to Count-1 do

      if List[f].SQLFieldType in RAWTEXT_FIELDS then begin

        AddFilterOrValidate(f,TSynFilterTrim.Create);

        AddFilterOrValidate(f,TSynValidateNonVoidText.Create);

      end;

end;



function TSQLRecord.Validate(aRest: TSQLRest; const aFields: TSQLFieldBits;

  aInvalidFieldIndex: PInteger; aValidator: PSynValidate): string;

var f, i: integer;

    Value: RawUTF8;

    Validate: TSynValidate;

    ValidateRest: TSynValidateRest absolute Validate;

    wasTSynValidateRest: boolean;

begin

  result := '';

  if (self=nil) or IsZero(aFields) then

    // avoid GPF and handle case if no field was selected

    exit;

  Value := '';  // alf: to circumvent FPC issues

  with RecordProps do

  if Filters<>nil then

  for f := 0 to Fields.Count-1 do

  if Fields.List[f].SQLFieldType in COPIABLE_FIELDS then begin

    for i := 0 to length(Filters[f])-1 do begin

      Validate := TSynValidate(Filters[f,i]);

      if Validate.InheritsFrom(TSynValidate) then begin

        if Value='' then

          Fields.List[f].GetValueVar(self,false,Value,nil);

        wasTSynValidateRest := Validate.InheritsFrom(TSynValidateRest);

        if wasTSynValidateRest then begin // set additional parameters

          ValidateRest.fProcessRec := self;

          ValidateRest.fProcessRest := aRest;

        end;

        try

          if not Validate.Process(f,Value,result) then begin

            // TSynValidate process failed -> notify caller

            if aInvalidFieldIndex<>nil then

              aInvalidFieldIndex^ := f;

            if aValidator<>nil then

              aValidator^ := Validate;

            if result='' then

              // no custom message -> show a default message

              result := format(sValidationFailed,[

                GetCaptionFromClass(Validate.ClassType)]);

            exit;

          end;

        finally

          if wasTSynValidateRest then begin // reset additional parameters

            ValidateRest.fProcessRec := nil;

            ValidateRest.fProcessRest := nil;

          end;

        end;

      end;

    end;

    Value := '';

  end;

end;



function TSQLRecord.Validate(aRest: TSQLRest; const aFields: array of RawUTF8;

  aInvalidFieldIndex: PInteger; aValidator: PSynValidate): string;

var F: TSQLFieldBits;

begin

  if RecordProps.FieldBitsFromRawUTF8(aFields,F) then

    // must always call the virtual Validate() method

    result := Validate(aRest,F,aInvalidFieldIndex,aValidator) else

    result := '';

end;



function TSQLRecord.FilterAndValidate(aRest: TSQLRest; out aErrorMessage: string;

  const aFields: TSQLFieldBits; aValidator: PSynValidate): boolean;

var invalidField: Integer;

begin

  Filter(aFields);

  aErrorMessage := Validate(aRest,aFields,@invalidField,aValidator);

  if aErrorMessage='' then

    result := true else begin

    if invalidField>=0 then

      aErrorMessage := Format('"%s": %s',

        [RecordProps.Fields.List[invalidField].GetNameDisplay,aErrorMessage]);

    result := false;

  end;

end;



function TSQLRecord.FilterAndValidate(aRest: TSQLRest;

  const aFields: TSQLFieldBits; aValidator: PSynValidate): RawUTF8;

var msg: string;

begin

  if FilterAndValidate(aRest,msg,aFields,aValidator) then

    result := '' else

    StringToUTF8(msg,result);

end;



function TSQLRecord.DynArray(const DynArrayFieldName: RawUTF8): TDynArray;

var F: integer;

begin

  with RecordProps do

    for F := 0 to high(DynArrayFields) do

      with DynArrayFields[F] do

      if IdemPropNameU(Name,DynArrayFieldName) then begin

        result := GetDynArray(self);

        exit;

      end;

  result.Void;

end;



function TSQLRecord.DynArray(DynArrayFieldIndex: integer): TDynArray;

var F: integer;

begin

  if DynArrayFieldIndex>0 then

    with RecordProps do

      for F := 0 to high(DynArrayFields) do

        with DynArrayFields[F] do

        if DynArrayIndex=DynArrayFieldIndex then begin

          result := GetDynArray(self);

          exit;

        end;

  result.Void;

end;



procedure TSQLRecord.ComputeFieldsBeforeWrite(aRest: TSQLRest; aOccasion: TSQLEvent);

var F: integer;

    types: TSQLFieldTypes;

    i64: Int64;

begin

  if (self<>nil) and (aRest<>nil) then

    with RecordProps do begin

      integer(types) := 0;

      if sftModTime in HasTypeFields then

        include(types,sftModTime);

      if (sftCreateTime in HasTypeFields) and (aOccasion=seAdd) then

        include(types,sftCreateTime);

      if integer(types)<>0 then begin

        i64 := aRest.ServerTimeStamp;

        for F := 0 to Fields.Count-1 do

        with TSQLPropInfoRTTIInt64(Fields.List[f]) do

        if SQLFieldType in types then

          fPropInfo.SetInt64Prop(Self,i64);

      end;

      if sftSessionUserID in HasTypeFields then begin

        i64 := aRest.GetCurrentSessionUserID;

        if i64<>0 then 

          for F := 0 to Fields.Count-1 do

          with TSQLPropInfoRTTIInt64(Fields.List[f]) do

          if SQLFieldType=sftSessionUserID then

            fPropInfo.SetInt64Prop(Self,i64);

      end;

    end;

end;





{ TSQLRecordPropertiesMapping }



procedure TSQLRecordPropertiesMapping.Init(Table: TSQLRecordClass;

  const MappedTableName: RawUTF8; MappedConnection: TObject;

  AutoComputeSQL: boolean);

begin

  fProps := Table.RecordProps;

  if MappedTableName='' then

    fTableName := fProps.SQLTableName else

    fTableName := MappedTableName;

  fConnectionProperties := MappedConnection;

  fRowIDFieldName := 'ID';

  fProps.Fields.NamesToRawUTF8DynArray(fFieldNames);

  FillcharFast(fFieldNamesMatchInternal,sizeof(fFieldNamesMatchInternal),255);

  fAutoComputeSQL := AutoComputeSQL;

  fMappingVersion := 1;

  if fAutoComputeSQL then

    ComputeSQL;

end;



function TSQLRecordPropertiesMapping.MapField(

  const InternalName, ExternalName: RawUTF8): PSQLRecordPropertiesMapping;

begin

  MapFields([InternalName,ExternalName]);

  result := @self;

end;



function TSQLRecordPropertiesMapping.MapFields(

  const InternalExternalPairs: array of RawUTF8): PSQLRecordPropertiesMapping;

var i,int: Integer;

begin

  for i := 0 to (length(InternalExternalPairs) shr 1)-1 do begin

    int := fProps.Fields.IndexByNameOrExcept(InternalExternalPairs[i*2]);

    if int<0 then begin

      fRowIDFieldName := InternalExternalPairs[i*2+1];

      if IdemPropNameU(fRowIDFieldName,'ID') then

        include(fFieldNamesMatchInternal,0) else     // [0]=ID

        exclude(fFieldNamesMatchInternal,0);

    end else begin

      fFieldNames[int] := InternalExternalPairs[i*2+1];

      if IdemPropNameU(fFieldNames[int],fProps.Fields.List[int].Name) then

        include(fFieldNamesMatchInternal,int+1) else // [0]=ID  [1..n]=fields[i-1]

        exclude(fFieldNamesMatchInternal,int+1);

    end;

  end;

  inc(fMappingVersion);

  if fAutoComputeSQL then

    ComputeSQL;

  result := @self;

end;



function TSQLRecordPropertiesMapping.MapAutoKeywordFields:

  PSQLRecordPropertiesMapping;

begin

  if @self<>nil then

    include(fOptions,rpmAutoMapKeywordFields);

  result := @self;

end;



function TSQLRecordPropertiesMapping.SetOptions(

  aOptions: TSQLRecordPropertiesMappingOptions): PSQLRecordPropertiesMapping;

begin

  if @self<>nil then

    fOptions := aOptions;

  result := @self;

end;



procedure TSQLRecordPropertiesMapping.ComputeSQL;

  type // similar to TSQLModelRecordProperties.Create()/SetKind()

    TContent = (TableSimpleFields, UpdateSimple, UpdateSetAll, InsertAll);

  procedure SetSQL(W: TTextWriter;

    withID, withTableName: boolean; var result: RawUTF8;

    content: TContent=TableSimpleFields);

  var f: integer;

  begin

    W.CancelAll;

    if withID and (content=TableSimpleFields) then begin

      if withTableName then

        W.AddStrings([TableName,'.']);

      W.AddString(RowIDFieldName);

      if 0 in FieldNamesMatchInternal then

        W.Add(',') else

        W.AddShort(' as ID,');

    end;

    with fProps do

    for f := 0 to Fields.Count-1 do

    with Fields.List[f] do

    if SQLFieldType in COPIABLE_FIELDS then // sftMany fields do not exist

      case content of

      TableSimpleFields:

        if f in SimpleFieldsBits[soSelect] then begin

          if withTableName then

            W.AddStrings([TableName,'.']);

          W.AddString(FieldNames[f]);

          if not(f+1 in FieldNamesMatchInternal) then

            W.AddStrings([' as ',Name]); // to get expected JSON column name

          W.Add(',');

        end;

      UpdateSimple:

        if f in SimpleFieldsBits[soSelect] then

          W.AddStrings([FieldNames[f],'=?,']);

      UpdateSetAll:

        W.AddStrings([FieldNames[f],'=?,']);

      InsertAll:

        W.AddStrings([FieldNames[f],',']);

      end;

    W.CancelLastComma;

    W.SetText(result);

  end;

var W: TTextWriter;

begin

  W := TTextWriter.CreateOwnedStream(1024);

  try // SQL.TableSimpleFields[withID: boolean; withTableName: boolean]

    SetSQL(W,false,false,fSQL.TableSimpleFields[false,false]);

    SetSQL(W,false,true,fSQL.TableSimpleFields[false,true]);

    SetSQL(W,true,false,fSQL.TableSimpleFields[true,false]);

    SetSQL(W,true,true,fSQL.TableSimpleFields[true,true]);

    // SQL.SelectAll: array[withRowID: boolean]

    fSQL.SelectAllWithRowID := SQLFromSelect(TableName,'*','',

      fSQL.TableSimpleFields[true,false]);

    fSQL.SelectAllWithID := fSQL.SelectAllWithRowID;

    SetSQL(W,false,false,fSQL.UpdateSetSimple,UpdateSimple);

    SetSQL(W,false,false,fSQL.UpdateSetAll,UpdateSetAll);

    SetSQL(W,false,false,fSQL.InsertSet,InsertAll);

  finally

    W.Free;

  end;

end;



function TSQLRecordPropertiesMapping.InternalToExternal(const FieldName: RawUTF8): RawUTF8;

var int: integer;

begin

  int := fProps.Fields.IndexByNameOrExcept(FieldName);

  if int<0 then

    result := RowIDFieldName else

    result := fFieldNames[int];

end;



function TSQLRecordPropertiesMapping.InternalCSVToExternalCSV(

  const CSVFieldNames, Sep, SepEnd: RawUTF8): RawUTF8;

var IntFields,ExtFields: TRawUTF8DynArray;

begin

  CSVToRawUTF8DynArray(CSVFieldNames,Sep,SepEnd,IntFields);

  InternalToExternalDynArray(IntFields,ExtFields);

  result := RawUTF8ArrayToCSV(ExtFields,Sep)+SepEnd;

end;



procedure TSQLRecordPropertiesMapping.InternalToExternalDynArray(

  const IntFieldNames: array of RawUTF8; out result: TRawUTF8DynArray;

  IntFieldIndex: PIntegerDynArray);

var i,n,ndx: integer;

begin

  n := length(IntFieldNames);

  SetLength(result,n);

  if IntFieldIndex<>nil then

    SetLength(IntFieldIndex^,n);

  for i := 0 to n-1 do begin

    ndx := fProps.Fields.IndexByNameOrExcept(IntFieldNames[i]);

    if IntFieldIndex<>nil then

      IntFieldIndex^[i] := ndx;

    if ndx<0 then

      result[i] := RowIDFieldName else

      result[i] := fFieldNames[ndx];

  end;

end;



function TSQLRecordPropertiesMapping.ExternalToInternalIndex(

  const ExtFieldName: RawUTF8): integer;

begin

  if IdemPropNameU(ExtFieldName,RowIDFieldName) then

    result := -1 else begin

    // search for customized field mapping

    for result := 0 to high(fFieldNames) do

      if IdemPropNameU(ExtFieldName,UnQuotedSQLSymbolName(fFieldNames[result])) then

        exit;

    result := -2; // indicates not found

  end;

end;



function TSQLRecordPropertiesMapping.ExternalToInternalOrNull(

  const ExtFieldName: RawUTF8): RawUTF8;

var i: integer;

begin

  i := ExternalToInternalIndex(ExtFieldName);

  if i=-1 then

    result := 'ID' else

  if i>=0 then

    result := fProps.Fields.List[i].Name else

    result := ''; // indicates not found

end;



function TSQLRecordPropertiesMapping.AppendFieldName(

  FieldIndex: Integer; var Text: RawUTF8): boolean;

begin

  result := false; // success

  if FieldIndex=VIRTUAL_TABLE_ROWID_COLUMN then

    Text := Text+RowIDFieldName else

  if cardinal(FieldIndex)>=cardinal(Length(FieldNames)) then

    result := true else // FieldIndex out of range

    Text := Text+FieldNames[FieldIndex];

end;



function TSQLRecordPropertiesMapping.FieldNameByIndex(FieldIndex: Integer): RawUTF8;

begin

  if FieldIndex=VIRTUAL_TABLE_ROWID_COLUMN then

    result := RowIDFieldName else

  if cardinal(FieldIndex)>=cardinal(Length(FieldNames)) then

    result := '' else // FieldIndex out of range

    result := FieldNames[FieldIndex];

end;





{ TSQLModelRecordProperties }



constructor TSQLModelRecordProperties.Create(aModel: TSQLModel;

  aTable: TSQLRecordClass; aKind: TSQLRecordVirtualKind);

var f: integer;

begin // similar to TSQLRecordPropertiesMapping.ComputeSQL

  fModel := aModel;

  fTableIndex := fModel.GetTableIndexExisting(aTable);

  fProps := aTable.RecordProps;

  SetKind(aKind);

  with Props do

    for f := 0 to Fields.Count-1 do

    with Fields.List[f] do

    if SQLFieldType in COPIABLE_FIELDS then begin // sftMany fields do not exist

      // pre-computation of SQL statements

      SQL.UpdateSetAll := SQL.UpdateSetAll+Name+'=?,';

      SQL.InsertSet := SQL.InsertSet+Name+',';

      if f in SimpleFieldsBits[soUpdate] then

        SQL.UpdateSetSimple := SQL.UpdateSetSimple+Name+'=?,';

      // filter + validation of unique fields, i.e. if marked as "stored false"

      if f in IsUniqueFieldsBits then begin

        // must trim() text value before storage, and validate for unicity

        if SQLFieldType in [sftUTF8Text,sftAnsiText] then

          AddFilterOrValidate(f,TSynFilterTrim.Create);

        // register unique field pre-validation

        AddFilterOrValidate(f,TSynValidateUniqueField.Create);

      end;

    end;

  SetLength(SQL.InsertSet,length(SQL.InsertSet)-1);

  SetLength(SQL.UpdateSetAll,length(SQL.UpdateSetAll)-1); // 'COL1=?,COL2=?'

  if SQL.UpdateSetSimple<>'' then

    SetLength(SQL.UpdateSetSimple,length(SQL.UpdateSetSimple)-1); // 'COL1=?,COL2=?'

  Props.InternalRegisterModel(aModel,aModel.GetTableIndexExisting(aTable),self);

end;



constructor TSQLModelRecordProperties.CreateFrom(aModel: TSQLModel;

  aSource: TSQLModelRecordProperties);

begin

  inherited Create;

  fModel := aModel;

  fTableIndex := aSource.fTableIndex;

  fFTSWithoutContentTableIndex := aSource.fFTSWithoutContentTableIndex;

  fFTSWithoutContentFields := aSource.fFTSWithoutContentFields;

  fProps := aSource.fProps;

  fKind := aSource.Kind;

  SQL := aSource.SQL;

  ExternalDB := aSource.ExternalDB;

  Props.InternalRegisterModel(fModel,fModel.GetTableIndexExisting(fProps.Table),self);

end;



procedure TSQLModelRecordProperties.SetKind(Value: TSQLRecordVirtualKind);

function IntSQLTableSimpleFields(withID, withTableName: boolean): RawUTF8;

const IDComma: array[TSQLRecordVirtualKind] of rawUTF8 =

  ('ID,','RowID,','RowID,','RowID,','RowID,','RowID,');

// rSQLite3, rFTS3, rFTS4, rRTree, rCustomForcedID, rCustomAutoID

var TableName: RawUTF8;

    i: integer;

begin

  if withTableName then

    TableName := Props.SQLTableName+'.'; // calc TableName once

  if withID then

    if withTableName then

      result := TableName+IDComma[Kind] else

      result := IDComma[Kind] else

    result := '';

  for i := 0 to high(Props.SimpleFields) do begin

    if withTableName then

      result := result+TableName;

    result := result+Props.SimpleFields[i].Name+','; // valid simple fields

  end;

  if result<>'' then

    SetLength(result,length(result)-1); // trim last ','

end;

begin

  fKind := Value;

  // SQL.TableSimpleFields[withID: boolean; withTableName: boolean]

  SQL.TableSimpleFields[false,false] := IntSQLTableSimpleFields(false,false);

  SQL.TableSimpleFields[false,true] := IntSQLTableSimpleFields(false,true);

  SQL.TableSimpleFields[true,false] := IntSQLTableSimpleFields(true,false);

  SQL.TableSimpleFields[true,true] := IntSQLTableSimpleFields(true,true);

  if Props.SQLTableSimpleFieldsNoRowID<>SQL.TableSimpleFields[false,false] then

    raise EModelException.CreateUTF8('SetKind(%)',[Props.Table]);

  SQL.SelectAllWithRowID := SQLFromSelectWhere('*','');

  SQL.SelectAllWithID := SQL.SelectAllWithRowID;

  if IdemPChar(PUTF8Char(pointer(SQL.SelectAllWithID))+7,'ROWID') then

    delete(SQL.SelectAllWithID,8,3); // 'SELECT RowID,..' -> 'SELECT ID,'

end;



function TSQLModelRecordProperties.SQLFromSelectWhere(

  const SelectFields, Where: RawUTF8): RawUTF8;

begin

  result := SQLFromSelect(Props.SQLTableName,SelectFields,Where,

    SQL.TableSimpleFields[true,false]);

end;



procedure TSQLModelRecordProperties.FTS4WithoutContent(ContentTable: TSQLRecordClass);

var i: integer;

    field: RawUTF8;

begin

  if Kind<>rFTS4 then

    raise EModelException.CreateUTF8('FTS4WithoutContent: % is not a FTS4 table',[Props.Table]);

  fFTSWithoutContentTableIndex := fModel.GetTableIndexExisting(ContentTable);

  for i := 0 to Props.Fields.Count-1 do begin

    field := Props.Fields.List[i].Name;

    if ContentTable.RecordProps.Fields.IndexByName(field)<0 then

      raise EModelException.CreateUTF8('FTS4WithoutContent: %.% is not a % field',

        [Props.Table,field,ContentTable]);

    fFTSWithoutContentFields := fFTSWithoutContentFields+',new.'+field;

  end;

  if fFTSWithoutContentFields='' then

    raise EModelException.CreateUTF8('FTS4WithoutContent: % has no field',[Props.Table]);

end;



function TSQLModelRecordProperties.GetProp(const PropName: RawUTF8): TSQLPropInfo;

begin

  if self<>nil then

    result := Props.Fields.ByName(pointer(PropName)) else

    result := nil;

end;





{ TSQLModel }



function TSQLModel.GetTableIndexSafe(aTable: TSQLRecordClass;

  RaiseExceptionIfNotExisting: boolean): integer;

begin

  for result := 0 to fTablesMax do // manual search: GetTableIndex() may fail

    if fTables[result]=aTable then

      exit;

  if RaiseExceptionIfNotExisting then

    raise EModelException.CreateUTF8('% must include %',[self,aTable]);

  result := -1;

end;



procedure TSQLModel.SetTableProps(aIndex: integer);

var j,f: integer;

    t: TSQLFieldType;

    Kind: TSQLRecordVirtualKind;

    Table: TSQLRecordClass;

    aTableName,aFieldName: RawUTF8;

    Props: TSQLModelRecordProperties;

    W: TTextWriter;



  procedure RegisterTableForRecordReference(aFieldType: TSQLPropInfo;

    aFieldTable: TClass);

  var R: integer;

  begin

    if (aFieldTable=nil) or not aFieldTable.InheritsFrom(TSQLRecord) then

      exit; // no associated table to track deletion

    R := length(fRecordReferences);

    SetLength(fRecordReferences,R+1);

    with fRecordReferences[R] do begin

      TableIndex := aIndex;

      FieldType := aFieldType;

      FieldTable := pointer(aFieldTable);

      FieldTableIndex := GetTableIndexSafe(FieldTable,false);

      if FieldTableIndex<0 then

        FieldTableIndex := -2; // allow lazy table index identification

      if aFieldType.InheritsFrom(TSQLPropInfoRTTIRecordReference) then

        CascadeDelete := TSQLPropInfoRTTIRecordReference(aFieldType).CascadeDelete;

    end;

  end;



begin

  if (cardinal(aIndex)>cardinal(fTablesMax)) or (fTableProps[aIndex]<>nil) then

    raise EModelException.Create('TSQLModel.SetTableProps');

  Table := fTables[aIndex];

  if Table.InheritsFrom(TSQLRecordFTS4) then

    Kind := rFTS4 else

  if Table.InheritsFrom(TSQLRecordFTS3) then

    Kind := rFTS3 else

  if Table.InheritsFrom(TSQLRecordVirtualTableForcedID) then

    Kind := rCustomForcedID else

  if Table.InheritsFrom(TSQLRecordRTree) then

    Kind := rRTree else

  if Table.InheritsFrom(TSQLRecordVirtual) then

    Kind := rCustomAutoID else

    Kind := rSQLite3;

  Props := TSQLModelRecordProperties.Create(self,Table,Kind);

  Props.Props.InternalRegisterModel(Self,aIndex,Props);

  for t := low(t) to high(t) do

    if fCustomCollationForAll[t]<>'' then

      Props.Props.SetCustomCollationForAll(t,fCustomCollationForAll[t]);

  fTableProps[aIndex] := Props;

  aTableName := Props.Props.SQLTableName;

  fSortedTablesName[aIndex] := aTableName;

  fSortedTablesNameIndex[aIndex] := aIndex;

  with Props.Props.Fields do

  for f := 0 to Count-1 do

    case List[f].SQLFieldType of

    sftRecord:

      RegisterTableForRecordReference(List[f],Table); // Table not used

    sftID:

      RegisterTableForRecordReference(

        List[f],(List[f] as TSQLPropInfoRTTIInstance).ObjectClass);

    sftTID:

      RegisterTableForRecordReference(

        List[f],(List[f] as TSQLPropInfoRTTITID).RecordClass);

    sftMany:

      GetTableIndexSafe(pointer((List[f] as TSQLPropInfoRTTIMany).ObjectClass),true);

    end;

  if Props.Props.JoinedFieldsTable<>nil then begin

    W := TTextWriter.CreateOwnedStream;

    try

      W.AddShort('SELECT ');

      // JoinedFieldsTable[0] is the class itself

      with Props.Props do begin

        W.Add('%.RowID as `%.RowID`,',[SQLTableName,SQLTableName]);

        for f := 0 to High(SimpleFields) do

          if SimpleFields[f].SQLFieldType<>sftID then

            W.Add('%.% as `%.%`,',[SQLTableName,SimpleFields[f].Name,

              SQLTableName,SimpleFields[f].Name]);

      end;

      // add JoinedFieldsTable[1..] fields

      for j := 1 to high(Props.Props.JoinedFieldsTable) do begin

        aFieldName := Props.Props.JoinedFields[j-1].Name;

        W.Add('%.RowID as `%.RowID`,',[aFieldName,aFieldName]);

        with Props.Props.JoinedFieldsTable[j].RecordProps do

        for f := 0 to High(SimpleFields) do

          if SimpleFields[f].SQLFieldType<>sftID then

            W.Add('%.% as `%.%`,',[aFieldName,SimpleFields[f].Name,

              aFieldName,SimpleFields[f].Name]);

      end;

      W.CancelLastComma;

      // add LEFT JOIN clause

      W.AddStrings([' FROM ',aTableName]);

      for j := 1 to high(Props.Props.JoinedFieldsTable) do begin

        aFieldName := Props.Props.JoinedFields[j-1].Name;

        with Props.Props.JoinedFieldsTable[j].RecordProps do

          W.Add(' LEFT JOIN % AS % ON %.%=%.RowID',[

            SQLTableName,aFieldName,aTableName,aFieldName,aFieldName]);

      end;

      W.SetText(Props.SQL.SelectAllJoined);

    finally

      W.Free;

    end;

  end;

end;



function TSQLModel.GetTableProps(aClass: TSQLRecordClass): TSQLModelRecordProperties;

begin

  result := fTableProps[GetTableIndexExisting(aClass)];

end;



function TSQLModel.AddTable(aTable: TSQLRecordClass;

  aTableIndexCreated: PInteger=nil): boolean;

var n: integer;

begin

  // first register for JSONToObject() and for TSQLPropInfoRTTITID.Create()

  TJSONSerializer.RegisterClassForJSON(aTable);

  // insert only once

  if GetTableIndex(aTable)>=0 then begin

    result := false;

    exit;

  end;

  // add to the model list

  inc(fTablesMax);

  n := fTablesMax+1;

  SetLength(fTables,n);

  SetLength(fSortedTablesName,n);

  SetLength(fSortedTablesNameIndex,n);

  SetLength(fTableProps,n);

  fTables[fTablesMax] := aTable;

  SetTableProps(fTablesMax);

  QuickSortRawUTF8(fSortedTablesName,fTablesMax+1,@fSortedTablesNameIndex,@StrIComp);

  if aTableIndexCreated<>nil then

    aTableIndexCreated^ := fTablesMax;

  result := true;

end;



function TSQLModel.AddTableInherited(aTable: TSQLRecordClass): pointer;

var ndx: integer;

begin

  ndx := GetTableIndexInheritsFrom(aTable);

  if ndx<0 then

    if not AddTable(aTable,@ndx) then

      raise EORMException.CreateUTF8('%.AddTableInherited(%)',[self,aTable]);

  result := Tables[ndx];

end;



constructor TSQLModel.Create(CloneFrom: TSQLModel);

var i: integer;

begin

  if CloneFrom=nil then

    raise EModelException.CreateUTF8('%.Create(CloneFrom=nil)',[self]);

  fTables := CloneFrom.fTables;

  fTablesMax := CloneFrom.fTablesMax;

  if fTablesMax<>High(fTables) then

    raise EModelException.CreateUTF8('%.Create: incorrect CloneFrom.TableMax',[self]);

  fRoot := CloneFrom.fRoot;

  fActions := CloneFrom.fActions;

  fEvents := CloneFrom.fEvents;

  fRestOwner := CloneFrom.fRestOwner;

  fSortedTablesName := CloneFrom.fSortedTablesName;

  fSortedTablesNameIndex := CloneFrom.fSortedTablesNameIndex;

  fRecordReferences := CloneFrom.fRecordReferences;

  fVirtualTableModule := CloneFrom.fVirtualTableModule;

  fCustomCollationForAll := CloneFrom.fCustomCollationForAll;

  SetLength(fTableProps,fTablesMax+1);

  for i := 0 to fTablesMax do

    fTableProps[i] := TSQLModelRecordProperties.CreateFrom(

      self,CloneFrom.fTableProps[i]);

end;



constructor TSQLModel.Create(Owner: TSQLRest; TabParameters: PSQLRibbonTabParameters;

  TabParametersCount, TabParametersSize: integer;

  const NonVisibleTables: array of TSQLRecordClass;

  Actions, Events: PTypeInfo; const aRoot: RawUTF8);

var i: integer;

    Tables: array of TSQLRecordClass;

begin

  if (TabParameters=nil) or (TabParametersCount<=0) or

     (cardinal(TabParametersSize)<sizeof(TSQLRibbonTabParameters)) then

    raise EModelException.CreateUTF8('%.Create(TabParameters?)',[self]);

  SetLength(Tables,TabParametersCount+length(NonVisibleTables));

  for i := 0 to TabParametersCount-1 do begin

    Tables[i] := TabParameters^.Table;

    inc(PByte(TabParameters),TabParametersSize);

  end;

  for i := 0 to high(NonVisibleTables) do

    Tables[i+TabParametersCount] := NonVisibleTables[i];

  Create(Tables,aRoot);

  fRestOwner := Owner;

  SetActions(Actions);

  SetEvents(Events);

end;



constructor TSQLModel.Create;

begin

  raise EModelException.CreateUTF8('Plain %.Create is not allowed: use overloaded Create()',[self]);

end;



constructor TSQLModel.Create(const Tables: array of TSQLRecordClass; const aRoot: RawUTF8);

var N, i: integer;

begin

  N := length(Tables);

  if N>sizeof(SUPERVISOR_ACCESS_RIGHTS.Get)*8 then // TSQLAccessRights bits size

    raise EModelException.CreateUTF8('% for "%" has too many Tables: %>%',

      [self,aRoot,N,sizeof(SUPERVISOR_ACCESS_RIGHTS.Get)*8]); // e.g. N>64

  // set the Tables to be associated with this Model, as TSQLRecord classes

  fTablesMax := N-1;

  SetLength(fTables,N);

  MoveFast(Tables[0],fTables[0],N*Sizeof(Tables[0]));

  for i := 0 to N-1 do

    // first register for JSONToObject() and for TSQLPropInfoRTTITID.Create()

    TJSONSerializer.RegisterClassForJSON(Tables[i]);

  SetLength(fSortedTablesName,N);

  SetLength(fSortedTablesNameIndex,N);

  SetLength(fTableProps,N);

  // initialize internal properties

  for i := 0 to fTablesMax do

    SetTableProps(i);

  QuickSortRawUTF8(fSortedTablesName,fTablesMax+1,@fSortedTablesNameIndex,@StrIComp);

  // set the optional Root URI path of this Model

  if aRoot<>'' then

    if aRoot[length(aRoot)]='/' then

      fRoot := copy(aRoot,1,Length(aRoot)-1) else

      fRoot := aRoot;

end;



function TSQLModel.GetIsUnique(aTable: TSQLRecordClass; aFieldIndex: integer): boolean;

var i: integer;

begin

  i := GetTableIndex(aTable);

  if (i<0) or (Cardinal(aFieldIndex)>=MAX_SQLFIELDS) then

    Result := false else

    Result := aFieldIndex in TableProps[i].Props.IsUniqueFieldsBits;

end;



function GetTableNameFromSQLSelect(const SQL: RawUTF8;

  EnsureUniqueTableInFrom: boolean): RawUTF8;

var i,j,k: integer;

begin

  i := PosI(' FROM ',SQL);

  if i>0 then begin

    inc(i,6);

    while SQL[i] in [#1..' '] do inc(i);

    j := 0;

    while ord(SQL[i+j]) in IsIdentifier do inc(j);

    if cardinal(j-1)<64 then begin

      k := i+j;

      while SQL[k] in [#1..' '] do inc(k);

      if (not EnsureUniqueTableInFrom) or (SQL[k]<>',') then begin

        SetString(result,PAnsiChar(PtrInt(SQL)+i-1),j);

        exit;

      end;

    end;

  end;

  result := '';

end;



function GetTableNamesFromSQLSelect(const SQL: RawUTF8): TRawUTF8DynArray;

var i,j,k,n: integer;

begin

  result := nil;

  n := 0;

  i := PosI(' FROM ',SQL);

  if i>0 then begin

    inc(i,6);

    repeat

      while SQL[i] in [#1..' '] do inc(i);

      j := 0;

      while ord(SQL[i+j]) in IsIdentifier do inc(j);

      if cardinal(j-1)>64 then begin

        result := nil;

        exit; // seems too big

      end;

      k := i+j;

      while SQL[k] in [#1..' '] do inc(k);

      SetLength(result,n+1);

      SetString(result[n],PAnsiChar(PtrInt(SQL)+i-1),j);

      inc(n);

      if SQL[k]<>',' then

        break;

      i := k+1;

    until false;

  end;

end;



function TSQLModel.GetTableIndexFromSQLSelect(const SQL: RawUTF8;

  EnsureUniqueTableInFrom: boolean): integer;

var TableName: RawUTF8;

begin

  TableName := GetTableNameFromSQLSelect(SQL,EnsureUniqueTableInFrom);

  result := GetTableIndex(TableName);

end;



function TSQLModel.GetTableIndexesFromSQLSelect(const SQL: RawUTF8): TIntegerDynArray;

var TableNames: TRawUTF8DynArray;

    i,t,n,ndx: integer;

begin

  result := nil;

  TableNames := GetTableNamesFromSQLSelect(SQL);

  t := length(TableNames);

  if t=0 then

    exit;

  SetLength(result,t);

  n := 0;

  for i := 0 to t-1 do begin

    ndx := GetTableIndex(TableNames[i]);

    if ndx<0 then

      continue;

    result[n] := ndx;

    inc(n);

  end;

  if n<>t then

    SetLength(result,n);

end;



function TSQLModel.GetTablesFromSQLSelect(const SQL: RawUTF8): TSQLRecordClassDynArray;

var t: TIntegerDynArray;

    n,i: integer;

begin

  t := GetTableIndexesFromSQLSelect(SQL);

  n := length(t);

  if n=0 then

    exit;

  SetLength(result,n);

  for i := 0 to n-1 do

    result[i] := Tables[t[i]];

end;



function TSQLModel.GetTable(const SQLTableName: RawUTF8): TSQLRecordClass;

var i: integer;

begin

  i := GetTableIndex(SQLTableName);

  if i>=0 then

    result := Tables[i] else

    result := nil;

end;



function TSQLModel.GetTableExactClass(const TableName: RawUTF8): TSQLRecordClass;

var i: integer;

begin

  i := GetTableExactIndex(TableName);

  if i>=0 then

    result := Tables[i] else

    result := nil;

end;



function TSQLModel.GetTableIndex(aTable: TSQLRecordClass): integer;

var i: integer;

    Props: TSQLRecordProperties;

begin

  if (self<>nil) and (aTable<>nil) then begin

    Props := PPointer(PtrInt(aTable)+vmtAutoTable)^;

    if (Props<>nil) and (Props.fModelMax>=0) and (Props.fModelMax<fTablesMax) then

      // fastest O(1) search in all registered models (if worth it)

      for i := 0 to Props.fModelMax do

        if Props.fModel[i].Model=self then begin

          result := Props.fModel[i].TableIndex;

          exit;

        end;

    // manual search e.g. if fModel[] is not yet set

    for result := 0 to fTablesMax do

      if Tables[result]=aTable then

        exit;

  end;

  result := -1;

end;



function TSQLModel.GetTableIndexInheritsFrom(aTable: TSQLRecordClass): integer;

begin

  if (self<>nil) and (aTable<>nil) and (aTable<>TSQLRecord) then

    for result := 0 to fTablesMax do

      if Tables[result].InheritsFrom(aTable) then

        exit;

  result := -1;

end;



function TSQLModel.GetTableIndexExisting(aTable: TSQLRecordClass): integer;

begin

  if self=nil then

    raise EModelException.Create('nil.GetTableIndexExisting');

  if aTable=nil then

    raise EModelException.CreateUTF8('aTable=nil for % "%"',[self,Root]);

  result := GetTableIndex(aTable);

  if result<0 then

    raise EModelException.CreateUTF8('% should be part of the % "%"',

      [aTable,self,Root]);

end;



function TSQLModel.GetTableExactIndex(const TableName: RawUTF8): integer;

var L: integer;

begin

  if self<>nil then begin

  L := length(TableName);

  for result := 0 to fTablesMax do

    if Tables[result]<>nil then // avoid GPF

    if IdemPropName(

       // new TObject.ClassName is UnicodeString (Delphi 20009) -> inline code

       // using vmtClassName = UTF-8 encoded text stored as shortstring

       PShortString(PPointer(PtrInt(Tables[result])+vmtClassName)^)^,

       pointer(TableName),L) then

      exit;  // case insensitive search

  end;

  result := -1;

end;



function TSQLModel.GetTableIndex(const SQLTableName: RawUTF8): integer;

begin

  if (self<>nil) and (SQLTableName<>'') then begin

    // fast binary search

    result := FastFindPUTF8CharSorted(

      pointer(fSortedTablesName),fTablesMax,pointer(SQLTableName),@StrIComp);

    if result>=0 then

      result := fSortedTablesNameIndex[result];

  end else

    result := -1;

end;



function TSQLModel.GetTableIndex(SQLTableName: PUTF8Char): integer;

begin

  if (self<>nil) and (SQLTableName<>nil) then begin

    // fast binary search

    result := FastFindPUTF8CharSorted(

      pointer(fSortedTablesName),fTablesMax,SQLTableName,@StrIComp);

    if result>=0 then

      result := fSortedTablesNameIndex[result];

  end else

    result := -1;

end;



function TSQLModel.getURI(aTable: TSQLRecordClass): RawUTF8;

begin

  result := '';

  if self=nil then

    exit;

  if aTable<>nil then

    result := aTable.RecordProps.SQLTableName else begin

    result := Root;

    exit;

  end;

  if Root<>'' then

    result := Root+'/'+result;

end;



function TSQLModel.URIMatch(const URI: RawUTF8): TSQLRestModelMatch;

var URILen: integer;

begin

  result := rmNoMatch;

  if (self=nil) or (fRoot='') or (URI='') then

    exit;

  if fRootUpper='' then

    UpperCaseCopy(fRoot,fRootUpper);

  if IdemPChar(pointer(URI),pointer(fRootUpper)) then begin

    URILen := length(fRoot);

    if URI[URILen+1] in [#0,'/','?'] then

      if CompareMem(pointer(URI),pointer(fRoot),URILen) then

        result := rmMatchExact else

        result := rmMatchWithCaseChange;

  end;

end;



function TSQLModel.SQLFromSelectWhere(const Tables: array of TSQLRecordClass;

   const SQLSelect, SQLWhere: RawUTF8): RawUTF8;

var i: integer;

    aProps: array[0..31] of TSQLModelRecordProperties;

begin

  if self=nil then

    raise EORMException.Create('Model required');

  if high(Tables)=0 then begin

    // fastest common call with one TSQLRecordClass

    result := Props[Tables[0]].SQLFromSelectWhere(SQLSelect,SQLWhere);

    exit;

  end;

  // 'SELECT T1.F1,T1.F2,T1.F3,T2.F1,T2.F2 FROM T1,T2 WHERE ..' e.g.

  if cardinal(high(Tables))>high(aProps) then

    raise EModelException.CreateUTF8('%.SQLFromSelectWhere() up to % Tables[]',

      [self,Length(aProps)]);

  for i := 0 to high(Tables) do

    aProps[i] := Props[Tables[i]]; // raise EModelException if not found

  if SQLSelect='*' then

     // don't send BLOB values to query: retrieve all other fields

    if high(Tables)=0 then

      result := 'SELECT '+aProps[0].SQL.TableSimpleFields[true,false] else begin

      result := 'SELECT '+aProps[0].SQL.TableSimpleFields[true,true];

      for i := 1 to high(Tables) do

        result := result+','+aProps[i].SQL.TableSimpleFields[true,true];

    end else

    result := 'SELECT '+SQLSelect;

  result := result+' FROM '+aProps[0].Props.SQLTableName;

  for i := 1 to high(Tables) do

    result := result+','+aProps[i].Props.SQLTableName;

  result := result+SQLFromWhere(SQLWhere);

end;



procedure TSQLModel.SetCustomCollationForAll(aFieldType: TSQLFieldType;

  const aCollationName: RawUTF8);

var i: integer;

begin

  if self=nil then

    exit;

  if fCustomCollationForAll[aFieldType]<>'' then

    raise EModelException.CreateUTF8('%.SetCustomCollationForAll(%)'+

      ' shall be called only once',[self,aCollationName]);

  fCustomCollationForAll[aFieldType] := aCollationName;

  for i := 0 to high(fTableProps) do

    fTableProps[i].fProps.SetCustomCollationForAll(aFieldType,aCollationName);

end;



procedure TSQLModel.SetMaxLengthValidatorForAllTextFields(IndexIsUTF8Length: boolean);

var i: integer;

begin

  if self<>nil then

    for i := 0 to high(fTableProps) do

      fTableProps[i].fProps.SetMaxLengthValidatorForTextFields(IndexIsUTF8Length);

end;



procedure TSQLModel.SetMaxLengthFilterForAllTextFields(IndexIsUTF8Length: boolean);

var i: integer;

begin

  if self<>nil then

    for i := 0 to high(fTableProps) do

      fTableProps[i].fProps.SetMaxLengthFilterForTextFields(IndexIsUTF8Length);

end;



{$ifndef NOVARIANTS}

procedure TSQLModel.SetVariantFieldsDocVariantOptions(const Options: TDocVariantOptions);

var i: integer;

begin

  if self<>nil then

    for i := 0 to high(fTableProps) do

      fTableProps[i].fProps.SetVariantFieldsDocVariantOptions(Options);

end;

{$endif}



function TSQLModel.SetIDGenerator(aTable: TSQLRecordClass;

  aIdentifier: TSynUniqueIdentifierProcess; const aSharedObfuscationKey: RawUTF8): TSynUniqueIdentifierGenerator;

var i: integer;

begin

  i := GetTableIndexExisting(aTable);

  if i>=length(fIDGenerator) then

    SetLength(fIDGenerator,fTablesMax+1);

  result := TSynUniqueIdentifierGenerator.Create(aIdentifier,aSharedObfuscationKey);

  fIDGenerator[i].Free;

  fIDGenerator[i] := result;

end;



function TSQLModel.GetIDGenerator(aTable: TSQLRecordClass): TSynUniqueIdentifierGenerator;

var i: cardinal;

begin

  i := GetTableIndexExisting(aTable);

  if i<cardinal(length(fIDGenerator)) then

    result := fIDGenerator[i] else

    result := nil; 

end;



function TSQLModel.NewRecord(const SQLTableName: RawUTF8): TSQLRecord;

var aClass: TSQLRecordClass;

begin

  aClass := Table[SQLTableName];

  if aClass=nil then

    result := nil else

    result := aClass.Create;

end;



procedure TSQLModel.SetActions(aActions: PTypeInfo);

begin

  if (aActions=nil) or not (aActions^.Kind=tkEnumeration) then

    fActions := nil else

    fActions := aActions^.EnumBaseType;

end;



procedure TSQLModel.SetEvents(aEvents: PTypeInfo);

begin

  if (aEvents=nil) or not (aEvents^.Kind=tkEnumeration) then

    fEvents := nil else

    fEvents := aEvents^.EnumBaseType;

end;



function TSQLModel.GetSQLCreate(aTableIndex: integer): RawUTF8;

begin

  if (self=nil) or (cardinal(aTableIndex)>cardinal(fTablesMax)) then

    result := '' else

    result := Tables[aTableIndex].GetSQLCreate(self);

end;



function TSQLModel.GetSQLAddField(aTableIndex, aFieldIndex: integer): RawUTF8;

begin

  if (self=nil) or (cardinal(aTableIndex)>cardinal(fTablesMax)) then

    result := '' else

    result := TableProps[aTableIndex].Props.SQLAddField(aFieldIndex);

end;



function TSQLModel.isLocked(aTable: TSQLRecordClass; aID: TID): boolean;

begin

  result := GetLocks(aTable)^.isLocked(aID);

end;



function TSQLModel.isLocked(aRec: TSQLRecord): boolean;

begin

  if aRec=nil then

    result := false else

    result := isLocked(PSQLRecordClass(aRec)^,aRec.fID);

end;



function TSQLModel.Lock(aTable: TSQLRecordClass; aID: TID): boolean;

begin

  if self=nil then

    result := false else begin

    if fLocks=nil then

      SetLength(fLocks,fTablesMax+1); // initialize fLocks[] if necessary

    result :=  GetLocks(aTable)^.Lock(aID);

  end;

end;



function TSQLModel.Lock(aTableIndex, aID: TID): boolean;

begin

  if (self=nil) or (Cardinal(aTableIndex)>cardinal(fTablesMax)) then

    result := false else begin

    if fLocks=nil then

      SetLength(fLocks,fTablesMax+1); // initialize fLocks[] if necessary

    result := fLocks[aTableIndex].Lock(aID);

  end;

end;



function TSQLModel.Lock(aRec: TSQLRecord): boolean;

begin

  if aRec=nil then

    result := false else

    result := Lock(PSQLRecordClass(aRec)^,aRec.fID);

end;



procedure TSQLModel.PurgeOlderThan(MinutesFromNow: cardinal);

var i: integer;

begin

  if fLocks<>nil then

    for i := 0 to high(fLocks) do

     fLocks[i].PurgeOlderThan(MinutesFromNow);

end;



function TSQLModel.UnLock(aTable: TSQLRecordClass; aID: TID): boolean;

begin

  if (self=nil) or (fLocks=nil) then

    result := false else

    result := GetLocks(aTable)^.UnLock(aID);

end;



function TSQLModel.UnLock(aTableIndex: integer; aID: TID): boolean;

begin

  if (self=nil) or (cardinal(aTableIndex)>=cardinal(length(fLocks))) then

    result := false else

    result := fLocks[aTableIndex].UnLock(aID);

end;



function TSQLModel.UnLock(aRec: TSQLRecord): boolean;

begin

  if aRec=nil then

    result := false else

    result := UnLock(PSQLRecordClass(aRec)^,aRec.fID);

end;



function TSQLModel.GetLocks(aTable: TSQLRecordClass): PSQLLocks;

begin

  if (self=nil) or (fLocks=nil) then

    result := nil else

    result := @fLocks[GetTableIndexExisting(aTable)];

end;



procedure TSQLModel.UnLockAll;

var i: integer;

begin

  for i := 0 to high(fLocks) do

    fLocks[i].Count := 0;

end;



function TSQLModel.getURIID(aTable: TSQLRecordClass; aID: TID): RawUTF8;

begin

  result := getURI(aTable);

  if aID>0 then

    result := result+'/'+Int64ToUtf8(aID);

end;



function TSQLModel.getURICallBack(const aMethodName: RawUTF8; aTable: TSQLRecordClass; aID: TID): RawUTF8;

begin

  result := getURIID(aTable,aID)+'/'+aMethodName;

end;



function TSQLModel.ActionName(const Action): string;

begin

  if (Self=nil) or (fActions=nil) then

    result := '' else

    result := TSQLRecord.CaptionNameFromRTTI(fActions^.GetEnumName(byte(Action)));

end;



function TSQLModel.EventName(const Event): string;

begin

  if (Self=nil) or (fEvents=nil) then

    result := '' else

    result := TSQLRecord.CaptionNameFromRTTI(fEvents^.GetEnumName(byte(Event)));

end;



function TSQLModel.RecordReference(Table: TSQLRecordClass; ID: TID): TRecordReference;

begin

  if (self=nil) or (ID<=0) then

    result := 0 else begin

    result := GetTableIndexExisting(Table);

    if result>63 then // TRecordReference handle up to 64=1 shl 6 tables

      result := 0 else

      inc(result,ID shl 6);

  end;

end;



function TSQLModel.RecordReferenceTable(const Ref: TRecordReference): TSQLRecordClass;

var i: integer;

begin

  i := Ref and 63;

  if i<=fTablesMax then

    result := fTables[i] else

    result := nil;

end;



function TSQLModel.VirtualTableRegister(aClass: TSQLRecordClass;

  aModule: TSQLVirtualTableClass; const aExternalTableName: RawUTF8='';

  aExternalDataBase: TObject=nil): boolean;

var i: integer;

begin

  result := false;

  if aClass=nil then exit;

  i := GetTableIndexExisting(aClass);

  with TableProps[i] do begin

    if not (Kind in IS_CUSTOM_VIRTUAL) then

      if Kind=rSQLite3 then

        SetKind(rCustomAutoID) else // SetKind() recompute all SQL

        raise EModelException.CreateUTF8('Invalid %.VirtualTableRegister(%) call: '+

          'impossible to set class as virtual',[self,aClass]);

    ExternalDB.Init(aClass,aExternalTableName,aExternalDataBase,true);

  end;

  if high(fVirtualTableModule)<>fTablesMax then

    SetLength(fVirtualTableModule,fTablesMax+1);

  fVirtualTableModule[i] := aModule;

  result := true;

end;



function TSQLModel.VirtualTableModule(aClass: TSQLRecordClass): TSQLVirtualTableClass;

var i: integer;

begin

  result := nil;

  if (self=nil) or (fVirtualTableModule=nil) then

    exit;

  i := GetTableIndexExisting(aClass);

  if TableProps[i].Kind in IS_CUSTOM_VIRTUAL then

    result := fVirtualTableModule[i];

end;



destructor TSQLModel.Destroy;

var i,j: integer;

begin

  for i := 0 to fTablesMax do begin

    with TableProps[i].Props do begin

      EnterCriticalSection(fLock); // may be called from several threads at once

      try

        for j := 0 to fModelMax do

          if fModel[j].Model=self then begin

            // un-associate this TSQLRecord with this model

            MoveFast(fModel[j+1],fModel[j],(fModelMax-j)*sizeof(fModel[j]));

            dec(fModelMax);

            break;

          end;

        TableProps[i].Free;

      finally

        LeaveCriticalSection(fLock);

      end;

    end;

  end;

  ObjArrayClear(fIDGenerator);

  inherited;

end;





{ TSQLRestBatch }



constructor TSQLRestBatch.Create(aRest: TSQLRest; aTable: TSQLRecordClass;

  AutomaticTransactionPerRow: cardinal; Options: TSQLRestBatchOptions);

begin

  if aRest=nil then

    raise EORMException.CreateUTF8('%.Create(aRest=nil)',[self]);

  fRest := aRest;

  Reset(aTable,AutomaticTransactionPerRow,Options);

end;



procedure TSQLRestBatch.Reset(aTable: TSQLRecordClass;

  AutomaticTransactionPerRow: cardinal; Options: TSQLRestBatchOptions);

begin

  fBatch.Free; // full reset for SetExpandedJSONWriter 

  fBatch := TJSONSerializer.CreateOwnedStream;

  fBatch.Expand := true;

  FillZero(fBatchFields);

  fBatchCount := 0;

  fAddCount := 0;

  fUpdateCount := 0;

  fDeleteCount := 0;

  fDeletedCount := 0;

  fTable := aTable;

  if aTable<>nil then begin

    fTableIndex := fRest.Model.GetTableIndexExisting(aTable);

    fBatch.Add('{'); // sending data is '{"Table":["cmd":values,...]}'

    fBatch.AddFieldName(aTable.SQLTableName);

  end else

    fTableIndex := -1;

  fBatch.Add('[');

  fAutomaticTransactionPerRow := AutomaticTransactionPerRow;

  if AutomaticTransactionPerRow>0 then begin // should be the first command

    fBatch.AddShort('"automaticTransactionPerRow",');

    fBatch.Add(AutomaticTransactionPerRow);

    fBatch.Add(',');

  end;

  fOptions := Options;

  if boExtendedJSON in Options then

    include(fBatch.fCustomOptions,twoForceJSONExtended);

  Options := Options-[boExtendedJSON,boPostNoSimpleFields]; // client-side only

  if byte(Options)<>0 then begin

    fBatch.AddShort('"options",');

    fBatch.Add(byte(Options));

    fBatch.Add(',');

  end;

end;



procedure TSQLRestBatch.Reset;

begin

  if self<>nil then

    Reset(fTable,fAutomaticTransactionPerRow,fOptions);

end;



destructor TSQLRestBatch.Destroy;

begin

  FreeAndNil(fBatch);

  inherited;

end;



function TSQLRestBatch.GetCount: integer;

begin

  if self=nil then

    result := 0 else

    result := fBatchCount;

end;



function TSQLRestBatch.GetSizeBytes: cardinal;

begin

  if self=nil then

    result := 0 else

    result := fBatch.TextLength;

end;



procedure TSQLRestBatch.SetExpandedJSONWriter(Props: TSQLRecordProperties;

  ForceResetFields, withID: boolean; const WrittenFields: TSQLFieldBits);

begin

  if (self=nil) or (fBatch=nil) then

    exit;

  if not ForceResetFields then

    if fBatch.Expand and (fBatch.WithID=withID) and

       IsEqual(fBatchFields,WrittenFields) then

      exit; // already set -> do not compute it again

  fBatchFields := WrittenFields;

  fBatch.ChangeExpandedFields(withID,FieldBitsToIndex(WrittenFields,Props.Fields.Count));

  Props.SetJSONWriterColumnNames(fBatch,0);

end;



function TSQLRestBatch.RawAppend(FullRow: boolean): TTextWriter;

begin

  if FullRow then

    inc(fBatchCount);

  result := fBatch;

end;



procedure TSQLRestBatch.RawAdd(const SentData: RawUTF8);

begin // '{"Table":[...,"POST",{object},...]}'

  if (fBatch=nil) or (fTable=nil) then

    raise EORMException.CreateUTF8('%.RawAdd %',[self,SentData]);

  fBatch.AddShort('"POST",');

  fBatch.AddString(SentData);

  fBatch.Add(',');

  inc(fBatchCount);

  inc(fAddCount);

end;



procedure TSQLRestBatch.RawUpdate(const SentData: RawUTF8; ID: TID);

var sentID: TID;

begin // '{"Table":[...,"PUT",{object},...]}'

  if (fBatch=nil) or (fTable=nil) then

    raise EORMException.CreateUTF8('%.RawUpdate % %',[self,ID,SentData]);

  if JSONGetID(pointer(SentData),sentID) and (sentID<>ID) then

    raise EORMException.CreateUTF8('%.RawUpdate ID=% <> %',[self,ID,SentData]);

  fBatch.AddShort('"PUT",{ID:');

  fBatch.Add(ID);

  fBatch.Add(',');

  fBatch.AddStringCopy(SentData,2,maxInt shr 2);

  fBatch.Add(',');

  inc(fBatchCount);

  inc(fUpdateCount);

end;



function TSQLRestBatch.Add(Value: TSQLRecord; SendData,ForceID: boolean;

  const CustomFields: TSQLFieldBits; DoNotAutoComputeFields: boolean): integer;

var Props: TSQLRecordProperties;

    FieldBits: TSQLFieldBits;

    PostSimpleFields: boolean;

    f: integer;

begin

  result := -1;

  if (self=nil) or (Value=nil) or (fBatch=nil) then

    exit; // invalid parameters, or not opened BATCH sequence

  if (fTable<>nil) and (PSQLRecordClass(Value)^<>fTable) then

    exit;

  Props := Value.RecordProps;

  if SendData and

     (fRest.Model.Props[PSQLRecordClass(Value)^].Kind in INSERT_WITH_ID) then

      ForceID := true; // same format as TSQLRestClient.Add

  if SendData and (not ForceID) and IsZero(CustomFields) and

     not(boPostNoSimpleFields in fOptions) then begin

    PostSimpleFields := true;

    fBatch.AddShort('"SIMPLE');

  end else begin

    PostSimpleFields := false;

    fBatch.AddShort('"POST');

  end;

  if fTable<>nil then  // '{"Table":[...,"POST",{object},...]}'

      fBatch.AddShort('",') else begin

      fBatch.Add('@'); // '[...,"POST@Table",{object}',...]'

      fBatch.AddString(Props.SQLTableName);

      fBatch.Add('"',',');

    end;

  if SendData then begin

    if IsZero(CustomFields) then

      FieldBits := Props.SimpleFieldsBits[soInsert] else

    if DoNotAutoComputeFields then

      FieldBits := CustomFields else

      FieldBits := CustomFields+Props.ComputeBeforeAddFieldsBits;

    SetExpandedJSONWriter(Props,fTablePreviousSendData<>PSQLRecordClass(Value)^,

      (Value.IDValue<>0) and ForceID,FieldBits);

    fTablePreviousSendData := PSQLRecordClass(Value)^;

    if not DoNotAutoComputeFields then // update TModTime/TCreateTime fields

      Value.ComputeFieldsBeforeWrite(fRest,seAdd);

    if PostSimpleFields then begin

      fBatch.Add('[');

      for f := 0 to length(Props.SimpleFields)-1 do begin

        Props.SimpleFields[f].GetJSONValues(Value,fBatch);

        fBatch.Add(',');

      end;

      fBatch.CancelLastComma;

      fBatch.Add(']');

    end else

      Value.GetJSONValues(fBatch);

    if fCalledWithinRest and ForceID then

      fRest.fCache.Notify(Value,soInsert);

  end else

    fBatch.Add('{','}'); // '{"Table":[...,"POST",{},...]}'

  fBatch.Add(',');

  result := fBatchCount;

  inc(fBatchCount);

  inc(fAddCount);

  if Assigned(fOnWrite) then

    fOnWrite(self,soInsert,PSQLRecordClass(Value)^,Value.IDValue,Value,FieldBits);

end;



procedure AddID(var Values: TIDDynArray; var ValuesCount: integer; Value: TID);

begin

  if ValuesCount=length(Values) then

    SetLength(Values,ValuesCount+256+ValuesCount shr 3);

  Values[ValuesCount] := Value;

  inc(ValuesCount);

end;



function TSQLRestBatch.Delete(Table: TSQLRecordClass;

  ID: TID): integer;

begin

  if (self=nil) or (fBatch=nil) or (Table=nil) or

     (ID<=0) or not fRest.RecordCanBeUpdated(Table,ID,seDelete) then begin

    result := -1; // invalid parameters, or not opened BATCH sequence

    exit;

  end;

  AddID(fDeletedRecordRef,fDeletedCount,fRest.Model.RecordReference(Table,ID));

  fBatch.AddShort('"DELETE@'); // '[...,"DELETE@Table",ID,...]}'

  fBatch.AddString(Table.RecordProps.SQLTableName);

  fBatch.Add('"',',');

  fBatch.Add(ID);

  fBatch.Add(',');

  result := fBatchCount;

  inc(fBatchCount);

  inc(fDeleteCount);

  if Assigned(fOnWrite) then

    fOnWrite(self,soDelete,Table,ID,nil,[]);

end;



function TSQLRestBatch.Delete(ID: TID): integer;

begin

  if (self=nil) or (fTable=nil) or

     (ID<=0) or not fRest.RecordCanBeUpdated(fTable,ID,seDelete) then begin

    result := -1; // invalid parameters, or not opened BATCH sequence

    exit;

  end;

  AddID(fDeletedRecordRef,fDeletedCount,RecordReference(fTableIndex,ID));

  fBatch.AddShort('"DELETE",'); // '{"Table":[...,"DELETE",ID,...]}'

  fBatch.Add(ID);

  fBatch.Add(',');

  result := fBatchCount;

  inc(fBatchCount);

  inc(fDeleteCount);

  if Assigned(fOnWrite) then

    fOnWrite(self,soDelete,fTable,ID,nil,[]);

end;



function TSQLRestBatch.PrepareForSending(out Data: RawUTF8): boolean;

var i: integer;

begin

  if (self=nil) or (fBatch=nil) then // no opened BATCH sequence

    result := false else begin

    if fBatchCount>0 then begin // if something to send

      for i := 0 to fDeletedCount-1 do

        if fDeletedRecordRef[i]<>0 then

          fRest.Cache.NotifyDeletion(fDeletedRecordRef[i] and 63,fDeletedRecordRef[i] shr 6);

      fBatch.CancelLastComma;

      fBatch.Add(']');

      if fTable<>nil then

        fBatch.Add('}'); // end sequence array '{"Table":["cmd":values,...]}'

      fBatch.SetText(Data);

    end;

    result := true;

  end;

end;



function TSQLRestBatch.Update(Value: TSQLRecord;

  const CustomFields: TSQLFieldBits; DoNotAutoComputeFields: boolean): integer;

var Props: TSQLRecordProperties;

    FieldBits: TSQLFieldBits;

    ID: TID;

    tableIndex: integer;

begin

  result := -1;

  if (Value=nil) or (fBatch=nil) then

    exit;

  ID := Value.IDValue;

  if (ID<=0) or not fRest.RecordCanBeUpdated(Value.RecordClass,ID,seUpdate) then

    exit; // invalid parameters, or not opened BATCH sequence

  Props := Value.RecordProps;

  if fTable<>nil then

    if PSQLRecordClass(Value)^<>fTable then

      exit else begin // '{"Table":[...,"PUT",{object},...]}'

      tableIndex := fTableIndex;

      fBatch.AddShort('"PUT",');

    end else begin

      tableIndex := fRest.Model.GetTableIndexExisting(Props.Table);

      fBatch.AddShort('"PUT@'); // '[...,"PUT@Table",{object}',...]'

      fBatch.AddString(Props.SQLTableName);

      fBatch.Add('"',',');

    end;

  // same format as TSQLRest.Update, BUT including the ID

  if IsZero(CustomFields) then

    Value.FillContext.ComputeSetUpdatedFieldBits(Props,FieldBits) else

    if DoNotAutoComputeFields then

      FieldBits := CustomFields else

      FieldBits := CustomFields+Value.RecordProps.FieldBits[sftModTime];

  SetExpandedJSONWriter(Props,fTablePreviousSendData<>PSQLRecordClass(Value)^,

    true,FieldBits);

  fTablePreviousSendData := PSQLRecordClass(Value)^;

  if not DoNotAutoComputeFields then

    Value.ComputeFieldsBeforeWrite(fRest,seUpdate); // update sftModTime fields

  Value.GetJSONValues(fBatch);

  fBatch.Add(',');

  if fCalledWithinRest and

     (FieldBits-Props.SimpleFieldsBits[soUpdate]=[]) then

    fRest.Cache.Notify(Value,soUpdate) else

    // may not contain all cached fields -> delete from cache

    AddID(fDeletedRecordRef,fDeletedCount,RecordReference(tableIndex,ID));

  result := fBatchCount;

  inc(fBatchCount);

  inc(fUpdateCount);

  if Assigned(fOnWrite) then

    fOnWrite(self,soUpdate,PSQLRecordClass(Value)^,Value.IDValue,Value,FieldBits);

end;



function TSQLRestBatch.Update(Value: TSQLRecord; const CustomCSVFields: RawUTF8;

  DoNotAutoComputeFields: boolean): integer;

begin

  if (Value=nil) or (fBatch=nil) then

    result := -1 else

    result := Update(Value,Value.RecordProps.FieldBitsFromCSV(CustomCSVFields),

      DoNotAutoComputeFields);

end;





{ TSQLRestBatchLocked }



constructor TSQLRestBatchLocked.Create(aRest: TSQLRest; aTable: TSQLRecordClass;

  AutomaticTransactionPerRow: cardinal; Options: TSQLRestBatchOptions);

begin

  inherited;

  fSafe.Init;

end;



destructor TSQLRestBatchLocked.Destroy;

begin

  fSafe.Done;

  inherited;

end;



procedure TSQLRestBatchLocked.Reset(aTable: TSQLRecordClass;

  AutomaticTransactionPerRow: cardinal; Options: TSQLRestBatchOptions);

begin

  inherited;

  fTix := GetTickCount64;

end;





{ TSQLRest }



constructor TSQLRest.Create(aModel: TSQLModel);

var cmd: TSQLRestServerURIContextCommand;

begin

  inherited Create;

  fPrivateGarbageCollector := TObjectList.Create;

  fModel := aModel;

  for cmd := Low(cmd) to high(cmd) do

    fAcquireExecution[cmd] := TSQLRestAcquireExecution.Create;

  AcquireWriteMode := amLocked;

  AcquireWriteTimeOut := 2000; // default 2 seconds

  fRoutingClass := TSQLRestRoutingREST;

  QueryPerformanceFrequency(fFrequencyTimeStamp);

  {$ifdef WITHLOG}

  SetLogClass(SQLite3Log); // by default

  {$endif}

end;



destructor TSQLRest.Destroy;

var cmd: TSQLRestServerURIContextCommand;

    i: integer;

begin

  {$ifndef FPC} // serialization during destruction seems unsafe under FPC

  InternalLog('%.Destroy -> %',[ClassType,self],sllInfo);

  {$endif}

  FreeAndNil(fServices);

  FreeAndNil(fCache);

  if (fModel<>nil) and (fModel.fRestOwner=self) then

    // make sure we are the Owner (TSQLRestStorage has fModel<>nil e.g.)

    FreeAndNil(fModel);

  for cmd := Low(cmd) to high(cmd) do

    FreeAndNil(fAcquireExecution[cmd]); // should be done BEFORE private GC

  if fPrivateGarbageCollector<>nil then begin

    for i := fPrivateGarbageCollector.Count-1 downto 0 do // last in, first out

    try

      fPrivateGarbageCollector.Delete(i); // will call fPrivate...[i].Free

    except

      on Exception do

        ; // just ignore exceptions in such destructors

    end;

    fPrivateGarbageCollector.Free;

  end;

  inherited Destroy;

end;



var

  GlobalDefinitions: array of TSQLRestClass;



class procedure TSQLRest.RegisterClassNameForDefinition;

begin

  ObjArrayAddOnce(GlobalDefinitions,TObject(self)); // TClass stored as TObject

end;



procedure TSQLRest.DefinitionTo(Definition: TSynConnectionDefinition);

begin

  if Definition<>nil then

    Definition.Kind := ClassName;

end;



function TSQLRest.DefinitionToJSON(Key: cardinal=0): RawUTF8;

var Definition: TSynConnectionDefinition;

begin

  Definition := TSynConnectionDefinition.Create;

  try

    Definition.Key := Key;

    DefinitionTo(Definition);

    result := Definition.SaveToJSON;

  finally

    Definition.Free;

  end;

end;



procedure TSQLRest.DefinitionToFile(const aJSONFile: TFileName; aKey: cardinal);

begin

  FileFromString(JSONReformat(DefinitionToJSON(aKey)),aJSONFile);

end;



class function TSQLRest.ClassFrom(aDefinition: TSynConnectionDefinition): TSQLRestClass;

var ndx: integer;

begin

  for ndx := 0 to length(GlobalDefinitions)-1 do

    if GlobalDefinitions[ndx].ClassNameIs(aDefinition.Kind) then begin

      result := GlobalDefinitions[ndx];

      exit;

    end;

  result := nil;

end;



constructor TSQLRest.RegisteredClassCreateFrom(aModel: TSQLModel;

  aDefinition: TSynConnectionDefinition);

begin

  Create(aModel);

end;



class function TSQLRest.CreateFrom(aModel: TSQLModel;

  aDefinition: TSynConnectionDefinition): TSQLRest;

var C: TSQLRestClass;

begin

  C := ClassFrom(aDefinition);

  if C=nil then

    raise EORMException.CreateUTF8('%.CreateFrom: unknown % class - please '+

      'add a reference to its implementation unit',[self,aDefinition.Kind]);

  result := C.RegisteredClassCreateFrom(aModel,aDefinition);

end;



class function TSQLRest.CreateTryFrom(aModel: TSQLModel;

  aDefinition: TSynConnectionDefinition; aServerHandleAuthentication: boolean): TSQLRest;

var C: TSQLRestClass;

begin

  C := ClassFrom(aDefinition);

  if C=nil then

    result := nil else

    if C.InheritsFrom(TSQLRestServer) then

      result := TSQLRestServerClass(C).RegisteredClassCreateFrom(

        aModel,aServerHandleAuthentication,aDefinition) else

      result := C.RegisteredClassCreateFrom(aModel,aDefinition);

end;



class function TSQLRest.CreateFromJSON(aModel: TSQLModel;

  const aJSONDefinition: RawUTF8; aKey: cardinal): TSQLRest;

var Definition: TSynConnectionDefinition;

begin

  Definition := TSynConnectionDefinition.CreateFromJSON(aJSONDefinition,aKey);

  try

    result := CreateFrom(aModel,Definition);

  finally

    Definition.Free;

  end;

end;



class function TSQLRest.CreateFromFile(aModel: TSQLModel;

  const aJSONFile: TFileName; aKey: cardinal): TSQLRest;

begin

  result := CreateFromJSON(aModel,AnyTextFileToRawUTF8(aJSONFile,true),aKey);

end;



procedure TSQLRest.InternalLog(const Text: RawUTF8; Level: TSynLogInfo);

begin

  {$ifdef WITHLOG}

  if (self<>nil) and (fLogFamily<>nil) and (Level in fLogFamily.Level) then

    fLogFamily.SynLog.Log(Level,Text,self);

  {$endif}

end;



procedure TSQLRest.InternalLog(const Format: RawUTF8;

  const Args: array of const; Level: TSynLogInfo);

begin

  {$ifdef WITHLOG}

  if (self<>nil) and (fLogFamily<>nil) and (Level in fLogFamily.Level) then

    fLogFamily.SynLog.Log(Level,Format,Args,self);

  {$endif}

end;



{$ifdef WITHLOG}

procedure TSQLRest.SetLogClass(aClass: TSynLogClass);

begin

  fLogClass := aClass;

  fLogFamily := fLogClass.Family;

end;



function TSQLRest.GetLogClass: TSynLogClass;

begin

  if self=nil then

    result := SQLite3Log else

    result := fLogClass;

end;

{$endif}



function TSQLRest.NewBackgroundThreadMethod(const Format: RawUTF8;

   const Args: array of const): TSynBackgroundThreadMethod;

begin

  result := TSynBackgroundThreadMethod.Create(nil,FormatUTF8(Format,Args),

    BeginCurrentThread,EndCurrentThread);

end;



function TSQLRest.NewBackgroundThreadprocess(

  aOnProcess: TOnSynBackgroundThreadProcess; aOnProcessMS: cardinal;

  const Format: RawUTF8; const Args: array of const;

  aStats: TSynMonitorClass): TSynBackgroundThreadProcess;

var name: RawUTF8;

begin

  FormatUTF8(Format,Args,name);

  if self=nil then

    result := TSynBackgroundThreadProcess.Create(name,aOnProcess,aOnProcessMS,

     nil,nil,aStats) else

    result := TSynBackgroundThreadProcess.Create(name,aOnProcess,aOnProcessMS,

      BeginCurrentThread,EndCurrentThread,aStats);

end;



procedure TSQLRest.AdministrationExecute(const DatabaseName,SQL: RawUTF8;

  var result: TServiceCustomAnswer);

begin

  if (SQL<>'') and (SQL[1]='#') then begin

    // pseudo SQL for a given TSQLRest[Server] instance

    case IdemPCharArray(@SQL[2],['TIME','MODEL','REST','HELP']) of

    0: result.Content := Int64ToUtf8(ServerTimeStamp);

    1: result.Content := ObjectToJSON(Model);

    2: result.Content := ObjectToJSON(self);

    3: begin

      result.Content[length(result.Content)] := '|';

      result.Content := result.Content+'#time|#model|#rest"';

    end;

    end;

  end else

  if isSelect(pointer(SQL)) then

    result.Content := ExecuteJson(Model.GetTablesFromSQLSelect(SQL),SQL) else

    Execute(SQL);

end;



function TSQLRest.EngineUpdateFieldIncrement(TableModelIndex: integer;

  ID: TID; const FieldName: RawUTF8; Increment: Int64): boolean;

var Value: Int64;

    Table: TSQLRecordClass;

begin

  if (TableModelIndex<0) or (ID<0) then

    result := false else begin

    Table := Model.Tables[TableModelIndex];

    result := OneFieldValue(Table,FieldName,'ID=?',[],[ID],Value) and

              UpdateField(Table,ID,FieldName,[Value+Increment]);

  end;

end;



procedure TSQLRest.SetRoutingClass(aServicesRouting: TSQLRestServerURIContextClass);

begin

  if self<>nil then

    if aServicesRouting<>fRoutingClass then

      if (aServicesRouting=nil) or (aServicesRouting=TSQLRestServerURIContext) then

         raise EServiceException.CreateUTF8('Unexpected %.SetRoutingClass(%)',

           [self,aServicesRouting]) else

         fRoutingClass := aServicesRouting;

end;



function TSQLRest.MultiFieldValue(Table: TSQLRecordClass;

  const FieldName: array of RawUTF8; var FieldValue: array of RawUTF8;

  WhereID: TID): boolean;

begin

  result := MultiFieldValue(Table,FieldName,FieldValue,

    'RowID=:('+Int64ToUtf8(WhereID)+'):');

end;



function TSQLRest.OneFieldValue(Table: TSQLRecordClass; const FieldName,

  WhereClause: RawUTF8): RawUTF8;

var Res: array[0..0] of RawUTF8;

begin

  if MultiFieldValue(Table,[FieldName],Res,WhereClause) then

    result := Res[0] else

    result := '';

end;



function TSQLRest.OneFieldValue(Table: TSQLRecordClass; const FieldName: RawUTF8;

  const FormatSQLWhere: RawUTF8; const BoundsSQLWhere: array of const): RawUTF8;

begin

  result := OneFieldValue(Table,FieldName,FormatUTF8(FormatSQLWhere,[],BoundsSQLWhere));

end;



function TSQLRest.OneFieldValue(Table: TSQLRecordClass;

  const FieldName: RawUTF8; const WhereClauseFmt: RawUTF8;

  const Args, Bounds: array of const): RawUTF8;

begin

  result := OneFieldValue(Table,FieldName,FormatUTF8(WhereClauseFmt,Args,Bounds));

end;



function TSQLRest.OneFieldValue(Table: TSQLRecordClass;

  const FieldName: RawUTF8; WhereID: TID): RawUTF8;

var Res: array[0..0] of RawUTF8;

begin

  if (WhereID>0) and

     MultiFieldValue(Table,[FieldName],Res,'RowID=:('+Int64ToUtf8(WhereID)+'):') then

    result := Res[0] else

    result := '';

end;



function TSQLRest.MemberExists(Table: TSQLRecordClass; ID: TID): boolean;

begin

  result := OneFieldValue(Table,'RowID',ID)<>'';

end;



function TSQLRest.OneFieldValue(Table: TSQLRecordClass; const FieldName: RawUTF8;

  const WhereClauseFmt: RawUTF8; const Args, Bounds: array of const;

  out Data: Int64): boolean;

var Res: array[0..0] of RawUTF8;

    err: integer;

    where: RawUTF8;

begin

  result := false;

  where := FormatUTF8(WhereClauseFmt,Args,Bounds);

  if MultiFieldValue(Table,[FieldName],Res,where) then

    if Res[0]<>'' then begin

      Data := GetInt64(pointer(Res[0]),err);

      if err=0 then

        result := true;

    end;

end;



function TSQLRest.OneFieldValues(Table: TSQLRecordClass; const FieldName,

  WhereClause: RawUTF8; out Data: TRawUTF8DynArray): boolean;

var i: integer;

    T: TSQLTableJSON;

begin

  result := false;

  T := MultiFieldValues(Table,FieldName,WhereClause);

  if T<>nil then

  try

    if (T.FieldCount<>1) or (T.fRowCount<=0) then

      exit;

    // get row values

    SetLength(Data,T.fRowCount);

    for i := 1 to T.fRowCount do // ignore fResults[0] i.e. field name

      Data[i-1] := T.fResults[i];

    result := true;

  finally

    T.Free;

  end;

end;



function TSQLRest.OneFieldValues(Table: TSQLRecordClass; const FieldName,

  WhereClause: RawUTF8; Strings: TStrings; IDToIndex: PID=nil): Boolean;

var Row: integer;

    aID: TID;

    T: TSQLTableJSON;

begin

  result := false;

  if (Strings<>nil) and (self<>nil) and (Table<>nil) then

  try

    {$ifndef LVCL}

    Strings.BeginUpdate;

    {$endif}

    Strings.Clear;

    T := ExecuteList([Table],

      SQLFromSelect(Table.SQLTableName,'ID,'+FieldName,WhereClause,''));

    if T<>nil then

    try

      if (T.FieldCount=2) and (T.fRowCount>0) then begin

        for Row := 1 to T.fRowCount do begin // ignore Row 0 i.e. field names

          aID := GetInt64(T.Get(Row,0));

          Strings.AddObject(T.GetString(Row,1),pointer(aID));

          if (IDToIndex<>nil) and (aID=IDToIndex^) then begin

            IDToIndex^ := Row-1;

            IDToIndex := nil; // set once

          end;

        end;

        result := true;

      end;

    finally

      T.Free;

    end;

  finally

    {$ifndef LVCL}

    Strings.EndUpdate;

    {$endif}

  end;

  if IDToIndex<>nil then

    IDToIndex^ := -1; // ID not found

end;



function TSQLRest.OneFieldValues(Table: TSQLRecordClass; const FieldName,

  WhereClause, Separator: RawUTF8): RawUTF8;

var i, Len, SepLen, L: integer;

    Lens: TIntegerDynArray;

    T: TSQLTableJSON;

    P: PUTF8Char;

begin

  result := '';

  T := MultiFieldValues(Table,FieldName,WhereClause);

  if T<>nil then

  try

    if (T.FieldCount<>1) or (T.fRowCount<=0) then

      exit;

    // calculate row values CSV needed memory

    SetLength(Lens,T.fRowCount);

    SepLen := length(Separator);

    Len := 0;

    for i := 0 to T.fRowCount-1 do begin // ignore fResults[0] i.e. field name

      Lens[i] := StrLen(T.fResults[i]);

      inc(Len,Lens[i]+SepLen);

    end;

    dec(Len,SepLen);

    SetLength(result,Len);

    // add row values as CSV

    P := pointer(result);

    for i := 1 to T.fRowCount do begin

      L := Lens[i-1];

      if L<>0 then begin

        MoveFast(T.fResults[i]^,P^,L);

        inc(P,L);

      end;

      if i=T.fRowCount then

        break;

      MoveFast(pointer(Separator)^,P^,SepLen);

      inc(P,SepLen);

    end;

    //assert(P-pointer(result)=Len);

  finally

    T.Free;

  end;

end;



function TSQLRest.OneFieldValues(Table: TSQLRecordClass; const FieldName,

  WhereClause: RawUTF8; var Data: TInt64DynArray; SQL: PRawUTF8=nil): boolean;

var T: TSQLTableJSON;

    V: Int64;

    Prop: RawUTF8;

    P: PUTF8Char;

begin

  Data := nil;

  // handle naive expressions like SELECT ID from Table where ID=10

  if IsRowID(pointer(FieldName)) and (length(WhereClause)>2) then begin

    P := pointer(WhereClause);

    GetNextFieldProp(P,Prop);

    if IsRowIDShort(Prop) then

      case P^ of

      '=': begin

        inc(P);

        if PWord(P)^=ord(':')+ord('(')shl 8 then

          inc(P,2); // handle inlined parameters

        SetInt64(P,V);

        if V>0 then begin

          SetLength(Data,1);

          Data[0] := V;

          result := true;

          exit;

        end;

      end;

      'i','I': if P[1] in ['n','N'] then begin

        P := GotoNextNotSpace(P+2);

        if (P^='(') and (GotoNextNotSpace(P+1)^ in ['0'..'9']) then begin

          CSVToInt64DynArray(P+1,Data);

          if Data<>nil then begin

            result := true;

            exit;

          end;

        end;

      end;

      end;

  end;

  // retrieve the content from database

  result := false;

  T := MultiFieldValues(Table,FieldName,WhereClause);

  if T<>nil then

  try

    if (T.FieldCount<>1) or (T.fRowCount<=0) then

      exit;

    T.GetRowValues(0,Data);

    if SQL<>nil then

      SQL^ := T.QuerySQL;

    result := true;

  finally

    T.Free;

  end;

end;



function TSQLRest.SQLComputeForSelect(Table: TSQLRecordClass;

  const FieldNames, WhereClause: RawUTF8): RawUTF8;

begin

  result := '';

  if (self=nil) or (Table=nil) then

    exit;

  if FieldNames='' then

    result := Model.Props[Table].SQLFromSelectWhere('*',WhereClause) else

    with Table.RecordProps do

    if FieldNames='*' then

      result := SQLFromSelect(SQLTableName,SQLTableRetrieveAllFields,WhereClause,'') else

    if (PosEx(RawUTF8(','),FieldNames,1)=0) and

       (PosEx(RawUTF8('('),FieldNames,1)=0) and

       not IsFieldName(FieldNames) then

      result := '' else // prevent SQL error

      result := SQLFromSelect(SQLTableName,FieldNames,WhereClause,'');

end;



function TSQLRest.MultiFieldValues(Table: TSQLRecordClass;

  const FieldNames, WhereClause: RawUTF8): TSQLTableJSON;

var sql: RawUTF8;

begin

  sql := SQLComputeForSelect(Table,FieldNames,WhereClause);

  if sql='' then

    result := nil else

    result := ExecuteList([Table],sql);

end;



function TSQLRest.MultiFieldValues(Table: TSQLRecordClass; const FieldNames: RawUTF8;

  const WhereClauseFormat: RawUTF8; const BoundsSQLWhere: array of const): TSQLTableJSON;

begin

  result := MultiFieldValues(Table,FieldNames,FormatUTF8(

    WhereClauseFormat,[],BoundsSQLWhere));

end;



function TSQLRest.MultiFieldValues(Table: TSQLRecordClass;

  const FieldNames: RawUTF8; const WhereClauseFormat: RawUTF8;

  const Args, Bounds: array of const): TSQLTableJSON;

begin

  result := MultiFieldValues(Table,FieldNames,FormatUTF8(WhereClauseFormat,Args,Bounds));

end;



function TSQLRest.MultiFieldValue(Table: TSQLRecordClass;

  const FieldName: array of RawUTF8; var FieldValue: array of RawUTF8;

  const WhereClause: RawUTF8): boolean;

var SQL: RawUTF8;

    n,i: integer;

    T: TSQLTableJSON;

begin

  result := false;

  n := length(FieldName);

  if (self<>nil) and (Table<>nil) and (n=length(FieldValue)) then

  with Table.RecordProps do begin

    if (n=1) and IdemPChar(pointer(FieldName[0]),'COUNT(*)') then

      SQL := 'SELECT COUNT(*) FROM '+SQLTableName+SQLFromWhere(WhereClause) else begin

      for i := 0 to high(FieldName) do

        if not IsFieldNameOrFunction(FieldName[i]) then

          exit else // prevent SQL error or security breach

          if SQL='' then

            SQL := 'SELECT '+FieldName[i] else

            SQL := SQL+','+FieldName[i];

      SQL := SQL+' FROM '+SQLTableName+SQLFromWhere(WhereClause)+' LIMIT 1';

    end;

    T := ExecuteList([Table],SQL);

    if T<>nil then

    try

      if (T.FieldCount<>length(FieldName)) or (T.fRowCount<=0) then

        exit;

      // get field values from the first (and unique) row

      for i := 0 to T.FieldCount-1 do

        FieldValue[i] := T.fResults[T.FieldCount+i];

      result := true;

    finally

      T.Free;

    end;

  end;

end;



function TSQLRest.Retrieve(const SQLWhere: RawUTF8; Value: TSQLRecord;

  const aCustomFieldsCSV: RawUTF8): boolean;

var T: TSQLTable;

begin

  result := false;

  if (self=nil) or (Value=nil) then

    exit;

  T := MultiFieldValues(PSQLRecordClass(Value)^,aCustomFieldsCSV,SQLWhere);

  if T<>nil then

    try

      if T.fRowCount>=1 then begin

        Value.FillFrom(T,1); // fetch data from first result row

        result := true;

      end else

        Value.fID := 0;

    finally

      T.Free;

    end;

end;



function TSQLRest.RetrieveList(Table: TSQLRecordClass; const FormatSQLWhere: RawUTF8;

  const BoundsSQLWhere: array of const; const aCustomFieldsCSV: RawUTF8): TObjectList;

var T: TSQLTable;

begin

  result := nil;

  if (self=nil) or (Table=nil) then

    exit;

  T := MultiFieldValues(Table,aCustomFieldsCSV,FormatSQLWhere,BoundsSQLWhere);

  if T<>nil then

  try

    result := TObjectList.Create;

    T.ToObjectList(result,Table);

  finally

    T.Free;

  end;

end;



function TSQLRest.RetrieveListJSON(Table: TSQLRecordClass; const FormatSQLWhere: RawUTF8;

  const BoundsSQLWhere: array of const; const aCustomFieldsCSV: RawUTF8;

  aForceAJAX: boolean): RawJSON;

begin

  result := RetrieveListJSON(Table,

    FormatUTF8(FormatSQLWhere,[],BoundsSQLWhere),aCustomFieldsCSV,aForceAJAX)

end;



function TSQLRest.RetrieveListJSON(Table: TSQLRecordClass; const SQLWhere: RawUTF8;

  const aCustomFieldsCSV: RawUTF8; aForceAJAX: boolean): RawJSON;

var sql: RawUTF8;

begin

  sql := SQLComputeForSelect(Table,aCustomFieldsCSV,SQLWhere);

  if sql='' then

    result := '' else

    result := EngineList(sql,aForceAJAX);

end;



function TSQLRest.RetrieveListObjArray(var ObjArray; Table: TSQLRecordClass;

  const FormatSQLWhere: RawUTF8; const BoundsSQLWhere: array of const;

  const aCustomFieldsCSV: RawUTF8): boolean;

var T: TSQLTable;

begin

  result := false;

  if (self=nil) or (Table=nil) then

    exit;

  T := MultiFieldValues(Table,aCustomFieldsCSV,FormatSQLWhere,BoundsSQLWhere);

  if T<>nil then

  try

    result := T.ToObjArray(ObjArray,Table);

  finally

    T.Free;

  end;

end;



procedure TSQLRest.AppendListAsJsonArray(Table: TSQLRecordClass;

  const FormatSQLWhere: RawUTF8; const BoundsSQLWhere: array of const;

  const OutputFieldName: RawUTF8; W: TJSONSerializer; const CustomFieldsCSV: RawUTF8);

var Rec: TSQLRecord;

begin

  if (self=nil) or (Table=nil) or (W=nil) then

    exit;

  Rec := Table.CreateAndFillPrepare(Self,FormatSQLWhere,BoundsSQLWhere,CustomFieldsCSV);

  try

    Rec.AppendFillAsJsonArray(OutputFieldName,W,Rec.fFill.TableMapFields);

  finally

    Rec.Free;

  end;

end;



{$ifndef NOVARIANTS}

function TSQLRest.RetrieveDocVariantArray(Table: TSQLRecordClass;

  const ObjectName: RawUTF8;

  const FormatSQLWhere: RawUTF8; const BoundsSQLWhere: array of const;

  const CustomFieldsCSV: RawUTF8; FirstRecordID,LastRecordID: PID): variant;

var T: TSQLTable;

    res: variant;

begin

  TVarData(res).VType := varNull;

  if (self<>nil) and (Table<>nil) then begin

    T := MultiFieldValues(Table,CustomFieldsCSV,FormatSQLWhere,BoundsSQLWhere);

    if T<>nil then

    try

      T.ToDocVariant(res,false); // readonly=false -> TDocVariant dvArray

      if FirstRecordID<>nil then

        FirstRecordID^ := T.IDColumnHiddenValue(1);

      if LastRecordID<>nil then

        LastRecordID^ := T.IDColumnHiddenValue(T.fRowCount);

    finally

      T.Free;

    end;

  end;

  if ObjectName<>'' then

    result := _ObjFast([ObjectName,res]) else

    result := res;

end;



function TSQLRest.RetrieveOneFieldDocVariantArray(Table: TSQLRecordClass;

  const FieldName, FormatSQLWhere: RawUTF8;

  const BoundsSQLWhere: array of const): variant;

var T: TSQLTable;

    row: Integer;

    res: TDocVariantData absolute result;

begin

  VarClear(result);

  if (self<>nil) and (Table<>nil) then begin

    T := MultiFieldValues(Table,FieldName,FormatSQLWhere,BoundsSQLWhere);

    if T<>nil then

    try

      res.InitFast(T.RowCount,dvArray);

      res.SetCount(T.RowCount); 

      for row := 1 to T.RowCount do

        T.GetAsVariant(row,0,res.Values[row-1],false,false,false,JSON_OPTIONS_FAST);

    finally

      T.Free;

    end;

  end;

end;



function TSQLRest.RetrieveDocVariantArray(Table: TSQLRecordClass;

  const ObjectName, CustomFieldsCSV: RawUTF8; FirstRecordID,LastRecordID: PID): variant;

begin

  result := RetrieveDocVariantArray(Table,ObjectName,'',[],CustomFieldsCSV,

    FirstRecordID,LastRecordID);

end;



function TSQLRest.RetrieveDocVariant(Table: TSQLRecordClass;

  const FormatSQLWhere: RawUTF8; const BoundsSQLWhere: array of const;

  const CustomFieldsCSV: RawUTF8): variant;

var T: TSQLTable;

    bits: TSQLFieldBits;

    Rec: TSQLRecord;

    ID: TID;

begin

  SetVariantNull(result);

  if (self<>nil) and (Table<>nil) then begin

    with Table.RecordProps do // optimized primary key direct access

    if Cache.IsCached(Table) and (length(BoundsSQLWhere)=1) and

       VarRecToInt64(BoundsSQLWhere[0],Int64(ID)) and

       FieldBitsFromCSV(CustomFieldsCSV,bits) then

      if IsZero(bits) then

        exit else

      if bits-SimpleFieldsBits[soSelect]=[] then

        if IdemPropNameU('RowID=?',FormatSQLWhere) or

           IdemPropNameU('ID=?',FormatSQLWhere) then begin

          Rec := Table.Create(self,ID);

          try

            Rec.GetAsDocVariant(True,bits,result);

          finally

            Rec.Free;

          end;

          exit;

        end;

    T := MultiFieldValues(Table,CustomFieldsCSV,FormatSQLWhere,BoundsSQLWhere);

    if T<>nil then

    try

      T.ToDocVariant(1,result)

    finally

      T.Free;

    end;

  end;

end;



{$endif}



function TSQLRest.Retrieve(aID: TID; Value: TSQLRecord;

  ForUpdate: boolean): boolean;

var TableIndex: integer; // used by EngineRetrieve() for SQL statement caching

    Resp: RawUTF8;

begin // this version handles locking and use fast EngineRetrieve() method

  // check parameters

  result := false;

  if Value=nil  then

    exit; // avoid GPF

  Value.fID := 0;

  if (self=nil) or (aID=0) then

    exit;

  TableIndex := Model.GetTableIndexExisting(PSQLRecordClass(Value)^);

  // try to lock before retrieval (if ForUpdate)

  if ForUpdate and not Model.Lock(TableIndex,aID) then

    exit;

  // try to retrieve existing JSON from internal cache

  Resp := fCache.Retrieve(TableIndex,aID);

  if Resp='' then begin

    // get JSON object '{...}' in Resp from corresponding EngineRetrieve() method

    Resp := EngineRetrieve(TableIndex,aID);

    if Resp='' then begin

      fCache.NotifyDeletion(TableIndex,aID);

      exit;

    end;

    fCache.Notify(Tableindex,aID,Resp,soSelect);

  end;

  Value.fID := aID; // Resp may not contain the "RowID": field after Update

  // fill Value from JSON if was correctly retrieved

  Value.FillFrom(Resp);

  result := true;

end;



function TSQLRest.Retrieve(const WhereClauseFmt: RawUTF8;

  const Args,Bounds: array of const; Value: TSQLRecord; const aCustomFieldsCSV: RawUTF8): boolean;

var where: RawUTF8;

begin

  where := FormatUTF8(WhereClauseFmt,Args,Bounds);

  result := Retrieve(where,Value,aCustomFieldsCSV);

end;



function TSQLRest.Retrieve(Reference: TRecordReference; ForUpdate: boolean): TSQLRecord;

var aClass: TSQLRecordClass;

begin

  result := nil;

  if (self=nil) or (RecordRef(Reference).ID=0) then

    exit;

  aClass := RecordRef(Reference).Table(Model);

  if aClass=nil then

    exit;

  result := aClass.Create(self,RecordRef(Reference).ID,ForUpdate);

  if result.fID=0 then

    FreeAndNil(result); // error during value retrieval

end;



function TSQLRest.Retrieve(aPublishedRecord, aValue: TSQLRecord): boolean;

begin

  result := Retrieve(aPublishedRecord.ID,aValue);

end;



function TSQLRest.UnLock(Rec: TSQLRecord): boolean;

begin

  if (self=nil) or (Rec=nil) or (Rec.fID<=0) then

    result := false else

    result := UnLock(PSQLRecordClass(Rec)^,Rec.fID);

end;



procedure TSQLRest.Commit(SessionID: cardinal; RaiseException: boolean);

begin

  if self<>nil then begin

    fAcquireExecution[execORMWrite].Safe.Lock;

    try

      if (fTransactionActiveSession<>0) and

         (fTransactionActiveSession=SessionID) then begin

        fTransactionActiveSession := 0; // by default, just release flag

        fTransactionTable := nil;

      end;

    finally

      fAcquireExecution[execORMWrite].Safe.UnLock;

    end;

  end;

end;



procedure TSQLRest.RollBack(SessionID: cardinal);

begin

  if self<>nil then begin

    fAcquireExecution[execORMWrite].Safe.Lock;

    try

      if (fTransactionActiveSession<>0) and

         (fTransactionActiveSession=SessionID) then begin

        fTransactionActiveSession := 0; // by default, just release flag

        fTransactionTable := nil;

      end;

    finally

      fAcquireExecution[execORMWrite].Safe.UnLock;

    end;

  end;

end;



function TSQLRest.TransactionBegin(aTable: TSQLRecordClass; SessionID: cardinal): boolean;

begin

  result := false;

  fAcquireExecution[execORMWrite].Safe.Lock;

  try

    if fTransactionActiveSession=0 then begin // nested transactions are not allowed

      fTransactionActiveSession := SessionID;

      fTransactionTable := aTable;

      result := true;

    end;

  finally

    fAcquireExecution[execORMWrite].Safe.UnLock;

  end;

end;



function TSQLRest.TransactionActiveSession: cardinal;

begin

  if self=nil then

    result := 0 else begin

    fAcquireExecution[execORMWrite].Safe.Lock;

    try

      result := fTransactionActiveSession;

    finally

      fAcquireExecution[execORMWrite].Safe.UnLock;

    end;

  end;

end;



function TSQLRest.BatchSend(Batch: TSQLRestBatch;

  var Results: TIDDynArray): integer;

var Data: RawUTF8;

begin

  result := HTML_BADREQUEST;

  if (self=nil) or (Batch=nil) then // no opened BATCH sequence

    exit;

  if Batch.PrepareForSending(Data) then

    if Data='' then // i.e. Batch.Count=0

      result := HTML_SUCCESS else

      try

        result := EngineBatchSend(Batch.Table,Data,Results,Batch.Count);

      except

        on Exception do // e.g. from TSQLRestServer.EngineBatchSend()

          result := HTML_SERVERERROR;

      end;

end;



function TSQLRest.BatchSend(Batch: TSQLRestBatch): integer;

var Res: TIDDynArray;

begin

  result := BatchSend(Batch,Res);

end;



function TSQLRest.RecordCanBeUpdated(Table: TSQLRecordClass; ID: TID;

  Action: TSQLEvent; ErrorMsg: PRawUTF8=nil): boolean;

begin

  result := true; // accept by default -> override this method to customize this

end;



function TSQLRest.Delete(Table: TSQLRecordClass; ID: TID): boolean;

var TableIndex: integer;

begin

  TableIndex := Model.GetTableIndexExisting(Table);

  if not RecordCanBeUpdated(Table,ID,seDelete) then

    result := false else begin

    fCache.NotifyDeletion(TableIndex,ID);

    result := EngineDelete(TableIndex,ID);

  end;

end;



function TSQLRest.InternalDeleteNotifyAndGetIDs(Table: TSQLRecordClass;

  const SQLWhere: RawUTF8; var IDs: TIDDynArray): boolean;

var i: integer;

begin

  result := false;

  if OneFieldValues(Table,'RowID',SQLWhere,TInt64DynArray(IDs)) and

     (IDs<>nil) then begin

    for i := 0 to high(IDs) do

      if not RecordCanBeUpdated(Table,IDs[i],seDelete) then

        exit;

    for i := 0 to high(IDs) do

      fCache.NotifyDeletion(Table,IDs[i]);

  end;

  result := true;

end;



function TSQLRest.Delete(Table: TSQLRecordClass; const SQLWhere: RawUTF8): boolean;

var IDs: TIDDynArray;

begin

  if InternalDeleteNotifyAndGetIDs(Table,SQLWhere,IDs) then

    result := EngineDeleteWhere(Model.GetTableIndexExisting(Table),SQLWhere,IDs) else

    result := false;

end;



function TSQLRest.Delete(Table: TSQLRecordClass; const FormatSQLWhere: RawUTF8;

  const BoundsSQLWhere: array of const): boolean;

begin

  result := Delete(Table,FormatUTF8(FormatSQLWhere,[],BoundsSQLWhere));

end;



function TSQLRest.Update(Value: TSQLRecord; const CustomFields: TSQLFieldBits;

  DoNotAutoComputeFields: boolean): boolean;

var JSONValues: RawUTF8;

    TableIndex: integer;

    FieldBits: TSQLFieldBits;

begin

  if (self=nil) or (Value=nil) or (Value.fID=0) or

    not RecordCanBeUpdated(PSQLRecordClass(Value)^,Value.fID,seUpdate) then begin

    result := false; // current user don't have enough right to update this record

    exit;

  end;

  TableIndex := Model.GetTableIndexExisting(PSQLRecordClass(Value)^);

  if not DoNotAutoComputeFields then

    Value.ComputeFieldsBeforeWrite(self,seUpdate); // update sftModTime fields

  if IsZero(CustomFields) then

    if (Value.fFill<>nil) and (Value.fFill.Table<>nil) and

       (Value.fFill.fTableMapRecordManyInstances=nil) then

      // within FillPrepare/FillOne loop: update ID, TModTime and mapped fields

      FieldBits := Value.fFill.fTableMapFields+Value.RecordProps.FieldBits[sftModTime] else

      // update all simple/custom fields (also for FillPrepareMany)

      FieldBits := Value.RecordProps.SimpleFieldsBits[soUpdate] else

    // CustomFields<>[] -> update specified (and TModTime fields)

    if DoNotAutoComputeFields then

      FieldBits := CustomFields else

      FieldBits := CustomFields+Value.RecordProps.FieldBits[sftModTime];

  if IsZero(FieldBits) then begin

    result := true; // a TSQLRecord with NO simple fields (e.g. ID/blob pair)

    exit;

  end;

  fCache.Notify(Value,soUpdate); // will serialize Value (JSONValues may not be enough)

  JSONValues := Value.GetJSONValues(true,false,FieldBits);

  result := EngineUpdate(TableIndex,Value.fID,JSONValues);

end;



function TSQLRest.Update(Value: TSQLRecord; const CustomCSVFields: RawUTF8;

  DoNotAutoComputeFields: boolean): boolean;

begin

  if (self=nil) or (Value=nil) then

    result := false else

    result := Update(Value,Value.RecordProps.FieldBitsFromCSV(CustomCSVFields),

      DoNotAutoComputeFields);

end;



function TSQLRest.Update(aTable: TSQLRecordClass; aID: TID;

  const aSimpleFields: array of const): boolean;

var Value: TSQLRecord;

begin

  result := false; // means error

  if (self=nil) or (aTable=nil) or (aID=0) then

    exit;

  Value := aTable.Create;

  try

    if not Value.SimplePropertiesFill(aSimpleFields) then

      exit;

    Value.fID := aID;

    result := Update(Value);

  finally

    Value.Free;

  end;

end;



function TSQLRest.UpdateField(Table: TSQLRecordClass; ID: TID;

  const FieldName: RawUTF8; const FieldValue: array of const): boolean;

begin

  result := UpdateField(Table,'RowID',[ID],FieldName,FieldValue);

end;



function TSQLRest.UpdateField(Table: TSQLRecordClass;

  const WhereFieldName: RawUTF8; const WhereFieldValue: array of const;

  const FieldName: RawUTF8; const FieldValue: array of const): boolean;

var TableIndex: integer;

    SetValue,WhereValue: RawUTF8;

begin

  result := false;

  if (length(FieldValue)<>1) or (WhereFieldName='') or (length(WhereFieldValue)<>1) then

    exit;

  VarRecToInlineValue(WhereFieldValue[0],WhereValue);

  VarRecToInlineValue(FieldValue[0],SetValue);

  TableIndex := Model.GetTableIndexExisting(Table);

  result := EngineUpdateField(TableIndex,FieldName,SetValue,WhereFieldName,WhereValue);

end;



{$ifndef NOVARIANTS}



function TSQLRest.UpdateField(Table: TSQLRecordClass; ID: TID;

  const FieldName: RawUTF8; const FieldValue: Variant): boolean;

begin

  result := UpdateField(Table,'RowID',ID,FieldName,FieldValue);

end;



function TSQLRest.UpdateField(Table: TSQLRecordClass;

  const WhereFieldName: RawUTF8; const WhereFieldValue: Variant;

  const FieldName: RawUTF8; const FieldValue: Variant): boolean;

var TableIndex: integer;

    SetValue,WhereValue: RawUTF8;

begin

  VariantToInlineValue(WhereFieldValue,WhereValue);

  VariantToInlineValue(FieldValue,SetValue);

  TableIndex := Model.GetTableIndexExisting(Table);

  result := EngineUpdateField(TableIndex,FieldName,SetValue,WhereFieldName,WhereValue);

end;



function TSQLRest.UpdateField(Table: TSQLRecordClass;

  const IDs: array of Int64; const FieldName: RawUTF8; const FieldValue: variant): boolean;

var csv: RawUTF8;

    SetValue: RawUTF8;

begin

  VariantToInlineValue(FieldValue,SetValue);

  csv := Int64DynArrayToCSV(IDs,length(IDs));

  result := ExecuteFmt('update % set %=:(%): where rowid in (%)',

    [Table.SQLTableName,FieldName,SetValue,csv]);

end;



{$endif NOVARIANTS}



function TSQLRest.UpdateFieldIncrement(Table: TSQLRecordClass; ID: TID;

  const FieldName: RawUTF8; Increment: Int64): boolean;

var tableIndex: integer;

begin

  if ID<>0 then begin

    tableIndex := Model.GetTableIndexExisting(Table);

    result := EngineUpdateFieldIncrement(tableIndex,ID,FieldName,Increment);

    if fCache<>nil then

      fCache.NotifyDeletion(tableIndex,ID);

  end else

    result := false;

end;



procedure TSQLRest.GetJSONValuesForAdd(TableIndex: integer; Value: TSQLRecord;

  ForceID, DoNotAutoComputeFields, WithBlobs: boolean;

  CustomFields: PSQLFieldBits; var result: RawUTF8);

var fields: TSQLFieldBits;

begin

  if not DoNotAutoComputeFields then // update TModTime/TCreateTime fields

    Value.ComputeFieldsBeforeWrite(self,seAdd);

  if Model.TableProps[TableIndex].Kind in INSERT_WITH_ID then

    ForceID := true;

  if (Model.fIDGenerator<>nil) and (Model.fIDGenerator[TableIndex]<>nil) then begin

    Value.fID := Model.fIDGenerator[TableIndex].ComputeNew;

    ForceID := true;

  end else

    if Value.fID=0 then

      ForceID := false;

  if CustomFields <> nil then

    if DoNotAutoComputeFields then

      fields := CustomFields^ else

      fields := CustomFields^+Value.RecordProps.ComputeBeforeAddFieldsBits else

    if withBlobs then

      fields := Value.RecordProps.CopiableFieldsBits else

      fields := Value.RecordProps.SimpleFieldsBits[soInsert];

  if (not ForceID) and IsZero(fields) then

    result := '' else

    result := Value.GetJSONValues(true,ForceID,fields);

end;



function TSQLRest.InternalAdd(Value: TSQLRecord; SendData: boolean;

  CustomFields: PSQLFieldBits; ForceID, DoNotAutoComputeFields: boolean): TID;

var json: RawUTF8;

    TableIndex: integer;

begin

  if Value=nil then begin

    result := 0;

    exit;

  end;

  TableIndex := Model.GetTableIndexExisting(PSQLRecordClass(Value)^);

  if SendData then

    GetJSONValuesForAdd(TableIndex,Value,ForceID,DoNotAutoComputeFields,false,CustomFields,json) else

    json := '';

  // on success, returns the new ROWID value; on error, returns 0

  result := EngineAdd(TableIndex,json); // will call static if necessary

  // on success, Value.ID is updated with the new ROWID

  Value.fID := result;

  if SendData and (result<>0) then

    fCache.Notify(PSQLRecordClass(Value)^,result,json,soInsert);

end;



function TSQLRest.Add(Value: TSQLRecord; SendData,ForceID,DoNotAutoComputeFields: boolean): TID;

begin

  result := InternalAdd(Value,SendData,nil,ForceID,DoNotAutoComputeFields);

end;



function TSQLRest.Add(Value: TSQLRecord; const CustomCSVFields: RawUTF8;

  ForceID, DoNotAutoComputeFields: boolean): TID;

var f: TSQLFieldBits;

begin

  with Value.RecordProps do

    if CustomCSVFields='*' then // FieldBitsFromCSV('*') would use [soSelect]

      f := SimpleFieldsBits[soInsert] else

      f := FieldBitsFromCSV(CustomCSVFields);

  result := InternalAdd(Value,true,@f,ForceID,DoNotAutoComputeFields);

end;



function TSQLRest.Add(Value: TSQLRecord; const CustomFields: TSQLFieldBits;

  ForceID, DoNotAutoComputeFields: boolean): TID;

begin

  result := InternalAdd(Value,true,@CustomFields,ForceID,DoNotAutoComputeFields);

end;



function TSQLRest.Add(aTable: TSQLRecordClass; const aSimpleFields: array of const;

  ForcedID: TID=0): TID;

var Value: TSQLRecord;

begin

  result := 0; // means error

  if (self=nil) or (aTable=nil) then

    exit;

  Value := aTable.Create;

  try

    if Value.SimplePropertiesFill(aSimpleFields) then begin

      if ForcedID<>0 then

        Value.fID := ForcedID;

      result := Add(Value,true,(ForcedID<>0));

    end;

  finally

    Value.Free;

  end;

end;



function TSQLRest.AddWithBlobs(Value: TSQLRecord;

  ForceID, DoNotAutoComputeFields: boolean): TID;

var TableIndex: integer;

    json: RawUTF8;

begin

  if Value=nil then begin

    result := 0;

    exit;

  end;

  TableIndex := Model.GetTableIndexExisting(PSQLRecordClass(Value)^);

  GetJSONValuesForAdd(TableIndex,Value,ForceID,DoNotAutoComputeFields,true,nil,json);

  // on success, returns the new ROWID value; on error, returns 0

  result := EngineAdd(TableIndex,json); // will call static if necessary

  // on success, Value.ID is updated with the new ROWID

  Value.fID := result;

  // here fCache.Notify is not called, since the JSONValues is verbose

end;



function TSQLRest.AddOrUpdate(Value: TSQLRecord; ForceID: boolean): TID;

begin

  if (self=nil) or (Value=nil) then begin

    result := 0;

    exit;

  end;

  if ForceID or (Value.fID=0) then begin

    result := Add(Value,true,ForceID);

    if (result<>0) or (Value.fID=0) then

      exit;

  end;

  if Update(Value) then

    result := Value.fID else

    result := 0;

end;



procedure TSQLRest.QueryAddCustom(aTypeInfo: pointer; aEvent: TSQLQueryEvent;

  const aOperators: TSQLQueryOperators);

var Enum: PEnumType;

    i,n: integer;

begin

  if (self=nil) or not Assigned(aEvent)  or

     (aTypeInfo=nil) or (PTypeInfo(aTypeInfo)^.Kind<>tkEnumeration) then

    exit;

  Enum := PTypeInfo(aTypeInfo)^.EnumBaseType;

  n := length(QueryCustom);

  SetLength(QueryCustom,n+Enum^.MaxValue+1);

  for i := 0 to Enum^.MaxValue do

    with QueryCustom[i+n] do begin

      EnumType := Enum;

      EnumIndex := i;

      Event := aEvent;

      Operators := aOperators;

    end;

end;



class function TSQLRest.QueryIsTrue(aTable: TSQLRecordClass; aID: TID;

  FieldType: TSQLFieldType; Value: PUTF8Char; Operator: integer;

  Reference: PUTF8Char): boolean;

begin // use mostly the same fast comparison functions as for sorting

  result := false;

  if aID=0 then

    exit; // invalid input field

  if Reference=nil then

    exit; // avoid most GPF

  if FieldType=sftMany then

    exit; // nothing is stored directly, but in a separate pivot table

  if FieldType in [sftUnknown,sftBlob,sftBlobDynArray,sftBlobCustom,sftObject,

    sftUTF8Custom{$ifndef NOVARIANTS},sftVariant,sftNullable{$endif}] then

    FieldType := sftUTF8Text; // unknown or blob fields are compared as UTF-8

  { TODO: handle proper sftBlobDynArray/sftBlobCustom/sftBlobRecord comparison }

  case TSQLQueryOperator(Operator) of

    qoNone:

      result := true;

    qoEqualTo:

      result := SQLFieldTypeComp[FieldType](Value,Reference)=0;

    qoNotEqualTo:

      result := SQLFieldTypeComp[FieldType](Value,Reference)<>0;

    qoLessThan:

      result := SQLFieldTypeComp[FieldType](Value,Reference)<0;

    qoLessThanOrEqualTo:

      result := SQLFieldTypeComp[FieldType](Value,Reference)<=0;

    qoGreaterThan:

      result := SQLFieldTypeComp[FieldType](Value,Reference)>0;

    qoGreaterThanOrEqualTo:

      result := SQLFieldTypeComp[FieldType](Value,Reference)>=0;

    qoEqualToWithCase:

      result := StrComp(Value,Reference)=0;

    qoNotEqualToWithCase:

      result := StrComp(Value,Reference)<>0;

    qoContains:

      result := PosIU(Reference,Value)<>0;

    qoBeginWith:

      result := IdemPCharU(Value,Reference);

    qoSoundsLikeEnglish,

    qoSoundsLikeFrench,

    qoSoundsLikeSpanish:

      result := PSynSoundEx(Reference)^.UTF8(Value);

  end;

end;



function TSQLRest.RetrieveBlob(Table: TSQLRecordClass; aID: TID;

  const BlobFieldName: RawUTF8; out BlobStream: THeapMemoryStream): boolean;

var BlobData: TSQLRawBlob;

begin

  BlobStream := THeapMemoryStream.Create;

  result := RetrieveBlob(Table,aID,BlobFieldName,BlobData);

  if not result or (BlobData='') then

    exit;

  BlobStream.Write(pointer(BlobData)^,length(BlobData));

  BlobStream.Seek(0,soFromBeginning); // rewind

end;



function TSQLRest.UpdateBlob(Table: TSQLRecordClass; aID: TID;

  const BlobFieldName: RawUTF8; BlobData: TStream): boolean;

var Blob: TSQLRawBlob;

    L: integer;

begin

  result := false;

  if (self=nil) or (BlobData=nil) then

    exit;

  L := BlobData.Seek(0,soFromEnd);

  SetLength(Blob,L);

  BlobData.Seek(0,soFromBeginning);

  if BlobData.Read(pointer(Blob)^,L)<>L then

    exit;

  result := UpdateBlob(Table,aID,BlobFieldName,Blob);

end;



function TSQLRest.UpdateBlob(Table: TSQLRecordClass; aID: TID;

  const BlobFieldName: RawUTF8; BlobData: pointer; BlobSize: integer): boolean;

var Blob: TSQLRawBlob;

begin

  if (self=nil) or (BlobData=nil) or (BlobSize<0) then

    result := false else begin

    SetString(Blob,PAnsiChar(BlobData),BlobSize);

    result := UpdateBlob(Table,aID,BlobFieldName,Blob);

  end;

end;



function TSQLRest.RetrieveBlob(Table: TSQLRecordClass; aID: TID;

  const BlobFieldName: RawUTF8; out BlobData: TSQLRawBlob): boolean;

var BlobField: PPropInfo;

begin

  result := false;

  if (self=nil) or (aID<=0) then

    exit;

  BlobField := Table.RecordProps.BlobFieldPropFromRawUTF8(BlobFieldName);

  if BlobField=nil then

    exit;

  result := EngineRetrieveBlob(

    Model.GetTableIndexExisting(Table),aID,BlobField,BlobData);

end;



function TSQLRest.UpdateBlob(Table: TSQLRecordClass; aID: TID;

  const BlobFieldName: RawUTF8; const BlobData: TSQLRawBlob): boolean;

var BlobField: PPropInfo;

begin

  result := false;

  if (self=nil) or (aID<=0) or not RecordCanBeUpdated(Table,aID,seUpdate) then

    exit;

  BlobField := Table.RecordProps.BlobFieldPropFromRawUTF8(BlobFieldName);

  if BlobField=nil then

    exit;

  result := EngineUpdateBlob(

    Model.GetTableIndexExisting(Table),aID,BlobField,BlobData);

end;



function TSQLRest.UpdateBlobFields(Value: TSQLRecord): boolean;

var BlobData: RawByteString;

    TableIndex, i: integer;

begin

  result := false;

  if (Value=nil) or (Value.fID<=0) then

    exit;

  with Value.RecordProps do

  if BlobFields<>nil then begin

    TableIndex := self.fModel.GetTableIndexExisting(PSQLRecordClass(Value)^);

    for i := 0 to high(BlobFields) do begin

      BlobFields[i].PropInfo.GetLongStrProp(Value,BlobData);

      if not EngineUpdateBlob(TableIndex,Value.fID,BlobFields[i].PropInfo,BlobData) then

        exit;

    end;

  end;

  result := true;

end;



function TSQLRest.RetrieveBlobFields(Value: TSQLRecord): boolean;

var BlobData: TSQLRawBlob;

    TableIndex, i: integer;

begin

  result := false;

  if (Self=nil) or (Value=nil) or (Value.fID<=0) then

    exit;

  with Value.RecordProps do

  if BlobFields<>nil then begin

    TableIndex := self.fModel.GetTableIndexExisting(PSQLRecordClass(Value)^);

    for i := 0 to high(BlobFields) do

      if EngineRetrieveBlob(TableIndex,Value.fID,BlobFields[i].PropInfo,BlobData) then

        BlobFields[i].PropInfo.SetLongStrProp(Value,BlobData) else

        exit;

  end;

  result := true;

end;



function TSQLRest.TableRowCount(Table: TSQLRecordClass): Int64;

var T: TSQLTableJSON;

begin

  if (self=nil) or (Table=nil) then

    T := nil else

    T := ExecuteList([Table],'SELECT Count(*) FROM '+Table.RecordProps.SQLTableName);

  if T<>nil then

  try

    Result := T.GetAsInt64(1,0);

  finally

    T.Free;

  end else

    Result := -1;

end;



function TSQLRest.TableHasRows(Table: TSQLRecordClass): boolean;

var T: TSQLTableJSON;

begin

  if (self=nil) or (Table=nil) then

    T := nil else

    T := ExecuteList([Table],'SELECT RowID FROM '+Table.RecordProps.SQLTableName+' LIMIT 1');

  if T<>nil then

  try

    Result := T.fRowCount>0;

  finally

    T.Free;

  end else

    Result := false;

end;



function TSQLRest.TableMaxID(Table: TSQLRecordClass): TID;

var T: TSQLTableJSON;

begin

  if (self=nil) or (Table=nil) then

    T := nil else

    T := ExecuteList([Table],'SELECT max(RowID) FROM '+Table.RecordProps.SQLTableName);

  if T<>nil then

  try

    Result := T.GetAsInt64(1,0);

  finally

    T.Free;

  end else

    Result := -1;

end;



function TSQLRest.ExecuteList(const Tables: array of TSQLRecordClass; const SQL: RawUTF8): TSQLTableJSON;

var JSON: RawUTF8;

begin

  JSON := EngineList(SQL,false);

  if JSON<>'' then

    result := TSQLTableJSON.CreateFromTables(Tables,SQL,JSON) else

    result := nil;

end;



function TSQLRest.ExecuteJson(const Tables: array of TSQLRecordClass; const SQL: RawUTF8): RawJSON;

begin

  result := EngineList(SQL,false);

end;



function TSQLRest.Execute(const aSQL: RawUTF8): boolean;

begin

  result := EngineExecute(aSQL);

end;



function TSQLRest.ExecuteFmt(const SQLFormat: RawUTF8;

  const Args: array of const): boolean;

var SQL: RawUTF8;

begin

  FormatUTF8(SQLFormat,Args,SQL);

  result := EngineExecute(SQL);

end;



function TSQLRest.ExecuteFmt(const SQLFormat: RawUTF8;

  const Args, Bounds: array of const): boolean;

var SQL: RawUTF8;

begin

  SQL := FormatUTF8(SQLFormat,Args,Bounds);

  result := EngineExecute(SQL);

end;



function TSQLRest.MainFieldValue(Table: TSQLRecordClass; ID: TID;

   ReturnFirstIfNoUnique: boolean=false): RawUTF8;

begin

  if (self=nil) or (Table=nil) or (ID<=0) then

    result := '' else begin

    result := Table.RecordProps.MainFieldName(ReturnFirstIfNoUnique);

    if result<>'' then

      result := OneFieldValue(Table,Result,ID);

  end;

end;



function TSQLRest.MainFieldID(Table: TSQLRecordClass; const Value: RawUTF8): TID;

var aMainField: integer;

begin

  result := 0;

  if (self<>nil) and (Value<>'') and (Table<>nil) then

  with Table.RecordProps do begin

    aMainField := MainField[false];

    if aMainField>=0 then

      SetID(OneFieldValue(Table,'RowID',

        Fields.List[aMainField].Name+'=:('+QuotedStr(Value,'''')+'):'),result);

  end;

end;



function TSQLRest.MainFieldIDs(Table: TSQLRecordClass; const Values: array of RawUTF8;

  out IDs: TIDDynArray): boolean;

var aMainField, id: TID;

begin

  if (self<>nil) and (high(Values)>=0) and (Table<>nil) then

    if high(Values)=0 then begin // handle special case of one Values[] item

      id := MainFieldID(Table,Values[0]);

      if id>0 then begin

        SetLength(IDs,1);

        IDs[0] := id;

      end;

    end else

    with Table.RecordProps do begin // request all Values[] IDs at once

      aMainField := MainField[false];

      if aMainField>=0 then

        OneFieldValues(Table,'RowID',Fields.List[aMainField].Name+' in ('+

          RawUTF8ArrayToQuotedCSV(Values)+')',TInt64DynArray(IDs));

    end;

  result := IDs<>nil;

end;



function TSQLRest.FTSMatch(Table: TSQLRecordFTS3Class;

  const WhereClause: RawUTF8; var DocID: TIDDynArray): boolean;

begin // FTS3 tables don't have any ID, but RowID or DocID

  result := OneFieldValues(Table,'RowID',WhereClause,TInt64DynArray(DocID));

end;



function TSQLRest.FTSMatch(Table: TSQLRecordFTS3Class;

  const MatchClause: RawUTF8; var DocID: TIDDynArray;

  const PerFieldWeight: array of double; limit,offset: integer): boolean;

var WhereClause: RawUTF8;

    i: integer;

begin

  result := false;

  with Table.RecordProps do

    if length(PerFieldWeight)<>length(SimpleFields) then

      exit else

    WhereClause := FormatUTF8('% MATCH ? ORDER BY rank(matchinfo(%)',

      [SQLTableName,SQLTableName],[MatchClause]);

  for i := 0 to high(PerFieldWeight) do

    WhereClause := FormatUTF8('%,?',[WhereClause],[PerFieldWeight[i]]);

  WhereClause := WhereClause+') DESC';

  if limit>0 then

    WhereClause := FormatUTF8('% LIMIT % OFFSET %',[WhereClause,limit,offset]);

  result := FTSMatch(Table,WhereClause,DocID);

end;



function TSQLRest.GetServerTimeStamp: TTimeLog;

var Tix: cardinal;

begin

  Tix := GetTickCount shr 9; // resolution change 1 ms -> 512 ms

  if fServerTimeStampCacheTix=Tix then

    result := fServerTimeStampCacheValue.Value else begin

    fServerTimeStampCacheTix := Tix;

    fServerTimeStampCacheValue.From(NowUTC+fServerTimeStampOffset);

    result := fServerTimeStampCacheValue.Value;

  end;

end;



procedure TSQLRest.SetServerTimeStamp(const Value: TTimeLog);

begin

  fServerTimeStampOffset := PTimeLogBits(@Value)^.ToDateTime-NowUTC;

  if fServerTimeStampOffset=0 then

    fServerTimeStampOffset := 0.000001; // retrieve server date/time only once

end;



function TSQLRest.GetCache: TSQLRestCache;

begin

  if self=nil then

    result := nil else begin

    if fCache=nil then

      fCache := TSQLRestCache.Create(self);

    result := fCache;

  end;

end;



function TSQLRest.CacheOrNil: TSQLRestCache;

begin

  if self=nil then

    result := nil else

    result := fCache;

end;



function TSQLRest.CacheWorthItForTable(aTableIndex: cardinal): boolean;

begin

  result := true; // always worth caching by default

end;



procedure TSQLRest.BeginCurrentThread(Sender: TThread);

begin // nothing do to at this level -> see TSQLRestServer.BeginCurrentThread

end;



procedure TSQLRest.EndCurrentThread(Sender: TThread);

begin // most would be done e.g. in TSQLRestServer.EndCurrentThread

  {$ifdef WITHLOG}

  fLogClass.Add.NotifyThreadEnded;

  {$endif}

end;



function TSQLRest.GetAcquireExecutionMode(Cmd: TSQLRestServerURIContextCommand): TSQLRestServerAcquireMode;

begin

  result := fAcquireExecution[Cmd].Mode;

end;



procedure TSQLRest.SetAcquireExecutionMode(Cmd: TSQLRestServerURIContextCommand; Value: TSQLRestServerAcquireMode);

begin

  fAcquireExecution[Cmd].Mode := Value;

end;



function TSQLRest.GetAcquireExecutionLockedTimeOut(Cmd: TSQLRestServerURIContextCommand): cardinal;

begin

  result := fAcquireExecution[Cmd].LockedTimeOut;

end;



procedure TSQLRest.SetAcquireExecutionLockedTimeOut(Cmd: TSQLRestServerURIContextCommand; Value: cardinal);

begin

  fAcquireExecution[Cmd].LockedTimeOut := Value;

end;



function TSQLRest.InternalBatchStart(Method: TSQLURIMethod;

  BatchOptions: TSQLRestBatchOptions): boolean;

begin

  result := false;

end;



procedure TSQLRest.InternalBatchStop;

begin

  raise EORMException.CreateUTF8('Unexpected %.InternalBatchStop',[self]);

end;



function TSQLRest.EngineBatchSend(Table: TSQLRecordClass; const Data: RawUTF8;

  var Results: TIDDynArray; ExpectedResultsCount: integer): integer;

begin

  raise EORMException.CreateUTF8('BATCH not supported by %',[self]);

end;



{$ifdef ISDELPHI2010} // Delphi 2009 generics support is buggy :(



function TSQLRest.Service<T>: T;

var service: TServiceFactory;

begin

  service := fServices.Info(TypeInfo(T));

  if (service=nil) or not service.Get(result) then

    result := Default(T);

end;



function TSQLRest.RetrieveList<T>(const aCustomFieldsCSV: RawUTF8): TObjectList<T>;

begin

  result := RetrieveList<T>('',[],aCustomFieldsCSV);

end;



function TSQLRest.RetrieveList<T>(const FormatSQLWhere: RawUTF8;

  const BoundsSQLWhere: array of const; const aCustomFieldsCSV: RawUTF8): TObjectList<T>;

var Table: TSQLTable;

begin

  result := nil;

  if self=nil then

    exit;

  Table := MultiFieldValues(TSQLRecordClass(T),aCustomFieldsCSV,FormatSQLWhere,BoundsSQLWhere);

  if Table<>nil then

  try

    result := Table.ToObjectList<T>;

  finally

    Table.Free;

  end;

end;



{$endif}





{ TSQLRestCacheEntry }



procedure TSQLRestCacheEntry.Init;

begin

  Value.InitSpecific(TypeInfo(TSQLRestCacheEntryValueDynArray),

    Values,djInt64,@Count); // will search/sort by first ID: TID field

  Mutex.Init;

end;



procedure TSQLRestCacheEntry.Done;

begin

  Mutex.Done;

end;



procedure TSQLRestCacheEntry.Clear;

begin

  Mutex.Lock;

  try

    Value.Clear;

    CacheAll := false;

    CacheEnable := false;

    TimeOutMS := 0;

  finally

    Mutex.UnLock;

  end;

end;



procedure TSQLRestCacheEntry.FlushCacheEntry(Index: Integer);

begin

  if cardinal(Index)<cardinal(Count) then

    if CacheAll then

      Value.FastDeleteSorted(Index) else

      with Values[Index] do begin

        TimeStamp64 := 0;

        JSON := '';

      end;

end;



procedure TSQLRestCacheEntry.FlushCacheAllEntries;

var i: integer;

begin

  if not CacheEnable then

    exit;

  Mutex.Lock;

  try

    if CacheAll then

      Value.Clear else

      for i := 0 to Count-1 do

      with Values[i] do begin

        TimeStamp64 := 0;

        JSON := '';

      end;

  finally

    Mutex.UnLock;

  end;

end;



procedure TSQLRestCacheEntry.SetCache(aID: TID);

var Rec: TSQLRestCacheEntryValue;

    i: integer;

begin

  Mutex.Lock;

  try

    CacheEnable := true;

    if (not CacheAll) and (not Value.FastLocateSorted(aID,i)) and (i>=0) then begin

      Rec.ID := aID;

      Rec.TimeStamp64 := 0; // indicates no value cache yet

      Value.FastAddSorted(i,Rec);

    end; // do nothing if aID is already in Values[]

  finally

    Mutex.UnLock;

  end;

end;



procedure TSQLRestCacheEntry.SetJSON(aID: TID; const aJSON: RawUTF8);

var Rec: TSQLRestCacheEntryValue;

    i: integer;

begin

  Rec.ID := aID;

  Rec.TimeStamp64 := GetTickCount64;

  Rec.JSON := aJSON;

  Mutex.Lock;

  try

    if Value.FastLocateSorted(Rec,i) then

      Values[i] := Rec else

      if CacheAll and (i>=0) then

        Value.FastAddSorted(i,Rec);

  finally

    Mutex.UnLock;

  end;

end;



procedure TSQLRestCacheEntry.SetJSON(aRecord: TSQLRecord);

begin  // soInsert = include all fields

  SetJSON(aRecord.fID,aRecord.GetJSONValues(true,false,soInsert));

end;



function TSQLRestCacheEntry.RetrieveJSON(aID: TID; var aJSON: RawUTF8): boolean;

var i: integer;

begin

  result := false;

  Mutex.Lock;

  try

    i := Value.Find(aID); // fast binary search by first ID field

    if i>=0 then

      with Values[i] do

      if TimeStamp64<>0 then // 0 when there is no JSON value cached

        if (TimeOutMS<>0) and (GetTickCount64>TimeStamp64+TimeOutMS) then

          FlushCacheEntry(i) else begin

          aJSON := JSON;

          result := true; // found a non outdated serialized value in cache

        end;

  finally

    Mutex.UnLock;

  end;

end;



function TSQLRestCacheEntry.RetrieveJSON(aID: TID; aValue: TSQLRecord): boolean;

var JSON: RawUTF8;

begin

  if RetrieveJSON(aID,JSON) then begin

    aValue.FillFrom(JSON);

    aValue.fID := aID; // override RowID field (may be not present after Update)

    result := true;

  end else

    result := false;

end;





{ TSQLRestCache }



function TSQLRestCache.CachedEntries: cardinal;

var i,j: integer;

begin

  result := 0;

  if self<>nil then

    for i := 0 to high(fCache) do

      with fCache[i] do

      if CacheEnable then begin

        Mutex.Lock;

        try

          for j := 0 to Count-1 do

            if Values[j].TimeStamp64<>0 then

              inc(result);

        finally

          Mutex.UnLock;

        end;

      end;

end;



function TSQLRestCache.CachedMemory(FlushedEntriesCount: PInteger=nil): cardinal;

var i,j: integer;

    tix: Int64;

begin

  result := 0;

  if FlushedEntriesCount<>nil then

    FlushedEntriesCount^ := 0;

  if self<>nil then

  for i := 0 to high(fCache) do

    with fCache[i] do

    if CacheEnable and (Count>0) then begin

      tix := GetTickCount64-TimeOutMS;

      Mutex.Lock;

      try

        for j := Count-1 downto 0 do

          if Values[j].TimeStamp64<>0 then begin

            if (TimeOutMS<>0) and (tix>Values[j].TimeStamp64) then begin

              FlushCacheEntry(j);

              if FlushedEntriesCount<>nil then

                inc(FlushedEntriesCount^);

            end else

              inc(result,length(Values[j].JSON)+(sizeof(Values[j])+16));

        end;

      finally

        Mutex.UnLock;

      end;

    end;

end;



function TSQLRestCache.SetTimeOut(aTable: TSQLRecordClass; aTimeoutMS: Cardinal): boolean;

var i: integer;

begin

  result := false;

  if (self=nil) or (aTable=nil) then

    exit;

  i := Rest.Model.GetTableIndexExisting(aTable);

  if Rest.CacheWorthItForTable(i) then

    if Cardinal(i)<Cardinal(Length(fCache)) then

      with fCache[i] do begin

        Mutex.Lock;

        try

          TimeOutMS := aTimeOutMS;

        finally

          Mutex.UnLock;

        end;

        result := true;

      end;

end;



function TSQLRestCache.IsCached(aTable: TSQLRecordClass): boolean;

var i: cardinal;

begin

  result := false;

  if (self=nil) or (aTable=nil) then

    exit;

  i := Rest.Model.GetTableIndexExisting(aTable);

  if i<Cardinal(Length(fCache)) then

    if fCache[i].CacheEnable then

      result := true;

end;



function TSQLRestCache.SetCache(aTable: TSQLRecordClass): boolean;

var i: integer;

begin

  result := false;

  if (self=nil) or (aTable=nil) then

    exit;

  i := Rest.Model.GetTableIndexExisting(aTable);

  if Rest.CacheWorthItForTable(i) then

    if Cardinal(i)<Cardinal(Length(fCache)) then

      with fCache[i] do begin

        // global cache of all records of this table

        Mutex.Lock;

        try

          CacheEnable := true;

          CacheAll := True;

          Value.Clear;

          result := true;

        finally

          Mutex.UnLock;

        end;

      end;

end;



function TSQLRestCache.SetCache(aTable: TSQLRecordClass; aID: TID): boolean;

var i: cardinal;

begin

  result := false;

  if (self=nil) or (aTable=nil) or (aID<=0) then

    exit;

  i := Rest.Model.GetTableIndex(aTable);

  if i>=cardinal(Length(fCache)) then

    exit;

  if Rest.CacheWorthItForTable(i) then

    fCache[i].SetCache(aID);

  result := True;

end;



function TSQLRestCache.SetCache(aTable: TSQLRecordClass; const aIDs: array of TID): boolean;

var i: cardinal;

    j: integer;

begin

  result := false;

  if (self=nil) or (aTable=nil) or (length(aIDs)=0) then

    exit;

  i := Rest.Model.GetTableIndex(aTable);

  if i>=cardinal(Length(fCache)) then

    exit;

  if Rest.CacheWorthItForTable(i) then

    for j := 0 to high(aIDs) do

      fCache[i].SetCache(aIDs[j]);

  result := True;

end;



function TSQLRestCache.SetCache(aRecord: TSQLRecord): boolean;

begin

  if (self=nil) or (aRecord=nil) or (aRecord.fID<=0) then

    result := false else

    result := SetCache(PSQLRecordClass(aRecord)^,aRecord.fID);

end;



constructor TSQLRestCache.Create(aRest: TSQLRest);

var i: integer;

begin

  if aRest=nil then

    EBusinessLayerException.CreateUTF8('%.Create',[self]);

  fRest := aRest;

  SetLength(fCache,length(fRest.Model.Tables));

  for i := 0 to high(fCache) do

    fCache[i].Init;

end;



destructor TSQLRestCache.Destroy;

var i: integer;

begin

  for i := 0 to high(fCache) do

    fCache[i].Done;

  inherited;

end;



procedure TSQLRestCache.Clear;

var i: integer;

begin

  if self<>nil then

  for i := 0 to high(fCache) do

    fCache[i].Clear;

end;



procedure TSQLRestCache.Flush;

var i: integer;

begin

  if self<>nil then

  for i := 0 to high(fCache) do

    fCache[i].FlushCacheAllEntries; // include *CriticalSection(Mutex)

end;



procedure TSQLRestCache.Flush(aTable: TSQLRecordClass);

begin

  if self<>nil then // includes *CriticalSection(Mutex):

    fCache[fRest.Model.GetTableIndexExisting(aTable)].FlushCacheAllEntries;

end;



procedure TSQLRestCache.Flush(aTable: TSQLRecordClass; aID: TID);

begin

  if self<>nil then

    with fCache[fRest.Model.GetTableIndexExisting(aTable)] do

    if CacheEnable then begin

      Mutex.Lock;

      try

        FlushCacheEntry(Value.Find(aID));

      finally

        Mutex.UnLock;

      end;

    end;

end;



procedure TSQLRestCache.Flush(aTable: TSQLRecordClass; const aIDs: array of TID);

var i: integer;

begin

  if (self<>nil) and (length(aIDs)>0) then

    with fCache[fRest.Model.GetTableIndexExisting(aTable)] do

    if CacheEnable then begin

      Mutex.Lock;

      try

        for i := 0 to high(aIDs) do

          FlushCacheEntry(Value.Find(aIDs[i]));

      finally

        Mutex.UnLock;

      end;

    end;

end;



procedure TSQLRestCache.Notify(aTable: TSQLRecordClass; aID: TID;

  const aJSON: RawUTF8; aAction: TSQLOccasion);

begin

  if (self<>nil) and (aTable<>nil) and (aID>0) then

    Notify(fRest.Model.GetTableIndex(aTable),aID,aJSON,aAction);

end;



procedure TSQLRestCache.Notify(aRecord: TSQLRecord; aAction: TSQLOccasion);

var aTableIndex: cardinal;

begin

  if (self=nil) or (aRecord=nil) or (aRecord.fID<=0) or

     not (aAction in [soInsert,soUpdate]) then

    exit;

  aTableIndex := fRest.Model.GetTableIndex(PSQLRecordClass(aRecord)^);

  if aTableIndex<Cardinal(Length(fCache)) then

    with fCache[aTableIndex] do

      if CacheEnable then

        SetJSON(aRecord);

end;



procedure TSQLRestCache.Notify(aTableIndex: integer; aID: TID;

  const aJSON: RawUTF8; aAction: TSQLOccasion);

begin

  if (self<>nil) and (aID>0) and (aAction in [soSelect,soInsert,soUpdate]) and

     (aJSON<>'') and (Cardinal(aTableIndex)<Cardinal(Length(fCache))) then

    with fCache[aTableIndex] do

      if CacheEnable then

        SetJSON(aID,aJSON);

end;



procedure TSQLRestCache.NotifyDeletion(aTableIndex, aID: TID);

begin

  if (self<>nil) and (aID>0) and

     (Cardinal(aTableIndex)<Cardinal(Length(fCache))) then

    with fCache[aTableIndex] do

    if CacheEnable then begin

      Mutex.Lock;

      try

        FlushCacheEntry(Value.Find(aID));

      finally

        Mutex.UnLock;

      end;

    end;

end;



procedure TSQLRestCache.NotifyDeletion(aTable: TSQLRecordClass; aID: TID);

begin

  if (self<>nil) and (aTable<>nil) and (aID>0) then

    NotifyDeletion(fRest.Model.GetTableIndex(aTable),aID);

end;



function TSQLRestCache.Retrieve(aID: TID; aValue: TSQLRecord): boolean;

var TableIndex: cardinal;

begin

  result := false;

  if (self=nil) or (aValue=nil) or (aID<=0) then

    exit;

  TableIndex := fRest.Model.GetTableIndexExisting(PSQLRecordClass(aValue)^);

  if TableIndex<cardinal(Length(fCache)) then

    with fCache[TableIndex] do

    if CacheEnable and RetrieveJSON(aID,aValue) then

      result := true;

end;



function TSQLRestCache.Retrieve(aTableIndex, aID: TID): RawUTF8;

begin

  result := '';

  if (self<>nil) and (aID>0) and

     (Cardinal(aTableIndex)<Cardinal(Length(fCache))) then

    with fCache[aTableIndex] do

    if CacheEnable then

      RetrieveJSON(aID,result);

end;





{ TSQLRestThread }



constructor TSQLRestThread.Create(aRest: TSQLRest;

  aOwnRest, aCreateSuspended: boolean);

begin

  if aRest=nil then

    raise EORMException.CreateUTF8('%.Create(aRest=nil)',[self]);

  fSafe.Init;

  fRest := aRest;

  fOwnRest := aOwnRest;

  inherited Create(aCreateSuspended);

end;



destructor TSQLRestThread.Destroy;

begin

  inherited Destroy;

  if fOwnRest then

    FreeAndNil(fRest);

  fSafe.Done;

end;



function TSQLRestThread.SleepOrTerminated(MS: integer): boolean;

var endtix: Int64;

begin

  result := true; // notify Terminated

  if Terminated then

    exit;

  if MS<32 then begin // smaller than GetTickCount resolution (under Windows)

    sleep(MS);

    if Terminated then

      exit;

  end else begin

    endtix := GetTickCount64+MS;

    repeat

      sleep(10);

      if Terminated then

        exit;

    until GetTickCount64>endtix;

  end;

  result := false; // normal delay expiration

end;



procedure TSQLRestThread.Execute;

begin

  {$ifdef WITHLOG}

  fLog := FRest.LogClass.Add;

  {$endif}

  SetCurrentThreadName('% %',[self,fRest.Model.Root]);

  FRest.BeginCurrentThread(self);

  try

    try

      InternalExecute;

    except

      on E: Exception do

        {$ifdef WITHLOG}

        fLog.Add.Log(sllError,'Unhandled % in %.Execute -> abort',[E,ClassType],self);

        {$endif}

    end;

  finally

    FRest.EndCurrentThread(self);

  end;

end;



{$ifndef HASTTHREADSTART}

procedure TSQLRestThread.Start;

begin

  Resume;

end;

{$endif}





{ TSQLRestURIParams }



procedure TSQLRestURIParams.Init;

begin

  OutStatus := 0;

  OutInternalState := 0;

  RestAccessRights := nil;

  LowLevelConnectionID := 0;

  byte(LowLevelFlags) := 0;

end;



procedure TSQLRestURIParams.Init(const aURI,aMethod,aInHead,aInBody: RawUTF8);

begin

  Init;

  Url := aURI;

  Method := aMethod;

  InHead := aInHead;

  InBody := aInBody;

end;



function TSQLRestURIParams.InBodyType(GuessJSONIfNoneSet: boolean): RawUTF8;

begin

  result := FindIniNameValue(pointer(InHead),HEADER_CONTENT_TYPE_UPPER);

  if GuessJSONIfNoneSet and (result='') then

    result := JSON_CONTENT_TYPE_VAR;

end;



function TSQLRestURIParams.OutBodyType(GuessJSONIfNoneSet: boolean): RawUTF8;

begin

  result := FindIniNameValue(pointer(OutHead),HEADER_CONTENT_TYPE_UPPER);

  if GuessJSONIfNoneSet and (result='') then

    result := JSON_CONTENT_TYPE_VAR;

end;





{ TSQLRestClientCallbacks }



constructor TSQLRestClientCallbacks.Create(aOwner: TSQLRestClientURI);

begin

  inherited Create;

  Owner := aOwner;

end;



function TSQLRestClientCallbacks.FindIndex(aID: integer): integer;

begin

  if self<>nil then

    for result := 0 to Count-1 do

      if List[result].ID=aID then

        exit;

  result := -1;

end;



function TSQLRestClientCallbacks.FindEntry(var aItem: TSQLRestClientCallbackItem): boolean;

var i: Integer;

    P: PSQLRestClientCallbackItem;

begin

  result := false;

  if self=nil then

    exit;

  fSafe.Lock;

  try

    P := pointer(List);

    for i := 1 to Count do

      if P^.ID=aItem.ID then begin

        if P^.Instance<>nil then begin

          result := true;

          aItem := P^;

        end;

        exit;

      end else

      inc(P);

  finally

    Safe.UnLock;

  end;

end;



function TSQLRestClientCallbacks.FindAndRelease(aID: integer): boolean;

var i: Integer;

begin

  result := false;

  if self=nil then

    exit;

  fSafe.Lock;

  try

    i := FindIndex(aID);

    if i<0 then

      exit;

    List[i].ReleasedFromServer := True;

  finally

    Safe.UnLock;

  end;

  result := true;

end;



function TSQLRestClientCallbacks.UnRegisterByIndex(index: integer): boolean;

begin

  result := false;

  if cardinal(index)>=cardinal(Count) then

    exit;

  with List[index] do

    if not ReleasedFromServer then

    try

      if Owner.FakeCallbackUnregister(Factory,ID,Instance) then

        result := true;

    except

      // ignore errors at this point, and continue

    end;

  dec(Count);

  if index<Count then

    MoveFast(List[index+1],List[index],(Count-index)*sizeof(List[index]));

end;



function TSQLRestClientCallbacks.UnRegister(aInstance: pointer): boolean;

var i: integer;

begin

  result := false;

  if (self=nil) or (Count=0) then

    exit;

  Safe.Lock;

  try

    for i := Count-1 downto 0 do

      if List[i].Instance=aInstance then

        if UnRegisterByIndex(i) then

          result := true else

          break;

  finally

    Safe.UnLock;

  end;

end;



procedure TSQLRestClientCallbacks.DoRegister(aID: integer;

  aInstance: pointer; aFactory: TInterfaceFactory);

begin

  if aID<=0 then

    exit;

  Safe.Lock;

  try

    if length(List)>=Count then

      SetLength(List,Count+32);

    with List[Count] do begin

      ID := aID;

      Instance := aInstance;

      Factory := aFactory;

    end;

    inc(Count);

  finally

    Safe.UnLock;

  end;

end;



function TSQLRestClientCallbacks.DoRegister(aInstance: pointer;

  aFactory: TInterfaceFactory): integer;

begin

  result := InterlockedIncrement(fCurrentID);

  DoRegister(result,aInstance,aFactory);

end;







{ TSQLRestClientURI }



function TSQLRestClientURI.EngineExecute(const SQL: RawUTF8): boolean;

begin

  result := URI(Model.Root,'POST',nil,nil,@SQL).Lo in [HTML_SUCCESS,HTML_NOCONTENT];

end;



function TSQLRestClientURI.URIGet(Table: TSQLRecordClass; ID: TID;

  var Resp: RawUTF8; ForUpdate: boolean=false): Int64Rec;

const METHOD: array[boolean] of RawUTF8 = ('GET','LOCK');

begin

  result := URI(Model.getURIID(Table,ID),METHOD[ForUpdate],@Resp,nil,nil);

end;



function TSQLRestClientURI.UnLock(Table: TSQLRecordClass; aID: TID): boolean;

begin

  if (self=nil) or not Model.UnLock(Table,aID) then

    result := false else // was not locked by the client

    result := URI(Model.getURIID(Table,aID),'UNLOCK').Lo in [HTML_SUCCESS,HTML_NOCONTENT];

end;



function TSQLRestClientURI.ExecuteList(const Tables: array of TSQLRecordClass;

  const SQL: RawUTF8): TSQLTableJSON;

var Resp: RawUTF8;

begin

  if self=nil then

    result := nil else

  with URI(Model.Root,'GET',@Resp,nil,@SQL) do

    if Lo=HTML_SUCCESS then begin // GET with SQL sent

      if high(Tables)=0 then

        result := TSQLTableJSON.CreateFromTables([Tables[0]],SQL,Resp) else

        result := TSQLTableJSON.CreateFromTables(Tables,SQL,Resp);

      result.fInternalState := Hi;

    end else // get data

    result := nil;

end;



function TSQLRestClientURI.ServerInternalState: cardinal;

begin

  if (Self=nil) or (Model=nil) then // avoid GPF

    result := cardinal(-1) else

    result := URI(Model.Root,'STATE').Hi;

end;



function TSQLRestClientURI.ServerCacheFlush(aTable: TSQLRecordClass; aID: TID): boolean;

var aResp: RawUTF8;

begin

  if (Self=nil) or (Model=nil) then // avoid GPF

    result := false else

    result := CallBackGet('CacheFlush',[],aResp,aTable,aID) in [HTML_SUCCESS,HTML_NOCONTENT];

end;



function TSQLRestClientURI.ServerTimeStampSynchronize: boolean;

var status: integer;

    aResp: RawUTF8;

begin

  if self=nil then begin

    result := false;

    exit;

  end;

  fServerTimeStampOffset := 0.0001; // avoid endless recursive call

  status := CallBackGet('TimeStamp',[],aResp);

  result := (status=HTML_SUCCESS) and (aResp<>'');

  if result then

    SetServerTimeStamp(GetInt64(pointer(aResp))) else begin

    InternalLog('/TimeStamp call failed -> Server not available',sllWarning);

    fLastErrorMessage := 'Server not available  - '+Trim(fLastErrorMessage);

  end;

end;



function TSQLRestClientURI.InternalRemoteLogSend(const aText: RawUTF8): boolean;

begin

  result := URI(Model.getURICallBack('RemoteLog',nil,0),

    'PUT',nil,nil,@aText).Lo in [HTML_SUCCESS,HTML_NOCONTENT];

end;





{$ifdef MSWINDOWS}

type

  TSQLRestClientURIServiceNotification = class(TServiceMethodExecute)

  protected

    fOwner: TSQLRestClientURI;

    fInstance: TObject;

    fPar: RawUTF8;

  end;



procedure TSQLRestClientURI.ServiceNotificationMethodViaMessages(hWnd: HWND; Msg: UINT);

begin

  if Msg=0 then

    hWnd := 0; // avoid half defined parameters

  fServiceNotificationMethodViaMessages.Wnd := hWnd;

  fServiceNotificationMethodViaMessages.Msg := Msg;

end;



class procedure TSQLRestClientURI.ServiceNotificationMethodExecute(var Msg : TMessage);

var exec: TSQLRestClientURIServiceNotification;

begin

  exec := pointer(Msg.LParam);

  if exec<>nil then

  try

    try

      if exec.InheritsFrom(TSQLRestClientURIServiceNotification) and

         (HWND(Msg.WParam)=exec.fOwner.fServiceNotificationMethodViaMessages.Wnd) then

        // run asynchronous notification callback in the main UI thread context

        exec.ExecuteJson([exec.fInstance],pointer(exec.fPar),nil);

    finally

      exec.Free; // always release notification resources

    end;

  except

    ; // ignore any exception for this asynchronous callback execution

  end;

end;

{$endif MSWINDOWS}



type

  TServiceInternalMethod = (imFree, imContract, imSignature);



const

  SERVICE_PSEUDO_METHOD: array[TServiceInternalMethod] of RawUTF8 = (

    '_free_','_contract_','_signature_');

  SERVICE_PSEUDO_METHOD_COUNT = Length(SERVICE_PSEUDO_METHOD);



procedure TSQLRestClientURI.InternalNotificationMethodExecute(

  var Ctxt: TSQLRestURIParams);

var url,root,interfmethod,interf,id,method,frames: RawUTF8;

    callback: TSQLRestClientCallbackItem;

    methodIndex: integer;

    WR: TTextWriter;

    ok: Boolean;

  procedure Call(methodIndex: Integer; const par: RawUTF8; res: TTextWriter);

  var method: PServiceMethod;

      exec: TServiceMethodExecute;

  begin

    method := @callback.Factory.Methods[methodIndex];

    {$ifdef MSWINDOWS}

    if (fServiceNotificationMethodViaMessages.Wnd<>0) and

       (method^.ArgsOutputValuesCount=0) then begin

      // expects no output -> asynchronous non blocking notification in UI thread

      Ctxt.OutStatus := 0;

      exec := TSQLRestClientURIServiceNotification.Create(method);

      TSQLRestClientURIServiceNotification(exec).fOwner := self;

      TSQLRestClientURIServiceNotification(exec).fInstance := callback.Instance;

      TSQLRestClientURIServiceNotification(exec).fPar := par;

      with fServiceNotificationMethodViaMessages do

        ok := PostMessage(Wnd,Msg,Wnd,LPARAM(exec));

      if ok then

        exit;

    end else // if PostMessage() failed (e.g. invalid Wnd/Msg) -> blocking exec

    {$endif}

      exec := TServiceMethodExecute.Create(method);

    try

      ok := exec.ExecuteJson([callback.Instance],pointer(par),res);

      Ctxt.OutHead := exec.ServiceCustomAnswerHead;

      Ctxt.OutStatus := exec.ServiceCustomAnswerStatus;

    finally

      exec.Free;

    end;

  end;

begin

  Ctxt.OutStatus := HTML_BADREQUEST;

  url := Ctxt.Url;

  if url='' then

    exit;

  if url[1]='/' then

    system.delete(url,1,1);

  Split(Split(url,'/',root),'/',interfmethod,id); // 'root/BidirCallback.AsynchEvent/1'

  if not IdemPropNameU(root,Model.Root) then

    exit;

  callback.ID := GetInteger(pointer(id));

  if callback.ID<=0 then

    exit;

  if interfmethod=SERVICE_PSEUDO_METHOD[imFree] then begin

    if fFakeCallbacks.FindAndRelease(callback.ID) then

      Ctxt.OutStatus := HTML_SUCCESS;

    exit;

  end;

  if not fFakeCallbacks.FindEntry(callback) then

    exit;

  if (Ctxt.InHead<>'') and

     (callback.Factory.MethodIndexCurrentFrameCallback>=0) then begin

    frames := FindIniNameValue(pointer(Ctxt.InHead),'SEC-WEBSOCKET-FRAME: ');

  end;

  split(interfmethod,'.',interf,method);

  methodIndex := callback.Factory.FindMethodIndex(method);

  if methodIndex<0 then

    exit;

  if IdemPropNameU(interfmethod,callback.Factory.Methods[methodIndex].InterfaceDotMethodName) then

  try

    WR := TJSONSerializer.CreateOwnedStream;

    try

      WR.AddShort('{"result":[');

      if frames='[0]' then // call before the first method of the jumbo frame

        Call(callback.Factory.MethodIndexCurrentFrameCallback,frames,nil);

      Call(methodIndex,Ctxt.InBody,WR);

      if ok then begin

        if Ctxt.OutHead='' then begin // <>'' if set via TServiceCustomAnswer

          WR.Add(']','}');

          Ctxt.OutStatus := HTML_SUCCESS;

        end;

        Ctxt.OutBody := WR.Text;

      end else

        Ctxt.OutStatus := HTML_SERVERERROR;

      if frames='[1]' then // call after the last method of the jumbo frame

        Call(callback.Factory.MethodIndexCurrentFrameCallback,frames,nil);

    finally

      WR.Free;

    end;

  except

    on E: Exception do begin

      Ctxt.OutHead := '';

      Ctxt.OutBody := ObjectToJSONDebug(E);

      Ctxt.OutStatus := HTML_SERVERERROR;

    end;

  end;

end;



{$ifdef LVCL} // SyncObjs.TEvent not available in LVCL yet



function TSQLRestClientURI.ServerRemoteLog(Sender: TTextWriter; Level: TSynLogInfo;

  const Text: RawUTF8): boolean;

begin

  result := InternalRemoteLogSend(Text);

end;



{$else}



type

  TRemoteLogThread = class(TSQLRestThread)

  protected

    fClient: TSQLRestClientURI;

    fPendingRows: RawUTF8;

    fNotifier: TEvent;

    procedure InternalExecute; override;

  public

    constructor Create(aClient: TSQLRestClientURI); reintroduce;

    destructor Destroy; override;

    procedure AddRow(const aText: RawUTF8);

  end;



constructor TRemoteLogThread.Create(aClient: TSQLRestClientURI);

begin

  fNotifier := TEvent.Create(nil,false,false,'');

  fClient := aClient;

  inherited Create(aClient,false,false);

end;



destructor TRemoteLogThread.Destroy;

var i: integer;

begin

  if fPendingRows<>'' then begin

    fNotifier.SetEvent;

    for i := 1 to 200 do begin

      SleepHiRes(10);

      if fPendingRows='' then

        break;

    end;

  end;

  Terminate; // will notify Execute that the process is finished

  fNotifier.SetEvent;

  SleepHiRes(50); // wait for Execute to finish

  fNotifier.Free;

  inherited;

end;



procedure TRemoteLogThread.AddRow(const aText: RawUTF8);

begin

  fSafe.Lock;

  try

    if fPendingRows='' then

      fPendingRows := aText else

      fPendingRows := fPendingRows+#13#10+aText;

  finally

    fSafe.UnLock;

  end;

  fNotifier.SetEvent;

end;



procedure TRemoteLogThread.InternalExecute;

var aText: RawUTF8;

begin

  while not Terminated do

    if FixedWaitFor(fNotifier,INFINITE)=wrSignaled then begin

      if Terminated then

        break;

      fSafe.Lock;

      try

        aText := fPendingRows;

        fPendingRows := '';

      finally

        fSafe.UnLock;

      end;

      if (aText<>'') and not Terminated then

      try

        while not fClient.InternalRemoteLogSend(aText) do

          if SleepOrTerminated(2000) then // retry after 2 seconds delay

            exit;

      except

        on E: Exception do

          if (fClient<>nil) and not Terminated then

            fClient.InternalLog('%.Execute fatal error: %'+

              'some events were not transmitted',[ClassType,E],sllWarning);

      end;

    end;

end;



function TSQLRestClientURI.ServerRemoteLog(Sender: TTextWriter; Level: TSynLogInfo;

  const Text: RawUTF8): boolean;

begin

  if fRemoteLogThread=nil then

    result := InternalRemoteLogSend(Text) else begin

    TRemoteLogThread(fRemoteLogThread).AddRow(Text);

    result := true;

  end;

end;



{$endif LVCL}



function TSQLRestClientURI.ServerRemoteLog(Level: TSynLogInfo;

  FormatMsg: PUTF8Char; const Args: array of const): boolean;

begin

  result := ServerRemoteLog(nil,Level,

    FormatUTF8('%00%    %',[NowToString(false),LOG_LEVEL_TEXT[Level],

      FormatUTF8(FormatMsg,Args)]));

end;



procedure TSQLRestClientURI.ServerRemoteLogStart(aLogClass: TSynLogClass;

  aClientOwnedByFamily: boolean);

begin

  if (fRemoteLogClass<>nil) or (aLogClass=nil) then

    exit;

  {$ifdef WITHLOG}

  SetLogClass(TSynLog.Void); // this client won't log anything

  {$endif}

  if not ServerRemoteLog(sllClient,'Remote Client % Connected',[self]) then

    // first test server without threading

    raise ECommunicationException.CreateUTF8(

      'Connection to RemoteLog server impossible'#13#10'%',[LastErrorMessage]);

  {$ifndef LVCL}

  if fRemoteLogThread<>nil then

    raise ECommunicationException.CreateUTF8('%.ServerRemoteLogStart twice',[self]);

  fRemoteLogThread := TRemoteLogThread.Create(self);

  {$endif}

  fRemoteLogClass := aLogClass.Add;

  aLogClass.Family.EchoRemoteStart(self,ServerRemoteLog,aClientOwnedByFamily);

  fRemoteLogOwnedByFamily := aClientOwnedByFamily;

end;



procedure TSQLRestClientURI.ServerRemoteLogStop;

begin

  if fRemoteLogClass=nil then

    exit;

  if not fRemoteLogOwnedByFamily then begin

    fRemoteLogClass.Log(sllTrace,'End Echoing to remote server');

    fRemoteLogClass.Family.EchoRemoteStop;

  end;

  fRemoteLogClass := nil;

end;



function TSQLRestClientURI.UpdateFromServer(const Data: array of TObject; out Refreshed: boolean;

  PCurrentRow: PInteger): boolean;

// notes about refresh mechanism:

// - if server doesn't implement InternalState, its value is 0 -> always refresh

// - if any TSQLTableJSON or TSQLRecord belongs to a TSQLRestStorage,

// the Server stated fInternalState=cardinal(-1) for them -> always refresh

var i: integer;

    State: cardinal;

    Resp: RawUTF8;

    T: TSQLTableJSON;

    TRefreshed: boolean; // to check for each Table refresh

const TState: array[boolean] of TOnTableUpdateState = (tusNoChange,tusChanged);

begin

  result := self<>nil;

  Refreshed := false;

  if not result then

    exit; // avoid GPF

  State := ServerInternalState; // get revision state from server

  for i := 0 to high(Data) do

    if Data[i]<>nil then

    if TObject(Data[i]).InheritsFrom(TSQLTableJSON) then begin

      T := TSQLTableJSON((Data[i]));

      if (T.QuerySQL<>'') and (T.InternalState<>State) then begin // refresh needed?

        with URI(Model.Root,'GET',@Resp,nil,@T.QuerySQL) do

          if Lo=HTML_SUCCESS then begin // GET with SQL sent

            if Assigned(OnTableUpdate) then

              OnTableUpdate(T,tusPrepare);

            TRefreshed := false;

            if not T.UpdateFrom(Resp,TRefreshed,PCurrentRow) then

              result := false else // mark error retrieving new content

              T.fInternalState := Hi;

            if TRefreshed then

              Refreshed := true;

            if Assigned(OnTableUpdate) then

              OnTableUpdate(T,TState[TRefreshed]);

          end

          else result := false; // mark error retrieving new content

        end;

    end else

    if TObject(Data[i]).InheritsFrom(TSQLRecord) then

    with TSQLRecord(Data[i]) do

      if (fID<>0) and (InternalState<>State) then begin // refresh needed?

        if not Refresh(fID,TSQLRecord(Data[i]),Refreshed) then

          result := false; // mark error retrieving new content

      end;

end;



function TSQLRestClientURI.List(const Tables: array of TSQLRecordClass;

  const SQLSelect, SQLWhere: RawUTF8): TSQLTableJSON;

var Resp, SQL: RawUTF8;

    U: RawUTF8;

    InternalState: cardinal;

begin

  result := nil;

  if high(Tables)<0 then exit;

  // GET Collection

  SQL := Model.SQLFromSelectWhere(Tables,SQLSelect,SQLWhere);

  if high(Tables)=0 then begin

    // one Table -> use REST protocol (SQL as parameters)

    if not IsRowID(pointer(SQLSelect)) then

      // ID selected by default

      U := '?select='+UrlEncode(SQLSelect) else

      U := '';

    if SQLWhere<>'' then begin

      if U<>'' then

        U := U+'&where=' else

        U := U+'?where=';

      U := U+UrlEncode(SQLWhere);

    end;

    with URI(Model.URI[TSQLRecordClass(Tables[0])]+U,'GET',@Resp) do

      if Lo<>HTML_SUCCESS then

        exit else

        InternalState := Hi;

    result := TSQLTableJSON.CreateFromTables([Tables[0]],SQL,Resp); // get data

  end else begin

    // multiple tables -> send SQL statement as HTTP body

    with URI(Model.Root,'GET',@Resp,nil,@SQL) do

      if Lo<>HTML_SUCCESS then

        exit else

        InternalState := Hi;

    result := TSQLTableJSON.CreateFromTables(Tables,SQL,Resp); // get data

  end;

  result.fInternalState := InternalState;

end;



procedure TSQLRestClientURI.SessionClose;

var tmp: RawUTF8;

begin

  if (self<>nil) and (fSessionUser<>nil) and

     (fSessionID<>CONST_AUTHENTICATION_SESSION_NOT_STARTED) then

  try

    // notify session closed to server

    CallBackGet('Auth',['UserName',fSessionUser.LogonName,'Session',fSessionID],tmp);

  finally

    fSessionID := CONST_AUTHENTICATION_SESSION_NOT_STARTED;

    fSessionIDHexa8 := '';

    fSessionPrivateKey := 0;

    fSessionAuthentication := nil;

    fSessionServer := '';

    fSessionVersion := '';

    fSessionData := '';

    FreeAndNil(fSessionUser);

  end;

end;



function TSQLRestClientURI.SessionCreate(aAuth: TSQLRestServerAuthenticationClass;

  var aUser: TSQLAuthUser; const aSessionKey: RawUTF8): boolean;

begin

  result := false;

  fSessionID := GetCardinal(pointer(aSessionKey));

  if fSessionID=0 then

    exit;

  fSessionIDHexa8 := CardinalToHex(fSessionID);

  fSessionPrivateKey := crc32(crc32(0,Pointer(aSessionKey),length(aSessionKey)),

    pointer(aUser.PasswordHashHexa),length(aUser.PasswordHashHexa));

  fSessionUser := aUser;

  fSessionAuthentication := aAuth;

  aUser := nil; // now owned by this instance

  result := true;

end;



function TSQLRestClientURI.GetCurrentSessionUserID: TID;

begin

  if fSessionUser=nil then

    result := 0 else

    result := fSessionUser.IDValue;

end;



constructor TSQLRestClientURI.Create(aModel: TSQLModel);

begin

  inherited Create(aModel);

  fSessionID := CONST_AUTHENTICATION_NOT_USED;

  fFakeCallbacks := TSQLRestClientCallbacks.Create(self);

  {$ifdef USELOCKERDEBUG}

  fSafe := TAutoLockerDebug.Create(fLogClass,aModel.Root); // more verbose

  {$else}

  fSafe := TAutoLocker.Create;

  {$endif}

end;



destructor TSQLRestClientURI.Destroy;

var t,i: integer;

    aID: TID;

    Table: TSQLRecordClass;

begin

  {$ifdef MSWINDOWS}

  fServiceNotificationMethodViaMessages.Wnd := 0; // disable notification

  {$endif}

  {$ifdef WITHLOG}

  if GarbageCollectorFreeing then // may be owned by a TSynLogFamily

    SetLogClass(nil);

  {$endif}

  fBatchCurrent.Free;

  fFakeCallbacks.Free;

  try

    // unlock all still locked records by this client

    if Model<>nil then

    for t := 0 to high(Model.Locks) do begin

      Table := Model.Tables[t];

      with Model.Locks[t] do

      for i := 0 to Count-1 do begin

        aID := IDs[i];

        if aID<>0 then // 0 is empty after unlock

          self.UnLock(Table,aID);

      end;

    end;

    SessionClose; // if not already notified

  finally

    // release memory and associated classes

    if fRemoteLogClass<>nil then begin

      {$ifndef LVCL}

      FreeAndNil(fRemoteLogThread);

      {$endif}

      ServerRemoteLogStop;

    end;

    fSessionUser.Free;

    try

      inherited Destroy; // fModel.Free if owned by this TSQLRest instance

      {$ifndef LVCL}

      FreeAndNil(fBackgroundThread); // should be done after fServices.Free

      fOnIdle := nil;

      {$endif}

    finally

      InternalClose;

    end;

  end;

end;



{$ifdef SSPIAUTH}

const

  SSPI_DEFINITION_USERNAME = '***SSPI***';

{$endif}



constructor TSQLRestClientURI.RegisteredClassCreateFrom(aModel: TSQLModel;

  aDefinition: TSynConnectionDefinition);

begin

  if fModel=nil then // if not already created with a reintroduced constructor

    Create(aModel);

  if fModel<>nil then

    fOnIdle := fModel.OnClientIdle; // allow UI interactivity during SetUser()

  if aDefinition.User<>'' then begin

    {$ifdef SSPIAUTH}

    if aDefinition.User=SSPI_DEFINITION_USERNAME then

      SetUser('',aDefinition.PasswordPlain) else

    {$endif}

      SetUser(aDefinition.User,aDefinition.PasswordPlain,true);

  end;

end;



procedure TSQLRestClientURI.DefinitionTo(Definition: TSynConnectionDefinition);

begin

  if Definition=nil then

    exit;

  inherited DefinitionTo(Definition); // save Kind

  if (fSessionAuthentication<>nil) and (fSessionUser<>nil) then begin

    {$ifdef SSPIAUTH}

    if fSessionAuthentication.InheritsFrom(TSQLRestServerAuthenticationSSPI) then

      Definition.User := SSPI_DEFINITION_USERNAME else

    {$endif}

       Definition.User := fSessionUser.LogonName;

     Definition.PasswordPlain := fSessionUser.fPasswordHashHexa;

  end;

end;



procedure TSQLRestClientURI.Commit(SessionID: cardinal; RaiseException: boolean);

begin

  inherited Commit(CONST_AUTHENTICATION_NOT_USED,RaiseException);

  // inherited Commit = reset fTransactionActiveSession flag

  URI(Model.Root,'END');

end;



procedure TSQLRestClientURI.RollBack(SessionID: cardinal);

begin

  inherited RollBack(CONST_AUTHENTICATION_NOT_USED); // reset fTransactionActiveSession flag

  URI(Model.Root,'ABORT');

end;



function TSQLRestClientURI.TransactionBegin(aTable: TSQLRecordClass;

  SessionID: cardinal): boolean;

begin

  result := inherited TransactionBegin(aTable,CONST_AUTHENTICATION_NOT_USED);

  if result then

    // fTransactionActiveSession flag was not already set

    if aTable=nil then

      result := URI(Model.Root,'BEGIN').Lo in [HTML_SUCCESS,HTML_NOCONTENT] else

      result := URI(Model.URI[aTable],'BEGIN').Lo in [HTML_SUCCESS,HTML_NOCONTENT];

end;



function TSQLRestClientURI.TransactionBeginRetry(aTable: TSQLRecordClass;

  Retries: integer): boolean;

begin

  if Retries>50 then

    Retries := 50; // avoid loop for more than 10 seconds

  repeat

    result := TransactionBegin(aTable);

    if result then

      exit;

    dec(Retries);

    if Retries<=0 then break;

    SleepHiRes(100);

  until false;

end;



const

  // log up to 2 KB of JSON response, to save space

  MAX_SIZE_RESPONSE_LOG = 2*1024;



function TSQLRestClientURI.CallBackGet(const aMethodName: RawUTF8;

  const aNameValueParameters: array of const; out aResponse: RawUTF8;

  aTable: TSQLRecordClass; aID: TID; aResponseHead: PRawUTF8): integer;

var url, header: RawUTF8;

    {$ifdef WITHLOG}

    Log: ISynLog; // for Enter auto-leave to work with FPC

    {$endif}

begin

  if self=nil then

    result := HTML_UNAVAILABLE else begin

    url := Model.getURICallBack(aMethodName,aTable,aID)+

      UrlEncode(aNameValueParameters);

    {$ifdef WITHLOG}

    Log := fLogClass.Enter('CallBackGet %',[url],self);

    {$endif}

    result := URI(url,'GET',@aResponse,@header).Lo;

    if aResponseHead<>nil then

      aResponseHead^ := header;

    {$ifdef WITHLOG}

    if (aResponse<>'') and (sllServiceReturn in fLogFamily.Level) then

      if IsHTMLContentTypeTextual(pointer(header)) then

        Log.Log(sllServiceReturn,aResponse,self,MAX_SIZE_RESPONSE_LOG) else

        Log.Log(sllServiceReturn,'% bytes "%"',[length(aResponse),header],self);

    {$endif}

  end;

end;



function TSQLRestClientURI.SetUser(const aUserName, aPassword: RawUTF8;

  aHashedPassword: Boolean): boolean;

const HASH: array[boolean] of TSQLRestServerAuthenticationClientSetUserPassword =

  (passClear, passHashed);

begin

  if self=nil then begin

    result := false;

    exit;

  end;

  {$ifdef SSPIAUTH} // try Windows authentication with the current logged user

  result := true;

  if ((trim(aUserName)='') or (PosEx('\',aUserName)>0)) and

    TSQLRestServerAuthenticationSSPI.ClientSetUser(self,aUserName,aPassword,passKerberosSPN) then

      exit;

  {$endif}

  result := TSQLRestServerAuthenticationDefault.

    ClientSetUser(self,aUserName,aPassword,HASH[aHashedPassword]);

end;



procedure TSQLRestClientURI.SetLastException(E: Exception; ErrorCode: integer;

  Call: PSQLRestURIParams);

begin

  fLastErrorCode := ErrorCode;

  if E=nil then begin

    fLastErrorException := nil;

    if StatusCodeIsSuccess(ErrorCode) then

      fLastErrorMessage := '' else

      StatusCodeToErrorMsg(ErrorCode,fLastErrorMessage);

  end else begin

    fLastErrorException := PPointer(E)^;

    fLastErrorMessage := ObjectToJSONDebug(E);

  end;

  if Assigned(fOnFailed) then

    fOnFailed(self,E,Call);

end;



{$ifndef LVCL} // SyncObjs.TEvent not available in LVCL yet



procedure TSQLRestClientURI.OnBackgroundProcess(Sender: TSynBackgroundThreadEvent;

  ProcessOpaqueParam: pointer);

var Call: ^TSQLRestURIParams absolute ProcessOpaqueParam;

begin

  if Call=nil then

    exit;

  InternalURI(Call^);

  if OnIdleBackgroundThreadActive then

    if Call^.OutStatus=HTML_NOTIMPLEMENTED then begin

      // InternalCheckOpen failed -> force recreate connection

      InternalClose;

      if OnIdleBackgroundThreadActive then

        InternalURI(Call^); // try request again

    end;

end;



function TSQLRestClientURI.GetOnIdleBackgroundThreadActive: boolean;

begin

  result := (self<>nil) and Assigned(fOnIdle) and

    fBackgroundThread.OnIdleBackgroundThreadActive;

end;



{$endif LVCL}



function TSQLRestClientURI.FakeCallbackRegister(Sender: TServiceFactoryClient;

  const Method: TServiceMethod; const ParamInfo: TServiceMethodArgument;

  ParamValue: Pointer): integer;

begin

  raise EServiceException.CreateUTF8('% does not support interface parameters '+

    'for %.%(%: %): consider using another kind of client',

    [self,Sender.fInterface.fInterfaceName,Method.URI,

     ParamInfo.ParamName^,ParamInfo.ArgTypeName^]);

end;



function TSQLRestClientURI.FakeCallbackUnregister(Factory: TInterfaceFactory;

  FakeCallbackID: integer; Instance: pointer): boolean;

begin

  raise EServiceException.CreateUTF8(

    '% does not support % callbacks: consider using another kind of client',

    [self,Factory.fInterfaceTypeInfo^.Name]);

end;



function TSQLRestClientURI.URI(const url, method: RawUTF8;

  Resp, Head, SendData: PRawUTF8): Int64Rec;

var Retry: integer;

    aUserName, aPassword: string;

    StatusMsg: RawUTF8;

    Call: TSQLRestURIParams;

    aRetryOnceOnTimeout, aPasswordHashed: boolean;

label DoRetry;

begin

  if self=nil then begin

    Int64(result) := HTML_UNAVAILABLE;

    SetLastException(nil,HTML_UNAVAILABLE);

    exit;

  end;

  aRetryOnceOnTimeout := RetryOnceOnTimeout;

  fLastErrorMessage := '';

  fLastErrorException := nil;

  if fServerTimeStampOffset=0 then

    if not ServerTimeStampSynchronize then begin

      Int64(result) := HTML_UNAVAILABLE;

      exit; // if /TimeStamp is not available, server is down!

    end;

  Call.Init;

  if (Head<>nil) and (Head^<>'') then

    Call.InHead := Head^;

  if fSessionHttpHeader<>'' then

    Call.InHead := Trim(Call.InHead+#13#10+fSessionHttpHeader);

  for Retry := -1 to MaximumAuthentificationRetry do

  try

DoRetry:

    Call.Url := url;

    if fSessionAuthentication<>nil then

      fSessionAuthentication.ClientSessionSign(self,Call);

    Call.Method := method;

    if SendData<>nil then

      Call.InBody := SendData^;

{$ifndef LVCL}

    if Assigned(fOnIdle) then begin

      if fBackgroundThread=nil then

        fBackgroundThread := TSynBackgroundThreadEvent.Create(OnBackgroundProcess,

          OnIdle,FormatUTF8('% "%" background',[self,Model.Root]));

      if not fBackgroundThread.RunAndWait(@Call) then

        Call.OutStatus := HTML_UNAVAILABLE;

    end else

{$endif}

    begin

      InternalURI(Call);

      if Call.OutStatus=HTML_NOTIMPLEMENTED then begin // InternalCheckOpen failed

        InternalClose;     // force recreate connection

        InternalURI(Call); // try request again

      end;

    end;

    result.Lo := Call.OutStatus;

    result.Hi := Call.OutInternalState;

    if Head<>nil then

      Head^ := Call.OutHead;

    if Resp<>nil then

      Resp^ := Call.OutBody;

    fLastErrorCode := Call.OutStatus;

    if (Call.OutStatus=HTML_TIMEOUT) and aRetryOnceOnTimeout then begin

      aRetryOnceOnTimeout := false;

      InternalLog('% % returned "408 Request Timeout" -> RETRY',[method,url],sllError);

      goto DoRetry;

    end;

    if not StatusCodeIsSuccess(Call.OutStatus) then begin

      StatusCodeToErrorMsg(Call.OutStatus,StatusMsg);

      if Call.OutBody='' then

        fLastErrorMessage := StatusMsg else

        fLastErrorMessage := Call.OutBody;

      InternalLog('% % returned % (%) with message  %',

        [method,url,Call.OutStatus,StatusMsg,fLastErrorMessage],sllError);

      if Assigned(fOnFailed) then

        fOnFailed(self,nil,@Call);

    end;

    if (Call.OutStatus<>HTML_FORBIDDEN) or not Assigned(OnAuthentificationFailed) then

      break;

    // "403 Forbidden" in case of authentication failure -> try relog

    if not OnAuthentificationFailed(Retry+2,aUserName,aPassword,aPasswordHashed) or

       not SetUser(StringToUTF8(aUserName),StringToUTF8(aPassword),aPasswordHashed) then

      break;

  except

    on E: Exception do begin

      Int64(result) := HTML_NOTIMPLEMENTED; // 501

      SetLastException(E,HTML_NOTIMPLEMENTED,@Call);

      exit;

    end;

  end;

end;



function TSQLRestClientURI.CallBackGetResult(const aMethodName: RawUTF8;

  const aNameValueParameters: array of const; aTable: TSQLRecordClass; aID: TID): RawUTF8;

var aResponse: RawUTF8;

begin

  if CallBackGet(aMethodName,aNameValueParameters,aResponse,aTable,aID)=HTML_SUCCESS then

    result := JSONDecode(aResponse) else

    result := '';

end;



function TSQLRestClientURI.CallBackPut(const aMethodName,

  aSentData: RawUTF8; out aResponse: RawUTF8; aTable: TSQLRecordClass;

  aID: TID; aResponseHead: PRawUTF8): integer;

begin

  result := CallBack(mPUT,aMethodName,aSentData,aResponse,aTable,aID,aResponseHead);

end;



function TSQLRestClientURI.CallBack(method: TSQLURIMethod;

  const aMethodName,aSentData: RawUTF8; out aResponse: RawUTF8;

  aTable: TSQLRecordClass; aID: TID; aResponseHead: PRawUTF8): integer;

const NAME: array[mGET..high(TSQLURIMethod)] of RawUTF8 = (

  'GET','POST','PUT','DELETE','HEAD','BEGIN','END','ABORT','LOCK','UNLOCK','STATE',

  'OPTIONS','PROPFIND','PROPPATCH','TRACE','COPY','MKCOL','MOVE','PURGE','REPORT',

  'MKACTIVITY','MKCALENDAR','CHECKOUT','MERGE','NOTIFY','PATCH','SEARCH','CONNECT');

var u: RawUTF8;

{$ifdef WITHLOG}

   Log: ISynLog; // for Enter auto-leave to work with FPC

{$endif}

begin

  if (self=nil) or (method<Low(NAME)) then

    result := HTML_UNAVAILABLE else begin

    u := Model.getURICallBack(aMethodName,aTable,aID);

    {$ifdef WITHLOG}

    Log := fLogClass.Enter('Callback %',[u],self);

    {$endif}

    result := URI(u,NAME[method],@aResponse,aResponseHead,@aSentData).Lo;

    InternalLog('% result=% resplen=%',[NAME[method],result,length(aResponse)],

      sllServiceReturn);

  end;

end;



function TSQLRestClientURI.ServiceRegister(const aInterfaces: array of PTypeInfo;

  aInstanceCreation: TServiceInstanceImplementation;

  const aContractExpected: RawUTF8): boolean;

begin

  result := False;

  if (self=nil) or (high(aInterfaces)<0) then

    exit;

  result := (ServiceContainer as TServiceContainerClient).AddInterface(

    aInterfaces,aInstanceCreation,aContractExpected);

end;



function TSQLRestClientURI.ServiceRegister(aInterface: PTypeInfo;

  aInstanceCreation: TServiceInstanceImplementation;

  const aContractExpected: RawUTF8): TServiceFactory;

begin

  result := nil;

  if (self=nil) or (aInterface=nil) then begin

    SetLastException;

    exit;

  end;

  with ServiceContainer as TServiceContainerClient do

  try

    result := AddInterface(aInterface,aInstanceCreation,aContractExpected);

  except

    on E: Exception do

      SetLastException(E);

  end;

end;



function TSQLRestClientURI.ServiceRegisterClientDriven(aInterface: PTypeInfo;

  out Obj; const aContractExpected: RawUTF8): boolean;

var Factory: TServiceFactory;

begin

  Factory := ServiceRegister(aInterface,sicClientDriven,aContractExpected);

  if Factory<>nil then begin

    result := true;

    Factory.Get(Obj);

  end else

    result := false;

end;



function TSQLRestClientURI.ServiceDefine(const aInterfaces: array of TGUID;

  aInstanceCreation: TServiceInstanceImplementation;

  const aContractExpected: RawUTF8): boolean;

begin

  if self<>nil then

    result := ServiceRegister(TInterfaceFactory.GUID2TypeInfo(aInterfaces),

      aInstanceCreation,aContractExpected) else

    result := false;

end;



function TSQLRestClientURI.ServiceDefine(const aInterface: TGUID;

  aInstanceCreation: TServiceInstanceImplementation;

  const aContractExpected: RawUTF8): TServiceFactoryClient;

begin

  result := TServiceFactoryClient(ServiceRegister(

    TInterfaceFactory.GUID2TypeInfo(aInterface),aInstanceCreation,aContractExpected));

end;



function TSQLRestClientURI.ServiceDefineClientDriven(const aInterface: TGUID;

  out Obj; const aContractExpected: RawUTF8): boolean;

begin

  result := ServiceRegisterClientDriven(

    TInterfaceFactory.GUID2TypeInfo(aInterface),Obj,aContractExpected);

end;



procedure TSQLRestClientURI.ServicePublishOwnInterfaces(OwnServer: TSQLRestServer);

begin

  fServicePublishOwnInterfaces := OwnServer.ServicesPublishedInterfaces;

end;



function TSQLRestClientURI.ServiceRetrieveAssociated(const aServiceName: RawUTF8;

  out URI: TSQLRestServerURIDynArray): boolean;

var json: RawUTF8;

begin

  result := (CallBackGet('stat',['findservice',aServiceName],json)=HTML_SUCCESS) and

    (DynArrayLoadJSON(URI,pointer(json),TypeInfo(TSQLRestServerURIDynArray))<>nil);

end;



function TSQLRestClientURI.ServiceRetrieveAssociated(const aInterface: TGUID;

  out URI: TSQLRestServerURIDynArray): boolean;

var fact: TInterfaceFactory;

begin

  fact := TInterfaceFactory.Get(aInterface);

  if fact=nil then

    result := false else

    result := ServiceRetrieveAssociated(copy(fact.InterfaceName,2,maxInt),URI);

end;



function TSQLRestClientURI.EngineAdd(TableModelIndex: integer;

  const SentData: RawUTF8): TID;

var P: PUTF8Char;

    url, Head: RawUTF8;

begin

  result := 0;

  url := Model.URI[Model.Tables[TableModelIndex]];

  if URI(url,'POST',nil,@Head,@SentData).Lo<>HTML_CREATED then

    exit; // response must be '201 Created'

  P := pointer(Head); // we need to check the headers

  if P<>nil then

  repeat

    // find ID from 'Location: Member Entry URI' header entry

    if IdemPChar(P,'LOCATION:') then begin // 'Location: root/People/11012' e.g.

      inc(P,9);

      while P^>#13 do inc(P); // go to end of line

      P^ := #0; // make line asciiz, even if ended with #13

      while P[-1] in ['0'..'9'] do dec(P); // get all number chars

      if P[-1]='-' then dec(P);

      result := GetInt64(P); // get numerical value at the end of the URI

      exit;

    end;

    while not (P^ in [#0,#13]) do inc(P);

    if P^=#0 then break else inc(P);

    if P^=#10 then inc(P);

  until false;

end;



function TSQLRestClientURI.EngineDelete(TableModelIndex: integer; ID: TID): boolean;

var url: RawUTF8;

begin

  url := Model.getURIID(Model.Tables[TableModelIndex],ID);

  result := URI(url,'DELETE').Lo in [HTML_SUCCESS,HTML_NOCONTENT];

end;



function TSQLRestClientURI.EngineDeleteWhere(TableModelIndex: Integer;

  const SQLWhere: RawUTF8; const IDs: TIDDynArray): boolean;

var url: RawUTF8;

begin  // ModelRoot/TableName?where=WhereClause to delete members

  url := Model.getURI(Model.Tables[TableModelIndex])+'?where='+UrlEncode(SQLWhere);

  result := URI(url,'DELETE').Lo in [HTML_SUCCESS,HTML_NOCONTENT];

end;



function TSQLRestClientURI.EngineList(const SQL: RawUTF8;

  ForceAJAX: Boolean; ReturnedRowCount: PPtrInt): RawUTF8;

begin

  if (self=nil) or (SQL='') or (ReturnedRowCount<>nil) or

     (URI(Model.Root,'GET',@result,nil,@SQL).Lo<>HTML_SUCCESS) then

    result := '';

end;



function TSQLRestClientURI.ClientRetrieve(TableModelIndex: integer; ID: TID;

  ForUpdate: boolean; var InternalState: cardinal; var Resp: RawUTF8): boolean;

begin

  if cardinal(TableModelIndex)<=cardinal(Model.fTablesMax) then

  with URIGet(Model.Tables[TableModelIndex],ID,Resp,ForUpdate) do

    if Lo=HTML_SUCCESS then begin

      InternalState := Hi;

      result := true;

    end else

      result := false else

      result := false;

end;



function TSQLRestClientURI.EngineRetrieveBlob(TableModelIndex: integer; aID: TID;

  BlobField: PPropInfo; out BlobData: TSQLRawBlob): boolean;

var url: RawUTF8;

begin

  if (self=nil) or (aID<=0) or (BlobField=nil) then

    result := false else begin

    // URI is 'ModelRoot/TableName/TableID/BlobFieldName' with GET method

    url := Model.getURICallBack(BlobField^.Name,Model.Tables[TableModelIndex],aID);

    result := URI(url,'GET',@BlobData).Lo=HTML_SUCCESS;

  end;

end;



function TSQLRestClientURI.EngineUpdate(TableModelIndex: integer; ID: TID;

  const SentData: RawUTF8): boolean;

var url: RawUTF8;

begin

  url := Model.getURIID(Model.Tables[TableModelIndex],ID);

  result := URI(url,'PUT',nil,nil,@SentData).Lo in [HTML_SUCCESS,HTML_NOCONTENT];

end;



function TSQLRestClientURI.EngineUpdateBlob(TableModelIndex: integer; aID: TID;

  BlobField: PPropInfo; const BlobData: TSQLRawBlob): boolean;

var url, Head: RawUTF8;

begin

  Head := 'Content-Type: application/octet-stream';

  if (self=nil) or (aID<=0) or (BlobField=nil) then

    result := false else begin

    // PUT ModelRoot/TableName/TableID/BlobFieldName

    FormatUTF8('%/%/%',[Model.URI[Model.Tables[TableModelIndex]],aID,BlobField^.Name],url);

    result := URI(url,'PUT',nil,@Head,@BlobData).Lo in [HTML_SUCCESS,HTML_NOCONTENT];

  end;

end;



function TSQLRestClientURI.EngineUpdateField(TableModelIndex: integer;

  const SetFieldName, SetValue, WhereFieldName, WhereValue: RawUTF8): boolean;

var url: RawUTF8;

begin

  if TableModelIndex<0 then

    result := false else begin

    // PUT ModelRoot/TableName?setname=..&set=..&wherename=..&where=..

    FormatUTF8('%?setname=%&set=%&wherename=%&where=%',

      [Model.URI[Model.Tables[TableModelIndex]],

       SetFieldName,UrlEncode(SetValue),WhereFieldName,UrlEncode(WhereValue)],url);

    result := URI(url,'PUT').Lo in [HTML_SUCCESS,HTML_NOCONTENT];

  end;

end;



function TSQLRestClientURI.EngineBatchSend(Table: TSQLRecordClass; const Data: RawUTF8;

  var Results: TIDDynArray; ExpectedResultsCount: integer): integer;

var Resp: RawUTF8;

    R: PUTF8Char;

    i: integer;

begin // TSQLRest.BatchSend() ensured that Batch contains some data

  try

    // URI is 'ModelRoot/Batch' or 'ModelRoot/Batch/TableName' with PUT method

    result := URI(Model.getURICallBack('Batch',Table,0),'PUT',@Resp,nil,@Data).Lo;

    if result<>HTML_SUCCESS then

      exit;

    // returned Resp shall be an array of integers: '[200,200,...]'

    R := pointer(Resp);

    if R<>nil then

      while not (R^ in ['[',#0]) do inc(R);

    result := HTML_BADREQUEST;

    if (R=nil) or (R^<>'[') then

      // invalid response

      exit;

    SetLength(Results,ExpectedResultsCount);

    if IdemPChar(R,'["OK"]') then begin // to save bandwith if no adding

      for i := 0 to ExpectedResultsCount-1 do

        Results[i] := HTML_SUCCESS;

    end else begin

      inc(R); // jump first '['

      for i := 0 to ExpectedResultsCount-1 do begin

        Results[i] := GetJSONInt64Var(R);

        while R^ in [#1..' '] do inc(R);

        case R^ of

          ',': inc(R);

          ']': break;

          else exit;

        end;

      end;

      if R^<>']' then

        exit;

    end;

    result := HTML_SUCCESS; // returns OK

  finally

    BatchAbort;

  end;

end;



procedure TSQLRestClientURI.BatchAbort;

begin

  if self<>nil then

    FreeAndNil(fBatchCurrent);

end;



function TSQLRestClientURI.BatchAdd(Value: TSQLRecord; SendData: boolean;

  ForceID: boolean=false; const CustomFields: TSQLFieldBits=[]): integer;

begin

  if self=nil then

    result := -1 else

    result := fBatchCurrent.Add(Value,SendData,ForceID,CustomFields);

end;



function TSQLRestClientURI.BatchCount: integer;

begin

  if self=nil then

    result := 0 else

    result := fBatchCurrent.Count;

end;



function TSQLRestClientURI.BatchDelete(ID: TID): integer;

begin

  if self=nil then

    result := -1 else

    result := fBatchCurrent.Delete(ID);

end;



function TSQLRestClientURI.BatchDelete(Table: TSQLRecordClass; ID: TID): integer;

begin

  if self=nil then

    result := -1 else

    result := fBatchCurrent.Delete(Table,ID);

end;



function TSQLRestClientURI.BatchStart(aTable: TSQLRecordClass;

  AutomaticTransactionPerRow: cardinal; Options: TSQLRestBatchOptions): boolean;

begin

  if (self=nil) or (fBatchCurrent<>nil) then

    result := false else begin

    fBatchCurrent := TSQLRestBatch.Create(self,aTable,AutomaticTransactionPerRow,Options);

    fBatchCurrent.fCalledWithinRest := true;

    result := true;

  end;

end;



function TSQLRestClientURI.BatchStartAny(AutomaticTransactionPerRow: cardinal;

  Options: TSQLRestBatchOptions): boolean;

begin

  result := BatchStart(nil,AutomaticTransactionPerRow,Options);

end;



function TSQLRestClientURI.BatchUpdate(Value: TSQLRecord;

  const CustomFields: TSQLFieldBits; DoNotAutoComputeFields: boolean): integer;

begin

  if (self=nil) or (Value=nil) or (fBatchCurrent=nil) or (Value.fID<=0) or

     not BeforeUpdateEvent(Value) then

    result := -1 else

    result := fBatchCurrent.Update(Value,CustomFields,DoNotAutoComputeFields);

end;



function TSQLRestClientURI.BatchSend(var Results: TIDDynArray): integer;

begin

  if self<>nil then

  try

    result := BatchSend(fBatchCurrent,Results);

  finally

    FreeAndNil(fBatchCurrent);

  end else

    result := HTML_BADREQUEST;

end;





{ TSQLRestServer }



const

  ServerPipeNamePrefix: TFileName = '\\.\pipe\mORMot_';



var

  GlobalURIRequestServer: TSQLRestServer = nil;



function URIRequest(url, method, SendData: PUTF8Char; Resp, Head: PPUTF8Char): Int64Rec; cdecl;

function StringToPCharCopy(const s: RawUTF8): PUTF8Char;

var L: integer;

begin

  L := length(s);

  if L=0 then

    result := nil else begin

    inc(L); // copy also last #0 from s

    {$ifdef MSWINDOWS}

    if not USEFASTMM4ALLOC then

      result := pointer(GlobalAlloc(GMEM_FIXED,L)) else

    {$endif}

      GetMem(result,L);

    MoveFast(pointer(s)^,result^,L);

  end;

end;

var call: TSQLRestURIParams;

begin

  if GlobalURIRequestServer=nil then begin

    Int64(result) := HTML_NOTIMPLEMENTED; // 501

    exit;

  end;

  call.Init;

  call.Url := url;

  call.Method := method;

  call.LowLevelConnectionID := PtrInt(GlobalURIRequestServer);

  call.InHead := 'RemoteIP: 127.0.0.1';

  if (Head<>nil) and (Head^<>nil) then

    call.InHead := RawUTF8(Head^)+#13#10+call.InHead;

  SetString(call.InBody,SendData,StrLen(SendData));

  call.RestAccessRights := @SUPERVISOR_ACCESS_RIGHTS;

  GlobalURIRequestServer.URI(call);

  result.Lo := call.OutStatus;

  result.Hi := call.OutInternalState;

  if Head<>nil then

    Head^ := StringToPCharCopy(call.OutHead);

  if Resp<>nil then

    Resp^ := StringToPCharCopy(call.OutBody);

end;



procedure AdministrationExecuteGetFiles(const Folder, Mask: TFileName; const Param: RawUTF8;

  var Answer: TServiceCustomAnswer);

var files: TFindFilesDynArray;

    fn: TFileName;

    fs: Int64;

begin

  if (Param<>'*') and (PosEx(':',Param)=0) and (PosEx(PathDelim,Param)=0) then begin

    fn := IncludeTrailingPathDelimiter(Folder)+UTF8ToString(Param);

    fs := FileSize(fn);

    if (fs>0) and (fs<256 shl 20) then begin // download up to 256 MB

      Answer.Content := StringFromFile(fn);

      if Answer.Content<>'' then begin

        Answer.Header := BINARY_CONTENT_TYPE_HEADER+#13#10'FileName: '+Param;

        exit;

      end;

    end;

  end;

  files := FindFiles(Folder,Mask,'',True,False);

  Answer.Content := DynArraySaveJSON(files,TypeInfo(TFindFilesDynArray));

end;



function ReadString(Handle: cardinal): RawUTF8;

var L, Read: cardinal;

    P: PUTF8Char;

begin

  result := '';

  if (FileRead(Handle,L,4)=4) and (L<>0) then begin

    SetLength(result,L);

    P := pointer(result);

    repeat

      Read := FileRead(Handle,P^,L);

      if Read=0 then begin

        SleepHiRes(100); // nothing available -> wait a little and retry

        Read := FileRead(Handle,P^,L);

        if Read=0 then // server may be down -> abort

          raise ECommunicationException.Create('ReadString');

      end;

      inc(P,Read);

      dec(L,Read);

    until L=0; // loop until received all expected data

  end;

end;



procedure WriteString(Handle: cardinal; const Text: RawUTF8);

var L: cardinal;

begin

  L := length(Text);

  if L=0 then

    // write cardinal 0 if Text=''

    FileWrite(Handle,L,4) else

    // write length+content at once

    {$ifdef FPC}

    begin

      FileWrite(Handle,L,4);

      FileWrite(Handle,pointer(Text)^,L);

    end;

    {$else}

    FileWrite(Handle,pointer(PtrInt(Text)-4)^,L+4);

    {$endif}

end;



{$ifdef MSWINDOWS}



function TSQLRestServer.ExportServerNamedPipe(const ServerApplicationName: TFileName): boolean;

var PipeName: TFileName;

    Pipe: THandle;

begin

  result := false;

  if fExportServerNamedPipeThread<>nil then

    exit; // only one ExportServer() by running process

  if {$ifdef UNICODE}IdemPCharW{$else}IdemPChar{$endif}(pointer(ServerApplicationName),'\\') then

    PipeName := ServerApplicationName else

    PipeName := ServerPipeNamePrefix+ServerApplicationName;

  Pipe := FileOpen(PipeName,fmOpenReadWrite); // is this pipe existing?

  if Pipe<>Invalid_Handle_Value then begin

    WriteString(Pipe,''); // send integer=0 -> force server disconnect

    FileClose(Pipe);

    exit; // only one pipe server with this name at once

  end;

  fExportServerNamedPipeThread := TSQLRestServerNamedPipe.Create(self, PipeName);

  NoAJAXJSON := true; // use smaller JSON size in this not HTTP use (never AJAX)

  result := true; // success

end;



function TSQLRestServer.ExportServerMessage(const ServerWindowName: string): boolean;

begin

  result := false;

  if (self=nil) or (fServerWindow<>0) then

    exit;  // only one ExportServerMessage() by running process

  fServerWindow := CreateInternalWindow(ServerWindowName,self);

  if fServerWindow=0 then

    exit; // impossible to create window -> fail

  fServerWindowName := ServerWindowName;

  result := true;

end;



const

  MAGIC_SYN: cardinal = $A5ABA5AB;



procedure TSQLRestServer.AnswerToMessage(var Msg: TWMCopyData);

var call: TSQLRestURIParams;

    P: PUTF8Char;

    input: PCopyDataStruct;

    Res: packed record

      Magic: cardinal;

      Status: cardinal;

      InternalState: cardinal;

    end;

    Data: TCopyDataStruct;

    Header, ResStr: RawUTF8;

begin

  Msg.Result := HTML_NOTFOUND;

  if (self=nil) or (Msg.From=0) then

    exit;

  input := PCopyDataStruct(Msg.CopyDataStruct);

  P := input^.lpData;

  if (P=nil) or (input^.cbData<=7) then

    exit;

  if PCardinal(P)^<>MAGIC_SYN then

    exit; // invalid layout: a broadcasted WM_COPYDATA message? :(

  inc(P,4);

  // #1 is a field delimiter below, since Get*Item() functions return nil for #0

  Msg.Result := HTML_SUCCESS; // Send something back

  call.Init;

  call.Url := GetNextItem(P,#1);

  call.Method := GetNextItem(P,#1);

  call.InHead := GetNextItem(P,#1);

  call.LowLevelConnectionID := Msg.From;

  Header := 'RemoteIP: 127.0.0.1';

  if call.InHead='' then

    call.InHead := Header else

    call.InHead := call.InHead+#13#10+Header;

  SetString(call.InBody,P,PtrInt(input^.cbData)-(P-input^.lpData));

  call.RestAccessRights := @SUPERVISOR_ACCESS_RIGHTS;

  // note: it's up to URI overridden method to implement access rights

  URI(call);

  Res.Magic := MAGIC_SYN;

  Res.Status := call.OutStatus;

  Res.InternalState := call.OutInternalState;

  {$ifdef FPC} // alf: to circumvent FPC issues

  ResStr := '';

  SetLength(ResStr,sizeof(Res)+Length(call.OutHead)+1+Length(call.OutBody));

  P := pointer(ResStr);

  System.Move(Pointer(@Res)^,P^,sizeof(Res));

  Inc(P,sizeof(Res));

  System.Move(pointer(call.OutHead)^,P^,Length(call.OutHead));

  Inc(P,Length(call.OutHead));

  PByte(P)^ := 1;

  Inc(P);

  System.Move(pointer(call.OutBody)^,P^,Length(call.OutBody));

  {$else}

  SetString(ResStr,PAnsiChar(@Res),sizeof(Res));

  ResStr := ResStr+call.OutHead+#1+call.OutBody;

  {$endif FPC}

  Data.dwData := fServerWindow;

  Data.cbData := length(ResStr);

  Data.lpData := pointer(ResStr);

  SendMessage(Msg.From,WM_COPYDATA,fServerWindow,PtrInt(@Data));

end;



function TSQLRestServer.CloseServerNamedPipe: boolean;

begin

  if fExportServerNamedPipeThread<>nil then begin

    fExportServerNamedPipeThread.Terminate;

    SleepHiRes(200); // we have sleep(128) in TSQLRestServerNamedPipe.EngineExecute

    FreeAndNil(fExportServerNamedPipeThread);

    result := true;

  end else

    result := false;

end;



function TSQLRestServer.CloseServerMessage: boolean;

begin

  result := ReleaseInternalWindow(fServerWindowName,fServerWindow);

end;



function TSQLRestServer.ExportedAsMessageOrNamedPipe: Boolean;

begin

  result := (self<>nil) and

    ((fExportServerNamedPipeThread<>nil) or (fServerWindow<>0));

end;



{$endif MSWINDOWS}



function TSQLRestServer.ExportServer: boolean;

begin

  {$ifdef MSWINDOWS}

  if (fServerWindow<>0) or (fExportServerNamedPipeThread<>nil) then

    result := false else // another server was running

  {$endif MSWINDOWS}

  if (GlobalURIRequestServer=nil) or (GlobalURIRequestServer=self) then begin

    GlobalURIRequestServer := self;

    result := true;

  end else

    result := false;

end;



procedure TSQLRestServer.ServiceMethodRegister(aMethodName: RawUTF8;

  const aEvent: TSQLRestServerCallBack; aByPassAuthentication: boolean);

begin

  aMethodName := trim(aMethodName);

  if aMethodName='' then

    raise EServiceException.CreateUTF8('%.ServiceMethodRegister('''')',[self]);

  if Model.GetTableIndex(aMethodName)>=0 then

    raise EServiceException.CreateUTF8('Published method name %.% '+

      'conflicts with a Table in the Model!',[self,aMethodName]);

  with PSQLRestServerMethod(fPublishedMethods.AddUniqueName(aMethodName,

      'Duplicated published method name %.%',[self,aMethodName]))^ do begin

    CallBack := aEvent;

    ByPassAuthentication := aByPassAuthentication;

  end;

end;



procedure TSQLRestServer.ServiceMethodRegisterPublishedMethods(const aPrefix: RawUTF8;

  aInstance: TObject);

var CallBack: TMethod;

{$ifdef FPC}

type

  PMethodNameRec = ^TMethodNameRec;

  TMethodNameRec = packed record

    name: PShortString;

    addr: pointer;

  end;

  TMethodNameTable = packed record

    count: dword;

    entries: packed array[0..0] of TMethodNameRec;

  end;

  PMethodNameTable =  ^TMethodNameTable;

var methodTable: pMethodNameTable;

    i: integer;

    vmt: TClass;

    pmr: PMethodNameRec;

begin

  vmt := aInstance.ClassType;

  while assigned(vmt) do begin

    methodTable := PMethodNameTable((Pointer(vmt)+vmtMethodTable)^);

    if Assigned(MethodTable) then begin

      CallBack.Data := aInstance;

      pmr := @methodTable^.entries[0];

      for i := 0 to MethodTable^.count-1 do begin

        CallBack.Code := pmr^.addr;

        ServiceMethodRegister(aPrefix+ToUTF8(pmr^.name^),TSQLRestServerCallBack(CallBack));

        inc(pmr);

      end;

    end;

    vmt := vmt.ClassParent;

  end;

end;

{$else}

var i,n: integer;

    C: PtrInt;

    M: PMethodInfo;

    RI: PReturnInfo; // such RTTI info not available at least in Delphi 7

    Param: PParamInfo;

procedure SignatureError;

begin

  raise EServiceException.CreateUTF8(

    'Expected "procedure %.%(Ctxt: TSQLRestServerURIContext)" method signature',

     [self,M^.Name]);

end;

begin

  if aInstance=nil then

    exit;

  if PosEx('/',aPrefix)>0 then

    raise EServiceException.CreateUTF8('%.ServiceMethodRegisterPublishedMethods'+

      '("%"): prefix should not contain "/"',[self,aPrefix]);

  C := PtrInt(aInstance.ClassType);

  while C<>0 do begin

    M := PPointer(C+vmtMethodTable)^;

    if M<>nil then begin

      CallBack.Data := aInstance;

      n := PWord(M)^;

      inc(PWord(M));

      for i := 1 to n do begin

        RI := M^.ReturnInfo;

        if (RI<>nil) then

          // $METHODINFO would also include public methods -> check signature

          if (RI^.CallingConvention<>ccRegister) or (RI^.ReturnType<>nil) then

            SignatureError else

          case RI^.Version of

          1: ; // older Delphi revision do not have much information

          2,3: if RI^.ParamCount<>2 then // self+Ctxt

                 SignatureError else begin

                 Param := RI^.Param;

                 if not IdemPropName(Param^.Name,'self') then

                   SignatureError;

                 Param := Param^.Next;

                 if Param^.ParamType^<>TypeInfo(TSQLRestServerURIContext) then

                   SignatureError;

               end;

          else

          end;

        CallBack.Code := M^.Addr;

        ServiceMethodRegister(aPrefix+ToUTF8(M^.Name),TSQLRestServerCallBack(CallBack));

        inc(PByte(M),M^.Len);

      end;

    end;

    C := PPtrInt(C+vmtParent)^;

    if C=0 then

      break else

      C := PPtrInt(C)^;

  end;

end;

{$endif FPC}



constructor TSQLRestServer.Create(aModel: TSQLModel; aHandleUserAuthentication: boolean);

var t: integer;

    tmp: RawUTF8;

begin

  if aModel=nil then

    raise EORMException.CreateUTF8('%.Create(Model=nil)',[self]);

  // specific server initialization

  fStatLevels := SERVERDEFAULTMONITORLEVELS;

  fVirtualTableDirect := true; // faster direct Static call by default

  fSessions := TObjectListLocked.Create; // needed by AuthenticationRegister() below

  fModel := aModel;

  fSQLAuthUserClass := TSQLAuthUser;

  fSQLAuthGroupClass := TSQLAuthGroup;

  fSQLRecordVersionDeleteTable := TSQLRecordTableDeleted;

  for t := 0 to high(Model.Tables) do

  if fModel.Tables[t].RecordProps.RecordVersionField<>nil then begin

    fSQLRecordVersionDeleteTable := fModel.AddTableInherited(TSQLRecordTableDeleted);

    break;

  end;

  fSessionClass := TAuthSession;

  if aHandleUserAuthentication then // default mORMot authentication schemes

    AuthenticationRegister([TSQLRestServerAuthenticationDefault

      {$ifdef SSPIAUTH},TSQLRestServerAuthenticationSSPI{$endif}]);

  fTrackChangesHistoryTableIndexCount := length(Model.Tables);

  SetLength(fTrackChangesHistory,fTrackChangesHistoryTableIndexCount);

  if fTrackChangesHistoryTableIndexCount>64 then

    fTrackChangesHistoryTableIndexCount := 64; // rows are identified as RecordRef

  SetLength(fTrackChangesHistoryTableIndex,fTrackChangesHistoryTableIndexCount);

  for t := 0 to fTrackChangesHistoryTableIndexCount-1 do

    fTrackChangesHistoryTableIndex[t] := -1;

  fAssociatedServices := TServicesPublishedInterfacesList.Create(0);

  // abstract REST initalization

  inherited Create(aModel);

  fAfterCreation := true;

  fStats := TSQLRestServerMonitor.Create(self);

  URIPagingParameters := PAGINGPARAMETERS_YAHOO;

  fSessionCounter := GetTickCount64*PtrInt(self); // pseudo-random session ID

  if fSessionCounter>cardinal(maxInt) then

    dec(fSessionCounter,maxInt);

  // retrieve published methods

  fPublishedMethods.InitSpecific(TypeInfo(TSQLRestServerMethods),

    fPublishedMethod,djRawUTF8,nil,true);

  ServiceMethodRegisterPublishedMethods('',self);

  ServiceMethodByPassAuthentication('Auth');

  ServiceMethodByPassAuthentication('TimeStamp');

  tmp := 'Batch';

  fPublishedMethodBatchIndex := fPublishedMethods.FindHashed(tmp);

  if fPublishedMethodBatchIndex<0 then

    raise EORMException.CreateUTF8('%.Create: no Batch method!',[self]);

end;



constructor TSQLRestServer.CreateWithOwnModel(const Tables: array of TSQLRecordClass;

  aHandleUserAuthentication: boolean; const aRoot: RawUTF8);

var Model: TSQLModel;

begin

  Model := TSQLModel.Create(Tables,aRoot);

  Create(Model,aHandleUserAuthentication);

  Model.Owner := self;

end;



class function TSQLRestServer.CreateInMemoryForAllVirtualTables(aModel: TSQLModel;

  aHandleUserAuthentication: boolean): TSQLRestServer;

var restClass: TSQLRestClass;

    fake: TSynConnectionDefinition;

begin

  fake := TSynConnectionDefinition.Create;

  try

    fake.Kind := 'TSQLRestServerDB';

    restClass := TSQLRest.ClassFrom(fake);

    if (restClass=nil) or

       not restClass.InheritsFrom(TSQLRestServer) then begin

      // fallback if mORMotSQlite3.pas not linked

      result := TSQLRestServerFullMemory.Create(aModel,aHandleUserAuthentication);

      exit;

    end;

    fake.ServerName := ':memory:'; // avoid dependency to SynSQLite3.pas

    result := TSQLRestServerClass(restClass).RegisteredClassCreateFrom(

      aModel,aHandleUserAuthentication,fake);

  finally

    fake.Free;

  end;

end;



procedure TSQLRestServer.CreateMissingTables(user_version: cardinal=0;

  Options: TSQLInitializeTableOptions=[]);

begin

  fCreateMissingTablesOptions := Options;

end;



procedure TSQLRestServer.InitializeTables(Options: TSQLInitializeTableOptions);

var t: integer;

begin

  if (Self<>nil) and (Model<>nil) then

    for t := 0 to Model.TablesMax do

      if not TableHasRows(Model.Tables[t]) then

        Model.Tables[t].InitializeTable(self,'',Options);

end;



constructor TSQLRestServer.RegisteredClassCreateFrom(aModel: TSQLModel;

  aServerHandleAuthentication: boolean; aDefinition: TSynConnectionDefinition);

begin

  Create(aModel,aServerHandleAuthentication);

end;



destructor TSQLRestServer.Destroy;

var i: integer;

begin

  Shutdown;

  if GlobalURIRequestServer=self then begin

    GlobalURIRequestServer := nil;

    SleepHiRes(200); // way some time any request is finished in another thread

  end;

  // close any running named-pipe or GDI-messages server instance

  {$ifdef MSWINDOWS}

  CloseServerNamedPipe;

  CloseServerMessage;

  {$endif}

  fRecordVersionSlaveCallbacks := nil; // should be done before fServices.Free

  for i := 0 to high(fStaticData) do

    // free all TSQLRestStorage objects and update file if necessary

    fStaticData[i].Free;

  for i := 0 to high(fPublishedMethod) do

    fPublishedMethod[i].Stats.Free;

  FreeAndNil(fSessions);

  FreeAndNil(fAssociatedServices);

  ObjArrayClear(fSessionAuthentication);

  inherited Destroy; // calls fServices.Free which will update fStats

  FreeAndNil(fStats);

end;



procedure TSQLRestServer.Shutdown(const aStateFileName: TFileName);

{$ifdef WITHLOG}

var Log: ISynLog; // for Enter auto-leave to work with FPC

{$endif}

begin

  if fSessions=nil then

    exit; // avoid GPF e.g. in case of missing sqlite3-64.dll

  {$ifdef WITHLOG}

  Log := fLogClass.Enter('Shutdown CurrentRequestCount=% File=%',

    [fStats.AddCurrentRequestCount(0),aStateFileName],self);

  {$endif}

  OnNotifyCallback := nil;

  fSessions.Safe.Lock;

  try

    if fShutdownRequested then

      exit; // Shutdown method already called

    fShutdownRequested := true; // will be identified by TSQLRestServer.URI()

  finally

    fSessions.Safe.UnLock;

  end;

  repeat

    SleepHiRes(5);

  until fStats.AddCurrentRequestCount(0)=0;

  if aStateFileName<>'' then

    SessionsSaveToFile(aStateFileName);

end;



function TSQLRestServer.GetStaticDataServer(aClass: TSQLRecordClass): TSQLRest;

var i: cardinal;

begin

  if (self<>nil) and (fStaticData<>nil) then begin

    i := Model.GetTableIndexExisting(aClass);

    if i<cardinal(length(fStaticData)) then

      result := fStaticData[i] else

      result := nil;

  end else

    result := nil;

end;



function TSQLRestServer.GetStaticDataServerOrVirtualTable(

  aClass: TSQLRecordClass): TSQLRest;

begin

  if (aClass=nil) or ((fStaticData=nil) and (fStaticVirtualTable=nil)) then

    result := nil else

    result := GetStaticDataServerOrVirtualTable(Model.GetTableIndexExisting(aClass));

end;



function TSQLRestServer.GetStaticDataServerOrVirtualTable(aTableIndex: integer): TSQLRest;

begin

  result := nil;

  if aTableIndex>=0 then begin

    if cardinal(aTableIndex)<cardinal(length(fStaticData)) then

      result := fStaticData[aTableIndex];

    if result=nil then

      if fVirtualTableDirect and (fStaticVirtualTable<>nil) then

        result := fStaticVirtualTable[aTableIndex];

  end;

end;



function TSQLRestServer.GetStaticDataServerOrVirtualTable(aTableIndex: integer;

  out Kind: TSQLRestServerKind): TSQLRest;

begin

  result := nil;

  Kind := sMainEngine;

  if aTableIndex>=0 then begin

    if cardinal(aTableIndex)<cardinal(length(fStaticData)) then begin

      result := fStaticData[aTableIndex];

      if result<>nil then begin

        Kind := sStaticDataTable;

        exit;

      end;

    end;

    if fVirtualTableDirect and (fStaticVirtualTable<>nil) then begin

      result := fStaticVirtualTable[aTableIndex];

      if result<>nil then

        Kind := sVirtualTable;

    end;

  end;

end;



function TSQLRestServer.GetRemoteTable(TableIndex: Integer): TSQLRest;

begin

  if (cardinal(TableIndex)>=cardinal(length(fStaticData))) or

     (fStaticData[TableIndex]=nil) or

     not fStaticData[TableIndex].InheritsFrom(TSQLRestStorageRemote) then

    result := nil else

    result := TSQLRestStorageRemote(fStaticData[TableIndex]).RemoteRest;

end;



function TSQLRestServer.GetVirtualTable(aClass: TSQLRecordClass): TSQLRest;

var i: integer;

begin

  result := nil;

  if fStaticVirtualTable<>nil then begin

    i := Model.GetTableIndexExisting(aClass);

    if (i>=0) and (Model.TableProps[i].Kind in IS_CUSTOM_VIRTUAL) then

      result := fStaticVirtualTable[i];

  end;

end;



function TSQLRestServer.IsInternalSQLite3Table(aTableIndex: integer): boolean;

begin

  result := ((cardinal(aTableIndex)>=cardinal(length(fStaticData))) or

             (fStaticData[aTableIndex]=nil)) and

            ((cardinal(aTableIndex)>=cardinal(length(fStaticVirtualTable))) or

             (fStaticVirtualTable[aTableIndex]=nil));

end;



function TSQLRestServer.StaticDataAdd(aStaticData: TSQLRestStorage): boolean;

var i,n,t: cardinal;

begin

  result := false;

  if (self=nil) or (aStaticData=nil) then

    exit;

  i := Model.GetTableIndexExisting(aStaticData.StoredClass);

  n := length(fStaticData);

  if (i<n) and (fStaticData[i]<>nil) and (fStaticData[i]<>aStaticData) then

    exit; // TSQLRecord already registered

  t := length(Model.Tables);

  if n<t then

    SetLength(fStaticData,t);

  fStaticData[i] := aStaticData;

  result := true;

end;



function TSQLRestServer.StaticDataCreate(aClass: TSQLRecordClass;

  const aFileName: TFileName; aBinaryFile: boolean;

  aServerClass: TSQLRestStorageInMemoryClass): TSQLRestStorage;

begin

  result := TSQLRestStorage(GetStaticDataServer(aClass));

  if result<>nil then begin

    // class already registered -> update file name

    (result as aServerClass).fFileName := aFileName;

  end else begin

    // class not already registered -> register now

    if aServerClass=nil then

      aServerClass := TSQLRestStorageInMemory; // default in-memory engine

    result := aServerClass.Create(aClass,self,aFileName,aBinaryFile);

    if not StaticDataAdd(result) then

      raise EORMException.CreateUTF8('Error in %.StaticDataCreate(%)',[self,aClass]);

  end;

end;



function TSQLRestServer.RemoteDataCreate(aClass: TSQLRecordClass;

  aRemoteRest: TSQLRest): TSQLRestStorageRemote;

begin

  if GetStaticDataServer(aClass)<>nil then

    raise EORMException.CreateUTF8('Duplicate %.RemoteDataCreate(%)',[self,aClass]);

  result := TSQLRestStorageRemote.Create(aClass,self,aRemoteRest);

  if not StaticDataAdd(result) then

    raise EORMException.CreateUTF8('Error in %.RemoteDataCreate(%)',[self,aClass]);

end;



procedure TSQLRestServer.FlushInternalDBCache;

begin // do nothing by default

end;



function SQLGetOrder(const SQL: RawUTF8): RawUTF8;

var P: PUTF8Char;

    i: integer;

begin

  i := PosI('ORDER BY ',SQL);

  if i>0 then begin

    inc(i,9);

    while SQL[i] in [#1..' '] do inc(i); // trim left

    result := copy(SQL,i,maxInt);

    P := PosChar(Pointer(Result),' ');

    if P=nil then

      P := PosChar(Pointer(Result),';');

    if P<>nil then

      SetLength(result,P-pointer(Result)); // trim right

  end;

  if result='' then // by default, a SQLite3 query is ordered by ID

    result := 'RowID';

end;



function TSQLRestServer.GetNoAJAXJSON: boolean;

begin

  result := (self<>nil) and (rsoNoAJAXJSON in fOptions);

end;



procedure TSQLRestServer.SetNoAJAXJSON(const Value: boolean);

begin

  if Value then

    include(fOptions,rsoNoAJAXJSON) else

    exclude(fOptions,rsoNoAJAXJSON);

end;



function TSQLRestServer.InternalAdaptSQL(TableIndex: integer; var SQL: RawUTF8): TSQLRest;

begin

  result := nil;

  if (self<>nil) and (TableIndex>=0) then begin // SQL refers to this unique table

    if cardinal(TableIndex)<cardinal(length(fStaticData)) then

      // no SQLite3 module available for fStaticData[] -> we need to

      // retrieve manualy any static table from the SQL SELECT statement

      result := fStaticData[TableIndex];

    if (result=nil) and fVirtualTableDirect and (fStaticVirtualTable<>nil) then begin

      result := fStaticVirtualTable[TableIndex];

      // virtual table may need adaptation (e.g. RowID -> ID)

      if result<>nil then

        if result.InheritsFrom(TSQLRestStorage) and

           not TSQLRestStorage(result).AdaptSQLForEngineList(SQL) then

          // complex request will use SQlite3 virtual engine module

          result := nil;

    end;

  end;

end;



function TSQLRestServer.InternalListRawUTF8(TableIndex: integer; const SQL: RawUTF8): RawUTF8;

var aSQL: RawUTF8;

    Rest: TSQLRest;

begin

  aSQL := SQL;

  Rest := InternalAdaptSQL(TableIndex,aSQL);

  if Rest<>nil then

     // this SQL statement is handled by direct connection, faster adaptation

    result := Rest.EngineList(aSQL) else

    // complex TSQLVirtualTableJSON/External queries will rely on virtual table

    result := MainEngineList(SQL,false,nil);

  if result='[]'#$A then

    result := '';

end;



const

  SQLRECORDVERSION_DELETEID_SHIFT = 58;

  SQLRECORDVERSION_DELETEID_RANGE = Int64(1) shl SQLRECORDVERSION_DELETEID_SHIFT;



procedure TSQLRestServer.InternalRecordVersionMaxFromExisting(RetrieveNext: PID);

var m: integer;

    field: TSQLPropInfoRTTIRecordVersion;

    current,max,mDeleted: Int64;

begin

  fAcquireExecution[execORMWrite].Safe.Lock;

  try

    if fRecordVersionMax=0 then begin // check twice to avoid race condition

      current := 0;

      for m := 0 to Model.TablesMax do begin

        field := Model.Tables[m].RecordProps.RecordVersionField;

        if field<>nil then begin

          if OneFieldValue(Model.Tables[m],'max('+field.Name+')','',[],[],max) then

            if max>current then

              current := max;

          mDeleted := Int64(m) shl SQLRECORDVERSION_DELETEID_SHIFT;

          if OneFieldValue(fSQLRecordVersionDeleteTable,'max(ID)','ID>? and ID<?',

             [],[mDeleted,mDeleted+SQLRECORDVERSION_DELETEID_RANGE],max) then begin

            max := max and pred(SQLRECORDVERSION_DELETEID_RANGE);

            if max>current then

              current := max;

          end;

        end;

      end;

    end else

      current := fRecordVersionMax;

    if RetrieveNext<>nil then begin

      inc(current);

      RetrieveNext^ := current;

    end;

    fRecordVersionMax := current;

  finally

    fAcquireExecution[execORMWrite].Safe.UnLock;

  end;

end;



function TSQLRestServer.InternalRecordVersionComputeNext: TRecordVersion;

begin

  if fRecordVersionMax=0 then

    InternalRecordVersionMaxFromExisting(@result) else begin

    fAcquireExecution[execORMWrite].Safe.Lock;

    inc(fRecordVersionMax);

    result := fRecordVersionMax;

    fAcquireExecution[execORMWrite].Safe.UnLock;

  end;

end;



function TSQLRestServer.RecordVersionCompute: TRecordVersion;

begin

  result := InternalRecordVersionComputeNext;

  if result>=SQLRECORDVERSION_DELETEID_RANGE then

    raise EORMException.CreateUTF8('%.InternalRecordVersionCompute=% overflow: '+

      '%.ID should be < 2^%)',[self,result,fSQLRecordVersionDeleteTable,

      SQLRECORDVERSION_DELETEID_SHIFT]);

end;



function TSQLRestServer.RecordVersionCurrent: TRecordVersion;

begin

  if self=nil then

    result := 0 else begin

    if fRecordVersionMax=0 then

      InternalRecordVersionMaxFromExisting(nil);

    result := fRecordVersionMax;

  end;

end;



procedure TSQLRestServer.InternalRecordVersionHandle(Occasion: TSQLOccasion;

  TableIndex: integer; var Decoder: TJSONObjectDecoder;

  RecordVersionField: TSQLPropInfoRTTIRecordVersion);

begin

  if RecordVersionField=nil then

    exit; // no TRecordVersion field to track

  if Decoder.FindFieldName(RecordVersionField.Name)<0 then

    // only compute new monotonic TRecordVersion if not already supplied by sender

    Decoder.AddFieldValue(RecordVersionField.Name,Int64ToUtf8(RecordVersionCompute),ftaNumber);

  if (fServices<>nil) then

    (fServices as TServiceContainerServer).RecordVersionNotifyAddUpdate(

      Occasion,TableIndex,Decoder);

end;



procedure TSQLRestServer.InternalRecordVersionDelete(TableIndex: integer;

  ID: TID; Batch: TSQLRestBatch);

var deleted: TSQLRecordTableDeleted;

    revision: TRecordVersion;

begin

  if fRecordVersionDeleteIgnore then

    exit;

  deleted := fSQLRecordVersionDeleteTable.Create;

  try

    revision := RecordVersionCompute;

    deleted.IDValue := revision+Int64(TableIndex) shl SQLRECORDVERSION_DELETEID_SHIFT;

    deleted.Deleted := ID;

    if Batch<>nil then

      Batch.Add(deleted,True,True) else

      Add(deleted,True,True);

    if (fServices<>nil) then

      (fServices as TServiceContainerServer).RecordVersionNotifyDelete(

        TableIndex,ID,Revision);

  finally

    deleted.Free;

  end;

end;



function TSQLRestServer.RecordVersionSynchronizeSlave(Table: TSQLRecordClass;

  Master: TSQLRest; ChunkRowLimit: integer; OnWrite: TOnBatchWrite): TRecordVersion;

var Writer: TSQLRestBatch;

    IDs: TIDDynArray;

{$ifdef WITHLOG}

    Log: ISynLog; // for Enter auto-leave to work with FPC

begin

  Log := fLogClass.Enter('RecordVersionSynchronizeSlave %',[Table],self);

{$else}

begin

{$endif}

  result := -1; // error

  if fRecordVersionMax=0 then

    InternalRecordVersionMaxFromExisting(nil);

  repeat

    Writer := RecordVersionSynchronizeSlaveToBatch(

      Table,Master,fRecordVersionMax,ChunkRowLimit,OnWrite);

    if Writer=nil then

      exit; // error

    if Writer.Count=0 then begin // nothing new (e.g. reached last chunk)

      result := fRecordVersionMax;

      Writer.Free;

      break;

    end else

    try

      fAcquireExecution[execORMWrite].Safe.Lock;

      fRecordVersionDeleteIgnore := true;

      if BatchSend(Writer,IDs)=HTML_SUCCESS then begin

        InternalLog('%.RecordVersionSynchronize Added=% Updated=% Deleted=% on %',

          [ClassType,Writer.AddCount,Writer.UpdateCount,Writer.DeleteCount,Master],sllDebug);

        if ChunkRowLimit=0 then begin

          result := fRecordVersionMax;

          break;

        end;

      end else begin

        InternalLog('%.RecordVersionSynchronize BatchSend() failed',[ClassType],sllError);

        fRecordVersionMax := 0; // force recompute the maximum from DB

        break;

      end;

    finally

      fRecordVersionDeleteIgnore := false;

      fAcquireExecution[execORMWrite].Safe.UnLock;

      Writer.Free;

    end;

  until false;

end;



function TSQLRestServer.RecordVersionSynchronizeSlaveToBatch(Table: TSQLRecordClass;

  Master: TSQLRest; var RecordVersion: TRecordVersion; MaxRowLimit: integer;

  OnWrite: TOnBatchWrite): TSQLRestBatch;

var TableIndex,SourceTableIndex,UpdatedRow,DeletedRow: integer;

    Props: TSQLRecordProperties;

    Where: RawUTF8;

    UpdatedVersion,DeletedVersion: TRecordVersion;

    ListUpdated,ListDeleted: TSQLTableJSON;

    Rec: TSQLRecord;

    DeletedMinID: TID;

    Deleted: TSQLRecordTableDeleted;

{$ifdef WITHLOG}

    Log: ISynLog; // for Enter auto-leave to work with FPC

begin

  Log := fLogClass.Enter('RecordVersionSynchronizeSlaveToBatch %',[Table],self);

{$else}

begin

{$endif}

  result := nil;

  if Master=nil then

    raise EORMException.CreateUTF8('%.RecordVersionSynchronizeSlaveToBatch(Master=nil)',[self]);

  TableIndex := Model.GetTableIndexExisting(Table);

  SourceTableIndex := Master.Model.GetTableIndexExisting(Table); // <>TableIndex?

  Props := Model.TableProps[TableIndex].Props;

  if Props.RecordVersionField=nil then

    raise EORMException.CreateUTF8(

      '%.RecordVersionSynchronizeSlaveToBatch(%) with no TRecordVersion field',[self,Table]);

  fAcquireExecution[execORMWrite].Safe.Lock;

  try

    Where := '%>? order by %';

    if MaxRowLimit>0 then

      Where := FormatUTF8('% limit %',[Where,MaxRowLimit]);

    ListUpdated := Master.MultiFieldValues(Table,'*',Where,

      [Props.RecordVersionField.Name,Props.RecordVersionField.Name],[RecordVersion]);

    if ListUpdated=nil then

      exit; // DB error

    ListDeleted := nil;

    try

      DeletedMinID := Int64(SourceTableIndex) shl SQLRECORDVERSION_DELETEID_SHIFT;

      Where := 'ID>? and ID<? order by ID';

      if MaxRowLimit>0 then

        Where := FormatUTF8('% limit %',[Where,MaxRowLimit]);

      ListDeleted := Master.MultiFieldValues(fSQLRecordVersionDeleteTable,

        'ID,Deleted',Where,[DeletedMinID+RecordVersion,

        DeletedMinID+SQLRECORDVERSION_DELETEID_RANGE]);

      if ListDeleted=nil then

        exit; // DB error

      result := TSQLRestBatch.Create(self,nil,10000);

      result.OnWrite := OnWrite;

      if (ListUpdated.fRowCount=0) and (ListDeleted.fRowCount=0) then

        exit; // nothing new -> returns void TSQLRestBach with Count=0

      Rec := Table.Create;

      Deleted := fSQLRecordVersionDeleteTable.Create;

      try

        Rec.FillPrepare(ListUpdated);

        Deleted.FillPrepare(ListDeleted);

        UpdatedRow := 1;

        DeletedRow := 1;

        UpdatedVersion := 0;

        DeletedVersion := 0;

        repeat // compute all changes in increasing version order

          if UpdatedVersion=0 then

            if UpdatedRow<=ListUpdated.fRowCount then begin

              Rec.FillRow(UpdatedRow);

              UpdatedVersion := Props.RecordVersionField.PropInfo.GetInt64Prop(Rec);

              inc(UpdatedRow);

            end;

          if DeletedVersion=0 then

            if DeletedRow<=ListDeleted.fRowCount then begin

              Deleted.FillRow(DeletedRow);

              DeletedVersion := Deleted.IDValue and pred(SQLRECORDVERSION_DELETEID_RANGE);

              inc(DeletedRow);

            end;

          if (UpdatedVersion=0) and (DeletedVersion=0) then

            break; // no more update available

          if (UpdatedVersion>0) and

             ((DeletedVersion=0) or (UpdatedVersion<DeletedVersion)) then begin

            if (RecordVersion=0) or

               (OneFieldValue(Table,'ID',Rec.IDValue)='') then

              result.Add(Rec,true,true,Rec.fFill.TableMapFields,true) else

              result.Update(Rec,[],true);

            RecordVersion := UpdatedVersion;

            UpdatedVersion := 0;

          end else

          if DeletedVersion>0 then begin

            result.Delete(Table,Deleted.Deleted);

            Deleted.IDValue := DeletedVersion+ // local ID follows current Model

              Int64(TableIndex) shl SQLRECORDVERSION_DELETEID_SHIFT;

            result.Add(Deleted,true,true,[],true);

            RecordVersion := DeletedVersion;

            DeletedVersion := 0;

          end;

        until false;

      finally

        Deleted.Free;

        Rec.Free;

      end;

    finally

      ListUpdated.Free;

      ListDeleted.Free;

    end;

  finally

    fAcquireExecution[execORMWrite].Safe.UnLock;

  end;

end;



function TSQLRestServer.ServiceContainer: TServiceContainer;

begin

  if fServices=nil then

    fServices := TServiceContainerServer.Create(self);

  result := fServices;

end;



function TSQLRestServer.RecordVersionSynchronizeSubscribeMaster(Table: TSQLRecordClass;

  RecordVersion: TRecordVersion; const SlaveCallback: IServiceRecordVersionCallback): boolean;

begin

  if self=nil then

    result := false else

    result := (ServiceContainer as TServiceContainerServer).

      RecordVersionSynchronizeSubscribeMaster(Model.GetTableIndexExisting(Table),

        RecordVersion,SlaveCallback);

end;



function TSQLRestServer.RecordVersionSynchronizeMasterStart(

  ByPassAuthentication: boolean): boolean;

var factory: TServiceFactoryServer;

begin

  if Services<>nil then begin

    factory := Services.Info(TypeInfo(IServiceRecordVersion)) as TServiceFactoryServer;

    if factory<>nil then begin

      result := factory.ByPassAuthentication=ByPassAuthentication;

      exit; // already registered with the same authentication parameter

    end;

  end;

  factory := ServiceRegister(TServiceRecordVersion,[TypeInfo(IServiceRecordVersion)],sicShared);

  if factory<>nil then begin

    if ByPassAuthentication then

      factory.ByPassAuthentication := ByPassAuthentication;

    result := true;

  end else

    result := false;

end;



function TSQLRestServer.RecordVersionSynchronizeSlaveStart(Table: TSQLRecordClass;

  MasterRemoteAccess: TSQLRestClientURI; OnNotify: TOnBatchWrite): boolean;

var current,previous: TRecordVersion;

    tableIndex: integer;

    tableName: RawUTF8;

    service: IServiceRecordVersion;

    callback: IServiceRecordVersionCallback;

    retry: integer;

begin

  //alfchange

  callback:=nil;

  result := false;

  if (self=nil) or (MasterRemoteAccess=nil) then

    exit;

  tableIndex := Model.GetTableIndexExisting(Table);

  if (fRecordVersionSlaveCallbacks<>nil) and

     (fRecordVersionSlaveCallbacks[tableIndex]<>nil) then begin

    InternalLog('%.RecordVersionSynchronizeSlaveStart(%): already running',[self,Table],sllWarning);

    exit;

  end;

  tableName := Model.TableProps[tableIndex].Props.SQLTableName;

  if MasterRemoteAccess.Services.Info(IServiceRecordVersion)=nil then

    if not MasterRemoteAccess.ServiceRegister([TypeInfo(IServiceRecordVersion)],sicShared) then

      exit;

  if not MasterRemoteAccess.Services.Resolve(IServiceRecordVersion,service) then

    exit;

  current := 0;

  retry := 0;            

  repeat

    repeat // retrieve all pending versions (may retry up to 5 times)

      previous := current;

      current := RecordVersionSynchronizeSlave(Table,MasterRemoteAccess,10000,OnNotify);

      if current<0 then begin

        InternalLog('%.RecordVersionSynchronizeSlaveStart(%): REST failure',[self,Table],sllError);

        exit;

      end;

    until current=previous;

    // subscribe for any further modification

    if callback=nil then

      callback := TServiceRecordVersionCallback.Create(self,MasterRemoteAccess,Table,OnNotify);

    if service.Subscribe(tableName,current,callback) then begin // push notifications

      if fRecordVersionSlaveCallbacks=nil then

        SetLength(fRecordVersionSlaveCallbacks,Model.TablesMax+1);

      fRecordVersionSlaveCallbacks[tableIndex] := callback;

      InternalLog('%.RecordVersionSynchronizeSlaveStart(%): started from revision %',

        [self,Table,current],sllDebug);

      result := true;

      exit;

    end;

    // some modifications since version (i.e. last RecordVersionSynchronizeSlave)

    inc(retry);

  until retry=5; // avoid endless loop (most of the time, not needed)

  InternalLog('%.RecordVersionSynchronizeSlaveStart(%): retry failure',[self,Table],sllError);

end;



function TSQLRestServer.RecordVersionSynchronizeSlaveStop(Table: TSQLRecordClass): boolean;

var tableIndex: integer;

begin

  result := false;

  if self=nil then

    exit;

  tableIndex := Model.GetTableIndexExisting(Table);

  if (fRecordVersionSlaveCallbacks=nil) or

     (fRecordVersionSlaveCallbacks[tableIndex]=nil) then begin

    InternalLog('%.RecordVersionSynchronizeSlaveStop(%): not running',[self,Table],sllWarning);

    exit;

  end;

  fRecordVersionSlaveCallbacks[tableIndex] := nil; // will notify the server

  result := true;

end;



function TSQLRestServer.UnLock(Table: TSQLRecordClass; aID: TID): boolean;

begin

  result := Model.UnLock(Table,aID);

end;



procedure TSQLRestServer.Commit(SessionID: cardinal; RaiseException: boolean);

var i: integer;

begin

  inherited Commit(SessionID,RaiseException);

  if self<>nil then

    for i := 0 to high(fStaticVirtualTable) do

    if fStaticVirtualTable[i]<>nil then

    with TSQLRestStorageInMemory(fStaticVirtualTable[i]) do

      if InheritsFrom(TSQLRestStorageInMemory) and not CommitShouldNotUpdateFile then

        UpdateFile; // will do nothing if not Modified

end;



function TSQLRestServer.Delete(Table: TSQLRecordClass; ID: TID): boolean;

begin

  result := inherited Delete(Table,ID); // call EngineDelete

  if result then

    // force relational database coherency (i.e. our FOREIGN KEY implementation)

    AfterDeleteForceCoherency(Model.GetTableIndex(Table),ID);

end;



function TSQLRestServer.Delete(Table: TSQLRecordClass; const SQLWhere: RawUTF8): boolean;

var IDs: TIDDynArray;

    TableIndex,i: integer;

begin

  result := InternalDeleteNotifyAndGetIDs(Table,SQLWhere,IDs);

  if (IDs=nil) or not result then

    exit; // nothing to delete

  TableIndex := Model.GetTableIndexExisting(Table);

  result := EngineDeleteWhere(TableIndex,SQLWhere,IDs);

  if result then

    // force relational database coherency (i.e. our FOREIGN KEY implementation)

    for i := 0 to high(IDs) do

      AfterDeleteForceCoherency(TableIndex,IDs[i]);

end;



function TSQLRestServer.TableRowCount(Table: TSQLRecordClass): Int64;

var Rest: TSQLRest;

begin

  Rest := GetStaticDataServerOrVirtualTable(Table);

  if Rest<>nil then // faster direct call

    result := Rest.TableRowCount(Table) else

    result := inherited TableRowCount(Table);

end;



function TSQLRestServer.TableHasRows(Table: TSQLRecordClass): boolean;

var Rest: TSQLRest;

begin

  Rest := GetStaticDataServerOrVirtualTable(Table);

  if Rest<>nil then // faster direct call

    result := Rest.TableHasRows(Table) else

    result := inherited TableHasRows(Table);

end;



function TSQLRestServer.UpdateBlobFields(Value: TSQLRecord): boolean;

var Rest: TSQLRest;

begin // overridden method to update all BLOB fields at once

  if (Value=nil) or (Value.fID<=0) then

    result := false else begin

    Rest := GetStaticDataServerOrVirtualTable(PSQLRecordClass(Value)^);

    if Rest<>nil then // faster direct call

      result := Rest.UpdateBlobFields(Value) else

      result := inherited UpdateBlobFields(Value);

  end;

end;



function TSQLRestServer.RetrieveBlobFields(Value: TSQLRecord): boolean;

var Rest: TSQLRest;

begin // overridden method to update all BLOB fields at once

  if Value=nil then

    result := false else begin

    Rest := GetStaticDataServerOrVirtualTable(PSQLRecordClass(Value)^);

    if Rest<>nil then // faster direct call

      result := Rest.RetrieveBlobFields(Value) else

      result := inherited RetrieveBlobFields(Value);

  end;

end;



function TSQLRestServer.AfterDeleteForceCoherency(aTableIndex: integer;

  aID: TID): boolean;



  procedure PerformCascade(const Where: Int64; Ref: PSQLModelRecordReference);

  var W: RawUTF8;

      cascadeOK: boolean;

      Rest: TSQLRest;

  begin // set Field=0 or delete row where Field references aID

    if Where=0 then

      exit;

    Int64ToUTF8(Where,W);

    if Ref^.CascadeDelete then

      cascadeOK := Delete(Model.Tables[Ref^.TableIndex],

        Ref^.FieldType.Name+'=:('+W+'):') else begin

      Rest := GetStaticDataServerOrVirtualTable(Ref^.TableIndex);

      if Rest<>nil then // fast direct call

        cascadeOK := Rest.EngineUpdateField(Ref^.TableIndex,

          Ref^.FieldType.Name,'0',Ref^.FieldType.Name,W) else

        cascadeOK := MainEngineUpdateField(Ref^.TableIndex,

          Ref^.FieldType.Name,'0',Ref^.FieldType.Name,W);

    end;

    if not cascadeOK then

      InternalLog('%.AfterDeleteForceCoherency() failed to handle field %.%',

        [ClassType,Model.Tables[Ref^.TableIndex],Ref^.FieldType.Name],sllWarning);

  end;



var i: integer;

    Ref: PSQLModelRecordReference;

begin

  Ref := @Model.fRecordReferences[0];

  if Ref<>nil then begin

    for i := 1 to length(Model.fRecordReferences) do begin

      if Ref^.FieldTableIndex=-2 then // lazy initialization

        Ref^.FieldTableIndex := Model.GetTableIndexSafe(Ref^.FieldTable,false);

      case Ref^.FieldType.SQLFieldType of

      sftRecord: // TRecordReference published field

        PerformCascade(RecordReference(aTableIndex,aID),Ref);

      sftID:     // TSQLRecord published field

        if Ref^.FieldTableIndex=aTableIndex then

          PerformCascade(aID,Ref);

      sftTID:    // TTableID = type TID published field

        if Ref^.FieldTableIndex=aTableIndex then

          PerformCascade(aID,Ref);

      end;

      inc(Ref);

    end;

  end;

  result := true; // success even if no match found, or some cascade warnings

end;



function TSQLRestServer.CreateSQLMultiIndex(Table: TSQLRecordClass;

  const FieldNames: array of RawUTF8; Unique: boolean; IndexName: RawUTF8=''): boolean;

var SQL: RawUTF8;

    i, TableIndex: integer;

    Props: TSQLRecordProperties;

    Rest: TSQLRest;

begin

  result := false;

  if high(FieldNames)<0 then

    exit; // avoid endless loop for TSQLRestStorage with no overridden method

  TableIndex := Model.GetTableIndexExisting(Table);

  Rest := nil;

  if TableIndex>=0 then begin // bypass fVirtualTableDirect 

    if cardinal(TableIndex)<cardinal(length(fStaticData)) then

      Rest := fStaticData[TableIndex];

    if (Rest=nil) and (fStaticVirtualTable<>nil) then

      Rest := fStaticVirtualTable[TableIndex];

  end;

  if Rest<>nil then begin

    if Rest.InheritsFrom(TSQLRestStorage) then

       // will try to create an index on the static table (e.g. for external DB)

       result := TSQLRestStorage(Rest).

         CreateSQLMultiIndex(Table,FieldNames,Unique,IndexName);

    exit;

  end;

  if (high(FieldNames)=0) and IsRowID(pointer(FieldNames[0])) then begin

    result := true; // SQLite3 has always its ID/RowID primary key indexed

    exit;

  end;

  Props := Model.TableProps[TableIndex].Props;

  for i := 0 to high(FieldNames) do

    if not IsRowID(pointer(FieldNames[i])) then

      if (Props.Fields.IndexByName(FieldNames[i])<0) then

        exit; // wrong field name

  if Unique then

    SQL := 'UNIQUE ' else

    SQL := '';

  if IndexName='' then begin

    IndexName := RawUTF8ArrayToCSV(FieldNames,'');

    if length(IndexName)+length(Props.SQLTableName)>64 then

      // avoid reaching potential identifier name size limit

      IndexName := crc32cUTF8ToHex(Props.SQLTableName)+

                   crc32cUTF8ToHex(IndexName);

  end;

  SQL := FormatUTF8('CREATE %INDEX IF NOT EXISTS Index%% ON %(%);',

    [SQL,Props.SQLTableName,IndexName,Props.SQLTableName,RawUTF8ArrayToCSV(FieldNames,',')]);

  result := EngineExecute(SQL);

end;



function TSQLRestServer.CreateSQLIndex(Table: TSQLRecordClass; const FieldName: RawUTF8;

  Unique: boolean; const IndexName: RawUTF8=''): boolean;

begin

  result := CreateSQLMultiIndex(Table,[FieldName],Unique,IndexName);

end;



function TSQLRestServer.CreateSQLIndex(Table: TSQLRecordClass;

  const FieldNames: array of RawUTF8; Unique: boolean): boolean;

var i: integer;

begin

  result := true;

  for i := 0 to high(FieldNames) do

    if not CreateSQLMultiIndex(Table,[FieldNames[i]],Unique) then

     result := false;

end;



function TSQLRestServer.GetAuthenticationSchemesCount: integer;

begin

  result := length(fSessionAuthentication);

end;



function TSQLRestServer.GetCurrentSessionUserID: TID;

begin

  with PServiceRunningContext(@ServiceContext)^ do

    if (Request<>nil) and (Request.Session>CONST_AUTHENTICATION_NOT_USED) then

      result := Request.SessionUser else

      result := 0;

end;



function TSQLRestServer.AuthenticationRegister(

  aMethod: TSQLRestServerAuthenticationClass): TSQLRestServerAuthentication;

var i: integer;

begin

  result := nil;

  if self=nil then

    exit;

  fSessions.Safe.Lock;

  try

    for i := 0 to high(fSessionAuthentication) do

      if fSessionAuthentication[i].ClassType=aMethod then begin

        result := fSessionAuthentication[i];

        exit; // method already there

      end;

    // create and initialize new authentication instance

    result := aMethod.Create(self);

    ObjArrayAdd(fSessionAuthentication,result); // will be owned by fSessionAuthentications

    fHandleAuthentication := true;

    // we need both AuthUser+AuthGroup tables for authentication -> create now

    fSQLAuthGroupClass := Model.AddTableInherited(TSQLAuthGroup);

    fSQLAuthUserClass := Model.AddTableInherited(TSQLAuthUser);

    if fAfterCreation and

      ((not TableHasRows(fSQLAuthUserClass)) or

       (not TableHasRows(fSQLAuthGroupClass))) then

      CreateMissingTables(0,fCreateMissingTablesOptions);

  finally

    fSessions.Safe.UnLock;

  end;

end;



procedure TSQLRestServer.AuthenticationRegister(

  const aMethods: array of TSQLRestServerAuthenticationClass);

var i: integer;

begin

  for i := 0 to high(aMethods) do

    AuthenticationRegister(aMethods[i]);

end;



procedure TSQLRestServer.AuthenticationUnregister(aMethod: TSQLRestServerAuthenticationClass);

var i: integer;

begin

  if (self=nil) or (fSessionAuthentication=nil) then

    exit;

  fSessions.Safe.Lock;

  try

    for i := 0 to high(fSessionAuthentication) do

      if fSessionAuthentication[i].ClassType=aMethod then begin

        ObjArrayDelete(fSessionAuthentication,i);

        fHandleAuthentication := (fSessionAuthentication<>nil);

        break;

      end;

  finally

    fSessions.Safe.UnLock;

  end;

end;



procedure TSQLRestServer.AuthenticationUnregister(

  const aMethods: array of TSQLRestServerAuthenticationClass);

var i: integer;

begin

  for i := 0 to high(aMethods) do

    AuthenticationUnregister(aMethods[i]);

end;



procedure TSQLRestServer.AuthenticationUnregisterAll;

begin

  if (self=nil) or (fSessionAuthentication=nil) then

    exit;

  fSessions.Safe.Lock;

  ObjArrayClear(fSessionAuthentication);

  fSessions.Safe.UnLock;

end;



procedure TSQLRestServer.ServiceMethodByPassAuthentication(const aMethodName: RawUTF8);

var i: Integer;

begin

  if self=nil then

    exit;

  if aMethodName='' then

    for i := 0 to fPublishedMethods.Count-1 do

      fPublishedMethod[i].ByPassAuthentication := true else begin

    i := fPublishedMethods.FindHashed(aMethodName);

    if i>=0 then

      fPublishedMethod[i].ByPassAuthentication := true;

  end;

end;



function TSQLRestServer.GetServiceMethodStat(const aMethod: RawUTF8): TSynMonitorInputOutput;

var i: Integer;

begin

  if self=nil then

    i := -1 else

    i := fPublishedMethods.FindHashed(aMethod);

  if i>=0 then

    result := fPublishedMethod[i].Stats else

    result := nil;

end;



procedure TSQLRestServer.SetPublicURI(const Address,Port: RawUTF8);

begin

  fPublicURI.Address := Address;

  fPublicURI.Port := Port;

  fPublicURI.Root := Model.Root;

end;



const // text definition registered in unit's initialization block below

  _TSQLRestServerURI = 'Address,Port,Root RawUTF8';

  _TServicesPublishedInterfaces =

    'PublicURI{Address,Port,Root RawUTF8} Names array of RawUTF8';



function TSQLRestServer.ServicesPublishedInterfaces: RawUTF8;

var nfo: TServicesPublishedInterfaces;

begin

  if (self=nil) or (Services=nil) then

    result := '' else begin

    nfo.PublicURI := fPublicURI;

    Services.SetInterfaceNames(nfo.Names);

    result := RecordSaveJSON(nfo,TypeInfo(TServicesPublishedInterfaces));

  end;

end;





{ Low-level background execution functions }



type

  TInterfacedObjectHooked = class(TInterfacedObject)

  public

    procedure InternalRelease;

  end;



  TBackgroundLauncherAction = (

    doCallMethod, doInstanceRelease, doThreadMethod);



  PBackgroundLauncher = ^TBackgroundLauncher;

  TBackgroundLauncher = record

    Context: PServiceRunningContext;

    case Action: TBackgroundLauncherAction of

    doCallMethod:

      (CallMethodArgs: pointer); // PCallMethodArgs

    doInstanceRelease:

      (Instance: TInterfacedObjectHooked);

    doThreadMethod:

      (ThreadMethod: TThreadMethod)

  end;



procedure TInterfacedObjectHooked.InternalRelease;

begin

  if self<>nil then

    IInterface(self)._Release; // call the release interface

end;



procedure BackgroundExecuteProc(Call: pointer); forward;



{$ifdef DELPHI6OROLDER} {$ifndef LVCL}

type TThreadHook = class(TThread);

{$endif} {$endif}



procedure BackGroundExecute(var synch: TBackgroundLauncher;

  backgroundThread: TSynBackgroundThreadMethod);

var event: TThreadMethod;

{$ifdef DELPHI6OROLDER} {$ifndef LVCL}

    tempThread: TThread;

{$endif} {$endif}

begin

  synch.Context := @ServiceContext;

  TMethod(event).Code := @BackgroundExecuteProc;

  TMethod(event).Data := @synch;

  if backgroundThread=nil then

    if GetCurrentThreadID=MainThreadID then

      event else

      {$ifdef LVCL}

      raise EServiceException.Create('BackGroundExecute(thread=nil)')

      {$else}

      {$ifdef DELPHI6OROLDER}

      if synch.Context^.RunningThread=nil then begin

        // circumvent Delphi 6 limitation by using a temporary TThread

        tempThread := TThread.Create(true);

        try

          TThreadHook(tempThread).Synchronize(event)

        finally

          tempThread.Free; // slightly slower, but working

        end;

      end else

        TThreadHook(synch.Context^.RunningThread).Synchronize(event)

      {$else}

      TThread.Synchronize(synch.Context^.RunningThread,event)

      {$endif DELPHI6OROLDER}

      {$endif LVCL} else

    backgroundThread.RunAndWait(event);

end;



procedure BackgroundExecuteCallMethod(args: pointer;

  backgroundThread: TSynBackgroundThreadMethod);

var synch: TBackgroundLauncher;

begin

  synch.Action := doCallMethod;

  synch.CallMethodArgs := args;

  BackGroundExecute(synch,backgroundThread);

end;



procedure BackgroundExecuteInstanceRelease(instance: TObject;

  backgroundThread: TSynBackgroundThreadMethod);

var synch: TBackgroundLauncher;

begin

  synch.Action := doInstanceRelease;

  if not instance.InheritsFrom(TInterfacedObject) then

    raise EServiceException.CreateUTF8('BackgroundExecuteInstanceRelease(%)',[instance]);

  synch.Instance := TInterfacedObjectHooked(instance);

  BackGroundExecute(synch,backgroundThread);

end;



procedure BackgroundExecuteThreadMethod(const method: TThreadMethod;

  backgroundThread: TSynBackgroundThreadMethod);

var synch: TBackgroundLauncher;

begin

  synch.Action := doThreadMethod;

  synch.ThreadMethod := method;

  BackGroundExecute(synch,backgroundThread);

end;





{ TSQLRestServerURIContext }



constructor TSQLRestServerURIContext.Create(aServer: TSQLRestServer;

  const aCall: TSQLRestURIParams);

begin

  Server := aServer;

  Call := @aCall;

  Method := StringToMethod(aCall.method);;

  fThreadServer := @ServiceContext;

  fThreadServer^.Request := self;

end;



destructor TSQLRestServerURIContext.Destroy;

begin

  fThreadServer^.Request := nil;

  inherited Destroy;

end;



procedure TSQLRestServerURIContext.InternalSetTableFromTableName(TableName: PUTF8Char);

begin

  TableEngine := Server;

  InternalSetTableFromTableIndex(Server.Model.GetTableIndex(TableName));

  if TableIndex<0 then

    exit;

  Static := Server.GetStaticDataServerOrVirtualTable(TableIndex,StaticKind);

  if Static<>nil then

    TableEngine := Static;

end;



procedure TSQLRestServerURIContext.InternalSetTableFromTableIndex(Index: integer);

begin

  TableIndex := Index;

  if TableIndex>=0 then

    with Server.Model do begin

      self.Table := Tables[TableIndex];

      self.TableRecordProps := TableProps[TableIndex];

    end;

end;



function TSQLRestServerURIContext.URIDecodeREST: boolean;

var i,j,slash: integer;

    Par: PUTF8Char;

begin // expects 'ModelRoot[/TableName[/TableID][/URIBlobFieldName]][?param=...]' format

  // check root URI and Parameters

  i := 0;

  if (Call^.url<>'') and (Call^.url[1]='/') then

    inc(i); // URL may be '/path'

  j := length(Server.Model.Root);

  if (i+j>length(Call^.Url)) or (not(Call^.Url[i+j+1] in [#0,'/','?'])) or

     (StrCompIL(pointer(PtrInt(Call^.url)+i),pointer(Server.Model.Root),j,0)<>0) then begin

    result := False;

    exit; // bad ModelRoot -> caller can try another TSQLRestServer

  end;

  ParametersPos := PosEx(RawUTF8('?'),Call^.url,1);

  if ParametersPos>0 then // '?select=...&where=...' or '?where=...'

    Parameters := @Call^.url[ParametersPos+1];

  if Method=mPost then begin

    fInputPostContentType := Call^.InBodyType(false);

    if (Parameters=nil) and

       IdemPChar(pointer(fInputPostContentType),'APPLICATION/X-WWW-FORM-URLENCODED') then

      Parameters := pointer(Call^.InBody);

  end;

  // compute URI without any root nor parameter

  inc(i,j+2);

  if ParametersPos=0 then

    URI := copy(Call^.url,i,maxInt) else

    URI := copy(Call^.url,i,ParametersPos-i);

  // compute Table, TableID and URIBlobFieldName

  slash := PosEx(RawUTF8('/'),URI);

  if slash>0 then begin

    URI[slash] := #0;

    Par := pointer(URI);

    InternalSetTableFromTableName(Par);

    inc(Par,slash);

    if (Table<>nil) and (Par^ in ['0'..'9']) then

      // "ModelRoot/TableName/TableID/URIBlobFieldName"

      TableID := GetNextItemInt64(Par,'/') else

      TableID := -1; // URI like "ModelRoot/TableName/MethodName"

    URIBlobFieldName := Par;

    if Table<>nil then begin

      j := PosEx('/',URIBlobFieldName);

      if j>0 then begin // handle "ModelRoot/TableName/URIBlobFieldName/ID"

        TableID := GetCardinalDef(pointer(PtrInt(URIBlobFieldName)+j),cardinal(-1));

        SetLength(URIBlobFieldName,j-1);

      end;

    end;

    SetLength(URI,slash-1);

  end else

    InternalSetTableFromTableName(pointer(URI)); // "ModelRoot/TableName"

  // compute URISessionSignaturePos and URIWithoutSignature

  if ParametersPos>0 then

    if IdemPChar(Parameters,'SESSION_SIGNATURE=') then

      URISessionSignaturePos := ParametersPos else

      URISessionSignaturePos := PosEx('&session_signature=',Call^.url,ParametersPos+1);

  if URISessionSignaturePos=0 then

    URIWithoutSignature := Call^.Url else

    URIWithoutSignature := Copy(Call^.Url,1,URISessionSignaturePos-1);

  result := True;

end;



procedure TSQLRestServerURIContext.URIDecodeSOAByMethod;

begin

  if Table=nil then

    // check URI as 'ModelRoot/MethodName'

    MethodIndex := Server.fPublishedMethods.FindHashed(URI) else

  if URIBlobFieldName<>'' then

    // check URI as 'ModelRoot/TableName[/TableID]/MethodName'

    MethodIndex := Server.fPublishedMethods.FindHashed(URIBlobFieldName) else

    MethodIndex := -1;

end;



var // as set by TSQLRestServer.AdministrationExecute()

  BYPASS_ACCESS_RIGHTS: TSQLAccessRights;



function TSQLRestServerURIContext.Authenticate: boolean;

var aSession: TAuthSession;

    i: integer;

begin

  if Server.HandleAuthentication and not IsRemoteAdministrationExecute then begin

    Session := CONST_AUTHENTICATION_SESSION_NOT_STARTED;

    result := false;

    Server.fSessions.Safe.Lock;

    try

      if Server.fSessionAuthentication<>nil then

        for i := 0 to length(Server.fSessionAuthentication)-1 do begin

          aSession := Server.fSessionAuthentication[i].RetrieveSession(self);

          if aSession<>nil then begin

            {$ifdef WITHLOG}

            Log.Log(sllUserAuth,'%/% %',[aSession.User.LogonName,aSession.ID,

              aSession.RemoteIP],self);

            {$endif}

            fSessionAccessRights := aSession.fAccessRights; // local copy

            Call^.RestAccessRights := @fSessionAccessRights;

            Session := aSession.IDCardinal;

            result := true;

            exit;

          end;

        end;

    finally

      Server.fSessions.Safe.UnLock;

    end;

    // if we reached here, no session was found

    if Service<>nil then

      // you can allow a service to be called directly

      result := Service.ByPassAuthentication else

    if MethodIndex>=0 then

      // /auth + /timestamp are e.g. allowed methods without signature

      result := Server.fPublishedMethod[MethodIndex].ByPassAuthentication else

    if (Table<>nil) and (Method in Server.fBypassORMAuthentication)  then

      // allow by-pass for a set of HTTP verbs (e.g. mGET)

      result := true;

  end else begin // default unique session if authentication is not enabled

    Session := CONST_AUTHENTICATION_NOT_USED;

    result := true;

  end;

end;



procedure TSQLRestServerURIContext.AuthenticationFailed(

  Reason: TNotifyAuthenticationFailedReason);

begin

  {$ifdef WITHLOG}

  Log.Log(sllUserAuth,'AuthenticationFailed(%) for % (session=%)',[GetEnumName(

    TypeInfo(TNotifyAuthenticationFailedReason),ord(Reason))^,Call^.Url,Session],self);

  {$endif}

  // 401 Unauthorized response MUST include a WWW-Authenticate header,

  // which is not what we used, so here we won't send 401 error code but 403

  Call.OutStatus := HTML_FORBIDDEN;

  // call the notification event

  if Assigned(Server.OnAuthenticationFailed) then

    Server.OnAuthenticationFailed(Server,Reason,nil,self);

end;



destructor TSQLRestAcquireExecution.Destroy;

begin

  inherited Destroy;

  Thread.Free;

end;



procedure TSQLRestServerURIContext.ExecuteCommand;

procedure TimeOut;

begin

  {$ifdef WITHLOG}

  Log.Log(sllServer,'TimeOut %.Execute(%) after % ms',[self,ToText(Command)^,

    Server.fAcquireExecution[Command].LockedTimeOut],self);

  {$endif}

  if Call<>nil then

    Call^.OutStatus := HTML_TIMEOUT; // 408 Request Time-out

end;

var Method: TThreadMethod;

    Start64: Int64;

begin

  with Server.fAcquireExecution[Command] do begin

    case Command of

      execSOAByMethod:

        Method := ExecuteSOAByMethod;

      execSOAByInterface:

        Method := ExecuteSOAByInterface;

      execORMGet:

        Method := ExecuteORMGet;

      execORMWrite: begin // special behavior to handle transactions at writing

        Method := ExecuteORMWrite;

        Start64 := GetTickCount64;

        repeat

          if Safe.TryLock then

          try

            if (Server.fTransactionActiveSession=0) or // avoid transaction mixups

               (Server.fTransactionActiveSession=Session) then begin

              if Mode=amLocked then begin

                ExecuteORMWrite; // process within the obtained write mutex

                exit;

              end;

              break;   // will handle Mode<>amLocked below

            end;

          finally

            Safe.UnLock;

          end;

          if (LockedTimeOut<>0) and (GetTickCount64>Start64+LockedTimeOut) then begin

            TimeOut; // wait up to 2 second by default

            exit;

          end;

          SleepHiRes(1); // retry every 1 ms

        until false;

      end;

      else raise EORMException.CreateUTF8('Unexpected Command=% in %.Execute',

        [ord(Command),self]);

    end;

    if Mode=amBackgroundORMSharedThread then

      if (Command=execORMWrite) and

         (Server.fAcquireExecution[execORMGet].Mode=amBackgroundORMSharedThread) then

        Command := execORMGet; // for share same thread for ORM read/write

  end;

  with Server.fAcquireExecution[Command] do

    case Mode of

    amUnlocked:

      Method;

    amLocked:

      if LockedTimeOut=0 then begin

        Safe.Lock;

        try

          Method;

        finally

          Safe.UnLock;

        end;

      end else begin

      Start64 := GetTickCount64;

      repeat

        if Safe.TryLock then

        try

          Method;

        finally

          Safe.UnLock;

        end;

        if GetTickCount64>Start64+LockedTimeOut then

          break; // wait up to 2 second by default

        SleepHiRes(1); // retry every 1 ms

      until false;

      TimeOut;

    end;

    {$ifndef LVCL}

    amMainThread:

      BackgroundExecuteThreadMethod(Method,nil);

    {$endif}

    amBackgroundThread,amBackgroundORMSharedThread: begin

      if Thread=nil then

        Thread := Server.NewBackgroundThreadMethod('% "%" %',

          [self,Server.Model.Root,ToText(Command)^]);

      BackgroundExecuteThreadMethod(Method,Thread);

    end;

    end;

end;



procedure TSQLRestServerURIContext.ConfigurationRestMethod(SettingsStorage: TObject);

var value: TDocVariantData;

    valid: boolean;

    config: variant;

begin

  URIBlobFieldName := StringReplaceChars(URIBlobFieldName,'/','.');

  if InputExists['value'] then begin

    if URIBlobFieldName='' then

      exit;

    value.InitObjectFromPath(URIBlobFieldName,Input['value']);

    JsonToObject(SettingsStorage,pointer(value.ToJSON),valid,nil,JSONTOOBJECT_TOLERANTOPTIONS);

    if not valid then begin

      Error('Invalid input [%] - expected %',[variant(value),

        ClassFieldNamesAllPropsAsText(SettingsStorage.ClassType,true)]);

      exit;

    end;

  end;

  ObjectToVariant(SettingsStorage,config,[woDontStoreDefault]);

  if URIBlobFieldName<>'' then

    config := TDocVariantData(config).GetValueByPath(URIBlobFieldName);

  ReturnsJson(config,HTML_SUCCESS,true,twJsonEscape,true);

end;



procedure StatsAddSizeForCall(Stats: TSynMonitorInputOutput; const Call: TSQLRestURIParams);

begin

  Stats.AddSize( // rough estimation

    length(Call.Url)+length(Call.Method)+length(Call.InHead)+length(Call.InBody)+12,

    length(Call.OutHead)+length(Call.OutBody)+16);

end;



procedure TSQLRestServerURIContext.StatsFromContext(Stats: TSynMonitorInputOutput;

  var Diff: Int64; DiffIsMicroSecs: boolean);

begin

  StatsAddSizeForCall(Stats,Call^);

  if not StatusCodeIsSuccess(Call.OutStatus) then

    Stats.ProcessErrorNumber(Call.OutStatus);

  if DiffIsMicroSecs then // avoid a division

    Stats.FromExternalMicroSeconds(Diff) else

    Diff := Stats.FromExternalQueryPerformanceCounters(Diff); // converted to us

end;



procedure TSQLRestServerURIContext.ExecuteSOAByMethod;

var timeStart,timeEnd: Int64;

    sessionstat: TSynMonitorInputOutput;

begin

  with Server.fPublishedMethod[MethodIndex] do begin

    if mlMethods in Server.StatLevels then begin

      QueryPerformanceCounter(timeStart);

      if Stats=nil then

        Stats := TSynMonitorInputOutput.Create(Name);

      Stats.Processing := true;

    end;

    Server.InternalLog('% %',[Name,Parameters],sllServiceCall);

    CallBack(self);

    if Stats<>nil then begin

      QueryPerformanceCounter(timeEnd);

      dec(timeEnd,timeStart);

      StatsFromContext(Stats,timeEnd,false);

      if Server.StatUsage<>nil then

        Server.StatUsage.Modified(Stats,[]);

      if (mlSessions in Server.StatLevels) and (fAuthSession<>nil) then begin

        if fAuthSession.Methods=nil then

          SetLength(fAuthSession.fMethods,length(Server.fPublishedMethod));

        sessionstat := fAuthSession.fMethods[MethodIndex];

        if sessionstat=nil then begin

          sessionstat := TSynMonitorInputOutput.Create(Name);

          fAuthSession.fMethods[MethodIndex] := sessionstat;

        end;

        StatsFromContext(sessionstat,timeEnd,true);

        // mlSessions stats are not yet tracked per Client

      end;

    end;

  end;

  with Server.fStats do begin

    EnterCriticalSection(fLock);

    inc(fServiceMethod);

    Changed;

    LeaveCriticalSection(fLock);

  end;

end;



const

  SERVICE_METHODINDEX_FREEINSTANCE = -1;



procedure TSQLRestServerURIContext.ServiceResultStart(WR: TTextWriter);

const JSONSTART: array[boolean] of RawUTF8 =

    ('{"result":[','{"result":{');

begin // InternalExecuteSOAByInterface has set ForceServiceResultAsJSONObject

  if ForceServiceResultAsJSONObjectWithoutResult then

    WR.Add('{') else

    WR.AddString(JSONSTART[ForceServiceResultAsJSONObject]);

end;



procedure TSQLRestServerURIContext.ServiceResultEnd(WR: TTextWriter; ID: TID);

const JSONSEND_WITHID: array[boolean] of RawUTF8 = ('],"id":','},"id":');

      JSONSEND_NOID: array[boolean] of AnsiChar = (']','}');

begin // InternalExecuteSOAByInterface has set ForceServiceResultAsJSONObject

  if ID=0 then

    WR.Add(JSONSEND_NOID[ForceServiceResultAsJSONObject]) else begin

    if ForceServiceResultAsJSONObjectWithoutResult then

      raise EServiceException.CreateUTF8(

        '%.ServiceResultEnd(ID=%) with ForceServiceResultAsJSONObjectWithoutResult',

        [self,ID]);

    WR.AddString(JSONSEND_WITHID[ForceServiceResultAsJSONObject]);

    WR.Add(ID); // only used in sicClientDriven mode

  end;

  if not ForceServiceResultAsJSONObjectWithoutResult then

    WR.Add('}');

end;



procedure TSQLRestServerURIContext.InternalExecuteSOAByInterface;

  procedure ComputeResult;

    procedure ServiceResult(const Name,JSONValue: RawUTF8);

    var WR: TTextWriter;

    begin

      WR := TJSONSerializer.CreateOwnedStream;

      try

        ServiceResultStart(WR);

        if ForceServiceResultAsJSONObject then

          WR.AddFieldName(Name);

        WR.AddString(JSONValue);

        ServiceResultEnd(WR,0);

        Returns(WR.Text);

      finally

        WR.Free;

      end;

    end;

  begin

    ForceServiceResultAsXMLObject := ForceServiceResultAsXMLObject or

      Service.ResultAsXMLObject;

    ForceServiceResultAsJSONObject := ForceServiceResultAsJSONObject or

      Service.ResultAsJSONObject or

      Service.ResultAsJSONObjectWithoutResult or

      ForceServiceResultAsXMLObject; // XML needs a full JSON object as input

    ForceServiceResultAsJSONObjectWithoutResult := ForceServiceResultAsJSONObject and

      (Service.InstanceCreation in SERVICE_IMPLEMENTATION_NOID) and

      Service.ResultAsJSONObjectWithoutResult;

    if ForceServiceResultAsXMLObjectNameSpace='' then

      ForceServiceResultAsXMLObjectNameSpace := Service.ResultAsXMLObjectNameSpace;

    with Server.fStats do begin

      EnterCriticalSection(fLock);

      inc(fServiceInterface);

      Changed;

      LeaveCriticalSection(fLock);

    end;

    case ServiceMethodIndex of

    ord(imFree):

      if not (Service.InstanceCreation in [sicClientDriven..sicPerThread]) then begin

        Error('_free_ is not compatible with %',[ToText(Service.InstanceCreation)^]);

        exit;

      end else  // {"method":"_free_", "params":[], "id":1234}

        ServiceMethodIndex := SERVICE_METHODINDEX_FREEINSTANCE;

    ord(imContract): begin

      // "method":"_contract_" to retrieve the implementation contract

      if (Call^.InBody<>'') and (Call^.InBody<>'[]') then

        Server.AssociatedServices.RegisterFromClientJSON(Call^.InBody);

      ServiceResult('contract',Service.ContractExpected);

      exit; // "id":0 for this method -> no instance was created

    end;

    ord(imSignature): begin

      // "method":"_signature_" to retrieve the implementation signature

      if TServiceContainerServer(Server.Services).PublishSignature then

        ServiceResult('signature',Service.Contract) else

        // "id":0 for this method -> no instance was created

        Error('Not allowed to publish signature');

      exit;

    end;

    else begin // TServiceFactoryServer.ExecuteMethod() expects index in fMethods[]:

      dec(ServiceMethodIndex,SERVICE_PSEUDO_METHOD_COUNT);

      if cardinal(ServiceMethodIndex)>=Service.fInterface.fMethodsCount then begin

        Error('Invalid ServiceMethodIndex');

        exit;

      end;

      ServiceExecution := @Service.fExecution[ServiceMethodIndex];

    end;

    end;

    if (Session>CONST_AUTHENTICATION_NOT_USED) and (ServiceExecution<>nil) and

       (SessionGroup-1 in ServiceExecution.Denied) then begin

      Error('Unauthorized method',HTML_NOTALLOWED);

      exit;

    end;

    // if we reached here, we have to run the service method

    Service.ExecuteMethod(self);

  end;

var xml: RawUTF8;

    m: integer;

begin // expects Service, ServiceParameters, ServiceMethodIndex to be set

  m := ServiceMethodIndex-SERVICE_PSEUDO_METHOD_COUNT;

  {$ifdef WITHLOG}

  if sllServiceCall in Log.GenericFamily.Level then

    if (m>=0) and (optNoLogInput in Service.fExecution[m].Options) then

      Log.Log(sllServiceCall,'%{optNoLogInput}',[Service.InterfaceFactory.Methods[m].

        InterfaceDotMethodName],Server) else

      Log.Log(sllServiceCall,'%%',[Service.InterfaceFactory.GetFullMethodName(

        ServiceMethodIndex),ServiceParameters],Server);

  {$endif}

  if Assigned(Service.OnMethodExecute) and (m>=0) then

    if not Service.OnMethodExecute(self,Service.InterfaceFactory.Methods[m]) then

      exit; // execution aborted by OnMethodExecute() callback event

  if Service.ResultAsXMLObjectIfAcceptOnlyXML then begin

    xml := FindIniNameValue(pointer(Call^.InHead),'ACCEPT: ');

    if (xml='application/xml') or (xml='text/xml') then

      ForceServiceResultAsXMLObject := true;

  end;

  try

    ComputeResult;

  finally

    ServiceParameters := nil; // ensure no GPF later if points to some local data

  end;

  if ForceServiceResultAsXMLObject and (Call.OutBody<>'') and (Call.OutHead<>'') and

     CompareMem(pointer(Call.OutHead),pointer(JSON_CONTENT_TYPE_HEADER_VAR),45) then begin

    delete(Call.OutHead,15,31);

    insert(XML_CONTENT_TYPE,Call.OutHead,15);

    JSONBufferToXML(pointer(Call.OutBody),XMLUTF8_HEADER,

      ForceServiceResultAsXMLObjectNameSpace,xml);

    Call.OutBody := xml;

  end;

end;



procedure TSQLRestServerURIContext.ExecuteORMGet;

  procedure ConvertOutBodyAsPlainJSON(const FieldsCSV: RawUTF8;

    Options: TJSONSerializerSQLRecordOptions);

  var rec: TSQLRecord;

      W: TJSONSerializer;

      bits: TSQLFieldBits;

      withid: boolean;

  begin // force plain standard JSON output for AJAX clients

    if (FieldsCSV='') or

      // handle ID single field only if ID_str is needed

      (IsRowID(pointer(FieldsCSV)) and not (jwoID_str in Options)) or

      // we won't handle min()/max() functions

      not TableRecordProps.Props.FieldBitsFromCSV(FieldsCSV,bits,withid) then

      exit;

    rec := Table.CreateAndFillPrepare(Call.OutBody);

    try

      W := TableRecordProps.Props.CreateJSONWriter(

        TRawByteStringStream.Create,true,FieldsCSV,0);

      try

        include(W.fCustomOptions,twoForceJSONStandard); // force regular JSON

        W.SQLRecordOptions := Options; // will do the magic

        rec.AppendFillAsJsonValues(W);

        W.SetText(Call.OutBody);

      finally

        W.Stream.Free; // associated TRawByteStringStream instance

        W.Free;

      end;

    finally

      rec.Free;

    end;

  end;

var SQLSelect, SQLWhere, SQLWhereCount, SQLSort, SQLDir, SQL: RawUTF8;

    SQLStartIndex, SQLResults, SQLTotalRowsCount: integer;

    NonStandardSQLSelectParameter, NonStandardSQLWhereParameter: boolean;

    SQLisSelect: boolean;

    ResultList: TSQLTableJSON;

    TableIndexes: TIntegerDynArray;

    rec: TSQLRecord;

    opt: TJSONSerializerSQLRecordOptions;

    P: PUTF8Char;

    i,j,L: integer;

    Blob: PPropInfo;

begin

  {$ifdef KYLIX3}

  TableIndexes := nil; // make Kylix happy

  {$endif}

  case Method of

  mLOCK,mGET: begin

    if Table=nil then begin

      if (Method<>mLOCK) then begin

        if (Call.InBody='') and (Parameters<>nil) and

           (reUrlEncodedSQL in Call.RestAccessRights^.AllowRemoteExecute) then begin

          // GET with a SQL statement sent in URI, as sql=....

          while not UrlDecodeValue(Parameters,'SQL=',SQL,@Parameters) do

            if Parameters=nil then break;

        end else

          // GET with a SQL statement sent as UTF-8 body (not 100% HTTP compatible)

          SQL := Call.InBody;

        if SQL<>'' then begin

          SQLisSelect := isSelect(pointer(SQL),@SQLSelect);

          if SQLisSelect or

             (reSQL in Call.RestAccessRights^.AllowRemoteExecute) then begin

            Static := nil;

            if SQLisSelect then begin

              TableIndexes := Server.Model.GetTableIndexesFromSQLSelect(SQL);

              if TableIndexes=nil then begin

                // check for SELECT without any known table

                if not (reSQLSelectWithoutTable in

                   Call.RestAccessRights^.AllowRemoteExecute) then begin

                  Call.OutStatus := HTML_NOTALLOWED;

                  exit;

                end;

              end else begin

                // check for SELECT with one (or several JOINed) tables

                for i := 0 to high(TableIndexes) do

                  if not (TableIndexes[i] in Call.RestAccessRights^.GET) then begin

                    Call.OutStatus := HTML_NOTALLOWED;

                    exit;

                  end;

                // use the first static table (poorman's JOIN)

                Static := Server.InternalAdaptSQL(TableIndexes[0],SQL);

              end;

            end;

            if Static<>nil then  begin

              TableEngine := Static;

              Call.OutBody := TableEngine.EngineList(SQL);

            end else

              Call.OutBody := Server.MainEngineList(SQL,false,nil);

            // security note: only first statement is run by EngineList()

            if Call.OutBody<>'' then begin // got JSON list '[{...}]' ?

              if (SQLSelect<>'') and (length(TableIndexes)=1) then begin

                InternalSetTableFromTableIndex(TableIndexes[0]);

                opt := ClientSQLRecordOptions;

                if opt<>[] then

                  ConvertOutBodyAsPlainJSON(SQLSelect,opt);

              end;

              Call.OutStatus := HTML_SUCCESS;  // 200 OK

              if not SQLisSelect then // accurate fStats.NotifyORM(Method) below

                Method := TSQLURIMethod(IdemPCharArray(SQLBegin(pointer(SQL)),

                  ['INSERT','UPDATE','DELETE'])+2); // -1+2 -> mGET=1

            end;

          end;

        end;

      end;

    end else

    // here, Table<>nil and TableIndex in [0..MAX_SQLTABLES-1]

    if not (TableIndex in Call.RestAccessRights^.GET) then // check User Access

      Call.OutStatus := HTML_NOTALLOWED else begin

      if TableID>0 then begin

        // GET ModelRoot/TableName/TableID[/BlobFieldName] to retrieve one member,

        // with or w/out locking, or a specified BLOB field content

        if Method=mLOCK then // Safe.Lock is to be followed by PUT -> check user

          if not (TableIndex in Call.RestAccessRights^.PUT) then

            Call.OutStatus := HTML_NOTALLOWED else

            if Server.Model.Lock(TableIndex,TableID) then

              Method := mGET; // mark successfully locked

        if Method<>mLOCK then

          if URIBlobFieldName<>'' then begin

            // GET ModelRoot/TableName/TableID/BlobFieldName: retrieve BLOB field content

            Blob := Table.RecordProps.BlobFieldPropFromRawUTF8(URIBlobFieldName);

            if Blob<>nil then begin

              if TableEngine.EngineRetrieveBlob(TableIndex,

                   TableID,Blob,TSQLRawBlob(Call.OutBody)) then begin

                Call.OutHead := GetMimeContentTypeHeader(Call.OutBody);

                Call.OutStatus := HTML_SUCCESS; // 200 OK

              end else

                Call.OutStatus := HTML_NOTFOUND;

            end;

          end else begin

            // GET ModelRoot/TableName/TableID: retrieve a member content, JSON encoded

            Call.OutBody := Server.fCache.Retrieve(TableIndex,TableID);

            if Call.OutBody='' then begin

              // get JSON object '{...}'

              if Static<>nil then

                Call.OutBody := Static.EngineRetrieve(TableIndex,TableID) else

                Call.OutBody := Server.MainEngineRetrieve(TableIndex,TableID);

              // cache if expected

              if Call.OutBody='' then

                Server.fCache.NotifyDeletion(TableIndex,TableID) else

                Server.fCache.Notify(TableIndex,TableID,Call.OutBody,soSelect);

            end;

            if Call.OutBody<>'' then begin // if something was found

              opt := ClientSQLRecordOptions;

              if opt<>[] then begin

                rec := Table.CreateFrom(Call.OutBody); // cached? -> make private

                try

                  Call.OutBody := rec.GetJSONValues(true,true,soSelect,nil,opt);

                finally

                  rec.Free;

                end;

              end;

              Call.OutStatus := HTML_SUCCESS;

            end else // 200 OK

              Call.OutStatus := HTML_NOTFOUND;

          end;

      end else

      // ModelRoot/TableName with 'select=..&where=' or YUI paging

      if Method<>mLOCK then begin // Safe.Lock not available here

        SQLSelect := 'RowID'; // if no select is specified (i.e. ModelRoot/TableName)

        // all IDs of this table are returned to the client

        SQLTotalRowsCount := 0;

        if Parameters<>nil then begin // '?select=...&where=...' or '?where=...'

          SQLStartIndex := 0;

          SQLResults := 0;

          if Parameters^<>#0 then

          with Server.URIPagingParameters do begin

            NonStandardSQLSelectParameter := StrComp(Select,PAGINGPARAMETERS_YAHOO.Select)<>0;

            NonStandardSQLWhereParameter := StrComp(Where,PAGINGPARAMETERS_YAHOO.Where)<>0;

            repeat

              UrlDecodeValue(Parameters,Sort,SQLSort);

              UrlDecodeValue(Parameters,Dir,SQLDir);

              UrlDecodeInteger(Parameters,StartIndex,SQLStartIndex);

              UrlDecodeInteger(Parameters,Results,SQLResults);

              UrlDecodeValue(Parameters,Select,SQLSelect);

              if NonStandardSQLSelectParameter and (SQLSelect='') then

                UrlDecodeValue(Parameters,PAGINGPARAMETERS_YAHOO.Select,SQLSelect);

              if NonStandardSQLWhereParameter and (SQLWhere='') then

                UrlDecodeValue(Parameters,PAGINGPARAMETERS_YAHOO.Where,SQLWhere);

              UrlDecodeValue(Parameters,Server.URIPagingParameters.Where,SQLWhere,@Parameters);

            until Parameters=nil;

          end;

          // let SQLite3 do the sort and the paging (will be ignored by Static)

          SQLWhereCount := SQLWhere; // "select count(*)" won't expect any ORDER

          if (SQLSort<>'') and

             not ContainsUTF8(pointer(SQLWhere),'ORDER BY') then begin

            if SameTextU(SQLDir,'DESC') then

              SQLSort := SQLSort+' DESC'; // allow DESC, default is ASC

            SQLWhere := SQLWhere+' ORDER BY '+SQLSort;

          end;

          SQLWhere := trim(SQLWhere);

          if (SQLResults<>0) and not ContainsUTF8(pointer(SQLWhere),'LIMIT ') then begin

            if (Server.URIPagingParameters.SendTotalRowsCountFmt<>'') then begin

              if SQLWhere=SQLWhereCount then begin

                i := PosEx('ORDER BY ',UpperCase(SQLWhereCount));

                if i>0 then // if ORDER BY already in the SQLWhere clause

                  SetLength(SQLWhereCount,i-1);

              end;

              ResultList := Server.ExecuteList([Table],

                Server.Model.TableProps[TableIndex].SQLFromSelectWhere('Count(*)',SQLWhereCount));

              if ResultList<>nil then

              try

                SQLTotalRowsCount := ResultList.GetAsInteger(1,0);

              finally

                ResultList.Free;

              end;

            end;

            SQLWhere := FormatUTF8('% LIMIT % OFFSET %',[SQLWhere,SQLResults,SQLStartIndex]);

          end;

        end;

        SQL := Server.Model.TableProps[TableIndex].

          SQLFromSelectWhere(SQLSelect,trim(SQLWhere));

        Call.OutBody := Server.InternalListRawUTF8(TableIndex,SQL);

        if Call.OutBody<>'' then begin // got JSON list '[{...}]' ?

          opt := ClientSQLRecordOptions;

          if opt<>[] then

            ConvertOutBodyAsPlainJSON(SQLSelect,opt);

          Call.OutStatus := HTML_SUCCESS;  // 200 OK

          if Server.URIPagingParameters.SendTotalRowsCountFmt<>'' then

            // insert "totalRows":% optional value to the JSON output

            if Server.NoAJAXJSON or (ClientKind=ckFramework) then begin

              P := pointer(Call.OutBody);

              L := length(Call.OutBody);

              P := NotExpandedBufferRowCountPos(P,P+L);

              j := 0;

              if P<>nil then

                j := P-pointer(Call.OutBody)-11 else

                 for i := 1 to 10 do

                   if Call.OutBody[L]='}' then begin

                     j := L;

                     break;

                   end else

                   dec(L);

              if j>0 then

                Insert(FormatUTF8(Server.URIPagingParameters.SendTotalRowsCountFmt,

                  [SQLTotalRowsCount]),Call.OutBody,j);

            end else begin // expanded format -> as {"values":[...],"total":n}

              if SQLTotalRowsCount=0 then // avoid sending fields array

                Call.OutBody := '[]' else

                Call.OutBody := trim(Call.OutBody);

              Call.OutBody := '{"values":'+Call.OutBody+

                FormatUTF8(Server.URIPagingParameters.SendTotalRowsCountFmt,[SQLTotalRowsCount])+'}';

            end;

        end else

          Call.OutStatus := HTML_NOTFOUND;

      end;

    end;

    if Call.OutStatus=HTML_SUCCESS then

      Server.fStats.NotifyORM(Method);

  end;

  mUNLOCK: begin

    // ModelRoot/TableName/TableID to unlock a member

    if not (TableIndex in Call.RestAccessRights^.PUT) then

      Call.OutStatus := HTML_NOTALLOWED else

    if (Table<>nil) and (TableID>0) and

       Server.Model.UnLock(Table,TableID) then

      Call.OutStatus := HTML_SUCCESS; // 200 OK

  end;

  mSTATE: begin

    // STATE method for TSQLRestClientServerInternalState

    // this method is called with Root (-> Table=nil -> Static=nil)

    // we need a specialized method in order to avoid fStats.Invalid increase

    Call.OutStatus := HTML_SUCCESS;

    for i := 0 to high(Server.fStaticData) do

      if (Server.fStaticData[i]<>nil) and

         Server.fStaticData[i].InheritsFrom(TSQLRestStorage) then

        if TSQLRestStorage(Server.fStaticData[i]).RefreshedAndModified then begin

          inc(Server.InternalState); // force refresh

          break;

        end;

  end else

    raise EORMException.CreateUTF8('%.ExecuteORMGet(method=%)',[self,ord(Method)]);

  end;

end;



procedure TSQLRestServerURIContext.ExecuteORMWrite;

  procedure ComputeInBodyFields(Occasion: TSQLEvent);

  var Rec: TSQLRecord;

      bits: TSQLFieldBits;

  begin

    Rec := Table.Create;

    try

      Rec.FillFrom(pointer(Call.InBody),@bits);

      Rec.ComputeFieldsBeforeWrite(Server,Occasion);

      with TableRecordProps.Props do

        if Occasion=seAdd then

          bits := bits+ComputeBeforeAddFieldsBits else

          bits := bits+ComputeBeforeUpdateFieldsBits;

      Call.Inbody := Rec.GetJSONValues(true,Rec.IDValue<>0,bits);

    finally

      Rec.Free;

    end;

  end;

var OK: boolean;

    Blob: PPropInfo;

    SQLSelect, SQLWhere, SQLSort, SQLDir: RawUTF8;

begin

  if MethodIndex=Server.fPublishedMethodBatchIndex then begin

    ExecuteSOAByMethod; // run the BATCH process in execORMWrite context

    exit;

  end;

  if not Call.RestAccessRights^.CanExecuteORMWrite(

     Method,Table,TableIndex,TableID,self) then begin

    Call.OutStatus := HTML_FORBIDDEN;

    exit;

  end;

  case Method of

  mPOST: // POST=ADD=INSERT

    if Table=nil then begin

      // ModelRoot with free SQL statement sent as UTF-8 (only for Admin group)

      // see e.g. TSQLRestClientURI.EngineExecute

      if reSQL in Call.RestAccessRights^.AllowRemoteExecute then

        if (Call.InBody<>'') and

           (not (GotoNextNotSpace(Pointer(Call.InBody))^ in [#0,'[','{'])) and

           Server.EngineExecute(Call.InBody) then begin

          Call.OutStatus := HTML_SUCCESS; // 200 OK

        end else

        Call.OutStatus := HTML_FORBIDDEN;

    end else begin

      // ModelRoot/TableName with possible JSON SentData: create a new member

      // here, Table<>nil, TableID<0 and TableIndex in [0..MAX_SQLTABLES-1]

      if rsoComputeFieldsBeforeWriteOnServerSide in Server.Options then

        ComputeInBodyFields(seAdd);

      TableID := TableEngine.EngineAdd(TableIndex,Call.InBody);

      if TableID<>0 then begin

        Call.OutStatus := HTML_CREATED; // 201 Created

        Call.OutHead := 'Location: '+URI+'/'+Int64ToUtf8(TableID);

        if rsoAddUpdateReturnsContent in Server.Options then begin

          Server.fCache.NotifyDeletion(TableIndex,TableID);

          Call.OutBody := TableEngine.EngineRetrieve(TableIndex,TableID);

          Server.fCache.Notify(TableIndex,TableID,Call.OutBody,soInsert);

        end else

          Server.fCache.Notify(TableIndex,TableID,Call.InBody,soInsert);

      end;

    end;

  mPUT: // PUT=UPDATE

    if TableID>0 then begin

      // PUT ModelRoot/TableName/TableID[/BlobFieldName] to update member/BLOB content

      if Server.RecordCanBeUpdated(Table,TableID,seUpdate,@CustomErrorMsg) then begin

        OK := false;

        if URIBlobFieldName<>'' then begin

          // PUT ModelRoot/TableName/TableID/BlobFieldName: update BLOB field content

          Blob := Table.RecordProps.BlobFieldPropFromRawUTF8(URIBlobFieldName);

          if Blob<>nil then

            OK := TableEngine.EngineUpdateBlob(TableIndex,TableID,Blob,Call.InBody);

        end else begin

          // ModelRoot/TableName/TableID with JSON SentData: update a member

          if rsoComputeFieldsBeforeWriteOnServerSide in Server.Options then

            ComputeInBodyFields(seUpdate);

          OK := TableEngine.EngineUpdate(TableIndex,TableID,Call.InBody);

          if OK then begin // flush (no CreateTime in JSON)

            Server.fCache.NotifyDeletion(TableIndex,TableID);

            if rsoAddUpdateReturnsContent in Server.Options then

              Call.OutBody := TableEngine.EngineRetrieve(TableIndex,TableID);

          end;

        end;

        if OK then

          Call.OutStatus := HTML_SUCCESS; // 200 OK

      end else

      Call.OutStatus := HTML_FORBIDDEN;

    end else

    if Parameters<>nil then begin // e.g. from TSQLRestClient.EngineUpdateField

      // PUT ModelRoot/TableName?setname=..&set=..&wherename=..&where=..

      repeat

        UrlDecodeValue(Parameters,'SETNAME=',SQLSelect);

        UrlDecodeValue(Parameters,'SET=',SQLDir);

        UrlDecodeValue(Parameters,'WHERENAME=',SQLSort);

        UrlDecodeValue(Parameters,'WHERE=',SQLWhere,@Parameters);

      until Parameters=nil;

      if (SQLSelect<>'') and (SQLDir<>'') and (SQLSort<>'') and (SQLWhere<>'') then

        if TableEngine.EngineUpdateField(TableIndex,SQLSelect,SQLDir,SQLSort,SQLWhere) then begin

          if rsoAddUpdateReturnsContent in Server.Options then

            Call.OutBody := TableEngine.EngineRetrieve(TableIndex,TableID);

          Call.OutStatus := HTML_SUCCESS; // 200 OK

        end;

    end;

  mDELETE:

    if TableID>0 then

      // ModelRoot/TableName/TableID to delete a member

      if not Server.RecordCanBeUpdated(Table,TableID,seDelete,@CustomErrorMsg) then

        Call.OutStatus := HTML_FORBIDDEN else begin

        if TableEngine.EngineDelete(TableIndex,TableID) and

           Server.AfterDeleteForceCoherency(TableIndex,TableID) then begin

          Call.OutStatus := HTML_SUCCESS; // 200 OK

          Server.fCache.NotifyDeletion(TableIndex,TableID);

        end;

      end else

    if Parameters<>nil then begin

      // ModelRoot/TableName?where=WhereClause to delete members

      repeat

        if UrlDecodeValue(Parameters,'WHERE=',SQLWhere,@Parameters) then begin

          SQLWhere := trim(SQLWhere);

          if SQLWhere<>'' then begin

            if Server.Delete(Table,SQLWhere) then

              Call.OutStatus := HTML_SUCCESS; // 200 OK

          end;

          break;

        end;

      until Parameters=nil;

    end;

  mBEGIN: begin      // BEGIN TRANSACTION

    // TSQLVirtualTableJSON/External will rely on SQLite3 module

    // and also TSQLRestStorageInMemory, since COMMIT/ROLLBACK have Static=nil

    // mBEGIN logic is just the opposite of mEND/mABORT: Safe.Lock main, then static

    if Server.TransactionBegin(Table,Session) then begin

      if (Static<>nil) and (StaticKind=sVirtualTable) then

        Static.TransactionBegin(Table,Session) else

      if (Static=nil) and (Server.fTransactionTable<>nil) then begin

        Static := Server.StaticVirtualTable[Server.fTransactionTable];

        if Static<>nil then

          Static.TransactionBegin(Table,Session);

      end;

      Call.OutStatus := HTML_SUCCESS; // 200 OK

    end;

  end;

  mEND: begin        // END=COMMIT

    // this method is called with Root (-> Table=nil -> Static=nil)

    // mEND logic is just the opposite of mBEGIN: release static, then main

    if (Static<>nil) and (StaticKind=sVirtualTable) then

      Static.Commit(Session,false) else

    if (Static=nil) and (Server.fTransactionTable<>nil) then begin

      Static := Server.StaticVirtualTable[Server.fTransactionTable];

      if Static<>nil then

        Static.Commit(Session,false);

    end;

    Server.Commit(Session,false);

    Call.OutStatus := HTML_SUCCESS; // 200 OK

  end;

  mABORT: begin      // ABORT=ROLLBACK

    // this method is called with Root (-> Table=nil -> Static=nil)

    // mABORT logic is just the opposite of mBEGIN: release static, then main

    if (Static<>nil) and (StaticKind=sVirtualTable) then

      Static.RollBack(Session) else

    if (Static=nil) and (Server.fTransactionTable<>nil) then begin

      Static := Server.StaticVirtualTable[Server.fTransactionTable];

      if Static<>nil then

        Static.RollBack(Session);

    end;

    Server.RollBack(Session);

    Call.OutStatus := HTML_SUCCESS; // 200 OK

  end;

  end;

  if StatusCodeIsSuccess(Call.OutStatus) then

    Server.fStats.NotifyORM(Method);

end;



procedure TSQLRestServerURIContext.FillInput(const LogInputIdent: RawUTF8);

var n,max: integer;

    P: PUTF8Char;

begin

  if (fInput<>nil) or (Parameters=nil) then

    exit; // only do it once

  P := Parameters;

  n := 0;

  max := 0;

  repeat

    if n>=max then begin

      if n>=96 then // avoid DOS - see MAX_METHOD_ARGS for TInterfacedObjectFake

        raise EParsingException.CreateUTF8(

          'Security Policy: Accept up to 48 parameters for %.FillInput',[self]);

      inc(max,16);

      SetLength(fInput,max);

    end;

    P := UrlDecodeNextNameValue(P,fInput[n],fInput[n+1]);

    if P=nil then

      break;

    inc(n,2);

  until P^=#0;

  SetLength(fInput,n);

  {$ifdef WITHLOG}

  if LogInputIdent<>'' then

    Log.Add.Log(sllDebug,LogInputIdent,TypeInfo(TRawUTF8DynArray),fInput,self);

  {$endif}

end;



function TSQLRestServerURIContext.GetInputInt(const ParamName: RawUTF8): Int64;

var err: integer;

begin

  result := GetInt64(pointer(GetInputUTF8(ParamName)),err);

  if err<>0 then

    raise EParsingException.CreateUTF8('%.GetInputInt(%): Invalid parameter',

      [self,ParamName]);

end;



function TSQLRestServerURIContext.GetInputDouble(const ParamName: RawUTF8): double;

var err: integer;

begin

  result := GetExtended(pointer(GetInputUTF8(ParamName)),err);

  if err<>0 then

    raise EParsingException.CreateUTF8('%.GetInputDouble(%): Invalid parameter',

      [self,ParamName]);

end;



function TSQLRestServerURIContext.GetInputIntOrVoid(const ParamName: RawUTF8): Int64;

begin

  result := GetInt64(pointer(GetInputUTF8OrVoid(ParamName)));

end;



function TSQLRestServerURIContext.GetInputHexaOrVoid(const ParamName: RawUTF8): cardinal;

var value: RawUTF8;

begin

  value := GetInputUTF8OrVoid(ParamName);

  if (length(value)<>8) or not HexDisplayToCardinal(Pointer(value),result) then

    result := 0;

end;



function TSQLRestServerURIContext.GetInputDoubleOrVoid(const ParamName: RawUTF8): double;

begin

  result := GetExtended(pointer(GetInputUTF8OrVoid(ParamName)));

end;



function TSQLRestServerURIContext.GetInputNameIndex(const ParamName: RawUTF8): integer;

begin // fInput[0]='Param1',fInput[1]='Value1',fInput[2]='Param2'...

  if (fInput=nil) and (Parameters<>nil) then

    FillInput;

  for result := 0 to (length(fInput)shr 1)-1 do

    if IdemPropNameU(ParamName,fInput[result*2]) then

      exit;

  result := -1;

end;



function TSQLRestServerURIContext.GetInputUTF8(const ParamName: RawUTF8): RawUTF8;

var i: integer;

begin

  i := GetInputNameIndex(ParamName);

  if i<0 then

    raise EParsingException.CreateUTF8('%: missing ''%'' parameter',[self,ParamName]);

  result := fInput[i*2+1];

end;



function TSQLRestServerURIContext.GetInputUTF8OrVoid(const ParamName: RawUTF8): RawUTF8;

var i: integer;

begin

  i := GetInputNameIndex(ParamName);

  if i<0 then

    result := '' else

    result := fInput[i*2+1];

end;



function TSQLRestServerURIContext.InputUTF8OrDefault(

  const ParamName, DefaultValue: RawUTF8): RawUTF8;

var i: integer;

begin

  i := GetInputNameIndex(ParamName);

  if i<0 then

    result := DefaultValue else

    result := fInput[i*2+1];

end;



function TSQLRestServerURIContext.InputUTF8OrError(const ParamName: RawUTF8;

  out Value: RawUTF8; const ErrorMessageForMissingParameter: string): boolean;

var i: integer;

begin

  i := GetInputNameIndex(ParamName);

  if i<0 then begin

    if ErrorMessageForMissingParameter='' then

      Error('%: missing ''%'' parameter',[self,ParamName]) else

      Error('%',[ErrorMessageForMissingParameter]);

    result := false;

  end else begin

    Value := fInput[i*2+1];

    result := true;

  end;

end;



function TSQLRestServerURIContext.InputEnum(const ParamName: RawUTF8;

  EnumType: PTypeInfo; out ValueEnum; DefaultEnumOrd: integer): boolean;

var value: RawUTF8;

    int,err: Integer;

begin

  result := false;

  if (EnumType=nil) or (EnumType^.Kind<>tkEnumeration) then

    exit;

  value := GetInputUTF8OrVoid(ParamName);

  if value<>'' then begin

    int := GetInteger(Pointer(value),err);

    if err=0 then

      result := true else begin

      int := EnumType^.EnumBaseType^.GetEnumNameValue(pointer(value),length(value));

      if int>=0 then

        result := true else

        int := DefaultEnumOrd;

    end;

  end else

    int := DefaultEnumOrd;

  EnumType^.EnumBaseType^.SetEnumFromOrdinal(ValueEnum,int);

end;



function TSQLRestServerURIContext.GetInputString(const ParamName: RawUTF8): string;

var i: integer;

begin

  i := GetInputNameIndex(ParamName);

  if i<0 then

    raise EParsingException.CreateUTF8('%: missing ''%'' parameter',[self,ParamName]);

  result := UTF8ToString(fInput[i*2+1]);

end;



function TSQLRestServerURIContext.GetInputStringOrVoid(const ParamName: RawUTF8): string;

var i: integer;

begin

  i := GetInputNameIndex(ParamName);

  if i<0 then

    result := '' else

    result := UTF8ToString(fInput[i*2+1]);

end;



function TSQLRestServerURIContext.GetInputExists(const ParamName: RawUTF8): Boolean;

begin

  result := GetInputNameIndex(ParamName)>=0;

end;



{$ifndef NOVARIANTS}



function TSQLRestServerURIContext.GetInput(const ParamName: RawUTF8): variant;

begin

  GetVariantFromJSON(pointer(GetInputUTF8(ParamName)),false,Result);

end;



function TSQLRestServerURIContext.GetInputOrVoid(const ParamName: RawUTF8): variant;

begin

  GetVariantFromJSON(pointer(GetInputUTF8OrVoid(ParamName)),false,Result);

end;



function TSQLRestServerURIContext.InputOrError(const ParamName: RawUTF8;

  out Value: variant; const ErrorMessageForMissingParameter: string): boolean;

var ValueUTF8: RawUTF8;

begin

  result := InputUTF8OrError(ParamName,ValueUTF8,ErrorMessageForMissingParameter);

  if result then

    GetVariantFromJSON(pointer(ValueUTF8),False,Value);

end;



function TSQLRestServerURIContext.GetInputAsTDocVariant: variant;

var ndx: integer;

    v: variant;

    MultiPart: TMultiPartDynArray;

begin

  VarClear(result);

  FillInput;

  if fInput<>nil then begin

    with TDocVariantData(result) do begin

      InitFast;

      for ndx := 0 to (length(fInput) shr 1)-1 do begin

        GetVariantFromJSON(pointer(fInput[ndx*2+1]),false,v,@JSON_OPTIONS[true]);

        AddValue(fInput[ndx*2],v);

      end;

    end;

  end else

  if InputAsMultiPart(MultiPart) then

    with TDocVariantData(result) do begin

      InitFast;

      for ndx := 0 to high(MultiPart) do

        with MultiPart[ndx] do

          if ContentType=TEXT_CONTENT_TYPE then begin

            // append as regular "Name":"TextValue" field

            RawUTF8ToVariant(Content,v);

            AddValue(Name,v);

          end else

            // append binary file as an object, with Base64-encoded data

            AddValue(Name,_ObjFast(['data',BinToBase64(Content),

              'filename',FileName,'contenttype',ContentType]));

    end;

end;



{$endif NOVARIANTS}



function TSQLRestServerURIContext.InputAsMultiPart(var MultiPart: TMultiPartDynArray): Boolean;

begin

  result := (Method=mPOST) and

     IdemPChar(pointer(fInputPostContentType),'MULTIPART/FORM-DATA') and

     MultiPartFormDataDecode(fInputPostContentType,Call^.InBody,MultiPart);

end;



function TSQLRestServerURIContext.GetInHeader(const HeaderName: RawUTF8): RawUTF8;

var up: array[byte] of AnsiChar;

begin

  if self=nil then

    result := '' else begin

    PWord(UpperCopy255(up,HeaderName))^ := ord(':');

    result := Trim(FindIniNameValue(pointer(Call.InHead),up));

    if (result='') and (SessionRemoteIP<>'') and IdemPropNameU(HeaderName,'remoteip') then

      // some protocols (e.g. WebSockets) do not send headers at each call

      result := SessionRemoteIP;

  end;

end;



procedure TSQLRestServerURIContext.SetInCookie(CookieName, CookieValue: RawUTF8);

var i,n: integer;

begin

  GetInCookie(CookieName); // force retrieve cookies

  fInputCookieLastName := ''; // cache reset

  CookieName := UpperCase(trim(CookieName))+'=';

  n := length(fInputCookies);

  for i := 0 to n-1 do

    if IdemPChar(pointer(fInputCookies[i]),pointer(CookieName)) then begin

      fInputCookies[i] := CookieName+CookieValue; // update in-place

      exit;

    end;

  SetLength(fInputCookies,n+1);

  fInputCookies[n] := CookieName+CookieValue; // add new cookie

end;



function TSQLRestServerURIContext.GetInCookie(CookieName: RawUTF8): RawUTF8;

var i: integer;

    cookieSearch: RawUTF8;

begin

  result := '';

  CookieName := trim(CookieName);

  if (self=nil) or (CookieName='') then

    exit;

  if CookieName=fInputCookieLastName then begin

    result := fInputCookieLastValue;

    exit;

  end;

  if not fInputCookiesRetrieved then begin

    fInputCookiesRetrieved := true;

    CSVToRawUTF8DynArray(pointer(GetInHeader('cookie')),fInputCookies,';');

    for i := 0 to length(fInputCookies)-1 do

      fInputCookies[i] := trim(fInputCookies[i]);

  end;

  fInputCookieLastName := CookieName;

  fInputCookieLastValue := '';

  if fInputCookies=nil then

    exit;

  cookieSearch := UpperCase(CookieName)+'=';

  for i := 0 to length(fInputCookies)-1 do

    if IdemPChar(pointer(fInputCookies[i]),pointer(cookieSearch)) then begin

      result := copy(fInputCookies[i],length(cookieSearch)+1,MaxInt);

      fInputCookieLastValue := result;

      exit;

    end;

end;



procedure TSQLRestServerURIContext.SetOutSetCookie(aOutSetCookie: RawUTF8);

begin

  if self=nil then

    exit;

  aOutSetCookie := Trim(aOutSetCookie);

  if PosEx('=',aOutSetCookie)<2 then

    raise EBusinessLayerException.CreateUTF8(

      '"name=value" expected for %.SetOutSetCookie("%")',[self,aOutSetCookie]);

  if PosI('; PATH=',aOutSetCookie)=0 then

    fOutSetCookie := aOutSetCookie+'; Path=/'+Server.Model.Root else

    fOutSetCookie := aOutSetCookie;

  fInputCookieLastName := ''; // cache reset

end;



function TSQLRestServerURIContext.GetUserAgent: RawUTF8;

begin

  if fUserAgent='' then begin

    result := FindIniNameValue(pointer(Call.InHead),'USER-AGENT: ');

    if result='' then

      fUserAgent := '*' else // ensure header is parsed only once

      fUserAgent := result;

  end else

    if fUserAgent='*' then

      result := '' else

      result := fUserAgent;

end;



function TSQLRestServerURIContext.ClientKind: TSQLRestServerURIContextClientKind;

var agent: RawUTF8;

begin

  if fClientKind=ckUnknown then

    if Call.InHead='' then // e.g. for WebSockets remote access

      fClientKind := ckAjax else begin

      agent := GetUserAgent;

      if (agent='') or (PosEx('mORMot',agent)>0) then

        fClientKind := ckFramework else

        fClientKind := ckAjax;

    end;

  result := fClientKind;

end;



function TSQLRestServerURIContext.IsRemoteAdministrationExecute: boolean;

begin

  result := (self<>nil) and (call.RestAccessRights=@BYPASS_ACCESS_RIGHTS);

end;



function TSQLRestServerURIContext.ClientSQLRecordOptions: TJSONSerializerSQLRecordOptions;

begin

  result := [];

  if (TableRecordProps=nil) or (ClientKind<>ckAjax) then

    exit;

  if rsoGetID_str in Server.Options then

    include(result,jwoID_str);

  if ([sftObject,sftBlobDynArray{$ifndef NOVARIANTS},sftVariant{$endif}]*

     TableRecordProps.Props.HasTypeFields<>[]) and

     (rsoGetAsJsonNotAsString in Server.Options) then

    include(result,jwoAsJsonNotAsString);

end;



function TSQLRestServerURIContext.GetResourceFileName: TFileName;

begin

  if (URIBlobFieldName='') or (PosEx('..',URIBlobFieldName)>0) then

    result := '' else // for security, disallow .. in the supplied file path

    result := UTF8ToString(StringReplaceAll(URIBlobFieldName,'/',PathDelim));

end;



procedure TSQLRestServerURIContext.Returns(const Result: RawUTF8;

  Status: integer; const CustomHeader: RawUTF8;

  Handle304NotModified,HandleErrorAsRegularResult: boolean);

var clientHash, serverHash: RawUTF8;

begin

  if HandleErrorAsRegularResult or StatusCodeIsSuccess(Status) then begin

    Call.OutStatus := Status;

    Call.OutBody := Result;

    if CustomHeader<>'' then

      Call.OutHead := CustomHeader else

      if Call.OutHead='' then

        Call.OutHead := JSON_CONTENT_TYPE_HEADER_VAR;

    if Handle304NotModified and (Status=HTML_SUCCESS) and

       (Length(Result)>64) then begin

      clientHash := FindIniNameValue(pointer(Call.InHead),'IF-NONE-MATCH: ');

      serverHash := '"'+crc32cUTF8ToHex(Result)+'"';

      if clientHash<>serverHash then

        Call.OutHead := Call.OutHead+#13#10'ETag: '+serverHash else begin

        Call.OutBody := ''; // save bandwidth for "304 Not Modified"

        Call.OutStatus := HTML_NOTMODIFIED;

      end;

    end;

  end else

    Error(Result,Status);

end;



procedure TSQLRestServerURIContext.Returns(Value: TObject; Status: integer;

  Handle304NotModified: boolean; SQLRecordOptions: TJSONSerializerSQLRecordOptions);

var json: RawUTF8;

begin

  if Value.InheritsFrom(TSQLRecord) then

    json := TSQLRecord(Value).GetJSONValues(true,true,soSelect,nil,SQLRecordOptions) else

    json := ObjectToJSON(Value);

  Returns(json,Status,'',Handle304NotModified);

end;



procedure TSQLRestServerURIContext.ReturnsJson(const Value: Variant; Status: integer;

  Handle304NotModified: boolean; Escape: TTextWriterKind; MakeHumanReadable: boolean);

var json,tmp: RawUTF8;

begin

  VariantSaveJSON(Value,Escape,json);

  if MakeHumanReadable and (json<>'') and (json[1] in ['{','[']) then begin

    tmp := json;

    JSONBufferReformat(pointer(tmp),json);

  end;

  Returns(json,Status,'',Handle304NotModified);

end;



procedure TSQLRestServerURIContext.ReturnBlob(const Blob: RawByteString;

  Status: integer; Handle304NotModified: boolean; const FileName: TFileName);

begin

  Returns(Blob,Status,GetMimeContentTypeHeader(Blob,FileName),Handle304NotModified);

end;



procedure TSQLRestServerURIContext.ReturnFile(const FileName: TFileName;

  Handle304NotModified: boolean; const ContentType,AttachmentFileName,

  Error404Redirect: RawUTF8);

var FileTime: TDateTime;

    clientHash, serverHash: RawUTF8;

begin

  if FileName='' then

    FileTime := 0 else

    FileTime := FileAgeToDateTime(FileName);

  if FileTime=0 then

    if Error404Redirect<>'' then

      Redirect(Error404Redirect) else

      Error('',HTML_NOTFOUND) else begin

    if Call.OutHead<>'' then

      Call.OutHead := Call.OutHead+#13#10;

    if ContentType<>'' then

      Call.OutHead := Call.OutHead+HEADER_CONTENT_TYPE+ContentType else

      Call.OutHead := Call.OutHead+GetMimeContentTypeHeader('',FileName);

    Call.OutStatus := HTML_SUCCESS;

    if Handle304NotModified then begin

      clientHash := FindIniNameValue(pointer(Call.InHead),'IF-NONE-MATCH: ');

      serverHash := '"'+DateTimeToIso8601(FileTime,false)+'"';

      Call.OutHead := Call.OutHead+#13#10'ETag: '+serverHash;

      if clientHash=serverHash then begin

        Call.OutStatus := HTML_NOTMODIFIED;

        exit;

      end;

    end;

    // Content-Type: appears twice: 1st to notify static file, 2nd for mime type

    Call.OutHead := STATICFILE_CONTENT_TYPE_HEADER+#13#10+Call.OutHead;

    StringToUTF8(FileName,Call.OutBody); // body=filename for STATICFILE_CONTENT

    if AttachmentFileName<>'' then

      Call.OutHead := Call.OutHead+

        #13#10'Content-Disposition: attachment; filename="'+AttachmentFileName+'"';

  end;

end;



procedure TSQLRestServerURIContext.ReturnFileFromFolder(const FolderName: TFileName;

  Handle304NotModified: boolean; const DefaultFileName: TFileName;

  const Error404Redirect: RawUTF8);

var fileName: TFileName;

begin

  if URIBlobFieldName='' then

    fileName := DefaultFileName else

    if PosEx('..',URIBlobFieldName)>0 then

      fileName := '' else

      fileName := UTF8ToString(StringReplaceChars(URIBlobFieldName,'/',PathDelim));

  if fileName<>'' then

    fileName := IncludeTrailingPathDelimiter(FolderName)+fileName;

  ReturnFile(fileName,Handle304NotModified,'','',Error404Redirect);

end;



procedure TSQLRestServerURIContext.Redirect(const NewLocation: RawUTF8;

  PermanentChange: boolean);

begin

  if PermanentChange then

    Call.OutStatus := HTML_MOVEDPERMANENTLY else

    Call.OutStatus := HTML_TEMPORARYREDIRECT;

  Call.OutHead := 'Location: '+NewLocation;

end;



procedure TSQLRestServerURIContext.Returns(const NameValuePairs: array of const;

  Status: integer; Handle304NotModified,HandleErrorAsRegularResult: boolean);

begin

  Returns(JSONEncode(NameValuePairs),Status,'',Handle304NotModified,

    HandleErrorAsRegularResult);

end;



procedure TSQLRestServerURIContext.Results(const Values: array of const;

  Status: integer; Handle304NotModified: boolean);

var i,h: integer;

    result: RawUTF8;

begin

  h := high(Values);

  if h<0 then

    result := '{"result":null}' else

    with TJSONSerializer.CreateOwnedStream do

    try

      AddShort('{"result":');

      if h=0 then

        // result is one value

        AddJSONEscape(Values[0]) else begin

        // result is one array of values

        Add('[');

        i := 0;

        repeat

          AddJSONEscape(Values[i]);

          if i=h then break;

          Add(',');

          inc(i);

        until false;

        Add(']');

      end;

      Add('}');

      SetText(result);

    finally

      Free;

    end;

  Returns(result,Status,'',Handle304NotModified);

end;





procedure TSQLRestServerURIContext.Success(Status: integer);

begin

  if StatusCodeIsSuccess(Status) then

    Call.OutStatus := Status else

    Error('',Status);

end;



procedure TSQLRestServerURIContext.Error(const Format: RawUTF8;

  const Args: array of const; Status: integer);

begin

  Error(FormatUTF8(Format,Args),Status);

end;



procedure TSQLRestServerURIContext.Error(E: Exception;

  const Format: RawUTF8; const Args: array of const; Status: integer);

var msg,exc: RawUTF8;

begin

  FormatUTF8(Format,Args,msg);

  if E=nil then

    Error(msg,Status) else begin

    exc := ObjectToJSONDebug(E);

    if msg='' then

      Error('{"%":%}',[E,exc],Status) else

      Error(FormatUTF8('{"msg":?,"%":%}',[E,exc],[msg],true),Status);

  end;

end;



procedure TSQLRestServerURIContext.Error(const ErrorMessage: RawUTF8; Status: integer);

var ErrorMsg: RawUTF8;

begin

  Call.OutStatus := Status;

  if StatusCodeIsSuccess(Status) then begin // not an error

    Call.OutBody := ErrorMessage;

    exit;

  end;

  if ErrorMessage='' then

    StatusCodeToErrorMsg(Status,ErrorMsg) else

    ErrorMsg := ErrorMessage;

  with TTextWriter.CreateOwnedStream do

  try

    AddShort('{'#13#10'"errorCode":');

    Add(call.OutStatus);

    if (ErrorMsg<>'') and (ErrorMsg[1]='{') and (ErrorMsg[length(ErrorMsg)]='}') then begin

      AddShort(','#13#10'"error":'#13#10);

      AddNoJSONEscape(pointer(ErrorMsg),length(ErrorMsg));

      AddShort(#13#10'}');

    end else begin

      AddShort(','#13#10'"errorText":"');

      AddJSONEscape(pointer(ErrorMsg));

      AddShort('"'#13#10'}');

    end;

    SetText(Call.OutBody);

  finally

    Free;

  end;

  Server.InternalLog('%.Error: %',[ClassType,Call.OutBody],sllDebug);

end;





{ TSQLRestRoutingREST }



procedure TSQLRestRoutingREST.URIDecodeSOAByInterface;

var i: integer;

    method,clientdrivenid: RawUTF8;

begin

  if (Table=nil) and (MethodIndex<0) and (URI<>'') and (Server.Services<>nil) then begin

    // check URI as '/Model/Interface.Method[/ClientDrivenID]'

    i := Server.Services.fListInterfaceMethods.FindHashed(URI);

    if i>=0 then // no specific message: it may be a valid request

      with Server.Services.fListInterfaceMethod[i] do begin

        Service := TServiceFactoryServer(InterfaceService);

        ServiceMethodIndex := InterfaceMethodIndex;

        fServiceListInterfaceMethodIndex := i;

        ServiceInstanceID := GetInteger(pointer(URIBlobFieldName));

      end else

      if URIBlobFieldName<>'' then begin

        // check URI as '/Model/Interface/Method[/ClientDrivenID]''

        i := Server.Services.fList.IndexOf(URI);

        if i>=0 then begin // identified as a valid JSON-RPC service

          Service := TServiceFactoryServer(Server.Services.fList.Objects[i]);

          Split(URIBlobFieldName,'/',method,clientdrivenid);

          ServiceMethodIndex := Service.InterfaceFactory.FindMethodIndex(method);

          if ServiceMethodIndex<0 then

            Service := nil else begin

            inc(ServiceMethodIndex,SERVICE_PSEUDO_METHOD_COUNT);

            fServiceListInterfaceMethodIndex := -1;

            ServiceInstanceID := GetInteger(pointer(clientdrivenid));

          end;

        end;

      end;

  end;

end;



procedure TSQLRestRoutingREST.ExecuteSOAByInterface;

var JSON: RawUTF8;

    Par: PUTF8Char;

    meth,a,i,iLow: Integer;

    WR: TTextWriter;

    argDone: boolean;

begin // here Ctxt.Service and ServiceMethodIndex are set

  if (Server.Services=nil) or (Service=nil) then

    raise EServiceException.CreateUTF8('%.ExecuteSOAByInterface invalid call',[self]);

  //  URI as '/Model/Interface.Method[/ClientDrivenID]'

  if Call.InBody<>'' then

    // either parameters were sent as JSON array (the Delphi/AJAX way)

    ServiceParameters := pointer(Call.InBody) else begin

    // or parameters were URI-encoded (the HTML way)

    Par := Parameters;

    if Par<>nil then begin

      while Par^='+' do inc(Par); // ignore trailing spaces

      if (Par^='[') or IdemPChar(Par,'%5B') then

        // either as JSON array (input is e.g. '+%5B...' for ' [...')

        JSON := UrlDecode(Parameters) else begin

        // or as a list of parameters (input is 'Param1=Value1&Param2=Value2...')

        FillInput; // fInput[0]='Param1',fInput[1]='Value1',fInput[2]='Param2'...

        if fInput<>nil then begin

          meth := ServiceMethodIndex-SERVICE_PSEUDO_METHOD_COUNT;

          if cardinal(meth)<Service.InterfaceFactory.MethodsCount then begin

            WR := TJSONSerializer.CreateOwnedStream;

            try // convert URI parameters into the expected ordered JSON array

              WR.Add('[');

              with Service.InterfaceFactory.fMethods[meth] do begin

                iLow := 0;

                for a := ArgsInFirst to ArgsInLast do

                with Args[a] do

                if ValueDirection<>smdOut then begin

                  argDone := false;

                  for i := iLow to high(fInput)shr 1 do // search argument in URI

                    if IdemPropName(ParamName^,pointer(fInput[i*2]),length(fInput[i*2])) then begin

                      AddValueJSON(WR,fInput[i*2+1]); // will add "" if needed

                      if i=iLow then

                        inc(iLow); // optimistic in-order search, but allow any order

                      argDone := true;

                      break;

                    end;

                  if not argDone then

                    AddDefaultJSON(WR); // allow missing argument (and add ',')

                end;

              end;

              WR.CancelLastComma;

              WR.Add(']');

              WR.SetText(JSON);

            finally

              WR.Free;

            end;

          end;

        end;

      end;

    end;

    ServiceParameters := pointer(JSON);

  end;

  // now Service, ServiceParameters, ServiceMethodIndex are set

  InternalExecuteSOAByInterface;

end;



class procedure TSQLRestRoutingREST.ClientSideInvoke(var uri: RawUTF8;

  const method, params, clientDrivenID: RawUTF8; out sent: RawUTF8);

begin

  if clientDrivenID<>'' then

    uri := uri+'.'+method+'/'+clientDrivenID else

    uri := uri+'.'+method;

  sent := '['+params+']'; // we may also encode them within the URI

end;





{ TSQLRestRoutingJSON_RPC }



procedure TSQLRestRoutingJSON_RPC.URIDecodeSOAByInterface;

var i: integer;

begin

  if (Table=nil) and (MethodIndex<0) and (URI<>'') and (Server.Services<>nil) then begin

    //  URI as '/Model/Interface'

    i := Server.Services.fList.IndexOf(URI);

    if i>=0 then // identified as a valid JSON-RPC service

      Service := TServiceFactoryServer(Server.Services.fList.Objects[i]);

  end; // ServiceMethodIndex will be retrieved from "method": in body

end;



procedure TSQLRestRoutingJSON_RPC.ExecuteSOAByInterface;

var method: RawUTF8;

    Values: TPUtf8CharDynArray;

    internal: TServiceInternalMethod;

    tmp: TSynTempBuffer;

begin // here Ctxt.Service is set (not ServiceMethodIndex yet)

  if (Server.Services=nil) or (Service=nil) then

    raise EServiceException.CreateUTF8('%.ExecuteSOAByInterface invalid call',[self]);

  tmp.Init(call.Inbody);

  try

    JSONDecode(tmp.buf,['method','params','id'],Values,True);

    if Values[0]=nil then // Method name required

      exit;

    SetString(method,Values[0],StrLen(Values[0]));

    ServiceParameters := Values[1];

    ServiceInstanceID := GetCardinal(Values[2]); // retrieve "id":ClientDrivenID

    ServiceMethodIndex := Service.fInterface.FindMethodIndex(method);

    if ServiceMethodIndex>=0 then

      inc(ServiceMethodIndex,SERVICE_PSEUDO_METHOD_COUNT) else begin

      for internal := low(TServiceInternalMethod) to high(TServiceInternalMethod) do

        if IdemPropNameU(method,SERVICE_PSEUDO_METHOD[internal]) then begin

          ServiceMethodIndex := ord(internal);

          break;

        end;

      if ServiceMethodIndex<0 then begin

        Error('Unknown method');

        exit;

      end;

    end;

    // now Service, ServiceParameters, ServiceMethodIndex are set

    InternalExecuteSOAByInterface;

  finally

    tmp.Done; // release temp storage for Values[] = Service* fields

  end;

end;



class procedure TSQLRestRoutingJSON_RPC.ClientSideInvoke(var uri: RawUTF8;

  const method, params, clientDrivenID: RawUTF8; out sent: RawUTF8);

begin

  sent := '{"method":"'+method+'","params":['+params;

  if clientDrivenID='' then

    sent := sent+']}' else

    sent := sent+'],"id":'+clientDrivenID+'}';

end;



function TSQLRestServer.ServiceRegister(

  aImplementationClass: TInterfacedClass; const aInterfaces: array of PTypeInfo;

  aInstanceCreation: TServiceInstanceImplementation;

  const aContractExpected: RawUTF8): TServiceFactoryServer;

begin

  if (aImplementationClass=nil) or (high(aInterfaces)<0) then

    result := nil else

    result := (ServiceContainer as TServiceContainerServer).

      AddImplementation(aImplementationClass,aInterfaces,aInstanceCreation,nil,aContractExpected);

end;



function TSQLRestServer.ServiceRegister(aSharedImplementation: TInterfacedObject;

  const aInterfaces: array of PTypeInfo; const aContractExpected: RawUTF8): TServiceFactoryServer;

begin

  if (self=nil) or (aSharedImplementation=nil) or (high(aInterfaces)<0) then

    result := nil else

    result := (ServiceContainer as TServiceContainerServer).

      AddImplementation(TInterfacedClass(aSharedImplementation.ClassType),

        aInterfaces,sicShared,aSharedImplementation,aContractExpected);

end;



function TSQLRestServer.ServiceRegister(aClient: TSQLRest;

  const aInterfaces: array of PTypeInfo;

  aInstanceCreation: TServiceInstanceImplementation;

  const aContractExpected: RawUTF8): boolean;

begin

  result := False;

  if (self=nil) or (high(aInterfaces)<0) or (aClient=nil) then

    exit;

  result := (ServiceContainer as TServiceContainerServer).AddInterface(

    aInterfaces,aInstanceCreation,aContractExpected);

end;



function TSQLRestServer.ServiceDefine(aImplementationClass: TInterfacedClass;

  const aInterfaces: array of TGUID; aInstanceCreation: TServiceInstanceImplementation;

  const aContractExpected: RawUTF8): TServiceFactoryServer;

begin

  result := ServiceRegister(aImplementationClass,

    TInterfaceFactory.GUID2TypeInfo(aInterfaces),aInstanceCreation,aContractExpected);

end;



function TSQLRestServer.ServiceDefine(aSharedImplementation: TInterfacedObject;

  const aInterfaces: array of TGUID; const aContractExpected: RawUTF8): TServiceFactoryServer;

begin

  result := ServiceRegister(aSharedImplementation,

    TInterfaceFactory.GUID2TypeInfo(aInterfaces),aContractExpected);

end;



function TSQLRestServer.ServiceDefine(aClient: TSQLRest;

  const aInterfaces: array of TGUID;

  aInstanceCreation: TServiceInstanceImplementation;

  const aContractExpected: RawUTF8): boolean;

begin

  result := ServiceRegister(aClient,

    TInterfaceFactory.GUID2TypeInfo(aInterfaces),

    aInstanceCreation,aContractExpected);

end;



procedure TSQLRestServer.URI(var Call: TSQLRestURIParams);

const COMMANDTEXT: array[TSQLRestServerURIContextCommand] of string[15] =

  ('','SOA-Method ','SOA-Interface ','ORM-Get ','ORM-Write ');

var Ctxt: TSQLRestServerURIContext;

    timeStart,timeEnd: Int64;

    elapsed, len: cardinal;

    outcomingfile: boolean;

{$ifdef WITHLOG}

    Log: ISynLog; // for Enter auto-leave to work with FPC

begin

  Log := fLogClass.Enter('URI(% % inlen=%)',[Call.Method,Call.Url,length(Call.InBody)],self);

{$else}

begin

{$endif}

  QueryPerformanceCounter(timeStart);

  fStats.AddCurrentRequestCount(1);

  Call.OutInternalState := InternalState; // other threads may change it

  Call.OutStatus := HTML_BADREQUEST; // default error code is 400 BAD REQUEST

  Ctxt := ServicesRouting.Create(self,Call);

  try

    {$ifdef WITHLOG}

    Ctxt.Log := Log.Instance;

    {$endif}

    if fShutdownRequested then

      Ctxt.Error('Server is shutting down',HTML_UNAVAILABLE) else

    if Ctxt.Method=mNone then

      Ctxt.Error('Unknown VERB') else

    // 1. decode URI

    if not Ctxt.URIDecodeREST then

      Ctxt.Error('Invalid Root',HTML_NOTFOUND) else

    if (RootRedirectGet<>'') and (Ctxt.Method=mGet) and

       (Call.Url=Model.Root) and (Call.InBody='') then

      Ctxt.Redirect(RootRedirectGet) else begin

      Ctxt.URIDecodeSOAByMethod;

      if (Ctxt.MethodIndex<0) and (Ctxt.URI<>'') then

        Ctxt.URIDecodeSOAByInterface;

      // 2. handle security

      if not Ctxt.Authenticate then

        Ctxt.AuthenticationFailed(afInvalidSignature) else

      if (Ctxt.Service<>nil) and

          not (reService in Call.RestAccessRights^.AllowRemoteExecute) then

        if (rsoRedirectForbiddenToAuth in Options) and (Ctxt.ClientKind=ckAjax) then

          Ctxt.Redirect(Model.Root+'/auth') else

          Ctxt.AuthenticationFailed(afRemoteServiceExecutionNotAllowed) else

      // 3. call appropriate ORM / SOA commands in fAcquireExecution[] context

      try

        if Ctxt.MethodIndex>=0 then

          if Ctxt.MethodIndex=fPublishedMethodBatchIndex then

            Ctxt.Command := execORMWrite else

            Ctxt.Command := execSOAByMethod else

        if Ctxt.Service<>nil then

          Ctxt.Command := execSOAByInterface else

        if Ctxt.Method in [mLOCK,mGET,mUNLOCK,mSTATE] then

          // handle read methods

          Ctxt.Command := execORMGet else

          // write methods (mPOST, mPUT, mDELETE...)

          Ctxt.Command := execORMWrite;

        if (not Assigned(OnBeforeURI)) or OnBeforeURI(Ctxt) then

          Ctxt.ExecuteCommand;

      except

        on E: Exception do

          if (not Assigned(OnErrorURI)) or OnErrorURI(Ctxt,E) then

            // return 500 internal server error

            Ctxt.Error(E,'',[],HTML_SERVERERROR);

      end;

    end;

    // 4. returns expected result to the client and update Server statistics

    if StatusCodeIsSuccess(Call.OutStatus) then begin

      outcomingfile := false;

      if Call.OutBody<>'' then begin

        len := length(Call.OutHead);

        outcomingfile := (len>=25) and (Call.OutHead[15]='!') and

          IdemPChar(pointer(Call.OutHead),STATICFILE_CONTENT_TYPE_HEADER_UPPPER);

      end else // Call.OutBody=''

        if (Call.OutStatus=HTML_SUCCESS) and

           (rsoHtml200WithNoBodyReturns204 in fOptions) then

          Call.OutStatus := HTML_NOCONTENT;

      fStats.ProcessSuccess(outcomingfile);

    end else begin

      fStats.ProcessErrorNumber(Call.OutStatus);

      if Call.OutBody='' then // if no custom error message, compute it now as JSON

        Ctxt.Error(Ctxt.CustomErrorMsg,Call.OutStatus);

    end;

    StatsAddSizeForCall(fStats,Call);

    if (Ctxt.Static<>nil) and Ctxt.Static.InheritsFrom(TSQLRestStorage) and

       TSQLRestStorage(Ctxt.Static).fOutInternalStateForcedRefresh then

      // force always refresh for Static table which demands it

      Call.OutInternalState := cardinal(-1) else

      // database state may have changed above

      Call.OutInternalState := InternalState;

    if Ctxt.OutSetCookie<>'' then

      Call.OutHead := Trim(Call.OutHead+#13#10'Set-Cookie: '+Ctxt.OutSetCookie+

        '; Path=/'); // not Path=/ModelRoot, since would be case sensitive

  finally

    QueryPerformanceCounter(timeEnd);

    Ctxt.MicroSecondsElapsed := fStats.FromExternalQueryPerformanceCounters(timeEnd-timeStart);

    {$ifdef WITHLOG}

    InternalLog('% % % %/% %-> % with outlen=% in % us',

      [Ctxt.SessionUserName,Ctxt.SessionRemoteIP,Call.Method,Model.Root,Ctxt.URI,

      COMMANDTEXT[Ctxt.Command],Call.OutStatus,length(Call.OutBody),Ctxt.MicroSecondsElapsed],sllServer);

    if (Call.OutBody<>'') and (sllServiceReturn in fLogFamily.Level) then

      if (Ctxt.ServiceExecution=nil) or not(optNoLogOutput in Ctxt.ServiceExecution^.Options) then

        if IsHTMLContentTypeTextual(pointer(Call.OutHead)) then

          fLogFamily.SynLog.Log(sllServiceReturn,Call.OutBody,self,MAX_SIZE_RESPONSE_LOG);

    {$endif}

    if mlTables in StatLevels then

      case Ctxt.Command of

      execORMGet:

        fStats.NotifyORMTable(Ctxt.TableIndex,length(Call.OutBody),false,Ctxt.MicroSecondsElapsed);

      execORMWrite:

        fStats.NotifyORMTable(Ctxt.TableIndex,length(Call.InBody),true,Ctxt.MicroSecondsElapsed);

      end;

    fStats.AddCurrentRequestCount(-1);

    if fStatUsage<>nil then

      fStatUsage.Modified(fStats,[]);

    if Assigned(OnAfterURI) then

    try

      OnAfterURI(Ctxt);

    except

    end;

    Ctxt.Free;

  end;

  if Assigned(OnIdle) then begin

    elapsed := GetTickCount64 shr 7; // trigger every 128 ms

    if elapsed<>fOnIdleLastTix then begin

      OnIdle(self);

      fOnIdleLastTix := elapsed;

    end;

  end;

end;



function TSQLRestServer.FullStatsAsJson: RawUTF8;

var Ctxt: TSQLRestServerURIContext;

    call: TSQLRestURIParams;

begin // emulates root/stat?withall=1 method call

  Ctxt := TSQLRestRoutingREST.Create(Self,call);

  try

    Ctxt.Parameters := 'withall=1';

    Stat(Ctxt);

    result := Call.OutBody;

  finally

    Ctxt.Free;

  end;

end;



function TSQLRestServer.FullStatsAsDocVariant: variant;

begin

  _Json(FullStatsAsJson,result,JSON_OPTIONS_FAST);

end;



procedure TSQLRestServer.InternalInfo(var info: TDocVariantData);

begin // called by root/TimeStamp/info REST method

  info.AddNameValuesToObject(['exe', ExeVersion.ProgramName,

    'version', ExeVersion.Version.Detailed, 'started', Stats.StartDate,

    'clients', Stats.ClientsCurrent, 'methods', Stats.ServiceMethod,

    'interfaces', Stats.ServiceInterface, 'total', Stats.TaskCount,

    'time', Stats.TotalTime.Text, 'host', ExeVersion.Host]);

  with TSynMonitorMemory.Create do

  try

    info.AddNameValuesToObject(['memused', KB(AllocatedUsed.Bytes),

      'memfree', FormatUTF8('% / %',[PhysicalMemoryFree.Text,PhysicalMemoryTotal.Text])]);

  finally

    Free;

  end;

end;



procedure TSQLRestServer.InternalStat(Ctxt: TSQLRestServerURIContext; W: TTextWriter);

const READWRITE: array[boolean] of string[9] = ('{"read":','{"write":');

var s,i: integer;

    withall,rw: boolean;

begin

  Stats.ComputeDetailsTo(W);

  W.CancelLastChar('}');

  if fCache<>nil then begin

    W.AddShort(',"cachedMemoryBytes":');

    W.AddU(fCache.CachedMemory); // will also flush outdated JSON

    W.Add(',');

  end;

  withall := Ctxt.InputExists['withall'];

  if withall or Ctxt.InputExists['withtables'] then begin

    W.CancelLastComma;

    W.AddShort(',"tables":[');

    Stats.Lock; // thread-safe Stats.fPerTable[] access

    try

      for i := 0 to fModel.TablesMax do begin

        W.Add('{"%":[',[fModel.TableProps[i].Props.SQLTableName]);

        for rw := False to True do

          if (i<Length(Stats.fPerTable[rw])) and

             (Stats.fPerTable[rw,i]<>nil) and

             (Stats.fPerTable[rw,i].TaskCount<>0) then begin

            W.AddShort(READWRITE[rw]);

            Stats.fPerTable[rw,i].ComputeDetailsTo(W);

            W.Add('}',',');

          end;

        W.CancelLastComma;

        W.AddShort(']},');

      end;

    finally

      Stats.UnLock;

    end;

    W.CancelLastComma;

    W.Add(']',',');

  end;

  if withall or Ctxt.InputExists['withmethods'] then begin

    W.CancelLastComma;

    W.AddShort(',"methods":[');

    for i := 0 to high(fPublishedMethod) do

      with fPublishedMethod[i] do

      if (Stats<>nil) and (Stats.TaskCount<>0) then begin

        W.Add('{"%":',[Name]);

        Stats.ComputeDetailsTo(W);

        W.Add('}',',');

      end;

    W.CancelLastComma;

    W.Add(']',',');

  end;

  if withall or Ctxt.InputExists['withinterfaces'] then begin

    W.CancelLastComma;

    W.AddShort(',"interfaces":[');

    for s := 0 to fServices.Count-1 do

    with fServices.Index(s) as TServiceFactoryServer do

      for i := 0 to fInterface.MethodsCount-1 do

      if fStats[i]<>nil then begin

        W.Add('{"%":',[fInterface.fMethods[i].InterfaceDotMethodName]);

        fStats[i].ComputeDetailsTo(W);

        W.Add('}',',');

      end;

    W.CancelLastComma;

    W.Add(']',',');

  end;

  if (withall or Ctxt.InputExists['withsessions']) and

     (fSessions<>nil) then begin

    W.CancelLastComma;

    W.AddShort(',"sessions":[');

    fSessions.Safe.Lock;

    try

      for s := 0 to fSessions.Count-1 do begin

        W.WriteObject(fSessions.List[s]);

        W.CancelLastChar('}');

        with TAuthSession(fSessions.List[s]) do begin

          W.AddShort(',"methods":[');

          for i := 0 to high(fMethods) do

            if fMethods[i]<>nil then begin

              W.Add('{"%":',[fPublishedMethod[i].Name]);

              fMethods[i].ComputeDetailsTo(W);

              W.Add('}',',');

            end;

          W.CancelLastComma;

          W.AddShort('],"interfaces":[');

          for i := 0 to high(fInterfaces) do

            if fInterfaces[i]<>nil then begin

              W.Add('{"%":',[Services.fListInterfaceMethod[i].InterfaceDotMethodName]);

              fInterfaces[i].ComputeDetailsTo(W);

              W.Add('}',',');

            end;

          W.CancelLastComma;

          W.AddShort(']},');

        end;

      end;

    finally

      fSessions.Safe.UnLock;

    end;

    W.CancelLastComma;

    W.Add(']',',');

  end;

  W.CancelLastComma;

  W.Add('}');

end;



procedure TSQLRestServer.Stat(Ctxt: TSQLRestServerURIContext);

var W: TTextWriter;

    json,xml,name: RawUTF8;

begin

  W := TJSONSerializer.CreateOwnedStream;

  try

    name := Ctxt.InputUTF8OrVoid['findservice'];

    if name='' then begin

      InternalStat(Ctxt,W);

      name := 'Stats';

    end else

      AssociatedServices.FindServiceAll(name,W);

    W.SetText(json);

    if Ctxt.InputExists['format'] or

       IdemPropNameU(Ctxt.URIBlobFieldName,'json') then

      json := JSONReformat(json) else

      if IdemPropNameU(Ctxt.URIBlobFieldName,'xml') then begin

        JSONBufferToXML(pointer(json),XMLUTF8_HEADER,'<'+name+'>',xml);

        Ctxt.Returns(xml,200,XML_CONTENT_TYPE_HEADER);

        exit;

      end;

    Ctxt.Returns(json);

  finally

    W.Free;

  end;

end;



procedure TSQLRestServer.SetStatUsage(usage: TSynMonitorUsage);

begin

  if fStatUsage=usage then

    exit;

  if usage=nil then begin

    // e.g. from TTestServiceOrientedArchitecture.ClientSideRESTSessionsStats

    FreeAndNil(fStatUsage);

    exit;

  end;

  if fStatUsage<>nil then

    raise EModelException.CreateUTF8('%.StatUsage should be set once', [self]);

  fStatUsage := usage;

  fStatUsage.Track(fStats,'rest');

end;



procedure TSQLRestServer.AdministrationExecute(const DatabaseName,SQL: RawUTF8;

  var result: TServiceCustomAnswer);

var isAjax: boolean;

    name,interf,method: RawUTF8;

    obj: TObject;

    call: TSQLRestURIParams;

    info: TDocVariantData;

    P: PUTF8Char;



  procedure PrepareCall;

  begin

    call.Init;

    BYPASS_ACCESS_RIGHTS := SUPERVISOR_ACCESS_RIGHTS;

    call.RestAccessRights := @BYPASS_ACCESS_RIGHTS;

    call.Url := Model.Root;

  end;



begin

  isAjax := not NoAjaxJson;

  if isAjax then

    NoAjaxJson := true; // reduce memory use from a Delphi (ToolsAdmin) tool

  try

    if (SQL<>'') and (SQL[1]='#') then begin

      P := @SQL[2];

      case IdemPCharArray(P,['INTERFACES','STATS(','STATS','SERVICES','SESSIONS',

        'GET','POST','WRAPPER','HELP','INFO']) of

      0: result.Content := ServicesPublishedInterfaces;

      1: begin

        name := copy(SQL,8,length(SQL)-8);

        obj := ServiceMethodStat[name];

        if obj=nil then begin

          Split(name,'.',interf,method);

          obj := Services[interf];

          if obj<>nil then

            obj := (obj as TServiceFactoryServer).Stat[method] else

            obj := nil;

        end;

        if obj<>nil then

          result.Content := ObjectToJSON(obj);

      end;

      2: result.Content := FullStatsAsJson;

      3: result.Content := Services.AsJson;

      4: result.Content := SessionsAsJson;

      5,6: begin

        PrepareCall;

        call.Method := GetNextItem(P,' '); // GET or POST

        if P<>nil then

          call.Url := call.Url+'/'+RawUTF8(P);

        URI(call);

        result.Content := call.OutBody;

      end;

      7: begin

        PrepareCall;

        call.Method := 'GET';

        call.Url := call.Url+'/wrapper/context';

        URI(call);

        result.Content := call.OutBody;

      end;

      8: begin

        inherited;

        result.Content[length(result.Content)] := '|';

        result.Content := result.Content+'#interfaces|#wrapper|#info|'+

          '#stats|#stats(method)|#stats(interface.method)|#services|#sessions|'+

          '#get url|#post url"';

      end;

      9: begin

        info.InitJSONInPlace(pointer(result.Content)); // from DatabaseExecute()

        InternalInfo(info);

        result.Content := info.ToJSON;

      end;

      else inherited AdministrationExecute(DatabaseName,SQL,result);

      end;

    end else

      inherited; // will execute the SQL

  finally

    NoAjaxJson := not isAjax;

  end;

end;



procedure TSQLRestServer.TimeStamp(Ctxt: TSQLRestServerURIContext);

var

  info: TDocVariantData;

begin

  if IdemPropNameU(Ctxt.URIBlobFieldName,'info') then begin

    info.InitFast;

    InternalInfo(info);

    Ctxt.Returns(info.ToJSON('','',jsonHumanReadable));

  end else

    Ctxt.Returns(Int64ToUtf8(ServerTimeStamp),HTML_SUCCESS,TEXT_CONTENT_TYPE_HEADER);

end;



procedure TSQLRestServer.CacheFlush(Ctxt: TSQLRestServerURIContext);

begin

  case Ctxt.Method of

  mGET: begin

    if Ctxt.Table=nil then

      Cache.Flush else

      if Ctxt.TableID=0 then

        Cache.Flush(Ctxt.Table) else

        Cache.SetCache(Ctxt.Table,Ctxt.TableID);

    Ctxt.Success;

  end;

  mPOST:

    if Ctxt.URIBlobFieldName='_callback_' then

      (Services as TServiceContainerServer).FakeCallbackRelease(Ctxt);

  end;

end;



procedure TSQLRestServer.Batch(Ctxt: TSQLRestServerURIContext);

var Results: TInt64DynArray;

    i: integer;

begin

  if not (Ctxt.Method in [mPUT,mPOST]) then begin

    Ctxt.Error('PUT/POST only');

    exit;

  end;

  try

    EngineBatchSend(Ctxt.Table,Ctxt.Call.InBody,TIDDynArray(Results),0);

  except

    on E: Exception do begin

      Ctxt.Error(E,'did break % BATCH process',[Ctxt.Table],HTML_SERVERERROR);

      exit;

    end;

  end;

  // send back operation status array

  Ctxt.Call.OutStatus := HTML_SUCCESS;

  for i := 0 to length(Results)-1 do

    if Results[i]<>HTML_SUCCESS then begin

      Ctxt.Call.OutBody := Int64DynArrayToCSV(Results,length(Results),'[',']');

      exit;

    end;

  Ctxt.Call.OutBody := '["OK"]';  // to save bandwith if no adding

end;



function ServerNonce(Previous: boolean): RawUTF8;

var Ticks: cardinal;

begin

  Ticks := GetTickCount64 div (1000*60*5); // valid for 5*60*1000 ms = 5 minutes

  if Previous then

    dec(Ticks);

  result := SHA256(@Ticks,sizeof(Ticks)); // naive but sufficient nonce

end;



procedure TSQLRestServer.SessionCreate(var User: TSQLAuthUser;

  Ctxt: TSQLRestServerURIContext; out Session: TAuthSession);

var i: integer;

begin

  Session := nil;

  if (reOneSessionPerUser in Ctxt.Call^.RestAccessRights^.AllowRemoteExecute) and

     (fSessions<>nil) then

    for i := 0 to fSessions.Count-1 do

      if TAuthSession(fSessions.List[i]).User.fID=User.fID then begin

        {$ifdef WITHLOG}

        with TAuthSession(fSessions.List[i]) do

          Ctxt.Log.Log(sllUserAuth,'User.LogonName=% already connected from "%/%"',

            [User.LogonName,RemoteIP,Ctxt.Call^.LowLevelConnectionID],self);

        {$endif}

        Ctxt.AuthenticationFailed(afSessionAlreadyStartedForThisUser);

        exit; // user already connected

      end;

  Session := fSessionClass.Create(Ctxt,User);

  if Assigned(OnSessionCreate) then

    if OnSessionCreate(self,Session,Ctxt) then begin // TRUE aborts session creation

      {$ifdef WITHLOG}

      Ctxt.Log.Log(sllUserAuth,'Session aborted by OnSessionCreate() callback '+

         'for User.LogonName=% (connected from "%/%") - clients=%, sessions=%',

        [User.LogonName,Session.RemoteIP,Ctxt.Call^.LowLevelConnectionID,

         fStats.GetClientsCurrent,fSessions.Count],self);

      {$endif}

      Ctxt.AuthenticationFailed(afSessionCreationAborted);

      User := nil;

      FreeAndNil(Session);

      exit;

    end;

  User := nil; // will be freed by TAuthSession.Destroy

  fSessions.Add(Session);

  fStats.ClientConnect;

end;



procedure TSQLRestServer.Auth(Ctxt: TSQLRestServerURIContext);

var i: integer;

begin

  if fSessionAuthentication=nil then

    exit;

  fSessions.Safe.Lock;

  try

    for i := 0 to length(fSessionAuthentication)-1 do

      if fSessionAuthentication[i].Auth(Ctxt) then

        break; // found an authentication, which may be successfull or not

  finally

    fSessions.Safe.UnLock;

  end;

end;



procedure TSQLRestServer.SessionDelete(aSessionIndex: integer;

  Ctxt: TSQLRestServerURIContext);

begin

  if (self<>nil) and (cardinal(aSessionIndex)<cardinal(fSessions.Count)) then

  with TAuthSession(fSessions.List[aSessionIndex]) do begin

    if Services is TServiceContainerServer then

      TServiceContainerServer(Services).OnCloseSession(IDCardinal);

    if Ctxt=nil then

      InternalLog('Deleted session %:%/%',

        [User.LogonName,IDCardinal,fSessions.Count],sllUserAuth) else

      InternalLog('Deleted session %:%/% from %/%',

        [User.LogonName,IDCardinal,fSessions.Count,RemoteIP,Ctxt.Call^.LowLevelConnectionID],sllUserAuth);

    if Assigned(OnSessionClosed) then

      OnSessionClosed(self,fSessions.List[aSessionIndex],Ctxt);

    fSessions.Delete(aSessionIndex);

    fStats.ClientDisconnect;

  end;

end;



function TSQLRestServer.SessionAccess(Ctxt: TSQLRestServerURIContext): TAuthSession;

var i: integer;

    Tix64: Int64;

begin // caller shall be locked via fSessions.Safe.Lock

  if (self<>nil) and (fSessions<>nil) then begin

    // first check for outdated sessions to be deleted

    Tix64 := GetTickCount64;

    for i := fSessions.Count-1 downto 0 do

      with TAuthSession(fSessions.List[i]) do

        if Tix64>LastAccess64+TimeOutMS then

          SessionDelete(i,nil);

    // retrieve session

    for i := 0 to fSessions.Count-1 do begin

      result := TAuthSession(fSessions.List[i]);

      if result.IDCardinal=Ctxt.Session then begin

        result.fLastAccess64 := Tix64; // refresh session access timestamp

        Ctxt.fAuthSession := result;

        Ctxt.SessionUser := result.User.fID;

        Ctxt.SessionGroup := result.User.GroupRights.fID;

        Ctxt.SessionUserName := result.User.LogonName;

        Ctxt.SessionRemoteIP := result.RemoteIP;

        exit;

      end;

    end;

  end;

  result := nil;

end;



function TSQLRestServer.SessionGetUser(aSessionID: Cardinal): TSQLAuthUser;

var i: integer;

begin

  result := nil;

  if self=nil then

    exit;

  fSessions.Safe.Lock;

  try

    for i := 0 to fSessions.Count-1 do

      with TAuthSession(fSessions.List[i]) do

      if IDCardinal=aSessionID then begin

        if User<>nil then begin

          result := User.CreateCopy as fSQLAuthUserClass;

          result.GroupRights := nil;

        end;

        Break;

      end;

  finally

    fSessions.Safe.UnLock;

  end;

end;





function TSQLRestServer.SessionsAsJson: RawJSON;

var i: integer;

begin

  result := '';

  if (self=nil) or (fSessions.Count=0) then

    exit;

  fSessions.Safe.Lock;

  with TJSONSerializer.CreateOwnedStream do

  try

    Add('[');

    for i := 0 to fSessions.Count-1 do begin

      WriteObject(fSessions.List[i]);

      Add(',');

    end;

    CancelLastComma;

    Add(']');

    SetText(RawUTF8(result));

  finally

    fSessions.Safe.UnLock;

    Free;

  end;

end;



const

  MAGIC_SESSION: cardinal = $A5ABA5AB;



procedure TSQLRestServer.SessionsSaveToFile(const aFileName: TFileName);

var i: integer;

    MS: TRawByteStringStream;

    W: TFileBufferWriter;

    s: RawByteString;

begin

  if self=nil then

    exit;

  DeleteFile(aFileName);

  MS := TRawByteStringStream.Create;

  try

    W := TFileBufferWriter.Create(MS);

    fSessions.Safe.Lock;

    try

      W.WriteVarUInt32(InternalState);

      SQLAuthUserClass.RecordProps.SaveBinaryHeader(W);

      SQLAuthGroupClass.RecordProps.SaveBinaryHeader(W);

      W.WriteVarUInt32(fSessions.Count);

      for i := 0 to fSessions.Count-1 do

        TAuthSession(fSessions.List[i]).SaveTo(W);

      W.Write4(MAGIC_SESSION);

      W.Flush;

    finally

      fSessions.Safe.UnLock;

      W.Free;

    end;

    s := SynLZCompress(MS.DataString);

    SymmetricEncrypt(MAGIC_SESSION,s);

    FileFromString(s,aFileName,true);

  finally

    MS.Free;

  end;

end;



procedure TSQLRestServer.SessionsLoadFromFile(const aFileName: TFileName;

  andDeleteExistingFileAfterRead: boolean);

procedure ContentError;

begin

  raise ESynException.CreateUTF8('%.SessionsLoadFromFile("%")',[self,aFileName]);

end;

var i,n: integer;

    s: RawByteString;

    R: TFileBufferReader;

    P: PAnsiChar;

begin

  if self=nil then

    exit;

  s := StringFromFile(aFileName);

  SymmetricEncrypt(MAGIC_SESSION,s);

  s := SynLZDecompress(s);

  if s='' then

    exit;

  R.OpenFrom(pointer(s),length(s));

  fSessions.Safe.Lock;

  try

    InternalState := R.ReadVarUInt32;

    if not SQLAuthUserClass.RecordProps.CheckBinaryHeader(R) or

       not SQLAuthGroupClass.RecordProps.CheckBinaryHeader(R) then

      ContentError;

    n := R.ReadVarUInt32;

    P := R.CurrentMemory;

    fSessions.Clear;

    for i := 1 to n do begin

      fSessions.Add(fSessionClass.CreateFrom(P,self));

      fStats.ClientConnect;

    end;

    if PCardinal(P)^<>MAGIC_SESSION then

      ContentError;

  finally

    fSessions.Safe.UnLock;

    R.Close;

  end;

  if andDeleteExistingFileAfterRead then

    DeleteFile(aFileName);

end;



function TSQLRestServer.CacheWorthItForTable(aTableIndex: cardinal): boolean;

begin

  if self=nil then

    result := false else

    result := (aTableIndex>=cardinal(length(fStaticData))) or

      (not fStaticData[aTableIndex].InheritsFrom(TSQLRestStorageInMemory));

end;



procedure TSQLRestServer.BeginCurrentThread(Sender: TThread);

var i, tc: integer;

    CurrentThreadId: TThreadID;

begin

  tc := fStats.NotifyThreadCount(1);

  CurrentThreadId := GetCurrentThreadId;

  if Sender=nil then

    raise ECommunicationException.CreateUTF8('%.BeginCurrentThread(nil)',[self]);

  InternalLog('BeginCurrentThread(%) root=% ThreadID=% ThreadCount=%',

    [Sender.ClassType,Model.Root,pointer(CurrentThreadId),tc],sllTrace);

  if Sender.ThreadID<>CurrentThreadId then

    raise ECommunicationException.CreateUTF8(

      '%.BeginCurrentThread(Thread.ID=%) and CurrentThreadID=% should match',

      [self,Sender.ThreadID,CurrentThreadId]);

  with PServiceRunningContext(@ServiceContext)^ do // P..(@..)^ for ONE GetTls()

    if RunningThread<>Sender then // e.g. if length(TSQLHttpServer.fDBServers)>1

      if RunningThread<>nil then

        raise ECommunicationException.CreateUTF8('%.BeginCurrentThread() twice',[self]) else

        RunningThread := Sender;

  if fStaticVirtualTable<>nil then

    for i := 0 to high(fStaticVirtualTable) do

      if (fStaticVirtualTable[i]<>nil) and

         fStaticVirtualTable[i].InheritsFrom(TSQLRestStorage) then

        TSQLRestStorage(fStaticVirtualTable[i]).BeginCurrentThread(Sender);

end;



procedure TSQLRestServer.EndCurrentThread(Sender: TThread);

var i, tc: integer;

    CurrentThreadId: TThreadID;

    Inst: TServiceFactoryServerInstance;

begin

  tc := fStats.NotifyThreadCount(-1);

  CurrentThreadId := GetCurrentThreadId;

  if Sender=nil then

    raise ECommunicationException.CreateUTF8('%.EndCurrentThread(nil)',[self]);

  InternalLog('EndCurrentThread(%) ThreadID=% ThreadCount=%',

    [Sender.ClassType,pointer(CurrentThreadId),tc],sllTrace);

  if Sender.ThreadID<>CurrentThreadId then

    raise ECommunicationException.CreateUTF8(

      '%.EndCurrentThread(%.ID=%) should match CurrentThreadID=%',

      [self,Sender,Sender.ThreadID,CurrentThreadId]);

 if fStaticVirtualTable<>nil then

   for i := 0 to high(fStaticVirtualTable) do

     if (fStaticVirtualTable[i]<>nil) and

        fStaticVirtualTable[i].InheritsFrom(TSQLRestStorage) then

       TSQLRestStorage(fStaticVirtualTable[i]).EndCurrentThread(Sender);

  if Services<>nil then begin

    Inst.InstanceID := PtrUInt(CurrentThreadId);

    for i := 0 to Services.Count-1 do

      with TServiceFactoryServer(Services.fList.Objects[i]) do

      if InstanceCreation=sicPerThread then

        InternalInstanceRetrieve(Inst,SERVICE_METHODINDEX_FREEINSTANCE);

  end;

  with PServiceRunningContext(@ServiceContext)^ do // P..(@..)^ for ONE GetTls()

    if RunningThread<>nil then  // e.g. if length(TSQLHttpServer.fDBServers)>1

      if RunningThread<>Sender then

        raise ECommunicationException.CreateUTF8(

          '%.EndCurrentThread(%) should match RunningThread=%',

          [self,Sender,RunningThread]) else

        RunningThread := nil;

  inherited EndCurrentThread(Sender); // should be done eventually

end;







{ TSQLRecordModification }



function TSQLRecordModification.ModifiedID: TID;

begin

  if self=nil then

    result := 0 else

    result := RecordRef(fModifiedRecord).ID;

end;



function TSQLRecordModification.ModifiedTable(Model: TSQLModel): TSQLRecordClass;

begin

  if (self=nil) or (Model=nil) then

    result := nil else

    result := RecordRef(fModifiedRecord).Table(Model);

end;



function TSQLRecordModification.ModifiedTableIndex: integer;

begin

  if self=nil then

    result := 0 else

    result := RecordRef(fModifiedRecord).TableIndex;

end;





{ TSQLRecordHistory }



class procedure TSQLRecordHistory.InitializeTable(Server: TSQLRestServer;

  const FieldName: RawUTF8; Options: TSQLInitializeTableOptions);

begin

  inherited InitializeTable(Server,FieldName,Options);

  if FieldName='' then

    Server.CreateSQLMultiIndex(Self,['ModifiedRecord','Event'],false);

end;



destructor TSQLRecordHistory.Destroy;

begin

  inherited;

  fHistoryAdd.Free;

end;



constructor TSQLRecordHistory.CreateHistory(aClient: TSQLRest;

  aTable: TSQLRecordClass; aID: TID);

var Reference: RecordRef;

    Rec: TSQLRecord;

    HistJson: TSQLRecordHistory;

begin

  if (aClient=nil) or (aID<=0) then

    raise EORMException.CreateUTF8('Invalid %.CreateHistory(%,%,%) call',

      [self,aClient,aTable,aID]);

  // read BLOB changes

  Reference.From(aClient.Model,aTable,aID);

  fModifiedRecord := Reference.Value;

  fEvent := heArchiveBlob;

  Create(aClient,'ModifiedRecord=? and Event=%',[ord(heArchiveBlob)],[fModifiedRecord]);

  if fID<>0 then

    aClient.RetrieveBlobFields(self); // load former fHistory field

  if not HistoryOpen(aClient.Model) then

    raise EORMException.CreateUTF8('HistoryOpen in %.CreateHistory(%,%,%)',

      [self,aClient,aTable,aID]);

  // append JSON changes

  HistJson := RecordClass.CreateAndFillPrepare(aClient,

    'ModifiedRecord=? and Event<>%',[ord(heArchiveBlob)],[fModifiedRecord])

    as TSQLRecordHistory;

  try

    if HistJson.FillTable.RowCount=0 then

      exit; // no JSON to append

    Rec := HistoryGetLast;

    try

      while HistJson.FillOne do begin

        Rec.FillFrom(pointer(HistJson.SentDataJSON));

        HistoryAdd(Rec,HistJson);

      end;

      HistorySave(nil); // update internal fHistory field

    finally

      Rec.Free;

    end;

  finally

    HistJson.Free;

  end;

  // prepare for HistoryCount and HistoryGet() from internal fHistory field

  HistoryOpen(aClient.Model);

end;



function TSQLRecordHistory.HistoryOpen(Model: TSQLModel): boolean;

var len: cardinal;

    start,i: integer;

    R: TFileBufferReader;

    tmp: RawByteString;

begin

  result := false;

  fHistoryModel := Model;

  fHistoryUncompressed := '';

  fHistoryTable := ModifiedTable(Model);

  fHistoryUncompressedCount := 0;

  fHistoryUncompressedOffset := nil;

  if fHistoryTable=nil then

    exit; // invalid Model or ModifiedRecord

  tmp := SynLZDecompress(fHistory);

  len := length(tmp);

  if len>4 then begin

    R.OpenFrom(pointer(tmp),len);

    if not fHistoryTable.RecordProps.CheckBinaryHeader(R) then

      exit; // invalid content: TSQLRecord layout may have changed

    R.ReadVarUInt32Array(fHistoryUncompressedOffset);

    fHistoryUncompressedCount := length(fHistoryUncompressedOffset);

    start := R.CurrentPosition;

    for i := 0 to fHistoryUncompressedCount-1 do

      inc(fHistoryUncompressedOffset[i],start);

    fHistoryUncompressed := tmp;

  end;

  result := true;

end;



function TSQLRecordHistory.HistoryCount: integer;

begin

  if (self=nil) or (fHistoryUncompressed='') then

    result := 0 else

    result := fHistoryUncompressedCount;

end;



function TSQLRecordHistory.HistoryGet(Index: integer;

  out Event: TSQLHistoryEvent; out TimeStamp: TModTime; Rec: TSQLRecord): boolean;

var P: PAnsiChar;

begin

  if cardinal(Index)>=cardinal(HistoryCount) then

    result := false else begin

    P := pointer(fHistoryUncompressed);

    inc(P,fHistoryUncompressedOffset[Index]);

    Event := TSQLHistoryEvent(P^); inc(P);

    TimeStamp := FromVarUInt64(PByte(P));

    if (Rec<>nil) and (Rec.RecordClass=fHistoryTable)  then begin

      if Event=heDelete then

        Rec.ClearProperties else

        Rec.SetBinaryValuesSimpleFields(P);

      Rec.fID := ModifiedID;

    end;

    result := true;

  end;

end;



function TSQLRecordHistory.HistoryGet(Index: integer; Rec: TSQLRecord): boolean;

var Event: TSQLHistoryEvent;

    TimeStamp: TModTime;

begin

  result := HistoryGet(Index,Event,TimeStamp,Rec);

end;



function TSQLRecordHistory.HistoryGet(Index: integer): TSQLRecord;

var Event: TSQLHistoryEvent;

    TimeStamp: TModTime;

begin

  if fHistoryTable=nil then

    result := nil else begin

    result := fHistoryTable.Create;

    if not HistoryGet(Index,Event,TimeStamp,result) then

      FreeAndNil(result);

  end;

end;



function TSQLRecordHistory.HistoryGetLast(Rec: TSQLRecord): boolean;

begin

  result := HistoryGet(fHistoryUncompressedCount-1,Rec);

end;



function TSQLRecordHistory.HistoryGetLast: TSQLRecord;

var Event: TSQLHistoryEvent;

    TimeStamp: TModTime;

begin

  if fHistoryTable=nil then

    result := nil else begin

    result := fHistoryTable.Create; // always return an instance

    HistoryGet(fHistoryUncompressedCount-1,Event,TimeStamp,result);

  end;

end;



procedure TSQLRecordHistory.HistoryAdd(Rec: TSQLRecord; Hist: TSQLRecordHistory);

begin

  if (self=nil) or (fHistoryModel=nil) or (Rec.RecordClass<>fHistoryTable) then

    exit;

  if fHistoryAdd=nil then

    fHistoryAdd := TFileBufferWriter.Create(TRawByteStringStream);

  AddInteger(fHistoryAddOffset,fHistoryAddCount,fHistoryAdd.TotalWritten);

  fHistoryAdd.Write1(Ord(Hist.Event));

  fHistoryAdd.WriteVarUInt64(Hist.TimeStamp);

  if Hist.Event<>heDelete then

    Rec.GetBinaryValuesSimpleFields(fHistoryAdd);

end;



function TSQLRecordHistory.HistorySave(Server: TSQLRestServer;

  LastRec: TSQLRecord): boolean;

var size,i,maxSize,TableHistoryIndex: integer;

    firstOldIndex,firstOldOffset, firstNewIndex,firstNewOffset: integer;

    newOffset: TIntegerDynArray;

    DBRec: TSQLRecord;

    HistTemp: TSQLRecordHistory;

    W: TFileBufferWriter;

begin

  result := false;

  if (self=nil) or (fHistoryTable=nil) or (fModifiedRecord=0) then

    exit; // wrong call

  try

    // ensure latest item matches "official" one, as read from DB

    if (Server<>nil) and (LastRec<>nil) and (LastRec.fID=ModifiedID) then begin

      DBRec := Server.Retrieve(ModifiedRecord);

      if DBRec<>nil then

      try // may be just deleted

        if not DBRec.SameRecord(LastRec) then begin

          HistTemp := RecordClass.Create as TSQLRecordHistory;

          try

            HistTemp.fEvent := heUpdate;

            HistTemp.fTimeStamp := Server.ServerTimeStamp;

            HistoryAdd(DBRec,HistTemp);

          finally

            HistTemp.Free;

          end;

        end;

      finally

        DBRec.Free;

      end;

    end;

    if fHistoryAdd=nil then

      exit; // nothing new

    // ensure resulting size matches specified criteria

    firstOldIndex := 0;

    TableHistoryIndex := 0;

    if Server=nil then

      maxSize := maxInt else begin

      TableHistoryIndex := Server.Model.GetTableIndexExisting(RecordClass);

      maxSize := Server.fTrackChangesHistory[TableHistoryIndex].MaxUncompressedBlobSize;

    end;

    size := fHistoryAdd.TotalWritten;

    if (size>maxSize) or (fHistoryUncompressedCount=0) then

      // e.g. if fHistory.Add() is already bigger than expected

      firstOldIndex := fHistoryUncompressedCount else begin

      inc(size,Length(fHistoryUncompressed)-fHistoryUncompressedOffset[0]);

      while (firstOldIndex<fHistoryUncompressedCount-1) and (size>maxSize) do begin

        dec(size,fHistoryUncompressedOffset[firstOldIndex+1]-fHistoryUncompressedOffset[firstOldIndex]);

        inc(firstOldIndex);

      end;

    end;

    // creates and store new History BLOB

    W := TFileBufferWriter.Create(TRawByteStringStream);

    try

      // compute offsets

      if firstOldIndex=fHistoryUncompressedCount then

        firstOldOffset := length(fHistoryUncompressed) else

        firstOldOffset := fHistoryUncompressedOffset[firstOldIndex];

      SetLength(newOffset,fHistoryUncompressedCount-firstOldIndex+fHistoryAddCount);

      for i := firstOldIndex to fHistoryUncompressedCount-1 do

        newOffset[i-firstOldIndex] := fHistoryUncompressedOffset[i]-firstOldOffset;

      firstNewIndex := fHistoryUncompressedCount-firstOldIndex;

      firstNewOffset := Length(fHistoryUncompressed)-firstOldOffset;

      for i := 0 to fHistoryAddCount-1 do

        newOffset[firstNewIndex+i] := fHistoryAddOffset[i]+firstNewOffset;

      // write header

      fHistoryTable.RecordProps.SaveBinaryHeader(W);

      W.WriteVarUInt32Array(newOffset,length(newOffset),wkOffsetU);

      // write data

      W.Write(@PByteArray(fHistoryUncompressed)[firstOldOffset],firstNewOffset);

      fHistoryAdd.Flush;

      W.WriteBinary((fHistoryAdd.Stream as TRawByteStringStream).DataString);

      W.Flush;

      fHistoryUncompressed := (W.Stream as TRawByteStringStream).DataString;

      fHistory := SynLZCompress(fHistoryUncompressed);

      if (Server<>nil) and (fID<>0) then begin

        Server.EngineUpdateField(TableHistoryIndex,

          'TimeStamp',Int64ToUTF8(Server.ServerTimeStamp),'RowID',Int64ToUtf8(fID));

        Server.EngineUpdateBlob(TableHistoryIndex,fID,

          RecordProps.BlobFields[0].PropInfo,fHistory);

      end;

      result := true;

    finally

      W.Free;

    end;

  finally

    fHistoryUncompressed := '';

    fHistoryUncompressedOffset := nil;

    FreeAndNil(fHistoryAdd);

    fHistoryAddOffset := nil;

    fHistoryAddCount := 0;

  end;

end;



procedure TSQLRestServer.TrackChangesFlush(aTableHistory: TSQLRecordHistoryClass);

var HistBlob: TSQLRecordHistory;

    Rec: TSQLRecord;

    HistJson: TSQLRecordHistory;

    WhereClause, JSON: RawUTF8;

    HistID, ModifiedRecord: TInt64DynArray;

    TableHistoryIndex,i,HistIDCount,n: integer;

    ModifRecord, ModifRecordCount, MaxRevisionJSON: integer;

{$ifdef WITHLOG}

    Log: ISynLog; // for Enter auto-leave to work with FPC

begin

  Log := fLogClass.Enter('TrackChangesFlush(%)',[aTableHistory],self);

{$else}

begin

{$endif}

  fAcquireExecution[execORMWrite].Safe.Lock; // avoid race condition

  try // low-level Add(TSQLRecordHistory) without cache

    TableHistoryIndex := Model.GetTableIndexExisting(aTableHistory);

    MaxRevisionJSON := fTrackChangesHistory[TableHistoryIndex].MaxRevisionJSON;

    if MaxRevisionJSON<=0 then

      MaxRevisionJSON := 10;

    // we will compress into BLOB only when we got more than 10 revisions of a record

    with MultiFieldValues(aTableHistory,'RowID,ModifiedRecord',

      'Event<>%',[ord(heArchiveBlob)],[]) do

    try

      GetRowValues(fFieldIndexID,HistID);

      GetRowValues(FieldIndex('ModifiedRecord'),ModifiedRecord);

    finally

      Free;

    end;

    QuickSortInt64(pointer(ModifiedRecord),pointer(HistID),0,high(ModifiedRecord));

    ModifRecord := 0;

    ModifRecordCount := 0;

    n := 0;

    HistIDCount := 0;

    for i := 0 to high(ModifiedRecord) do begin

      if (ModifiedRecord[i]=0) or (HistID[i]=0) then

        raise EORMException.CreateUTF8('%.TrackChangesFlush: Invalid %.ID=%',

          [self,aTableHistory,HistID[i]]);

      if ModifiedRecord[i]<>ModifRecord then begin

        if ModifRecordCount>MaxRevisionJSON then

          HistIDCount := n else

          n := HistIDCount;

        ModifRecord := ModifiedRecord[i];

        ModifRecordCount := 1;

      end else

        inc(ModifRecordCount);

      HistID[n] := HistID[i];

      inc(n);

    end;

    if ModifRecordCount>MaxRevisionJSON then

      HistIDCount := n;

    if HistIDCount=0 then

      exit; // nothing to compress

    QuickSortInt64(Pointer(HistID),0,HistIDCount-1);

    WhereClause := Int64DynArrayToCSV(HistID,HistIDCount,'RowID in (',')');

    { following SQL is much slower with external tables, and won't work

      with TSQLRestStorageInMemory -> manual process instead

    WhereClause := FormatUTF8('ModifiedRecord in (select ModifiedRecord from '+

        '(select ModifiedRecord, count(*) NumItems from % group by ModifiedRecord) '+

        'where NumItems>% order by ModifiedRecord) and History is null',

        [aTableHistory.SQLTableName,MaxRevisionJSON]); }

    Rec := nil;

    HistBlob := nil;

    HistJson := aTableHistory.CreateAndFillPrepare(self,WhereClause);

    try

      HistBlob := aTableHistory.Create;

      while HistJson.FillOne do begin

        if HistJson.ModifiedRecord<>HistBlob.ModifiedRecord then begin

          if HistBlob.ModifiedRecord<>0 then

            HistBlob.HistorySave(self,Rec);

          FreeAndNil(Rec);

          HistBlob.fHistory := '';

          HistBlob.fID := 0;

          HistBlob.fEvent := heArchiveBlob;

          if not Retrieve('ModifiedRecord=? and Event=%',

              [ord(heArchiveBlob)],[HistJson.ModifiedRecord],HistBlob) then

            HistBlob.fModifiedRecord := HistJson.ModifiedRecord else

            RetrieveBlobFields(HistBlob);

          if not HistBlob.HistoryOpen(Model) then begin

            InternalLog('Invalid %.History BLOB content for ID=%: % '+

              'layout may have changed -> flush any previous content',

              [HistBlob.RecordClass,HistBlob.fID,HistJson.ModifiedTable(Model)],sllError);

            HistBlob.fID := 0;

          end;

          if HistBlob.fID<>0 then // allow changes appending to HistBlob

            Rec := HistBlob.HistoryGetLast else begin

            // HistBlob.fID=0 -> no previous BLOB content

            JSON := JSONEncode(['ModifiedRecord',HistJson.ModifiedRecord,

              'TimeStamp',ServerTimeStamp,'Event',ord(heArchiveBlob)]);

            if HistJson.Event=heAdd then begin // allow versioning from scratch

              HistBlob.fID := EngineAdd(TableHistoryIndex,JSON);

              Rec := HistJson.ModifiedTable(Model).Create;

              HistBlob.HistoryOpen(Model);

            end else begin

              Rec := Retrieve(HistJson.ModifiedRecord);

              if Rec<>nil then

              try // initialize BLOB with latest revision

                HistBlob.fID := EngineAdd(TableHistoryIndex,JSON);

                HistBlob.HistoryOpen(Model);

                HistBlob.HistoryAdd(Rec,HistJson);

              finally

                FreeAndNil(Rec); // ignore partial SentDataJSON for this record

              end;

            end;

          end;

        end;

        if (Rec=nil) or (HistBlob.fID=0) then

          continue; // only append modifications to BLOB if valid

        Rec.FillFrom(pointer(HistJson.SentDataJSON));

        HistBlob.HistoryAdd(Rec,HistJson);

      end;

      if HistBlob.ModifiedRecord<>0 then

        HistBlob.HistorySave(self,Rec);

      SetLength(HistID,HistIDCount);

      EngineDeleteWhere(TableHistoryIndex,WhereClause,TIDDynArray(HistID));

    finally

      HistJson.Free;

      HistBlob.Free;

      Rec.Free;

    end;

  finally

    fAcquireExecution[execORMWrite].Safe.UnLock;

  end;

end;



function TSQLRestServer.InternalUpdateEvent(aEvent: TSQLEvent; aTableIndex: integer;

  aID: TID; const aSentData: RawUTF8; aIsBlobFields: PSQLFieldBits): boolean;

procedure DoTrackChanges;

var TableHistoryIndex: integer;

    JSON: RawUTF8;

    Event: TSQLHistoryEvent;

begin

  case aEvent of

  seAdd:    Event := heAdd;

  seUpdate: Event := heUpdate;

  seDelete: Event := heDelete;

  else exit;

  end;

  TableHistoryIndex := fTrackChangesHistoryTableIndex[aTableIndex];

  fAcquireExecution[execORMWrite].Safe.Lock; // avoid race condition

  try // low-level Add(TSQLRecordHistory) without cache

    JSON := JSONEncode(['ModifiedRecord',aTableIndex+aID shl 6,'Event',ord(Event),

                        'SentDataJSON',aSentData,'TimeStamp',ServerTimeStamp]);

    EngineAdd(TableHistoryIndex,JSON);

    { TODO: use a BATCH to speed up TSQLHistory storage }

    if fTrackChangesHistory[TableHistoryIndex].CurrentRow>

        fTrackChangesHistory[TableHistoryIndex].MaxSentDataJsonRow then begin

      // gather & compress TSQLRecordHistory.SentDataJson into History BLOB

      TrackChangesFlush(TSQLRecordHistoryClass(Model.Tables[TableHistoryIndex]));

      fTrackChangesHistory[TableHistoryIndex].CurrentRow := 0;

    end else

      // fast append as JSON until reached MaxSentDataJsonRow

      inc(fTrackChangesHistory[TableHistoryIndex].CurrentRow);

  finally

    fAcquireExecution[execORMWrite].Safe.UnLock;

  end;

end;

begin

  if aID<=0 then

    result := false else

    if aIsBlobFields<>nil then

      // BLOB fields update

      if (aEvent=seUpdateBlob) and Assigned(OnBlobUpdateEvent) then

        result := OnBlobUpdateEvent(

          self,seUpdate,fModel.Tables[aTableIndex],aID,aIsBlobFields^) else

        result := true else begin

      // simple fields modification

      if (cardinal(aTableIndex)<fTrackChangesHistoryTableIndexCount) and

         (fTrackChangesHistoryTableIndex[aTableIndex]>=0) then

        DoTrackChanges;

      if Assigned(OnUpdateEvent) then

        result := OnUpdateEvent(self,aEvent,fModel.Tables[aTableIndex],aID,aSentData) else

        result := true; // true on success, false if error (but action continues)

    end;

end;



procedure TSQLRestServer.TrackChanges(const aTable: array of TSQLRecordClass;

  aTableHistory: TSQLRecordHistoryClass; aMaxHistoryRowBeforeBlob,

  aMaxHistoryRowPerRecord, aMaxUncompressedBlobSize: integer);

var t, tableIndex, TableHistoryIndex: integer;

begin

  if (self=nil) or (high(aTable)<0) then

    exit;

  if aMaxHistoryRowBeforeBlob<=0 then // disable change tracking

    TableHistoryIndex := -1 else begin

    if aTableHistory=nil then

      aTableHistory := TSQLRecordHistory;

    TableHistoryIndex := Model.GetTableIndexExisting(aTableHistory);

  end;

  for t := 0 to high(aTable) do begin

    tableIndex := Model.GetTableIndexExisting(aTable[t]);

    if aTable[t].InheritsFrom(TSQLRecordHistory) then

      raise EORMException.CreateUTF8('%.TrackChanges([%]) not allowed',[self,aTable[t]]);

    if cardinal(tableIndex)<fTrackChangesHistoryTableIndexCount then begin

      fTrackChangesHistoryTableIndex[tableIndex] := TableHistoryIndex;

      if TableHistoryIndex>=0 then

        with fTrackChangesHistory[TableHistoryIndex] do begin

          if CurrentRow=0 then

            CurrentRow := TableRowCount(aTableHistory);

          MaxSentDataJsonRow := aMaxHistoryRowBeforeBlob;

          MaxRevisionJSON := aMaxHistoryRowPerRecord;

          MaxUncompressedBlobSize := aMaxUncompressedBlobSize;

        end;

    end;

  end;

end;



function TSQLRestServer.InternalUpdateEventNeeded(aTableIndex: integer): boolean;

begin

  result := (self<>nil) and (Assigned(OnUpdateEvent) or

    ((cardinal(aTableIndex)<fTrackChangesHistoryTableIndexCount) and

     (fTrackChangesHistoryTableIndex[aTableIndex]>=0)));

end;



function TSQLRestServer.EngineAdd(TableModelIndex: integer; const SentData: RawUTF8): TID;

var Rest: TSQLRest;

begin

  Rest := GetStaticDataServerOrVirtualTable(TableModelIndex);

  if Rest=nil then

    result := MainEngineAdd(TableModelIndex,SentData) else

    result := Rest.EngineAdd(TableModelIndex,SentData);

end;



function TSQLRestServer.EngineRetrieve(TableModelIndex: integer; ID: TID): RawUTF8;

var Rest: TSQLRest;

begin

  Rest := GetStaticDataServerOrVirtualTable(TableModelIndex);

  if Rest=nil then

    result := MainEngineRetrieve(TableModelIndex,ID) else

    result := Rest.EngineRetrieve(TableModelIndex,ID);

end;



function TSQLRestServer.EngineList(const SQL: RawUTF8; ForceAJAX: Boolean;

  ReturnedRowCount: PPtrInt): RawUTF8;

var Rest: TSQLRest;

    StaticSQL: RawUTF8;

begin

  StaticSQL := SQL;

  Rest := InternalAdaptSQL(Model.GetTableIndexFromSQLSelect(SQL,false),StaticSQL);

  if Rest=nil then

    result := MainEngineList(SQL,ForceAJAX,ReturnedRowCount) else

    result := Rest.EngineList(StaticSQL,ForceAJAX,ReturnedRowCount);

end;



function TSQLRestServer.EngineUpdate(TableModelIndex: integer; ID: TID;

  const SentData: RawUTF8): boolean;

var Rest: TSQLRest;

begin

  Rest := GetStaticDataServerOrVirtualTable(TableModelIndex);

  if Rest=nil then

    result := MainEngineUpdate(TableModelIndex,ID,SentData) else

    result := Rest.EngineUpdate(TableModelIndex,ID,SentData);

end;



function TSQLRestServer.EngineDelete(TableModelIndex: integer; ID: TID): boolean;

var Rest: TSQLRest;

begin

  Rest := GetStaticDataServerOrVirtualTable(TableModelIndex);

  if Rest=nil then

    result := MainEngineDelete(TableModelIndex,ID) else

    result := Rest.EngineDelete(TableModelIndex,ID);

  if result then

    if Model.TableProps[TableModelIndex].Props.RecordVersionField<>nil then

      InternalRecordVersionDelete(TableModelIndex,ID,nil);

end;



function TSQLRestServer.EngineDeleteWhere(TableModelIndex: integer;

  const SQLWhere: RawUTF8; const IDs: TIDDynArray): boolean;

var Rest: TSQLRest;

    Batch: TSQLRestBatch;

    i: integer;

begin

  case length(IDs) of

  0: result := false;

  1: result := EngineDelete(TableModelIndex,IDs[0]);

  else begin

    Rest := GetStaticDataServerOrVirtualTable(TableModelIndex);

    if Rest=nil then

      result := MainEngineDeleteWhere(TableModelIndex,SQLWhere,IDs) else

      result := Rest.EngineDeleteWhere(TableModelIndex,SQLWhere,IDs);

    if (Model.TableProps[TableModelIndex].Props.RecordVersionField=nil) or

       not result then

      exit;

    Batch := TSQLRestBatch.Create(Self,Model.Tables[TableModelIndex],1000);

    try

      for i := 0 to high(IDs) do

        InternalRecordVersionDelete(TableModelIndex,IDs[i],Batch);

      BatchSend(Batch); // allow faster deletion for engines allowing it

    finally

      Batch.Free;

    end;

  end;

  end;

end;



function TSQLRestServer.EngineRetrieveBlob(TableModelIndex: integer; aID: TID;

  BlobField: PPropInfo; out BlobData: TSQLRawBlob): boolean;

var Rest: TSQLRest;

begin

  Rest := GetStaticDataServerOrVirtualTable(TableModelIndex);

  if Rest=nil then

    result := MainEngineRetrieveBlob(TableModelIndex,aID,BlobField,BlobData) else

    result := Rest.EngineRetrieveBlob(TableModelIndex,aID,BlobField,BlobData);

end;



function TSQLRestServer.EngineUpdateBlob(TableModelIndex: integer; aID: TID;

  BlobField: PPropInfo; const BlobData: TSQLRawBlob): boolean;

var Rest: TSQLRest;

begin

  Rest := GetStaticDataServerOrVirtualTable(TableModelIndex);

  if Rest=nil then

    result := MainEngineUpdateBlob(TableModelIndex,aID,BlobField,BlobData) else

    result := Rest.EngineUpdateBlob(TableModelIndex,aID,BlobField,BlobData);

end;



function TSQLRestServer.EngineUpdateField(TableModelIndex: integer;

  const SetFieldName, SetValue, WhereFieldName, WhereValue: RawUTF8): boolean;

var Rest: TSQLRest;

begin

  Rest := GetStaticDataServerOrVirtualTable(TableModelIndex);

  if Rest=nil then

    result := MainEngineUpdateField(TableModelIndex,SetFieldName,SetValue,

      WhereFieldName,WhereValue) else

    result := Rest.EngineUpdateField(TableModelIndex,SetFieldName,SetValue,

      WhereFieldName,WhereValue);

end;



function TSQLRestServer.EngineUpdateFieldIncrement(TableModelIndex: integer;

  ID: TID; const FieldName: RawUTF8; Increment: Int64): boolean;

var Rest: TSQLRest;

begin

  Rest := GetStaticDataServerOrVirtualTable(TableModelIndex);

  if Rest=nil then

    result := MainEngineUpdateFieldIncrement(TableModelIndex,ID,FieldName,Increment) else

    result := Rest.EngineUpdateFieldIncrement(TableModelIndex,ID,FieldName,Increment);

end;





type

  EORMBatchException = class(EORMException);



function TSQLRestServer.EngineBatchSend(Table: TSQLRecordClass;

  const Data: RawUTF8; var Results: TIDDynArray; ExpectedResultsCount: integer): integer;

var EndOfObject: AnsiChar;

    wasString, OK: boolean;

    TableName, Value, ErrMsg: RawUTF8;

    URIMethod, RunningBatchURIMethod: TSQLURIMethod;

    RunningBatchRest, RunningRest: TSQLRest;

    Sent, Method, MethodTable: PUTF8Char;

    AutomaticTransactionPerRow: cardinal;

    RowCountForCurrentTransaction: cardinal;

    RunTableTransactions: array of TSQLRest;

    RunMainTransaction: boolean;

    ID: TID;

    Count: integer;

    timeoutTix: Int64;

    batchOptions: TSQLRestBatchOptions;

    RunTable, RunningBatchTable: TSQLRecordClass;

    RunTableIndex,i,TableIndex: integer;

    RunStatic: TSQLRest;

    RunStaticKind: TSQLRestServerKind;

    CurrentContext: TSQLRestServerURIContext;

    counts: array[mPOST..mDELETE] of cardinal;



  procedure PerformAutomaticCommit;

  var i: integer;

  begin

    if RunningBatchRest<>nil then begin

      RunningBatchRest.InternalBatchStop; // send pending rows before commit

      RunningBatchRest := nil;

      RunningBatchTable := nil;

    end;

    for i := 0 to high(RunTableTransactions) do

      if RunTableTransactions[i]<>nil then begin

        RunTableTransactions[i].Commit(CONST_AUTHENTICATION_NOT_USED,true);

        RunTableTransactions[i] := nil;

        if RunTableTransactions[i]=Self then

          RunMainTransaction := false;

      end;

    RowCountForCurrentTransaction := 0;

  end;

  function IsNotAllowed: boolean;

  begin

    result := (CurrentContext<>nil) and

      not CurrentContext.Call.RestAccessRights^.CanExecuteORMWrite(

        URIMethod,RunTable,RunTableIndex,ID,CurrentContext);

  end;



{$ifdef WITHLOG}

var Log: ISynLog; // for Enter auto-leave to work with FPC

begin

  Log := fLogClass.Enter('EngineBatchSend % inlen=%',[Table,length(Data)],self);

{$else}

begin

{$endif}

  Sent := pointer(Data);

  if Sent=nil then

    raise EORMBatchException.CreateUTF8('%.EngineBatchSend(%,"")',[self,Table]);

  CurrentContext := ServiceContext.Request;

  if Table<>nil then begin

    TableIndex := Model.GetTableIndexExisting(Table);

    // unserialize expected sequence array as '{"Table":["cmd",values,...]}'

    if not NextNotSpaceCharIs(Sent,'{') then

      raise EORMBatchException.CreateUTF8('%.EngineBatchSend: Missing {',[self]);

    TableName := GetJSONPropName(Sent);

    if (TableName='') or (Sent=nil) or

       not IdemPropNameU(TableName,Model.TableProps[TableIndex].Props.SQLTableName) then

      raise EORMBatchException.CreateUTF8('%.EngineBatchSend(%): Wrong "Table":"%"',

        [self,Table,TableName]);

  end else // or '["cmd@Table":values,...]'

    TableIndex := -1;

  if not NextNotSpaceCharIs(Sent,'[') then

    raise EORMBatchException.CreateUTF8('%.EngineBatchSend: Missing [',[self]);

  if IdemPChar(Sent,'"AUTOMATICTRANSACTIONPERROW",') then begin

    inc(Sent,29);

    AutomaticTransactionPerRow := GetNextItemCardinal(Sent,',');

  end else

    AutomaticTransactionPerRow := 0;

  SetLength(RunTableTransactions,Model.TablesMax+1);

  RunMainTransaction := false;

  RowCountForCurrentTransaction := 0;

  if IdemPChar(Sent,'"OPTIONS",') then begin

    inc(Sent,10);

    byte(batchOptions) := GetNextItemCardinal(Sent,',');

  end else

    byte(batchOptions) := 0;

  MethodTable := nil;

  RunningBatchRest := nil;

  RunningBatchTable := nil;

  RunningBatchURIMethod := mNone;

  Count := 0;

  FillcharFast(counts,SizeOf(counts),0);

  fAcquireExecution[execORMWrite].fSafe.Lock; // multi thread protection 

  try // to protect automatic transactions and global write lock

  try // to protect InternalBatchStart/Stop locking

    repeat // main loop: process one POST/PUT/DELETE per iteration

      // retrieve method name and associated (static) table

      Method := GetJSONField(Sent,Sent,@wasString);

      if (Sent=nil) or (Method=nil) or not wasString then

        raise EORMBatchException.CreateUTF8('%.EngineBatchSend: Missing CMD',[self]);

      MethodTable := PosChar(Method,'@');

      if MethodTable=nil then begin // e.g. '{"Table":[...,"POST",{object},...]}'

        if TableIndex<0 then

          raise EORMBatchException.CreateUTF8(

            '%.EngineBatchSend: "..@Table" expected',[self]);

        RunTableIndex := TableIndex;

        RunTable := Table;

      end else begin                // e.g. '[...,"POST@Table",{object},...]'

        RunTableIndex := Model.GetTableIndex(MethodTable+1);

        if RunTableIndex<0 then

          raise EORMBatchException.CreateUTF8('%.EngineBatchSend: Unknown %',

            [self,MethodTable]);

        RunTable := Model.Tables[RunTableIndex];

      end;

      RunStatic := GetStaticDataServerOrVirtualTable(RunTableIndex,RunStaticKind);

      if RunStatic=nil then

        RunningRest := self else

        RunningRest := RunStatic;

      // get CRUD method and associated Value/ID

      case IdemPCharArray(Method,['POST','PUT','DELETE','SIMPLE']) of

        // IdemPCharArray() will ignore '@' char if appended after method name

        0: begin

          // '{"Table":[...,"POST",{object},...]}' or '[...,"POST@Table",{object},...]'

          URIMethod := mPOST;

          Value := JSONGetObject(Sent,@ID,EndOfObject,true);

          if Sent=nil then

            raise EORMBatchException.CreateUTF8(

              '%.EngineBatchSend: Wrong POST',[self]);

          if IsNotAllowed then

            raise EORMBatchException.CreateUTF8(

              '%.EngineBatchSend: POST/Add not allowed on %',[self,RunTable]);

          if not RecordCanBeUpdated(RunTable,ID,seAdd,@ErrMsg)  then

            raise EORMBatchException.CreateUTF8(

              '%.EngineBatchSend: POST impossible: %',[self,ErrMsg]);

        end;

        1: begin

          // '{"Table":[...,"PUT",{object},...]}' or '[...,"PUT@Table",{object},...]'

          URIMethod := mPUT;

          Value := JSONGetObject(Sent,@ID,EndOfObject,false);

          if (Sent=nil) or (Value='') or (ID<=0) then

            raise EORMBatchException.CreateUTF8('%.EngineBatchSend: Wrong PUT',[self]);

          if IsNotAllowed then

            raise EORMBatchException.CreateUTF8(

              '%.EngineBatchSend: PUT/Update not allowed on %',[self,RunTable]);

        end;

        2: begin

          // '{"Table":[...,"DELETE",ID,...]}' or '[...,"DELETE@Table",ID,...]'

          URIMethod := mDELETE;

          ID := GetInt64(GetJSONField(Sent,Sent,@wasString,@EndOfObject));

          if (ID<=0) or wasString then

            raise EORMBatchException.CreateUTF8(

              '%.EngineBatchSend: Wrong DELETE',[self]);

          if IsNotAllowed then

            raise EORMBatchException.CreateUTF8(

              '%.EngineBatchSend: DELETE not allowed on %',[self,RunTable]);

          if not RecordCanBeUpdated(RunTable,ID,seDelete,@ErrMsg) then

            raise EORMBatchException.CreateUTF8(

              '%.EngineBatchSend: DELETE impossible: "%"',[self,ErrMsg]);

        end;

        3: begin

          // '{"Table":[...,"SIMPLE",[values],...]}' or '[...,"SIMPLE@Table",[values],...]'

          URIMethod := mPOST;

          Value := Model.TableProps[RunTableIndex].Props.

            SaveSimpleFieldsFromJsonArray(Sent,EndOfObject,true);

          ID := 0; // no ID is never transmitted with simple fields

          if (Sent=nil) or (Value='') then

            raise EORMBatchException.CreateUTF8(

              '%.EngineBatchSend: Wrong SIMPLE',[self]);

          if IsNotAllowed then

            raise EORMBatchException.CreateUTF8(

              '%.EngineBatchSend: SIMPLE/Add not allowed on %',[self,RunTable]);

          if not RecordCanBeUpdated(RunTable,0,seAdd,@ErrMsg)  then

            raise EORMBatchException.CreateUTF8(

              '%.EngineBatchSend: SIMPLE/Add impossible: %',[self,ErrMsg]);

        end;

        else raise EORMBatchException.CreateUTF8(

          '%.EngineBatchSend: Unknown "%" method',[self,Method]);

      end;

      if (Count=0) and (EndOfObject=']') then begin

        // single operation do not need a transaction nor InternalBatchStart/Stop

        AutomaticTransactionPerRow := 0;

        SetLength(Results,1);

      end else begin

        // handle auto-committed transaction process

        if AutomaticTransactionPerRow>0 then begin

          if RowCountForCurrentTransaction=AutomaticTransactionPerRow then

            PerformAutomaticCommit; // reached AutomaticTransactionPerRow chunk

          inc(RowCountForCurrentTransaction);

          if RunTableTransactions[RunTableIndex]=nil then

            // initiate transaction for this table if not started yet

            if (RunStatic<>nil) or not RunMainTransaction then begin

              timeoutTix := GetTickCount64+2000;

              repeat

                if RunningRest.TransactionBegin(RunTable, // acquire transaction

                     CONST_AUTHENTICATION_NOT_USED) then begin

                  RunTableTransactions[RunTableIndex] := RunningRest;

                  if RunStatic=nil then

                    RunMainTransaction := true;

                  Break;

                end;

                if GetTickCount64>timeoutTix then

                  raise EORMBatchException.CreateUTF8(

                    '%.EngineBatchSend: %.TransactionBegin timeout',[self,RunningRest]);

                SleepHiRes(1); // retry in 1 ms

              until false;

            end;

        end;

        // handle batch pending request sending (if table or method changed)

        if (RunningBatchRest<>nil) and

           ((RunTable<>RunningBatchTable) or (RunningBatchURIMethod<>URIMethod)) then begin

          RunningBatchRest.InternalBatchStop; // send pending statements

          RunningBatchRest := nil;

          RunningBatchTable := nil;

        end;

        if (RunStatic<>nil) and (RunStatic<>RunningBatchRest) and

           RunStatic.InternalBatchStart(URIMethod,batchOptions) then begin

          RunningBatchRest := RunStatic;

          RunningBatchTable := RunTable;

          RunningBatchURIMethod := URIMethod;

        end else

        if (RunningBatchRest=nil) and (RunStatic=nil) and

           InternalBatchStart(URIMethod,batchOptions) then begin

          RunningBatchRest := self; // e.g. multi-insert in main SQlite3 engine

          RunningBatchTable := RunTable;

          RunningBatchURIMethod := URIMethod;

        end;

        if Count>=length(Results) then

          SetLength(Results,Count+256+Count shr 3);

      end;

      // process CRUD method operation

      Results[Count] := HTML_NOTMODIFIED;

      case URIMethod of

      mDELETE: begin

        OK := EngineDelete(RunTableIndex,ID);

        if OK then begin

          if fCache<>nil then

            fCache.NotifyDeletion(RunTableIndex,ID);

          if (RunningBatchRest<>nil) or

             AfterDeleteForceCoherency(RunTableIndex,ID) then

            Results[Count] := HTML_SUCCESS; // 200 OK

        end;

      end;

      mPOST: begin

        ID := EngineAdd(RunTableIndex,Value);

        Results[Count] := ID;

        if (ID<>0) and (fCache<>nil) then

          fCache.Notify(RunTableIndex,ID,Value,soInsert);

      end;

      mPUT: begin

        OK := EngineUpdate(RunTableIndex,ID,Value);

        if OK then begin

          Results[Count] := HTML_SUCCESS; // 200 OK

          if fCache<>nil then // JSON Value may be uncomplete -> delete from cache

            fCache.NotifyDeletion(RunTableIndex,ID);

        end;

      end;

      else raise EORMBatchException.CreateUTF8('%.EngineBatchSend: Unknown "%" method',

        [self,Method]);

      end;

      inc(Count);

      inc(counts[URIMethod]);

    until EndOfObject=']';

    if (AutomaticTransactionPerRow>0) and (RowCountForCurrentTransaction>0) then

      // send pending rows within transaction

      PerformAutomaticCommit;

  finally

    if RunningBatchRest<>nil then

      RunningBatchRest.InternalBatchStop; // send pending rows, and release Safe.Lock

    fAcquireExecution[execORMWrite].fSafe.UnLock;

    InternalLog('EngineBatchSend json=% add=% update=% delete=% %%',

      [KB(length(Data)),counts[mPOST],counts[mPUT],counts[mDELETE],

       MethodTable,Table],sllTrace);

  end;

  except

    on Exception do begin

      if (AutomaticTransactionPerRow>0) and (RowCountForCurrentTransaction>0) then begin

        for i := 0 to high(RunTableTransactions) do

          if RunTableTransactions[i]<>nil then

            RunTableTransactions[i].RollBack(CONST_AUTHENTICATION_NOT_USED);

        InternalLog('PARTIAL rollback of latest auto-committed transaction',sllWarning);

      end;

      raise;

    end;

  end;

  if Table<>nil then begin // '{"Table":["cmd":values,...]}' format

    if Sent=nil then

      raise EORMBatchException.CreateUTF8('%.EngineBatchSend: % Truncated',[self,Table]);

    while not (Sent^ in ['}',#0]) do inc(Sent);

    if Sent^<>'}' then

      raise EORMBatchException.CreateUTF8('%.EngineBatchSend(%): Missing }',[self,Table]);

  end;

  // if we reached here, process was OK

  SetLength(Results,Count);

  result := HTML_SUCCESS;

end;



function CurrentServiceContext: TServiceRunningContext;

begin

  result := ServiceContext;

end;



function CurrentServiceContextServer: TSQLRestServer;

begin

  with PServiceRunningContext(@ServiceContext)^ do

  if Request<>nil then

    result := Request.Server else

    result := nil;

end;





function ToText(gran: TSynMonitorUsageGranularity): PShortString;

begin

  result := GetEnumName(TypeInfo(TSynMonitorUsageGranularity),ord(gran));

end;



function ToText(ft: TSQLFieldType): PShortString; 

begin

  result := GetEnumName(TypeInfo(TSQLFieldType),ord(ft));

end;



function ToText(tk: TTypeKind): PShortString; 

begin

  result := GetEnumName(TypeInfo(TTypeKind),ord(tk));

end;



function ToText(e: TSQLEvent): PShortString; 

begin

  result := GetEnumName(TypeInfo(TSQLEvent),ord(e));

end;



function ToText(he: TSQLHistoryEvent): PShortString; 

begin

  result := GetEnumName(TypeInfo(TSQLHistoryEvent),ord(he));

end;



function ToText(o: TSQLOccasion): PShortString; 

begin

  result := GetEnumName(TypeInfo(TSQLOccasion),ord(o));

end;



function ToText(dft: TSQLDBFieldType): PShortString;

begin

  result := GetEnumName(TypeInfo(TSQLDBFieldType),ord(dft));

end;



function ToText(si: TServiceInstanceImplementation): PShortString;

begin

  result := GetEnumName(TypeInfo(TServiceInstanceImplementation),ord(si));

end;



function ToText(cmd: TSQLRestServerURIContextCommand): PShortString;

begin

  result := GetEnumName(TypeInfo(TSQLRestServerURIContextCommand),ord(cmd));

end;



function ToText(op: TSQLQueryOperator): PShortString;

begin

  result := GetEnumName(TypeInfo(TSQLQueryOperator),ord(op));

end;



function ToText(V: TInterfaceMockSpyCheck): PShortString;

begin

  result := GetEnumName(TypeInfo(TInterfaceMockSpyCheck),ord(V));

end;



function ToText(m: TSQLURIMethod): PShortString;

begin

  result := GetEnumName(TypeInfo(TSQLURIMethod),ord(m));

end;



function ToText(o: TSynTableStatementOperator): PShortString;

begin

  result := GetEnumName(TypeInfo(TSynTableStatementOperator),ord(o));

end;



function ToText(t: TSQLVirtualTableTransaction): PShortString; 

begin

  result := GetEnumName(TypeInfo(TSQLVirtualTableTransaction),ord(t));

end;







{ TSQLRestClientURIDll }



constructor TSQLRestClientURIDll.Create(aModel: TSQLModel; const DllName: TFileName);

var aRequest: TURIMapRequest;

    aDLL: cardinal;

begin

  {$ifdef KYLIX3}

  aDLL := LoadLibrary(pointer(DllName));

  {$else}

  {$ifndef MSWINDOWS}

  aDLL := LoadLibrary(DllName);

  {$else}

  aDLL := LoadLibrary(pointer(DllName));

  {$endif}

  {$endif}

  if aDLL=0 then

    raise ECommunicationException.CreateUTF8('%.Create: LoadLibrary(%)',[self,DllName]);

  aRequest := GetProcAddress(aDLL,'URIRequest');

  if (@aRequest=nil) or (aRequest(nil,nil,nil,nil,nil).Lo<>HTML_NOTFOUND) then begin

    FreeLibrary(aDLL);

    raise ECommunicationException.CreateUTF8(

      '%.Create: % doesn''t export a valid URIRequest() function',[self,DllName]);

  end;

  Create(aModel,aRequest);

  fLibraryHandle := aDLL;

end;



constructor TSQLRestClientURIDll.Create(aModel: TSQLModel; aRequest: TURIMapRequest);

begin

  inherited Create(aModel);

  Func := aRequest;

end;



destructor TSQLRestClientURIDll.Destroy;

begin

  if fLibraryHandle<>0 then

    FreeLibrary(fLibraryHandle);

  inherited;

end;



procedure TSQLRestClientURIDll.InternalURI(var Call: TSQLRestURIParams);

var result: Int64Rec;

    pHead, pResp: PUTF8Char;

begin

  if @Func=nil then begin

    Call.OutStatus := HTML_NOTIMPLEMENTED; // 501 (no valid application or library)

    exit;

  end;

  pResp := nil;

  pHead := nil;

  try

    result := Func(pointer(Call.Url),pointer(Call.Method),pointer(Call.InBody),

      @pResp,@pHead);

    Call.OutStatus := result.Lo;

    Call.OutInternalState := result.Hi;

    if pHead<>nil then

      Call.OutHead := pHead;

    if pResp<>nil then

      Call.OutBody := pResp;

  finally // always release response memory allocated by the server

    if pResp<>nil then

      {$ifdef MSWINDOWS}

      if not USEFASTMM4ALLOC then

        GlobalFree(PtrUInt(pResp)) else

      {$endif}

        Freemem(pResp);

    if pHead<>nil then

      {$ifdef MSWINDOWS}

      if not USEFASTMM4ALLOC then

        GlobalFree(PtrUInt(pHead)) else

      {$endif}

        Freemem(pHead);

  end;

end;



function TSQLRestClientURIDll.InternalCheckOpen: boolean;

begin

  result := true; // success

end;



procedure TSQLRestClientURIDll.InternalClose;

begin

end;





{ TSQLRestClientRedirect }



constructor TSQLRestClientRedirect.Create(aModel: TSQLModel);

begin

  inherited Create(aModel);

  fModel.Owner := self;

end;



constructor TSQLRestClientRedirect.Create(aRedirected: TSQLRest);

begin

  if aRedirected=nil then

    raise EORMException.CreateUTF8('%.Create(nil)',[self]);

  Create(TSQLModel.Create(aRedirected.Model));

  RedirectTo(aRedirected);

end;



constructor TSQLRestClientRedirect.CreateOwned(aRedirected: TSQLRestServer);

begin

  Create(aRedirected);

  fPrivateGarbageCollector.Add(aRedirected);

end;



procedure TSQLRestClientRedirect.RedirectTo(aRedirected: TSQLRest);

begin

  fSafe.Enter;

  try

    fRedirectedClient := nil;

    fRedirectedServer := nil;

    if aRedirected=nil then

      exit; // redirection disabled

    if aRedirected.InheritsFrom(TSQLRestServer) then

      fRedirectedServer := aRedirected as TSQLRestServer else

    if aRedirected.InheritsFrom(TSQLRestClientURI) then

      fRedirectedClient := aRedirected as TSQLRestClientURI else

      raise EORMException.CreateUTF8('%.RedirectTo: % should be either % or %',

        [self,aRedirected,TSQLRestServer,TSQLRestClientURI]);

  finally

    fSafe.Leave;

  end;

end;



function TSQLRestClientRedirect.InternalCheckOpen: boolean;

begin

  result := Assigned(fRedirectedServer) or Assigned(fRedirectedClient);

end;



procedure TSQLRestClientRedirect.InternalClose;

begin

end;



procedure TSQLRestClientRedirect.InternalURI(var Call: TSQLRestURIParams);

begin

  fSafe.Enter;

  try

    if Assigned(fRedirectedServer) then

      fRedirectedServer.URI(Call) else

    if Assigned(fRedirectedClient) then

      // hook to access InternalURI() protected method

      TSQLRestClientRedirect(fRedirectedClient).InternalURI(Call) else

      Call.OutStatus := HTML_GATEWAYTIMEOUT;

  finally

    fSafe.Leave;

  end;

end;





{$ifdef MSWINDOWS}



{$ifdef ANONYMOUSNAMEDPIPE}



// it should be necessary to Edit settings under Local Security Policy -> Local

// policies -> Security options -> Edit settings under "Network access" to allow

// for anonymous connections.



// BUT even with the pipe name added to the

//  SYSTEM\CurrentControlSet\Services\lanmanserver\parameters\NullSessionPipes

// registry key, code below didn't work



function GetUserSid(var SID: PSID; var Token: THandle): boolean;

var TokenUserSize: DWORD;

    TokenUserP: PSIDAndAttributes;

begin

  result := false;

  if not OpenThreadToken(GetCurrentThread,TOKEN_QUERY,True,Token) then

    if (GetLastError <> ERROR_NO_TOKEN) or

       not OpenProcessToken(GetCurrentProcess,TOKEN_QUERY,Token) then

      exit;

  TokenUserP := nil;

  TokenUserSize := 0;

  try

    if not GetTokenInformation(Token,TokenUser,nil,0,TokenUserSize) and

       (GetLastError <> ERROR_INSUFFICIENT_BUFFER) then

      exit;

    TokenUserP := AllocMem(TokenUserSize);

    if not GetTokenInformation(Token,TokenUser,TokenUserP,TokenUserSize,TokenUserSize) then

      exit;

    SID := TokenUserP^.Sid;

    result := true;

  finally

    FreeMem(TokenUserP);

  end;

end;



{$ALIGN ON}

type

    ACE_HEADER = record

      AceType: BYTE;

      AceFlags: BYTE;

      AceSize: WORD;

    end;

    ACCESS_ALLOWED_ACE = record

      Header: ACE_HEADER;

      Mask: ACCESS_MASK;

      SidStart: DWORD;

    end;

{$A8}



procedure InitializeSecurity(var SA: TSecurityAttributes; var SD);

const

  SECURITY_NT_AUTHORITY: TSIDIdentifierAuthority = (Value: (0, 0, 0, 0, 0, 5));

  SECURITY_ANONYMOUS_LOGON_RID = ($00000007);

  ACL_REVISION = 2;

var pSidAnonymous, pSidOwner: PSID;

    dwAclSize: integer;

    ACLP: PACL;

    Token: THandle;

begin

  FillcharFast(SD,SECURITY_DESCRIPTOR_MIN_LENGTH,0);

  // Initialize the new security descriptor

  if InitializeSecurityDescriptor(@SD, SECURITY_DESCRIPTOR_REVISION) and

      GetUserSid(pSidOwner,Token) then begin

    AllocateAndInitializeSid(SECURITY_NT_AUTHORITY,1,

      SECURITY_ANONYMOUS_LOGON_RID,0,0,0,0,0,0,0,pSidAnonymous);

    try

      dwAclSize := sizeof(TACL) +

        2 * ( sizeof(ACCESS_ALLOWED_ACE) - sizeof(DWORD) ) +

        GetLengthSid(pSidAnonymous) + GetLengthSid(pSidOwner) ;

      ACLP := AllocMem(dwAclSize);

      try

        InitializeAcl(ACLP^,dwAclSize,ACL_REVISION);

        if not AddAccessAllowedAce(ACLP^,ACL_REVISION,

           GENERIC_ALL,pSidOwner) then

          exit;

        if not AddAccessAllowedAce(ACLP^,ACL_REVISION,

           GENERIC_READ or GENERIC_WRITE,pSidAnonymous) then

          exit;

        if SetSecurityDescriptorDacl(@SD,true,ACLP,false) then begin

           // Set up the security attributes structure

           SA.nLength := sizeof(TSecurityAttributes);

           SA.lpSecurityDescriptor := @SD;

           SA.bInheritHandle := true;

           exit; // mark OK

        end;

      finally

        FreeMem(ACLP);

      end;

    finally

      FreeSid(pSidAnonymous);

      CloseHandle(Token);

    end;

  end;

  FillcharFast(SA,sizeof(SA),0); // mark error: no security

end;



{$else}



{$ifndef NOSECURITYFORNAMEDPIPECLIENTS}



{$if CompilerVersion >= 22.0} // fix Delphi XE incompatilibility

function InitializeSecurityDescriptor(pSecurityDescriptor: PSecurityDescriptor;

  dwRevision: DWORD): BOOL; stdcall; external advapi32;

function SetSecurityDescriptorDacl(pSecurityDescriptor: PSecurityDescriptor;

  bDaclPresent: BOOL; pDacl: PACL; bDaclDefaulted: BOOL): BOOL; stdcall; external advapi32;

{$ifend}



procedure InitializeSecurity(var SA: TSecurityAttributes; var SD);

begin

  FillcharFast(SD,SECURITY_DESCRIPTOR_MIN_LENGTH,0);

  // Initialize the new security descriptor

  if InitializeSecurityDescriptor(@SD, SECURITY_DESCRIPTOR_REVISION) then begin

     // Add a NULL descriptor ACL to the security descriptor

     if SetSecurityDescriptorDacl(@SD, true, nil, false) then begin

        // Set up the security attributes structure

        SA.nLength := sizeof(TSecurityAttributes);

        SA.lpSecurityDescriptor := @SD;

        SA.bInheritHandle := true;

        exit; // mark OK

     end;

  end;

  FillcharFast(SA,sizeof(SA),0); // mark error: no security

end;



{$endif NOSECURITYFORNAMEDPIPECLIENTS}



{$endif ANONYMOUSNAMEDPIPE}





{ TSQLRestServerNamedPipe }



constructor TSQLRestServerNamedPipe.Create(aServer: TSQLRestServer;

  const PipeName: TFileName);

begin

  fServer := aServer;

  fPipeName := PipeName;

  fChild := TList.Create;

  inherited Create(aServer,false,false);

end;



destructor TSQLRestServerNamedPipe.Destroy;

var i: integer;

begin

  for i := 0 to fChild.Count-1 do // close any still opened pipe

    if fChild[i]<>nil then begin

      {writeln('fChildCount=',fChildCount,' TSQLRestServerNamedPipeResponse=',

        integer(TSQLRestServerNamedPipeResponse),'.Terminated=',

        BoolToStr(TSQLRestServerNamedPipeResponse(fChild[i]).Terminated,true));}

      TSQLRestServerNamedPipeResponse(fChild[i]).Terminate;

    end;

  while fChildCount>0 do

    SleepHiRes(64); // wait for all TSQLRestServerNamedPipeResponse.Destroy

  fChild.Free;

  inherited;

end;



procedure TSQLRestServerNamedPipe.InternalExecute;

{$ifdef FPC}

const PIPE_UNLIMITED_INSTANCES = 255;

{$endif}

var aPipe: cardinal;

    Available: cardinal;

    {$ifndef NOSECURITYFORNAMEDPIPECLIENTS}

    fPipeSecurityAttributes: TSecurityAttributes;

    fPipeSecurityDescriptor: array[0..SECURITY_DESCRIPTOR_MIN_LENGTH] of byte;

    {$endif}

begin // see http://msdn.microsoft.com/en-us/library/aa365588(v=VS.85).aspx

  //writeln('TSQLRestServerNamedPipe=',integer(TSQLRestServerNamedPipe),'.Execute');

  {$ifndef NOSECURITYFORNAMEDPIPECLIENTS}

  InitializeSecurity(fPipeSecurityAttributes,fPipeSecurityDescriptor);

  {$endif}

  while not Terminated do begin

    //writeln('TSQLRestServerNamedPipe.CreateNamedPipe(',fPipeName,')');

    aPipe := CreateNamedPipe(pointer(fPipeName),

      PIPE_ACCESS_DUPLEX,

      PIPE_TYPE_BYTE or PIPE_READMODE_BYTE or PIPE_WAIT,

      PIPE_UNLIMITED_INSTANCES, 0, 0, 0,

      {$ifdef NOSECURITYFORNAMEDPIPECLIENTS}nil{$else}@fPipeSecurityAttributes{$endif});

    if aPipe=cardinal(INVALID_HANDLE_VALUE) then

      break;

    while not Terminated do

      if PeekNamedPipe(aPipe,nil,0,nil,@Available,nil) then

        if (Available>=4) then begin

          // PeekNamedPipe() made an implicit ConnectNamedPipe(aPipe,nil)

          InterlockedIncrement(fChildCount);

          TSQLRestServerNamedPipeResponse.Create(fServer,self,aPipe);

          aPipe := 0; // aPipe will be closed in TSQLRestServerNamedPipeResponse

          break;

        end

        else break // invalid request

      else SleepHiRes(128); // doesn't slow down connection but decreases CSwitch

    if aPipe<>0 then begin

      DisconnectNamedPipe(aPipe);

      CloseHandle(aPipe);

    end;

  end;

end;





{ TSQLRestServerNamedPipeResponse }



constructor TSQLRestServerNamedPipeResponse.Create(aServer: TSQLRestServer;

  aMasterThread: TSQLRestServerNamedPipe; aPipe: cardinal);

begin

  fServer := aServer;

  fMasterThread := aMasterThread;

  with fMasterThread.fChild do begin

    fMasterThreadChildIndex := IndexOf(nil); // get free position in fChild[]

    if fMasterThreadChildIndex<0 then

      fMasterThreadChildIndex := Add(self) else

      Items[fMasterThreadChildIndex] := self;

  end;

  fPipe := aPipe;

{$ifdef LVCL}

  FOnTerminate := fServer.EndCurrentThread;

{$endif}

  FreeOnTerminate := true;

  inherited Create(fServer,false,false);

end;



destructor TSQLRestServerNamedPipeResponse.Destroy;

begin

  if fMasterThread<>nil then

    with fMasterThread do begin

      fChild[fMasterThreadChildIndex] := nil;

      InterlockedDecrement(fChildCount);

    end;

  inherited;

end;



procedure TSQLRestServerNamedPipeResponse.InternalExecute;

var call: TSQLRestURIParams;

    Code: integer;

    Ticks64, Sleeper64, ClientTimeOut64: Int64;

    Header: RawUTF8;

    Available: cardinal;

begin

  if (fPipe=0) or (fPipe=Cardinal(INVALID_HANDLE_VALUE)) or (fServer=nil) then

    exit;

  Header := 'RemoteIP: 127.0.0.1';

  call.Init;

  call.LowLevelConnectionID := fPipe;

  Ticks64 := 0;

  Sleeper64 := 0;

  ClientTimeOut64 := GetTickCount64+30*60*1000; // disconnect after 30 min of inactivity

  try

    while not Terminated do

    if // (WaitForSingleObject(fPipe,200)=WAIT_OBJECT_0)  = don't wait

       PeekNamedPipe(fPipe,nil,0,nil,@Available,nil) and (Available>=4) then begin

      FileRead(fPipe,Code,4);

      if (Code=integer(MAGIC_SYN)) // magic word for URI like request

        and not Terminated then

        try

          call.Url := ReadString(fPipe);

          call.Method := ReadString(fPipe);

          call.InHead := ReadString(fPipe);

          if call.InHead='' then

            call.InHead := Header else

            call.InHead := call.InHead+#13#10+Header;

          call.InBody := ReadString(fPipe);

          call.RestAccessRights := @SUPERVISOR_ACCESS_RIGHTS;

          call.OutHead := ''; // may not be reset explicitly by fServer.URI()

          call.OutBody := '';

          // it's up to URI overridden method to implement access rights

          fServer.URI(call);

          FileWrite(fPipe,call.OutStatus,sizeof(cardinal));

          FileWrite(fPipe,call.OutInternalState,sizeof(cardinal));

          WriteString(fPipe,call.OutHead);

          WriteString(fPipe,call.OutBody);

          FlushFileBuffers(fPipe); // Flush the pipe to allow the client to read

          Ticks64 := GetTickCount64+20; // start sleeping after 20 ms

          ClientTimeOut64 := Ticks64+30*60*1000;

          Sleeper64 := 0;

          SleepHiRes(0);

        except

          on Exception do // error in ReadString() or fServer.URI()

            break; // disconnect client

        end else

          break; // invalid magic word: disconnect client

    end else

    if (Ticks64=0) or (GetTickCount64>Ticks64) then begin

      if Sleeper64<128 then

        inc(Sleeper64,16);

      SleepHiRes(Sleeper64); // doesn't slow down connection but decreases CSwitch

      Ticks64 := 0;

      if GetTickCount64>ClientTimeOut64 then

        break; // disconnect client after 30 min of inactivity

    end else

      SleepHiRes(0);

  finally

    DisconnectNamedPipe(fPipe);

    CloseHandle(fPipe);

  end;

end;





{ TSQLRestClientURINamedPipe }



function ImpersonateAnonymousToken(ThreadHandle: THANDLE): BOOL; stdcall; external advapi32;



constructor TSQLRestClientURINamedPipe.Create(aModel: TSQLModel;

  const ApplicationName: TFileName);

begin

  inherited Create(aModel);

  if {$ifdef UNICODE}IdemPCharW{$else}IdemPChar{$endif}(pointer(ApplicationName),'\\') then

    fPipeName := ApplicationName else // caller specified a full path

    fPipeName := ServerPipeNamePrefix+ApplicationName;

end;



procedure TSQLRestClientURINamedPipe.DefinitionTo(Definition: TSynConnectionDefinition);

begin

  if Definition=nil then

    exit;

  inherited DefinitionTo(Definition); // write Kind + User/Password

  Definition.ServerName := StringToUTF8(fPipeName);

end;



constructor TSQLRestClientURINamedPipe.RegisteredClassCreateFrom(aModel: TSQLModel;

  aDefinition: TSynConnectionDefinition);

begin

  Create(aModel,UTF8ToString(aDefinition.ServerName));

  inherited RegisteredClassCreateFrom(aModel,aDefinition); // call SetUser()

end;



function TSQLRestClientURINamedPipe.InternalCheckOpen: boolean;

procedure InternalCreateClientPipe;

var Pipe: THandle;

    StartTime64: Int64;

    {$ifdef WITHLOG}

    Log: ISynLog;

    {$endif}

procedure CreatePipe;

begin

  Pipe := CreateFile(pointer(fPipeName), GENERIC_READ or GENERIC_WRITE,

{$ifdef ANONYMOUSNAMEDPIPE}

    FILE_SHARE_READ or FILE_SHARE_WRITE,

    nil, OPEN_EXISTING, SECURITY_SQOS_PRESENT or SECURITY_ANONYMOUS, 0);

{$else}

    0, {$ifdef NOSECURITYFORNAMEDPIPECLIENTS}nil{$else}@fPipeSecurityAttributes{$endif},

    OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL or FILE_FLAG_OVERLAPPED, 0);

{$endif}

end;

begin

  {$ifdef WITHLOG}

  Log := fLogClass.Enter(self);

  {$endif}

{$ifdef ANONYMOUSNAMEDPIPE}

  if not ImpersonateAnonymousToken(GetCurrentThread) then

     raise Exception.Create('ImpersonateAnonymousToken');

  try

{$else}

  {$ifndef NOSECURITYFORNAMEDPIPECLIENTS}

  InitializeSecurity(fPipeSecurityAttributes,fPipeSecurityDescriptor);

  {$endif}

{$endif}

  StartTime64 := GetTickCount64;

  CreatePipe;

  while (Pipe=INVALID_HANDLE_VALUE) and (GetLastError=ERROR_FILE_NOT_FOUND) do begin

    SleepHiRes(10); // wait for TSQLRestServerNamedPipe.EngineExecute to be reached

    CreatePipe;

    if (Pipe<>INVALID_HANDLE_VALUE) or (GetTickCount64>StartTime64+500) then

      break;

  end;

  StartTime64 := GetTickCount64;

  if (Pipe=INVALID_HANDLE_VALUE) and (GetLastError=ERROR_PIPE_BUSY) then

    InternalLog('Busy % -> retry',[fPipeName],sllDebug);

    repeat

      SleepHiRes(10);

      if WaitNamedPipe(pointer(fPipeName),50) then begin

        CreatePipe;

        if GetLastError<>ERROR_PIPE_BUSY then

          break;

      end;

    until GetTickCount64>StartTime64+2000;

  if Pipe=INVALID_HANDLE_VALUE then begin

    InternalLog('when connecting to % after % ms',

      [fPipeName,GetTickCount64-StartTime64],sllLastError);

    exit;

  end;

{$ifdef ANONYMOUSNAMEDPIPE}

  finally

    RevertToSelf; // we just needed to be anonymous during pipe connection

  end;

{$endif}

  InternalLog('Connected to %',[fPipeName],sllDebug);

  fServerPipe := Pipe;

end;

begin

  if fServerPipe<>0 then begin

    result := true;

    exit; // only reconnect if forced by InternalClose call or at first access

  end;

  InternalCreateClientPipe; // local sub-procedure to reduce stack overhead

  result := fServerPipe<>0;

end;



procedure TSQLRestClientURINamedPipe.InternalClose;

begin

  if fServerPipe<>0 then begin   // inherited; may use pipe -> close after

    WriteString(fServerPipe,''); // send integer=0 -> force server disconnect

    FileClose(fServerPipe);

  end;

end;



procedure TSQLRestClientURINamedPipe.InternalURI(var Call: TSQLRestURIParams);

var Card: cardinal;

{.$define TSQLRestClientURIDll_TIMEOUT} // to be tried over slow networks if errors

    {$ifdef TSQLRestClientURIDll_TIMEOUT}

    i: integer;

    {$endif}

    {$ifdef WITHLOG}

    Log: ISynLog;

    {$endif}

begin

  {$ifdef WITHLOG}

  Log := fLogClass.Enter(self);

  {$endif}

  Call.OutStatus := HTML_NOTIMPLEMENTED; // 501 (no valid application or library)

  fSafe.Enter;

  try

    if InternalCheckOpen then

    try

      Card := MAGIC_SYN; // magic word

      if FileWrite(fServerPipe,Card,4)<>4 then begin

        SleepHiRes(0);

        WaitNamedPipe(pointer(fPipeName),200);

        if FileWrite(fServerPipe,Card,4)<>4 then begin // pipe may be broken

          SleepHiRes(10);

          FileClose(fServerPipe);

          fServerPipe := 0;

          if not InternalCheckOpen then // recreate connection

            exit;

          if (fServerPipe=Invalid_Handle_Value) or

             (FileWrite(fServerPipe,Card,4)<>4) then begin

            Card := GetLastError;

            InternalLog('reconnecting to %',[fPipeName],sllLastError);

            if fServerPipe<>Invalid_Handle_Value then

              FileClose(fServerPipe);

            fServerPipe := 0;

            exit; // no existing pipe

          end;

        end;

      end;

      // send the request

      WriteString(fServerPipe,Call.Url);

      WriteString(fServerPipe,Call.Method);

      WriteString(fServerPipe,Call.InHead);

      WriteString(fServerPipe,Call.InBody);

      FlushFileBuffers(fServerPipe);

      // receive the answer

{$ifdef TSQLRestClientURIDll_TIMEOUT}

      for i := 0 to 25 do // wait up to 325 ms

        if PeekNamedPipe(fServerPipe,nil,0,nil,@Card,nil) and

           (Card>=sizeof(Int64)) then begin

          FileRead(fServerPipe,Call.OutStatus,sizeof(cardinal));

          FileRead(fServerPipe,Call.OutInternalState,sizeof(cardinal));

          Call.OutHead := ReadString(fServerPipe);

          Call.OutBody := ReadString(fServerPipe);

          exit;

        end else

        SleepHiRes(i);

      Call.OutStatus := HTML_TIMEOUT; // 408 Request Timeout Error

{$else}

      if FileRead(fServerPipe,Call.OutStatus,sizeof(cardinal))=sizeof(cardinal) then begin

        // FileRead() waits till response arrived (or pipe is broken)

        FileRead(fServerPipe,Call.OutInternalState,sizeof(cardinal));

        Call.OutHead := ReadString(fServerPipe);

        Call.OutBody := ReadString(fServerPipe);

      end else

        Call.OutStatus := HTML_NOTFOUND;

{$endif}

     except

       on E: Exception do begin // error in ReadString()

         InternalLog('% for PipeName=%',[E,fPipeName],sllLastError);

         Call.OutStatus := HTML_NOTIMPLEMENTED; // 501 (no valid application or library)

         WriteString(fServerPipe,''); // try to notify the server of client logout

         FileClose(fServerPipe);

         fServerPipe := 0;

       end;

     end;

  finally

    fSafe.Leave;

  end;

  with Call do

    InternalLog('% % status=% state=%',[method,url,OutStatus,OutInternalState],sllClient);

end;



{$endif MSWINDOWS}





{ TSQLRestServerMonitor }



constructor TSQLRestServerMonitor.Create(aServer: TSQLRestServer);

begin

  if aServer=nil then

    raise EORMException.CreateUTF8('%.Create(nil)',[self]);

  inherited Create(aServer.Model.Root);

  fServer := aServer;

  SetLength(fPerTable[false],length(aServer.Model.Tables));

  SetLength(fPerTable[true],length(aServer.Model.Tables));

  fStartDate := NowUTCToString;

end;



destructor TSQLRestServerMonitor.Destroy;

begin

  ObjArrayClear(fPerTable[false]);

  ObjArrayClear(fPerTable[true]);

  inherited;

end;



procedure TSQLRestServerMonitor.ProcessSuccess(IsOutcomingFile: boolean);

begin

  EnterCriticalSection(fLock);

  try

    inc(fSuccess);

    if IsOutcomingFile then

      inc(fOutcomingFiles);

    Changed;

  finally

    LeaveCriticalSection(fLock);

  end;

end;



procedure TSQLRestServerMonitor.NotifyORM(aMethod: TSQLURIMethod);

begin

  EnterCriticalSection(fLock);

  try

    case aMethod of

    mGET,mLOCK: inc(fRead);

    mPOST:      inc(fCreated);

    mPUT:       inc(fUpdated);

    mDELETE:    inc(fDeleted);

    end;

    Changed;

  finally

    LeaveCriticalSection(fLock);

  end;

end;



procedure TSQLRestServerMonitor.NotifyORMTable(TableIndex, DataSize: integer;

  Write: boolean; const MicroSecondsElapsed: QWord);

const RW: array[boolean] of RawUTF8 = ('.read','.write');

var st: TSynMonitorWithSize;

begin

  if TableIndex<0 then

    exit;

  EnterCriticalSection(fLock);

  try

    if TableIndex>=length(fPerTable[Write]) then

      // tables may have been added after Create()

      SetLength(fPerTable[Write],TableIndex+1);

    if fPerTable[Write,TableIndex]=nil then

      fPerTable[Write,TableIndex] := TSynMonitorWithSize.Create(

        fServer.Model.TableProps[TableIndex].Props.SQLTableName+RW[Write]);

    st := fPerTable[Write,TableIndex];

    st.FromExternalMicroSeconds(MicroSecondsElapsed);

    st.AddSize(DataSize);

    if fServer.fStatUsage<>nil then

      fServer.fStatUsage.Modified(st,[]);

  finally

    LeaveCriticalSection(fLock);

  end;

end;



function TSQLRestServerMonitor.NotifyThreadCount(delta: integer): integer;

begin

  EnterCriticalSection(fLock);

  try

    inc(fCurrentThreadCount,delta);

    result := fCurrentThreadCount;

    if delta<>0 then

      Changed;

  finally

    LeaveCriticalSection(fLock);

  end;

end;



{ TSQLMonitorUsage }



const

  SQLMONITORSHIFT = 16;



function TSQLMonitorUsage.GetUsageID: integer;

begin

  result := fID shr SQLMONITORSHIFT;

end;



procedure TSQLMonitorUsage.SetUsageID(Value: integer);

begin

  fID := (Int64(Value) shl SQLMONITORSHIFT) or Int64(fProcess);

end;



{ TSynMonitorUsageRest }



constructor TSynMonitorUsageRest.Create(aStorage: TSQLRest;

  aProcessID: TSynUniqueIdentifierProcess; aStoredClass: TSQLMonitorUsageClass);

var g: TSynMonitorUsageGranularity;

begin

  if aStorage=nil then

    raise ESynException.CreateUTF8('%.Create(nil)',[self]);

  if aStoredClass=nil then

    fStoredClass := TSQLMonitorUsage else

    fStoredClass := aStoredClass;

  fStorage := aStorage;

  for g := low(fStoredCache) to high(fStoredCache) do

    fStoredCache[g] := fStoredClass.Create;

  fProcessID := aProcessID;

  {$ifdef WITHLOG}

  fLog := fStorage.LogFamily;

  {$endif}

  inherited Create;

end;



destructor TSynMonitorUsageRest.Destroy;

var g: TSynMonitorUsageGranularity;

begin

  inherited Destroy; // would save pending changes

  for g := low(fStoredCache) to high(fStoredCache) do

    fStoredCache[g].Free;

end;



function TSynMonitorUsageRest.LoadDB(ID: integer; Gran: TSynMonitorUsageGranularity;

  out Track: variant): boolean;

var recid: TID;

    rec: TSQLMonitorUsage;

begin

  if (ID=0) or (Gran<Low(fStoredCache)) then begin

    result := false;

    exit;

  end;

  rec := fStoredCache[Gran];

  recid := (Int64(ID) shl SQLMONITORSHIFT) or Int64(fProcessID);

  if rec.IDValue=recid then

    result := true else

  if fStorage.Retrieve(recid,rec) then begin // may use REST cache

    Track := rec.Info;

    if rec.Gran=mugHour then

      fComment := rec.Comment;

    if rec.Process<>fProcessID then

      fLog.SynLog.Log(sllWarning,'%.LoadDB(%,%) received Process=%, expected %',

        [ClassType,ID,ToText(Gran)^,rec.Process,fProcessID]);

    result := true;

  end else begin

    rec.ClearProperties;

    result := false;

  end;

end;



function TSynMonitorUsageRest.SaveDB(ID: integer; const Track: variant;

  Gran: TSynMonitorUsageGranularity): boolean;

var update: boolean;

    recid: TID;

    rec: TSQLMonitorUsage;

begin

  if (ID=0) or (Gran<Low(fStoredCache)) then begin

    result := false;

    exit;

  end;

  rec := fStoredCache[Gran];

  recid := (Int64(ID) shl SQLMONITORSHIFT) or Int64(fProcessID);

  if rec.IDValue=recid then // already available

    update := true else begin

    update := fStorage.Retrieve(recid,rec); // may use REST cache

    rec.IDValue := recid;

  end;

  rec.Gran := Gran;

  rec.Process := fProcessID;

  if Gran=mugHour then

    rec.Comment := fComment;

  rec.Info := Track;

  if update then

    result := fStorage.Update(rec) else

    result := fStorage.Add(rec,true,true)=recid;

end;





{ TSQLRestServerURI }



function TSQLRestServerURI.GetURI: TSQLRestServerURIString;

begin

  result := Address;

  if Port<>'' then

    result := result+':'+Port;

  if Root<>'' then

    result := result+'/'+Root;

end;



procedure TSQLRestServerURI.SetURI(const Value: TSQLRestServerURIString);

begin

  Split(Value,':',Address,Port);

  if Port<>'' then

    Split(Port,'/',Port,Root) else

    Split(Address,'/',Address,Root);

end;



function TSQLRestServerURI.Equals(const other: TSQLRestServerURI): boolean;

begin

  result := IdemPropNameU(Address,other.Address) and

            IdemPropNameU(Port,other.Port) and

            IdemPropNameU(Root,other.Root);

end;





{ TServicesPublishedInterfacesList }



constructor TServicesPublishedInterfacesList.Create(aTimeoutMS: integer);

begin

  inherited Create;

  fTimeOut := aTimeoutMS;

  fDynArray.Init(TypeInfo(TServicesPublishedInterfacesDynArray),List,@Count);

  fDynArrayTimeoutTix.Init(TypeInfo(TInt64DynArray),fTimeoutTix,@fTimeoutTixCount);

end;



function TServicesPublishedInterfacesList.FindURI(

  const aPublicURI: TSQLRestServerURI): integer;

var tix: Int64;

begin

  tix := GetTickCount64;

  Safe.Lock;

  try

    for result := 0 to Count-1 do

      if List[result].PublicURI.Equals(aPublicURI) then

        if (fTimeOut=0) or (fTimeoutTix[result]<tix) then

          exit;

    result := -1;

  finally

    Safe.UnLock;

  end;

end;



function TServicesPublishedInterfacesList.FindService(

  const aServiceName: RawUTF8): TSQLRestServerURIDynArray;

var i,n: integer;

    tix: Int64;

begin

  tix := GetTickCount64;

  result := nil;

  Safe.Lock;

  try

    n := 0;

    for i := Count-1 downto 0 do // downwards to return the latest first

      if FindRawUTF8(List[i].Names,length(List[i].Names),aServiceName,true)>=0 then

        if (fTimeOut=0) or (fTimeoutTix[i]<tix) then begin

          SetLength(result,n+1);

          result[n] := List[i].PublicURI;

          inc(n);

        end;

  finally

    Safe.UnLock;

  end;

end;



function TServicesPublishedInterfacesList.FindServiceAll(

  const aServiceName: RawUTF8): TSQLRestServerURIStringDynArray;

var i,n: integer;

    tix: Int64;

begin

  tix := GetTickCount64;

  result := nil;

  n := 0;

  Safe.Lock;

  try

    for i := Count-1 downto 0 do // downwards to return the latest first

      if FindRawUTF8(List[i].Names,length(List[i].Names),aServiceName,true)>=0 then

        if (fTimeOut=0) or (fTimeoutTix[i]<tix) then

          AddRawUTF8(TRawUTF8DynArray(result),n,List[i].PublicURI.URI);

  finally

    Safe.UnLock;

  end;

  SetLength(result,n);

end;



procedure TServicesPublishedInterfacesList.FindServiceAll(

  const aServiceName: RawUTF8; aWriter: TTextWriter);

var i: integer;

    tix: Int64;

begin

  tix := GetTickCount64;

  Safe.Lock;

  try

    aWriter.Add('[');

    if aServiceName='*' then begin

      // for RegisterFromServer: return all TServicesPublishedInterfaces

      for i := 0 to Count-1 do

        with List[i] do

          if (fTimeOut=0) or (fTimeoutTix[i]<tix) then begin

            aWriter.AddRecordJSON(List[i],TypeInfo(TServicesPublishedInterfaces));

            aWriter.Add(',');

          end;

    end else // from SQLRestClientURI.ServiceRetrieveAssociated

      // search matching (and non deprecated) services as TSQLRestServerURI

      for i := Count-1 downto 0 do // downwards to return the latest first

        with List[i] do

          if FindRawUTF8(Names,length(Names),aServiceName,true)>=0 then

            if (fTimeOut=0) or (fTimeoutTix[i]<tix) then begin

              aWriter.AddRecordJSON(PublicURI,TypeInfo(TSQLRestServerURI));

              aWriter.Add(',');

            end;

    aWriter.CancelLastComma;

    aWriter.Add(']');

  finally

    Safe.UnLock;

  end;

end;



function TServicesPublishedInterfacesList.RegisterFromServer(Client: TSQLRestClientURI): boolean;

var json: RawUTF8;

begin

  result := Client.CallBackGet('stat',['findservice','*'],json)=HTML_SUCCESS;

  if result and (json<>'') then

    RegisterFromServerJSON(json);

end;



procedure TServicesPublishedInterfacesList.RegisterFromServerJSON(

  var PublishedJson: RawUTF8);

var tix: Int64;

    i: integer;

begin

  Safe.Lock;

  try

    fDynArray.LoadFromJSON(pointer(PublishedJson));

    fDynArrayTimeoutTix.Count := Count;

    tix := GetTickCount64;

    if fTimeout=0 then

      inc(tix,maxInt) else

      inc(tix,fTimeout);

    for i := 0 to Count-1 do

      fTimeoutTix[i] := tix;

  finally

    Safe.UnLock;

  end;

end;



procedure TServicesPublishedInterfacesList.RegisterFromClientJSON(

  var PublishedJson: RawUTF8);

var i: integer;

    nfo: TServicesPublishedInterfaces;

    crc: cardinal;

    tix: Int64;

    P: PUTF8Char;

begin

  if PublishedJson='' then

    exit;

  crc := crc32c(0,pointer(PublishedJson),length(PublishedJson));

  if (self=nil) or ((fLastPublishedJson<>0) and (crc=fLastPublishedJson)) then

    exit; // rough but working good in practice, when similar _contract_ 

  P := Pointer(PublishedJson);

  if P^='[' then

    inc(P); // when transmitted as [params] in a _contract_ HTTP body content

  if (RecordLoadJSON(nfo,P,TypeInfo(TServicesPublishedInterfaces))=nil) or

     (nfo.PublicURI.Address='') then

    exit; // invalid supplied JSON content

  Safe.Lock;

  try // store so that the latest updated version is always at the end

    for i := 0 to Count-1 do

      if List[i].PublicURI.Equals(nfo.PublicURI) then begin // ignore Timeout

        fDynArray.Delete(i);

        fDynArrayTimeoutTix.Delete(i);

        break;

      end;

    if nfo.Names<>nil then begin

      fDynArray.Add(nfo);

      tix := GetTickCount64;

      if fTimeout=0 then

        inc(tix,maxInt) else

        inc(tix,fTimeout); 

      fDynArrayTimeoutTix.Add(tix);

    end;

    fLastPublishedJson := crc;

  finally

    Safe.UnLock;

  end;

end;





{ TSQLRestStorageRecordBased }



function TSQLRestStorageRecordBased.EngineAdd(TableModelIndex: integer;

  const SentData: RawUTF8): TID;

var Rec: TSQLRecord;

begin

  result := 0; // mark error

  if (TableModelIndex<0) or (Model.Tables[TableModelIndex]<>fStoredClass) then

    exit;

  Rec := fStoredClass.Create;

  try

    Rec.FillFrom(SentData);

    StorageLock(true);

    try

      result := AddOne(Rec,Rec.fID>0,SentData);

    finally

      StorageUnLock;

    end;

  finally

    if result<=0 then

      Rec.Free; // on success, Rec is owned by fValue: TObjectList

  end;

end;



function TSQLRestStorageRecordBased.EngineUpdate(TableModelIndex: integer; ID: TID;

  const SentData: RawUTF8): boolean;

var Rec: TSQLRecord;

begin

  // this implementation won't handle partial fields update (e.g. BatchUpdate

  // after FillPrepare) - but TSQLRestStorageInMemory.EngineUpdate will

  if (ID<=0) or (TableModelIndex<0) or

     (Model.Tables[TableModelIndex]<>fStoredClass) then begin

    result := false; // mark error

    exit;

  end;

  StorageLock(true);

  try

    Rec := fStoredClass.Create;

    try

      Rec.FillFrom(SentData);

      Rec.fID := ID;

      result := UpdateOne(Rec,SentData);

    finally

      Rec.Free;

    end;

  finally

    StorageUnLock;

  end;

end;



function TSQLRestStorageRecordBased.UpdateOne(ID: TID;

  const Values: TSQLVarDynArray): boolean;

var Rec: TSQLRecord;

begin

  if (ID<=0) then begin

    result := false; // mark error

    exit;

  end;

  StorageLock(true);

  try

    Rec := fStoredClass.Create;

    try

      Rec.SetFieldSQLVars(Values);

      Rec.fID := ID;

      result := UpdateOne(Rec,Rec.GetJSONValues(true,False,soUpdate));

    finally

      Rec.Free;

    end;

  finally

    StorageUnLock;

  end;

end;





{ TSQLRestStorageInMemory }



constructor TSQLRestStorageInMemory.Create(aClass: TSQLRecordClass; aServer: TSQLRestServer;

  const aFileName: TFileName = ''; aBinaryFile: boolean=false);

var F: integer;

begin

  inherited Create(aClass,aServer);

  if (fStoredClassProps<>nil) and (fStoredClassProps.Kind in INSERT_WITH_ID) then

    raise EModelException.CreateUTF8('%.Create: % virtual table can''t be static',

      [self,aClass]);

  fFileName := aFileName;

  fBinaryFile := aBinaryFile;

  fValue := TObjectList.Create;

  fSearchRec := fStoredClass.Create;

  fIDSorted := true; // sorted by design of this class (may change in children)

  if (ClassType<>TSQLRestStorageInMemory) and (fStoredClassProps<>nil) then

    with fStoredClassProps do begin // used by AdaptSQLForEngineList() method

      fBasicUpperSQLSelect[false] := SynCommons.UpperCase(SQL.SelectAllWithRowID);

      SetLength(fBasicUpperSQLSelect[false],length(fBasicUpperSQLSelect[false])-1); // trim right ';'

      fBasicUpperSQLSelect[true] := StringReplaceAll(fBasicUpperSQLSelect[false],' ROWID,',' ID,');

    end;

  if not IsZero(fIsUnique) then begin

    fUniqueFields := TObjectList.Create;

    with fStoredClassRecordProps do

    for F := 0 to Fields.Count-1 do

      if F in fIsUnique then

        // CaseInsensitive=true just like in SQlite3 (but slower)

        fUniqueFields.Add(TListFieldHash.Create(fValue,Fields.List[F],true));

  end;

  ReloadFromFile;

end;



function TSQLRecordCompare(Item1,Item2: Pointer): integer;

var tmp: Int64;

begin // we assume Item1<>nil and Item2<>nil in fValue[]

  tmp := TSQLRecord(Item1).fID-TSQLRecord(Item2).fID;

  if tmp<0 then

    result := -1 else

  if tmp>0 then

    result := 1 else

    result := 0;

end;



function TSQLRestStorageInMemory.AddOne(Rec: TSQLRecord; ForceID: boolean;

  const SentData: RawUTF8): TID;

var ndx,i: integer;

    lastID: TID;

    needSort: boolean;

    hash: TListFieldHash;

begin

  if (self=nil) or (Rec=nil) then begin

    result := -1; // mark error

    exit;

  end;

  if fValue.Count=0 then

    lastID := 0 else // default ID for a void table

    lastID := TSQLRecord(fValue[fValue.Count-1]).fID; // ID in increasing order

  needSort := false;

  if ForceID then begin // check forced ID

    if Rec.fID<=0 then

      raise EORMException.CreateUTF8('%.AddOne(%.ForceID=0)',[self,Rec]);

    if Rec.fID<=lastID then begin

      if fUniqueFields<>nil then begin

        for i := 0 to fUniqueFields.Count-1 do begin

          hash := fUniqueFields.List[i];

          ndx := hash.Scan(Rec,fValue.Count); // O(n) search to avoid hashing

          if ndx>=0 then begin

            InternalLog('%.AddOne: Duplicated field "%" value for % and %',

              [ClassType,hash.Field.Name,Rec,TSQLRecord(fValue.List[ndx])],sllTrace);

            result := 0; // duplicate unique fields -> error

            exit;

          end;

          hash.Invalidate;

        end;

        InternalLog('%.AddOne(%.ForceID=%<=lastID=%) -> UniqueFields[].Invalidate',

          [ClassType,Rec.ClassType,Rec.fID,lastID],sllTrace);

      end;

      if IDToIndex(Rec.fID)>=0 then

        raise EORMException.CreateUTF8('%.AddOne(%.ForceID=%) already existing',

          [self,Rec,Rec.fID]);

      needSort := true; // brutal, but working

    end;

    result := Rec.fID;

  end else begin // not ForceID -> compute new ID

    result := lastID+1;

    Rec.fID := result;

  end;

  ndx := fValue.Add(Rec);

  if needSort then

    fValue.Sort(TSQLRecordCompare) else // fUniqueFields[] already checked

    if fUniqueFields<>nil then

      for i := 0 to fUniqueFields.Count-1 do // perform hash of List[Count-1]

      if not TListFieldHash(fUniqueFields.List[i]).EnsureJustAddedNotDuplicated then begin

        InternalLog('%.AddOne: Duplicated field "%" value for %',

          [ClassType,TListFieldHash(fUniqueFields.List[i]).Field.Name,Rec],sllTrace);

        result := 0; // duplicate unique fields -> error

        fValue.List[ndx] := nil; // avoid GPF within Delete()

        fValue.Delete(ndx);

        exit;

      end;

  fModified := true;

  if Owner<>nil then

    Owner.InternalUpdateEvent(seAdd,fStoredClassProps.TableIndex,result,SentData,nil);

end;



function TSQLRestStorageInMemory.UniqueFieldsUpdateOK(aRec: TSQLRecord; aUpdateIndex: integer): boolean;

var i,ndx: integer;

begin

  if fUniqueFields<>nil then begin

    result := false;

    with fUniqueFields do

      for i := 0 to Count-1 do begin

        ndx := TListFieldHash(List[i]).Find(aRec);

        if (ndx>=0) and (ndx<>aUpdateIndex) then

          exit; // duplicate value found at another entry

      end;

  end;

  result := true;

end;



function TSQLRestStorageInMemory.UniqueFieldHash(aFieldIndex: integer): TListFieldHash;

var i: integer;

begin

  if (fUniqueFields<>nil) and

     (cardinal(aFieldIndex)<cardinal(fStoredClassRecordProps.Fields.Count)) then

    with fUniqueFields do

      for i := 0 to Count-1 do begin

        result := List[i];

        if result.FieldIndex=aFieldIndex then

          exit;

      end;

  result := nil;

end;



function TSQLRestStorageInMemory.EngineDelete(TableModelIndex: integer; ID: TID): boolean;

begin

  if (self=nil) or (ID<=0) or (TableModelIndex<0) or

     (Model.Tables[TableModelIndex]<>fStoredClass) then

    result := false else begin

    StorageLock(True);

    try

      result := DeleteOne(IDToIndex(ID));

    finally

      StorageUnLock;

    end;

  end;

end;



function TSQLRestStorageInMemory.DeleteOne(aIndex: integer): boolean;

var F: integer;

begin

  if cardinal(aIndex)>=cardinal(fValue.Count) then

    result := false else begin

    if fUniqueFields<>nil then

      for F := 0 to fUniqueFields.Count-1 do

        TListFieldHash(fUniqueFields.List[F]).Invalidate;

    if Owner<>nil then // notify BEFORE deletion

       Owner.InternalUpdateEvent(seDelete,fStoredClassProps.TableIndex,

         TSQLRecord(fValue.List[aIndex]).fID,'',nil);

    fValue.Delete(aIndex);  // TObjectList.Delete() will Free record

    fModified := true;

    result := true;

  end;

end;



function TSQLRestStorageInMemory.EngineDeleteWhere(TableModelIndex: Integer;

  const SQLWhere: RawUTF8; const IDs: TIDDynArray): boolean;

var ndx: TIntegerDynArray;

    n,i: integer;

begin // RecordCanBeUpdated() has already been called

  result := false;

  n := length(IDs);

  SetLength(ndx,n);

  dec(n);

  StorageLock(True);

  try

    for i := 0 to n do begin

      ndx[i] := IDToIndex(IDs[i]);

      if ndx[i]<0 then

        exit;

    end;

    if fUniqueFields<>nil then

      for i := 0 to fUniqueFields.Count-1 do

        TListFieldHash(fUniqueFields.List[i]).Invalidate;

    if Owner<>nil then

      for i := 0 to n do

        Owner.InternalUpdateEvent(seDelete,fStoredClassProps.TableIndex,IDs[i],'',nil); // notify BEFORE deletion

    QuickSortInteger(pointer(ndx),0,n); // deletion a bit faster in reverse order

    for i := n downto 0 do

      fValue.Delete(ndx[i]);

    fModified := true;

    result := true;

  finally

    StorageUnLock;

  end;

end;



function TSQLRestStorageInMemory.EngineExecute(const aSQL: RawUTF8): boolean;

begin

  result := false; // there is no SQL engine with this class

end;



destructor TSQLRestStorageInMemory.Destroy;

begin

  UpdateFile;

  fValue.Free; // TObjectList.Destroy will free all stored TSQLRecord instances

  fUniqueFields.Free;

  fSearchRec.Free;

  inherited Destroy;

end;



function TSQLRestStorageInMemory.GetCount: integer;

begin

  if Self<>nil then

    result := fValue.Count else

    result := 0;

end;



function TSQLRestStorageInMemory.GetID(Index: integer): TID;

begin

  with fValue do

    if (self=nil) or (cardinal(Index)>=cardinal(Count)) then

      result := 0 else

      result := TSQLRecord(List[Index]).fID;

end;



function TSQLRestStorageInMemory.GetItem(Index: integer): TSQLRecord;

begin

  if self<>nil then

    with fValue do

      if cardinal(Index)>=cardinal(Count) then

        raise EORMException.CreateUTF8('%.GetItem(%) out of range',[self,Index]) else

        result := List[Index] else

    result := nil;

end;



function TSQLRestStorageInMemory.GetListPtr: PPointerArray;

begin

  result := pointer(fValue.List);

end;



procedure TSQLRestStorageInMemory.GetJSONValuesEvent(aDest: pointer;

  aRec: TSQLRecord; aIndex: integer);

var W: TJSONSerializer absolute aDest;

begin

  aRec.GetJSONValues(W);

  W.Add(',');

end;



procedure TSQLRestStorageInMemory.AddIntegerDynArrayEvent(

  aDest: pointer; aRec: TSQLRecord; aIndex: integer);

var Ints: TList absolute aDest;

begin

  Ints.Add(pointer(aIndex));

end;



procedure TSQLRestStorageInMemory.DoNothingEvent(

  aDest: pointer; aRec: TSQLRecord; aIndex: integer);

begin

end;



function TSQLRestStorageInMemory.AdaptSQLForEngineList(var SQL: RawUTF8): boolean;

var P: PUTF8Char;

    Prop: RawUTF8;

    WithoutRowID: boolean;

begin

  result := inherited AdaptSQLForEngineList(SQL);

  if result then

    exit; // 'select * from table'

  if IdemPropNameU(fBasicSQLCount,SQL) or

     IdemPropNameU(fBasicSQLHasRows[false],SQL) or

     IdemPropNameU(fBasicSQLHasRows[true],SQL) then begin

    result := true;

    exit; // 'select count(*) from table' will be handled as static

  end;

  if fBasicUpperSQLSelect[false]='' then

    exit;

  if IdemPChar(pointer(SQL),pointer(fBasicUpperSQLSelect[false])) then

    WithoutRowID := false else

    if IdemPChar(pointer(SQL),pointer(fBasicUpperSQLSelect[true])) then

      WithoutRowID := true else

      exit;

  P := pointer(SQL);

  inc(P,length(fBasicUpperSQLSelect[WithoutRowID]));

  if P^ in [#0,';'] then begin

    result := true; // properly ended the WHERE clause as 'SELECT * FROM table'

    exit;

  end;

  P := GotoNextNotSpace(P);

  if not IdemPChar(P,'WHERE ') then begin

    if IdemPChar(P,'LIMIT ') then

      result := true;

    exit;

  end;

  P := GotoNextNotSpace(P+6);

  Prop := GetNextItem(P,'=');

  if (P=nil) or (fStoredClassRecordProps.Fields.IndexByName(Prop)<0) then

    exit;

  if PWord(P)^=ord(':')+ord('(') shl 8 then

    inc(P,2); // +2 to ignore :(...): parameter

  if P^ in ['''','"'] then begin

    P := GotoEndOfQuotedString(P);

    if not (P^ in ['''','"']) then

      exit;

  end;

  repeat inc(P) until P^ in [#0..' ',';',')']; // go to end of value

  if PWord(P)^=ord(')')+ord(':')shl 8 then

    inc(P,2); // ignore :(...): parameter

  P := GotoNextNotSpace(P);

  if (P^ in [#0,';']) or IdemPChar(P,'LIMIT ') then

    result := true; // properly ended the WHERE clause as 'FIELDNAME=value'

end;



function TSQLRestStorageInMemory.FindWhereEqual(const WhereFieldName, WhereValue: RawUTF8;

  OnFind: TFindWhereEqualEvent; Dest: pointer; FoundLimit,FoundOffset: integer;

  CaseInsensitive: boolean): PtrInt;

var WhereFieldIndex: integer;

begin

  result := 0;

  if (Self=nil) or not Assigned(OnFind) then

    exit;

  if IsRowID(pointer(WhereFieldName)) then

    WhereFieldIndex := 0 else begin

    WhereFieldIndex := fStoredClassRecordProps.Fields.IndexByName(pointer(WhereFieldName));

    if WhereFieldIndex<0 then

      exit;

    inc(WhereFieldIndex); // FindWhereEqual() expects index = RTTI+1

  end;

  result := FindWhereEqual(WhereFieldIndex,WhereValue,Onfind,Dest,

    FoundLimit,FoundOffset,CaseInsensitive);

end;



function TSQLRestStorageInMemory.FindWhereEqual(WhereField: integer;

  const WhereValue: RawUTF8; OnFind: TFindWhereEqualEvent; Dest: pointer;

  FoundLimit,FoundOffset: integer; CaseInsensitive: boolean): PtrInt;

var i, ndx, i32: integer;

    i64: Int64;

    err, currentRow: integer;

    P: TSQLPropInfo;

    nfo: PPropInfo;

    Hash: TListFieldHash;

    offs: PtrUInt;

    item: PPointer;



  procedure FoundOne;

  begin

    if FoundOffset>0 then begin // omit first FoundOffset rows

      inc(currentRow);

      if currentRow>FoundOffset then

        FoundOffset := 0 else

        exit;

    end;

    if Assigned(OnFind) then

      OnFind(Dest,TSQLRecord(item^),(PtrUInt(item)-PtrUInt(fValue.List)) shr POINTERSHR);

    inc(result);

  end;



begin

  result := 0;

  if fValue.Count=0 then

    exit;

  if FoundLimit<=0 then

    FoundLimit := maxInt;

  if WhereField=SYNTABLESTATEMENTWHEREID then begin

    if FoundOffset<=0 then begin // omit first FoundOffset rows

      i64 := GetInt64(pointer(WhereValue),err);

      if (err=0) and (i64>0) then begin

        ndx := IDToIndex(i64); // use fast binary search

        if ndx>=0 then begin

          if Assigned(OnFind) then

            OnFind(Dest,TSQLRecord(fValue.List[ndx]),ndx);

          inc(result);

        end;

      end;

    end;

    exit;

  end else

  if cardinal(WhereField)>cardinal(fStoredClassRecordProps.Fields.Count) then

    exit;

  dec(WhereField); // WHERE WhereField=WhereValue (WhereField=RTTIfield+1)

  P := fStoredClassRecordProps.Fields.List[WhereField];

  if not (P.SQLFieldType in COPIABLE_FIELDS) then

    exit; // nothing to search (e.g. sftUnknown or sftMany)

  // use fUniqueFields[] hash array for O(1) search if available

  Hash := UniqueFieldHash(WhereField);

  if Hash<>nil then begin

    if FoundOffset<=0 then begin // omit first FoundOffset rows, for ID unique field

      P.SetValueVar(fSearchRec,WhereValue,false);

      ndx := Hash.Find(fSearchRec);

      if ndx>=0 then begin

        if Assigned(OnFind) then

          OnFind(Dest,fValue.List[ndx],ndx);

        inc(result);

      end;

    end;

    exit;

  end;

  // full scan optimized search for a specified value

  currentRow := 0;

  item := pointer(fValue.List);

  if P.InheritsFrom(TSQLPropInfoRTTIInt32) then begin

    // optimized search for 8/16/32-bit Integer values 

    i32 := GetInteger(pointer(WhereValue),err);

    if err<>0 then

      exit;

    nfo := TSQLPropInfoRTTI(P).PropInfo;

    offs := TSQLPropInfoRTTI(P).fGetterIsFieldPropOffset;

    if (offs<>0) and {$ifndef CPU64}(nfo^.PropType^.Kind=tkClass) or{$endif}

       ((nfo^.PropType^.Kind=tkInteger)and(nfo^.PropType^.OrdType=otSLong)) then begin

      // optimized version for fast retrieval of signed 32-bit Integer field value

      for i := 1 to fValue.Count do begin

        if PInteger(PPtrUInt(item)^+offs)^=i32 then begin

          FoundOne;

          if result>=FoundLimit then

            exit;

        end;

        inc(item);

      end;

    end else

    // 8-bit or 16-bit value, or there is a getter procedure -> use GetOrdProp()

    for i := 1 to fValue.Count do begin

      if nfo^.GetOrdProp(item^)=i32 then begin

        FoundOne;

        if result>=FoundLimit then

          exit;

      end;

      inc(item);

    end;

  end else

  if P.InheritsFrom(TSQLPropInfoRTTIInt64) then begin

    // stored as one 64-bit Integer value -> optimized search

    i64 := GetInt64(pointer(WhereValue),err);

    if err<>0 then

      exit;

    nfo := TSQLPropInfoRTTI(P).PropInfo;

    offs := TSQLPropInfoRTTI(P).fGetterIsFieldPropOffset;

    if offs<>0 then begin

      for i := 1 to fValue.Count do begin

        if PInt64(PPtrUInt(item)^+offs)^=i64 then begin

          FoundOne;

          if result>=FoundLimit then

            exit;

        end;

        inc(item);

      end;

    end else

    for i := 1 to fValue.Count do begin

      if nfo^.GetInt64Prop(item^)=i64 then begin

        FoundOne;

        if result>=FoundLimit then

          exit;

      end;

      inc(item);

    end;

  end else begin

    // generic search of any value, using fast CompareValue() overridden method

    P.SetValueVar(fSearchRec,WhereValue,false);

    for i := 1 to fValue.Count do begin

      if P.CompareValue(item^,fSearchRec,CaseInsensitive)=0 then begin

        FoundOne;

        if result>=FoundLimit then

          exit;

      end;

      inc(item);

    end;

  end;

end;



function TSQLRestStorageInMemory.FindMax(WhereField: integer; out max: Int64): boolean;

var list: PPointerArray;

    P: TSQLPropInfo;

    nfo: PPropInfo;

    i: integer;

    v: Int64;

begin

  result := false;

  max := low(Int64);

  if fValue.Count=0 then

    exit;

  list := pointer(fValue.List);

  if WhereField=SYNTABLESTATEMENTWHEREID then begin

    max := TSQLRecord(list[fValue.Count-1]).IDValue; // should be ordered

    result := true;

    exit;

  end;

  if cardinal(WhereField)>cardinal(fStoredClassRecordProps.Fields.Count) then

    exit;

  dec(WhereField); // WHERE WhereField=WhereValue (WhereField=RTTIfield+1)

  P := fStoredClassRecordProps.Fields.List[WhereField];

  if P.InheritsFrom(TSQLPropInfoRTTIInt32) then begin

    nfo := TSQLPropInfoRTTI(P).PropInfo;

    for i := 0 to fValue.Count-1 do begin

      v := nfo.GetOrdProp(list[i]);

      if v>max then

        max := v;

    end;

    result := true;

  end

  else if P.InheritsFrom(TSQLPropInfoRTTIInt64) then begin

    nfo := TSQLPropInfoRTTI(P).PropInfo;

    for i := 0 to fValue.Count-1 do begin

      v := nfo.GetInt64Prop(list[i]);

      if v>max then

        max := v;

    end;

    result := true;

  end;

end;



procedure TSQLRestStorageInMemory.ForEach(WillModifyContent: boolean;

  OnEachProcess: TFindWhereEqualEvent; Dest: pointer);

var i: integer;

begin

  if (self=nil) or (fValue.Count=0) or not Assigned(OnEachProcess) then

    exit;

  StorageLock(WillModifyContent);

  try

    for i := 0 to fValue.Count-1 do

      OnEachProcess(Dest,fValue.List[i],i);

  finally

    StorageUnLock;

  end;

end;



function TSQLRestStorageInMemory.GetJSONValues(Stream: TStream;

  Expand: boolean; Stmt: TSynTableStatement): PtrInt;

var ndx,KnownRowsCount: integer;

    {$ifndef NOVARIANTS}

    j: integer;

    id: Int64;

    {$endif}

    W: TJSONSerializer;

    IsNull: boolean;

    Prop: TSQLPropInfo;

    bits: TSQLFieldBits;

    withID: boolean;

label err;

begin // exact same format as TSQLTable.GetJSONValues()

  result := 0;

  if length(Stmt.Where)>1 then

    raise EORMException.CreateUTF8('%.GetJSONValues on % with Stmt.Where[]=%',

      [self,fStoredClass,length(Stmt.Where)]);

  if Stmt.Where=nil then // no WHERE statement -> get all rows -> set rows count

    if (Stmt.Limit>0) and (fValue.Count>Stmt.Limit) then

      KnownRowsCount := Stmt.Limit else

      KnownRowsCount := fValue.Count else

    KnownRowsCount := 0;

  Stmt.SelectFieldBits(bits,withID);

  W := fStoredClassRecordProps.CreateJSONWriter(Stream,Expand,withID,bits,KnownRowsCount);

  if W<>nil then

  try

    if Expand then

      W.Add('[');

    if Stmt.Where=nil then begin // no WHERE statement -> all rows

      for ndx := 0 to KnownRowsCount-1 do begin

        if Expand then

          W.AddCR; // for better readability

        TSQLRecord(fValue.List[ndx]).GetJSONValues(W);

        W.Add(',');

      end;

      result := KnownRowsCount;

    end else

    case Stmt.Where[0].Operator of

    opEqualTo:

      result := FindWhereEqual(Stmt.Where[0].Field,Stmt.Where[0].Value,

        GetJSONValuesEvent,W,Stmt.Limit,Stmt.Offset);

    {$ifndef NOVARIANTS}

    opIn:

      if (Stmt.Where[0].Field<>0) or // only handle ID IN (..) by now

         (Stmt.Offset>0) then

        goto err else

        with _Safe(Stmt.Where[0].ValueVariant)^ do

          for ndx := 0 to Count-1 do

            if VariantToInt64(Values[ndx],id) then begin

              j := IDToIndex(id);

              if j>=0 then begin

                TSQLRecord(fValue.List[j]).GetJSONValues(W);

                W.Add(',');

                inc(result);

                if (Stmt.Limit>0) and (result>=Stmt.Limit) then

                  break;

              end;

            end else

              goto err;

    {$endif}

    opIsNull, opIsNotNull:

      if Stmt.Where[0].Field>0 then begin

        Prop := fStoredClassRecordProps.Fields.List[Stmt.Where[0].Field-1];

        if Prop.InheritsFrom(TSQLPropInfoRTTIRawBlob) then begin

          IsNull := Stmt.Where[0].Operator=opIsNull;

          for ndx := 0 to fValue.Count-1 do

          if TSQLPropInfoRTTIRawBlob(Prop).IsNull(fValue.List[ndx])=IsNull then begin

            TSQLRecord(fValue.List[ndx]).GetJSONValues(W);

            W.Add(',');

            inc(result);

            if (Stmt.Limit>0) and (result>=Stmt.Limit) then

              break;

          end;

        end else

          goto err;

      end else

        goto err;

    else begin

err:  W.CancelAll;

      result := 0;

      exit;

    end;

    end;

    if (result=0) and W.Expand then begin

      // we want the field names at least, even with no data

      W.Expand := false; //  {"fieldCount":2,"values":["col1","col2"]}

      W.CancelAll;

      fStoredClassRecordProps.SetJSONWriterColumnNames(W,0);

    end;

    W.EndJSONObject(KnownRowsCount,result);

  finally

    W.Free;

  end;

end;



function TSQLRestStorageInMemory.IDToIndex(ID: TID): integer;

var L, R: integer;

    cmp: TID;

begin

  if self<>nil then

  with fValue do begin

    R := Count-1;

    if fIDSorted and (R>=8) then begin

      // IDs are sorted -> use fast binary search algorithm

      L := 0;

      repeat

        result := (L + R) shr 1;

        cmp := TSQLRecord(List[result]).fID-ID;

        if cmp=0 then

          exit;

        if cmp<0 then

          L := result + 1 else

          R := result - 1;

      until (L > R);

    end else

      // IDs are not sorted -> compare all from beginning to end

      for result := 0 to R do

        if TSQLRecord(List[result]).fID=ID then

          exit;

  end;

  result := -1;

end;



function TSQLRestStorageInMemory.EngineList(const SQL: RawUTF8;

  ForceAJAX: Boolean=false; ReturnedRowCount: PPtrInt=nil): RawUTF8;

// - GetJSONValues/FindWhereEqual will handle basic REST commands (not all SQL)

// only valid SQL command is "SELECT Field1,Field2 FROM Table WHERE ID=120;",

// i.e one Table SELECT with one optional "WHERE fieldname = value" statement

// - handle also basic "SELECT Count(*) FROM TableName;" SQL statement

// Note: this is sufficient for OneFieldValue() and MultiFieldValue() to work

var MS: TRawByteStringStream;

    ResCount: PtrInt;

    Stmt: TSynTableStatement;

    max: Int64;

procedure SetCount(aCount: integer);

begin

  FormatUTF8('[{"Count(*)":%}]'#$A,[aCount],result);

  ResCount := 1;

end;

begin

  result := '';

  ResCount := 0;

  StorageLock(false);

  try

    if IdemPropNameU(fBasicSQLCount,SQL) then

      SetCount(TableRowCount(fStoredClass)) else

    if IdemPropNameU(fBasicSQLHasRows[false],SQL) or

       IdemPropNameU(fBasicSQLHasRows[true],SQL) then

      if TableRowCount(fStoredClass)=0 then begin

        result := '{"fieldCount":1,"values":["RowID"]}'#$A;

        ResCount := 0;

      end else begin // return one row with fake ID=1

        result := '[{"RowID":1}]'#$A;

        ResCount := 1;

      end else begin

      Stmt := TSynTableStatement.Create(SQL,

        fStoredClassRecordProps.Fields.IndexByName,

        fStoredClassRecordProps.SimpleFieldsBits[soSelect]);

      try

        if (Stmt.SQLStatement='') or  // parsing failed

           (length(Stmt.Where)>1) or // only a SINGLE expression is allowed yet

           not IdemPropNameU(Stmt.TableName,fStoredClassRecordProps.SQLTableName) then

          // invalid request -> return ''

          exit;

        if Stmt.SelectFunctionCount=0 then begin

          // save rows as JSON, with appropriate search according to Where.* arguments

          MS := TRawByteStringStream.Create;

          try

            ForceAJAX := ForceAJAX or not Owner.NoAJAXJSON;

            ResCount := GetJSONValues(MS,ForceAJAX,Stmt);

            result := MS.DataString;

          finally

            MS.Free;

          end;

        end else

        if (length(Stmt.Select)<>1) or (Stmt.SelectFunctionCount<>1) or

           ((Stmt.Limit>1) or (Stmt.Offset<>0)) then

           // handle a single max() or count() function with no LIMIT nor OFFSET

          exit else

          case Stmt.Select[0].FunctionKnown of

           funcCountStar:

            if Stmt.Where=nil then

              // was e.g. "SELECT Count(*) FROM TableName;"

              SetCount(TableRowCount(fStoredClass)) else begin

              // was e.g. "SELECT Count(*) FROM TableName WHERE ..."

              ResCount := FindWhereEqual(Stmt.Where[0].Field,Stmt.Where[0].Value,

                DoNothingEvent,nil,0,0);

              case Stmt.Where[0].Operator of

              opEqualTo:    SetCount(ResCount);

              opNotEqualTo: SetCount(TableRowCount(fStoredClass)-ResCount);

              end;

            end;

            funcMax:

              if (Stmt.Where=nil) and FindMax(Stmt.Select[0].Field,max) then begin

                FormatUTF8('[{"Max()":%}]'#$A,[max],result);

                ResCount := 1;

              end;

            else exit;

           end;

      finally

        Stmt.Free;

      end;

    end;

  finally

    StorageUnLock;

  end;

  if ReturnedRowCount<>nil then

    ReturnedRowCount^ := ResCount;

end;



procedure TSQLRestStorageInMemory.DropValues;

begin

  StorageLock(true);

  try

    fModified := fValue.Count>0;

    fValue.Clear;

    UpdateFile;

  finally

    StorageUnLock;

  end;

end;



procedure TSQLRestStorageInMemory.LoadFromJSON(const aJSON: RawUTF8);

begin

  LoadFromJSON(Pointer(aJSON),length(aJSON));

end;



procedure TSQLRestStorageInMemory.LoadFromJSON(JSONBuffer: PUTF8Char; JSONBufferLen: integer);

  function IsSorted(U: PPUTF8Char; RowCount, FieldCount: integer): boolean;

  var i: integer;

      aID, lastID: TID;

  begin

    result := false;

    lastID := 0;

    for i := 1 to RowCount do begin

      SetID(U^,aID);

      if aID<=lastID then

        exit else

        lastID := aID;

      inc(U,FieldCount);

    end;

    result := true;

  end;

var T: TSQLTableJSON;

begin

  fModified := false;

  fValue.Clear;

  if JSONBuffer=nil then

    exit;

  T := TSQLTableJSON.CreateFromTables([fStoredClass],'',JSONBuffer,JSONBufferLen);

  try

    if T.fFieldIndexID<0 then

      exit; // no ID field -> load is impossible -> error

    // ensure ID were stored in an increasing order

    if not IsSorted(@T.fResults[T.fFieldIndexID+T.FieldCount],T.fRowCount,T.FieldCount) then begin

      // force sorted by ID -> faster IDToIndex()

      T.SortFields(T.fFieldIndexID,true,nil,sftInteger);

      // if data is corrupted, IDs may not be unique -> check it now

      if not IsSorted(@T.fResults[T.fFieldIndexID+T.FieldCount],T.fRowCount,T.FieldCount) then

        exit; // some duplicated ID fields -> error

    end;

    // create TSQLRecord instances with data from T

    T.ToObjectList(fValue,fStoredClass);

  finally

    T.Free;

  end;

end;



procedure TSQLRestStorageInMemory.SaveToJSON(Stream: TStream; Expand: Boolean);

var i: integer;

    W: TJSONSerializer;

begin

  if self=nil then

    exit;

  StorageLock(false);

  try

    W := fStoredClassRecordProps.CreateJSONWriter(

      Stream,Expand,true,ALL_FIELDS,fValue.Count);

    try

      if Expand then

        W.Add('[');

      for i := 0 to fValue.Count-1 do begin

        if Expand then

          W.AddCR; // for better readability

        TSQLRecord(fValue.List[i]).GetJSONValues(W);

        W.Add(',');

      end;

      W.EndJSONObject(fValue.Count,fValue.Count);

    finally

      W.Free;

    end;

  finally

    StorageUnLock;

  end;

end;



function TSQLRestStorageInMemory.SaveToJSON(Expand: Boolean): RawUTF8;

var MS: TRawByteStringStream;

begin

  if self=nil then

    result := '' else begin

    MS := TRawByteStringStream.Create;

    try

      SaveToJSON(MS,Expand);

      result := MS.DataString;

    finally

      MS.Free;

    end;

  end;

end;



function TSQLRestStorageInMemory.SaveToBinary: RawByteString;

var MS: TRawByteStringStream;

begin

  if self=nil then

    result := '' else begin

    MS := TRawByteStringStream.Create;

    try

      SaveToBinary(MS);

      result := MS.DataString;

    finally

      MS.Free;

    end;

  end;

end;



const

  TSQLRESTSTORAGEINMEMORY_MAGIC = $A5ABA5A5;



function TSQLRestStorageInMemory.LoadFromBinary(Stream: TStream): boolean;

var R: TFileBufferReader;

    MS: TMemoryStream;

    i,n,f: integer;

    ID32: TIntegerDynArray;

    P: PAnsiChar;

    aRecord: TSQLRecord;

    lastID,newID: TID;

    s: RawUTF8;

begin

  result := false;

  if self=nil then

    exit;

  MS := StreamUnSynLZ(Stream,TSQLRESTSTORAGEINMEMORY_MAGIC);

  if MS<>nil then

  with fStoredClassRecordProps do

  try

    // check header: expect same exact RTTI

    R.OpenFrom(MS.Memory,MS.Size);

    R.Read(s);

    if (s<>'') and  // new fixed format

       not IdemPropNameU(s,'TSQLRecordProperties') then // old buggy format

      exit;

    if not CheckBinaryHeader(R) then

      exit;

    // read IDs

    fModified := false;

    fValue.Clear;

    n := R.ReadVarUInt32Array(ID32);

    fValue.Count := abs(n); // faster than fValue.Add() to allocate all at once

    if n<0 then begin // was wkFakeMarker -> TID were stored as Int64

      lastID := 0;

      for i := 0 to -n-1 do begin

        aRecord := fStoredClass.Create;

        newID := lastID+R.ReadVarUInt64;

        aRecord.fID := newID;

        lastID := newID;

        fValue.List[i] := aRecord;

      end;

    end else

      for i := 0 to n-1 do begin

        aRecord := fStoredClass.Create;

        aRecord.fID := ID32[i];

        fValue.List[i] := aRecord;

      end;

    // read content, grouped by field (for better compression)

    P := R.CurrentMemory;

    for f := 0 to Fields.Count-1 do

      with Fields.List[f], fValue do

        for i := 0 to Count-1 do begin

          P := SetBinary(TSQLRecord(List[i]),P);

          if P=nil then begin

            fValue.Clear; // on error, reset whole

            exit;

          end;

        end;

    Result := true;

  finally

    R.Close;

    MS.Free;

  end;

end;



function TSQLRestStorageInMemory.LoadFromBinary(const Buffer: RawByteString): boolean;

var S: TStream;

begin

  S := TRawByteStringStream.Create(Buffer);

  try

    result := LoadFromBinary(S);

  finally

    S.Free;

  end;

end;



procedure TSQLRestStorageInMemory.LoadFromResource(ResourceName: string);

var S: TStream;

begin

  if ResourceName = '' then

    ResourceName := fStoredClass.ClassName;

  S := TResourceStream.Create(HInstance,ResourceName,pointer(10));

  try

    if not LoadFromBinary(S) then

      raise EORMException.CreateUTF8('%.LoadFromResource with invalid % content',

        [self,fStoredClass]);

  finally

    S.Free;

  end;

end;



function TSQLRestStorageInMemory.SaveToBinary(Stream: TStream): integer;

var W: TFileBufferWriter;

    MS: THeapMemoryStream;

    ID32: TIntegerDynArray;

    i, f: integer;

    hasInt64ID: boolean;

    p: PID;

    lastID,newID: TID;

begin

  result := 0;

  if (self=nil) or (Stream=nil) then

    exit;

  MS := THeapMemoryStream.Create;

  W := TFileBufferWriter.Create(MS);

  StorageLock(false);

  try

    with fStoredClassRecordProps do

    try

      // primitive magic and fields signature for file type identification

      W.Write1(0); // ClassName='TSQLRecordProperties' in old buggy format

      SaveBinaryHeader(W);

      // write IDs

      hasInt64ID := false;

      SetLength(ID32,Count);

      with fValue do

        for i := 0 to Count-1 do begin

          p := @TSQLRecord(List[i]).fID;

          if p^>high(cardinal) then begin

            hasInt64ID := true;

            break;

          end else

            ID32[i] := PInteger(p)^;

        end;

      if hasInt64ID then begin

        W.WriteVarUInt32(fValue.Count);

        W.Write1(ord(wkFakeMarker)); // fake marker

        lastID := 0;

        with fValue do

        for i := 0 to Count-1 do begin // a bit less efficient than wkSorted

          newID := TSQLRecord(List[i]).fID;

          if newID<=lastID then

            raise EORMException.CreateUTF8('%.SaveToBinary(%): IDs not sorted',

              [self,fStoredClass]);

          W.WriteVarUInt64(newID-lastID);

          lastID := newID;

        end;

      end else

        W.WriteVarUInt32Array(ID32,Count,wkSorted); // efficient ID storage

      // write content, grouped by field (for better compression)

      for f := 0 to Fields.Count-1 do

        with Fields.List[f], fValue do

          for i := 0 to Count-1 do

            GetBinary(TSQLRecord(List[i]),W);

      W.Flush;

      result := StreamSynLZ(MS,Stream,TSQLRESTSTORAGEINMEMORY_MAGIC);

    finally

      W.Free;

      MS.Free;

    end;

  finally

    StorageUnLock;

  end;

end;



function TSQLRestStorageInMemory.EngineRetrieve(TableModelIndex: integer; ID: TID): RawUTF8;

var i: integer;

begin // TableModelIndex is not useful here

  StorageLock(false);

  try

    i := IDToIndex(ID);

    if i<0 then

      result := '' else

      result := TSQLRecord(fValue.List[i]).GetJSONValues(true,true,soSelect);

  finally

    StorageUnLock;

  end;

end;



function TSQLRestStorageInMemory.GetOne(aID: TID): TSQLRecord;

var i: integer;

begin

  StorageLock(false);

  try

    i := IDToIndex(aID);

    if i<0 then

      result := nil else begin

      result := fStoredClass.Create;

      CopyObject(TObject(fValue.List[i]),result);

      result.fID := aID;

    end;

  finally

    StorageUnLock;

  end;

end;



function TSQLRestStorageInMemory.EngineUpdateFieldIncrement(TableModelIndex: integer;

  ID: TID; const FieldName: RawUTF8; Increment: Int64): boolean;

var i,err: integer;

    P: TSQLPropInfo;

    V: RawUTF8;

    wasString: boolean;

    int: Int64;

begin

  result := false;

  if (ID<0) or (TableModelIndex<0) or (Model.Tables[TableModelIndex]<>fStoredClass) then

    exit;

  P := fStoredClassProps.Prop[FieldName];

  if P=nil then

    exit;

  StorageLock(false);

  try

    i := IDToIndex(ID);

    if i<0 then

      exit;

    P.GetValueVar(fValue.List[i],false,V,@wasstring);

    int := GetInt64(pointer(V),err);

    if wasString or (err<>0) then

      exit;

    Int64ToUtf8(int+Increment,V);

    P.SetValueVar(fValue.List[i],V,false);

    result := true;

  finally

    StorageUnLock;

  end;

end;



function TSQLRestStorageInMemory.EngineUpdate(TableModelIndex: integer; ID: TID;

  const SentData: RawUTF8): boolean;

var i: integer;

    Orig,Rec: TSQLRecord;

begin

  // this implementation will handle partial fields update (e.g.

  // FillPrepare+BatchUpdate or TSQLRestServerRemoteDB.UpdateField)

  // but TSQLRestStorageRecordBased.EngineUpdate won't

  result := false;

  if (ID<0) or (TableModelIndex<0) or (Model.Tables[TableModelIndex]<>fStoredClass) then

    exit;

  if SentData='' then begin

    result := True;

    exit;

  end;

  StorageLock(true);

  try

    i := IDToIndex(ID);

    if (i<0) or not RecordCanBeUpdated(fStoredClass,ID,seUpdate) then

      exit;

    if fUniqueFields<>nil then begin

      Orig := TSQLRecord(fValue.List[i]);

      Rec := Orig.CreateCopy; // copy since can be a partial update

      Rec.FillFrom(SentData); // overwrite updated properties

      if not UniqueFieldsUpdateOK(Rec,i) then begin

        Rec.Free; // stored false property duplicated value -> error

        exit;

      end;

      Orig.Free; // avoid memory leak

      TSQLRecord(fValue.List[i]) := Rec; // update item in list

    end else

      // direct in-place partial update

      TSQLRecord(fValue.List[i]).FillFrom(SentData);

    fModified := true;

    result := true;

    if Owner<>nil then

      Owner.InternalUpdateEvent(seUpdate,fStoredClassProps.TableIndex,ID,SentData,nil);

  finally

    StorageUnLock;

  end;

end;



function TSQLRestStorageInMemory.UpdateOne(Rec: TSQLRecord; const SentData: RawUTF8): boolean;

var i: integer;

begin

  result := false;

  if (Rec=nil) or (PSQLRecordClass(Rec)^<>fStoredClass) or (Rec.fID<=0) then

    exit;

  StorageLock(true);

  try

    i := IDToIndex(Rec.fID);

    if (i<0) or not RecordCanBeUpdated(fStoredClass,Rec.fID,seUpdate) then

      exit;

    if (fUniqueFields<>nil) and not UniqueFieldsUpdateOK(Rec,i) then

      exit; // stored false property duplicated value -> error

    CopyObject(Rec,TObject(fValue.List[i]));

    fModified := true;

    result := true;

    if Owner<>nil then

      Owner.InternalUpdateEvent(seUpdate,fStoredClassProps.TableIndex,Rec.fID,SentData,nil);

  finally

    StorageUnLock;

  end;

end;



function TSQLRestStorageInMemory.UpdateOne(ID: TID;

  const Values: TSQLVarDynArray): boolean;

var i: integer;

    Orig,Rec: TSQLRecord;

begin

  result := false;

  if ID<=0 then

    exit;

  StorageLock(true);

  try

    i := IDToIndex(ID);

    if (i<0) or not RecordCanBeUpdated(fStoredClass,ID,seUpdate) then

      exit;

    if fUniqueFields<>nil then begin

      Orig := TSQLRecord(fValue.List[i]);

      Rec := Orig.CreateCopy; // copy since can be a partial update

      if (not Rec.SetFieldSQLVars(Values)) or

         (not UniqueFieldsUpdateOK(Rec,i)) then begin

        Rec.Free; // stored false property duplicated value -> error

        exit;

      end;

      Orig.Free; // avoid memory leak

      TSQLRecord(fValue.List[i]) := Rec;

    end else

    if not TSQLRecord(fValue.List[i]).SetFieldSQLVars(Values) then

      exit;

    fModified := true;

    result := true;

    if Owner<>nil then

      Owner.InternalUpdateEvent(seUpdate,fStoredClassProps.TableIndex,ID,

        TSQLRecord(fValue.List[i]).GetJSONValues(True,False,soUpdate),nil);

  finally

    StorageUnLock;

  end;

end;



function TSQLRestStorageInMemory.EngineRetrieveBlob(TableModelIndex: integer; aID: TID;

  BlobField: PPropInfo; out BlobData: TSQLRawBlob): boolean;

var i: integer;

begin

  result := false;

  if (TableModelIndex<0) or (not BlobField^.IsBlob) or

     (fModel.Tables[TableModelIndex]<>fStoredClass) then

    exit;

  StorageLock(false);

  try

    i := IDToIndex(aID);

    if i<0 then

      exit;

    // get result blob directly from RTTI property description

    BlobField.GetLongStrProp(fValue.List[i],RawByteString(BlobData));

    result := true;

  finally

    StorageUnLock;

  end;

end;



function TSQLRestStorageInMemory.RetrieveBlobFields(Value: TSQLRecord): boolean;

var i,f: integer;

begin

  result := false;

  if (Value<>nil) and (Value.fID>0) and (PSQLRecordClass(Value)^=fStoredClass) then

  with Value.RecordProps do

  if BlobFields<>nil then begin

    StorageLock(false);

    try

      i := IDToIndex(Value.fID);

      if i<0 then

        exit;

      for f := 0 to high(BlobFields) do

        BlobFields[f].CopyValue(fValue.List[i],Value);

      result := true;

    finally

      StorageUnLock;

    end;

  end;

end;



function TSQLRestStorageInMemory.EngineUpdateBlob(TableModelIndex: integer; aID: TID;

  BlobField: PPropInfo; const BlobData: TSQLRawBlob): boolean;

var i: integer;

    AffectedField: TSQLFieldBits;

begin

  result := false;

  if (aID<0) or (TableModelIndex<0) or (not BlobField^.IsBlob) or

     (fModel.Tables[TableModelIndex]<>fStoredClass) then

    exit;

  StorageLock(true);

  try

    i := IDToIndex(aID);

    if (i<0) or not RecordCanBeUpdated(fStoredClass,aID,seUpdate) then

      exit;

    // set blob value directly from RTTI property description

    BlobField.SetLongStrProp(fValue.List[i],BlobData);

    if Owner<>nil then begin

      fStoredClassRecordProps.FieldBitsFromBlobField(BlobField,AffectedField);

      Owner.InternalUpdateEvent(seUpdateBlob,fStoredClassProps.TableIndex,aID,'',@AffectedField);

    end;

    result := true;

  finally

    StorageUnLock;

  end;

end;



function TSQLRestStorageInMemory.UpdateBlobFields(Value: TSQLRecord): boolean;

var i,f: integer;

begin

  result := false;

  if (Value<>nil) and (Value.fID>0) and (PSQLRecordClass(Value)^=fStoredClass) then

  with Value.RecordProps do

  if BlobFields<>nil then begin

    StorageLock(true);

    try

      i := IDToIndex(Value.fID);

      if (i<0) or not RecordCanBeUpdated(Table,Value.fID,seUpdate) then

        exit;

      for f := 0 to high(BlobFields) do

        BlobFields[f].CopyValue(Value,fValue.List[i]);

      if Owner<>nil then

        Owner.InternalUpdateEvent(seUpdateBlob,fStoredClassProps.TableIndex,Value.fID,'',

          @fStoredClassRecordProps.FieldBits[sftBlob]);

      result := true;

    finally

      StorageUnLock;

    end;

  end else

    result := true; // as TSQLRest.UpdateblobFields()

end;



function TSQLRestStorageInMemory.TableRowCount(Table: TSQLRecordClass): Int64;

begin

  if Table<>fStoredClass then

    result := 0 else

    result := fValue.Count;

end;



function TSQLRestStorageInMemory.TableHasRows(Table: TSQLRecordClass): boolean;

begin

  if Table<>fStoredClass then

    result := false else

    result := fValue.Count>0;

end;



function TSQLRestStorageInMemory.EngineUpdateField(TableModelIndex: integer;

  const SetFieldName, SetValue, WhereFieldName, WhereValue: RawUTF8): boolean;

var SetField: TSQLPropInfo;

    WhereValueString, SetValueString, SetValueJson: RawUTF8;

    Where: TList;

    i, ndx, WhereFieldIndex: integer;

    SetValueWasString: boolean;

    Rec: TSQLRecord;

begin

  result := false;

  if (TableModelIndex<0) or (fModel.Tables[TableModelIndex]<>fStoredClass) or

     (SetFieldName='') or (SetValue='') or

     (WhereFieldName='') or (WhereValue='') then

    exit;

  // handle destination field RTTI

  SetField := fStoredClassRecordProps.Fields.ByRawUTF8Name(SetFieldName);

  if SetField=nil then

    exit; // don't allow setting ID field, which is Read Only

  SetValueWasString := SetValue[1]='"';

  if SetValueWasString then

    UnQuoteSQLStringVar(pointer(SetValue),SetValueString) else

    SetValueString := SetValue;

  // handle search field RTTI

  if IsRowID(pointer(WhereFieldName)) then begin

    WhereFieldIndex := 0;

    WhereValueString := WhereValue;

  end else begin

    WhereFieldIndex := fStoredClassRecordProps.Fields.IndexByName(WhereFieldName);

    if WhereFieldIndex<0  then

      exit;

    inc(WhereFieldIndex); // FindWhereEqual() expects index = RTTI+1

  end;

  if WhereValue[1]='"' then

    UnQuoteSQLStringVar(pointer(WhereValue),WhereValueString) else

    WhereValueString := WhereValue;

  // search indexes, then apply updates

  Where := TList.Create;

  StorageLock(true);

  SetValueJson := ''; // alf: to circumvent FPC issues

  try

    // find matching Where[]

    if FindWhereEqual(WhereFieldIndex,WhereValueString,AddIntegerDynArrayEvent,Where,0,0)=0 then

      exit; // Where.Count=0 -> nothing to update

    // check that all records can be updated

    for i := 0 to Where.Count-1 do

      if not RecordCanBeUpdated(fStoredClass,

         TSQLRecord(fValue.List[PtrInt(Where.List[i])]).fID,seUpdate) then

        exit; // one record update fails -> abort all

    if fUniqueFields<>nil then

      for i := 0 to fUniqueFields.Count-1 do

      with TListFieldHash(fUniqueFields.List[i]) do

        if Field=SetField then

          if Where.Count>1 then // unique field can't allow multiple sets

            exit else begin

            SetField.SetValueVar(fSearchRec,SetValueString,false);

            ndx := Find(fSearchRec);

            if (ndx>=0) and (ndx<>PtrInt(Where.List[0])) then

              exit; // duplicated entry error

          end;

    // update field value

    for i := 0 to Where.Count-1 do begin

      Rec := fValue.List[PtrInt(Where.List[i])];

      SetField.SetValueVar(Rec,SetValueString,SetValueWasString);

      fModified := true;

      if Owner<>nil then begin

        if SetValueJson='' then

          JSONEncodeNameSQLValue(SetField.Name,SetValue,SetValueJson);

        Owner.InternalUpdateEvent(seUpdate,fStoredClassProps.TableIndex,Rec.fID,SetValueJson,nil);

      end;

      result := true;

    end;

  finally

    StorageUnLock;

    Where.Free;

  end;

end;



procedure TSQLRestStorageInMemory.UpdateFile;

var F: TFileStream;

    Timer: TPrecisionTimer;

begin

  if (self=nil) or (not Modified) or (FileName='') then

    exit;

  Timer.Start;

  StorageLock(false);

  try

    if fValue.Count=0 then

      DeleteFile(FileName) else begin

      F := TFileStream.Create(FileName,fmCreate);

      try

        if BinaryFile then

          SaveToBinary(F) else

          SaveToJSON(F,true);

        F.Size := F.Position; // truncate file

      finally

        F.Free;

      end;

    end;

    fModified := false;

  finally

    StorageUnLock;

  end;

  InternalLog('UpdateFile(%) done in %',

    [fStoredClassRecordProps.SQLTableName,Timer.Stop],sllDB);

end;



procedure TSQLRestStorageInMemory.SetFileName(const aFileName: TFileName);

begin

  if aFileName=fFileName then

    exit;

  fFileName := aFileName;

  fModified := true;

end;



procedure TSQLRestStorageInMemory.SetBinaryFile(aBinary: boolean);

begin

  if aBinary=fBinaryFile then

    Exit;

  fBinaryFile := aBinary;

  fModified := true;

end;



procedure TSQLRestStorageInMemory.ReloadFromFile;

var JSON: RawUTF8;

    Stream: TStream;

begin

  if (fFileName<>'') and FileExists(fFileName) then begin

    if fBinaryFile then begin

      Stream := TSynMemoryStreamMapped.Create(fFileName);

      try

        LoadFromBinary(Stream)

      finally

        Stream.Free;

      end;

    end else begin

      JSON := AnyTextFileToRawUTF8(fFileName,true);

      LoadFromJSON(JSON);

    end;

  end;

end;



function TSQLRestStorageInMemory.SearchField(const FieldName, FieldValue: RawUTF8;

  out ResultID: TIDDynArray): boolean;

var n, WhereField: integer;

    {$ifndef CPU64}i: integer;{$endif}

    Where: TList;

begin

  result := false;

  if (self=nil) or (fValue.Count=0) then

    exit;

  if IsRowID(pointer(FieldName)) then

    WhereField := SYNTABLESTATEMENTWHEREID else begin

    WhereField := fStoredClassRecordProps.Fields.IndexByName(FieldName);

    if WhereField<0 then

      exit;

    inc(WhereField); // FindWhereEqual() expects index = RTTI+1

  end;

  Where := TList.Create;

  try

    StorageLock(false);

    try

      n := FindWhereEqual(WhereField,FieldValue,AddIntegerDynArrayEvent,Where,0,0);

    finally

      StorageUnLock;

    end;

    if n=0 then

      exit;

    SetLength(ResultID,n);

    {$ifdef CPU64} // on x64 TList[]=Pointer does map an TID/Int64

    MoveFast(Where.List[0],ResultID[0],n*sizeof(TID));

    {$else}

    with Where do

      for i := 0 to Count-1 do

        ResultID[i] := PPtrIntArray(List)^[i];

    {$endif}

  finally

    Where.Free;

  end;

end;



function TSQLRestStorageInMemory.SearchEvent(const FieldName, FieldValue: RawUTF8;

  OnFind: TFindWhereEqualEvent; Dest: pointer; FoundLimit,FoundOffset: integer): integer;

begin

  result := 0;

  if (self=nil) or (fValue.Count=0) or (FieldName='') then

    exit;

  StorageLock(false);

  try

    result := FindWhereEqual(FieldName,FieldValue,OnFind,Dest,FoundLimit,FoundOffset);

  finally

    StorageUnlock;

  end;

end;



procedure TSQLRestStorageInMemory.DoCopyEvent(

  aDest: pointer; aRec: TSQLRecord; aIndex: integer);

begin

  if aDest<>nil then

    PPointer(aDest)^ := aRec.CreateCopy;

end;



function TSQLRestStorageInMemory.SearchCopy(const FieldName, FieldValue: RawUTF8): pointer;

begin

  if SearchEvent(FieldName,FieldValue,DoCopyEvent,@result,1,0)=0 then

    result := nil;

end;



procedure TSQLRestStorageInMemory.DoInstanceEvent(aDest: pointer; aRec: TSQLRecord;

  aIndex: integer);

begin

  if aDest<>nil then

    PPointer(aDest)^ := aRec;

end;



function TSQLRestStorageInMemory.SearchInstance(const FieldName, FieldValue: RawUTF8): pointer;

begin

  if SearchEvent(FieldName,FieldValue,DoInstanceEvent,@result,1,0)=0 then

    result := nil;

end;



procedure TSQLRestStorageInMemory.DoIndexEvent(aDest: pointer; aRec: TSQLRecord;

  aIndex: integer);

begin

  if aDest<>nil then

    PInteger(aDest)^ := aIndex;

end;



function TSQLRestStorageInMemory.SearchIndex(const FieldName, FieldValue: RawUTF8): integer;

begin

  if SearchEvent(FieldName,FieldValue,DoIndexEvent,@result,1,0)=0 then

    result := -1;

end;





function TSQLRestStorageInMemory.SearchCount(const FieldName, FieldValue: RawUTF8): integer;

begin

  result := SearchEvent(FieldName,FieldValue,DoNothingEvent,nil,0,0);

end;





{ TSQLRestStorageInMemoryExternal }



constructor TSQLRestStorageInMemoryExternal.Create(aClass: TSQLRecordClass;

  aServer: TSQLRestServer; const aFileName: TFileName = ''; aBinaryFile: boolean=false);

begin

  inherited Create(aClass,aServer,aFileName,aBinaryFile);

  fStorageLockShouldIncreaseOwnerInternalState := false; // done by overriden StorageLock()

end;



procedure TSQLRestStorageInMemoryExternal.StorageLock(WillModifyContent: boolean);

begin

  inherited StorageLock(WillModifyContent);

  if WillModifyContent and (Owner<>nil) then

    Owner.FlushInternalDBCache;

end;





{ TSQLRestStorageRemote }



constructor TSQLRestStorageRemote.Create(aClass: TSQLRecordClass;

  aServer: TSQLRestServer; aRemoteRest: TSQLRest);

begin

  if aRemoteRest=nil then

    raise EORMException.CreateUTF8('%.Create(nil)',[self]);

  inherited Create(aClass,aServer);

  fRemoteTableIndex := aRemoteRest.Model.GetTableIndexExisting(aClass);

  fRemoteRest := aRemoteRest;

end;



function TSQLRestStorageRemote.EngineAdd(TableModelIndex: integer;

  const SentData: RawUTF8): TID;

begin

  result := fRemoteRest.EngineAdd(fRemoteTableIndex,SentData);

end;



function TSQLRestStorageRemote.EngineDelete(TableModelIndex: integer; ID: TID): boolean;

begin

  result := fRemoteRest.EngineDelete(fRemoteTableIndex,ID);

end;



function TSQLRestStorageRemote.EngineDeleteWhere(TableModelIndex: Integer;

  const SQLWhere: RawUTF8; const IDs: TIDDynArray): boolean;

begin

  result := fRemoteRest.EngineDeleteWhere(fRemoteTableIndex,SQLWhere,IDs);

end;



function TSQLRestStorageRemote.EngineExecute(const aSQL: RawUTF8): boolean;

begin

  result := fRemoteRest.EngineExecute(aSQL);

end;



function TSQLRestStorageRemote.EngineList(const SQL: RawUTF8;

  ForceAJAX: Boolean; ReturnedRowCount: PPtrInt): RawUTF8;

begin

  result := fRemoteRest.EngineList(SQL,ForceAJAX,ReturnedRowCount);

end;



function TSQLRestStorageRemote.EngineRetrieve(TableModelIndex: integer; ID: TID): RawUTF8;

begin

  result := fRemoteRest.EngineRetrieve(fRemoteTableIndex,ID);

end;



function TSQLRestStorageRemote.EngineRetrieveBlob(TableModelIndex: integer; aID: TID;

  BlobField: PPropInfo; out BlobData: TSQLRawBlob): boolean;

begin

  if (self=nil) or (BlobField=nil) then

    result := false else

    result := fRemoteRest.EngineRetrieveBlob(fRemoteTableIndex,aID,BlobField,BlobData);

end;



function TSQLRestStorageRemote.EngineUpdate(TableModelIndex: integer;

  ID: TID; const SentData: RawUTF8): boolean;

begin

  result := fRemoteRest.EngineUpdate(fRemoteTableIndex,ID,SentData);

end;



function TSQLRestStorageRemote.EngineUpdateBlob(TableModelIndex: integer; aID: TID;

  BlobField: PPropInfo; const BlobData: TSQLRawBlob): boolean;

begin

  if (self=nil) or (BlobField=nil) then

    result := false else

    result := fRemoteRest.EngineUpdateBlob(fRemoteTableIndex,aID,BlobField,BlobData);

end;



function TSQLRestStorageRemote.EngineUpdateField(TableModelIndex: integer;

  const SetFieldName, SetValue, WhereFieldName, WhereValue: RawUTF8): boolean;

begin

  result := fRemoteRest.EngineUpdateField(fRemoteTableIndex,SetFieldName,SetValue,WhereFieldName,WhereValue);

end;



function TSQLRestStorageRemote.EngineUpdateFieldIncrement(TableModelIndex: integer;

  ID: TID; const FieldName: RawUTF8; Increment: Int64): boolean;

begin

   result := fRemoteRest.EngineUpdateFieldIncrement(fRemoteTableIndex,ID,FieldName,Increment);

end;





{ TSQLRestStorageShard }



const MIN_SHARD = 1000;



constructor TSQLRestStorageShard.Create(aClass: TSQLRecordClass;

  aServer: TSQLRestServer; aShardRange: TID; aOptions: TSQLRestStorageShardOptions);

var i,n: integer;

begin

  if aShardRange<MIN_SHARD then

    raise EORMException.CreateUTF8('%.Create(%,aShardRange=%<%) does not make sense',

      [self,aClass,aShardRange,MIN_SHARD]);

  inherited Create(aClass,aServer);

  fShardRange := aShardRange;

  fShardLast := cardinal(-1);

  fOptions := aOptions;

  InitShards; // set fShards[], fShardLast and fShardLastID

  n := length(fShards);

  fShardNextID := n*fShardRange+1;

  SetLength(fShardTableIndex,n);

  for i := 0 to fShardLast do

    if fShards[i]=nil then

      fShardTableIndex[i] := -1 else

      fShardTableIndex[i] := fShards[i].Model.GetTableIndexExisting(aClass);

end;



destructor TSQLRestStorageShard.Destroy;

var i,j: integer;

    rest: TSQLRest;

begin

  try

    if not (ssoNoConsolidateAtDestroy in fOptions) then

      ConsolidateShards;

  finally

    inherited Destroy;

    for i := 0 to high(fShards) do begin

      rest := fShards[i];

      if rest=nil then

        continue;

      rest.Free;

      for j := i+1 to high(fShards) do

        if fShards[j]=rest then

          fShards[j] := nil; // same instance re-used in fShards[]

    end;

  end;

end;



procedure TSQLRestStorageShard.ConsolidateShards;

begin // do nothing by default

end;





procedure TSQLRestStorageShard.RemoveShard(aShardIndex: integer);

begin

  StorageLock(true);

  try

    if (fShards<>nil) and (cardinal(aShardIndex)<=fShardLast) then

      FreeAndNil(fShards[aShardIndex]);

  finally

    StorageUnLock;

  end;

end;



procedure TSQLRestStorageShard.InternalAddNewShard;

var rest: TSQLRest;

begin

  {$ifdef WITHLOG}

  fLogClass.Enter('%.InternalAddNewShard: #% for %',[fShardLast+1,fStoredClass],self);

  {$endif}

  rest := InitNewShard;

  if rest=nil then

    raise EORMException.CreateUTF8('%.InitNewShard(%) =nil',[self,fStoredClass]);

  inc(fShardNextID,fShardRange);

  SetLength(fShardTableIndex,fShardLast+1);

  fShardTableIndex[fShardLast] := rest.Model.GetTableIndexExisting(fStoredClass);

end;



function TSQLRestStorageShard.ShardFromID(aID: TID; out aShardTableIndex: integer;

  out aShard: TSQLRest; aOccasion: TSQLOccasion; aShardIndex: PInteger): boolean;

var ndx: cardinal;

begin

  result := false;

  if aID<=0 then

    exit;

  case aOccasion of

    soUpdate:

      if ssoNoUpdate in fOptions then

        exit;

    soDelete:

      if ssoNoDelete in fOptions then

        exit;

  end;

  EnterCriticalSection(fStorageCriticalSection);

  try

    ndx := (aID-1) div fShardRange;

    if (ndx<=fShardLast) and (fShards[ndx]<>nil) then begin

      case aOccasion of

        soUpdate:

          if (ssoNoUpdateButLastShard in fOptions) and (ndx<>fShardLast) then

            exit;

        soDelete:

          if (ssoNoDeleteButLastShard in fOptions) and (ndx<>fShardLast) then

            exit;

      end;

      aShard := fShards[ndx];

      aShardTableIndex := fShardTableIndex[ndx];

      if aShardIndex<>nil then

        aShardIndex^ := ndx;

      result := true;

    end;

  finally

    LeaveCriticalSection(fStorageCriticalSection);

  end;

end;



function TSQLRestStorageShard.EngineAdd(TableModelIndex: integer;

  const SentData: RawUTF8): TID;

var data: RawUTF8;

    i: Integer;

begin

  if JSONGetID(pointer(SentData),result) then

    raise EORMException.CreateUTF8('%.EngineAdd(%) unexpected ID in %',

      [self,fStoredClass,SentData]);

  StorageLock(true);

  try

    inc(fShardLastID);

    if fShardLastID>=fShardNextID then begin

      InternalAddNewShard;

      if fShardLastID>=fShardNextID then

        raise EORMException.CreateUTF8('%.EngineAdd(%) fShardNextID',[self,fStoredClass]);

    end;

    result := fShardLastID;

    i := PosEx('{',SentData);

    if i=0 then

      data := FormatUTF8('{ID:%}',[result]) else begin

      data := SentData;

      insert(FormatUTF8('ID:%,',[result]),data,i+1);

    end;

    if fShardBatch<>nil then

      InternalShardBatch(fShardLast).RawAdd(data) else begin

      if fShards[fShardLast].EngineAdd(fShardTableIndex[fShardLast],data)<>result then begin

        InternalLog('EngineAdd(%) error adding ID=%',[fStoredClass,result],sllError);

        result := 0;

      end;

    end;

  finally

    StorageUnLock;

  end;

end;



function TSQLRestStorageShard.EngineDelete(TableModelIndex: integer;

  ID: TID): boolean;

var tableIndex,shardIndex: integer;

    rest: TSQLRest;

begin

  StorageLock(true);

  try

    if not ShardFromID(ID,tableIndex,rest,soDelete,@shardIndex) then

      result := false else

      if fShardBatch<>nil then

        result := InternalShardBatch(shardIndex).Delete(ID)>=0 else

        result := rest.EngineDelete(tableIndex,ID);

  finally

    StorageUnLock;

  end;

end;



function TSQLRestStorageShard.EngineDeleteWhere(TableModelIndex: integer;

  const SQLWhere: RawUTF8; const IDs: TIDDynArray): boolean;

var i: integer;

    ndx: cardinal;

    id: array of TInt64DynArray; // IDs split per shard

    sql: RawUTF8;

begin

  result := false;

  if (IDs=nil) or (ssoNoDelete in fOptions) then

    exit;

  StorageLock(true);

  try

    SetLength(id,fShardLast+1);

    for i := 0 to high(IDs) do begin

      ndx := (IDs[i]-1) div fShardRange;

      if (ndx>=fShardLast) or (fShards[ndx]=nil) then

        continue;

      if (ssoNoDeleteButLastShard in fOptions) and (ndx<>fShardLast) then

        continue;

      AddInt64(id[ndx],IDs[i]);

    end;

    result := true;

    for i := 0 to high(id) do

      if id[i]<>nil then begin

        sql := Int64DynArrayToCSV(id[i],length(id[i]),'ID in (',')');

        if not fShards[i].EngineDeleteWhere(fShardTableIndex[i],sql,TIDDynArray(id[i])) then

          result := false;

      end;

  finally

    StorageUnLock;

  end;

end;



function TSQLRestStorageShard.EngineExecute(const aSQL: RawUTF8): boolean;

begin

  StorageLock(false);

  try

    if (integer(fShardLast)>=0) and not (ssoNoExecute in fOptions) then

      result := fShards[fShardLast].EngineExecute(aSQL) else

      result := false;

  finally

    StorageUnLock;

  end;

end;



function TSQLRestStorageShard.TableHasRows(Table: TSQLRecordClass): boolean;

begin

  result := fShards<>nil;

end;



function TSQLRestStorageShard.TableRowCount(Table: TSQLRecordClass): Int64;

var i: integer;

begin

  result := 0;

  InternalLog('TableRowCount(%) may take a while',[fStoredClass],sllWarning);

  for i := 0 to high(fShards) do

    if fShards[i]<>nil then

      inc(result,fShards[i].TableRowCount(fStoredClass));

end;



function TSQLRestStorageShard.EngineList(const SQL: RawUTF8;

  ForceAJAX: Boolean; ReturnedRowCount: PPtrInt): RawUTF8;

var ResCount: PtrInt;

begin

  result := ''; // indicates error occurred

  StorageLock(false);

  try

    ResCount := 0;

    if IdemPropNameU(fBasicSQLCount,SQL) then begin

      FormatUTF8('[{"Count(*)":%}]'#$A,[TableRowCount(fStoredClass)],result);

      ResCount := 1;

    end else

    if IdemPropNameU(fBasicSQLHasRows[false],SQL) or

       IdemPropNameU(fBasicSQLHasRows[true],SQL) then

      if fShards<>nil then begin // return one row with fake ID=1

        result := '[{"RowID":1}]'#$A;

        ResCount := 1;

      end else

        result := '{"fieldCount":1,"values":["RowID"]}'#$A else begin

        if (integer(fShardLast)>=0) and not (ssoNoList in fOptions) then

          result := fShards[fShardLast].EngineList(SQL,ForceAJAX,@ResCount);

    end;

    if ReturnedRowCount<>nil then

      ReturnedRowCount^ := ResCount;

  finally

    StorageUnLock;

  end;

end;



function TSQLRestStorageShard.EngineRetrieve(TableModelIndex: integer;

  ID: TID): RawUTF8;

var tableIndex: integer;

    rest: TSQLRest;

begin

  StorageLock(false);

  try

    if not ShardFromID(ID,tableIndex,rest) then

      result := '' else

      result := rest.EngineRetrieve(tableIndex,ID);

  finally

    StorageUnLock;

  end;

end;



function TSQLRestStorageShard.EngineRetrieveBlob(TableModelIndex: integer;

  aID: TID; BlobField: PPropInfo; out BlobData: TSQLRawBlob): boolean;

var tableIndex: integer;

    rest: TSQLRest;

begin

  StorageLock(false);

  try

    if not ShardFromID(aID,tableIndex,rest) then

      result := false else

      result := rest.EngineRetrieveBlob(tableIndex,aID,BlobField,BlobData);

  finally

    StorageUnLock;

  end;

end;



function TSQLRestStorageShard.EngineUpdate(TableModelIndex: integer;

  ID: TID; const SentData: RawUTF8): boolean;

var tableIndex,shardIndex: integer;

    rest: TSQLRest;

begin

  StorageLock(true);

  try

    if not ShardFromID(ID,tableIndex,rest,soUpdate,@shardIndex) then

      result := false else

      if fShardBatch<>nil then begin

        InternalShardBatch(shardIndex).RawUpdate(SentData,ID);

        result := true;

      end else

        result := rest.EngineUpdate(tableIndex,ID,SentData);

  finally

    StorageUnLock;

  end;

end;



function TSQLRestStorageShard.EngineUpdateBlob(TableModelIndex: integer;

  aID: TID; BlobField: PPropInfo; const BlobData: TSQLRawBlob): boolean;

var tableIndex: integer;

    rest: TSQLRest;

begin

  result := false;

  StorageLock(true);

  try

    if ShardFromID(aID,tableIndex,rest,soUpdate) then

      result := rest.EngineUpdateBlob(tableIndex,aID,BlobField,BlobData);

  finally

    StorageUnLock;

  end;

end;



function TSQLRestStorageShard.EngineUpdateField(TableModelIndex: integer;

  const SetFieldName, SetValue, WhereFieldName, WhereValue: RawUTF8): boolean;

begin

  result := false;

  StorageLock(true);

  try

    if not ((ssoNoUpdate in fOptions) or (ssoNoUpdateField in fOptions)) then

      result := fShards[fShardLast].EngineUpdateField(fShardTableIndex[fShardLast],

        SetFieldName,SetValue,WhereFieldName,WhereValue);

  finally

    StorageUnLock;

  end;

end;



function TSQLRestStorageShard.EngineUpdateFieldIncrement(

  TableModelIndex: integer; ID: TID; const FieldName: RawUTF8;

  Increment: Int64): boolean;

var tableIndex: integer;

    rest: TSQLRest;

begin

  result := false;

  StorageLock(true);

  try

    if ShardFromID(ID,tableIndex,rest,soUpdate) then

      result := rest.EngineUpdateFieldIncrement(tableIndex,ID,FieldName,Increment);

  finally

    StorageUnLock;

  end;

end;



function TSQLRestStorageShard.InternalBatchStart(Method: TSQLURIMethod;

  BatchOptions: TSQLRestBatchOptions): boolean;

begin

  result := false;

  if ssoNoBatch in fOptions then

    exit;

  StorageLock(true); // protected by try..finally in TSQLRestServer.RunBatch

  try

    if fShardBatch<>nil then

      raise EORMException.CreateUTF8('%.InternalBatchStop should have been called',[self]);

    SetLength(fShardBatch,fShardLast+1);

    result := true;

  finally

    if not result then // release lock on error

      StorageUnLock;

  end;

end;



function TSQLRestStorageShard.InternalShardBatch(ShardIndex: integer): TSQLRestBatch;

begin

  if cardinal(ShardIndex)>fShardLast then

    raise EORMException.CreateUTF8('%.InternalShardBatch(%)',[self,ShardIndex]);

  if fShardBatch=nil then

    raise EORMException.CreateUTF8('%.InternalBatchStart should have been called',[self]);

  if ShardIndex>=length(fShardBatch) then

    SetLength(fShardBatch,ShardIndex+1); // InitNewShard just called

  if fShardBatch[ShardIndex]=nil then

    if fShards[ShardIndex]<>nil then

      fShardBatch[ShardIndex] := TSQLRestBatch.Create(

        fShards[ShardIndex],fStoredClass,10000,[boExtendedJSON]) else

      raise EORMException.CreateUTF8('%.InternalShardBatch fShards[%]=nil',[self,ShardIndex]);

  result := fShardBatch[ShardIndex];

end;



procedure TSQLRestStorageShard.InternalBatchStop;

var i: integer;

begin

  try

    for i := 0 to high(fShardBatch) do

      if fShardBatch[i]<>nil then

        if fShards[i].BatchSend(fShardBatch[i])<>HTML_SUCCESS then

          InternalLog('%.InternalBatchStop(%): %.BatchSend failed for shard #%',

            [ClassType,fStoredClass,fShards[i].ClassType,i],sllWarning);

  finally

    ObjArrayClear(fShardBatch);

    StorageUnLock;

  end;

end;





{ TListFieldHash }



function TListFieldHash.Compare(Item1,Item2: TObject): boolean;

begin

  result := fProp.CompareValue(Item1,Item2,CaseInsensitive)=0;

end;



function TListFieldHash.Count: integer;

begin

  result := fValues.Count;

end;



constructor TListFieldHash.Create(aValues: TList; aField: TSQLPropInfo;

  aCaseInsensitive: boolean);

begin

  fValues := aValues;

  fField := aField.PropertyIndex;

  fProp := aField;

  fCaseInsensitive := aCaseInsensitive;

end;



function TListFieldHash.Hash(Item: TObject): cardinal;

begin

  result := fProp.GetHash(Item,CaseInsensitive);

  if result=0 then

    result := 1; // HASH=0 is used to indicate a void slot in fHash[]

end;



function TListFieldHash.Get(Index: integer): TObject;

begin

  with fValues do

    if cardinal(Index)<cardinal(Count) then

      result := List[Index] else

      result := nil;

end;



function TListFieldHash.Scan(Item: TObject; ListCount: integer): integer;

begin

  for result := 0 to ListCount-1 do

    if fProp.CompareValue(fValues.List[result],Item,CaseInsensitive)=0 then

      exit;

  result := -1;

end;





{ TSQLRestStorage }



constructor TSQLRestStorage.Create(aClass: TSQLRecordClass;

  aServer: TSQLRestServer);

begin

  inherited Create(nil);

  if aClass=nil then

    raise EBusinessLayerException.CreateUTF8('%.Create(aClass=nil)',[self]);

  InitializeCriticalSection(fStorageCriticalSection);

  fStoredClass := aClass;

  fStoredClassRecordProps := aClass.RecordProps;

  if aServer<>nil then begin

    fOwner := aServer;

    fModel := aServer.Model;

    fStoredClassProps := fModel.Props[aClass];

  end else

    // if no server is defined, simply use the first model using this class

    if fStoredClassRecordProps.fModel<>nil then

    with fStoredClassRecordProps.fModel[0] do begin

      fModel := Model;

      fStoredClassProps := Properties;

    end;

  fIsUnique := fStoredClassRecordProps.IsUniqueFieldsBits;

  fBasicSQLCount := 'SELECT COUNT(*) FROM '+fStoredClassRecordProps.SQLTableName;

  fBasicSQLHasRows[false] := 'SELECT RowID FROM '+fStoredClassRecordProps.SQLTableName+' LIMIT 1';

  fBasicSQLHasRows[true] := fBasicSQLHasRows[false];

  system.delete(fBasicSQLHasRows[true],8,3);

end;



destructor TSQLRestStorage.Destroy;

begin

  inherited;

  if fStorageCriticalSectionCount<>0 then

    raise EORMException.CreateUTF8('%.Destroy with CS=%',[self,fStorageCriticalSectionCount]);

  DeleteCriticalSection(fStorageCriticalSection);

end;



procedure TSQLRestStorage.BeginCurrentThread(Sender: TThread);

begin // called by TSQLRestServer.BeginCurrentThread

  // nothing to do in this basic REST static class

end;



procedure TSQLRestStorage.EndCurrentThread(Sender: TThread);

begin // called by TSQLRestServer.EndCurrentThread

  // nothing to do in this basic REST static class

end;



function TSQLRestStorage.ServiceContainer: TServiceContainer;

begin

  result := nil;

end;



function TSQLRestStorage.CreateSQLMultiIndex(Table: TSQLRecordClass;

  const FieldNames: array of RawUTF8; Unique: boolean; IndexName: RawUTF8): boolean;

begin

  result := false; // not implemented in this basic REST static class

end;



function TSQLRestStorage.SearchField(const FieldName: RawUTF8;

  FieldValue: Int64; out ResultID: TIDDynArray): boolean;

begin

  result := SearchField(FieldName,Int64ToUTF8(FieldValue),ResultID);

end;



function TSQLRestStorage.RecordCanBeUpdated(Table: TSQLRecordClass;

  ID: TID; Action: TSQLEvent; ErrorMsg: PRawUTF8 = nil): boolean;

begin

  result := ((Owner=nil) or Owner.RecordCanBeUpdated(Table,ID,Action,ErrorMsg));

end;



function TSQLRestStorage.RefreshedAndModified: boolean;

begin

  result := false; // no refresh necessary with "normal" static tables

end;



procedure TSQLRestStorage.StorageLock(WillModifyContent: boolean);

begin

  if fStorageLockLogTrace then

    InternalLog('StorageLock % %',[fStoredClass,fStorageCriticalSectionCount],sllTrace);

  EnterCriticalSection(fStorageCriticalSection);

  inc(fStorageCriticalSectionCount);

  if WillModifyContent and

     fStorageLockShouldIncreaseOwnerInternalState and (Owner<>nil) then

    inc(Owner.InternalState);

end;



procedure TSQLRestStorage.StorageUnLock;

begin

  dec(fStorageCriticalSectionCount);

  if fStorageLockLogTrace then

    InternalLog('StorageUnlock % %',[fStoredClass,fStorageCriticalSectionCount],sllTrace);

  if fStorageCriticalSectionCount<0 then

    raise EORMException.CreateUTF8('%.StorageUnLock with CS=%',

      [self,fStorageCriticalSectionCount]);

  LeaveCriticalSection(fStorageCriticalSection);

end;



function TSQLRestStorage.GetCurrentSessionUserID: TID;

begin

  if fOwner=nil then

    result := 0 else

    result := fOwner.GetCurrentSessionUserID;

end;



procedure TSQLRestStorage.RecordVersionFieldHandle(Occasion: TSQLOccasion;

  var Decoder: TJSONObjectDecoder);

begin

  if fStoredClassRecordProps.RecordVersionField=nil then

    exit;

  if Owner=nil then

    raise EORMException.CreateUTF8('Owner=nil for %.%: TRecordVersion',

      [fStoredClass,fStoredClassRecordProps.RecordVersionField.Name]);

  Owner.InternalRecordVersionHandle(Occasion,fStoredClassProps.TableIndex,

    Decoder,fStoredClassRecordProps.RecordVersionField);

end;



function TSQLRestStorage.UnLock(Table: TSQLRecordClass; aID: TID): boolean;

begin

  result := Model.UnLock(Table,aID);

end;



function TSQLRestStorage.AdaptSQLForEngineList(var SQL: RawUTF8): boolean;

begin

  if fStoredClassProps=nil then

    result := false else begin

    result := IdemPropNameU(fStoredClassProps.SQL.SelectAllWithRowID,SQL);

    if result then

      SQL := fStoredClassProps.SQL.SelectAllWithID else

      result := IdemPropNameU(fStoredClassProps.SQL.SelectAllWithID,SQL);

  end;

end;



function TSQLRestStorage.GetStoredClassName: RawUTF8;

begin

  if self=nil then

    result := '' else

    ShortStringToAnsi7String(PShortString(PPointer(PtrInt(fStoredClass)+vmtClassName)^)^,result);

end;





{ TSQLRestServerFullMemory }



constructor TSQLRestServerFullMemory.Create(aModel: TSQLModel;

  aHandleUserAuthentication: boolean);

var t: integer;

begin

  inherited Create(aModel,aHandleUserAuthentication);

  fStaticDataCount := length(fModel.Tables);

  SetLength(fStorage,fStaticDataCount);

  for t := 0 to fStaticDataCount-1 do begin

    fStorage[t] := (StaticDataCreate(fModel.Tables[t]) as TSQLRestStorageInMemory);

    fStorage[t].fStorageLockShouldIncreaseOwnerInternalState := true;

  end;

end;



constructor TSQLRestServerFullMemory.Create(aModel: TSQLModel;

  const aFileName: TFileName; aBinaryFile, aHandleUserAuthentication: boolean);

begin

  fFileName := aFileName;

  fBinaryFile := aBinaryFile;

  Create(aModel,aHandleUserAuthentication);

  LoadFromFile;

  CreateMissingTables(0,[]);

end;



constructor TSQLRestServerFullMemory.CreateWithOwnedAuthenticatedModel(

  const Tables: array of TSQLRecordClass; const aUserName,aHashedPassword: RawUTF8;

  aRoot: RawUTF8);

var User: TSQLAuthUser;

begin

  if aRoot='' then

    aRoot := 'root';

  if aUserName='' then

    CreateWithOwnModel(Tables,false,aRoot) else begin

    CreateWithOwnModel(Tables,true,aRoot);

    CreateMissingTables(0,[itoNoAutoCreateUsers]);

    User := TSQLAuthUser.Create;

    try

      User.LogonName := aUserName;

      User.PasswordHashHexa := aHashedPassword;

      User.GroupRights := TSQLAuthGroup(2); // member of 'Supervisor' group

      Add(User,true);

    finally

      User.Free;

    end;

  end;

end;



constructor TSQLRestServerFullMemory.RegisteredClassCreateFrom(aModel: TSQLModel;

  aServerHandleAuthentication: boolean; aDefinition: TSynConnectionDefinition);

begin

  fFileName := UTF8ToString(aDefinition.ServerName);

  fBinaryFile := aDefinition.DatabaseName<>''; // DefinitionTo() set 'binary'

  Create(aModel,aServerHandleAuthentication);

  LoadFromFile;

end;



procedure TSQLRestServerFullMemory.DefinitionTo(Definition: TSynConnectionDefinition);

begin

  if Definition=nil then

    exit;

  inherited; // set Kind

  Definition.ServerName := StringToUTF8(fFileName);

  if fBinaryFile then

    Definition.DatabaseName := 'binary';

end;



procedure TSQLRestServerFullMemory.CreateMissingTables(user_version: cardinal=0;

  Options: TSQLInitializeTableOptions=[]);

var t: integer;

begin

  inherited;

  // create any missing static instances

  if integer(fStaticDataCount)<>length(fModel.Tables) then begin

    SetLength(fStorage,length(fModel.Tables));

    for t := fStaticDataCount to high(fModel.Tables) do begin

      fStorage[t] := (StaticDataCreate(fModel.Tables[t]) as TSQLRestStorageInMemory);

      fStorage[t].fStorageLockShouldIncreaseOwnerInternalState := true;

    end;

    fStaticDataCount := length(fModel.Tables);

  end;

  // initialize new tables

  for t := 0 to fStaticDataCount-1 do

    with TSQLRestStorageInMemory(fStaticData[t]) do

    if Count=0 then // emulates TSQLRestServerDB.CreateMissingTables

      StoredClass.InitializeTable(Self,'',Options);

end;



destructor TSQLRestServerFullMemory.Destroy;

begin

  UpdateToFile;

  inherited;

end;



procedure TSQLRestServerFullMemory.DropDatabase;

var t: integer;

begin

  for t := 0 to fStaticDataCount-1 do

    TSQLRestStorageInMemory(fStaticData[t]).DropValues;

end;



procedure TSQLRestServerFullMemory.LoadFromStream(aStream: TStream);

var JSON: RawUTF8;

    P, TableName, Data: PUTF8Char;

    t: integer;

    wasString: boolean;

begin

  if aStream=nil then

    exit;

  if fBinaryFile then begin

      if ReadStringFromStream(aStream)=RawUTF8(ClassName)+'00' then

      repeat

        t := Model.GetTableIndex(ReadStringFromStream(aStream));

      until (t<0) or

        not TSQLRestStorageInMemory(fStaticData[t]).LoadFromBinary(aStream);

  end else begin // [{"AuthUser":[{....},{...}]},{"AuthGroup":[{...},{...}]}]

    JSON := StreamToRawByteString(aStream); // assume UTF-8 content

    if JSON='' then

      exit;

    P := pointer(JSON);

    while (P^<>'[') do if P^=#0 then exit else inc(P);

    inc(P);

    repeat

      while (P^<>']') and (P^<>'{') do if P^=#0 then exit else inc(P);

      if P^=']' then break else inc(P);

      TableName := GetJSONField(P,P,@wasString);

      if not wasString or (P=nil) then

        exit;

      t := Model.GetTableIndex(TableName);

      if t<0 then

        exit;

      Data := P;

      P := GotoNextJSONObjectOrArray(P);

      if P=nil then

        break else

        TSQLRestStorageInMemory(fStaticData[t]).LoadFromJSON(Data,P-Data);

    until false;

  end;

end;



procedure TSQLRestServerFullMemory.LoadFromFile;

var S: TFileStream;

begin

  if (fFileName='') or not FileExists(fFileName) then

    exit;

  DropDatabase;

  S := FileStreamSequentialRead(FileName);

  try

    LoadFromStream(S);

  finally

    S.Free;

  end;

end;



procedure TSQLRestServerFullMemory.UpdateToFile;

const CHARS: array[0..6] of AnsiChar = '[{":,}]';

var S: TFileStream;                //   0123456

    t: integer;

    Modified: boolean;

    Timer: TPrecisionTimer;

begin

  if (self=nil) or (FileName='') then

    exit;

  Modified := false;

  for t := 0 to fStaticDataCount-1 do

    if TSQLRestStorageInMemory(fStaticData[t]).Modified then begin

      Modified := true;

      break;

    end;

  if not Modified then

    exit;

  Timer.Start;

  S := TFileStream.Create(FileName,fmCreate);

  try

    if fBinaryFile then begin

      WriteStringToStream(S,RawUTF8(ClassName)+'00');

      for t := 0 to fStaticDataCount-1 do

      with TSQLRestStorageInMemory(fStaticData[t]) do begin

        WriteStringToStream(S,fStoredClassRecordProps.SQLTableName);

        SaveToBinary(S);

      end;

    end else begin

      S.Write(CHARS[0],1);

      for t := 0 to fStaticDataCount-1 do

      with TSQLRestStorageInMemory(fStaticData[t]) do begin

        S.Write(CHARS[1],2);

        with fStoredClassRecordProps do

          S.Write(pointer(SQLTableName)^,length(SQLTableName));

        S.Write(CHARS[2],2);

        SaveToJSON(S,true);

        S.Write(CHARS[5],1);

        if t<integer(fStaticDataCount-1) then

          S.Write(CHARS[4],1);

      end;

      S.Write(CHARS[6],1);

    end;

  finally

    S.Free;

  end;

  InternalLog('UpdateToFile done in %',[Timer.Stop],sllDB);

end;



function TSQLRestServerFullMemory.EngineExecute(const aSQL: RawUTF8): boolean;

begin

  result := false; // not implemented in this basic REST server class

end;



procedure TSQLRestServerFullMemory.Flush(Ctxt: TSQLRestServerURIContext);

begin

  if Ctxt.Method=mPUT then begin

    UpdateToFile;

    Ctxt.Success;

  end;

end;



function TSQLRestServerFullMemory.GetStorage(aTable: TSQLRecordClass): TSQLRestStorageInMemory;

var i: cardinal;

begin

  i := fModel.GetTableIndex(aTable);

  if i>=cardinal(length(fStorage)) then

    result := nil else

    result := fStorage[i];

end;



// Engine*() methods will have direct access to static fStorage[])



function TSQLRestServerFullMemory.EngineAdd(TableModelIndex: integer;

  const SentData: RawUTF8): TID;

begin

  result := fStorage[TableModelIndex].EngineAdd(TableModelIndex,SentData);

  InternalState := InternalState+1;

end;



function TSQLRestServerFullMemory.EngineRetrieve(TableModelIndex: integer; ID: TID): RawUTF8;

begin

 result := fStorage[TableModelIndex].EngineRetrieve(TableModelIndex,ID);

end;



function TSQLRestServerFullMemory.EngineUpdate(TableModelIndex: integer; ID: TID;

  const SentData: RawUTF8): boolean;

begin

  result := fStorage[TableModelIndex].EngineUpdate(TableModelIndex,ID,SentData);

end;



function TSQLRestServerFullMemory.EngineDelete(TableModelIndex: integer; ID: TID): boolean;

begin

  result := fStorage[TableModelIndex].EngineDelete(TableModelIndex,ID);

end;



function TSQLRestServerFullMemory.EngineDeleteWhere(TableModelIndex: integer;

  const SQLWhere: RawUTF8; const IDs: TIDDynArray): boolean;

begin

  result := fStorage[TableModelIndex].EngineDeleteWhere(TableModelIndex,SQLWhere,IDs);

end;



function TSQLRestServerFullMemory.EngineRetrieveBlob(TableModelIndex: integer; aID: TID;

  BlobField: PPropInfo; out BlobData: TSQLRawBlob): boolean;

begin

  result := fStorage[TableModelIndex].EngineRetrieveBlob(TableModelIndex,aID,BlobField,BlobData);

end;



function TSQLRestServerFullMemory.EngineUpdateBlob(TableModelIndex: integer; aID: TID;

  BlobField: PPropInfo; const BlobData: TSQLRawBlob): boolean;

begin

  result := fStorage[TableModelIndex].EngineUpdateBlob(TableModelIndex,aID,BlobField,BlobData);

end;



function TSQLRestServerFullMemory.EngineUpdateField(TableModelIndex: integer;

  const SetFieldName, SetValue, WhereFieldName, WhereValue: RawUTF8): boolean;

begin

  result := fStorage[TableModelIndex].EngineUpdateField(TableModelIndex,

    SetFieldName,SetValue,WhereFieldName,WhereValue);

end;



function TSQLRestServerFullMemory.EngineUpdateFieldIncrement(TableModelIndex: integer;

  ID: TID; const FieldName: RawUTF8; Increment: Int64): boolean;

begin

  result := fStorage[TableModelIndex].EngineUpdateFieldIncrement(TableModelIndex,

    ID,FieldName,Increment);

end;



// MainEngine*() methods should return error (only access via static fStorage[])



function TSQLRestServerFullMemory.MainEngineAdd(TableModelIndex: integer;

  const SentData: RawUTF8): TID;

begin

  result := 0;

end;



function TSQLRestServerFullMemory.MainEngineRetrieve(TableModelIndex: integer;

  ID: TID): RawUTF8;

begin

  result := '';

end;



function TSQLRestServerFullMemory.MainEngineList(const SQL: RawUTF8;

  ForceAJAX: Boolean; ReturnedRowCount: PPtrInt): RawUTF8;

begin

  result := '';

end;



function TSQLRestServerFullMemory.MainEngineUpdate(TableModelIndex: integer; aID: TID;

  const SentData: RawUTF8): boolean;

begin

  result := false;

end;



function TSQLRestServerFullMemory.MainEngineDelete(TableModelIndex: integer; ID: TID): boolean;

begin

  result := false;

end;



function TSQLRestServerFullMemory.MainEngineDeleteWhere(TableModelIndex: integer;

  const SQLWhere: RawUTF8; const IDs: TIDDynArray): boolean;

begin

  result := false;

end;



function TSQLRestServerFullMemory.MainEngineRetrieveBlob(TableModelIndex: integer; aID: TID;

  BlobField: PPropInfo; out BlobData: TSQLRawBlob): boolean;

begin

  result := false;

end;



function TSQLRestServerFullMemory.MainEngineUpdateBlob(TableModelIndex: integer; aID: TID;

  BlobField: PPropInfo; const BlobData: TSQLRawBlob): boolean;

begin

  result := false;

end;



function TSQLRestServerFullMemory.MainEngineUpdateField(TableModelIndex: integer;

  const SetFieldName, SetValue, WhereFieldName, WhereValue: RawUTF8): boolean;

begin

  result := false;

end;



function TSQLRestServerFullMemory.MainEngineUpdateFieldIncrement(

  TableModelIndex: integer; ID: TID; const FieldName: RawUTF8; Increment: Int64): boolean;

begin

  result := false;

end;





{ TSQLRestServerRemoteDB }



constructor TSQLRestServerRemoteDB.Create(aRemoteRest: TSQLRest;

  aHandleUserAuthentication: boolean);

var i: integer;

begin

  if aRemoteRest=nil then

    raise EORMException.CreateUTF8('%.Create(nil)',[self]);

  inherited Create(aRemoteRest.Model,aHandleUserAuthentication);

  SetLength(fRemoteTableIndex,Model.TablesMax+1);

  for i := 0 to Model.TablesMax do

    fRemoteTableIndex[i] := aRemoteRest.Model.GetTableIndexExisting(Model.Tables[i]);

  fRemoteRest := aRemoteRest;

end;



function TSQLRestServerRemoteDB.EngineAdd(TableModelIndex: integer;

  const SentData: RawUTF8): TID;

begin

  result := fRemoteRest.EngineAdd(fRemoteTableIndex[TableModelIndex],SentData);

end;



function TSQLRestServerRemoteDB.EngineDelete(TableModelIndex: integer; ID: TID): boolean;

begin

  result := fRemoteRest.EngineDelete(fRemoteTableIndex[TableModelIndex],ID);

end;



function TSQLRestServerRemoteDB.EngineDeleteWhere(TableModelIndex: Integer;

  const SQLWhere: RawUTF8; const IDs: TIDDynArray): boolean;

begin

  result := fRemoteRest.EngineDeleteWhere(fRemoteTableIndex[TableModelIndex],SQLWhere,IDs);

end;



function TSQLRestServerRemoteDB.EngineExecute(const aSQL: RawUTF8): boolean;

begin

  result := fRemoteRest.EngineExecute(aSQL);

end;



function TSQLRestServerRemoteDB.EngineList(const SQL: RawUTF8;

  ForceAJAX: Boolean; ReturnedRowCount: PPtrInt): RawUTF8;

begin

  result := fRemoteRest.EngineList(SQL,ForceAJAX,ReturnedRowCount);

end;



function TSQLRestServerRemoteDB.EngineRetrieve(TableModelIndex: integer; ID: TID): RawUTF8;

begin

  result := fRemoteRest.EngineRetrieve(fRemoteTableIndex[TableModelIndex],ID);

end;



function TSQLRestServerRemoteDB.EngineRetrieveBlob(TableModelIndex: integer; aID: TID;

  BlobField: PPropInfo; out BlobData: TSQLRawBlob): boolean;

begin

  if (self=nil) or (BlobField=nil) then

    result := false else

    result := fRemoteRest.EngineRetrieveBlob(fRemoteTableIndex[TableModelIndex],aID,BlobField,BlobData);

end;



function TSQLRestServerRemoteDB.EngineUpdate(TableModelIndex: integer;

  ID: TID; const SentData: RawUTF8): boolean;

begin

  result := fRemoteRest.EngineUpdate(fRemoteTableIndex[TableModelIndex],ID,SentData);

end;



function TSQLRestServerRemoteDB.EngineUpdateBlob(TableModelIndex: integer; aID: TID;

  BlobField: PPropInfo; const BlobData: TSQLRawBlob): boolean;

begin

  if (self=nil) or (BlobField=nil) then

    result := false else

    result := fRemoteRest.EngineUpdateBlob(fRemoteTableIndex[TableModelIndex],aID,BlobField,BlobData);

end;



function TSQLRestServerRemoteDB.EngineUpdateField(TableModelIndex: integer;

  const SetFieldName, SetValue, WhereFieldName, WhereValue: RawUTF8): boolean;

begin

  result := fRemoteRest.EngineUpdateField(fRemoteTableIndex[TableModelIndex],SetFieldName,SetValue,WhereFieldName,WhereValue);

end;



function TSQLRestServerRemoteDB.EngineUpdateFieldIncrement(TableModelIndex: integer;

  ID: TID; const FieldName: RawUTF8; Increment: Int64): boolean;

begin

  result := fRemoteRest.EngineUpdateFieldIncrement(fRemoteTableIndex[TableModelIndex],

    ID,FieldName,Increment);

end;



function TSQLRestServerRemoteDB.AfterDeleteForceCoherency(TableIndex: integer;

  aID: TID): boolean;

begin

  result := true; // coherency will be performed on the server side

end;





{ TSQLRestClient }



function TSQLRestClient.GetForceBlobTransfert: Boolean;

var i: integer;

begin

  result := false;

  if fForceBlobTransfert=nil then

    exit;

  for i := 0 to fModel.fTablesMax do

    if not fForceBlobTransfert[i] then

      exit;

  result := true; // all Tables have BLOB transfert set

end;



procedure TSQLRestClient.SetForceBlobTransfert(Value: boolean);

var i: integer;

begin

  Finalize(fForceBlobTransfert);

  if Value then begin

    SetLength(fForceBlobTransfert,fModel.fTablesMax+1);

    for i := 0 to fModel.fTablesMax do

      fForceBlobTransfert[i] := true;

  end;

end;



function TSQLRestClient.GetForceBlobTransfertTable(aTable: TSQLRecordClass): Boolean;

begin

  if fForceBlobTransfert=nil then

    result := false else

    result := fForceBlobTransfert[fModel.GetTableIndexExisting(aTable)];

end;



procedure TSQLRestClient.SetForceBlobTransfertTable(aTable: TSQLRecordClass; aValue: Boolean);

var i: integer;

begin

  i := fModel.GetTableIndexExisting(aTable);

  if fForceBlobTransfert=nil then

    if aValue then

      SetLength(fForceBlobTransfert,fModel.fTablesMax+1) else

      exit; // nothing to set

  fForceBlobTransfert[i] := aValue;

end;



function TSQLRestClient.InternalAdd(Value: TSQLRecord; SendData: boolean;

  CustomFields: PSQLFieldBits; ForceID, DoNotAutoComputeFields: boolean): TID;

begin

  result := inherited InternalAdd(Value,SendData,CustomFields,ForceID,DoNotAutoComputeFields);

  if (result>0) and (fForceBlobTransfert<>nil) and

     fForceBlobTransfert[fModel.GetTableIndexExisting(PSQLRecordClass(Value)^)] then

     UpdateBlobFields(Value);

end;



function TSQLRestClient.EngineRetrieve(TableModelIndex: integer; ID: TID): RawUTF8;

var dummy: cardinal;

begin

  if not ClientRetrieve(TableModelIndex,ID,false,dummy,result) then

    result := '';

end;



function TSQLRestClient.Retrieve(aID: TID; Value: TSQLRecord;

  ForUpdate: boolean=false): boolean;

var Resp: RawUTF8;

    TableIndex: integer;

begin

  result := false;

  if (self=nil) or (aID<=0) or (Value=nil) then

    exit;

  TableIndex := Model.GetTableIndexExisting(PSQLRecordClass(Value)^);

  if ForUpdate then begin

    if not Model.Lock(TableIndex,aID) then

      exit; // error marking as locked by the client

  end else begin

    Resp := fCache.Retrieve(TableIndex,aID);

    if Resp<>'' then begin

      Value.FillFrom(Resp);

      Value.fID := aID; // JSON object may not contain the ID

      result := true;

      exit; // fast retrieved from internal Client cache (BLOBs ignored)

  end;

  end;

  try

    if ClientRetrieve(TableIndex,aID,ForUpdate,Value.fInternalState,Resp) then begin

      if not ForUpdate then

        fCache.Notify(TableIndex,aID,Resp,soSelect);

      Value.FillFrom(Resp);

      Value.fID := aID; // JSON object may not contain the ID

      if (fForceBlobTransfert<>nil) and fForceBlobTransfert[TableIndex] then

        result := RetrieveBlobFields(Value) else

        result := true;

      ForUpdate := false; // any exception shall unlock the record

    end;

  finally

    if ForUpdate then

      Model.UnLock(TableIndex,aID);

  end;

end;



function TSQLRestClient.Update(Value: TSQLRecord; const CustomFields: TSQLFieldBits;

  DoNotAutoComputeFields: boolean): boolean;

begin

  result := BeforeUpdateEvent(Value) and

    inherited Update(Value,CustomFields,DoNotAutoComputeFields);

  if result then begin

    if (fForceBlobTransfert<>nil) and IsZero(CustomFields) and

       fForceBlobTransfert[Model.GetTableIndexExisting(PSQLRecordClass(Value)^)] then

      result := UpdateBlobFields(Value);

    if result and assigned(OnRecordUpdate) then

      OnRecordUpdate(Value);

  end;

end;



function TSQLRestClient.BeforeUpdateEvent(Value: TSQLRecord): Boolean;

begin

  Result := true; // by default, just allow the update to proceed

end;



function TSQLRestClient.Refresh(aID: TID; Value: TSQLRecord;

  var Refreshed: boolean): boolean;

var Resp, Original: RawUTF8;

begin

  result := false;

  if (aID>0) and (self<>nil) and (Value<>nil) then

    if ClientRetrieve(Model.GetTableIndexExisting(PSQLRecordClass(Value)^),aID,False,

       Value.fInternalState,Resp) then begin

      Original := Value.GetJSONValues(IsNotAjaxJSON(pointer(Resp)),true,soSelect);

      Resp := trim(Resp);

      if (Resp<>'') and (Resp[1]='[') then // '[{....}]' -> '{...}'

        Resp := copy(Resp,2,length(Resp)-2);

      if Original<>Resp then begin // did the content really change?

        Refreshed := true;

        Value.FillFrom(Resp);

      end;

      result := true;

    end;

end;



procedure TSQLRestClient.Commit(SessionID: cardinal; RaiseException: boolean);

begin

  inherited Commit(SessionID,RaiseException);

end;



function TSQLRestClient.TransactionBegin(aTable: TSQLRecordClass;

  SessionID: cardinal): boolean;

begin

  result := inherited TransactionBegin(aTable,SessionID);

end;



procedure TSQLRestClient.RollBack(SessionID: cardinal);

begin

  inherited;

end;



function TSQLRestClient.ListFmt(const Tables: array of TSQLRecordClass; const SQLSelect: RawUTF8;

  const SQLWhereFormat: RawUTF8; const Args: array of const): TSQLTableJSON;

begin

  result := List(Tables,SQLSelect,FormatUTF8(SQLWhereFormat,Args));

end;



function TSQLRestClient.ListFmt(const Tables: array of TSQLRecordClass;

  const SQLSelect: RawUTF8; const SQLWhereFormat: RawUTF8;

  const Args, Bounds: array of const): TSQLTableJSON;

begin

  result := List(Tables,SQLSelect,FormatUTF8(SQLWhereFormat,Args,Bounds));

end;



function TSQLRestClient.RTreeMatch(DataTable: TSQLRecordClass;

  const DataTableBlobFieldName: RawUTF8; RTreeTable: TSQLRecordRTreeClass;

  const DataTableBlobField: RawByteString; var DataID: TIDDynArray): boolean;

var Blob: PPropInfo;

    Res: TSQLTableJSON;

    B: TSQLRecordTreeCoords;

    Where: RawUTF8;

    Data, RTree: TSQLRecordProperties;

    i: integer;

begin

  result := false;

  if (self=nil) or (DataTable=nil) or (RTreeTable=nil) or (DataTableBlobField='') then

    exit;

  RTree := RTreeTable.RecordProps;

  Data := DataTable.RecordProps;

  Blob :=  Data.BlobFieldPropFromRawUTF8(DataTableBlobFieldName);

  if Blob=nil then

    exit;

  for i := 0 to (RTree.Fields.Count shr 1)-1 do

    Where := FormatUTF8('%% >= :(%): AND % <= :(%): AND ',

      [Where,RTree.Fields.List[i*2].Name,B[i].Min,RTree.Fields.List[i*2+1].Name,

       B[i].Max]);

  RTreeTable.BlobToCoord(DataTableBlobField[1],B);

  Res := ListFmt([DataTable,RTreeTable],Data.SQLTableName+'.RowID',

    'WHERE %.RowID=%.RowID AND %%(%,:(%):);',

      [Data.SQLTableName,RTree.SQLTableName,Where,

       RTreeTable.RTreeSQLFunctionName,Data.SQLTableName,

       BinToBase64WithMagic(DataTableBlobField)]);

  if Res<>nil then

  try

    if (Res.FieldCount<>1) or (Res.fRowCount<=0) then

      exit;

    Res.GetRowValues(0,TInt64DynArray(DataID));

    result := true;

  finally

    Res.Free;

  end;

end;



function TSQLRestClient.ServiceContainer: TServiceContainer;

begin

  if fServices=nil then

    fServices := TServiceContainerClient.Create(self);

  result := fServices;

end;





{ TSQLRecordLog }



destructor TSQLRecordLog.Destroy;

begin

  fLogTableWriter.Free;

  fLogTableStorage.Free;

  inherited;

end;



constructor TSQLRecordLog.CreateFrom(OneLog: TSQLRecord; const aJSON: RawUTF8);

var L,FieldCount: integer;

    P: PUTF8Char;

begin

  inherited Create;

  L := length(aJSON);

  if (L<10) or (Copy(aJSON,L-1,2)<>']}') then

    exit;

  fLogTableStorage := THeapMemoryStream.Create;

  fLogTableWriter := OneLog.RecordProps.CreateJSONWriter(

    fLogTableStorage,false,true,ALL_ACCESS_RIGHTS,0);

  fLogTableWriter.FlushToStream;

  P := pointer(aJSON);

  if not CompareMem(fLogTableStorage.Memory,P,fLogTableStorage.Position) or

     not IsNotExpandedBuffer(P,P+length(aJSON),FieldCount,fLogTableRowCount) or

     (fLogTableRowCount<0) then begin

    // field format changed or invalid

    FreeAndNil(fLogTableWriter);

    FreeAndNil(fLogTableStorage);

    exit;

  end;

  fLogTableStorage.Seek(0,soFromBeginning);

  fLogTableStorage.Write(Pointer(aJSON)^,L-2);

end;



procedure TSQLRecordLog.Log(OneLog: TSQLRecord);

begin

  if OneLog=nil then

    exit;

  // simulate adding a row: compute new ID

  inc(OneLog.fID);

  // adding a row, in not-expanded format

  if not Assigned(fLogTableStorage) then begin

    fLogTableStorage := THeapMemoryStream.Create;

    fLogTableWriter := OneLog.RecordProps.CreateJSONWriter(

      fLogTableStorage,false,true,ALL_ACCESS_RIGHTS,0);

    fLogTableRowCount := 1;

  end else begin

    fLogTableWriter.Add(',');

    if (fMaxLogTableRowCount<>0) and (fLogTableRowCount>=fMaxLogTableRowCount) then

      fLogTableWriter.TrimFirstRow else

      inc(fLogTableRowCount);

  end;

  OneLog.GetJSONValues(fLogTableWriter)

end;



function TSQLRecordLog.LogCurrentPosition: integer;

begin

  if not Assigned(fLogTableStorage) then

    result := 0 else begin

    fLogTableWriter.FlushToStream;

    result := fLogTableStorage.Position;

  end;

end;



function TSQLRecordLog.LogTableJSON: RawUTF8;

begin

  result := LogTableJSONFrom(0);

end;



function TSQLRecordLog.LogTableJSONFrom(StartPosition: integer): RawUTF8;

var JSONStart: RawUTF8;

    Data: PAnsiChar;

begin

  if not Assigned(fLogTableStorage) or (StartPosition<0) then

    result := '' else begin

    fLogTableWriter.FlushToStream;

    Data := fLogTableStorage.Memory;

    SetString(result,Data+StartPosition,fLogTableStorage.Position-StartPosition);

    // format as valid not expanded JSON table content:

    if StartPosition<>0 then begin

      SetString(JSONStart,Data,fLogTableWriter.StartDataPosition);

      result := JSONStart+result;

    end;

    result := result+']}';

  end;

end;





{ RecordRef }



function RecordReference(Model: TSQLModel; aTable: TSQLRecordClass; aID: TID): TRecordReference;

begin

  if aID=0 then

    result := 0 else begin

    result := Model.GetTableIndexExisting(aTable);

    if result>63 then // TRecordReference handle up to 64=1 shl 6 tables

      result := 0 else

      inc(result,aID shl 6); // 64=1 shl 6

  end;

end;



function RecordReference(aTableIndex: cardinal; aID: TID): TRecordReference;

begin

  if (aID=0) or (aTableIndex>63) then

    result := 0 else

    result := aTableIndex+aID shl 6;

end;



procedure RecordRefToID(var aArray: TInt64DynArray);

var i: Integer;

begin

  for i := 0 to high(aArray) do

    aArray[i] := aArray[i] shr 6;

end;



procedure RecordRef.From(Model: TSQLModel; aTable: TSQLRecordClass; aID: TID);

begin

  Value := Model.GetTableIndexExisting(aTable);

  if Value>63 then // TRecordReference handle up to 64=1 shl 6 tables

    Value := 0 else

    inc(Value,aID shl 6); // 64=1 shl 6

end;



function RecordRef.ID: TID;

begin

  result := Value shr 6;  // 64=1 shl 6

end;



function RecordRef.Table(Model: TSQLModel): TSQLRecordClass;

var V: integer;

begin

  if (Model=nil) or (Value=0) then

    result := nil else begin

    V := Value and 63;

    if V>Model.TablesMax then

      result := nil else

      result := Model.Tables[V];

  end;

end;



function RecordRef.TableIndex: integer;

begin

  result := Value and 63;

end;



function RecordRef.Text(Model: TSQLModel): RawUTF8;

var aTable: TSQLRecordClass;

begin

  if ((Value shr 6)=0) then

    // Value=0 or no valid ID

    result := '' else begin

    aTable := Table(Model);

    if aTable=nil then

      result := '' else

      result := Model.TableProps[Value and 63].Props.SQLTableName+

        ' '+Int64ToUtf8(Value shr 6);

  end;

end;



function RecordRef.Text(Rest: TSQLRest): RawUTF8;

var T: TSQLRecordClass;

    aID: TID;

begin

  result := '';

  if ((Value shr 6)=0) or (Rest=nil) then

    exit;

  T := Table(Rest.Model);

  if T=nil then

    exit;

  aID := ID;

  with Rest.Model.TableProps[Value and 63].Props do

  if aID<=0 then

    result := SQLTableName else begin

    result := Rest.MainFieldValue(T,aID,true);

    if result='' then

      FormatUTF8('% %',[SQLTableName,aID],result) else

      result := FormatUTF8('% "%"',[SQLTableName,result]);

  end;

end;





{ TSQLLocks }



function TSQLLocks.isLocked(aID: TID): boolean;

begin

  result := (@self<>nil) and (Count<>0) and (aID<>0) and

    Int64ScanExists(pointer(IDs),Count,aID);

end;



function TSQLLocks.Lock(aID: TID): boolean;

var P: PInt64;

begin

  if (@self=nil) or (aID=0) then

    // void or full

    result := false else begin

    P := Int64Scan(pointer(IDs),Count,aID);

    if P<>nil then

      // already locked

      result := false else begin

      // add to ID[] and Ticks[]

      P := Int64Scan(pointer(IDs),Count,0);

      if P=nil then begin

        // no free entry -> add at the end

        if Count>=length(IDs) then begin

          SetLength(IDs,Count+512);

          SetLength(Ticks64s,Count+512);

        end;

        IDs[Count] := aID;

        Ticks64s[Count] := GetTickCount64;

        inc(Count);

      end else begin

        // store at free entry

        P^ := aID;

        Ticks64s[(PtrUInt(P)-PtrUInt(IDs))shr 3] := GetTickCount64;

      end;

      result := true;

    end;

  end;

end;



procedure TSQLLocks.PurgeOlderThan(MinutesFromNow: cardinal);

var LastOK64: Int64;

    i, LastEntry: integer;

begin

  if (@self=nil) or (Count=0) then

    exit; // nothing to purge

  LastOK64 := GetTickCount64-MinutesFromNow*(1000*60); // GetTickCount64() unit is ms

  LastEntry := -1;

  for i := 0 to Count-1 do

    if IDs[i]<>0 then

    if Ticks64s[i]<LastOK64 then // too old?

      IDs[i] := 0 else // 0 frees entry

      LastEntry := i; // refresh last existing entry

  Count := LastEntry+1; // update count (may decrease list length)

end;



function TSQLLocks.UnLock(aID: TID): boolean;

var P: PInt64;

begin

  if (@self=nil) or (Count=0) or (aID=0) then

    result := false else begin

    P := Int64Scan(pointer(IDs),Count,aID);

    if P=nil then

      result := false else begin

      P^ := 0; // 0 marks free entry

      if ((PtrUInt(P)-PtrUInt(IDs))shr 3>=PtrUInt(Count-1)) then

        dec(Count); // freed last entry -> decrease list length

      result := true;

    end;

  end;

end;





procedure CopyObject(aFrom, aTo: TObject);

var P,P2: PPropInfo;

    i: integer;

    C,C2: TClass;

begin

  if (aFrom=nil) or (aTo=nil) then

    exit;

  {$ifndef LVCL}

  if aFrom.InheritsFrom(TCollection) then begin

    CopyCollection(TCollection(aFrom),TCollection(aTo));

    exit;

  end;

  {$endif}

  if aFrom.InheritsFrom(TStrings) then begin

    if aTo.InheritsFrom(TStrings) then

      CopyStrings(TStrings(aFrom),TStrings(aTo));

    exit;

  end;

  C := aFrom.ClassType;

  C2 := aTo.ClassType;

  if C2.InheritsFrom(C) then

    repeat // fast process of inherited PPropInfo

      for i := 1 to InternalClassPropInfo(C,P) do begin

        P^.CopyValue(aFrom,aTo);

        P := P^.Next;

      end;

      C := C.ClassParent;

    until C=TObject else

  if C.InheritsFrom(C2) then

    repeat // fast process of inherited PPropInfo

      for i := 1 to InternalClassPropInfo(C2,P) do begin

        P^.CopyValue(aFrom,aTo);

        P := P^.Next;

      end;

      C2 := C2.ClassParent;

    until C2=TObject else

    repeat // slower lookup by property name

      for i := 1 to InternalClassPropInfo(C,P) do begin

        P2 := ClassFieldPropWithParents(C2,P^.Name);

        if P2<>nil then

          P^.CopyValue(aFrom,aTo,P2);

        P := P^.Next;

      end;

      C := C.ClassParent;

    until C=TObject;

end;



function CopyObject(aFrom: TObject): TObject; 

var DInst: TClassInstance;

begin

  if aFrom=nil then begin

    result := nil;

    exit;

  end;

  DInst.Init(aFrom.ClassType);

  result := DInst.CreateNew;

  try

    CopyObject(aFrom,result);

  except

    FreeAndNil(result); // avoid memory leak if error during new instance copy

  end;

end;



{$ifndef LVCL}

procedure CopyCollection(Source, Dest: TCollection);

var i: integer;

begin

  if (Source=nil) or (Dest=nil) or (Source.ClassType<>Dest.ClassType) then

    exit;

  Dest.BeginUpdate;

  try

    Dest.Clear;

    for i := 0 to Source.Count-1 do

      CopyObject(Source.Items[i],Dest.Add); // Assign() fails for most objects

  finally

    Dest.EndUpdate;

  end;

end;

{$endif}



procedure CopyStrings(Source, Dest: TStrings);

begin

  if (Source=nil) or (Dest=nil) then

    exit;

  {$ifdef LVCL}

  Dest.Clear;

  Dest.AddStrings(Source);

  {$else}

  Dest.Assign(Source);

  {$endif}

end;



procedure WriteObject(Value: TObject; var IniContent: RawUTF8; const Section: RawUTF8;

  const SubCompName: RawUTF8=''); overload;

var P: PPropInfo;

    i, V: integer;

    Obj: TObject;

    tmp: RawUTF8;

begin

  if Value=nil then

    exit;

  for i := 1 to InternalClassPropInfo(Value.ClassType,P) do begin

    case P^.PropType^.Kind of

      tkInt64{$ifdef FPC}, tkQWord{$endif}:

        UpdateIniEntry(IniContent,Section,SubCompName+ToUTF8(P^.Name),

          Int64ToUtf8(P^.GetInt64Prop(Value)));

      {$ifdef FPC}tkBool,{$endif} tkEnumeration, tkSet, tkInteger: begin

        V := P^.GetOrdProp(Value);

        //if V<>P^.Default then NO DEFAULT: update INI -> must override previous

        UpdateIniEntry(IniContent,Section,SubCompName+ToUTF8(P^.Name),

          Int32ToUtf8(V));

      end;

      {$ifdef HASVARUSTRING}tkUString,{$endif} {$ifdef FPC}tkAString,{$endif}

      tkLString, tkWString: begin

        P^.GetLongStrValue(Value,tmp);

        UpdateIniEntry(IniContent,Section,SubCompName+ToUTF8(P^.Name),tmp);

      end;

      tkClass:

      if Section='' then begin // recursive call works only as plain object

        Obj := P^.GetObjProp(Value);

        if (Obj<>nil) and Obj.InheritsFrom(TPersistent) then

          WriteObject(Value,IniContent,Section,SubCompName+ToUTF8(P^.Name)+'.');

      end;

      // tkString (shortstring) and tkInterface are not handled

    end;

    P := P^.Next;

  end;

end;



function WriteObject(Value: TObject): RawUTF8; overload;

begin

  if Value<>nil then

    with TIniWriter.CreateOwnedStream do

    try

      WriteObject(Value,'');

      SetText(result);

    finally

      Free;

    end else

    result := '';

end;



function ObjectEquals(Value1,Value2: TObject; ignoreGetterFields: boolean): boolean;

var i: integer;

    C1,C2: TClass;

    P1,P2: PPropInfo;

begin

  if (Value1=nil) or (Value2=nil) then

    result := Value1=Value2 else

  if Value1.InheritsFrom(TSQLRecord) and Value2.InheritsFrom(TSQLRecord) then

    result := TSQLRecord(Value1).SameValues(TSQLRecord(Value2)) else begin

    result := false;

    C1 := Value1.ClassType;

    C2 := Value2.ClassType;

    repeat

      for i := 1 to InternalClassPropInfo(C1,P1) do begin

        if (not ignoreGetterFields) or P1^.GetterIsField then

          if C2<>C1 then begin

            P2 := ClassFieldPropWithParents(C2,P1^.Name);

            if (P2=nil) or not P1^.SameValue(Value1,P2,Value2) then

              exit;

          end else

            if not P1^.SameValue(Value1,P1,Value2) then

              exit;

        P1 := P1^.Next;

      end;

      C1 := C1.ClassParent;

    until C1=nil;

    result := true;

  end;

end;



function ObjectToJSONDebug(Value: TObject): RawUTF8;

begin

  if Value=nil then

    result := 'null' else

  if Value.InheritsFrom(Exception) and not Value.InheritsFrom(ESynException) then

    result := FormatUTF8('{"%":?}',[Value],[Exception(Value).Message],True) else

    result := ObjectToJSON(Value,

      [woDontStoreDefault,woHumanReadable,woStoreClassName,woStorePointer]);

end;



function ObjectToVariantDebug(Value: TObject): variant;

var json: RawUTF8;

begin

  VarClear(result);

  json := ObjectToJSONDebug(Value);

  PDocVariantData(@result)^.InitJSONInPlace(pointer(json),JSON_OPTIONS_FAST);

end;



procedure _ObjAddProps(Value: TObject; var Obj: variant);

var v: variant;

begin

  ObjectToVariant(Value,v,[woDontStoreDefault]);

  _ObjAddProps(v,Obj);

end;



function ObjectToVariantDebug(Value: TObject;

  const ContextFormat: RawUTF8; const ContextArgs: array of const;

  const ContextName: RawUTF8): variant;

begin

  _Json(ObjectToJSONDebug(Value),result,JSON_OPTIONS_FAST);

  if ContextFormat<>'' then

    if ContextFormat[1]='{' then

      _ObjAddProps([ContextName,_JsonFastFmt(ContextFormat,[],ContextArgs)],result) else

      _ObjAddProps([ContextName,FormatUTF8(ContextFormat,ContextArgs)],result);

end;



var

  JSONCustomParsers: array of record

    Kind: TClass;

    Reader: TJSONSerializerCustomReader;

    Writer: TJSONSerializerCustomWriter;

  end;



type

  TJSONCustomParserExpectedDirection = (cpRead, cpWrite);

  TJSONCustomParserExpectedDirections = set of TJSONCustomParserExpectedDirection;



function JSONCustomParsersIndex(aClass: TClass;

  aExpectedReadWriteTypes: TJSONCustomParserExpectedDirections): integer;

  {$ifdef HASINLINE}inline;{$endif}

begin

  if JSONCustomParsers<>nil then

    for result := 0 to length(JSONCustomParsers)-1 do

      with JSONCustomParsers[result] do

      if Kind=aClass then

        if ((cpRead in aExpectedReadWriteTypes) and not Assigned(Reader)) or

           ((cpWrite in aExpectedReadWriteTypes) and not Assigned(Writer)) then

          break // any (un)serializer callbacks missing

        else

          exit; // found with appropriate (un)serializers callbacks

  result := -1;

end;



class procedure TJSONSerializer.RegisterCustomSerializer(aClass: TClass;

  aReader: TJSONSerializerCustomReader; aWriter: TJSONSerializerCustomWriter);

var i: integer;

begin

  i := JSONCustomParsersIndex(aClass,[]);

  if i<0 then begin

    i := length(JSONCustomParsers);

    SetLength(JSONCustomParsers,i+1);

  end;

  with JSONCustomParsers[i] do begin

    Kind := aClass;

    Writer := aWriter;

    Reader := aReader;

  end;

end;



constructor TJSONSerializerRegisteredClassAbstract.Create;

begin

  inherited Create;

  fSafe.Init;

end;



destructor TJSONSerializerRegisteredClassAbstract.Destroy;

begin

  inherited;

  fSafe.Done;

end;



function TJSONSerializerRegisteredClass.Find(JSON: PUTF8Char; AndRegisterClass: boolean): TClass;

var token: shortstring;

    ClassNameValue: PUTF8Char;

    ClassNameLen: integer;

begin // at input, JSON^='{'

  result := nil;

  if self=nil then

    exit;

  inc(JSON);

  GetJSONPropName(JSON,token);

  if (JSON=nil) or not IdemPropName('ClassName',token) then

    exit; // we expect woStoreClassName option to have been used

  if JSONRetrieveStringField(JSON,ClassNameValue,ClassNameLen,false)=nil then

    exit; //invalid JSON string value

  fSafe.Lock;

  try

    if (fLastClass<>nil) and

       IdemPropName(PShortString(PPointer(PtrInt(fLastClass)+vmtClassName)^)^,

       ClassNameValue,ClassNameLen) then begin

      result := fLastClass; // for speed-up e.g. within a loop

      exit;

    end;

    result := Find(ClassNameValue,ClassNameLen);

    if result=nil then begin // not registered here -> try from Classes.pas

      {$ifndef LVCL}

      if AndRegisterClass then

        result := FindClass(UTF8DecodeToString(ClassNameValue,ClassNameLen));

      if result=nil then

      {$endif}

        exit; // unknown type

    end;

    fLastClass  := result;

  finally

    fSafe.UnLock;

  end;

end;



procedure TJSONSerializerRegisteredClass.AddOnce(aItemClass: TClass);

begin

  fSafe.Lock;

  try

    if not PtrUIntScanExists(pointer(List),Count,PtrUInt(aItemClass)) then

      Add(aItemClass);

  finally

    fSafe.UnLock;

  end;

end;



function TJSONSerializerRegisteredClass.Find(aClassName: PUTF8Char; aClassNameLen: integer): TClass;

var i: integer;

begin

  result := nil;

  fSafe.Lock;

  try

    for i := 0 to Count-1 do

      // new TObject.ClassName is UnicodeString (since Delphi 20009) -> inline code

      // with vmtClassName = UTF-8 encoded text stored in a shortstring = -44

      if IdemPropName(PShortString(PPointer(PtrInt(List[i])+vmtClassName)^)^,

         aClassName,aClassNameLen) then begin

        result := List[i];

        exit;

      end;

  finally

    fSafe.UnLock;

  end;

end;





{$ifndef LVCL}

type

  TJSONSerializerRegisteredCollection = class(TJSONSerializerRegisteredClassAbstract)

  protected

  public

    procedure AddOnce(aCollection: TCollectionClass; aItem: TCollectionItemClass);

    function Find(aCollClassName: PUTF8Char; aCollClassNameLen: integer): TCollectionItemClass; overload;

    function Find(aCollection: TCollectionClass): TCollectionItemClass; overload;

  end;



function TJSONSerializerRegisteredCollection.Find(aCollection: TCollectionClass): TCollectionItemClass;

var i: integer;

begin

  result := nil;

  if self=nil then

    exit;

  fSafe.Lock;

  try

    for i := 0 to (Count shr 1)-1 do

      if TClass(List[i*2])=aCollection then begin

        result := List[i*2+1];

        exit;

      end;

  finally

    fSafe.UnLock;

  end;

end;



procedure TJSONSerializerRegisteredCollection.AddOnce(aCollection: TCollectionClass; aItem: TCollectionItemClass);

begin

  if (self=nil) or (Find(aCollection)<>nil) then

    exit;

  fSafe.Lock;

  try

    Add(aCollection);

    Add(aItem);

  finally

    fSafe.UnLock;

  end;

end;



function TJSONSerializerRegisteredCollection.Find(aCollClassName: PUTF8Char;

  aCollClassNameLen: integer): TCollectionItemClass;

var i: integer;

begin

  result := nil;

  fSafe.Lock;

  try

    for i := 0 to (Count shr 1)-1 do

      // new TObject.ClassName is UnicodeString (since Delphi 20009) -> inline code

      // with vmtClassName = UTF-8 encoded text stored in a shortstring = -44

      if IdemPropName(PShortString(PPointer(PtrInt(List[i*2])+vmtClassName)^)^,

         aCollClassName,aCollClassNameLen) then begin

        result := List[i*2+1];

        exit;

      end;

  finally

    fSafe.UnLock;

  end;

end;



var

  JSONSerializerRegisteredCollection: TJSONSerializerRegisteredCollection=nil;



class procedure TJSONSerializer.RegisterCollectionForJSON(aCollection: TCollectionClass;

  aItem: TCollectionItemClass);

begin

  if JSONSerializerRegisteredCollection=nil then

    GarbageCollectorFreeAndNil(JSONSerializerRegisteredCollection,

      TJSONSerializerRegisteredCollection.Create);

  JSONSerializerRegisteredCollection.AddOnce(aCollection,aItem);

  RegisterClassForJSON([aCollection,aItem]);

end;



{$endif LVCL}



class procedure TJSONSerializer.RegisterClassForJSON(aItemClass: TClass);

begin

  if JSONSerializerRegisteredClass=nil then

    GarbageCollectorFreeAndNil(JSONSerializerRegisteredClass,

      TJSONSerializerRegisteredClass.Create);

  JSONSerializerRegisteredClass.AddOnce(aItemClass);

end;



class procedure TJSONSerializer.RegisterClassForJSON(const aItemClass: array of TClass);

var i: integer;

begin

  for i := 0 to high(aItemClass) do

    RegisterClassForJSON(aItemClass[i]);

end;



class procedure TJSONSerializer.RegisterObjArrayForJSON(aDynArray: PTypeInfo;

  aItem: TClass);

var serializer: ^TObjArraySerializer;

begin

  if (aItem=nil) or (aDynArray^.DynArrayItemSize<>sizeof(TObject)) then

    raise EModelException.CreateUTF8(

      'Invalid %.RegisterObjArrayForJSON(TypeInfo(%),%)',[self,aDynArray^.Name,aItem]);

  if ObjArraySerializers=nil then

    GarbageCollectorFreeAndNil(ObjArraySerializers,TPointerClassHash.Create);

  serializer := pointer(ObjArraySerializers.TryAdd(aDynArray));

  if serializer=nil then

    exit; // avoid duplicate

  serializer^ := TObjArraySerializer.Create(aDynArray);

  serializer^.Instance.Init(aItem);

  TTextWriter.RegisterCustomJSONSerializer(

    aDynArray,serializer^.CustomReader,serializer^.CustomWriter);

end;



class function TJSONSerializer.RegisterObjArrayFindType(aDynArray: PTypeInfo): PClassInstance;

var serializer: TPointerClassHashed;

begin

  serializer := ObjArraySerializers.Find(aDynArray);

  if serializer=nil then

    result := nil else

    result := @TObjArraySerializer(serializer).Instance;

end;



class procedure TJSONSerializer.RegisterObjArrayForJSON(

  const aDynArrayClassPairs: array of const);

var n,i: integer;

begin

  n := length(aDynArrayClassPairs);

  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 (aDynArrayClassPairs[i*2].VType<>vtPointer) or

       (aDynArrayClassPairs[i*2+1].VType<>vtClass) then

      raise EParsingException.Create('RegisterObjArrayForJSON[?]') else

      RegisterObjArrayForJSON(

        aDynArrayClassPairs[i*2].VPointer,aDynArrayClassPairs[i*2+1].VClass);

end;



function JSONToNewObject(var From: PUTF8Char; var Valid: boolean;

  Options: TJSONToObjectOptions=[]): TObject;

var ItemClass: TClass;

    ItemInstance: TClassInstance;

begin

  Valid := false;

  result := nil;

  if From=nil then

    exit;

  while From^ in [#1..' '] do inc(From);

  if PInteger(From)^=NULL_LOW then begin

    Valid := true;

    exit;

  end;

  if From^<>'{' then

    exit; // input should be either null, either {"ClassName":"TMyClass",...}

  ItemClass := JSONSerializerRegisteredClass.Find(From,true);

  if ItemClass=nil then

    exit; // unknown type

  ItemInstance.Init(ItemClass);

  result := ItemInstance.CreateNew;

  From := JSONToObject(result,From,Valid,nil,Options);

  if not Valid then

    FreeAndNil(result); // avoid memory leak

end;



type

  TJSONObject =

    (oNone, oException, oList, oObjectList, {$ifndef LVCL}oCollection,{$endif}

     oUtfs, oStrings, oSQLRecord, oSQLMany, oPersistent, oPersistentPassword,

     oSynMonitor, oSQLTable, oCustom);



function JSONObject(aClassType: TClass; out aCustomIndex: integer;

  aExpectedReadWriteTypes: TJSONCustomParserExpectedDirections): TJSONObject;

const

  MAX = {$ifdef LVCL}14{$else}15{$endif};

  TYP: array[0..MAX] of TClass = ( // all classes types gathered in CPU L1 cache

    TObject,Exception,ESynException,TList,TObjectList,TPersistent,

    TSynPersistentWithPassword,TSynPersistent,TInterfacedObjectWithCustomCreate,

    TSynMonitor,TSQLRecordMany,TSQLRecord,TStrings,TRawUTF8List,TSQLTable

    {$ifndef LVCL},TCollection{$endif});

  OBJ: array[0..MAX] of TJSONObject = (

    oNone,oException,oPersistent,oList,oObjectList,oPersistent,

    oPersistentPassword,oPersistent,oPersistent,

    oSynMonitor,oSQLMany,oSQLRecord,oStrings,oUtfs,oSQLTable

    {$ifndef LVCL},oCollection{$endif});

var i: integer;

begin

  if aClassType<>nil then begin

    aCustomIndex := JSONCustomParsersIndex(aClassType,aExpectedReadWriteTypes);

    if aCustomIndex>=0 then begin

      result := oCustom; // found exact custom type (ignore inherited)

      exit;

    end;

    repeat // guess class type (faster than multiple InheritsFrom calls)

      i := PtrUIntScanIndex(@TYP,MAX+1,PtrUInt(aClassType));

      if i>=0 then begin

        result := OBJ[i];

        exit;

      end;

      {$ifdef FPC}

      aClassType := aClassType.ClassParent;

      {$else}

      if PPointer(PtrInt(aClassType)+vmtParent)^<>nil then

        aClassType := PPointer(PPointer(PtrInt(aClassType)+vmtParent)^)^ else

        break;

      {$endif}

    until aClassType=nil;

  end;

  result := oNone;

end;



function PropIsIDTypeCastedField(Prop: PPropInfo; IsObj: TJSONObject;

  Value: TObject): boolean; // see [22ce911c715]

begin

  if (Value<>nil) and (Prop^.PropType^.ClassSQLFieldType=sftID) then

  case IsObj of

  oSQLMany:

    if IdemPropName(Prop^.Name,'source') or IdemPropName(Prop^.Name,'dest') then

      result := true else

      result := not TSQLRecord(Value).fFill.JoinedFields;

  oSQLRecord:

    result := not TSQLRecord(Value).fFill.JoinedFields;

  else result := false;

  end else

    result := false; // assume true instance by default

end;



function ObjectLoadJSON(var ObjectInstance; const JSON: RawUTF8;

  TObjectListItemClass: TClass; Options: TJSONToObjectOptions): boolean;

var tmp: TSynTempBuffer;

begin

  result := false;

  tmp.Init(JSON);

  if tmp.len<>0 then

    try

      JSONToObject(ObjectInstance,tmp.buf,result,TObjectListItemClass,Options);

    finally

      tmp.Done;

    end;

end;



function JSONToObject(var ObjectInstance; From: PUTF8Char; var Valid: boolean;

  TObjectListItemClass: TClass; Options: TJSONToObjectOptions): PUTF8Char;

var P: PPropInfo;

    Value: TObject absolute ObjectInstance;

{$ifndef LVCL}

    Coll: TCollection absolute ObjectInstance;

    CollItem: TObject;

{$endif}

    Str: TStrings absolute ObjectInstance;

    Utf: TRawUTF8List absolute ObjectInstance;

    Lst: TObjectList absolute ObjectInstance;

    Item: TObject;

    ItemInstance: TClassInstance;

    ValueClass, ItemClass: TClass;

    V: PtrInt;

    err: integer;

    E: TSynExtended;

    V64: Int64;

    PropName: PUTF8Char;

    PropNameLen: integer;

    PropValue: PUTF8Char;

    EndOfObject: AnsiChar;

    Kind: TTypeKind;

    wasString, NestedValid: boolean;

    IsObj: TJSONObject;

    IsObjCustomIndex: integer;

    s: string;

    WS: WideString;

    U: RawUTF8;

    {$ifndef NOVARIANTS}

    VVariant: variant;

    DocVariantOptionsSet: TDocVariantOptions;

label doProp;

    {$endif}

begin

  Valid := false;

  result := From;

  if Value=nil then

    exit;

  ValueClass := Value.ClassType;

  IsObj := JSONObject(ValueClass,IsObjCustomIndex,[cpRead]);

  if From=nil then begin

    case IsObj of // handle '' as Clear for arrays

{$ifndef LVCL}

    oCollection: Coll.Clear;

{$endif}

    oStrings:    Str.Clear;

    oUtfs:       Utf.Clear;

    oObjectList: Lst.Clear;

    end;

    exit;

  end;

  if PInteger(From)^=NULL_LOW then begin

    if (IsObj=oCustom) and Assigned(JSONCustomParsers[IsObjCustomIndex].Reader) then

      // custom JSON reader expects to be executed even if value is null

      result := JSONCustomParsers[IsObjCustomIndex].Reader(Value,From,Valid,Options) else begin

      FreeAndNil(Value);

      result := From+4;

      Valid := true; // null is a valid JSON object

    end;

    exit;

  end;

  while From^ in [#1..' '] do inc(From);

  if IsObj=oCustom then

  with JSONCustomParsers[IsObjCustomIndex] do begin

    if Assigned(Reader) then // leave Valid=false if Reader=nil

      result := Reader(Value,From,Valid,Options);

    exit;

  end;

  if From^='[' then begin

    // nested array = TObjectList, TCollection, TRawUTF8List or TStrings

    inc(From);

    case IsObj of

    oObjectList: begin // TList leaks memory, but TObjectList uses "ClassName":..

      Lst.Clear;

      ItemInstance.ItemClass := nil;

      repeat

        while From^ in [#1..' '] do inc(From);

        case From^ of

        #0: exit;

        ']': begin

          inc(From);

          break;

        end;

        ',':

          inc(From); // valid delimiter between objects

        '{': begin

          result := From;

          if TObjectListItemClass=nil then begin // recognize "ClassName":...

            ItemClass := JSONSerializerRegisteredClass.Find(From,true);

            if ItemClass=nil then

              exit; // unknown "ClassName":.. type

          end else

            ItemClass := TObjectListItemClass;

          if ItemInstance.ItemClass<>ItemClass then

            ItemInstance.Init(ItemClass);

          Item := ItemInstance.CreateNew;

          From := JSONToObject(Item,From,NestedValid,nil,Options);

          if not NestedValid then begin

            result := From;

            exit;

          end else

          if From=nil then

            exit;

          Lst.Add(Item);

        end;

        else exit;

        end;

      until false;

      // only way of being here is to have an ending ] at expected place

      Valid := true;

    end;

{$ifndef LVCL}

    oCollection: begin

      Coll.BeginUpdate;  // Coll: TCollection absolute Value

      try

        Coll.Clear;

        repeat

          while From^ in [#1..' '] do inc(From);

          case From^ of

          #0: exit;

          ']': begin

            inc(From);

            break;

          end;

          ',':

            inc(From); // valid delimiter between objects

          '{': begin

            result := From;

            CollItem := Coll.Add;

            From := JSONToObject(CollItem,From,NestedValid,nil,Options);

            if not NestedValid then begin

              result := From;

              exit;

            end else

            if From=nil then

              exit;

          end;

          else exit;

          end;

        until false;

        // only way of being here is to have an ending ] at expected place

        Valid := true;

      finally

        Coll.EndUpdate;

      end;

    end;

{$endif}

    oStrings: begin

{$ifndef LVCL}

      Str.BeginUpdate; // Str: TStrings absolute Value

      try

{$endif}

        Str.Clear;

        repeat

          while From^ in [#1..' '] do inc(From);

          case From^ of

          #0: exit;

          ']': begin

            inc(From);

            break;

          end;

          '"': begin

            result := From;

            PropValue := GetJSONField(From,From,@wasString,@EndOfObject);

            if (PropValue=nil) or not wasString then

              exit;

            UTF8DecodeToString(PropValue,StrLen(PropValue),s);

            Str.Add(s);

            case EndOfObject of

              ']': break;

              ',': continue;

              else exit;

            end;

          end;

          else exit;

          end;

        until false;

        Valid := true;

{$ifndef LVCL}

      finally

        Str.EndUpdate;

      end;

{$endif}

    end;

    oUtfs: begin

      utf.BeginUpdate; // utf: TRawUTF8List absolute Value

      try

        utf.Clear;

        repeat

          while From^ in [#1..' '] do inc(From);

          case From^ of

          #0: exit;

          ']': begin

            inc(From);

            break;

          end;

          '"': begin

            result := From;

            PropValue := GetJSONField(From,From,@wasString,@EndOfObject);

            if (PropValue=nil) or not wasString then

              exit;

            SetString(U,PAnsiChar(PropValue),StrLen(PropValue));

            utf.Add(U);

            case EndOfObject of

              ']': break;

              ',': if From=nil then exit else continue;

              else exit;

            end;

          end;

          else exit;

          end;

        until false;

        Valid := true;

      finally

        utf.EndUpdate;

      end;

    end;

    end; // case IsObj of

    // Valid=false if not TCollection, TRawUTF8List nor TStrings

    if Valid and (From<>nil) then begin

      while From^ in [#1..' '] do inc(From);

      if From^=#0 then

        From := nil;

    end;

    result := From;

    exit; // a JSON array begin with [

  end else

  if From^<>'{' then begin

    result := From;

    exit; // a JSON object MUST begin with {

  end;

  repeat inc(From) until (From^=#0) or (From^>' ');

  EndOfObject := #0;

  if From^='}' then begin

    // empty JSON object like {} (e.g. all properties having default values)

    EndOfObject := '}';

    Inc(From);

  end else

  repeat

    wasString := false;

    result := From;

    PropName := GetJSONPropName(From);  // get property name

    PropNameLen := StrLen(PropName);

    if (From=nil) or (PropNameLen=0) then

      exit; // invalid JSON content

    if IdemPropName('ClassName',PropName,PropNameLen) then begin

      // WriteObject() was called with woStoreClassName option -> handle it

      PropValue := GetJSONField(From,From,@wasString,@EndOfObject);

      if (PropValue=nil) or (not wasString) or not (EndOfObject in ['}',',']) then

        exit; // invalid JSON content

      continue; // just ignore the field here

    end;

    if (IsObj in [oSQLRecord,oSQLMany]) and IsRowID(PropName) then begin

      // manual handling of TSQLRecord.ID property unserialization

      PropValue := GetJSONField(From,From,@wasString,@EndOfObject);

      if (PropValue=nil) or wasString or not (EndOfObject in ['}',',']) then

        exit; // invalid JSON content

      SetID(PropValue,TSQLRecord(Value).fID);

      continue;

    end;

    P := ClassFieldPropWithParentsFromUTF8(ValueClass,PropName,PropNameLen);

    if P=nil then // unknown property

      if j2oIgnoreUnknownProperty in Options then begin

        From := GotoNextJSONItem(From,1,@EndOfObject);

        continue;

      end else

        exit; // by default, abort

    Kind := P^.PropType^.Kind;

    while From^ in [#1..' '] do inc(From);

    result := From;

    if PInteger(From)^=NULL_LOW then begin

      // null value should set the default value, or free nested object 

      if (Kind=tkClass) and (IsObj in [oSQLRecord,oSQLMany]) then

          exit; // null expects a plain TSynPersistent/TPersistent

      P^.SetDefaultValue(Value); // will set 0,'' or FreeAndNil(NestedObject)

      inc(From,4);

      while From^ in [#1..' '] do inc(From);

      EndOfObject := From^;

      if From^ in EndOfJSONField then

        inc(From);

    end else

    if From^ in ['[','{'] then begin

      // nested array or object

      if Kind=tkDynArray then begin

        From := P^.GetDynArray(Value).LoadFromJSON(From);

        if From=nil then

          exit; // invalid '[dynamic array]' content

      end else

      {$ifndef NOVARIANTS}

      if Kind=tkVariant then

        goto doProp else

      {$endif}

      if (Kind=tkSet) and (From^='[') then begin // set as string array

        V := GetSetNameValue(P^.TypeInfo,From,EndOfObject);

        P^.SetOrdProp(Value,V);

      end else

      if (Kind in tkRecordTypes) and (From^='{') then begin // from Delphi XE5+

        From := RecordLoadJSON(P^.GetFieldAddr(Value)^,From,P^.TypeInfo,@EndOfObject);

        if From=nil then

          exit; // invalid '{record}' content

        if EndOfObject='}' then

          break else

          continue;

      end else begin

        if Kind<>tkClass then

          exit; // true nested object should begin with '[' or '{'

        if PropIsIDTypeCastedField(P,IsObj,Value) then

          exit; // only TSQLRecordMany/joined properties are true instances

        // will handle '[TCollection...' '[TStrings...' '{TObject...'

        From := P^.ClassFromJSON(Value,From,NestedValid,Options);

        if not NestedValid then begin

          result := From;

          exit;

        end else

        if From=nil then

          exit; // invalid JSON content: we expect at least a last '}'

      end;

      while From^ in [#1..' '] do inc(From);

      EndOfObject := From^;

      if From^ in EndOfJSONField then

        inc(From);

    end else begin

doProp: // normal property value

      PropValue := GetJSONFieldOrObjectOrArray(From,@wasString,@EndOfObject

        {$ifndef NOVARIANTS},Kind=tkVariant{$endif});

      if (PropValue=nil) or not (EndOfObject in ['}',',']) then

        exit; // invalid JSON content (null has been handled above)

      case Kind of

      tkInt64{$ifdef FPC}, tkQWord{$endif}:

        if wasString then

          exit else begin

          V64 := GetInt64(PropValue,err);

          if err<>0 then

            exit;

          P^.SetInt64Prop(Value,V64);

        end;

      tkClass: begin

        if wasString or (P^.PropType^.ClassSQLFieldType<>sftID) then

          exit; // should have been handled above

        V := GetInteger(PropValue,err);

        if err<>0 then

          exit; // invalid value

        P^.SetOrdProp(Value,V);

      end;

      tkEnumeration: begin

        if wasString then begin // in case enum stored as string

          V := P^.PropType^.EnumBaseType^.GetEnumNameValue(PropValue);

          if V<0 then

            if j2oIgnoreUnknownEnum in Options then

              V := 0 else

              exit;

        end else begin

          V := GetInteger(PropValue,err);

          if err<>0 then

            if j2oIgnoreUnknownEnum in Options then

              V := 0 else

              exit; // invalid value

        end;

        P^.SetOrdProp(Value,V);

      end;

      {$ifdef FPC} tkBool, {$endif}

      tkInteger, tkSet:

        if wasString then

          exit else begin

          // From='true' or From='false' were converted into '1 or '0'

          V := GetInteger(PropValue,err);

          if err<>0 then

            exit; // invalid value

          P^.SetOrdProp(Value,V);

        end;

      {$ifdef FPC}tkAString,{$endif} tkLString: 

        if wasString or (j2oIgnoreStringType in Options) then begin

          SetString(U,PAnsiChar(PropValue),StrLen(PropValue));

          P^.SetLongStrValue(Value,U);

        end else

          exit;

      {$ifdef HASVARUSTRING}

      tkUString:

        if wasString or (j2oIgnoreStringType in Options) then

          P^.SetUnicodeStrProp(Value,

            UTF8DecodeToUnicodeString(PropValue,StrLen(PropValue))) else

          exit;

      {$endif}

      tkWString:

        if wasString or (j2oIgnoreStringType in Options) then begin

          UTF8ToWideString(PropValue,StrLen(PropValue),WS);

          P^.SetWideStrProp(Value,WS);

        end else

          exit;

      {$ifdef PUBLISHRECORD}

      tkRecord{$ifdef FPC},tkObject{$endif}:

        if not wasString then

          exit else

          RecordLoadJSON(P^.GetFieldAddr(Value)^,PropValue,P^.TypeInfo);

      {$endif}

      {$ifndef NOVARIANTS}

      tkVariant: begin

        if j2oHandleCustomVariants in Options then begin

          if j2oHandleCustomVariantsWithinString in Options then

            DocVariantOptionsSet := [dvoValueCopiedByReference,dvoJSONObjectParseWithinString] else

            DocVariantOptionsSet := [dvoValueCopiedByReference];

          GetVariantFromJSON(PropValue,wasString,VVariant,@DocVariantOptionsSet);

        end else

          GetVariantFromJSON(PropValue,wasString,VVariant);

        P^.SetVariantProp(Value,VVariant);

      end;

      {$endif}

      tkFloat:

        if P^.TypeInfo=TypeInfo(TDateTime) then

          if wasString then begin

            if PInteger(PropValue)^ and $ffffff=JSON_SQLDATE_MAGIC then

              inc(PropValue,3); // ignore U+FFF1 pattern

            P^.SetFloatProp(Value,Iso8601ToDateTimePUTF8Char(PropValue,0));

          end else

            exit else

        if wasString then

          exit else

        if (P^.TypeInfo=TypeInfo(Currency)) and P^.SetterIsField then

          PInt64(P^.SetterAddr(Value))^ := StrToCurr64(PropValue) else begin

          E := GetExtended(pointer(PropValue),err);

          if err<>0 then

            exit else // invalid JSON content

            P^.SetFloatProp(Value,E);

        end;

      end;

    end;

  until (From=nil) or (EndOfObject='}');

  if From<>nil then begin

    while From^ in [#1..' '] do inc(From);

    if From^=#0 then

      From := nil;

  end;

  Valid := (EndOfObject='}'); // mark parsing success

  result := From;

end;



function UrlDecodeObject(U: PUTF8Char; Upper: PAnsiChar; var ObjectInstance;

  Next: PPUTF8Char=nil; Options: TJSONToObjectOptions=[]): boolean;

var tmp: RawUTF8;

begin

  result := UrlDecodeValue(U, Upper, tmp, Next);

  if result then

    JSONToObject(ObjectInstance,Pointer(tmp),result,nil,Options);

end;



function JSONFileToObject(const JSONFile: TFileName; var ObjectInstance;

  TObjectListItemClass: TClass=nil; Options: TJSONToObjectOptions=[]): boolean;

var tmp: RawUTF8;

begin

  tmp := AnyTextFileToRawUTF8(JSONFile,true);

  if tmp='' then

    result := false else begin

    RemoveCommentsFromJSON(pointer(tmp));

    JSONToObject(ObjectInstance,pointer(tmp),result,TObjectListItemClass,Options);

  end;

end;



function ObjectToJSONFile(Value: TObject; const JSONFile: TFileName;

  Options: TTextWriterWriteObjectOptions): boolean;

var humanread: boolean;

    json: RawUTF8;

begin

  humanread := woHumanReadable in Options;

  Exclude(Options,woHumanReadable);

  json := ObjectToJSON(Value,Options);

  if humanread then

    // woHumanReadable not working with custom JSON serializers, e.g. T*ObjArray

    result := JSONBufferReformatToFile(pointer(json),JSONFile) else

    result := FileFromString(json,JSONFile);

end;



procedure ReadObject(Value: TObject; From: PUTF8Char; const SubCompName: RawUTF8=''); overload;

var P: PPropInfo;

    i, V, err: integer;

    V64: Int64;

    E: TSynExtended;

    Obj: TObject;

    UpperName: array[byte] of AnsiChar;

    U: RawUTF8;

    {$ifndef NOVARIANTS}

    VVariant: variant;

    {$endif}

begin

  if Value=nil then // allow From=nil -> default values

    exit;

  for i := 1 to InternalClassPropInfo(Value.ClassType,P) do begin

    PWord(UpperCopyShort(UpperCopy255(UpperName,SubCompName),P^.Name))^ := ord('=');

    U := FindIniNameValue(From,UpperName);

    case P^.PropType^.Kind of

      tkInt64{$ifdef FPC}, tkQWord{$endif}: begin

        V64 := GetInt64(pointer(U),err);

        if err=0 then

          P^.SetInt64Prop(Value,V64); // pointer() to call typinfo

      end;

      {$ifdef FPC}tkBool,{$endif} tkEnumeration, tkSet, tkInteger: begin

        V := GetInteger(pointer(U),err);

        if err=0 then

          P^.SetOrdProp(Value,V) else // pointer() to call typinfo

          if P^.Default<>longint($80000000) then

            P^.SetOrdProp(Value,P^.Default);

      end;

      tkFloat:

      if U<>'' then

        if (P^.TypeInfo=TypeInfo(Currency)) and P^.SetterIsField then

          PInt64(P^.SetterAddr(Value))^ := StrToCurr64(pointer(U)) else begin

          E := GetExtended(pointer(U),err);

          if err=0 then

            P^.SetFloatProp(Value,E);

        end;

      {$ifdef FPC}tkAString,{$endif} tkLString:

        P^.SetLongStrValue(Value,U);

      tkWString:

         P^.SetWideStrProp(Value,UTF8ToWideString(U));

      {$ifdef HASVARUSTRING}

      tkUString:

         P^.SetUnicodeStrProp(Value,UTF8ToString(U));

      {$endif}

      tkDynArray:

        P^.GetDynArray(Value).LoadFrom(pointer(BlobToTSQLRawBlob(U)));

{$ifdef PUBLISHRECORD}

      tkRecord{$ifdef FPC},tkObject{$endif}:

        RecordLoadJSON(P^.GetFieldAddr(Value)^,pointer(U),P^.PropType^);

{$endif PUBLISHRECORD}

      tkClass: begin

        Obj := P^.GetObjProp(Value);

        if {$ifdef MSWINDOWS}(PtrUInt(Obj)>=PtrUInt(SystemInfo.lpMinimumApplicationAddress)) and{$endif}

           Obj.InheritsFrom(TPersistent) then

          ReadObject(Obj,From,SubCompName+ToUTF8(P^.Name)+'.');

      end;

{$ifndef NOVARIANTS}

      tkVariant: begin

        VariantLoadJSON(VVariant,pointer(U));

        P^.SetVariantProp(Value,VVariant);

      end;

{$endif} // tkString (shortstring) and tkInterface is not handled

    end;

    P := P^.Next;

  end;

end;



procedure ReadObject(Value: TObject; const FromContent: RawUTF8;

  const SubCompName: RawUTF8=''); overload;

var source: PUTF8Char;

    UpperSection: array[byte] of AnsiChar;

begin

  if Value=nil then

    exit; // avoid GPF

  PWord(UpperCopyShort(UpperSection,PShortString(PPointer(

    PPtrInt(Value)^+vmtClassName)^)^))^ := ord(']');

  source := pointer(FromContent);

  if FindSectionFirstLine(source,UpperSection) then

    ReadObject(Value,source,SubCompName);

end;



procedure SetDefaultValuesObject(Value: TObject);

var p: PPropInfo;

    c: TClass;

    i: integer;

begin

  if Value=nil then

    exit;

  c := Value.ClassType;

  repeat

    for i := 1 to InternalClassPropInfo(Value.ClassType,p) do begin

      case p^.PropType^.Kind of

        {$ifdef FPC}tkBool,{$endif} tkEnumeration, tkSet, tkInteger:

          if p^.Default<>longint($80000000) then

            p^.SetOrdProp(Value,p^.Default);

        tkClass:

          SetDefaultValuesObject(p^.GetObjProp(Value));

      end;

      p := p^.Next;

    end;

    c := c.ClassParent;

  until c=nil;

end;



procedure ClearObject(Value: TObject; FreeAndNilNestedObjects: boolean=false);

var p: PPropInfo;

    c: TClass;

    i: integer;

begin

  if Value=nil then

    exit;

  c := Value.ClassType;

  repeat

    for i := 1 to InternalClassPropInfo(c,p) do begin

      p^.SetDefaultValue(Value,FreeAndNilNestedObjects);

      {$ifdef HASINLINE}

      p := p^.Next;

      {$else}

      with p^ do p := @Name[ord(Name[0])+1];

      {$endif}

    end;

    c := c.ClassParent;

  until c=nil;

end;





{ TClassInstance }



procedure TClassInstance.Init(C: TClass);

begin

  ItemClass := C;

  if C<>nil then

  repeat // this unrolled loop is faster than cascaded if C.InheritsFrom()

    if C<>TSQLRecord then

    if C<>TObjectList then

    if C<>TInterfacedObjectWithCustomCreate then

    if C<>TPersistentWithCustomCreate then

    if C<>TSynPersistent then

    if C<>TComponent then

  {$ifndef LVCL}

    if C<>TInterfacedCollection then

    if C<>TCollection then

    if C<>TCollectionItem then

  {$endif}

  {$ifdef FPC}

    if C.ClassParent<>nil then begin

      C := C.ClassParent;

  {$else}

    if PPointer(PtrInt(C)+vmtParent)^<>nil then begin

      C := PPointer(PPointer(PtrInt(C)+vmtParent)^)^;

  {$endif}

      if C<>nil then

        continue else begin

        ItemCreate := cicTObject;

        exit;

      end;

    end else begin

      ItemCreate := cicTObject;

      exit;

    end else

  {$ifndef LVCL} begin

      ItemCreate := cicTCollectionItem;

      exit;

    end else begin // plain TCollection shall have been registered

      CollectionItemClass := JSONSerializerRegisteredCollection.Find(TCollectionClass(ItemClass));

      if CollectionItemClass<>nil then begin

        ItemCreate := cicTCollection;

        exit;

      end else

        raise EParsingException.CreateUTF8('% shall inherit from TInterfacedCollection'+

         ' or call TJSONSerializer.RegisterCollectionForJSON()',[ItemClass]);

    end else begin

      ItemCreate := cicTInterfacedCollection;

      exit;

    end else

  {$endif} begin

      ItemCreate := cicTComponent;

      exit;

    end else begin

      ItemCreate := cicTSynPersistent;

      exit;

    end else begin

      ItemCreate := cicTPersistentWithCustomCreate;

      exit;

    end else begin

      ItemCreate := cicTInterfacedObjectWithCustomCreate;

      exit;

    end else begin

      ItemCreate := cicTObjectList;

      exit;

    end else begin

      ItemCreate := cicTSQLRecord;

      exit;

    end;

  until false;

  ItemCreate := cicUnknown;

end;



function TClassInstance.CreateNew: TObject;

begin

  if @self<>nil then

  case ItemCreate of

    cicUnknown: begin

      result := nil;

      exit;

    end;

    cicTSQLRecord: begin

      result := TSQLRecordClass(ItemClass).Create;

      exit;

    end;

    cicTObjectList: begin

      result := TObjectList.Create;

      exit;

    end;

    cicTPersistentWithCustomCreate: begin

      result := TPersistentWithCustomCreateClass(ItemClass).Create;

      exit;

    end;

    cicTComponent: begin

      result := TComponentClass(ItemClass).Create(nil);

      exit;

    end;

    cicTSynPersistent: begin

      result := TSynPersistentClass(ItemClass).Create;

      exit;

    end;

    cicTInterfacedObjectWithCustomCreate: begin

      result := TInterfacedObjectWithCustomCreateClass(ItemClass).Create;

      exit;

    end;

    {$ifndef LVCL}

    cicTInterfacedCollection: begin

      result := TInterfacedCollectionClass(ItemClass).Create;

      exit;

    end;

    cicTCollection: begin

      result := TCollectionClass(ItemClass).Create(CollectionItemClass);

      exit;

    end;

    cicTCollectionItem: begin

      result := TCollectionItemClass(ItemClass).Create(nil);

      exit;

    end;

    {$endif}

    cicTObject: begin

      result := ItemClass.Create;

      exit;

    end;

    else begin

      result := nil;

      exit;

    end;

  end else begin

    result := nil;

    exit;

  end;

end;





{$ifdef MSWINDOWS}



{ TSQLRestClientURIMessage }



constructor TSQLRestClientURIMessage.Create(aModel: TSQLModel;

  const ServerWindowName: string; ClientWindow: HWND; TimeOutMS: cardinal);

begin

  inherited Create(aModel);

  fClientWindow := ClientWindow;

  fServerWindowName := ServerWindowName;

  fTimeOutMS := TimeOutMS;

end;



constructor TSQLRestClientURIMessage.Create(aModel: TSQLModel;

  const ServerWindowName, ClientWindowName: string; TimeOutMS: cardinal);

var H: HWND;

begin

  H := CreateInternalWindow(ClientWindowName,self);

  if H=0 then

    raise ECommunicationException.CreateUTF8('%.Create(): CreateInternalWindow("%")',

      [self,ClientWindowName]);

  fClientWindowName := ClientWindowName;

  Create(aModel,ServerWindowName,H,TimeOutMS);

end;



destructor TSQLRestClientURIMessage.Destroy;

begin

  try

    inherited Destroy;

  finally

    ReleaseInternalWindow(fClientWindowName,fClientWindow);

  end;

end;



procedure TSQLRestClientURIMessage.DefinitionTo(Definition: TSynConnectionDefinition);

begin

  if Definition=nil then

    exit;

  inherited DefinitionTo(Definition); // save Kind + User/Password

  Definition.ServerName := StringToUTF8(fServerWindowName);

  Definition.DatabaseName := StringToUTF8(fClientWindowName);

end;



constructor TSQLRestClientURIMessage.RegisteredClassCreateFrom(aModel: TSQLModel;

  aDefinition: TSynConnectionDefinition);

begin

  Create(aModel,UTF8ToString(aDefinition.ServerName),

    UTF8ToString(aDefinition.DatabaseName),10000);

  inherited RegisteredClassCreateFrom(aModel,aDefinition); // call SetUser()

end;



procedure TSQLRestClientURIMessage.InternalURI(var Call: TSQLRestURIParams);

var Msg: RawUTF8;

    Data: TCopyDataStruct;

    Finished64: Int64;

    P: PUTF8Char;

    aMsg: TMsg;

    {$ifdef WITHLOG}

    Log: ISynLog;

    {$endif}

begin

  {$ifdef WITHLOG}

  Log := fLogClass.Enter(self);

  {$endif}

  if (fClientWindow=0) or not InternalCheckOpen then begin

    Call.OutStatus := HTML_NOTIMPLEMENTED; // 501

    InternalLog('InternalCheckOpen failure',sllClient);

    exit;

  end;

  // 1. send request

  // #1 is a field delimiter below, since Get*Item() functions return nil for #0

  SetString(Msg,PAnsiChar(@MAGIC_SYN),4);

  Msg := Msg+Call.Url+#1+Call.Method+#1+Call.InHead+#1+Call.InBody;

  Data.dwData := fClientWindow;

  Data.cbData := length(Msg)*SizeOf(Msg[1]);

  Data.lpData := pointer(Msg);

  fSafe.Enter;

  try

    fCurrentResponse := #0; // mark expect some response

    Call.OutStatus := SendMessage(fServerWindow,WM_COPYDATA,fClientWindow,PtrInt(@Data));

    if not StatusCodeIsSuccess(Call.OutStatus) then begin

      fCurrentResponse := '';

      with Call do

        InternalLog('% % status=%',[Method,Url,OutStatus],sllError);

      exit;

    end;

    // 2. expect answer from server

    if fCurrentResponse=#0 then begin

      // in practice, we never reach here since SendMessage() did wait for the

      // message to be processed by the receiver, so the Server should have

      // already answered and fCurrentResponse field should have been set

      Finished64 := GetTickCount64+fTimeOutMS;

      repeat

        // incoming WM_COPYDATA will set fCurrentResponse in WMCopyData() method

        if not DoNotProcessMessages then

          while PeekMessage(aMsg,0,0,0,PM_REMOVE) do begin

            TranslateMessage(aMsg);

            DispatchMessage(aMsg);

          end;

        SleepHiRes(0);

        if GetTickCount64>Finished64 then begin

          Call.OutStatus := HTML_TIMEOUT; // 408 Request Timeout Error

          exit;

        end;

      until fCurrentResponse<>#0;

    end;

    // 3. return answer to caller

    if length(fCurrentResponse)<=sizeof(Int64) then

      Call.OutStatus := HTML_NOTIMPLEMENTED else begin

      P := pointer(fCurrentResponse);

      if PCardinal(P)^<>MAGIC_SYN then // broadcasted WM_COPYDATA message? :(

        Call.OutStatus := 0 else begin

        Call.OutStatus := PIntegerArray(P)[1];

        Call.OutInternalState := PIntegerArray(P)[2];

        inc(P,sizeof(integer)*3);

      end;

      if Call.OutStatus=0 then

        Call.OutStatus := HTML_NOTFOUND else begin

        Call.OutHead := GetNextItem(P,#1);

        if P<>nil then

          SetString(Call.OutBody,P,length(fCurrentResponse)-(P-pointer(fCurrentResponse)));

      end;

    end;

  finally

    fSafe.Leave;

  end;

  with Call do

    InternalLog('% % status=% state=%',[Method,Url,OutStatus,OutInternalState],sllClient);

end;



procedure TSQLRestClientURIMessage.WMCopyData(var Msg: TWMCopyData);

begin

  if (self=nil) or (Msg.From<>fServerWindow) or

     (PCopyDataStruct(Msg.CopyDataStruct)^.dwData<>fServerWindow) then

    exit;

  Msg.Result := HTML_SUCCESS; // Send something back

  if fCurrentResponse=#0 then // expect some response?

    SetString(fCurrentResponse,PAnsiChar(PCopyDataStruct(Msg.CopyDataStruct)^.lpData),

      PCopyDataStruct(Msg.CopyDataStruct)^.cbData);

end;



function TSQLRestClientURIMessage.InternalCheckOpen: boolean;

begin

  fSafe.Enter;

  try

    if fServerWindow<>0 then begin

      result := true;

      exit; // only reconnect if forced by InternalClose call or at first access

    end;

    fServerWindow := FindWindow(pointer(fServerWindowName),nil);

    result := fServerWindow<>0;

  finally

    fSafe.Leave;

  end;

end;



procedure TSQLRestClientURIMessage.InternalClose;

begin

  fServerWindow := 0;

end;





{$endif}







{ TSQLRecordSigned }



function TSQLRecordSigned.CheckSignature(const Content: RawByteString): boolean;

var tmp: RawUTF8;

    i: integer;

    SHA: TSHA256;

    Digest: TSHA256Digest;

begin

  result := false;

  i := PosEx(RawUTF8('/'),fSignature,1);

  if i=0 then

    exit;

  tmp := TTimeLogBits(fSignatureTime).Text(false)+RawUTF8(ClassName)+copy(fSignature,1,i-1);

  SHA.Init;

  SHA.Update(pointer(tmp),length(tmp));

  SHA.Update(pointer(Content),length(Content)); // hash in place: no Content copy

  SHA.Final(Digest);

  if SHA256DigestToString(Digest)=copy(fSignature,i+1,sizeof(Digest)*2) then

    result := true;

end;



function TSQLRecordSigned.SetAndSignContent(const UserName: RawUTF8;

  const Content: RawByteString; ForcedSignatureTime: Int64): boolean;

var tmp: RawUTF8;

    SHA: TSHA256;

    Digest: TSHA256Digest;

begin

  result := (fSignature='') and (fSignatureTime=0);

  if not result then

    exit; // sign is allowed only once

  if ForcedSignatureTime<>0 then

    fSignatureTime := ForcedSignatureTime else

    fSignatureTime := TimeLogNow;

  { content is hashed with User Name value }

  tmp := TTimeLogBits(fSignatureTime).Text(false)+RawUTF8(ClassName)+UserName;

  SHA.Init;

  SHA.Update(pointer(tmp),length(tmp));

  SHA.Update(pointer(Content),length(Content)); // hash in place: no Content copy

  SHA.Final(Digest);

  fSignature := UserName+'/'+SHA256DigestToString(Digest);

end;



function TSQLRecordSigned.SignedBy: RawUTF8;

var i: integer;

begin

  i := PosEx(RawUTF8('/'),fSignature,1);

  if i=0 then

    result := '' else

    result := copy(fSignature,1,i-1);

end;



procedure TSQLRecordSigned.UnSign;

begin

  fSignature := '';

  fSignatureTime := 0;

end;





{ TSQLRecordInterfaced }



class function TSQLRecordInterfaced.NewInstance: TObject;

begin

  result := inherited NewInstance;

  TSQLRecordInterfaced(result).fRefCount := 1;

end;



procedure TSQLRecordInterfaced.AfterConstruction;

{$ifdef PUREPASCAL}

begin

  InterlockedDecrement(fRefCount); // fRefCount=1 in NewInstance

end;

{$else}

asm

  lock dec [eax].TInterfacedObject.fRefCount

end;

{$endif}



procedure TSQLRecordInterfaced.BeforeDestruction;

begin

  if fRefCount<>0 then

    System.Error(reInvalidPtr);

end;



{$ifdef FPC}

function TSQLRecordInterfaced.QueryInterface(

  {$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID; out Obj): longint;

{$else}

function TSQLRecordInterfaced.QueryInterface(const IID: TGUID; out Obj): HResult;

{$endif}

begin

  if GetInterface(IID,Obj) then

    result := 0 else

    result := {$ifdef FPC}longint{$endif}(E_NOINTERFACE);

end;



function TSQLRecordInterfaced._AddRef: {$ifdef FPC}longint{$else}integer{$endif};

begin

  result := InterlockedIncrement(fRefCount);

end;



function TSQLRecordInterfaced._Release: {$ifdef FPC}longint{$else}integer{$endif};

begin

  result := InterlockedDecrement(fRefCount);

  if result=0 then

    Destroy;

end;





{ TSQLRecordFTS3 }



class function TSQLRecordFTS3.OptimizeFTS3Index(Server: TSQLRestServer): boolean;

begin

  if (self=nil) or (Server=nil) then

    Result:= false else

    with RecordProps do

      Result := Server.ExecuteFmt('INSERT INTO %(%) VALUES(''optimize'');',

        [SQLTableName,SQLTableName]);

end;





{ TSQLRecordFTS4 }



class procedure TSQLRecordFTS4.InitializeTable(Server: TSQLRestServer;

  const FieldName: RawUTF8; Options: TSQLInitializeTableOptions);

var Props: TSQLModelRecordProperties;

    main,fts,ftsfields: RawUTF8;

begin

  inherited;

  if FieldName<>'' then

    exit;

  Props := Server.Model.Props[self];

  if (Props=nil) or (Props.fFTSWithoutContentFields='') then

    exit;

  main := Server.Model.Tables[Props.fFTSWithoutContentTableIndex].SQLTableName;

  if not Server.IsInternalSQLite3Table(Props.fFTSWithoutContentTableIndex) then begin

    Server.InternalLog('% is an external content FTS4 table but source % is not '+

      'a local SQLite3 table: FTS search would be unavailable',[self,main],sllWarning);

    exit;

  end;

  fts := Props.Props.SQLTableName;

  ftsfields := Props.Props.SQLTableSimpleFieldsNoRowID;

  // see http://www.sqlite.org/fts3.html#*fts4content

  Server.ExecuteFmt('CREATE TRIGGER %_bu BEFORE UPDATE ON % '+

    'BEGIN DELETE FROM % WHERE docid=old.rowid; END;',

    [main,main,fts]);

  Server.ExecuteFmt('CREATE TRIGGER %_bd BEFORE DELETE ON % '+

    'BEGIN DELETE FROM % WHERE docid=old.rowid; END;',

    [main,main,fts]);

  Server.ExecuteFmt('CREATE TRIGGER %_au AFTER UPDATE ON % '+

    'BEGIN INSERT INTO %(docid,%) VALUES(new.rowid%); END;',

    [main,main,fts,ftsfields,Props.fFTSWithoutContentFields]);

  Server.ExecuteFmt('CREATE TRIGGER %_ai AFTER INSERT ON % '+

    'BEGIN INSERT INTO %(docid,%) VALUES(new.rowid%); END;',

    [main,main,fts,ftsfields,Props.fFTSWithoutContentFields]);

end;





{ TSQLRecordRTree }



class procedure TSQLRecordRTree.BlobToCoord(const InBlob;

  var OutCoord: TSQLRecordTreeCoords);

begin // direct memory copy with no memory check

  MoveFast(InBlob,OutCoord,(RecordProps.Fields.Count shr 1)*sizeof(double));

end;



class function TSQLRecordRTree.ContainedIn(const BlobA,BlobB): boolean;

var A,B: TSQLRecordTreeCoords;

    i: integer;

begin

  BlobToCoord(BlobA,A);

  BlobToCoord(BlobB,B);

  result := false;

  for i := 0 to (RecordProps.Fields.Count shr 1)-1 do

    if (A[i].max<B[i].min) or (A[i].min>B[i].max) then

      exit; // no match

  result := true; // box match

end;



class function TSQLRecordRTree.RTreeSQLFunctionName: RawUTF8;

begin

  result := RecordProps.SQLTableName+'_in';

end;





{ TSQLRecordMany }



constructor TSQLRecordMany.Create;

begin

  inherited Create;

  with RecordProps do

    if (fRecordManySourceProp<>nil) and (fRecordManyDestProp<>nil) then begin

      fSourceID := fRecordManySourceProp.GetFieldAddr(Self);

      fDestID := fRecordManyDestProp.GetFieldAddr(Self);

    end;

end;



function TSQLRecordMany.ManyAdd(aClient: TSQLRest; aSourceID, aDestID: TID;

  NoDuplicates: boolean; aUseBatch: TSQLRestBatch): boolean;

begin

  result := false;

  if (self=nil) or (aClient=nil) or (aSourceID=0) or (aDestID=0) or

     (fSourceID=nil) or (fDestID=nil) then

    exit; // invalid parameters

  if NoDuplicates and

     (InternalIDFromSourceDest(aClient,aSourceID,aDestID)<>0) then

      exit; // this TRecordReference pair already exists

  fSourceID^ := aSourceID;

  fDestID^ := aDestID;

  if aUseBatch<>nil then

    result := aUseBatch.Add(self,true)<>0 else

    result := aClient.Add(self,true)<>0;

end;



function TSQLRecordMany.ManyAdd(aClient: TSQLRest; aDestID: TID;

  NoDuplicates: boolean): boolean;

begin

  if (self=nil) or (fSourceID=nil) then

    result := false else // avoid GPF

    result := ManyAdd(aClient,fSourceID^,aDestID,NoDuplicates);

end;



function TSQLRecordMany.DestGet(aClient: TSQLRest; aSourceID: TID;

  out DestIDs: TIDDynArray): Boolean;

var Where: RawUTF8;

begin

  Where := IDWhereSQL(aClient,aSourceID,False);

  if Where='' then

    result := False else

    result := aClient.OneFieldValues(RecordClass,'Dest',Where,TInt64DynArray(DestIDs));

end;



function TSQLRecordMany.DestGetJoined(aClient: TSQLRest;

  const aDestWhereSQL: RawUTF8; aSourceID: TID;

  out DestIDs: TIDDynArray): boolean;

var aTable: TSQLTable;

begin

  aTable := DestGetJoinedTable(aClient,aDestWhereSQL,aSourceID,jkDestID);

  if aTable=nil then

    Result := False else

    try

      aTable.GetRowValues(0,TInt64DynArray(DestIDs));

      Result := true;

    finally

      aTable.Free;

    end;

end;



function TSQLRecordMany.DestGetJoined(aClient: TSQLRest;

  const aDestWhereSQL: RawUTF8; aSourceID: TID): TSQLRecord;

var aTable: TSQLTable;

begin

  aTable := DestGetJoinedTable(aClient,aDestWhereSQL,aSourceID,jkDestFields);

  if aTable=nil then

    Result := nil else begin

    Result := TSQLRecordClass(RecordProps.fRecordManyDestProp.ObjectClass).Create;

    aTable.OwnerMustFree := true;

    Result.FillPrepare(aTable,ctnTrimExisting);

  end;

end;



function TSQLRecordMany.DestGetJoinedTable(aClient: TSQLRest;

  const aDestWhereSQL: RawUTF8; aSourceID: TID; JoinKind: TSQLRecordManyJoinKind;

  const aCustomFieldsCSV: RawUTF8): TSQLTable;

var Select, SQL: RawUTF8;

    SelfProps, DestProps: TSQLModelRecordProperties;

procedure SelectFields(const Classes: array of TSQLModelRecordProperties);

var i: integer;

begin

  for i := 0 to high(Classes) do begin

    Select := Select+Classes[i].SQL.TableSimpleFields[True,True];

    if i<high(Classes) then

      Select := Select+',';

  end;

end;

begin

  result := nil;

  if (Self=nil) or (fSourceID=nil) or (fDestID=nil) or (aClient=nil) then

    exit;

  if aSourceID=0 then

    if fSourceID<>nil then

      aSourceID := fSourceID^;

  if aSourceID=0 then

    exit;

  SelfProps := aClient.Model.Props[PSQLRecordClass(self)^];

  DestProps := aClient.Model.Props[TSQLRecordClass(SelfProps.Props.fRecordManyDestProp.ObjectClass)];

  case JoinKind of

    jkDestID:

      Select := DestProps.Props.SQLTableName+'.RowID';

    jkPivotID:

      Select := SelfProps.Props.SQLTableName+'.RowID';

    jkDestFields:

      if aCustomFieldsCSV='' then

        SelectFields([DestProps]) else

        Select := AddPrefixToCSV(pointer(aCustomFieldsCSV),DestProps.Props.SQLTableName+'.');

    jkPivotFields:

      if aCustomFieldsCSV='' then

        SelectFields([SelfProps]) else

        Select := AddPrefixToCSV(pointer(aCustomFieldsCSV),SelfProps.Props.SQLTableName+'.');

    jkPivotAndDestFields:

      if aCustomFieldsCSV='' then

        SelectFields([SelfProps,DestProps]) else

        Select := aCustomFieldsCSV;

  end;

  if aDestWhereSQL='' then

    // fast inlined prepared statement

    SQL := 'SELECT % FROM %,% WHERE %.Source=:(%): AND %.Dest=%.RowID' else

    if PosEx(RawUTF8(':('),aDestWhereSQL,1)>0 then

      // statement is globaly inlined -> cache prepared statement

      SQL := 'SELECT % FROM %,% WHERE %.Source=:(%): AND %.Dest=%.RowID AND %' else

      // statement is not globaly inlined -> no caching of prepared statement

      SQL := 'SELECT % FROM %,% WHERE %.Source=% AND %.Dest=%.RowID AND %';

  result := aClient.ExecuteList([PSQLRecordClass(Self)^,

     TSQLRecordClass(SelfProps.Props.fRecordManyDestProp.ObjectClass)],

    FormatUTF8(SQL,

      [Select, DestProps.Props.SQLTableName,SelfProps.Props.SQLTableName,

       SelfProps.Props.SQLTableName,aSourceID, SelfProps.Props.SQLTableName,

       DestProps.Props.SQLTableName, aDestWhereSQL]));

end;



function TSQLRecordMany.DestGet(aClient: TSQLRest;

  out DestIDs: TIDDynArray): boolean;

begin

  if fSourceID=nil then

    result := false else // avoid GPF

    result := DestGet(aClient,fSourceID^,DestIDs);

   // fSourceID has been set by TSQLRecord.Create

end;



function TSQLRecordMany.ManyDelete(aClient: TSQLRest; aSourceID, aDestID: TID;

  aUseBatch: TSQLRestBatch): boolean;

var aID: TID;

begin

  result := false;

  if (self=nil) or (aClient=nil) or (aSourceID=0) or (aDestID=0) then

    exit;

  aID := InternalIDFromSourceDest(aClient,aSourceID,aDestID);

  if aID<>0 then

    if aUseBatch<>nil then

      result := aUseBatch.Delete(RecordClass,aID)>=0 else

      result := aClient.Delete(RecordClass,aID);

end;



function TSQLRecordMany.ManyDelete(aClient: TSQLRest; aDestID: TID): boolean;

begin

  if fSourceID=nil then

    result := false else // avoid GPF

    result := ManyDelete(aClient,fSourceID^,aDestID,nil);

end;



function TSQLRecordMany.ManySelect(aClient: TSQLRest; aSourceID, aDestID: TID): boolean;

begin

  if (self=nil) or (aClient=nil) or (aSourceID=0) or (aDestID=0) then

    result := false else // invalid parameters

    result := aClient.Retrieve(FormatUTF8('Source=:(%): AND Dest=:(%):',

      [aSourceID,aDestID]),Self);

end;



function TSQLRecordMany.ManySelect(aClient: TSQLRest; aDestID: TID): boolean;

begin

  if (self=nil) or (fSourceID=nil) then

    result := false else // avoid GPF

    result := ManySelect(aClient,fSourceID^,aDestID);

end;



function TSQLRecordMany.InternalFillMany(aClient: TSQLRest;

  aID: TID; const aAndWhereSQL: RawUTF8; isDest: boolean): integer;

var aTable: TSQLTable;

    Where: RawUTF8;

begin

  result := 0;

  if self=nil then

    exit;

  if not isDest and (aID=0)then

    if fSourceID<>nil then

      aID := fSourceID^; // has been set by TSQLRecord.Create

  Where := IDWhereSQL(aClient,aID,isDest,aAndWhereSQL);

  if Where='' then

    exit;

  aTable := aClient.MultiFieldValues(RecordClass,'',Where);

  if aTable=nil then

    exit;

  aTable.OwnerMustFree := true;

  FillPrepare(aTable); // temporary storage for FillRow, FillOne and FillRewind

  result := aTable.fRowCount;

end;



function TSQLRecordMany.FillMany(aClient: TSQLRest; aSourceID: TID;

  const aAndWhereSQL: RawUTF8): integer;

begin

  result := InternalFillMany(aclient,aSourceID,aAndWhereSQL,false);

end;



function TSQLRecordMany.FillManyFromDest(aClient: TSQLRest; aDestID: TID;

  const aAndWhereSQL: RawUTF8): integer;

begin

  result := InternalFillMany(aclient,aDestID,aAndWhereSQL,true);

end;



function TSQLRecordMany.IDWhereSQL(aClient: TSQLRest; aID: TID; isDest: boolean;

  const aAndWhereSQL: RawUTF8=''): RawUTF8;

const FieldName: array[boolean] of RawUTF8 = ('Source=','Dest=');

begin

  if (self=nil) or (aID=0) or (fSourceID=nil) or (fDestID=nil) or

     (aClient=nil) then

    Result := '' else begin

    if aAndWhereSQL<>'' then

      if PosEx(RawUTF8(':('),aAndWhereSQL,1)>0 then

        Result := '%:(%): AND %' else // inlined parameters

        Result := '%% AND %' else // no inlined parameters -> not cached

      Result := '%:(%):'; // no additional where clause -> inline ID

    Result := FormatUTF8(result,[FieldName[isDest],aID,aAndWhereSQL]);

  end;

end;



function TSQLRecordMany.SourceGet(aClient: TSQLRest; aDestID: TID;

  out SourceIDs: TIDDynArray): boolean;

var Where: RawUTF8;

begin

  Where := IDWhereSQL(aClient,aDestID,True);

  if Where='' then

    Result := false else

    Result := aClient.OneFieldValues(RecordClass,'Source',Where,TInt64DynArray(SourceIDs));

end;



function TSQLRecordMany.InternalIDFromSourceDest(aClient: TSQLRest;

  aSourceID, aDestID: TID): TID;

begin

  SetID(aClient.OneFieldValue(RecordClass,'RowID',

    FormatUTF8('Source=:(%): AND Dest=:(%):',[aSourceID,aDestID])),result);

end;





{ TSQLRestTempStorage }



constructor TSQLRestTempStorage.Create(aClass: TSQLRecordClass);

begin

  inherited Create;

  fStoredClass := aClass;

  fStoredClassRecordProps := aClass.RecordProps;

  fItems.InitSpecific(

    TypeInfo(TSQLRestTempStorageItemDynArray),fItem,djInt64,@fCount);

  fItems.Sorted := true;

  // space for 524287 fake items (our sorted array would not like bigger extent)

  fLastFakeID := $100000000000;

end;



destructor TSQLRestTempStorage.Destroy;

var i: integer;

begin

  for i := 0 to fCount-1 do

    fItem[i].Value.Free;

  inherited;

end;



procedure TSQLRestTempStorage.InternalAddItem(const item: TSQLRestTempStorageItem);

begin

  fItems.Add(item);

  if (fCount>1) and (fItem[fCount-2].ID>item.ID) then

    fItems.Sort else // ensure IDs are in increasing order

    fItems.Sorted := true; // pessimistic fItems.Add() did reset to false

end;



function TSQLRestTempStorage.InternalSetFields(const FieldNames: RawUTF8;

  out Fields: TSQLFieldBits): Boolean;

begin

  if FieldNames='' then

    Fields := fStoredClassRecordProps.SimpleFieldsBits[soUpdate] else

  if FieldNames='*' then

    FillcharFast(Fields,sizeof(Fields),255) else

    if not fStoredClassRecordProps.FieldBitsFromCSV(FieldNames,Fields) then begin

      result := false; // invalid FieldNames content

      exit;

    end;

  result := True;

end;



function TSQLRestTempStorage.AddCopy(Value: TSQLRecord;

  ForceID: boolean; const FieldNames: RawUTF8): TID;

begin

  if (self=nil) or (Value=nil) then

    result := 0 else

    result := AddOwned(Value.CreateCopy,ForceID,FieldNames);

end;



function TSQLRestTempStorage.AddOwned(Value: TSQLRecord; ForceID: boolean;

  const Fields: TSQLFieldBits): TID;

var item: TSQLRestTempStorageItem;

begin

  result := 0;

  if (self=nil) or (Value=nil) or

     (ForceID and (Value.IDValue=0)) or

     IsZero(Fields) then

    exit;

  item.ValueFields := Fields;

  fSafe.Lock;

  try

    if ForceID then begin

      item.ID := Value.IDValue;

      if fItems.Find(item)>=0 then begin

        Value.Free; // avoid memory leak

        exit; // this forced ID is already existing!

      end;

      item.Kind := [itemInsert];

    end else begin

      inc(fLastFakeID);

      item.ID := fLastFakeID;

      Value.IDValue := fLastFakeID;

      item.Kind := [itemInsert,itemFakeID];

    end;

    item.Value := Value; // instance will be owned by the list

    InternalAddItem(item);

  finally

    Safe.UnLock;

  end;

  result := item.ID;

end;



function TSQLRestTempStorage.AddOwned(Value: TSQLRecord;

  ForceID: boolean; const FieldNames: RawUTF8): TID;

var fields: TSQLFieldBits;

begin

  if (self=nil) or not InternalSetFields(FieldNames,fields) then

    result := 0 else

    result := AddOwned(Value,ForceID,fields);

end;



procedure TSQLRestTempStorage.Delete(const ID: TID);

var i: integer;

    item: TSQLRestTempStorageItem;

begin

  if (self=nil) or (ID=0) then

    exit;

  fSafe.Lock;

  try

    i := fItems.Find(ID);

    if i>=0 then

    with fItem[i] do begin

      FreeAndNil(Value); // Value=nil indicates deleted reord

      if itemInsert in Kind then

        fItems.Delete(i); // Add + Delete in place -> ignore this entry

      exit;

    end;

    item.ID := ID;

    item.Value := nil;  // Value=nil indicates deleted record

    FillZero(item.ValueFields);

    InternalAddItem(item);

  finally

    Safe.UnLock;

  end;

end;



function TSQLRestTempStorage.Update(Value: TSQLRecord;

  const Fields: TSQLFieldBits): boolean;

var i,f: integer;

    item: TSQLRestTempStorageItem;

    existing: ^TSQLRestTempStorageItem;

begin

  result := false;

  if (self=nil) or (Value=nil) or (Value.IDValue=0) or

     IsZero(fields) then

    exit;

  item.ID := Value.IDValue;

  item.ValueFields := Fields;

  fSafe.Lock;

  try

    i := fItems.Find(item);

    if i>=0 then begin

      existing := @fItem[i];

      if existing.Value=nil then

        exit; // impossible to update a deleted record

      existing^.ValueFields := existing^.ValueFields+item.ValueFields;

      for f := 0 to fStoredClassRecordProps.Fields.Count-1 do

        if f in item.ValueFields then

          fStoredClassRecordProps.Fields.List[f].CopyValue(Value,existing^.Value);

    end else begin

      item.Value := Value.CreateCopy;

      FillZero(item.ValueFields);

      InternalAddItem(item);

    end;

    result := true;

  finally

    Safe.UnLock;

  end;

end;



function TSQLRestTempStorage.Update(Value: TSQLRecord;

  const FieldNames: RawUTF8): boolean;

var fields: TSQLFieldBits;

begin

  if (self<>nil) and InternalSetFields(FieldNames,fields) then

    result := Update(Value,fields) else

    result := false;

end;



function TSQLRestTempStorage.FlushAsBatch(Rest: TSQLRest;

  AutomaticTransactionPerRow: cardinal): TSQLRestBatch;

var i: integer;

begin

  if (self=nil) or (fCount=0) then begin

    result := nil;

    exit;

  end;

  result := TSQLRestBatch.Create(Rest,fStoredClass,AutomaticTransactionPerRow,[]);

  fSafe.Lock;

  try

    for i := 0 to fCount-1 do

    with fItem[i] do

      if Value=nil then

        result.Delete(ID) else begin

        if itemInsert in Kind then

          result.Add(Value,true,not(itemFakeID in Kind),ValueFields) else

          result.Update(Value,ValueFields);

        FreeAndNil(Value);

      end;

    fItems.Clear;

  finally

    Safe.UnLock;

  end;

end;



function TSQLRestTempStorage.FromEvent(Event: TSQLEvent; ID: TID;

  const JSON: RawUTF8): boolean;

var Value: TSQLRecord;

    fields: TSQLFieldBits;

begin

  if (self=nil) or (ID=0) then begin

    result := false;

    exit;

  end;

  if Event=seDelete then begin

    Delete(ID);

    result := true;

    exit;

  end;

  Value := fStoredClass.Create;

  try

    Value.FillFrom(JSON,@fields);

    Value.IDValue := ID;

    case Event of

    seAdd: begin

      result := AddOwned(Value,True,fields)<>0;

      Value := nil; // owned by the list

    end;

    seUpdate,seUpdateBlob:

      result := Update(Value,fields);

    else result := false;

    end;

  finally

    Value.Free;

  end;

end;





{ TSQLRecordProperties }



procedure TSQLRecordProperties.InternalRegisterModel(aModel: TSQLModel;

  aTableIndex: integer; aProperties: TSQLModelRecordProperties);

var i: integer;

begin

  //assert(aTableIndex>=0);

  EnterCriticalSection(fLock); // may be called from several threads at once

  try

    for i := 0 to fModelMax do

      if fModel[i].Model=aModel then

        exit; // already registered

    inc(fModelMax);

    if fModelMax>=length(fModel) then

      SetLength(fModel,fModelMax+4);

    with fModel[fModelMax] do begin

      Model := aModel;

      Properties := aProperties;

      TableIndex := aTableIndex;

    end;

  finally

    LeaveCriticalSection(fLock);

  end;

end;



const // the most ambigous keywords - others may be used as column names

  SQLITE3_KEYWORDS = ' from where group in as ';



constructor TSQLRecordProperties.Create(aTable: TSQLRecordClass);

var i,j, nProps: integer;

    nMany, nSQLRecord, nSimple, nDynArray, nBlob, nBlobCustom,

    nCopiableFields: integer;

    isTSQLRecordMany: boolean;

    F: TSQLPropInfo;

label Simple, Small, Copiabl;

begin

  InitializeCriticalSection(fLock);

  if aTable=nil then

    raise EModelException.Create('TSQLRecordProperties.Create(nil)');

  // register for JSONToObject() and for TSQLPropInfoRTTITID.Create()

  // (should have been done before in TSQLModel.Create/AddTable)

  TJSONSerializer.RegisterClassForJSON(aTable);

  // initialize internal structures

  fModelMax := -1;

  fTable := aTable;

  fSQLTableName := GetDisplayNameFromClass(aTable);

  fSQLTableNameUpperWithDot := SynCommons.UpperCase(SQLTableName)+'.';

  isTSQLRecordMany := aTable.InheritsFrom(TSQLRecordMany);

  // add properties to internal Fields list

  fClassType := PTypeInfo(aTable.ClassInfo)^.ClassType;

  fClassProp := InternalClassProp(aTable);

  nProps := ClassFieldCountWithParents(aTable);

  if nProps>MAX_SQLFIELDS_INCLUDINGID then

    raise EModelException.CreateUTF8('% has too many fields: %>=%',

      [Table,nProps,MAX_SQLFIELDS]);

  fFields := TSQLPropInfoList.Create(aTable,[pilRaiseEORMExceptionIfNotHandled]);

  aTable.InternalRegisterCustomProperties(self);

  if Fields.Count>MAX_SQLFIELDS_INCLUDINGID then

    raise EModelException.CreateUTF8(

      '% has too many fields after InternalRegisterCustomProperties(%): %>=%',

      [Table,self,Fields.Count,MAX_SQLFIELDS]);

  SetLength(Fields.fList,Fields.Count);

  // generate some internal lookup information

  fSQLTableRetrieveAllFields := 'ID';

  SetLength(fManyFields,MAX_SQLFIELDS);

  SetLength(fSimpleFields,MAX_SQLFIELDS);

  SetLength(fJoinedFields,MAX_SQLFIELDS);

  SetLength(fCopiableFields,MAX_SQLFIELDS);

  SetLength(fDynArrayFields,MAX_SQLFIELDS);

  SetLength(fBlobCustomFields,MAX_SQLFIELDS);

  SetLength(fBlobFields,MAX_SQLFIELDS);

  MainField[false] := -1;

  MainField[true] := -1;

  nMany := 0;

  nSimple := 0;

  nSQLRecord := 0;

  nCopiableFields := 0;

  nDynArray := 0;

  nBlob := 0;

  nBlobCustom := 0;

  for i := 0 to Fields.Count-1  do begin

    F := Fields.List[i];

    // check field name

    if IsRowID(pointer(F.Name)) then

      raise EORMException.CreateUTF8('ID is already defined in TSQLRecord: '+

        '%.% field name is not allowed as published property',[Table,F.Name]);

    if PosEx(' '+LowerCase(F.Name)+' ',SQLITE3_KEYWORDS)>0 then

      raise EORMException.CreateUTF8('%.% field name conflicts with a SQL keyword',[Table,F.Name]);

    //  handle unique fields, i.e. if marked as "stored false"

    if aIsUnique in F.Attributes then begin

      include(IsUniqueFieldsBits,i);

      // must trim() text value before storage, and validate for unicity

      if F.SQLFieldType in [sftUTF8Text,sftAnsiText] then

        AddFilterOrValidate(i,TSynFilterTrim.Create);

      AddFilterOrValidate(i,TSynValidateUniqueField.Create);

    end;

    // get corresponding properties content

    include(fHasTypeFields,F.SQLFieldType);

    include(FieldBits[F.SQLFieldType],i);

    case F.SQLFieldType of

      sftUnknown: ;

      sftUTF8Text: begin

        if aIsUnique in F.Attributes then

          if MainField[false]<0 then

            MainField[false] := i;

        if MainField[true]<0 then

          MainField[true] := i;

        goto Small;

      end;

      sftBlob: begin

        BlobFields[nBlob] := F as TSQLPropInfoRTTI;

        inc(nBlob);

        fSQLTableUpdateBlobFields := fSQLTableUpdateBlobFields+F.Name+'=?,';

        fSQLTableRetrieveBlobFields := fSQLTableRetrieveBlobFields+F.Name+',';

        fSQLTableRetrieveAllFields := fSQLTableRetrieveAllFields+','+F.Name;

        goto Copiabl;

      end;

      sftID: // = TSQLRecord(aID)

        if isTSQLRecordMany and

           (IdemPropNameU(F.Name,'Source') or IdemPropNameU(F.Name,'Dest')) then

          goto Small else begin

          JoinedFields[nSQLRecord] := F as TSQLPropInfoRTTIID;

          inc(nSQLRecord);

          goto Small;

        end;

      sftMany: begin

        ManyFields[nMany] := F as TSQLPropInfoRTTIMany;

        inc(nMany);

      end;

      sftBlobDynArray:

      with F as TSQLPropInfoRTTIDynArray do begin

        if DynArrayIndex>0 then

          for j := 0 to nDynArray-1 do

          if DynArrayFields[j].DynArrayIndex=DynArrayIndex then

            raise EModelException.CreateUTF8('dup index % for %.% and %.% properties',

              [DynArrayIndex,Table,Name,Table,DynArrayFields[j].Name]);

        DynArrayFields[nDynArray] := TSQLPropInfoRTTIDynArray(F);

        if TSQLPropInfoRTTIDynArray(F).ObjArray<>nil then

          fDynArrayFieldsHasObjArray := true;

        inc(nDynArray);

        goto Simple;

      end;

      sftBlobCustom, sftUTF8Custom: begin

        BlobCustomFields[nBlobCustom] := F;

        inc(nBlobCustom);

        goto Simple;

      end;

      sftCreateTime: begin

        include(ComputeBeforeAddFieldsBits,i);

        goto Small;

      end;

      sftModTime, sftSessionUserID: begin

        include(ComputeBeforeAddFieldsBits,i);

        include(ComputeBeforeUpdateFieldsBits,i);

        goto Small;

      end;

      sftRecordVersion: begin

        if fRecordVersionField<>nil then

          raise EModelException.CreateUTF8('%: only a single TRecordVersion '+

           'field is allowed per class',[Table]);

        fRecordVersionField := F as TSQLPropInfoRTTIRecordVersion;

        fSQLTableRetrieveAllFields := fSQLTableRetrieveAllFields+','+F.Name;

        goto Copiabl;

      end; // TRecordVersion is a copiable but not a simple field!

      sftVariant: // sftNullable are included in SmallfieldsBits

        goto Simple;

      else begin

Small:  include(SmallFieldsBits,i);

        // this code follows NOT_SIMPLE_FIELDS/COPIABLE_FIELDS constants

Simple: SimpleFields[nSimple] := F;

        inc(nSimple);

        include(SimpleFieldsBits[soSelect],i);

        fSQLTableSimpleFieldsNoRowID := fSQLTableSimpleFieldsNoRowID+F.Name+',';

        fSQLTableRetrieveAllFields := fSQLTableRetrieveAllFields+','+F.Name;

Copiabl:include(CopiableFieldsBits,i);

        CopiableFields[nCopiableFields] := F;

        inc(nCopiableFields);

      end;

    end;

  end;

  if fSQLTableSimpleFieldsNoRowID<>'' then

    SetLength(fSQLTableSimpleFieldsNoRowID,length(fSQLTableSimpleFieldsNoRowID)-1);

  if fSQLTableUpdateBlobFields<>'' then

    SetLength(fSQLTableUpdateBlobFields,length(fSQLTableUpdateBlobFields)-1);

  if fSQLTableRetrieveBlobFields<>'' then

    SetLength(fSQLTableRetrieveBlobFields,length(fSQLTableRetrieveBlobFields)-1);

  SetLength(fManyFields,nMany);

  SetLength(fSimpleFields,nSimple);

  SetLength(fJoinedFields,nSQLRecord);

  if nSQLRecord>0 then begin

    SetLength(fJoinedFieldsTable,nSQLRecord+1);

    fJoinedFieldsTable[0] := aTable;

    for i := 0 to nSQLRecord-1 do

      fJoinedFieldsTable[i+1] := TSQLRecordClass(JoinedFields[i].ObjectClass);

  end;

  SetLength(fCopiableFields,nCopiableFields);

  SetLength(fDynArrayFields,nDynArray);

  SetLength(fBlobCustomFields,nBlobCustom);

  SetLength(fBlobFields,nBlob);

  SimpleFieldsBits[soInsert] := SimpleFieldsBits[soSelect];

  SimpleFieldsBits[soUpdate] := SimpleFieldsBits[soSelect];

  SimpleFieldsBits[soDelete] := SimpleFieldsBits[soSelect];

  SimpleFieldsCount[soInsert] := nSimple;

  SimpleFieldsCount[soUpdate] := nSimple;

  SimpleFieldsCount[soDelete] := nSimple;

  fHasNotSimpleFields := nSimple<>Fields.Count;

  for i := 0 to Fields.Count-1 do

    if Fields.List[i].SQLFieldType=sftCreateTime then begin

      exclude(SimpleFieldsBits[soUpdate],i);

      dec(SimpleFieldsCount[soUpdate]);

    end;

  if SmallFieldsBits<>SimpleFieldsBits[soSelect]-FieldBits[sftVariant]-

    FieldBits[sftBlobDynArray]-FieldBits[sftBlobCustom]-FieldBits[sftUTF8Custom] then

    raise EModelException.CreateUTF8('TSQLRecordProperties.Create(%) Bits?',[Table]);

  if isTSQLRecordMany then begin

    fRecordManySourceProp := Fields.ByRawUTF8Name('Source') as TSQLPropInfoRTTIInstance;

    if fRecordManySourceProp=nil then

      raise EModelException.CreateUTF8('% expects a SOURCE field',[Table]) else

    fRecordManyDestProp := Fields.ByRawUTF8Name('Dest') as TSQLPropInfoRTTIInstance;

    if fRecordManyDestProp=nil then

      raise EModelException.CreateUTF8('% expects a DEST field',[Table]);

  end;

end;



function TSQLRecordProperties.BlobFieldPropFromRawUTF8(const PropName: RawUTF8): PPropInfo;

var i: integer;

begin

  if (self<>nil) and (PropName<>'') then

  for i := 0 to high(BlobFields) do

    if IdemPropNameU(BlobFields[i].Name,PropName) then begin

      result := BlobFields[i].PropInfo;

      exit;

    end;

  result := nil;

end;



function TSQLRecordProperties.BlobFieldPropFromUTF8(PropName: PUTF8Char; PropNameLen: integer): PPropInfo;

var i: integer;

begin

  if (self<>nil) and (PropName<>'') then

  for i := 0 to high(BlobFields) do

    if IdemPropName(BlobFields[i].PropInfo^.Name,PropName,PropNameLen) then begin

      result := BlobFields[i].PropInfo;

      exit;

    end;

  result := nil;

end;



const

  DBTOFIELDTYPE: array[TSQLDBFieldType] of TSQLFieldType  = (sftUnknown,

    sftUnknown,sftInteger,sftFloat,sftCurrency,sftDateTime,sftUTF8Text,sftBlob);



function TSQLRecordProperties.SQLFieldTypeToSQL(FieldIndex: integer): RawUTF8;

const

  /// simple wrapper from each SQL used type into SQLite3 field datatype

  // - set to '' for fields with no column created in the database

  DEFAULT_SQLFIELDTYPETOSQL: array[TSQLFieldType] of RawUTF8 =

   ('',                              // sftUnknown

    ' TEXT COLLATE NOCASE, ',        // sftAnsiText

    ' TEXT COLLATE SYSTEMNOCASE, ',  // sftUTF8Text

    ' INTEGER, ',                    // sftEnumerate

    ' INTEGER, ',                    // sftSet

    ' INTEGER, ',                    // sftInteger

    ' INTEGER, ',                    // sftID = TSQLRecord(aID)

    ' INTEGER, ',                    // sftRecord = TRecordReference

    ' INTEGER, ',                    // sftBoolean

    ' FLOAT, ',                      // sftFloat

    ' TEXT COLLATE ISO8601, ',       // sftDateTime

    ' INTEGER, ',                    // sftTimeLog

    ' FLOAT, ',                      // sftCurrency

    ' TEXT COLLATE BINARY, ',        // sftObject

    {$ifndef NOVARIANTS}

    ' TEXT COLLATE BINARY, ',        // sftVariant

    ' TEXT COLLATE NOCASE, ',        // sftNullable (from SQLFieldTypeStored)

    {$endif}

    ' BLOB, ',                       // sftBlob

    ' BLOB, ',                       // sftBlobDynArray

    ' BLOB, ',                       // sftBlobCustom

    ' TEXT COLLATE NOCASE, ',        // sftUTF8Custom

    '',                              // sftMany

    ' INTEGER, ',                    // sftModTime

    ' INTEGER, ',                    // sftCreateTime

    ' INTEGER, ',                    // sftTID

    ' INTEGER, ',                    // sftRecordVersion

    ' INTEGER, ');                   // sftSessionUserID

begin

  if (self=nil) or (cardinal(FieldIndex)>=cardinal(Fields.Count)) then

    result := '' else

  if (FieldIndex<length(fCustomCollation)) and (fCustomCollation[FieldIndex]<>'') then

    result := ' TEXT COLLATE '+fCustomCollation[FieldIndex]+', ' else

    result := DEFAULT_SQLFIELDTYPETOSQL[Fields.List[FieldIndex].SQLFieldTypeStored];

end;



function TSQLRecordProperties.SetCustomCollation(FieldIndex: integer; const aCollationName: RawUTF8): boolean;

begin

  result := (self<>nil) and (cardinal(FieldIndex)<cardinal(Fields.Count));

  if result then begin

    if Fields.Count>length(fCustomCollation) then

      SetLength(fCustomCollation,Fields.Count);

    fCustomCollation[FieldIndex] := aCollationName;

  end;

end;



function TSQLRecordProperties.SetCustomCollation(const aFieldName, aCollationName: RawUTF8): boolean;

begin

  result := SetCustomCollation(Fields.IndexByNameOrExcept(aFieldName),aCollationName);

end;



procedure TSQLRecordProperties.SetCustomCollationForAll(aFieldType: TSQLFieldType;

  const aCollationName: RawUTF8);

var i: integer;

begin

  if (self=nil) or (aFieldType in [sftUnknown,sftMany]) then

    exit;

  if Fields.Count>length(fCustomCollation) then

    SetLength(fCustomCollation,Fields.Count);

  for i := 0 to Fields.Count-1 do

    if Fields.List[i].SQLFieldTypeStored=aFieldType then

      fCustomCollation[i] := aCollationName;

end;



procedure TSQLRecordProperties.SetMaxLengthValidatorForTextFields(IndexIsUTF8Length: boolean);

var i: integer;

begin

  if self<>nil then

  for i := 0 to Fields.Count-1 do

    with Fields.List[i] do

    if (SQLDBFieldType in TEXT_DBFIELDS) and (cardinal(FieldWidth-1)<262144) then

      AddFilterOrValidate(i,TSynValidateText.CreateUTF8('{maxLength:%,UTF8Length:%}',

        [FieldWidth,IndexIsUTF8Length],[]));

end;



procedure TSQLRecordProperties.SetMaxLengthFilterForTextFields(IndexIsUTF8Length: boolean);

var i: integer;

begin

  if self<>nil then

  for i := 0 to Fields.Count-1 do

    with Fields.List[i] do

    if (SQLDBFieldType in TEXT_DBFIELDS) and (cardinal(FieldWidth-1)<262144) then

      AddFilterOrValidate(i,TSynFilterTruncate.CreateUTF8('{maxLength:%,UTF8Length:%}',

        [FieldWidth,IndexIsUTF8Length],[]));

end;



{$ifndef NOVARIANTS}

procedure TSQLRecordProperties.SetVariantFieldsDocVariantOptions(const Options: TDocVariantOptions);

var i: integer;

begin

  if self<>nil then

  for i := 0 to Fields.Count-1 do

    if (Fields.List[i].SQLFieldType=sftVariant) and

       Fields.List[i].InheritsFrom(TSQLPropInfoRTTIVariant) then

      TSQLPropInfoRTTIVariant(Fields.List[i]).DocVariantOptions := Options;

end;

{$endif}



function TSQLRecordProperties.SQLAddField(FieldIndex: integer): RawUTF8;

begin

  if (self=nil) or (cardinal(FieldIndex)>=cardinal(Fields.Count)) then begin

    result := '';

    exit;

  end;

  result := SQLFieldTypeToSQL(FieldIndex);

  if result='' then

    exit; // some fields won't have any column created in the database

  result := FormatUTF8('ALTER TABLE % ADD COLUMN %%',

    [SQLTableName,Fields.List[FieldIndex].Name,result]);

  if FieldIndex in IsUniqueFieldsBits then

    insert(' UNIQUE',result,length(result)-1);

  result[length(result)-1] := ';' // SQLFieldTypeToSQL[] ends with ','

end;



procedure TSQLRecordProperties.SetJSONWriterColumnNames(W: TJSONSerializer;

  KnownRowsCount: integer);

var i,n,nf: integer;

begin

  // get col count overhead

  if W.withID then

    n := 1 else

    n := 0;

  // set col names

  nf := Length(W.Fields);

  SetLength(W.ColNames,nf+n);

  if W.withID then

    W.ColNames[0] := 'RowID'; // works for both normal and FTS3 records

  for i := 0 to nf-1 do begin

    W.ColNames[n] := Fields.List[W.Fields[i]].Name;

    inc(n);

  end;

  // write or init field names for appropriate JSON Expand

  W.AddColumns(KnownRowsCount);

end;



function TSQLRecordProperties.CreateJSONWriter(JSON: TStream; Expand,

  withID: boolean; const aFields: TSQLFieldBits; KnownRowsCount: integer): TJSONSerializer;

begin

  result := CreateJSONWriter(JSON,Expand,withID,

    FieldBitsToIndex(aFields,Fields.Count),KnownRowsCount);

end;



function TSQLRecordProperties.CreateJSONWriter(JSON: TStream; Expand,

  withID: boolean; const aFields: TSQLFieldIndexDynArray; KnownRowsCount: integer): TJSONSerializer;

begin

  if (self=nil) or ((Fields=nil) and not withID) then  // no data

    result := nil else begin

    result := TJSONSerializer.Create(JSON,Expand,withID,aFields);

    SetJSONWriterColumnNames(result,KnownRowsCount);

  end;

end;



function TSQLRecordProperties.CreateJSONWriter(JSON: TStream; Expand: boolean;

   const aFieldsCSV: RawUTF8; KnownRowsCount: integer): TJSONSerializer;

var withID: boolean;

    bits: TSQLFieldBits;

begin

  FieldBitsFromCSV(aFieldsCSV,bits,withID);

  result := CreateJSONWriter(JSON,Expand,withID,bits,KnownRowsCount);

end;



function TSQLRecordProperties.SaveSimpleFieldsFromJsonArray(var P: PUTF8Char;

  var EndOfObject: AnsiChar; ExtendedJSON: boolean): RawUTF8;

var i: integer;

    W: TJSONSerializer;

    Start: PUTF8Char;

begin

  result := '';

  if P=nil then

    exit;

  if P^ in [#1..' '] then repeat inc(P) until not(P^ in [#1..' ']);

  if P^<>'[' then

    exit;

  repeat inc(P) until not(P^ in [#1..' ']);

  W := TJSONSerializer.CreateOwnedStream(1024);

  try

    W.Add('{');

    for i := 0 to length(SimpleFields)-1 do begin

      if ExtendedJSON then begin

        W.AddString(SimpleFields[i].Name);

        W.Add(':');

      end else

        W.AddFieldName(SimpleFields[i].Name);

      Start := P;

      P := GotoEndJSONItem(P);

      if (P=nil) or not(P^ in [',',']']) then

        exit;

      W.AddNoJSONEscape(Start,P-Start);

      W.Add(',');

      repeat inc(P) until not(P^ in [#1..' ']);

    end;

    W.CancelLastComma;

    W.Add('}');

    W.SetText(result);

  finally

    W.Free;

  end;

  EndOfObject := P^;

  if P^<>#0 then

    repeat inc(P) until not(P^ in [#1..' ']);

end;



procedure TSQLRecordProperties.SaveBinaryHeader(W: TFileBufferWriter);

var i: integer;

    FieldNames: TRawUTF8DynArray;

begin

  W.Write(SQLTableName);

  SetLength(FieldNames,Fields.Count);

  for i := 0 to Fields.Count-1 do

    FieldNames[i] := Fields.List[i].Name;

  W.WriteRawUTF8DynArray(FieldNames,Fields.Count);

  for i := 0 to Fields.Count-1 do

    W.Write(@Fields.List[i].fSQLFieldType,sizeof(TSQLFieldType));

end;



function TSQLRecordProperties.CheckBinaryHeader(var R: TFileBufferReader): boolean;

var n,i: integer;

    FieldNames: TRawUTF8DynArray;

    FieldTypes: array[0..MAX_SQLFIELDS-1] of TSQLFieldType;

begin

  result := false;

  if (R.ReadRawUTF8<>SQLTableName) or

     (R.ReadVarRawUTF8DynArray(FieldNames)<>Fields.Count) then

    exit;

  n := sizeof(TSQLFieldType)*Fields.Count;

  if R.Read(@FieldTypes,n)<>n then

    exit;

  for i := 0 to Fields.Count-1 do

    with Fields.List[i] do

    if (Name<>FieldNames[i]) or (SQLFieldType<>FieldTypes[i]) then

      exit;

  result := true;

end;



function TSQLRecordProperties.IsFieldName(const PropName: RawUTF8): boolean;

begin

  result := (PropName<>'') and

    (isRowID(pointer(PropName)) or (Fields.IndexByName(PropName)>=0));

end;



function TSQLRecordProperties.IsFieldNameOrFunction(const PropName: RawUTF8): boolean;

var L: integer;

begin

  L := length(PropName);

  if (L=0) or (self=nil) then

    result := false else

    if (PropName[L]=')') and

       (IdemPCharArray(pointer(PropName),['MAX(','MIN(','AVG(','SUM('])>=0) then

      result := IsFieldName(copy(PropName,5,L-5)) else

      result := IsFieldName(PropName);

end;



function TSQLRecordProperties.AddFilterOrValidate(aFieldIndex: integer;

  aFilter: TSynFilterOrValidate): boolean;

begin

  if (self=nil) or (cardinal(aFieldIndex)>=cardinal(Fields.Count)) or

    (aFilter=nil) then

    result := false else begin

    if Filters=nil then

      SetLength(fFilters,Fields.Count);

    aFilter.AddOnce(Filters[aFieldIndex]);

    result := true;

  end;

end;



procedure TSQLRecordProperties.AddFilterOrValidate(const aFieldName: RawUTF8;

  aFilter: TSynFilterOrValidate);

begin

  AddFilterOrValidate(Fields.IndexByNameOrExcept(aFieldName),aFilter);

end;



destructor TSQLRecordProperties.Destroy;

var f: integer;

begin

  for f := 0 to high(Filters) do

    ObjArrayClear(Filters[f]); // will free any created TSynFilter instances

  inherited;

  DeleteCriticalSection(fLock);

  Fields.Free;

end;



function TSQLRecordProperties.FieldBitsFromBlobField(aBlobField: PPropInfo;

  var Bits: TSQLFieldBits): boolean;

var f: integer;

begin

  FillZero(Bits);

  if self<>nil then

  for f := 0 to high(BlobFields) do

    if BlobFields[f].fPropInfo=aBlobField then begin

      Include(Bits,BlobFields[f].PropertyIndex);

      result := true;

      exit;

    end;

  result := false;

end;



function TSQLRecordProperties.FieldBitsFromCSV(const aFieldsCSV: RawUTF8;

  var Bits: TSQLFieldBits): boolean;

var ndx: integer;

    P: PUTF8Char;

    FieldName: ShortString;

begin

  FillZero(Bits);

  result := false;

  if self=nil then

    exit;

  P := pointer(aFieldsCSV);

  while P<>nil do begin

    GetNextItemShortString(P,FieldName);

    FieldName[ord(FieldName[0])+1] := #0; // make PUTF8Char

    ndx := Fields.IndexByName(@FieldName[1]);

    if ndx<0 then

      exit; // invalid field name

    include(Bits,ndx);

  end;

  result := true;

end;



function TSQLRecordProperties.FieldBitsFromCSV(const aFieldsCSV: RawUTF8;

  var Bits: TSQLFieldBits; out withID: boolean): boolean;

var ndx: integer;

    P: PUTF8Char;

    FieldName: ShortString;

begin

  if (aFieldsCSV='*') and (self<>nil) then begin

    Bits := SimpleFieldsBits[soSelect];

    withID := true;

    result := true;

    exit;

  end;

  FillZero(Bits);

  withID := false;

  result := false;

  if self=nil then

    exit;

  P := pointer(aFieldsCSV);

  while P<>nil do begin

    GetNextItemShortString(P,FieldName);

    if IsRowIDShort(FieldName) then begin

      withID := true;

      continue;

    end;

    FieldName[ord(FieldName[0])+1] := #0; // make PUTF8Char

    ndx := Fields.IndexByName(@FieldName[1]);

    if ndx<0 then

      exit; // invalid field name

    include(Bits,ndx);

  end;

  result := true;

end;



function TSQLRecordProperties.FieldBitsFromCSV(const aFieldsCSV: RawUTF8): TSQLFieldBits;

begin

  if not FieldBitsFromCSV(aFieldsCSV,Result) then

    FillZero(result);

end;



function TSQLRecordProperties.FieldBitsFromExcludingCSV(

  const aFieldsCSV: RawUTF8; aOccasion: TSQLOccasion): TSQLFieldBits;

var excluded: TSQLFieldBits;

begin

  result := SimpleFieldsBits[aOccasion];

  if FieldBitsFromCSV(aFieldsCSV,excluded) then

    result := result-excluded;

end;



function TSQLRecordProperties.FieldBitsFromRawUTF8(const aFields: array of RawUTF8;

  var Bits: TSQLFieldBits): boolean;

var f,ndx: integer;

begin

  FillZero(Bits);

  result := false;

  if self=nil then

    exit;

  for f := 0 to high(aFields) do begin

    ndx := Fields.IndexByName(aFields[f]);

    if ndx<0 then

      exit; // invalid field name

    include(Bits,ndx);

  end;

  result := true;

end;



function TSQLRecordProperties.FieldBitsFromRawUTF8(const aFields: array of RawUTF8): TSQLFieldBits;

begin

  if not FieldBitsFromRawUTF8(aFields,Result) then

    FillZero(result);

end;



function TSQLRecordProperties.CSVFromFieldBits(const Bits: TSQLFieldBits): RawUTF8;

var f: integer;

    W: TTextWriter;

begin

  W := TTextWriter.CreateOwnedStream(512);

  try

    for f := 0 to Fields.Count-1 do

      if f in Bits then begin

        W.AddString(Fields.List[f].Name);

        W.Add(',');

      end;

    W.CancelLastComma;

    W.SetText(result);

  finally

    W.Free;

  end;

end;



function TSQLRecordProperties.FieldIndexDynArrayFromRawUTF8(

  const aFields: array of RawUTF8; var Indexes: TSQLFieldIndexDynArray): boolean;

var f,ndx: integer;

begin

  result := false;

  if self=nil then

    exit;

  for f := 0 to high(aFields) do begin

    ndx := Fields.IndexByName(aFields[f]);

    if ndx<0 then

      exit; // invalid field name

    AddFieldIndex(Indexes,ndx);

  end;

  result := true;

end;



function TSQLRecordProperties.FieldIndexDynArrayFromRawUTF8(const aFields: array of RawUTF8): TSQLFieldIndexDynArray;

begin

  if not FieldIndexDynArrayFromRawUTF8(aFields,result) then

    result := nil;

end;



function TSQLRecordProperties.FieldIndexDynArrayFromCSV(const aFieldsCSV: RawUTF8;

  var Indexes: TSQLFieldIndexDynArray): boolean;

var ndx: integer;

    P: PUTF8Char;

    FieldName: ShortString;

begin

  result := false;

  if self=nil then

    exit;

  P := pointer(aFieldsCSV);

  while P<>nil do begin

    GetNextItemShortString(P,FieldName);

    FieldName[ord(FieldName[0])+1] := #0; // make PUTF8Char

    ndx := Fields.IndexByName(@FieldName[1]);

    if ndx<0 then

      exit; // invalid field name

    AddFieldIndex(Indexes,ndx);

  end;

  result := true;

end;



function TSQLRecordProperties.FieldIndexDynArrayFromCSV(const aFieldsCSV: RawUTF8): TSQLFieldIndexDynArray;

begin

  if not FieldIndexDynArrayFromCSV(aFieldsCSV,result) then

    result := nil;

end;



function TSQLRecordProperties.FieldIndexDynArrayFromBlobField(aBlobField: PPropInfo;

  var Indexes: TSQLFieldIndexDynArray): boolean;

var f: integer;

begin

  if self<>nil then

  for f := 0 to high(BlobFields) do

    if BlobFields[f].fPropInfo=aBlobField then begin

      AddFieldIndex(Indexes,BlobFields[f].PropertyIndex);

      result := true;

      exit;

    end;

  result := false;

end;



function TSQLRecordProperties.AppendFieldName(FieldIndex: Integer;

  var Text: RawUTF8; ForceNoRowID: boolean): boolean;

begin

  result := false; // success

  if FieldIndex=VIRTUAL_TABLE_ROWID_COLUMN then

    if ForceNoRowID then

      Text := Text+'ID' else

      Text := Text+'RowID' else

  if (self=nil) or (cardinal(FieldIndex)>=cardinal(Fields.Count)) then

    result := true else

    Text := Text+Fields.List[FieldIndex].Name;

end;



function TSQLRecordProperties.MainFieldName(ReturnFirstIfNoUnique: boolean=false): RawUTF8;

begin

  if (self=nil) or (Table=nil) or (MainField[ReturnFirstIfNoUnique]<0) then

    result := '' else

    result := Fields.List[MainField[ReturnFirstIfNoUnique]].Name;

end;



procedure TSQLRecordProperties.RegisterCustomFixedSizeRecordProperty(

  aTable: TClass; aRecordSize: cardinal; const aName: RawUTF8;

  aPropertyPointer: pointer; aAttributes: TSQLPropInfoAttributes;

  aFieldWidth: integer; aData2Text: TOnSQLPropInfoRecord2Text;

  aText2Data: TOnSQLPropInfoRecord2Data);

begin

  Fields.Add(TSQLPropInfoRecordFixedSize.Create(aRecordSize,aName,Fields.Count,

    aPropertyPointer,aAttributes,aFieldWidth,aData2Text,aText2Data));

end;



procedure TSQLRecordProperties.RegisterCustomRTTIRecordProperty(aTable: TClass;

  aRecordInfo: PTypeInfo; const aName: RawUTF8;  aPropertyPointer: pointer;

  aAttributes: TSQLPropInfoAttributes=[]; aFieldWidth: integer=0;

  aData2Text: TOnSQLPropInfoRecord2Text=nil;

  aText2Data: TOnSQLPropInfoRecord2Data=nil);

begin

  Fields.Add(TSQLPropInfoRecordRTTI.Create(aRecordInfo,aName,Fields.Count,

    aPropertyPointer,aAttributes,aFieldWidth,aData2Text,aText2Data));

end;



procedure TSQLRecordProperties.RegisterCustomPropertyFromRTTI(aTable: TClass;

  aTypeInfo: PTypeInfo; const aName: RawUTF8; aPropertyPointer: pointer;

  aAttributes: TSQLPropInfoAttributes=[]; aFieldWidth: integer=0);

begin

  Fields.Add(TSQLPropInfoCustomJSON.Create(aTypeInfo,aName,Fields.Count,

    aPropertyPointer,aAttributes,aFieldWidth));

end;



procedure TSQLRecordProperties.RegisterCustomPropertyFromTypeName(aTable: TClass;

  const aTypeName, aName: RawUTF8; aPropertyPointer: pointer;

  aAttributes: TSQLPropInfoAttributes=[]; aFieldWidth: integer=0);

begin

  Fields.Add(TSQLPropInfoCustomJSON.Create(aTypeName,aName,Fields.Count,

    aPropertyPointer,aAttributes,aFieldWidth));

end;





{ TSynValidateUniqueField }



function TSynValidateUniqueField.Process(aFieldIndex: integer; const Value: RawUTF8;

  var ErrorMsg: string): boolean;

var aID: TID;

begin

  result := false;

  if Value='' then

    ErrorMsg := sValidationFieldVoid else

  if (fProcessRest=nil) or (fProcessRec=nil) then

    result := true else

  with fProcessRec.RecordProps do

    if cardinal(aFieldIndex)>=cardinal(Fields.Count) then

      result := true else begin

      SetID(fProcessRest.OneFieldValue(Table,'RowID',

        Fields.List[aFieldIndex].Name+'=:('+QuotedStr(Value,'''')+'):'),aID);

      if (aID>0) and (aID<>fProcessRec.fID) then

        ErrorMsg := sValidationFieldDuplicate else

        result := true;

    end;

end;





{ TSynValidateUniqueFields }



procedure TSynValidateUniqueFields.SetParameters(const Value: RawUTF8);

var V: TPUtf8CharDynArray;

    tmp: TSynTempBuffer;

begin

  tmp.Init(Value);

  try

    JSONDecode(tmp.buf,['FieldNames'],V,True);

    CSVToRawUTF8DynArray(V[0],fFieldNames);

  finally

    tmp.Done;

  end;

end;



function TSynValidateUniqueFields.Process(aFieldIndex: integer;

  const Value: RawUTF8; var ErrorMsg: string): boolean;

var where: RawUTF8;

    i: integer;

    aID: TID;

begin

  where := ''; // alf: to circumvent FPC issues

  if (fProcessRest=nil) or (fProcessRec=nil) or (fFieldNames=nil) then

    result := true else begin

    for i := 0 to high(fFieldNames) do begin

      if where<>'' then

        where := where+' AND ';

      where := where+fFieldNames[i]+'=:('+

        QuotedStr(fProcessRec.GetFieldValue(fFieldNames[i]),'''')+'):';

    end;

    SetID(fProcessRest.OneFieldValue(fProcessRec.RecordClass,'ID',where),aID);

    if (aID>0) and (aID<>fProcessRec.fID) then begin

      ErrorMsg := sValidationFieldDuplicate;

      result := false;

    end else

      result := true;

  end;

end;





{ TJSONSerializer }



procedure TJSONSerializer.WriteObject(Value: TObject; Options: TTextWriterWriteObjectOptions);

var Added: boolean;

    CustomComment: RawUTF8;



  procedure HR(P: PPropInfo=nil);

  begin

    if woHumanReadable in Options then begin

      if CustomComment<>'' then begin

        AddShort(' // ');

        AddString(CustomComment);

        CustomComment := '';

      end;

      AddCRAndIndent;

    end;

    if P=nil then

      exit;

    AddPropName(P^.Name); // would handle twoForceJSONExtended in CustomOptions

    if woHumanReadable in Options then

      Add(' ');

    Added := true;

  end;



var P: PPropInfo;

    i, V, c, codepage: integer;

    V64: Int64;

    Obj: TObject;

    List: TList absolute Value;

{$ifndef LVCL}

    Coll: TCollection absolute Value;

{$endif}

    Str: TStrings absolute Value;

    Utf: TRawUTF8List absolute Value;

    Table: TSQLTable absolute Value;

    aClassType: TClass;

    Kind: TTypeKind;

    UtfP: PPUtf8CharArray;

    IsObj: TJSONObject;

    IsObjCustomIndex: integer;

    PS: PShortString;

    WS: WideString;

    {$ifdef HASVARUSTRING}

    US: UnicodeString;

    {$endif}

    tmp: RawByteString;

    dyn: TDynArray;

    dynObjArray: PClassInstance;

    {$ifndef NOVARIANTS}

    VVariant: variant;

    {$endif}

label next;

begin

  if not (woHumanReadable in Options) or (fHumanReadableLevel<0) then

    fHumanReadableLevel := 0;

  if (self=nil) or (Value=nil) then begin

    AddShort('null'); // return void object

    exit;

  end;

  aClassType := PClass(Value)^;

  IsObj := JSONObject(aClassType,IsObjCustomIndex,[cpWrite]);

  if woFullExpand in Options then

    if IsObj=oSynMonitor then begin // nested values do not need extended info

      exclude(Options,woFullExpand);

      include(Options,woEnumSetsAsText); // only needed info is textual enums

     end else begin

      Add('{');

      AddInstanceName(Value,':');

    end;

  case IsObj of

  // handle custom class serialization

  oCustom:

    with JSONCustomParsers[IsObjCustomIndex] do begin

      if Assigned(Writer) then

        Writer(self,Value,Options);

      exit;

    end;

  // handle JSON arrays

  oSQLTable:

    Table.GetJSONValues(Stream,true);

  oList, oObjectList, {$ifndef LVCL}oCollection,{$endif} oUtfs, oStrings: begin

    HR;

    Add('['); // write as JSON array of JSON objects

    inc(fHumanReadableLevel);

    case IsObj of

    oList: // TList

      for c := 0 to List.Count-1 do begin

        WriteObject(List.List[c],Options);

        Add(',');

      end;

    oObjectList: begin

      if not (woObjectListWontStoreClassName in Options) then

        // TObjectList will include "ClassName":"TMyObject" field

        Options := Options+[woStoreClassName];

      for c := 0 to List.Count-1 do begin

        WriteObject(List.List[c],Options);

        Add(',');

      end;

    end;

{$ifndef LVCL}

    oCollection:

      for c := 0 to Coll.Count-1 do begin

        WriteObject(Coll.Items[c],Options);

        Add(',');

      end;

{$endif}

    oUtfs: begin

      UtfP := Utf.ListPtr;

      for c := 0 to Utf.Count-1 do begin

        HR;

        Add('"');

        AddJSONEscape(UtfP^[c]);

        Add('"',',');

      end;

    end;

    oStrings:

      for c := 0 to Str.Count-1 do begin

        HR;

        Add('"');

        AddJSONEscapeString(Str[c]);

        Add('"',',');

      end;

    end;

    CancelLastComma;

    dec(fHumanReadableLevel);

    HR;

    Add(']');

    if woFullExpand in Options then

      Add('}');

    exit;

  end;

  end;

  // handle JSON object

  Add('{');

  inc(fHumanReadableLevel);

  if woStoreClassName in Options then begin // optional "ClassName":"TObjectClass"

    HR;

    AddPropName('ClassName');

    Add('"');

    AddShort(PShortString(PPointer(PPtrInt(Value)^+vmtClassName)^)^);

    Add('"',',');

  end;

  if IsObj in [oSQLRecord,oSQLMany] then begin

    // manual handling of TSQLRecord.ID property serialization

    HR;

    AddPropName('ID');

    if woHumanReadable in Options then

      Add(' ');

    Add(TSQLRecord(Value).fID);

    Add(',');

  end else begin

    if woStorePointer in Options then begin // "Address":"0431298a" field

      HR;

      AddPropName('Address');

      Add('"');

      AddPointer(PtrUInt(Value));

      Add('"',',');

    end;

    case IsObj of

    oException: begin

      HR;

      AddPropName('Message');

      Add('"');

      AddJSONEscapeString(Exception(Value).Message);

      Add('"',',');

    end;

    end;

  end;

  repeat

    for i := 1 to InternalClassPropInfo(aClassType,P) do begin

      if Assigned(OnWriteObject) and OnWriteObject(self,Value,P,Options) then

        goto next else

      if IsObj in [oSQLRecord,oSQLMany] then begin // ignore "stored AS_UNIQUE"

        if IsRowIDShort(P^.Name) then

          goto next; // should not happen

      end else

        if (not (woStoreStoredFalse in Options)) and

           (not P^.IsStored(Value)) then

          goto next; // ignore regular "stored false" attribute

      Added := false;  // HR(P) would write field name and set Added := true

      Kind := P^.PropType^.Kind;

      case Kind of

        tkInt64{$ifdef FPC}, tkQWord{$endif}: begin

          V64 := P^.GetInt64Prop(Value);

          if not ((woDontStoreDefault in Options) and (V64=Int64(P^.Default))) then begin

            HR(P);

            if (woTimeLogAsText in Options) and (P^.PropType^.GetSQLFieldType

                in [sftTimeLog,sftModTime,sftCreateTime]) then begin

              Add('"');

              AddTimeLog(@V64);

              Add('"');

            end else

              Add(V64);

          end;

        end;

        {$ifdef FPC} tkBool, {$endif}

        tkEnumeration, tkInteger, tkSet: begin

          V := P^.GetOrdProp(Value);

          if (V<>P^.Default) or not (woDontStoreDefault in Options) then begin

            HR(P);

            if {$ifdef FPC}(Kind=tkBool) or{$endif}

               ((Kind=tkEnumeration) and (P^.TypeInfo=TypeInfo(boolean))) then

              Add(boolean(V)) else

              if (woFullExpand in Options) or (woHumanReadable in Options) or

                 (woEnumSetsAsText in Options) or

                 (twoEnumSetsAsTextInRecord in CustomOptions) then

              case Kind of

              tkEnumeration:

              with P^.PropType^.EnumBaseType^ do begin

                Add('"');

                PS := GetEnumNameOrd(V);

                if twoTrimLeftEnumSets in CustomOptions then

                  AddTrimLeftLowerCase(PS) else

                  AddShort(PS^);

                Add('"');

                if woHumanReadableEnumSetAsComment in Options then

                  GetEnumNameAll(CustomComment,'',true);

              end;

              tkSet:

              with P^.PropType^.SetEnumType^ do begin

                GetSetNameCSV(self,V,',',woHumanReadableFullSetsAsStar in Options);

                if woHumanReadableEnumSetAsComment in Options then

                  GetEnumNameAll(CustomComment,'"*" or a set of ',true);

              end;

              else

                Add(V);

              end else

                Add(V); // typecast enums and sets as plain integer by default

          end;

        end;

        {$ifdef FPC}tkAString,{$endif} tkLString: begin

          codepage := P^.PropType^.AnsiStringCodePage;

          if (codepage=CP_SQLRAWBLOB) and not (woSQLRawBlobAsBase64 in Options) then begin

            if not (woDontStoreEmptyString in Options) then begin

              HR(P);

              AddShort('""');

            end;

          end else begin

            P^.GetLongStrProp(Value,tmp);

            if (tmp<>'') or not (woDontStoreEmptyString in Options) then begin

              HR(P);

              Add('"');

              if (IsObj=oPersistentPassword) and (codepage=CP_UTF8) and

                 ((woHideSynPersistentPassword in Options) or

                  (woFullExpand in Options)) and

                 P^.GetterIsField and (P^.GetterAddr(Value)=

                   TSynPersistentWithPassword(Value).GetPasswordFieldAddress) then begin

                if tmp<>'' then

                  AddShort('***')

              end else

                AddAnyAnsiString(tmp,twJSONEscape,codepage);

              Add('"');

            end;

          end;

        end;

        tkFloat: begin

          HR(P);

          if (P^.TypeInfo=TypeInfo(Currency)) and P^.GetterIsField then

            AddCurr64(PInt64(P^.GetterAddr(Value))^) else

          if P^.TypeInfo=TypeInfo(TDateTime) then begin

            if woDateTimeWithMagic in Options then

              AddNoJSONEscape(@JSON_SQLDATE_MAGIC_QUOTE_VAR,4) else

              Add('"');

            AddDateTime(P^.GetDoubleProp(Value));

            if woDateTimeWithZSuffix in Options then

              Add('Z');

            Add('"');

          end else

            Add(P^.GetFloatProp(Value),DOUBLE_PRECISION);

        end;

        {$ifdef HASVARUSTRING}

        tkUString: begin // write converted to UTF-8

          US := P^.GetUnicodeStrProp(Value);

          if (US<>'') or not (woDontStoreEmptyString in Options) then begin

            HR(P);

            Add('"');

            AddJSONEscapeW(pointer(US));

            Add('"');

          end;

        end;

        {$endif}

        tkWString: begin // write converted to UTF-8

          P^.GetWideStrProp(Value,WS);

          if (WS<>'') or not (woDontStoreEmptyString in Options) then begin

            HR(P);

            Add('"');

            AddJSONEscapeW(pointer(WS));

            Add('"');

          end;

        end;

        tkDynArray: begin

          HR(P);

          P^.GetDynArray(Value,dyn);

          dynObjArray := P^.DynArrayIsObjArrayInstance;

          if dynObjArray<>nil then begin

            if dyn.Count=0 then begin

              if woHumanReadableEnumSetAsComment in Options then

                CustomComment := FormatUTF8('array of {%}',[

                  ClassFieldNamesAllPropsAsText(dynObjArray^.ItemClass,true)]);

              Add('[',']');

            end else begin // do not use AddDynArrayJSON to support HR

              inc(fHumanReadableLevel);

              Add('[');

              for c := 0 to dyn.Count-1 do begin

                WriteObject(PPointerArray(dyn.Value^)^[c],Options);

                Add(',');

              end;

              CancelLastComma;

              dec(fHumanReadableLevel);

              HR;

              Add(']');

            end;

          end else

            AddDynArrayJSON(dyn);

        end;

        {$ifdef PUBLISHRECORD}

        tkRecord{$ifdef FPC},tkObject{$endif}: begin

          HR(P);

          AddRecordJSON(P^.GetFieldAddr(Value)^,P^.PropType^);

        end;

        {$endif}

        {$ifndef NOVARIANTS}

        tkVariant: begin // stored as JSON, e.g. '1.234' or '"text"'

          HR(P);

          P^.GetVariantProp(Value,VVariant);

          AddVariant(VVariant,twJSONEscape);

        end;

        {$endif}

        tkClass: begin

          Obj := P^.GetObjProp(Value);

          case IsObj of

          oSQLRecord,oSQLMany: // TSQLRecord or inherited

            if PropIsIDTypeCastedField(P,IsObj,Value) then begin

              HR(P);

              Add(PtrInt(Obj)); // not true instances, but ID

            end else

            if Obj<>nil then begin

              HR(P);

              WriteObject(Obj,Options);

            end;

          else // TPersistent or any class defined with $M+

            if Obj<>nil then begin

              HR(P);

              WriteObject(Obj,Options);

            end;

          end;

        end;

        // tkString (shortstring) and tkInterface is not handled

      end;

      if Added then

        Add(',');

next: P := P^.Next;

    end;

    if woDontStoreInherited in Options then

      break;

    aClassType := aClassType.ClassParent;

  until aClassType=nil;

  CancelLastComma;

  dec(fHumanReadableLevel);

  HR;

  Add('}');

  if woFullExpand in Options then

    Add('}');

end;



procedure TJSONSerializer.AddInstancePointer(Instance: TObject; SepChar: AnsiChar;

  IncludeUnitName: boolean);

var info: PTypeInfo;

begin

  if IncludeUnitName then begin

    info := PPointer(PPtrInt(Instance)^+vmtTypeInfo)^;

    if info<>nil then begin // avoid GPF if not RTTI for this class

      with info^ do

        AddShort(PClassType(AlignToPtr(@Name[ord(Name[0])+1]))^.UnitName);

      Add('.');

    end;

  end;

  inherited AddInstancePointer(Instance,SepChar,IncludeUnitName);

end;



procedure TJSONSerializer.SetSQLRecordOptions(Value: TJSONSerializerSQLRecordOptions);

begin

  fSQLRecordOptions := Value;

  if Value*[jwoAsJsonNotAsString,jwoID_str]<>[] then

    if (ColNames<>nil) and (ColNames[0]='"RowID":') then

      ColNames[0] := '"ID":'; // as expected by AJAX

end;





{ TSQLVirtualTableModule }



constructor TSQLVirtualTableModule.Create(aTableClass: TSQLVirtualTableClass;

  aServer: TSQLRestServer);

begin

  fTableClass := aTableClass;

  fServer := aServer;

  fTableClass.GetTableModuleProperties(fFeatures);

  fModuleName := fTableClass.ModuleName;

  if fFeatures.FileExtension='' then // default extension is the module name

    fFeatures.FileExtension := UTF8ToString(LowerCase(fModuleName));

end;



function TSQLVirtualTableModule.FileName(const aTableName: RawUTF8): TFileName;

begin

  result := UTF8ToString(aTableName)+'.'+FileExtension;;

  if fFilePath='' then

    result := ExeVersion.ProgramFilePath+result else

    result := IncludeTrailingPathDelimiter(fFilePath)+result;

end;





{ TSQLVirtualTable }



constructor TSQLVirtualTable.Create(aModule: TSQLVirtualTableModule;

  const aTableName: RawUTF8; FieldCount: integer; Fields: PPUTF8CharArray);

var aClass: TSQLRestStorageClass;

    aServer: TSQLRestServer;

begin

  if (aModule=nil) or (aTableName='') then

    raise EModelException.CreateUTF8('Invalid %.Create(%,"%")',[self,aModule,aTableName]);

  fModule := aModule;

  fTableName := aTableName;

  if fModule.fFeatures.StaticClass<>nil then begin

    // create new fStatic instance e.g. for TSQLVirtualTableLog

    aServer := fModule.Server;

    if aServer=nil then

      raise EModelException.CreateUTF8('%.Server=nil for %.Create',[Module,self]) else

    fStaticTableIndex := aServer.Model.GetTableIndex(aTableName);

    if fStaticTableIndex>=0 then begin

      fStaticTable := aServer.Model.Tables[fStaticTableIndex];

      aClass := fModule.fFeatures.StaticClass;

      if aClass.InheritsFrom(TSQLRestStorageInMemory) then

        fStatic := TSQLRestStorageInMemoryClass(aClass).Create(fStaticTable,

          fModule.Server,fModule.FileName(aTableName),

          self.InheritsFrom(TSQLVirtualTableBinary)) else

        fStatic := aClass.Create(fStaticTable,fModule.Server);

      if length(aServer.fStaticVirtualTable)<>length(aServer.Model.Tables) then

        SetLength(aServer.fStaticVirtualTable,length(aServer.Model.Tables));

      aServer.fStaticVirtualTable[fStaticTableIndex] := fStatic;

      if fStatic.InheritsFrom(TSQLRestStorage) then

        fStaticStorage := TSQLRestStorage(fStatic);

    end;

  end;

end;



destructor TSQLVirtualTable.Destroy;

var aTableIndex: cardinal;

begin

  if fStatic<>nil then begin

    if (Module<>nil) and (Module.Server<>nil) then

      with Module.Server do begin // temporary release (e.g. backup)

        aTableIndex := Model.GetTableIndex(TableName);

        if aTableIndex<cardinal(length(fStaticVirtualTable)) then begin

          fStaticVirtualTable[aTableIndex] := nil;

          if IsZero(fStaticVirtualTable,length(fStaticVirtualTable)*sizeof(pointer)) then

            fStaticVirtualTable := nil;

        end;

      end;

    fStatic.Free;

  end;

  inherited;

end;



function TSQLVirtualTable.Prepare(var Prepared: TSQLVirtualTablePrepared): boolean;

begin

  result := Self<>nil;

  if result then

    if (vtWhereIDPrepared in fModule.Features) and

       Prepared.IsWhereIDEquals(true) then

    with Prepared.Where[0] do begin // check ID=?

      Value.VType := ftNull; // mark TSQLVirtualTableCursorJSON expects it

      OmitCheck := true;

      Prepared.EstimatedCost := costPrimaryIndex;

      Prepared.EstimatedRows := 1;

    end else begin

      Prepared.EstimatedCost := costFullScan;

      Prepared.EstimatedRows := 1000000;

    end;

end;



function TSQLVirtualTable.Drop: boolean;

begin

  result := false;  // no DROP TABLE to be implemented here

end;



function TSQLVirtualTable.Delete(aRowID: Int64): boolean;

begin

  result := false;  // no DELETE to be implemented here

end;



function TSQLVirtualTable.Insert(aRowID: Int64;

  var Values: TSQLVarDynArray; out insertedRowID: Int64): boolean;

begin

  result := false;  // no INSERT to be implemented here

end;



function TSQLVirtualTable.Update(oldRowID, newRowID: Int64;

  var Values: TSQLVarDynArray): boolean;

begin

  result := false;  // no UPDATE to be implemented here

end;



function TSQLVirtualTable.Transaction(aState: TSQLVirtualTableTransaction;

  aSavePoint: integer): boolean;

begin

  result := (Module<>nil) and (vtWrite in Module.Features) and

    (aState in [vttBegin, vttSync, vttCommit, vttSavePoint, vttRelease]);

end;



function TSQLVirtualTable.Rename(const NewName: RawUTF8): boolean;

begin

  result := false;

end;



class function TSQLVirtualTable.ModuleName: RawUTF8;

const LEN: array[-1..2] of byte = (1,16,11,4);

begin

  if self=nil then

    result := '' else begin

    result := RawUTF8(ClassName);

    system.delete(result,1,LEN[IdemPCharArray(pointer(result),

      ['TSQLVIRTUALTABLE','TSQLVIRTUAL','TSQL'])]);

  end;

end;



class function TSQLVirtualTable.StructureFromClass(aClass: TSQLRecordClass;

  const aTableName: RawUTF8): RawUTF8;

begin

  result := FormatUTF8('CREATE TABLE % (%',[aTableName,

    GetVirtualTableSQLCreate(aClass.RecordProps)]);

end;



function TSQLVirtualTable.Structure: RawUTF8;

begin

  result := '';

  if Self<>nil then

    if (Static<>nil) then

      // e.g. for TSQLVirtualTableJSON or TSQLVirtualTableExternal

      Result := StructureFromClass(StaticTable,TableName) else

    if (Module<>nil) and (Module.RecordClass<>nil) then

      // e.g. for TSQLVirtualTableLog

      Result := StructureFromClass(Module.RecordClass,TableName);

end;





{ TSQLVirtualTableCursor }



constructor TSQLVirtualTableCursor.Create(aTable: TSQLVirtualTable);

begin

  fTable := aTable;

end;



procedure TSQLVirtualTableCursor.SetColumn(var aResult: TSQLVar; aValue: Int64);

begin

  aResult.VType := ftInt64;

  aResult.VInt64 := aValue;

end;



procedure TSQLVirtualTableCursor.SetColumn(var aResult: TSQLVar; const aValue: double);

begin

  aResult.VType := ftDouble;

  aResult.VDouble := aValue;

end;



procedure TSQLVirtualTableCursor.SetColumn(var aResult: TSQLVar; const aValue: RawUTF8);

begin

  aResult.VType := ftUTF8;

  fColumnTemp := aValue; // temporary copy available until next Column() call

  aResult.VText := pointer(fColumnTemp);

end;



procedure TSQLVirtualTableCursor.SetColumn(var aResult: TSQLVar;

  aValue: PUTF8Char; aValueLength: integer);

begin

  aResult.VType := ftUTF8;

  SetString(fColumnTemp,PAnsiChar(aValue),aValueLength); // temporary copy

  aResult.VText := pointer(fColumnTemp);

end;



procedure TSQLVirtualTableCursor.SetColumnBlob(var aResult: TSQLVar;

  aValue: pointer; aValueLength: integer);

begin

  aResult.VType := ftBlob;

  SetString(fColumnTemp,PAnsiChar(aValue),aValueLength); // temporary copy

  aResult.VBlob := pointer(fColumnTemp);

  aResult.VBlobLen := aValueLength;

end;





{ TSQLLog }



procedure TSQLLog.CreateLogWriter;

begin

  fWriterClass := TJSONSerializer;

  inherited CreateLogWriter;

end;





{ TSQLVirtualTableCursorIndex }



function TSQLVirtualTableCursorIndex.HasData: boolean;

begin

  result := (self<>nil) and (fCurrent<=fMax);

end;



function TSQLVirtualTableCursorIndex.Next: boolean;

begin

  if self=nil then

    result := false else begin

    if fCurrent<=fMax then

      inc(fCurrent);

    result := true;

  end;

end;



function TSQLVirtualTableCursorIndex.Search(

  const Prepared: TSQLVirtualTablePrepared): boolean;

begin

  fCurrent := 0; // mark EOF by default

  fMax := -1;

  result := self<>nil;

end;





{ TSQLVirtualTablePrepared }



function TSQLVirtualTablePrepared.IsWhereIDEquals(CalledFromPrepare: Boolean): boolean;

begin

  result := (WhereCount=1) and (Where[0].Column=VIRTUAL_TABLE_ROWID_COLUMN) and

     (CalledFromPrepare or (Where[0].Value.VType=ftInt64)) and

     (Where[0].Operation=soEqualTo);

end;



function TSQLVirtualTablePrepared.IsWhereOneFieldEquals: boolean;

begin

  result := (WhereCount=1) and (Where[0].Column>=0) and

     (Where[0].Operation=soEqualTo);

end;





{ TSQLVirtualTableJSON }



constructor TSQLVirtualTableJSON.Create(aModule: TSQLVirtualTableModule;

  const aTableName: RawUTF8; FieldCount: integer; Fields: PPUTF8CharArray);

begin

  inherited Create(aModule,aTableName,FieldCount,Fields);

  fStaticInMemory := fStatic as TSQLRestStorageInMemory;

end;



function TSQLVirtualTableJSON.Delete(aRowID: Int64): boolean;

begin

  result := (Static<>nil) and Static.Delete(StaticTable,aRowID);

  if result and (StaticStorage<>nil) and (StaticStorage.Owner<>nil) then

    StaticStorage.Owner.fCache.NotifyDeletion(StaticTable,aRowID);

end;



function TSQLVirtualTableJSON.Drop: boolean;

begin

  if (self<>nil) and (Static<>nil) then begin

    fStaticInMemory.RollBack(0); // close any pending transaction

    fStaticInMemory.fValue.Clear;

    fStaticInMemory.Modified := true; // force update file after clear

    fStaticInMemory.UpdateFile;

    result := true;

  end else

    result := false;

end;



class procedure TSQLVirtualTableJSON.GetTableModuleProperties(

  var aProperties: TVirtualTableModuleProperties);

begin

  aProperties.Features := [vtWrite,vtWhereIDPrepared];

  aProperties.CursorClass := TSQLVirtualTableCursorJSON;

  aProperties.StaticClass := TSQLRestStorageInMemoryExternal; // will flush Cache

  if InheritsFrom(TSQLVirtualTableBinary) then

    aProperties.FileExtension := 'data';

  // default will follow the class name, e.g. '.json' for TSQLVirtualTableJSON

end;



function TSQLVirtualTableJSON.Insert(aRowID: Int64;

  var Values: TSQLVarDynArray; out insertedRowID: Int64): boolean;

var aRecord: TSQLRecord;

begin

  result := false;

  if (self=nil) or (Static=nil) then

    exit;

  aRecord := StaticTable.Create;

  try

    if aRecord.SetFieldSQLVars(Values) then begin

      if aRowID>0 then

        aRecord.fID := aRowID;

      insertedRowID := fStaticInMemory.AddOne(aRecord,aRowID>0,

        aRecord.GetJSONValues(true,False,soInsert));

      if insertedRowID>0 then begin

        if fStaticInMemory.Owner<>nil then

          fStaticInMemory.Owner.fCache.Notify(aRecord,soInsert);

        result := true;

      end;

    end;

  finally

    if not result then

      aRecord.Free; // on success, aRecord will stay in Values[]

  end;

end;



function TSQLVirtualTableJSON.Prepare(var Prepared: TSQLVirtualTablePrepared): boolean;

begin

  result := inherited Prepare(Prepared); // optimize ID=? WHERE clause

  if result and (Static<>nil) then begin

    if Prepared.IsWhereOneFieldEquals then

    with Prepared.Where[0] do

    if fStaticInMemory.UniqueFieldHash(Column)<>nil then begin

      Value.VType := ftNull; // mark TSQLVirtualTableCursorJSON expects it

      OmitCheck := true;

      Prepared.EstimatedCost := costSecondaryIndex;

      Prepared.EstimatedRows := 10;

    end else

      if Prepared.EstimatedCost in [costFullScan,costScanWhere] then

        Prepared.EstimatedRows := fStaticInMemory.Count;

    if fStaticInMemory.fIDSorted and (Prepared.OrderByCount=1) then

      // ascending IDs ?

      with Prepared.OrderBy[0] do

        if (Column=VIRTUAL_TABLE_ROWID_COLUMN) and not Desc then

          Prepared.OmitOrderBy := true;

  end;

end;



function TSQLVirtualTableJSON.Update(oldRowID, newRowID: Int64;

  var Values: TSQLVarDynArray): boolean;

var i: integer;

begin

  result := false;

  if (self=nil) or (Static=nil) or

     (oldRowID<>newRowID) or (newRowID<=0) then // don't allow ID change

    exit;

    if fStaticInMemory.UpdateOne(newRowID,Values) then begin

      if (fStaticInMemory.Owner<>nil) then begin

        i := fStaticInMemory.IDToIndex(newRowID);

        if i>=0 then

          fStaticInMemory.Owner.fCache.Notify(

            TSQLRecord(fStaticInMemory.fValue.List[i]),soUpdate);

      end;

      result := true;

    end;

end;





{ TSQLVirtualTableCursorJSON }



function TSQLVirtualTableCursorJSON.Column(aColumn: integer;

  var aResult: TSQLVar): boolean;

var Value: TObjectList;

begin

  if (self=nil) or (fCurrent>fMax) or

     (TSQLVirtualTableJSON(Table).Static=nil) then begin

    result := false;

    exit;

  end;

  Value := TSQLVirtualTableJSON(Table).fStaticInMemory.fValue;

  if Cardinal(fCurrent)>=Cardinal(Value.Count) then

    result := False else begin

    if aColumn=VIRTUAL_TABLE_ROWID_COLUMN then begin

      aResult.VType := ftInt64;

      aResult.VInt64 := TSQLRecord(Value.List[fCurrent]).fID;

    end else

    with TSQLVirtualTableJSON(Table).fStaticInMemory.fStoredClassRecordProps.Fields do

      if cardinal(aColumn)>=cardinal(Count) then

        aResult.VType := ftNull else

        List[aColumn].GetFieldSQLVar(Value.List[fCurrent],aResult,fColumnTemp);

    result := true;

  end;

end;



function TSQLVirtualTableCursorJSON.Search(const Prepared: TSQLVirtualTablePrepared): boolean;

var Hash: TListFieldHash;

begin

  result := inherited Search(Prepared); // mark EOF by default

  if (not result) or (not Table.InheritsFrom(TSQLVirtualTableJSON)) or

     (TSQLVirtualTableJSON(Table).fStaticInMemory=nil) then

    result := false else

    with TSQLVirtualTableJSON(Table).fStaticInMemory do begin

    if Count>0 then

      // if something to search in

      if Prepared.IsWhereIDEquals(false) then begin // ID=?

        fMax := IDToIndex(Prepared.Where[0].Value.VInt64); // binary search

        if fMax>=0 then

          fCurrent := fMax; // ID found

      end else

      if Prepared.IsWhereOneFieldEquals then

      with Prepared.Where[0] do begin

        Hash := UniqueFieldHash(Column);

        if Hash<>nil then begin // optimized hash-based search

          fStoredClassRecordProps.Fields.List[Column].SetFieldSQLVar(fSearchRec,Value);

          fMax := Hash.Find(fSearchRec);

          if fMax>=0 then

            fCurrent := fMax; // value found with O(1) search

        end else

         fMax := Count-1; // loop all records in ID order

      end else

        fMax := Count-1; // loop all records in ID order

    result := true; // no DB error

  end;

end;





{ TSQLVirtualTableLog }



type

  /// Record associated to Virtual Table implemented in Delphi, for Read/Only

  // access to a .log file, as created by TSynLog

  // - not used as real instances, but only used by the TSQLVirtualTableLog module

  // to provide the field layout needed to create the column layout for the

  // CREATE TABLE statement

  TSQLRecordLogFile = class(TSQLRecordVirtualTableAutoID)

  protected

    fContent: RawUTF8;

    fDateTime: TDateTime;

    fLevel: TSynLogInfo;

  published

    /// the log event time stamp

    property DateTime: TDateTime read fDateTime;

    /// the log event level

    property Level: TSynLogInfo read fLevel;

    /// the textual message associated to the log event

    property Content: RawUTF8 read fContent;

  end;





constructor TSQLVirtualTableLog.Create(aModule: TSQLVirtualTableModule;

  const aTableName: RawUTF8; FieldCount: integer; Fields: PPUTF8CharArray);

var aFileName: TFileName;

begin

  inherited Create(aModule,aTableName,Fieldcount,Fields);

  if (FieldCount=1) then

    aFileName := UTF8ToString(Fields[0]) else

    aFileName := aModule.FileName(aTableName);

  fLogFile := TSynLogFile.Create(aFileName);

end;



destructor TSQLVirtualTableLog.Destroy;

begin

  fLogFile.Free;

  inherited;

end;



class procedure TSQLVirtualTableLog.GetTableModuleProperties(

  var aProperties: TVirtualTableModuleProperties);

begin

  aProperties.Features := [vtWhereIDPrepared];

  aProperties.CursorClass := TSQLVirtualTableCursorLog;

  aProperties.RecordClass := TSQLRecordLogFile;

end;





{ TSQLVirtualTableCursorLog }



function TSQLVirtualTableCursorLog.Column(aColumn: integer;

  var aResult: TSQLVar): boolean;

var LogFile: TSynLogFile;

begin

  result := false;

  if (self=nil) or (fCurrent>fMax) then

    exit;

  LogFile := TSQLVirtualTableLog(Table).fLogFile;

  if LogFile=nil then

    exit;

  case aColumn of

   -1: SetColumn(aResult,fCurrent+1); // ID = row index + 1

    0: SetColumn(aResult,LogFile.EventDateTime(fCurrent));

    1: SetColumn(aResult,ord(LogFile.EventLevel[fCurrent]));

    2: SetColumn(aResult,LogFile.LinePointers[fCurrent],LogFile.LineSize(fCurrent));

    else exit;

  end;

  result := true;

end;



function TSQLVirtualTableCursorLog.Search(

  const Prepared: TSQLVirtualTablePrepared): boolean;

begin

  result := inherited Search(Prepared); // mark EOF by default

  if result then begin

    fMax := TSQLVirtualTableLog(Table).fLogFile.Count-1; // search all range

    if Prepared.IsWhereIDEquals(false) then begin

      fCurrent := Prepared.Where[0].Value.VInt64-1; // ID=? -> index := ID-1

      if cardinal(fCurrent)<=cardinal(fMax) then

        fMax := fCurrent else // found one

        fMax := fCurrent-1;   // out of range ID

    end;

  end;

end;





{ TAuthSession }



procedure TAuthSession.ComputeProtectedValues;

begin // here User.GroupRights and fPrivateKey should have been set

  fLastAccess64 := GetTickCount64;

  fTimeOutMS := User.GroupRights.SessionTimeout*(1000*60); // min to ms

  fAccessRights := User.GroupRights.SQLAccessRights;

  fPrivateSalt := fID+'+'+fPrivateKey;

  fPrivateSaltHash :=

    crc32(crc32(0,pointer(fPrivateSalt),length(fPrivateSalt)),

      pointer(User.PasswordHashHexa),length(User.PasswordHashHexa));

  fRemoteIP := FindIniNameValue(pointer(fSentHeaders),'REMOTEIP: ');

end;



constructor TAuthSession.Create(aCtxt: TSQLRestServerURIContext; aUser: TSQLAuthUser);

var GID: TSQLAuthGroup;

begin

  fUser := aUser;

  if (aCtxt<>nil) and (User<>nil) and (User.fID<>0) then begin

    GID := User.GroupRights; // save pseudo TSQLAuthGroup = ID

    User.GroupRights := aCtxt.Server.fSQLAuthGroupClass.Create(aCtxt.Server,GID);

    if User.GroupRights.fID<>0 then begin

      // compute the next Session ID

      with aCtxt.Server do begin

        if fSessionCounter>=cardinal(maxInt) then

          fSessionCounter := 10 else

          if fSessionCounter=75 then // avoid IDCardinal=0 (77) or 1 (76)

            fSessionCounter := 78 else

            inc(fSessionCounter);

          fIDCardinal := fSessionCounter xor 77;

          UInt32ToUtf8(fIDCardinal,fID);

      end;

      // set session parameters

      fPrivateKey := SHA256(NowToString+fID);

      aCtxt.Server.RetrieveBlob(aCtxt.Server.fSQLAuthUserClass,User.fID,'Data',User.fData);

      if (aCtxt.Call<>nil) and (aCtxt.Call.InHead<>'') then

        fSentHeaders := aCtxt.Call.InHead;

      ComputeProtectedValues;

      {$ifdef WITHLOG}

      aCtxt.Log.Log(sllUserAuth,

        'New "%" session %/% created at %/% running %',

        [User.GroupRights.Ident,User.LogonName,fIDCardinal,fRemoteIP,

         aCtxt.Call^.LowLevelConnectionID,aCtxt.UserAgent],self);

      {$endif}

      exit; // create successfull

    end;

    // on error: set GroupRights back to a pseudo TSQLAuthGroup = ID

    User.GroupRights.Free;

    User.GroupRights := GID;

  end;

  raise ESecurityException.CreateUTF8('Invalid %.Create(%,%)',[self,aCtxt,aUser]);

end;



destructor TAuthSession.Destroy;

begin

  if User<>nil then begin

    User.GroupRights.Free;

    fUser.Free;

  end;

  ObjArrayClear(fMethods);

  ObjArrayClear(fInterfaces);

  inherited;

end;



function TAuthSession.GetUserName: RawUTF8;

begin

  if User=nil then

    result := '' else

    result := User.LogonName;

end;



function TAuthSession.GetUserID: TID;

begin

  if User=nil then

    result := 0 else

    result := User.fID;

end;



function TAuthSession.GetGroupID: TID;

begin

  if User=nil then

    result := 0 else

    result := User.GroupRights.ID;

end;



const TAUTHSESSION_MAGIC = 1;



procedure TAuthSession.SaveTo(W: TFileBufferWriter);

begin

  W.Write1(TAUTHSESSION_MAGIC);

  W.WriteVarUInt32(IDCardinal);

  W.WriteVarUInt32(fUser.fID);

  fUser.GetBinaryValues(W); // User.fGroup is a pointer, but would be overriden

  W.WriteVarUInt32(fUser.GroupRights.fID);

  fUser.GroupRights.GetBinaryValues(W);

  W.Write(fPrivateKey);

  W.Write(fSentHeaders);

end; // TODO: persist ORM/SOA stats? -> rather integrate them before saving



constructor TAuthSession.CreateFrom(var P: PAnsiChar; Server: TSQLRestServer);

var PB: PByte absolute P;

begin

  if PB^=TAUTHSESSION_MAGIC then

    inc(PB) else

    raise ESynException.CreateUTF8('%.CreateFrom() with invalid format',[self]);

  fIDCardinal := FromVarUInt32(PB);

  UInt32ToUtf8(fIDCardinal,fID);

  fUser := Server.SQLAuthUserClass.Create;

  fUser.fID := FromVarUInt32(PB);

  fUser.SetBinaryValues(P); // fUser.fGroup would be overriden by true instance

  fUser.fGroup := Server.SQLAuthGroupClass.Create;

  fUser.fGroup.fID := FromVarUInt32(PB);

  fUser.fGroup.SetBinaryValues(P);

  fPrivateKey := FromVarString(PB);

  fSentHeaders := FromVarString(PB);

  ComputeProtectedValues;

end;





{ TSQLAccessRights }



procedure TSQLAccessRights.Edit(aTableIndex: integer; C, R, U, D: Boolean);

begin

  if C then

    Include(POST,aTableIndex) else

    Exclude(POST,aTableindex);

  if R then

    Include(GET,aTableIndex) else

    Exclude(GET,aTableindex);

  if U then

    Include(PUT,aTableIndex) else

    Exclude(PUT,aTableindex);

  if D then

    Include(DELETE,aTableIndex) else

    Exclude(DELETE,aTableindex);

end;



procedure TSQLAccessRights.Edit(aTableIndex: integer; aRights: TSQLOccasions);

begin

  if soInsert in aRights then

    Include(POST,aTableIndex) else

    Exclude(POST,aTableindex);

  if soSelect in aRights then

    Include(GET,aTableIndex) else

    Exclude(GET,aTableindex);

  if soUpdate in aRights then

    Include(PUT,aTableIndex) else

    Exclude(PUT,aTableindex);

  if soDelete in aRights then

    Include(DELETE,aTableIndex) else

    Exclude(DELETE,aTableindex);

end;



procedure TSQLAccessRights.Edit(aModel: TSQLModel; aTable: TSQLRecordClass;

  C, R, U, D: Boolean);

begin

  Edit(aModel.GetTableIndexExisting(aTable),C,R,U,D);

end;



procedure TSQLAccessRights.Edit(aModel: TSQLModel; aTable: TSQLRecordClass;

  aRights: TSQLOccasions);

begin

  Edit(aModel.GetTableIndexExisting(aTable),aRights);

end;



procedure TSQLAccessRights.FromString(P: PUTF8Char);

begin

  FillcharFast(self,sizeof(self),0);

  if P=nil then

    exit;

  AllowRemoteExecute := TSQLAllowRemoteExecute(byte(GetNextItemCardinal(P)));

  SetBitCSV(GET,MAX_SQLTABLES,P);

  SetBitCSV(POST,MAX_SQLTABLES,P);

  SetBitCSV(PUT,MAX_SQLTABLES,P);

  SetBitCSV(DELETE,MAX_SQLTABLES,P);

end;



function TSQLAccessRights.ToString: RawUTF8;

begin

  result := FormatUTF8('%,%,%,%,%',

    [Byte(AllowRemoteExecute),

     GetBitCSV(GET,MAX_SQLTABLES), GetBitCSV(POST,MAX_SQLTABLES),

     GetBitCSV(PUT,MAX_SQLTABLES), GetBitCSV(DELETE,MAX_SQLTABLES)]);

end;



function TSQLAccessRights.CanExecuteORMWrite(Method: TSQLURIMethod;

  Table: TSQLRecordClass; TableIndex: integer; const TableID: TID;

  Context: TSQLRestServerURIContext): boolean;

begin

  result := true;

  case Method of

  mPOST:   // POST=ADD=INSERT

    if Table<>nil then  // ExecuteORMWrite will check reSQL access right

      result := (TableIndex in POST);

  mPUT:    // PUT=UPDATE

    result := (Table<>nil) and

     ((TableIndex in PUT) or

      ((TableID>0) and (Context.Session>CONST_AUTHENTICATION_NOT_USED) and

       (Table=Context.Server.fSQLAuthUserClass) and (TableID=Context.SessionUser) and

       (reUserCanChangeOwnPassword in AllowRemoteExecute)));

  mDelete:

    result := (Table<>nil) and (TableIndex in DELETE) and

      ((TableID>0) or (reUrlEncodedDelete in AllowRemoteExecute));

  end;

end;





{ TSQLAuthGroup }



function TSQLAuthGroup.GetSQLAccessRights: TSQLAccessRights;

begin

  if self=nil then

    FillcharFast(result,sizeof(result),0) else

    result.FromString(pointer(AccessRights));

end;



class procedure TSQLAuthGroup.InitializeTable(Server: TSQLRestServer;

  const FieldName: RawUTF8; Options: TSQLInitializeTableOptions);

var G: TSQLAuthGroup;

    A: TSQLAccessRights;

    U: TSQLAuthUser;

    AuthUserIndex, AuthGroupIndex: integer;

    AdminID, SupervisorID, UserID: PtrInt;

begin

  inherited; // will create any needed index

  if (Server<>nil) and (FieldName='') then

    if Server.HandleAuthentication then begin

      // create default Groups and Users (we are already in a Transaction)

      AuthGroupIndex := Server.Model.GetTableIndexExisting(Server.fSQLAuthUserClass);

      AuthUserIndex := Server.Model.GetTableIndexExisting(Server.fSQLAuthGroupClass);

      if not (itoNoAutoCreateGroups in Options) then begin

        G := Server.fSQLAuthGroupClass.Create;

        try

          //            POSTSQL SELECTSQL Service AuthR AuthW TablesR TablesW

          // Admin        Yes     Yes       Yes    Yes   Yes    Yes    Yes

          // Supervisor   No      Yes       Yes    Yes   No     Yes    Yes

          // User         No      No        Yes    No    No     Yes    Yes

          // Guest        No      No        No     No    No     Yes    No

          A := FULL_ACCESS_RIGHTS;

          G.Ident := 'Admin';

          G.SQLAccessRights := A;

          G.SessionTimeout := 10;

          AdminID := Server.Add(G,true);

          G.Ident := 'Supervisor';

          A.AllowRemoteExecute := SUPERVISOR_ACCESS_RIGHTS.AllowRemoteExecute;

          A.Edit(AuthUserIndex,[soSelect]); // AuthUser  R/O

          A.Edit(AuthGroupIndex,[soSelect]); // AuthGroup R/O

          G.SQLAccessRights := A;

          G.SessionTimeout := 60;

          SupervisorID := Server.Add(G,true);

          G.Ident := 'User';

          Exclude(A.AllowRemoteExecute,reSQLSelectWithoutTable);

          Exclude(A.GET,AuthUserIndex); // no Auth R

          Exclude(A.GET,AuthGroupIndex);

          G.SQLAccessRights := A;

          G.SessionTimeout := 60;

          UserID := Server.Add(G,true);

          G.Ident := 'Guest';

          A.AllowRemoteExecute := [];

          FillcharFast(A.POST,sizeof(TSQLFieldTables),0); // R/O access

          FillcharFast(A.PUT,sizeof(TSQLFieldTables),0);

          FillcharFast(A.DELETE,sizeof(TSQLFieldTables),0);

          G.SQLAccessRights := A;

          G.SessionTimeout := 60;

          Server.Add(G,true);

        finally

          G.Free;

        end;

        if (not (itoNoAutoCreateUsers in Options)) and

           (Server.TableRowCount(Server.fSQLAuthUserClass)=0) then begin

          U := Server.fSQLAuthUserClass.Create;

          try

            U.LogonName := 'Admin';

            U.PasswordHashHexa := AuthAdminDefaultPassword;

            U.DisplayName := U.LogonName;

            U.GroupRights := TSQLAuthGroup(AdminID);

            Server.Add(U,true);

            U.LogonName := 'Supervisor';

            U.PasswordHashHexa := AuthSupervisorDefaultPassword;

            U.DisplayName := U.LogonName;

            U.GroupRights := TSQLAuthGroup(SupervisorID);

            Server.Add(U,true);

            U.LogonName := 'User';

            U.PasswordHashHexa := AuthUserDefaultPassword;

            U.DisplayName := U.LogonName;

            U.GroupRights := TSQLAuthGroup(UserID);

            Server.Add(U,true);

          finally

            U.Free;

          end;

        end;

      end;

    end;

end;



procedure TSQLAuthGroup.SetSQLAccessRights(const Value: TSQLAccessRights);

begin

  if self<>nil then

    AccessRights := Value.ToString;

end;





{ TSQLAuthUser }



class function TSQLAuthUser.ComputeHashedPassword(

  const aPasswordPlain, aHashSalt: RawUTF8; aHashRound: integer): RawUTF8;

const TSQLAUTHUSER_SALT = 'salt';

var dig: TSHA256Digest;

begin

  if aHashSalt='' then

    result := SHA256(TSQLAUTHUSER_SALT+aPasswordPlain) else begin

    PBKDF2_HMAC_SHA256(aPasswordPlain,aHashSalt,aHashRound,dig);

    result := SHA256DigestToString(dig);

    FillcharFast(dig,sizeof(dig),0);

  end;

end;



procedure TSQLAuthUser.SetPasswordPlain(const Value: RawUTF8);

begin

  if self<>nil then

    PasswordHashHexa := ComputeHashedPassword(Value);

end;



procedure TSQLAuthUser.SetPassword(const aPasswordPlain, aHashSalt: RawUTF8;

  aHashRound: integer);

begin

  if self<>nil then

    PasswordHashHexa := ComputeHashedPassword(aPasswordPlain,aHashSalt,aHashRound);

end;



function TSQLAuthUser.CanUserLog(Ctxt: TSQLRestServerURIContext): boolean;

begin

  result := true; // any existing TSQLAuthUser is allowed by default

end;





{ TSQLRestServerAuthentication }



constructor TSQLRestServerAuthentication.Create(aServer: TSQLRestServer);

begin

  fServer := aServer;

  fOptions := [saoUserByLogonOrID];

end;



function TSQLRestServerAuthentication.AuthSessionRelease(

  Ctxt: TSQLRestServerURIContext): boolean;

var aUserName: RawUTF8;

    aSessionID: cardinal;

    i: integer;

begin

  result := false;

  if fServer.fSessions=nil then

    exit;

  aUserName := Ctxt.InputUTF8OrVoid['UserName'];

  if aUserName='' then

    exit;

  aSessionID := Ctxt.InputIntOrVoid['Session'];

  if aSessionID=0 then

    aSessionID := Ctxt.InputHexaOrVoid['SessionHex'];

  if aSessionID=0 then

    exit;

  result := true; // recognized GET ModelRoot/auth?UserName=...&Session=...

  // allow only to delete its own session - ticket [7723fa7ebd]

  if aSessionID=Ctxt.Session then

    for i := 0 to fServer.fSessions.Count-1 do

      with TAuthSession(fServer.fSessions.List[i]) do

      if (fIDCardinal=aSessionID) and (fUser.LogonName=aUserName) then begin

        fServer.SessionDelete(i,Ctxt);

        Ctxt.Success;

        break;

      end;

end;



function TSQLRestServerAuthentication.GetUser(Ctxt: TSQLRestServerURIContext;

  const aUserName: RawUTF8): TSQLAuthUser;

var UserID: TID;

    err: integer;

begin

  UserID := GetInt64(pointer(aUserName),err);

  if (err<>0) or (UserID<=0) or not (saoUserByLogonOrID in fOptions) then

    UserID := 0;

  if Assigned(fServer.OnAuthenticationUserRetrieve) then

    result := fServer.OnAuthenticationUserRetrieve(self,Ctxt,UserID,aUserName) else begin

    if UserID<>0 then begin // try if TSQLAuthUser.ID was transmitted

      result := fServer.fSQLAuthUserClass.Create(fServer,UserID); // may use ORM cache :)

      if result.fID=0 then

        FreeAndNil(result);

    end else

      result := nil;

    if result=nil then

      result := fServer.fSQLAuthUserClass.Create(fServer,'LogonName=?',[aUserName]);

    if (result.fID=0) and

       (saoHandleUnknownLogonAsStar in fOptions) then

      if fServer.Retrieve('LogonName=?',[],['*'],result) then begin

        result.LogonName := aUserName;

        result.DisplayName := aUserName;

      end;

  end;

  if (result=nil) or (result.fID=0) then begin

    fServer.InternalLog('%.LogonName=% not found',[fServer.fSQLAuthUserClass,aUserName],sllUserAuth);

    FreeAndNil(result);

  end else

  if not result.CanUserLog(Ctxt) then begin

    fServer.InternalLog('%.CanUserLog(%) returned FALSE -> rejected',[result,aUserName],sllUserAuth);

    FreeAndNil(result);

  end;

end;



procedure TSQLRestServerAuthentication.SessionCreate(Ctxt: TSQLRestServerURIContext;

  var User: TSQLAuthUser);

var Session: TAuthSession;

begin

  if User<>nil then

  try // now client is authenticated -> create a session

    fServer.SessionCreate(User,Ctxt,Session); // call Ctxt.AuthenticationFailed on error

    if Session<>nil then

      with Session.User do

      Ctxt.Returns(['result',Session.fPrivateSalt,'logonid',IDValue,

        'logonname',LogonName,'logondisplay',DisplayName,'logongroup',GroupRights.IDValue,

        'server',ExeVersion.ProgramName,'version',ExeVersion.Version.Detailed]);

  finally

    User.Free;

  end;

end;



class function TSQLRestServerAuthentication.ClientGetSessionKey(

  Sender: TSQLRestClientURI; User: TSQLAuthUser; const aNameValueParameters: array of const): RawUTF8;

var resp: RawUTF8;

    values: TPUtf8CharDynArray;

begin

  if (Sender.CallBackGet('Auth',aNameValueParameters,resp)<>HTML_SUCCESS) or

     (JSONDecode(pointer(resp),['result','data','server','version',

       'logonid','logonname','logondisplay','logongroup'],values)=nil) then begin

    Sender.fSessionData := '';

    result := '';

  end else begin

    SetString(result,values[0],StrLen(values[0]));

    Base64ToBin(PAnsiChar(values[1]),StrLen(values[1]),Sender.fSessionData);

    Sender.fSessionServer := values[2];

    Sender.fSessionVersion := values[3];

    SetID(values[4],User.fID);

    User.LogonName := values[5]; // set/fix using values from server

    User.DisplayName := values[6];

    User.GroupRights := pointer(GetInteger(values[7]));

  end;

end;



class function TSQLRestServerAuthentication.ClientSetUser(Sender: TSQLRestClientURI;

  const aUserName, aPassword: RawUTF8; aPasswordKind: TSQLRestServerAuthenticationClientSetUserPassword;

  const aHashSalt: RawUTF8; aHashRound: integer): boolean;

var U: TSQLAuthUser;

    key: RawUTF8;

begin

  result := false;

  if Sender=nil then

    exit;

  try

    Sender.SessionClose;

    U := TSQLAuthUser.Create;

    try

      U.LogonName := trim(aUserName);

      U.DisplayName := U.LogonName;

      if aPasswordKind<>passClear then

        U.PasswordHashHexa := aPassword else

        if aHashSalt='' then

          U.PasswordPlain := aPassword else // compute SHA256('salt'+aPassword)

          U.SetPassword(aPassword,aHashSalt,aHashRound);

      key := ClientComputeSessionKey(Sender,U);

      result := Sender.SessionCreate(self,U,key);

    finally

      U.Free;

    end;

  finally

    if Assigned(Sender.OnSetUser) then

      Sender.OnSetUser(Sender); // always notify of user change, even if failed

  end;

end;





{ TSQLRestServerAuthenticationURI }



function TSQLRestServerAuthenticationURI.RetrieveSession(

  Ctxt: TSQLRestServerURIContext): TAuthSession;

begin

  result := nil;

  if (Ctxt=nil) or (Ctxt.URISessionSignaturePos=0) then

    exit;

  // expected format is 'session_signature='Hexa8(SessionID)'...

  if (Ctxt.URISessionSignaturePos>0) and

     (Ctxt.URISessionSignaturePos+(18+8)<=length(Ctxt.Call^.Url)) and

     HexDisplayToCardinal(PAnsiChar(pointer(Ctxt.Call^.url))+Ctxt.URISessionSignaturePos+18,Ctxt.Session) then

    result := fServer.SessionAccess(Ctxt);

end;



class procedure TSQLRestServerAuthenticationURI.ClientSessionSign(

  Sender: TSQLRestClientURI; var Call: TSQLRestURIParams);

begin

  if (Sender<>nil) and (Sender.fSessionID<>0) and (Sender.fSessionUser<>nil) then

    if PosEx(RawUTF8('?'),Call.url,1)=0 then

      Call.url := Call.url+'?session_signature='+Sender.fSessionIDHexa8 else

      Call.url := Call.url+'&session_signature='+Sender.fSessionIDHexa8;

end;





{ TSQLRestServerAuthenticationSignedURI }



// expected format is session_signature=

// Hexa8(SessionID)+

// Hexa8(TimeStamp)+

// Hexa8(crc32('SessionID+HexaSessionPrivateKey'+Sha256('salt'+PassWord)+

//             Hexa8(TimeStamp)+url))



constructor TSQLRestServerAuthenticationSignedURI.Create(aServer: TSQLRestServer);

begin

  inherited Create(aServer);

  fTimeStampCoherencySeconds := 5;

end;



procedure TSQLRestServerAuthenticationSignedURI.SetNoTimeStampCoherencyCheck(value: boolean);

begin

  if self<>nil then

    fNoTimeStampCoherencyCheck := value;

end;



function TSQLRestServerAuthenticationSignedURI.RetrieveSession(

  Ctxt: TSQLRestServerURIContext): TAuthSession;

var aTimeStamp, aSignature, aExpectedSignature: cardinal;

    PTimeStamp: PAnsiChar;

    aURLlength: Integer;

begin

  result := inherited RetrieveSession(Ctxt);

  if result=nil then

    exit; // no valid session ID in session_signature

  if Ctxt.URISessionSignaturePos+(18+8+8+8)>length(Ctxt.Call^.url) then begin

    result := nil;

    exit;

  end;

  aURLlength := Ctxt.URISessionSignaturePos-1;

  PTimeStamp := @Ctxt.Call^.url[aURLLength+(20+8)]; // points to Hexa8(TimeStamp)

  if HexDisplayToCardinal(PTimeStamp,aTimeStamp) and

     (fNoTimeStampCoherencyCheck or (result.fLastTimeStamp=0) or

      (aTimeStamp>=result.fLastTimeStamp-fTimeStampCoherencySeconds)) then begin

    aExpectedSignature := crc32(crc32(result.fPrivateSaltHash,PTimeStamp,8),

      pointer(Ctxt.Call^.url),aURLlength);

    if HexDisplayToCardinal(PTimeStamp+8,aSignature) and

       (aSignature=aExpectedSignature) then begin

      if aTimeStamp>result.fLastTimeStamp then

        result.fLastTimeStamp := aTimeStamp;

      exit;

    end else begin

      {$ifdef WITHLOG}

      Ctxt.Log.Log(sllUserAuth,'Invalid Signature: expected %, got %',

        [Int64(aExpectedSignature),Int64(aSignature)],self);

      {$endif}

    end;

  end else begin

    {$ifdef WITHLOG}

    Ctxt.Log.Log(sllUserAuth,'Invalid TimeStamp: expected >=%, got %',

      [result.fLastTimeStamp-fTimeStampCoherencySeconds,aTimeStamp],self);

    {$endif}

  end;

  result := nil; // indicates invalid signature

end;



class procedure TSQLRestServerAuthenticationSignedURI.ClientSessionSign(

  Sender: TSQLRestClientURI; var Call: TSQLRestURIParams);

var nonce, blankURI: RawUTF8;

begin

  if (Sender=nil) or (Sender.fSessionID=0) or (Sender.fSessionUser=nil) then

    exit;

  blankURI := Call.Url;

  if PosEx(RawUTF8('?'),Call.Url,1)=0 then

    Call.url := Call.Url+'?session_signature=' else

    Call.url := Call.Url+'&session_signature=';

  with Sender do begin

    fSessionLastTick64 := GetTickCount64;

    nonce := CardinalToHex(fSessionLastTick64 shr 8); // 256 ms resolution

    Call.url := Call.url+fSessionIDHexa8+nonce+CardinalToHex(

      crc32(crc32(fSessionPrivateKey,Pointer(nonce),length(nonce)),

      Pointer(blankURI),length(blankURI)));

  end;

end;





{ TSQLRestServerAuthenticationDefault }



function TSQLRestServerAuthenticationDefault.Auth(

  Ctxt: TSQLRestServerURIContext): boolean;

var aUserName, aPassWord, aClientNonce: RawUTF8;

    User: TSQLAuthUser;

begin

  result := true;

  if AuthSessionRelease(Ctxt) then

    exit;

  aUserName := Ctxt.InputUTF8OrVoid['UserName'];

  aPassWord := Ctxt.InputUTF8OrVoid['Password'];

  aClientNonce := Ctxt.InputUTF8OrVoid['ClientNonce'];

  if (aUserName<>'') and (length(aClientNonce)>32) then begin

    // GET ModelRoot/auth?UserName=...&PassWord=...&ClientNonce=... -> handshaking

    User := GetUser(Ctxt,aUserName);

    if User<>nil then

    try

      // check if match TSQLRestClientURI.SetUser() algorithm

      if CheckPassword(Ctxt,User,aClientNonce,aPassWord) then

        SessionCreate(Ctxt,User) else // will call Ctxt.AuthenticationFailed on error

        Ctxt.AuthenticationFailed(afInvalidPassword);

    finally

      User.Free;

    end else

      Ctxt.AuthenticationFailed(afUnknownUser);

  end else

    if aUserName<>'' then

      // only UserName=... -> return hexadecimal nonce content valid for 5 minutes

      Ctxt.Results([ServerNonce(false)]) else

      // parameters does not match any expected layout -> try next authentication

      result := false;

end;



function TSQLRestServerAuthenticationDefault.CheckPassword(Ctxt: TSQLRestServerURIContext;

  User: TSQLAuthUser; const aClientNonce, aPassWord: RawUTF8): boolean;

var aSalt: RawUTF8;

begin

  aSalt := aClientNonce+User.LogonName+User.PasswordHashHexa;

  result := (aPassWord=SHA256(fServer.Model.Root+ServerNonce(false)+aSalt)) or

            // if current nonce failed, tries with previous 5 minutes' nonce

            (aPassWord=SHA256(fServer.Model.Root+ServerNonce(true)+aSalt));

end;



class function TSQLRestServerAuthenticationDefault.ClientComputeSessionKey(

  Sender: TSQLRestClientURI; User: TSQLAuthUser): RawUTF8;

var aServerNonce, aClientNonce: RawUTF8;

    rnd: TSHA256Digest;

begin

  result := '';

  if User.LogonName='' then

    exit;

  aServerNonce := Sender.CallBackGetResult('Auth',['UserName',User.LogonName]);

  if aServerNonce='' then

    exit;

  TAESPRNG.Main.FillRandom(@rnd,SizeOf(rnd));

  aClientNonce := SHA256DigestToString(rnd);

  result := ClientGetSessionKey(Sender,User,['UserName',User.LogonName,'Password',

     Sha256(Sender.Model.Root+aServerNonce+aClientNonce+User.LogonName+User.PasswordHashHexa),

     'ClientNonce',aClientNonce]);

end;





{ TSQLRestServerAuthenticationNone }



function TSQLRestServerAuthenticationNone.Auth(Ctxt: TSQLRestServerURIContext): boolean;

var aUserName: RawUTF8;

    U: TSQLAuthUser;

begin

  aUserName := Ctxt.InputUTF8OrVoid['UserName'];

  if aUserName='' then begin

    result := false; // let's try another TSQLRestServerAuthentication class

    exit;

  end;

  result := true; // this kind of weak authentication avoid stronger ones

  if AuthSessionRelease(Ctxt) then

    exit;

  U := GetUser(Ctxt,aUserName);

  if U=nil then

    Ctxt.AuthenticationFailed(afUnknownUser) else

    SessionCreate(Ctxt,U); // call Ctxt.AuthenticationFailed on error

end;



class function TSQLRestServerAuthenticationNone.ClientComputeSessionKey(

  Sender: TSQLRestClientURI; User: TSQLAuthUser): RawUTF8;

begin

  result := ClientGetSessionKey(Sender,User,['UserName',User.LogonName]);

end;





{ TSQLRestServerAuthenticationHttpAbstract }



const

  COOKIE_SESSION = 'mORMot_session_signature';



class procedure TSQLRestServerAuthenticationHttpAbstract.ClientSessionSign(

  Sender: TSQLRestClientURI; var Call: TSQLRestURIParams);

begin

  if (Sender<>nil) and (Sender.fSessionID<>0) and (Sender.fSessionUser<>nil) then

    Call.InHead := Trim(Call.InHead+ // session ID transmitted as HTTP cookie

      (#13#10'Cookie: '+COOKIE_SESSION+'=')+Sender.fSessionIDHexa8);

end;



class function TSQLRestServerAuthenticationHttpAbstract.ClientSetUser(

  Sender: TSQLRestClientURI; const aUserName, aPassword: RawUTF8;

  aPasswordKind: TSQLRestServerAuthenticationClientSetUserPassword;

  const aHashSalt: RawUTF8; aHashRound: integer): boolean;

var res: RawUTF8;

    U: TSQLAuthUser;

begin

  result := false;

  if (aUserName='') or (Sender=nil) then

    exit;

  if aPasswordKind<>passClear then

    raise ESecurityException.CreateUTF8('%.ClientSetUser(%) expects passClear',

      [self,Sender]);

  Sender.SessionClose;

  try // inherited ClientSetUser() won't fit with Auth() method below

    ClientSetUserHttpOnly(Sender,aUserName,aPassword);

    Sender.fSessionAuthentication := self; // to enable ClientSessionSign()

    U := TSQLAuthUser.Create;

    try

      U.LogonName := trim(aUserName);

      res := ClientGetSessionKey(Sender,U,[]);

      if res<>'' then

        result := Sender.SessionCreate(self,U,res);

    finally

      U.Free;

    end;

  finally

    if not result then begin

      // on error, reverse all values

      Sender.fSessionAuthentication := nil;

      Sender.fSessionHttpHeader := '';

    end;

    if Assigned(Sender.OnSetUser) then

      Sender.OnSetUser(Sender); // always notify of user change, even if failed

  end;

end;



function TSQLRestServerAuthenticationHttpAbstract.RetrieveSession(

  Ctxt: TSQLRestServerURIContext): TAuthSession;

var cookie: RawUTF8;

begin

  cookie := Ctxt.InCookie[COOKIE_SESSION];

  if (length(cookie)=8) and HexDisplayToCardinal(pointer(cookie),Ctxt.Session) then

    result := fServer.SessionAccess(Ctxt) else

    result := nil;

end;



class procedure TSQLRestServerAuthenticationHttpAbstract.ClientSetUserHttpOnly(

  Sender: TSQLRestClientURI; const aUserName, aPasswordClear: RawUTF8);

begin

  Sender.fSessionHttpHeader := ComputeAuthenticateHeader(aUserName,aPasswordClear);

end;





{ TSQLRestServerAuthenticationHttpBasic }



class function TSQLRestServerAuthenticationHttpBasic.GetUserPassFromInHead(

  Ctxt: TSQLRestServerURIContext; out userPass,user,pass: RawUTF8): boolean;

begin

  userPass := Ctxt.InHeader['Authorization'];

  if IdemPChar(pointer(userPass),'BASIC ') then begin

    delete(userPass,1,6);

    Split(Base64ToBin(userPass),':',user,pass);

    result := user<>'';

  end else

    result := false;

end;



function TSQLRestServerAuthenticationHttpBasic.RetrieveSession(

  Ctxt: TSQLRestServerURIContext): TAuthSession;

var userPass,user,pass: RawUTF8;

begin

  result := inherited RetrieveSession(Ctxt);

  if result=nil then

    exit; // not a valid 'Cookie: mORMot_session_signature=...' header

  if GetUserPassFromInHead(Ctxt,userPass,user,pass) then begin

    if (result.fExpectedHttpAuthentication<>'') and // fast validation

       (result.fExpectedHttpAuthentication=userPass) then

      exit; // already previously authenticated

    if user=Result.User.LogonName then

    with Ctxt.Server.SQLAuthUserClass.Create do

    try

      PasswordPlain := pass; // compute SHA-256 hash of the supplied password

      if PasswordHashHexa=result.User.PasswordHashHexa then begin

        // match -> store header in result (locked by fSessions.fSafe.Lock)

        result.fExpectedHttpAuthentication := userPass;

        exit;

      end;

    finally

      Free;

    end;

  end;

  result := nil; // identicates authentication error

end;



class function TSQLRestServerAuthenticationHttpBasic.ComputeAuthenticateHeader(

  const aUserName,aPasswordClear: RawUTF8): RawUTF8;

begin

  result := 'Authorization: Basic '+BinToBase64(aUsername+':'+aPasswordClear);

end;



function TSQLRestServerAuthenticationHttpBasic.CheckPassword(Ctxt: TSQLRestServerURIContext;

  User: TSQLAuthUser; const aPassWord: RawUTF8): boolean;

var expectedPass: RawUTF8;

begin

  expectedPass := User.PasswordHashHexa;

  User.PasswordPlain := aPassWord; // override with SHA-256 hash from HTTP header

  result := User.PasswordHashHexa=expectedPass;

end;



function TSQLRestServerAuthenticationHttpBasic.Auth(Ctxt: TSQLRestServerURIContext): boolean;

var userPass,user,pass: RawUTF8;

    U: TSQLAuthUser;

    Session: TAuthSession;

begin

  if Ctxt.InputExists['UserName'] then begin

    result := false; // allow other schemes to check this request

    exit;

  end;

  result := true; // this authentication method is exclusive to any other

  if GetUserPassFromInHead(Ctxt,userPass,user,pass) then begin

    U := GetUser(Ctxt,user);

    if U<>nil then

    try

      if CheckPassword(Ctxt,U,pass) then begin

        fServer.SessionCreate(U,Ctxt,Session); // call Ctxt.AuthenticationFailed on error

        if Session<>nil then begin

          // see TSQLRestServerAuthenticationHttpAbstract.ClientSessionSign()

          Ctxt.SetOutSetCookie((COOKIE_SESSION+'=')+CardinalToHex(Session.IDCardinal));

          if (rsoRedirectForbiddenToAuth in fServer.Options) and (Ctxt.ClientKind=ckAjax) then

            Ctxt.Redirect(fServer.Model.Root) else

            with Session.User do

            Ctxt.Returns(['result',Session.IDCardinal,'logonid',IDValue,

              'logonname',LogonName,'logondisplay',DisplayName,'logongroup',GroupRights.IDValue,

              'server',ExeVersion.ProgramName,'version',ExeVersion.Version.Detailed]);

          exit; // success

        end;

      end else

        Ctxt.AuthenticationFailed(afInvalidPassword);

    finally

      U.Free;

    end else

      Ctxt.AuthenticationFailed(afUnknownUser);

  end else begin

    Ctxt.Call.OutHead := 'WWW-Authenticate: Basic realm="mORMot Server"';;

    Ctxt.Error('',HTML_UNAUTHORIZED); // will popup for credentials in browser

  end;

end;





{$ifdef SSPIAUTH}



{ TSQLRestServerAuthenticationSSPI }



const

  /// maximum number of Windows Authentication context to be handled at once

  // - 64 should be big enough

  MAXSSPIAUTHCONTEXTS = 64;



function TSQLRestServerAuthenticationSSPI.Auth(

  Ctxt: TSQLRestServerURIContext): boolean;

var i: integer;

    UserName, InDataEnc: RawUTF8;

    ticks,ConnectionID: Int64;

    BrowserAuth: Boolean;

    CtxArr: TDynArray;

    SecCtxIdx: Integer;

    OutData: RawByteString;

    User: TSQLAuthUser;

    Session: TAuthSession;

begin

  result := AuthSessionRelease(Ctxt);

  if result or (not Ctxt.InputExists['UserName']) or (not Ctxt.InputExists['Data']) then

    exit;

  // use ConnectionID to find authentication session

  ConnectionID := Ctxt.Call^.LowLevelConnectionID;

  // GET ModelRoot/auth?UserName=&data=... -> windows SSPI auth

  InDataEnc := Ctxt.InputUTF8['Data'];

  if InDataEnc='' then begin

    // client is browser and used HTTP headers to send auth data

    InDataEnc := FindIniNameValue(pointer(Ctxt.Call.InHead),SECPKGNAMEHTTPAUTHORIZATION);

    if InDataEnc = '' then begin

      // no auth data sent, reply with supported auth methods

      Ctxt.Call.OutHead := SECPKGNAMEHTTPWWWAUTHENTICATE;

      Ctxt.Call.OutStatus := HTML_UNAUTHORIZED;

      StatusCodeToErrorMsg(Ctxt.Call.OutStatus, Ctxt.Call.OutBody);

      exit;

    end;

    BrowserAuth := True;

  end else

    BrowserAuth := False;

  CtxArr.InitSpecific(TypeInfo(TSecContextDynArray),fSSPIAuthContexts,djInt64);

  // check for outdated auth context

  ticks := GetTickCount64-30000;

  for i := High(fSSPIAuthContexts) downto 0 do

    if ticks>fSSPIAuthContexts[i].CreatedTick64 then begin

      FreeSecContext(fSSPIAuthContexts[i]);

      CtxArr.Delete(i);

    end;

  // if no auth context specified, create a new one

  result := true;

  SecCtxIdx := CtxArr.Find(ConnectionID);

  if SecCtxIdx<0 then begin

    // 1st call: create SecCtxId

    if High(fSSPIAuthContexts)>MAXSSPIAUTHCONTEXTS then begin

      fServer.InternalLog(

        'Too many Windows Authenticated session in pending state: MAXSSPIAUTHCONTEXTS=%',

        [MAXSSPIAUTHCONTEXTS],sllUserAuth);

      exit;

    end;

    SecCtxIdx := CtxArr.New; // add a new entry to fSSPIAuthContexts[]

    InvalidateSecContext(fSSPIAuthContexts[SecCtxIdx],ConnectionID);

  end;

  // call SSPI provider

  if ServerSSPIAuth(fSSPIAuthContexts[SecCtxIdx], Base64ToBin(InDataEnc), OutData) then begin

    if BrowserAuth then begin

      Ctxt.Call.OutHead := (SECPKGNAMEHTTPWWWAUTHENTICATE+' ')+BinToBase64(OutData);

      Ctxt.Call.OutStatus := HTML_UNAUTHORIZED;

      StatusCodeToErrorMsg(Ctxt.Call.OutStatus, Ctxt.Call.OutBody);

    end else

      Ctxt.Returns(['result','','data',BinToBase64(OutData)]);

    exit; // 1st call: send back OutData to the client

  end;

  // 2nd call: user was authenticated -> release used context

  ServerSSPIAuthUser(fSSPIAuthContexts[SecCtxIdx],UserName);

  {$ifdef WITHLOG}

  if sllUserAuth in fServer.fLogFamily.Level then

    fServer.fLogFamily.SynLog.Log(sllUserAuth,'% Authentication success for %',

      [SecPackageName(fSSPIAuthContexts[SecCtxIdx]),UserName],self);

  {$endif}

  // now client is authenticated -> create a session for aUserName

  // and send back OutData

  try

    if UserName='' then

      exit;

    User := GetUser(Ctxt,UserName);

    if User<>nil then

    try

      User.PasswordHashHexa := ''; // override with context

      fServer.SessionCreate(User,Ctxt,Session); // call Ctxt.AuthenticationFailed on error

      if Session<>nil then

        with Session.User do

        if BrowserAuth then

          Ctxt.Returns(JSONEncode(['result',Session.fPrivateSalt,

            'logonid',IDValue,'logonname',LogonName,'logondisplay',DisplayName,

            'logongroup',GroupRights.IDValue,

            'server',ExeVersion.ProgramName,'version',ExeVersion.Version.Detailed]),

            HTML_SUCCESS,(SECPKGNAMEHTTPWWWAUTHENTICATE+' ')+BinToBase64(OutData)) else

          Ctxt.Returns([

            'result',BinToBase64(SecEncrypt(fSSPIAuthContexts[SecCtxIdx],Session.fPrivateSalt)),

            'logonid',IDValue,'logonname',LogonName,'logondisplay',DisplayName,

            'logongroup',GroupRights.ID,'server',ExeVersion.ProgramName,

            'version',ExeVersion.Version.Detailed,'data',BinToBase64(OutData)]);

    finally

      User.Free;

    end else

      Ctxt.AuthenticationFailed(afUnknownUser);

  finally

    FreeSecContext(fSSPIAuthContexts[SecCtxIdx]);

    CtxArr.Delete(SecCtxIdx);

  end;

end;



class function TSQLRestServerAuthenticationSSPI.ClientComputeSessionKey(

  Sender: TSQLRestClientURI; User: TSQLAuthUser): RawUTF8;

var SecCtx: TSecContext;

    OutData: RawByteString;

begin

  result := '';

  InvalidateSecContext(SecCtx,0);

  Sender.fSessionData := '';

  try

    repeat

      if User.LogonName<>'' then

        ClientSSPIAuthWithPassword(SecCtx,Sender.fSessionData,

          User.LogonName,User.PasswordHashHexa,OutData) else

        ClientSSPIAuth(SecCtx,Sender.fSessionData,User.PasswordHashHexa,OutData);

      if OutData='' then

        break;

      if result<>'' then

        break; // 2nd pass

      // 1st call will return data, 2nd call SessionKey

      result := ClientGetSessionKey(Sender,User,['UserName','','data',BinToBase64(OutData)]);

    until Sender.fSessionData='';

    if result<>'' then

      result := SecDecrypt(SecCtx,Base64ToBin(result));

  finally

    FreeSecContext(SecCtx);

  end;

  // authenticated by Windows on the server side: use the returned

  // SessionKey + PasswordHashHexa to sign the URI, as usual

  User.PasswordHashHexa := ''; // should not appear on URI signature

end;



constructor TSQLRestServerAuthenticationSSPI.Create(aServer: TSQLRestServer);

begin

  inherited Create(aServer);

end;



destructor TSQLRestServerAuthenticationSSPI.Destroy;

var i: integer;

begin

  for i := 0 to High(fSSPIAuthContexts) do

    FreeSecContext(fSSPIAuthContexts[i]);

  inherited;

end;





{$endif SSPIAUTH}





{ TSynAuthenticationRest }



constructor TSynAuthenticationRest.Create(aServer: TSQLRestServer;

  const aAllowedGroups: array of integer);

begin

  inherited Create;

  fServer := aServer;

  RegisterAllowedGroups(aAllowedGroups);

end;



procedure TSynAuthenticationRest.RegisterAllowedGroups(

  const aAllowedGroups: array of integer);

var i: integer;

begin

  for i := 0 to high(aAllowedGroups) do

    AddSortedInteger(fAllowedGroups,aAllowedGroups[i]);

end;



function TSynAuthenticationRest.GetPassword(const UserName: RawUTF8;

  out Password: RawUTF8): boolean;

var U: TSQLAuthUser;

begin

  if fServer=nil then begin

    result := false;

    exit;

  end;

  U := fServer.fSQLAuthUserClass.Create(fServer,'LogonName=?',[UserName]);

  try

    result := (U.fID>0) and

      (FastFindIntegerSorted(fAllowedGroups,PtrInt(U.fGroup))>=0);

    if result then

      Password := U.PasswordHashHexa; // same as ComputeHash() below

  finally

    U.Free;

  end;

end;



function TSynAuthenticationRest.GetUsersCount: integer;

begin

  result := 1; // fake answer indicating that authentication is enabled

end;



class function TSynAuthenticationRest.ComputeHash(Token: Int64;

  const UserName,PassWord: RawUTF8): cardinal;

begin // same as GetPassword() above

  result := inherited ComputeHash(Token,UserName,

    TSQLAuthUser.ComputeHashedPassword(Password));

end;





{ TServiceContainer }



function TServiceContainer.AddInterface(

  const aInterfaces: array of PTypeInfo; aInstanceCreation: TServiceInstanceImplementation;

  aContractExpected: RawUTF8): boolean;

var i: integer;

    F: TServiceFactoryClient;

begin

  result := false;

  if (self=nil) or (high(aInterfaces)<0) then

    exit;

  CheckInterface(aInterfaces);

  for i := 0 to high(aInterfaces) do begin

    F := TServiceFactoryClient.Create(

      Rest,aInterfaces[i],aInstanceCreation,aContractExpected);

    AddServiceInternal(F);

    aContractExpected := ''; // supplied contract is only for the 1st interface

  end;

  result := true;

end;



function TServiceContainer.AddInterface(aInterface: PTypeInfo;

  aInstanceCreation: TServiceInstanceImplementation;

  const aContractExpected: RawUTF8=''): TServiceFactoryClient;

begin

  CheckInterface([aInterface]);

  result := TServiceFactoryClient.Create(Rest,aInterface,aInstanceCreation,aContractExpected);

  AddServiceInternal(result);

end;



function TServiceContainer.Count: integer;

begin

  if self=nil then

    result := 0 else

    result := fList.Count;

end;



constructor TServiceContainer.Create(aRest: TSQLRest);

begin

  fRest := aRest;

  fList := TRawUTF8ListHashed.Create;

  fList.CaseSensitive := false;

  fListInterfaceMethods.InitSpecific(TypeInfo(TServiceContainerInterfaceMethods),

    fListInterfaceMethod,djRawUTF8,nil,true);

end;



destructor TServiceContainer.Destroy;

var i: integer;

begin

  for i := 0 to fList.Count-1 do

    fList.Objects[i].Free;

  fList.Free;

  inherited;

end;



procedure TServiceContainer.Release;

begin

  if (self<>nil) and (fRest<>nil) and (fRest.fServices=self) then

    FreeAndNil(fRest.fServices);

end;



function TServiceContainer.AddServiceInternal(aService: TServiceFactory): integer;

var MethodIndex: integer;

  procedure AddOne(const aInterfaceDotMethodName: RawUTF8);

  begin

    with PServiceContainerInterfaceMethod(fListInterfaceMethods.AddUniqueName(

       aInterfaceDotMethodName,'',[]))^ do begin

      InterfaceService := aService;

      InterfaceMethodIndex := MethodIndex;

    end;

    inc(MethodIndex);

  end;

var aURI: RawUTF8;

    internal: TServiceInternalMethod;

    m: integer;

begin

  if (self=nil) or (aService=nil) then

    result := 0 else

  with aService do begin

    // add service factory

    if ExpectMangledURI then

      aURI := fInterfaceMangledURI else

      aURI := fInterfaceURI;

    result := fList.AddObject(aURI,aService);

    // add associated methods

    aURI := aURI+'.';

    MethodIndex := 0;

    for internal := Low(TServiceInternalMethod) to High(TServiceInternalMethod) do

      AddOne(aURI+SERVICE_PSEUDO_METHOD[internal]);

    for m := 0 to fInterface.fMethodsCount-1 do

      AddOne(aURI+fInterface.fMethods[m].URI);

  end;

end;



procedure TServiceContainer.CheckInterface(const aInterfaces: array of PTypeInfo);

var i: integer;

begin

  for i := 0 to high(aInterfaces) do

    if aInterfaces[i]=nil then

      raise EServiceException.CreateUTF8('%: aInterfaces[%]=nil',[self,i]) else

    with aInterfaces[i]^, PInterfaceTypeData(ClassType)^ do

    if Kind<>tkInterface then

      raise EServiceException.CreateUTF8('%: % is not an interface',[self,Name]) else

    if not (ifHasGuid in IntfFlags) then

      raise EServiceException.CreateUTF8('%: % interface has no GUID',[self,Name]) else

    if Info(IntfGuid)<>nil then

      raise EServiceException.CreateUTF8('%: % GUID already registered',[self,Name]);

end;



procedure TServiceContainer.SetExpectMangledURI(aValue: Boolean);

var f: Integer;

    Fac: array of TServiceFactory;

begin

  if aValue=fExpectMangledURI then

    exit;

  fExpectMangledURI := aValue;

  fList.CaseSensitive := aValue;

  SetLength(Fac,fList.Count);

  for f := 0 to fList.Count-1 do

    Fac[f] := fList.Objects[f] as TServiceFactory;

  fList.Clear;

  fListInterfaceMethod := nil;

  fListInterfaceMethods.InitSpecific(TypeInfo(TServiceContainerInterfaceMethods),

    fListInterfaceMethod,djRawUTF8,nil,not aValue);

  for f := 0 to High(Fac) do

    AddServiceInternal(Fac[f]);

end;



procedure TServiceContainer.SetInterfaceMethodBits(MethodNamesCSV: PUTF8Char;

  IncludePseudoMethods: boolean; out bits: TServiceContainerInterfaceMethodBits);

var i,n: integer;

    method: RawUTF8;

begin

  FillcharFast(bits,sizeof(bits),0);

  n := length(fListInterfaceMethod);

  if n>sizeof(bits) shl 3 then

    raise EServiceException.CreateUTF8('%.SetInterfaceMethodBits: n=%',[self,n]);

  if IncludePseudoMethods then

    for i := 0 to n-1 do

      if fListInterfaceMethod[i].InterfaceMethodIndex<SERVICE_PSEUDO_METHOD_COUNT then

        include(bits,i);

  while MethodNamesCSV<>nil do begin

    method := GetNextItem(MethodNamesCSV);

    if PosEx('.',method)=0 then begin

      for i := 0 to n-1 do

      with fListInterfaceMethod[i] do // O(n) search is fast enough here

        if (InterfaceMethodIndex>=SERVICE_PSEUDO_METHOD_COUNT) and

           IdemPropNameU(method,InterfaceService.fInterface.

            fMethods[InterfaceMethodIndex-SERVICE_PSEUDO_METHOD_COUNT].URI) then

          include(bits,i);

    end else begin

      i := fListInterfaceMethods.FindHashed(method); // O(1) search

      if i>=0 then

        include(bits,i);

    end;

  end;

end;



function TServiceContainer.GetMethodName(ListInterfaceMethodIndex: integer): RawUTF8;

begin

  if cardinal(ListInterfaceMethodIndex)>=cardinal(length(fListInterfaceMethod)) then

    result := '' else

    with fListInterfaceMethod[ListInterfaceMethodIndex] do

      result := InterfaceService.fInterface.GetMethodName(InterfaceMethodIndex);

end;



function TServiceContainer.GetService(const aURI: RawUTF8): TServiceFactory;

var i: Integer;

begin

  if (self<>nil) and (aURI<>'') then begin

    i := fList.IndexOf(aURI);

    if i>=0 then

      result := TServiceFactory(fList.Objects[i]) else

      result := nil;

  end else

    result := nil;

end;



function TServiceContainer.Info(aTypeInfo: PTypeInfo): TServiceFactory;

var i: Integer;

    Obj: PPointerArray;

begin

  if self<>nil then begin

    Obj := fList.ObjectPtr;

    for i := 0 to fList.Count-1 do begin

      result := Obj[i];

      if result.fInterface.fInterfaceTypeInfo=aTypeInfo then

        exit;

    end;

  end;

  result := nil;

end;



function TServiceContainer.Info(const aGUID: TGUID): TServiceFactory;

var i: Integer;

    Obj: PPointerArray;

begin

  if self<>nil then begin

    Obj := fList.ObjectPtr;

    for i := 0 to fList.Count-1 do begin

      result := Obj[i];

      if IsEqualGUID(result.fInterface.fInterfaceIID,aGUID) then

        exit;

    end;

  end;

  result := nil;

end;



procedure TServiceContainer.SetGUIDs(out Services: TGUIDDynArray);

var i: Integer;

begin

  if self=nil then

    exit;

  SetLength(Services,fList.Count);

  for i := 0 to fList.Count-1 do

    Services[i] := TServiceFactory(fList.ObjectPtr[i]).fInterface.fInterfaceIID;

end;



procedure TServiceContainer.SetInterfaceNames(out Names: TRawUTF8DynArray);

var i: Integer;

begin

  if self=nil then

    exit;

  SetLength(Names,fList.Count);

  for i := 0 to fList.Count-1 do

    Names[i] :=  TServiceFactory(fList.ObjectPtr[i]).fInterfaceURI;

end;



function TServiceContainer.AsJson: RawJSON;

var WR: TTextWriter;

    i: integer;

begin

  result := '';

  if (self=nil) or (fList.Count=0) then

    exit;

  WR := TJSONSerializer.CreateOwnedStream;

  try

    WR.Add('[');

    for i := 0 to fList.Count-1 do begin

      WR.AddString(TServiceFactory(fList.ObjectPtr[i]).Contract);

      WR.Add(',');

    end;

    WR.CancelLastComma;

    WR.Add(']');

    WR.SetText(RawUTF8(result));

  finally

    WR.Free;

  end;

end;



function TServiceContainer.TryResolve(aInterface: PTypeInfo; out Obj): boolean;

var factory: TServiceFactory;

begin

  factory := Info(aInterface);

  if factory=nil then

    result := inherited TryResolve(aInterface,Obj) else

    result := factory.Get(Obj);

end;



function TServiceContainer.Index(aIndex: integer): TServiceFactory;

begin

  if Self=nil then

    result := nil else

    result := TServiceFactory(fList.Objects[aIndex]);

end;



function TServiceContainer.CallBackUnRegister(const Callback: IInvokable): boolean;

begin

  result := false; // nothing to be done here

end;





{ TInterfacedObjectFake }



const

  // this is used to avoid creating dynamic arrays if not needed

  MAX_METHOD_ARGS = 32;



  // QueryInterface, _AddRef and _Release methods are hard-coded

  RESERVED_VTABLE_SLOTS = 3;



// see http://docwiki.embarcadero.com/RADStudio/en/Program_Control



{$ifdef CPU64}

  // maximum stack size at method execution must match .PARAMS 64 (minus 4 regs)

  MAX_EXECSTACK = 60*8;

{$else}

  // maximum stack size at method execution

  {$ifdef CPUARM}

  MAX_EXECSTACK = 60*4;

  {$else}

  MAX_EXECSTACK = 1024;

  {$endif}

{$endif CPU64}



{$ifdef CPUX86}

  // 32-bit integer param registers (in "register" calling convention)

  REGEAX = 1;

  REGEDX = 2;

  REGECX = 3;

  PARAMREG_FIRST = REGEAX;

  PARAMREG_LAST = REGECX;

  // floating-point params are passed by reference

{$endif CPUX86}



{$ifdef CPUX64}

  // 64-bit integer param registers

  {$ifdef LINUX}

  REGRDI = 1;

  REGRSI = 2;

  REGRDX = 3;

  REGRCX = 4;

  REGR8 = 5;

  REGR9 = 6;

  PARAMREG_FIRST = REGRDI;

  PARAMREG_RESULT = REGRSI;

  {$else}

  REGRCX = 1;

  REGRDX = 2;

  REGR8 = 3;

  REGR9 = 4;

  PARAMREG_FIRST = REGRCX;

  PARAMREG_RESULT = REGRDX;

  {$endif}

  PARAMREG_LAST = REGR9;

  // 64-bit floating-point (double) registers

  REGXMM0 = 1;

  REGXMM1 = 2;

  REGXMM2 = 3;

  REGXMM3 = 4;

  {$ifdef LINUX}

  REGXMM4 = 5;

  REGXMM5 = 6;

  REGXMM6 = 7;

  REGXMM7 = 8;

  FPREG_FIRST = REGXMM0;

  FPREG_LAST = REGXMM7;

  {$else}

  FPREG_FIRST = REGXMM0;

  FPREG_LAST = REGXMM3;

  {$endif}

  {$define HAS_FPREG}

{$endif CPUX64}



{$ifdef CPUARM}

  // 32-bit integer param registers

  REGR0 = 1;

  REGR1 = 2;

  REGR2 = 3;

  REGR3 = 4;

  PARAMREG_FIRST = REGR0;

  PARAMREG_LAST = REGR3;

  PARAMREG_RESULT = REGR1;

  // 64-bit floating-point (double) registers

  REGD0 = 1;

  REGD1 = 2;

  REGD2 = 3;

  REGD3 = 4;

  REGD4 = 5;

  REGD5 = 6;

  REGD6 = 7;

  REGD7 = 8;

  FPREG_FIRST = REGD0;

  FPREG_LAST = REGD7;

  {$define HAS_FPREG}

{$endif CPUARM}



{$ifdef CPUAARCH64}

  // 64-bit integer param registers

  REGX0 = 1;

  REGX1 = 2;

  REGX2 = 3;

  REGX3 = 4;

  REGX4 = 5;

  REGX5 = 6;

  REGX6 = 7;

  REGX7 = 8;

  PARAMREG_FIRST = REGX0;

  PARAMREG_LAST = REGX7;

  PARAMREG_RESULT = REGX0; // is really REGX1 self?

  // 64-bit floating-point (double) registers

  REGD0 = 1; // map REGV0 128-bit NEON register

  REGD1 = 2; // REGV1

  REGD2 = 3; // REGV2

  REGD3 = 4; // REGV3

  REGD4 = 5; // REGV4

  REGD5 = 6; // REGV5

  REGD6 = 7; // REGV6

  REGD7 = 8; // REGV7

  FPREG_FIRST = REGD0;

  FPREG_LAST = REGD7;

  {$define HAS_FPREG}

{$endif CPUAARCH64}



  PTRSIZ = sizeof(Pointer);

  PTRSHR = {$ifdef CPU64}3{$else}2{$endif};



  STACKOFFSET_NONE = -1;



  // ordinal values are stored within 64-bit buffer, and records in a RawUTF8

  CONST_ARGS_TO_VAR: array[TServiceMethodValueType] of TServiceMethodValueVar = (

    smvvNone, smvvSelf, smvv64, smvv64, smvv64, smvv64, smvv64, smvv64, smvv64,

    smvv64, smvv64,

    smvvRawUTF8, smvvString, smvvRawUTF8, smvvWideString, smvvRecord,

    {$ifndef NOVARIANTS}smvvRecord,{$endif} smvvObject, smvvRawUTF8,

    smvvDynArray, smvvInterface);



  {$ifdef CPU32}

  // always aligned to 8 bytes boundaries for 64-bit

  CONST_ARGS_IN_STACK_SIZE: array[TServiceMethodValueType] of Cardinal = (

     0,  PTRSIZ,PTRSIZ, PTRSIZ,PTRSIZ,PTRSIZ, PTRSIZ,    8,     8,      8,

 // None, Self, Boolean, Enum, Set,  Integer, Cardinal, Int64, Double, DateTime,

     8,       PTRSIZ,  PTRSIZ, PTRSIZ,        PTRSIZ,     PTRSIZ,

 // Currency, RawUTF8, String, RawByteString, WideString, Record,

    {$ifndef NOVARIANTS}PTRSIZ,{$endif} // Variant

    PTRSIZ, PTRSIZ,  PTRSIZ, PTRSIZ);

 // Object, RawJSON, DynArray, Interface

  {$endif}



  CONST_ARGS_RESULT_BY_REF: TServiceMethodValueTypes = [

    smvRawUTF8, smvRawJSON, smvString, smvRawByteString, smvWideString, smvRecord,

    {$ifndef NOVARIANTS}smvVariant,{$endif} smvDynArray];



  CONST_PSEUDO_RESULT_NAME: string[6] = 'Result';

  CONST_PSEUDO_SELF_NAME: string[4] = 'Self';

  CONST_INTEGER_NAME: string[7] = 'Integer';



type

  /// map the stack memory layout at TInterfacedObjectFake.FakeCall()

  TFakeCallStack = packed record

    {$ifdef CPUX86}

    EDX, ECX, MethodIndex, EBP, Ret: cardinal;

    {$else}

    {$ifdef Linux}

    ParamRegs: packed array[PARAMREG_FIRST..PARAMREG_LAST] of pointer;

    {$endif}

    {$ifdef HAS_FPREG}

    FPRegs: packed array[FPREG_FIRST..FPREG_LAST] of double;

    {$endif}

    MethodIndex: PtrUInt;

    Frame: pointer;

    Ret: pointer;

    {$ifndef Linux}

    ParamRegs: packed array[PARAMREG_FIRST..PARAMREG_LAST] of pointer;

    {$endif}

    {$endif CPUX86}

    {$ifdef CPUARM}

    // alf: on ARM, there is more on the stack than you would expect

    DummyStack: packed array[0..9] of pointer;

    {$endif}

    {$ifdef CPUAARCH64}

    // alf: on AARCH64, there is more on the stack than you would expect

    DummyStack: packed array[0..0] of pointer;

    {$endif}

    Stack: packed array[word] of byte;

  end;



  /// instances of this class will emulate a given interface

  // - as used by TInterfaceFactory.CreateFakeInstance

  TInterfacedObjectFake = class(TInterfacedObjectFromFactory)

  protected

    fVTable: PPointerArray;

    function FakeCall(var aCall: TFakeCallStack): Int64;

    {$ifdef FPC}

    {$ifdef CPUARM}

    // on ARM, the FakeStub needs to be here, otherwise the FakeCall cannot be found by the FakeStub

    procedure ArmFakeStub;

    {$endif}

    {$ifdef CPUAARCH64}

    // on Aarch64, the FakeStub needs to be here, otherwise the FakeCall cannot be found by the FakeStub

    procedure AArch64FakeStub;

    {$endif}

    function FakeQueryInterface(

      {$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID;

      out Obj): longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};

    function Fake_AddRef: longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};

    function Fake_Release: longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};

    {$else}

    function FakeQueryInterface(const IID: TGUID; out Obj): HResult; stdcall;

    function Fake_AddRef: Integer; stdcall;

    function Fake_Release: Integer; stdcall;

    {$endif}

    function SelfFromInterface: TInterfacedObjectFake;

      {$ifdef PUREPASCAL} {$ifdef HASINLINE}inline;{$endif} {$endif}

    procedure InterfaceWrite(W: TJSONSerializer; const aMethod: TServiceMethod;

      const aParamInfo: TServiceMethodArgument; aParamValue: Pointer); virtual;

  public

    /// create an instance, using the specified interface

    constructor Create(aFactory: TInterfaceFactory;

      aOptions: TInterfacedObjectFromFactoryOptions;

      aInvoke: TOnFakeInstanceInvoke; aNotifyDestroy: TOnFakeInstanceDestroy);

    /// retrieve one local instance of this interface

    procedure Get(out Obj);

  end;



  TInterfacedObjectFakeClient = class(TInterfacedObjectFake)

  protected

    fClient: TServiceFactoryClient;

    procedure InterfaceWrite(W: TJSONSerializer; const aMethod: TServiceMethod;

      const aParamInfo: TServiceMethodArgument; aParamValue: Pointer); override;

  public

    constructor Create(aClient: TServiceFactoryClient;

      aInvoke: TOnFakeInstanceInvoke; aNotifyDestroy: TOnFakeInstanceDestroy);

    destructor Destroy; override;

  end;



  TInterfacedObjectFakeServer = class(TInterfacedObjectFake)

  protected

    fServer: TSQLRestServer;

    fLowLevelConnectionID: Int64;

    fService: TServiceFactoryServer;

    fReleasedOnClientSide: boolean;

    fFakeInterface: Pointer;

    fRaiseExceptionOnInvokeError: boolean;

    function CallbackInvoke(const aMethod: TServiceMethod;

      const aParams: RawUTF8; aResult, aErrorMsg: PRawUTF8;

      aClientDrivenID: PCardinal; aServiceCustomAnswer: PServiceCustomAnswer): boolean; virtual;

  public

    constructor Create(aRequest: TSQLRestServerURIContext;

      aFactory: TInterfaceFactory; aFakeID: Integer);

    destructor Destroy; override;

  end;



  EInterfaceStub = class(EInterfaceFactoryException)

  public

    constructor Create(Sender: TInterfaceStub; const Method: TServiceMethod;

      const Error: RawUTF8); overload;

    constructor Create(Sender: TInterfaceStub; const Method: TServiceMethod;

      const Format: RawUTF8; const Args: array of const); overload;

  end;





constructor TInterfacedObjectFake.Create(aFactory: TInterfaceFactory;

  aOptions: TInterfacedObjectFromFactoryOptions; aInvoke: TOnFakeInstanceInvoke;

  aNotifyDestroy: TOnFakeInstanceDestroy);

begin

  inherited Create(aFactory,aOptions,aInvoke,aNotifyDestroy);

  fVTable := aFactory.GetMethodsVirtualTable;

end;



function TInterfacedObjectFake.SelfFromInterface: TInterfacedObjectFake;

{$ifdef PUREPASCAL}

begin

  result := pointer(PtrInt(self)-PtrInt(@TInterfacedObjectFake(nil).fVTable));

end;

{$else}

{$ifdef CPUINTEL}

asm

  sub eax,TInterfacedObjectFake.fVTable

end;

{$endif CPUINTEL}

{$endif}



function TInterfacedObjectFake.Fake_AddRef: {$ifdef FPC}longint{$else}integer{$endif};

begin

  result := SelfFromInterface._AddRef;

end;



function TInterfacedObjectFake.Fake_Release: {$ifdef FPC}longint{$else}integer{$endif};

begin

  result := SelfFromInterface._Release;

end;



function TInterfacedObjectFake.FakeQueryInterface(

{$ifdef FPC}

  {$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID; out Obj): longint;

{$else}

  const IID: TGUID; out Obj): HResult;

{$endif}

begin

  self := SelfFromInterface;

  if IsEqualGUID(IID,fFactory.fInterfaceIID) then begin

    pointer(Obj) := @fVTable;

    _AddRef;

    result := NOERROR;

  end else

  if GetInterface(IID,Obj) then

    result := NOERROR else

    result := {$ifdef FPC}longint{$endif}(E_NOINTERFACE);

end;



procedure TInterfacedObjectFake.Get(out Obj);

begin

  pointer(Obj) := @fVTable;

  _AddRef;

end;



procedure IgnoreComma(var P: PUTF8Char);

begin

  if P<>nil then begin

    if P^ in [#1..' '] then repeat inc(P) until not(P^ in [#1..' ']);

    if P^=',' then inc(P);

  end;

end;



function TInterfacedObjectFake.FakeCall(var aCall: TFakeCallStack): Int64;

var method: ^TServiceMethod;

procedure RaiseError(const Format: RawUTF8; const Args: array of const);

var msg: RawUTF8;

begin

  msg := FormatUTF8(Format,Args);

  raise EInterfaceFactoryException.CreateUTF8('%.FakeCall(%.%) failed: %',

    [self,fFactory.fInterfaceTypeInfo^.Name,method^.URI,msg]);

end;

var resultType: TServiceMethodValueType; // type of value stored into result

procedure InternalProcess;

var Params: TJSONSerializer;

    Error, ResArray, ParamsJSON: RawUTF8;

    arg, ValLen: integer;

    V: PPointer;

    R, Val: PUTF8Char;

    valid, wasString, resultAsJSONObject: boolean;

    ServiceCustomAnswerPoint: PServiceCustomAnswer;

    DynArrays: array[0..MAX_METHOD_ARGS-1] of TDynArray;

    Value: array[0..MAX_METHOD_ARGS-1] of pointer;

    I64s: array[0..MAX_METHOD_ARGS-1] of Int64;

begin

  Params := TJSONSerializer.CreateOwnedStream;

  try

    // create the parameters

    if ifoJsonAsExtended in fOptions then

      include(Params.fCustomOptions,twoForceJSONExtended) else

      include(Params.fCustomOptions,twoForceJSONStandard); // e.g. for AJAX

    FillcharFast(I64s,method^.ArgsUsedCount[smvv64]*sizeof(Int64),0);

    for arg := 1 to high(method^.Args) do

    with method^.Args[arg] do

    if ValueType>smvSelf then begin

      {$ifdef HAS_FPREG} // x64, arm, aarch64

      if FPRegisterIdent>0 then

        V := Pointer((PtrUInt(@aCall.FPRegs[FPREG_FIRST])+Sizeof(Double)*(FPRegisterIdent-1))) else

      if RegisterIdent>0 then

        V := Pointer((PtrUInt(@aCall.ParamRegs[PARAMREG_FIRST])+Sizeof(pointer)*(RegisterIdent-1))) else

      {$endif}

        V := nil;

      {$ifndef CPUAARCH64} // on aarch64, reference result can be in PARAMREG_FIRST

      if RegisterIdent=PARAMREG_FIRST then

         RaiseError('unexpected self',[]);

      {$endif}

      {$ifdef CPUX86}

      case RegisterIdent of

      REGEAX: RaiseError('unexpected self',[]);

      REGEDX: V := @aCall.EDX;

      REGECX: V := @aCall.ECX;

      else

      {$endif}

      if V=nil then

        if (SizeInStack>0) and (InStackOffset<>STACKOFFSET_NONE) then

          V := @aCall.Stack[InStackOffset] else

          V := @I64s[IndexVar]; // for results in CPU

      {$ifdef CPUX86}

      end;

      {$endif}

      if vPassedByReference in ValueKindAsm then

        V := PPointer(V)^;

      case ValueType of

      smvDynArray:

        {$ifdef FPC} // FIXME ?

          if vIsObjArray in ValueKindAsm then

             DynArrays[IndexVar].Init(ArgTypeInfo,V^) else

             DynArrays[IndexVar].Init(ArgTypeInfo,V);

        {$else}

        DynArrays[IndexVar].Init(ArgTypeInfo,V^);

        {$endif}

      end;

      Value[arg] := V;

      if ValueDirection in [smdConst,smdVar] then

        case ValueType of

        smvInterface:

          InterfaceWrite(Params,method^,method^.Args[arg],V^);

        smvDynArray: begin

          Params.AddDynArrayJSON(DynArrays[IndexVar]);

          Params.Add(',');

        end;

        else AddJSON(Params,V);

        end;

    end;

    Params.CancelLastComma;

    Params.SetText(ParamsJSON);

    // call remote server or stub implementation

    if method^.ArgsResultIsServiceCustomAnswer then

      ServiceCustomAnswerPoint := Value[method^.ArgsResultIndex] else

      ServiceCustomAnswerPoint := nil;

    if not fInvoke(method^,ParamsJSON,

       @ResArray,@Error,@fClientDrivenID,ServiceCustomAnswerPoint) then

      RaiseError('''%''',[Error]);

  finally

    Params.Free;

  end;

  // retrieve method result and var/out parameters content

  if ServiceCustomAnswerPoint=nil then

  if ResArray<>'' then begin

    R := pointer(ResArray);

    if R^ in [#1..' '] then repeat inc(R) until not(R^ in [#1..' ']);

    resultAsJSONObject := false; // [value,...] JSON array format

    if R^='{' then   // {"paramname":value,...} JSON object format

      resultAsJSONObject := true else

    if R^<>'[' then

      RaiseError('JSON array/object result expected',[]);

    inc(R);

    arg := method^.ArgsOutFirst;

    if arg>0 then

    repeat

      if resultAsJSONObject then begin

        Val := GetJSONPropName(R);

        if Val=nil then

          break; // end of JSON object

        ValLen := StrLen(Val);

        if (arg>0) and not IdemPropName(method^.Args[arg].ParamName^,Val,ValLen) then begin

          arg := method^.ArgIndex(Val,ValLen,false); // only if were not in-order

          if arg<0 then

            RaiseError('unexpected parameter "%"',[Val]);

        end;

      end;

      with method^.Args[arg] do begin

        //assert(ValueDirection in [smdVar,smdOut,smdResult]);

        V := Value[arg];

        case ValueType of

        smvObject: begin

          if PInteger(R)^=NULL_LOW then

            inc(R,4) else begin // null from TInterfacedStub -> stay untouched

            R := JSONToObject(V^,R,valid);

            if not valid then

              RaiseError('returned object',[]);

          end;

          IgnoreComma(R);

        end;

        smvInterface:

          RaiseError('unexpected var/out interface',[]);

        smvRawJSON:

          if (R<>nil) and (R^=']') then

            PRawUTF8(V)^ := '' else begin

            GetJSONItemAsRawJSON(R,PRawJSON(V)^);

            if R=nil then

              RaiseError('returned RawJSON',[]);

          end;

        smvDynArray: begin

          if vIsObjArray in ValueKindAsm then

            ObjArrayClear(V^);

          R := DynArrays[IndexVar].LoadFromJSON(R);

          if R=nil then

            RaiseError('returned array',[]);

          IgnoreComma(R);

        end;

        smvBoolean..smvWideString: begin

          Val := GetJSONField(R,R,@wasString);

          if (Val=nil) or (wasString<>(vIsString in ValueKindAsm)) then

            if resultAsJSONObject then

              RaiseError('missing or invalid value',[]) else

              RaiseError('missing or invalid value: '+

              'parameters shall follow method var/out/result order',[]);

          if (ValueType=smvBoolean) and (PInteger(Val)^=TRUE_LOW) then

            Val := '1'; // handle also BOOL with SizeInStorage=2

          case ValueType of

          smvBoolean, smvEnum, smvSet, smvCardinal:

            case SizeInStorage of

            1: PByte(V)^     := GetCardinal(Val);

            2: PWord(V)^     := GetCardinal(Val);

            4: PCardinal(V)^ := GetCardinal(Val);

            end;

          smvInteger:    PInteger(V)^ := GetInteger(Val);

          smvInt64:      SetInt64(Val,PInt64(V)^);

          smvDouble,smvDateTime: PDouble(V)^ := GetExtended(Val);

          smvCurrency:   PInt64(V)^   := StrToCurr64(Val);

          smvRawUTF8:    SetString(PRawUTF8(V)^,PAnsiChar(Val),StrLen(Val));

          smvString:     UTF8DecodeToString(Val,StrLen(Val),PString(V)^);

          smvRawByteString: Base64ToBin(PAnsiChar(Val),StrLen(Val),PRawByteString(V)^);

          smvWideString: UTF8ToWideString(Val,StrLen(Val),PWideString(V)^);

          else RaiseError('ValueType=%',[ord(ValueType)]);

          end;

        end;

        smvRecord: begin

          R := RecordLoadJSON(V^,R,ArgTypeInfo);

          if R=nil then

            RaiseError('returned record',[]);

        end;

        {$ifndef NOVARIANTS}

        smvVariant: begin

          R := VariantLoadJSON(PVariant(V)^,R,nil,@fFactory.DocVariantOptions);

          if R=nil then

            RaiseError('returned variant',[]);

        end;

        {$endif}

        end;

        if ValueDirection=smdResult then begin

          resultType := ValueType;

          if ValueType in [smvBoolean..smvCurrency] then

            // ordinal/real result values to CPU/FPU registers

            MoveFast(V^,Result,SizeInStorage);

        end;

      end;

      if R=nil then

        break;

      if R^ in [#1..' '] then repeat inc(R) until not(R^ in [#1..' ']);

      if resultAsJSONObject then begin

        if (R^=#0) or (R^='}') then

          break else // end of JSON object

          if not method^.ArgNext(arg,false) then

            arg := 0; // no next result argument -> force manual search

      end else

      if not method^.ArgNext(arg,false) then

        break; // end of JSON array

    until false;

  end else

    if method^.ArgsOutputValuesCount>0 then

      RaiseError('method returned value, but ResArray=''''',[]);

end;

begin

  // WELCOME ABOARD: you just landed in TInterfacedObjectFake.FakeCall() !

  // if your debugger reached here, you are executing a "fake" interface

  // forged to call a remote SOA server or mock/stub an interface



  self := SelfFromInterface;

  {$ifdef CPUAARCH64}

  // alf: on aarch64, the self is sometimes only available in x1, when we have a result pointer !

  // try to detect this ... although not very elegant, but I do not yet know how else to do this

  try

    if (fFactory=nil) or (fFactory.fDetectX0ResultMagic<>$AAAAAAAA) then begin

      // aha, we have a reference result, placed in X0, so self is in X1 !!

      self := aCall.ParamRegs[REGX1];

      self := SelfFromInterface;

      if fFactory.fDetectX0ResultMagic<>$AAAAAAAA then

         raise EInterfaceFactoryException.CreateUTF8('Self error',[]);

    end;

  except

    // if the above fails due to some error, we are definitely sure that the self is in REGX1 !!

    self := aCall.ParamRegs[REGX1];

    self := SelfFromInterface;

    if fFactory.fDetectX0ResultMagic<>$AAAAAAAA then

       raise EInterfaceFactoryException.CreateUTF8('Self error',[]);

  end;

  {$endif}

  if aCall.MethodIndex>=fFactory.fMethodsCount then

    raise EInterfaceFactoryException.CreateUTF8(

      '%.FakeCall(%.%) failed: out of range method %>=%',

      [self,fFactory.fInterfaceTypeInfo^.Name,aCall.MethodIndex,fFactory.fMethodsCount]);

  method := @fFactory.fMethods[aCall.MethodIndex];

  if not Assigned(fInvoke)then

    RaiseError('fInvoke=nil',[]);

  result := 0;

  resultType := smvNone;

  InternalProcess; // use an inner proc to ensure direct fld/fild FPU ops

  case resultType of // al/ax/eax/eax:edx/rax already in result

  {$ifdef HAS_FPREG}

  smvDouble,smvDateTime: aCall.FPRegs[FPREG_FIRST] := PDouble(@result)^;

  {$else}

  smvDouble,smvDateTime: asm fld  qword ptr [result] end;  // in st(0)

  smvCurrency:           asm fild qword ptr [result] end;  // in st(0)

  {$endif}

  end;

end;



procedure TInterfacedObjectFake.InterfaceWrite(W: TJSONSerializer;

  const aMethod: TServiceMethod; const aParamInfo: TServiceMethodArgument;

  aParamValue: Pointer);

begin

  raise EInterfaceFactoryException.CreateUTF8('%: unhandled %.%(%: %) argument',

    [self,fFactory.fInterfaceTypeInfo^.Name,aMethod.URI,

     aParamInfo.ParamName^,aParamInfo.ArgTypeName^]);

end;



constructor TInterfacedObjectFakeClient.Create(aClient: TServiceFactoryClient;

  aInvoke: TOnFakeInstanceInvoke; aNotifyDestroy: TOnFakeInstanceDestroy);

var opt: TInterfacedObjectFromFactoryOptions;

begin

  fClient := aClient;

  if (fClient.fClient<>nil) and (fClient.fClient.fSessionID<>0) then

    opt := [ifoJsonAsExtended] else

    opt := [];

  inherited Create(aClient.fInterface,opt,aInvoke,aNotifyDestroy);

end;



procedure TInterfacedObjectFakeClient.InterfaceWrite(W: TJSONSerializer;

  const aMethod: TServiceMethod; const aParamInfo: TServiceMethodArgument;

  aParamValue: Pointer);

begin

  W.Add(fClient.fClient.FakeCallbackRegister(fClient,aMethod,aParamInfo,aParamValue));

  W.Add(',');

end;



destructor TInterfacedObjectFakeClient.Destroy;

begin

  fClient.fClient.InternalLog('%(%).Destroy I%',

    [ClassType,pointer(self),fClient.InterfaceURI],sllTrace);

  inherited Destroy;

end;



constructor TInterfacedObjectFakeServer.Create(aRequest: TSQLRestServerURIContext;

  aFactory: TInterfaceFactory; aFakeID: Integer);

var opt: TInterfacedObjectFromFactoryOptions;

begin

  if aRequest.ClientKind=ckFramework then

    opt := [ifoJsonAsExtended] else

    opt := [];

  fServer := aRequest.Server;

  fService := aRequest.Service;

  fLowLevelConnectionID := aRequest.Call^.LowLevelConnectionID;

  fClientDrivenID := aFakeID;

  inherited Create(aFactory,opt,CallbackInvoke,nil);

  Get(fFakeInterface);

end;



destructor TInterfacedObjectFakeServer.Destroy;

begin

  if fServer<>nil then begin // may be called asynchronously AFTER server is down

    fServer.InternalLog('%(%:%).Destroy I%',

      [ClassType,pointer(self),fClientDrivenID,fService.InterfaceURI],sllTrace);

    if fServer.Services<>nil then

      with (fServer.Services as TServiceContainerServer) do

        if fFakeCallbacks<>nil then

          FakeCallbackRemove(self);

  end;

  inherited Destroy;

end;



function TInterfacedObjectFakeServer.CallbackInvoke(const aMethod: TServiceMethod;

  const aParams: RawUTF8; aResult, aErrorMsg: PRawUTF8;

  aClientDrivenID: PCardinal; aServiceCustomAnswer: PServiceCustomAnswer): boolean;

begin // here aClientDrivenID^ = FakeCall ID

  if fServer=nil then begin

    if aErrorMsg<>nil then

      aErrorMsg^ := 'Server was already shutdown';

    result := true;

    exit;

  end;

  if not Assigned(fServer.OnNotifyCallback) then

    raise EServiceException.CreateUTF8('% does not implement callbacks for I%',

      [fServer,aMethod.InterfaceDotMethodName]);

  if fReleasedOnClientSide then begin

    if not IdemPropName(fFactory.fInterfaceTypeInfo^.Name,'ISynLogCallback') then

      fServer.InternalLog('%.CallbackInvoke: % instance has been released on '+

        'the client side, so I% callback notification was NOT sent',

        [self,fFactory.fInterfaceTypeInfo^.Name,aMethod.InterfaceDotMethodName],sllWarning);

    if fRaiseExceptionOnInvokeError or

       ((fServer.Services<>nil) and

        (coRaiseExceptionIfReleasedByClient in

         (fServer.Services as TServiceContainerServer).CallbackOptions)) then begin

      if aErrorMsg<>nil then

        aErrorMsg^ := FormatUTF8('%.CallbackInvoke(I%): instance has been '+

          'released on client side',[self,aMethod.InterfaceDotMethodName]);

      result := false; // will raise an exception

    end else

      result := true; // do not raise an exception here: just log warning

  end else begin

    if aMethod.ArgsOutputValuesCount=0 then

      aResult := nil; // no result -> asynchronous non blocking callback

    result := fServer.OnNotifyCallback(fServer,aMethod.InterfaceDotMethodName,

      aParams,fLowLevelConnectionID,aClientDrivenID^,aResult,aErrorMsg);

  end;

end;



procedure TSQLRestServerURIContext.ExecuteCallback(var Par: PUTF8Char;

  ParamInterfaceInfo: PTypeInfo; out Obj);

var FakeID: PtrInt;

    factory: TInterfaceFactory;

    instance: TInterfacedObjectFakeServer;

begin

  if not Assigned(Server.OnNotifyCallback) then

    raise EServiceException.CreateUTF8('% does not implement callbacks for I%',

      [Server,ParamInterfaceInfo^.Name]);

  FakeID := GetInteger(GetJSONField(Par,Par)); // GetInteger returns a PtrInt

  if Par=nil then

    Par := @NULL_SHORTSTRING; // allow e.g. '[12345]'

  if (FakeID=0) or (ParamInterfaceInfo=TypeInfo(IInvokable)) then begin

    pointer(Obj) := pointer(FakeID); // Obj = IInvokable(FakeID)

    exit;

  end;

  factory := TInterfaceFactory.Get(ParamInterfaceInfo);

  instance := TInterfacedObjectFakeServer.Create(self,factory,FakeID);

  pointer(Obj) := instance.fFakeInterface;

  (Server.Services as TServiceContainerServer).FakeCallbackAdd(instance);

end;





{ TInterfacedObjectFromFactory }



constructor TInterfacedObjectFromFactory.Create(aFactory: TInterfaceFactory;

  aOptions: TInterfacedObjectFromFactoryOptions; aInvoke: TOnFakeInstanceInvoke;

  aNotifyDestroy: TOnFakeInstanceDestroy);

begin

  inherited Create;

  fFactory := aFactory;

  fOptions := aOptions;

  fInvoke := aInvoke;

  fNotifyDestroy := aNotifyDestroy;

end;



destructor TInterfacedObjectFromFactory.Destroy;

var C: TClass;

begin

  if Assigned(fNotifyDestroy) then

  try // release server instance

    fNotifyDestroy(fClientDrivenID);

  except

    on E: Exception do begin

      C := E.ClassType;

      if (C=EInterfaceStub) or (C=EInterfaceFactoryException) or

         (C=EAccessViolation) {$ifndef LVCL}or (C=EInvalidPointer){$endif} then

        raise; // ignore all low-level exceptions

    end;

  end;

  inherited;

end;





{ TInterfaceFactory }



function TypeInfoToMethodValueType(P: PTypeInfo): TServiceMethodValueType;

var IsObjCustomIndex: integer;

begin

  result := smvNone;

  if P<>nil then

  case P^.Kind of

  tkInteger:

    case P^.OrdType of

    otSLong: result := smvInteger;

    otULong: result := smvCardinal;

    end;

  tkInt64{$ifdef FPC}, tkQWord{$endif}:

    result := smvInt64;

  {$ifdef FPC}

  tkBool:

    result := smvBoolean;

  tkEnumeration:

    result := smvEnum;

  {$else}

  tkEnumeration:

    if P=TypeInfo(boolean) then

      result := smvBoolean else

      result := smvEnum;

  {$endif}

  tkSet:

    result := smvSet;

  tkFloat:

    if P=TypeInfo(TDateTime) then

      result := smvDateTime else

    case P^.FloatType of

      ftCurr: result := smvCurrency;

      ftDoub: result := smvDouble;

    end;

  {$ifdef FPC}tkAString,{$endif} tkLString:

    if P=TypeInfo(RawJSON) then

      result := smvRawJSON else

    if P=TypeInfo(RawByteString) then

      result := smvRawByteString else

  {$ifndef UNICODE}

    if P=TypeInfo(AnsiString) then

      result := smvString else

      result := smvRawUTF8; // UTF-8 by default

  {$ifdef HASVARUSTRING}

  tkUString:

    result := smvRawUTF8;

  {$endif}

  {$else UNICODE}

      result := smvRawUTF8;

  tkUString:

    result := smvString;

  {$endif UNICODE}

  tkWString:

    result := smvWideString;

  tkClass:

    with P^.ClassType^ do

    if ClassHasPublishedFields(ClassType) or

       (JSONObject(ClassType,IsObjCustomIndex,[cpRead,cpWrite]) in

         [{$ifndef LVCL}oCollection,{$endif}oObjectList,oUtfs,oStrings,

          oException,oCustom]) then

      result := smvObject; // JSONToObject/ObjectToJSON types

  {$ifdef FPC}tkObject,{$endif} tkRecord:

    // Base64 encoding of our RecordLoad / RecordSave binary format

    result := smvRecord;

  {$ifndef NOVARIANTS}

  tkVariant:

    result := smvVariant;

  {$endif}

  tkDynArray: // TDynArray.LoadFromJSON / TTextWriter.AddDynArrayJSON type

    result := smvDynArray;

  tkInterface:

    result := smvInterface;

  tkUnknown: // assume var/out untyped arguments are in fact objects

    result := smvObject;

  end;

end;



var

  InterfaceFactoryCache: TObjectListLocked;



procedure EnterInterfaceFactoryCache;

begin

  if InterfaceFactoryCache=nil then

    GarbageCollectorFreeAndNil(InterfaceFactoryCache,TObjectListLocked.Create);

  InterfaceFactoryCache.Safe.Lock;

end;



class function TInterfaceFactory.Get(aInterface: PTypeInfo): TInterfaceFactory;

var i: integer;

    F: ^TInterfaceFactory;

begin

  if (aInterface=nil) or (aInterface^.Kind<>tkInterface) then

    raise EInterfaceFactoryException.CreateUTF8('%.Get(nil)',[self]);

  EnterInterfaceFactoryCache;

  try

    F := @InterfaceFactoryCache.List[0];

    for i := 1 to InterfaceFactoryCache.Count do

       if F^.fInterfaceTypeInfo=aInterface then begin

        result := F^;

        exit; // retrieved from cache

      end else

        inc(F);

    // not existing -> create new instance from RTTI

    {$ifdef HASINTERFACERTTI}

    result := TInterfaceFactoryRTTI.Create(aInterface);

    InterfaceFactoryCache.Add(result);

    {$else}

    result := nil; // make compiler happy

    raise EInterfaceFactoryException.CreateUTF8('No RTTI available for I%: please '+

      'define the methods using a TInterfaceFactoryGenerated wrapper',[aInterface^.Name]);

    {$endif}

  finally

    InterfaceFactoryCache.Safe.UnLock;

  end;

end;



class procedure TInterfaceFactory.RegisterInterfaces(const aInterfaces: array of PTypeInfo);

{$ifdef HASINTERFACERTTI}

var i: integer;

begin

  for i := 0 to high(aInterfaces) do

    Get(aInterfaces[i]);

end;

{$else}

begin // in fact, TInterfaceFactoryGenerated.RegisterInterface() should do it

end;

{$endif}



class function TInterfaceFactory.Get(const aGUID: TGUID): TInterfaceFactory;

type TGUID32 = packed record a,b,c,d: integer; end; // brute force optimization

     PGUID32 = ^TGUID32;

var i,ga: integer;

    F: ^TInterfaceFactory;

    GUID32: TGUID32 absolute aGUID;

begin

  if InterfaceFactoryCache<>nil then begin

    InterfaceFactoryCache.Safe.Lock;

    F := @InterfaceFactoryCache.List[0];

    ga := GUID32.a;

    for i := 1 to InterfaceFactoryCache.Count do

    with PGUID32(@F^.fInterfaceIID)^ do

    if (a=ga) and (b=GUID32.b) and (c=GUID32.c) and (d=GUID32.d) then begin

      result := F^;

      InterfaceFactoryCache.Safe.UnLock;

      exit;

    end else

      inc(F);

    InterfaceFactoryCache.Safe.UnLock;

  end;

  result := nil;

end;



class procedure TInterfaceFactory.AddToObjArray(var Obj: TInterfaceFactoryObjArray;

  const aGUIDs: array of TGUID);

var i: integer;

    fac: TInterfaceFactory;

begin

  for i := 0 to high(aGUIDs) do begin

    fac := Get(aGUIDs[i]);

    if fac<>nil then

      ObjArrayAddOnce(Obj,fac);

  end;

end;



class function TInterfaceFactory.GUID2TypeInfo(

  const aGUIDs: array of TGUID): PTypeInfoDynArray;

var i: integer;

begin

  SetLength(result,length(aGUIDs));

  for i := 0 to high(aGUIDs) do

    result[i] := GUID2TypeInfo(aGUIDs[i]);

end;



class function TInterfaceFactory.GUID2TypeInfo(const aGUID: TGUID): PTypeInfo;

var fact: TInterfaceFactory;

begin

  fact := Get(aGUID);

  if fact=nil then

    raise EServiceException.CreateUTF8(

      '%.GUID2TypeInfo(%): Interface not registered - use %.RegisterInterfaces()',

      [self,GUIDToShort(aGUID),self]);

  result := fact.fInterfaceTypeInfo;

end;



class function TInterfaceFactory.Get(const aInterfaceName: RawUTF8): TInterfaceFactory;

var L,i: integer;

begin

  L := length(aInterfaceName);

  if (InterfaceFactoryCache<>nil) and (L<>0) then

    for i := 0 to InterfaceFactoryCache.Count-1 do begin

      result := InterfaceFactoryCache.List[i];

      if IdemPropName(result.fInterfaceTypeInfo^.Name,pointer(aInterfaceName),L) then

        exit; // retrieved from cache

    end;

  result := nil;

end;



class function TInterfaceFactory.GetUsedInterfaces: TObjectList;

begin

  result := InterfaceFactoryCache;

end;



constructor TInterfaceFactory.Create(aInterface: PTypeInfo);

var m,a,reg: integer;

    WR: TTextWriter;

    C: TClass;

    ErrorMsg: RawUTF8;

    {$ifdef HAS_FPREG}

    ValueIsInFPR:boolean;

    {$endif}

    {$ifdef CPUX86}

    offs: integer;

    {$else}

    {$ifdef Linux} // not used for Win64

    fpreg: integer;

    {$endif}

    {$endif}

label error;

begin

  if aInterface=nil then

    raise EInterfaceFactoryException.CreateUTF8('%.Create(nil)',[self]);

  if aInterface^.Kind<>tkInterface then

    raise EInterfaceFactoryException.CreateUTF8(

      '%.Create(%): % is not an interface',[self,aInterface^.Name,aInterface^.Name]);

  {$ifndef NOVARIANTS}

  fDocVariantOptions := JSON_OPTIONS_FAST;

  {$endif}

  {$ifdef CPUAARCH64}

  fDetectX0ResultMagic := $AAAAAAAA; // alf: see comment above

  {$endif}

  fInterfaceTypeInfo := aInterface;

  fInterfaceIID := aInterface^.InterfaceGUID^;

  if IsNullGUID(fInterfaceIID) then

    raise EInterfaceFactoryException.CreateUTF8(

      '%.Create: % has no GUID',[self,aInterface^.Name]);

  fInterfaceName := ToUTF8(fInterfaceTypeInfo^.Name);

  // retrieve all interface methods (recursively including ancestors)

  fMethod.InitSpecific(TypeInfo(TServiceMethodDynArray),fMethods,djRawUTF8,

    @fMethodsCount,true);

  AddMethodsFromTypeInfo(aInterface); // from RTTI or generated code

  if fMethodsCount=0 then

    raise EInterfaceFactoryException.CreateUTF8(

      '%.Create(%): interface has no RTTI',[self,fInterfaceName]);

  fMethodIndexCurrentFrameCallback := -1;

  fMethodIndexCallbackReleased := -1;

  SetLength(fMethods,fMethodsCount);

  // compute additional information for each method

  for m := 0 to fMethodsCount-1 do

  with fMethods[m] do begin

    InterfaceDotMethodName := fInterfaceName+'.'+URI;

    if InterfaceDotMethodName[1] in ['I','i'] then

      delete(InterfaceDotMethodName,1,1); // as in TServiceFactory.Create

    IsInherited := HierarchyLevel<>fAddMethodsLevel;

    ExecutionMethodIndex := m+RESERVED_VTABLE_SLOTS;

    ArgsInFirst := -1;

    ArgsInLast := -2;

    ArgsOutFirst := -1;

    ArgsOutLast := -2;

    ArgsNotResultLast := -2;

    ArgsOutNotResultLast := -2;

    ArgsResultIndex := -1;

    ArgsManagedFirst := -1;

    ArgsManagedLast := -2;

    Args[0].ValueType := smvSelf;

    for a := 1 to high(Args) do

    with Args[a] do begin

      ValueType := TypeInfoToMethodValueType(ArgTypeInfo);

      case ValueType of

      smvNone: begin

        case ArgTypeInfo^.Kind of

        tkClass: begin

          C := ArgTypeInfo^.ClassType^.ClassType;

          if C.InheritsFrom(TList) then

            ErrorMsg := ' - use TObjectList instead' else

          {$ifndef LVCL}

          if (C.InheritsFrom(TCollection) and not C.InheritsFrom(TInterfacedCollection)) and

            (JSONSerializerRegisteredCollection.Find(TCollectionClass(C))=nil) then

            ErrorMsg := ' - inherit from TInterfacedCollection '+

              'or use TJSONSerializer.RegisterCollectionForJSON()' else

          {$endif}

            ErrorMsg := ' - use TJSONSerializer.RegisterCustomSerializer()';

        end;

        tkInteger: ErrorMsg := ' - use integer/cardinal instead';

        tkFloat:   ErrorMsg := ' - use double/currency instead';

        end;

error:  raise EInterfaceFactoryException.CreateUTF8(

          '%.Create: %.% "%" parameter has unexpected type %%',

          [self,aInterface^.Name,URI,ParamName^,ArgTypeInfo^.Name,ErrorMsg]);

      end;

      smvObject:

        if ValueDirection=smdResult then begin

          ErrorMsg := ' - class not allowed as function result: use a var/out parameter';

          goto error;

        end;

      smvInterface:

        if ValueDirection in [smdVar,smdOut,smdResult] then begin

          ErrorMsg := ' - interface not allowed as output: use a const parameter';

          goto error;

        end;

      end;

      if ValueDirection=smdResult then

        ArgsResultIndex := a else begin

        ArgsNotResultLast := a;

        if ValueDirection<>smdOut then begin

          inc(ArgsInputValuesCount);

          if ArgsInFirst<0 then

            ArgsInFirst := a;

          ArgsInLast := a;

        end;

        if ValueDirection<>smdConst then

          ArgsOutNotResultLast := a;

      end;

      if ValueDirection<>smdConst then begin

        if ArgsOutFirst<0 then

          ArgsOutFirst := a;

        ArgsOutLast := a;

        inc(ArgsOutputValuesCount);

      end;

      if ValueType in [smvObject,smvDynArray,smvRecord,smvInterface

          {$ifndef NOVARIANTS},smvVariant{$endif}] then begin

        if ArgsManagedFirst<0 then

          ArgsManagedFirst := a;

        ArgsManagedLast := a;

      end;

    end;

    if ArgsOutputValuesCount=0 then // plain procedure with no out param

      case ArgsInputValuesCount of

      1: if Args[1].ValueType=smvBoolean then

           if IdemPropNameU(URI,'CurrentFrame') then

            fMethodIndexCurrentFrameCallback := m;

      2: if (Args[1].ValueType=smvInterface) and

            (Args[1].ArgTypeInfo=TypeInfo(IInvokable)) and

            (Args[2].ValueType=smvRawUTF8) and

             IdemPropNameU(URI,'CallbackReleased') then

            fMethodIndexCallbackReleased := m;

      end;

  end;

  // compute asm low-level layout of the parameters for each method

  for m := 0 to fMethodsCount-1 do

  with fMethods[m] do begin

    // prepare stack and register layout

    reg := PARAMREG_FIRST;

    {$ifndef CPUX86}

    {$ifdef Linux}

    fpreg := FPREG_FIRST;

    {$endif Linux}

    {$endif CPUX86}

    for a := 0 to high(Args) do

    with Args[a] do begin

      RegisterIdent := 0;

      {$ifdef HAS_FPREG}

      FPRegisterIdent := 0;

      ValueIsInFPR := false;

      {$endif}

      ValueVar := CONST_ARGS_TO_VAR[ValueType];

      IndexVar := ArgsUsedCount[ValueVar];

      inc(ArgsUsedCount[ValueVar]);

      include(ArgsUsed,ValueType);

      if (ValueType in [smvRecord{$ifndef NOVARIANTS},smvVariant{$endif}

          {$ifdef FPC},smvDynArray{$endif}]) or

         (ValueDirection in [smdVar,smdOut]) or

         ((ValueDirection=smdResult) and (ValueType in CONST_ARGS_RESULT_BY_REF)) then

        Include(ValueKindAsm,vPassedByReference);

      case ValueType of

      smvRawUTF8..smvWideString:

        Include(ValueKindAsm,vIsString);

      smvDynArray:

        if ObjArraySerializers.Find(ArgTypeInfo)<>nil then

          Include(ValueKindAsm,vIsObjArray);

      {$ifdef HAS_FPREG}

      smvDouble,smvDateTime:

        ValueIsInFPR := not (vPassedByReference in ValueKindAsm);

      {$endif}

      end;

      case ValueType of

        smvBoolean:

          SizeInStorage := 1;

        smvInteger, smvCardinal:

          SizeInStorage := 4;

        smvInt64, smvDouble, smvDateTime, smvCurrency:

          SizeInStorage := 8;

        smvEnum:

          SizeInStorage := ArgTypeInfo^.EnumBaseType^.SizeInStorageAsEnum;

        smvSet: begin

          SizeInStorage := ArgTypeInfo^.SetEnumType^.SizeInStorageAsSet;

          if SizeInStorage=0 then

            raise EInterfaceFactoryException.CreateUTF8(

              '%.Create: % set too big in %.% method % parameter',

              [self,ArgTypeName^,fInterfaceTypeInfo^.Name,URI,ParamName^]);

        end;

        smvRecord:

          if ArgTypeInfo^.RecordType^.Size<=PTRSIZ then

            raise EInterfaceFactoryException.CreateUTF8(

              '%.Create: % record too small in %.% method % parameter',

              [self,ArgTypeName^,fInterfaceTypeInfo^.Name,URI,ParamName^]) else

            SizeInStorage := PTRSIZ; // handle only records when passed by ref

        else

          SizeInStorage := PTRSIZ;

      end;

      if ValueDirection=smdResult then begin

        if not(ValueType in CONST_ARGS_RESULT_BY_REF) then

          continue; // ordinal/real/class results are returned in CPU/FPU registers

        {$ifndef CPUX86}

        InStackOffset := STACKOFFSET_NONE;

        RegisterIdent := PARAMREG_RESULT;

        continue;

        {$endif CPUX86}

        // CPUX86 would add an additional by-ref parameter

      end;

      {$ifdef CPU32}

      if ValueDirection=smdConst then

        SizeInStack := CONST_ARGS_IN_STACK_SIZE[ValueType] else

      {$endif}

        SizeInStack := PTRSIZ; // always aligned to 8 bytes boundaries for 64-bit

      if{$ifndef CPUARM}

        // on ARM, ordinals>PTRSIZ can also be placed in the normal registers !!

        (SizeInStack<>PTRSIZ) or

        {$endif CPUARM}

        {$ifdef CPUX86}

        (reg>PARAMREG_LAST) // Win32, Linux x86

        {$else}

        {$ifdef Linux}  // Linux x64, arm, aarch64

        ((ValueIsInFPR) and (fpreg>FPREG_LAST)) or

        ((not ValueIsInFPR) and (reg>PARAMREG_LAST))

        {$else}

        (reg>PARAMREG_LAST) // Win64

        {$endif Linux}

        {$endif CPUX86}

        // alf: TODO: fix smvDynArray as expected by fpc\compiler\i386\cpupara.pas

        {$ifdef FPC}or ((ValueType in [smvRecord,smvDynArray]) and

          not (vPassedByReference in ValueKindAsm)){$endif} then begin

        // this parameter would go on the stack

        InStackOffset := ArgsSizeInStack;

        inc(ArgsSizeInStack,SizeInStack);

      end else begin

        // this parameter would go in a register

        InStackOffset := STACKOFFSET_NONE;

        {$ifndef CPUX86}

        if (ArgsResultIndex>=0) and (reg=PARAMREG_RESULT) and

           (Args[ArgsResultIndex].ValueType in CONST_ARGS_RESULT_BY_REF) then begin

          inc(reg); // this register is reserved for method result pointer

        end;

       {$endif}

        {$ifdef HAS_FPREG}

        if ValueIsInFPR then begin

          // put in a floating-point register

          {$ifdef Linux}

          FPRegisterIdent := fpreg;

          inc(fpreg);

          {$else}

          FPRegisterIdent := reg; // Win64 ABI: reg and fpreg do overlap

          inc(reg);

          {$endif Linux}

        end

        else

        {$endif} begin

          // put in an integer register

          {$ifdef CPUARM}

          // on 32-bit ARM, ordinals>PTRSIZ are also placed in normal registers

          if (SizeInStack>PTRSIZ) and ((reg and 1)=0) then

            inc(reg); // must be aligned on even boundary

          // check if we have still enough registers, after previous increments

          if ((PARAMREG_LAST-reg+1)*PTRSIZ)<SizeInStack then begin

            // no space, put on stack

            InStackOffset := ArgsSizeInStack;

            inc(ArgsSizeInStack,SizeInStack);

            // all other parameters following the current one, must also be placed on stack

            reg := PARAMREG_LAST+1;

            continue;

          end;

          RegisterIdent := reg;

          if SizeInStack>PTRSIZ then

            inc(reg,SizeInStack shr PTRSHR) else

            inc(reg);

          {$else}

          RegisterIdent := reg;

          inc(reg);

          {$endif CPUARM}

        end;

      end;

    end;

    if ArgsSizeInStack>MAX_EXECSTACK then

      raise EInterfaceFactoryException.CreateUTF8(

        '%.Create: Stack size % > % for %.% method',

        [self,ArgsSizeInStack,MAX_EXECSTACK,fInterfaceTypeInfo^.Name,URI]);

    {$ifdef CPUX86}

    // pascal/register convention are passed left-to-right -> reverse order

    offs := ArgsSizeInStack;

    for a := 0 to high(Args) do

    with Args[a] do

      if InStackOffset>=0 then begin

        dec(offs,SizeInStack);

        InStackOffset := offs;

      end;

    //assert(offs=0);

    {$endif CPUX86}

  end;

  WR := TJSONSerializer.CreateOwnedStream;

  try

    // compute the default results JSON array for all methods

    for m := 0 to fMethodsCount-1 do

    with fMethods[m] do begin

      WR.CancelAll;

      WR.Add('[');

      for a := ArgsOutFirst to ArgsOutLast do

        with Args[a] do

        if ValueDirection in [smdVar,smdOut,smdResult] then

          AddDefaultJSON(WR);

      WR.CancelLastComma;

      WR.Add(']');

      WR.SetText(DefaultResult);

    end;

    // compute the service contract as a JSON array

    WR.CancelAll;

    WR.Add('[');

    for m := 0 to fMethodsCount-1 do

    with fMethods[m] do begin

      WR.Add('{"method":"%","arguments":[',[URI]);

      for a := 0 to High(Args) do

        Args[a].SerializeToContract(WR);

      WR.CancelLastComma;

      WR.AddShort(']},');

    end;

    WR.CancelLastComma;

    WR.Add(']');

    WR.SetText(fContract);

  finally

    WR.Free;

  end;

end;



function TInterfaceFactory.FindMethodIndex(const aMethodName: RawUTF8): integer;

begin

  if (self=nil) or (aMethodName='') then

    result := -1 else

  if fMethodsCount<10 then begin

    for result := 0 to fMethodsCount-1 do

      if IdemPropNameU(fMethods[result].URI,aMethodName) then

        exit;

    result := -1;

  end else

    result := fMethod.FindHashed(aMethodName);

  if (result<0) and (aMethodName[1]<>'_') then

    result := FindMethodIndex('_'+aMethodName);

end;



function TInterfaceFactory.FindFullMethodIndex(const aFullMethodName: RawUTF8;

  alsoSearchExactMethodName: boolean): integer;

begin

  if PosEx('.',aFullMethodName)>=0 then

    for result := 0 to fMethodsCount-1 do

      if IdemPropNameU(fMethods[result].InterfaceDotMethodName,aFullMethodName) then

        exit;

  if alsoSearchExactMethodName then

    result := FindMethodIndex(aFullMethodName) else

    result := -1;

end;



function TInterfaceFactory.CheckMethodIndex(const aMethodName: RawUTF8): integer;

begin

  if self=nil then

    raise EInterfaceFactoryException.Create('TInterfaceFactory(nil).CheckMethodIndex');

  result := FindMethodIndex(aMethodName);

  if result<0 then

    raise EInterfaceFactoryException.CreateUTF8(

      '%.CheckMethodIndex: %.% not found',[self,fInterfaceTypeInfo^.Name,aMethodName]);

end;



function TInterfaceFactory.CheckMethodIndex(aMethodName: PUTF8Char): integer;

begin

  result := CheckMethodIndex(RawUTF8(aMethodName));

end;



procedure TInterfaceFactory.CheckMethodIndexes(const aMethodName: array of RawUTF8;

  aSetAllIfNone: boolean; out aBits: TInterfaceFactoryMethodBits);

var i: integer;

begin

  if aSetAllIfNone and (high(aMethodName)<0) then begin

    FillCharFast(aBits,sizeof(aBits),255);

    exit;

  end;

  FillCharFast(aBits,sizeof(aBits),0);

  for i := 0 to high(aMethodName) do

    include(aBits,CheckMethodIndex(aMethodName[i]));

end;



function TInterfaceFactory.GetMethodName(MethodIndex: integer): RawUTF8;

begin

  if (MethodIndex<0) or (self=nil) then

    result := '' else

  if MethodIndex<SERVICE_PSEUDO_METHOD_COUNT then

    result := SERVICE_PSEUDO_METHOD[TServiceInternalMethod(MethodIndex)] else begin

    dec(MethodIndex,SERVICE_PSEUDO_METHOD_COUNT);

    if cardinal(MethodIndex)<fMethodsCount then

      result := fMethods[MethodIndex].URI else

      result := '';

  end;

end;



function TInterfaceFactory.GetFullMethodName(aMethodIndex: integer): RawUTF8;

begin

  if self=nil then

    result := '' else begin

    result := GetMethodName(aMethodIndex);

    if result = '' then

      result := fInterfaceName else

      result := fInterfaceName+'.'+result;

  end;

end;



{ low-level ASM for TInterfaceFactory.GetMethodsVirtualTable

  - all ARM, AARCH64 and Linux64 code below was provided by ALF! Thanks! :)  }

{$ifdef FPC}

{$ifdef CPUARM}

procedure TInterfacedObjectFake.ArmFakeStub;

var smetndx: pointer;

    sd7, sd6, sd5, sd4, sd3, sd2, sd1, sd0: double;

    sr3,sr2,sr1,sr0: pointer;

asm

  // get method index

  str  v1,smetndx

  // store registers

  vstr d0,sd0

  vstr d1,sd1

  vstr d2,sd2

  vstr d3,sd3

  vstr d4,sd4

  vstr d5,sd5

  vstr d6,sd6

  vstr d7,sd7

  str r0,sr0

  str r1,sr1

  str r2,sr2

  str r3,sr3

  // TFakeCallStack address as 2nd parameter

  // there is no lea equivalent instruction for ARM (AFAIK), so this is calculated by hand (by looking at assembler)

  sub r1, fp, #128

  // branch to the FakeCall function

  bl FakeCall

  // FakeCall should set Int64 result in method result, and float in aCall.FPRegs["sd0"]

  vstr d0,sd0

end;

{$endif}

{$ifdef CPUAARCH64}

procedure TInterfacedObjectFake.AArch64FakeStub;

var sx0, sx1, sx2, sx3, sx4, sx5, sx6, sx7: pointer;

    sd0, sd1, sd2, sd3, sd4, sd5, sd6, sd7: double;

    smetndx:pointer;

asm

  // get method index

  str  x9,smetndx

  // store registers

  str d0,sd0

  str d1,sd1

  str d2,sd2

  str d3,sd3

  str d4,sd4

  str d5,sd5

  str d6,sd6

  str d7,sd7

  str x0,sx0

  str x1,sx1

  str x2,sx2

  str x3,sx3

  str x4,sx4

  str x5,sx5

  str x6,sx6

  str x7,sx7

  // TFakeCallStack address as 2nd parameter

  // sx0 is at the stack pointer !

  // local variables are stored in reverse on the stack

  add x1, sp, #0

  // branch to the FakeCall function

  bl FakeCall

  // FakeCall should set Int64 result in method result, and float in aCall.FPRegs["sd0"]

  str d0,sd0

end;

{$endif}

{$endif}



{$ifdef CPUX64}

// note: x64 code below uses movlpd for reg,reg/mem,reg and movsd for reg,mem

procedure x64FakeStub;

var

  smetndx,

  {$ifdef Linux}

  sxmm7, sxmm6, sxmm5, sxmm4,

  {$endif}

  sxmm3, sxmm2, sxmm1, sxmm0: pointer;

  {$ifdef Linux}

  sr9, sr8, srcx, srdx, srsi, srdi: pointer;

  {$endif}

asm // mov ax,{MethodIndex}; jmp x64FakeStub

  {$ifndef FPC}

  // FakeCall(self: TInterfacedObjectFake; var aCall: TFakeCallStack): Int64

  // So, make space for two variables (+shadow space)

  // adds $50 to stack, so rcx .. at rpb+$10+$50 = rpb+$60

  .params 2

  {$endif}

  and rax,$ffff

  movlpd sxmm0,xmm0

  movlpd sxmm1,xmm1

  movlpd sxmm2,xmm2

  movlpd sxmm3,xmm3

  {$ifdef LINUX}

  movlpd sxmm4,xmm4

  movlpd sxmm5,xmm5

  movlpd sxmm6,xmm6

  movlpd sxmm7,xmm7

  mov sr9,r9

  mov sr8,r8

  mov srcx,rcx

  mov srdx,rdx

  mov srsi,rsi

  mov srdi,rdi

  {$endif LINUX}

  mov smetndx,rax

  {$ifdef LINUX}

  lea rsi, srdi // TFakeCallStack address as 2nd parameter

  {$else}

  {$ifndef FPC}

  mov [rbp+$60],rcx

  mov [rbp+$68],rdx

  mov [rbp+$70],r8

  mov [rbp+$78],r9

  {$else}

  mov [rbp+$10],rcx

  mov [rbp+$18],rdx

  mov [rbp+$20],r8

  mov [rbp+$28],r9

  {$endif FPC}

  lea rdx, sxmm0 // TFakeCallStack address as 2nd parameter

  {$endif LINUX}

  call TInterfacedObjectFake.FakeCall

  // FakeCall should set Int64 result in method result, and float in aCall.FPRegs["XMM0"]

  movsd xmm0,sxmm0

end;

{$endif CPUX64}



const

  STUB_SIZE = 65536; // 16*4 KB (4 KB = memory granularity)



{$ifdef FPC} // alf: multi platforms support

{$ifdef MSWINDOWS}

function AddrAllocMem(const Size, flProtect: DWORD): Pointer;

type

  PMEMORY_BASIC_INFORMATION64 = ^_MEMORY_BASIC_INFORMATION64;

  _MEMORY_BASIC_INFORMATION64 = record

     BaseAddress: ULONGLONG;

     AllocationBase: ULONGLONG;

     AllocationProtect: DWORD;

     __alignment1: DWORD;

     RegionSize: ULONGLONG;

     State: DWORD;

     Protect: DWORD;

     Type_: DWORD;

     __alignment2: DWORD;

  end;

var

  mbiold: TMemoryBasicInformation;

  {$ifdef CPUX64}

  mbi: _MEMORY_BASIC_INFORMATION64 absolute mbiold;

  {$else}

  mbi: TMemoryBasicInformation;

  {$endif}

  Info: TSystemInfo;

  P, Q: UInt64;

  PP: Pointer;

  error: DWORD;

  Addr: UInt64;

begin

  {$ifdef CPUX64}

  Addr := UInt64(@x64FakeStub);

  {$else}

  Addr := 0;

  {$endif}

  result := nil;

  if Addr = 0 then begin

    result := VirtualAlloc(nil,Size,MEM_COMMIT,flProtect);

    exit;

  end;

  P := UInt64(Addr);

  Q := UInt64(Addr);

  GetSystemInfo(Info);

  // Interval = [2GB ..P.. 2GB] = 4GB

  if Int64(P - (High(DWORD) div 2)) < 0 then

    P := 1 else

    P := UInt64(P - (High(DWORD) div 2)); // -2GB .

  if UInt64(Q + (High(DWORD) div 2)) > High( {$IFDEF CPUX64}UInt64{$ELSE}UInt{$ENDIF} ) then

    Q := High( {$IFDEF CPUX64}UInt64{$ELSE}UInt{$ENDIF} ) else

    Q := Q + (High(DWORD) div 2); // + 2GB

  while P < Q do begin

    PP := Pointer(P);

    if VirtualQuery(PP, mbiold, sizeof(_MEMORY_BASIC_INFORMATION64)) = 0 then

      break;

    if (mbi.State and MEM_FREE = MEM_FREE) and (UInt64(mbi.RegionSize) > Size) then

      // this memory block is usable

      if (UInt64(mbi.RegionSize) >= Info.dwAllocationGranularity) then begin

        { The RegionSize must be greater than the dwAllocationGranularity  }

        { The address (PP) must be multiple of the allocation granularity (dwAllocationGranularity) . }

        PP := Pointer(Info.dwAllocationGranularity *

          (UInt64(PP) div Info.dwAllocationGranularity) +

          Info.dwAllocationGranularity);

        // if PP is multiple of dwAllocationGranularity then alloc memory

        // if PP is not multiple of dwAllocationGranularity, VirtualAlloc will fail

        if UInt64(PP) mod Info.dwAllocationGranularity=0 then

          result := VirtualAlloc(PP, Size, MEM_COMMIT or MEM_RESERVE, flProtect);

        if result <> nil then

          exit;

      end;

    P := UInt64(mbi.BaseAddress) + UInt64(mbi.RegionSize); // Next region

  end;

end;

{$else}

function AddrAllocMem(const Size, flProtect: DWORD): Pointer;

var P, Q: UInt64;

    PP: Pointer;

    Addr: UInt64;

begin

  Addr := 0;

  {$ifdef CPUX64}

  Addr := UInt64(@x64FakeStub);

  {$endif}

  {$ifdef CPUARM}

  Addr := UInt64(@TInterfacedObjectFake.ArmFakeStub);

  {$endif}

  {$ifdef CPUAARCH64}

  Addr := UInt64(@TInterfacedObjectFake.AArch64FakeStub);

  {$endif}

  Result := nil;

  if Addr = 0 then begin

    Result := fpmmap(nil,STUB_SIZE,flProtect,MAP_PRIVATE OR MAP_ANONYMOUS,-1,0);

    Exit;

  end;

  P := UInt64(Addr);

  Q := UInt64(Addr);

  { Interval = [2GB ..P.. 2GB] = 4GB }

  if Int64(P - (High(DWORD) div 2)) < 0 then

    P := 1 else

    P := UInt64(P - (High(DWORD) div 2)); // -2GB .

  if UInt64(Q + (High(DWORD) div 2)) > High( {$IFDEF CPU64}UInt64{$ELSE}DWORD{$ENDIF} ) then

    Q := High( {$IFDEF CPU64}UInt64{$ELSE}DWORD{$ENDIF} ) else

    Q := Q + (High(DWORD) div 2); // + 2GB

  P := P AND $FFFFFFFFFFFF0000; //AND QWORD(-(STUB_SIZE-1));

  Q := Q AND $FFFFFFFFFFFF0000;

  while P < Q do begin

    P := P + (STUB_SIZE);

    PP := Pointer(P);

    Result := fpmmap(PP,STUB_SIZE,flProtect,MAP_PRIVATE or MAP_ANONYMOUS,-1,0);

    if (Result <> MAP_FAILED) then begin

      {$ifdef CPUARM}

      // are we close enough for a relative jump (24 bit signed)?

      if ((PtrUInt(Result)-Addr)<DWORD($7FFFFF)) or (Addr-(PtrUInt(Result))<DWORD($7FFFFF)) then 

        exit else 

        fpmunmap(Result,STUB_SIZE);

      {$else}

      // are we close enough for a relative jump (32 bit signed)?

      if ((PtrUInt(Result)-Addr)<Int64($7FFFFFFF)) or (Addr-(PtrUInt(Result))<Int64($7FFFFFFF)) then 

        exit else 

        fpmunmap(Result,STUB_SIZE);

      {$endif}

    end;

  end;

end;

{$endif}

{$endif}



type

  // internal memory buffer created with PAGE_EXECUTE_READWRITE flags

  TFakeStubBuffer = class

  protected

    fStub: PByteArray;

    fStubUsed: cardinal;

  public

    constructor Create;

    destructor Destroy; override;

    // call shall be protected by InterfaceFactoryCache critical section

    class function Reserve(size: Cardinal): pointer;

  end;



var

  CurrentFakeStubBuffer: TFakeStubBuffer;



constructor TFakeStubBuffer.Create;

begin

  {$ifdef MSWINDOWS}

  {$ifdef FPC}

  // alf: this is necessary, because a plain call to VirtualAlloc with FPC

  // reserves a piece of memory too far away for a relative jump (on x64)

  fStub := AddrAllocMem(STUB_SIZE,PAGE_EXECUTE_READWRITE);

  {$else FPC}

  fStub := VirtualAlloc(nil,STUB_SIZE,MEM_COMMIT,PAGE_EXECUTE_READWRITE);

  {$endif FPC}

  {$else MSWINDOWS}

  {$ifdef KYLIX3}

  fStub := mmap(nil,STUB_SIZE,PROT_READ OR PROT_WRITE OR PROT_EXEC,MAP_PRIVATE OR MAP_ANONYMOUS,-1,0);

  {$else}

  fStub := AddrAllocMem(STUB_SIZE,PROT_READ OR PROT_WRITE OR PROT_EXEC);

  {$endif}

  {$endif MSWINDOWS}

end;



destructor TFakeStubBuffer.Destroy;

begin

  {$ifdef MSWINDOWS}

  VirtualFree(fStub,0,MEM_RELEASE);

  {$else}

  {$ifdef KYLIX3}

  munmap(fStub,STUB_SIZE);

  {$else}

  fpmunmap(fStub,STUB_SIZE);

  {$endif}

  {$endif}

  inherited;

end;



class function TFakeStubBuffer.Reserve(size: Cardinal): pointer;

begin

  if size>STUB_SIZE then

    raise EServiceException.CreateUTF8('%.Reserve(size=%>%)',[self,size,STUB_SIZE]);

  if CurrentFakeStubBuffer=nil then

    GarbageCollectorFreeAndNil(CurrentFakeStubBuffer,TFakeStubBuffer.Create) else

  if CurrentFakeStubBuffer.fStubUsed+size>STUB_SIZE then begin

    GarbageCollector.Add(CurrentFakeStubBuffer);

    CurrentFakeStubBuffer := TFakeStubBuffer.Create;

  end;

  with CurrentFakeStubBuffer do begin

    result := @fStub[fStubUsed];

    inc(fStubUsed,size);

  end;

end;



function TInterfaceFactory.GetMethodsVirtualTable: pointer;

var i, tmp: cardinal;

    P: PCardinal;

begin

  if fFakeVTable=nil then begin

    InterfaceFactoryCache.Safe.Lock;

    try

      if fFakeVTable=nil then begin // avoid race condition error

        SetLength(fFakeVTable,fMethodsCount+RESERVED_VTABLE_SLOTS);

        fFakeVTable[0] := @TInterfacedObjectFake.FakeQueryInterface;

        fFakeVTable[1] := @TInterfacedObjectFake.Fake_AddRef;

        fFakeVTable[2] := @TInterfacedObjectFake.Fake_Release;

        if fMethodsCount=0 then begin

          result := pointer(fFakeVTable);

          exit;

        end;

        tmp := {$ifdef CPUX86}fMethodsCount*24{$endif}

             {$ifdef CPUX64}fMethodsCount*12{$endif}

             {$ifdef CPUARM}fMethodsCount*12{$endif}

             {$ifdef CPUAARCH64}($120 shr 2)+fMethodsCount*28{$endif};

        fFakeStub := TFakeStubBuffer.Reserve(tmp);

        PtrUInt(fFakeStub) := PtrUInt(fFakeStub){$ifdef CPUAARCH64} + $120{$endif};

        P := pointer(fFakeStub);

        for i := 0 to fMethodsCount-1 do begin

          fFakeVTable[i+RESERVED_VTABLE_SLOTS] := P;

          {$ifdef CPUX64}

          P^ := $b866+(i shl 16); inc(P);  // mov (r)ax,{MethodIndex}

          PByte(P)^ := $e9; inc(PByte(P)); // jmp x64FakeStub

          P^ := PtrUInt(@x64FakeStub)-PtrUInt(P)-4; inc(P);

          P^ := $909090;

          inc(PByte(P),3);

          {$endif CPUX64}

          {$ifdef CPUARM}

          P^ := ($e3a040 shl 8)+i;  inc(P); // mov r4 (v1),{MethodIndex} : store method index in register

          tmp := ((PtrUInt(@TInterfacedObjectFake.ArmFakeStub)-PtrUInt(P)) shr 2)-2;

          P^ := ($ea shl 24) + (tmp and $00FFFFFF); // branch ArmFakeStub (24bit relative, word aligned)

          inc(P);

          P^ := $e320f000; inc(P);

          {$endif CPUARM}

          {$ifdef CPUAARCH64}

          // store method index in register x9

          // $09 = r9 ... loop to $1F -> number shifted * $20

          P^ := ($d280 shl 16)+(i shl 5)+$09; inc(P);  // mov x9 ,{MethodIndex}

          // we are using a register branch here

          // fill register x10 with address

          tmp := (PtrUInt(@TInterfacedObjectFake.AArch64FakeStub) shr 0) AND $FFFF;

          P^ := ($d280 shl 16)+(tmp shl 5)+$0A; inc(P);

          tmp := (PtrUInt(@TInterfacedObjectFake.AArch64FakeStub) shr 16) AND $FFFF;

          P^ := ($f2a0 shl 16)+(tmp shl 5)+$0A; inc(P);

          tmp := (PtrUInt(@TInterfacedObjectFake.AArch64FakeStub) shr 32) AND $FFFF;

          P^ := ($f2c0 shl 16)+(tmp shl 5)+$0A; inc(P);

          tmp := (PtrUInt(@TInterfacedObjectFake.AArch64FakeStub) shr 48) AND $FFFF;

          P^ := ($f2e0 shl 16)+(tmp shl 5)+$0A; inc(P);

          // branch to address in x10 register

          P^ := ($d61f0140); inc(P);

          P^ := $d503201f; inc(P);

          {$endif CPUAARCH64}

          {$ifdef CPUX86}

          P^ := $68ec8b55; inc(P);                 // push ebp; mov ebp,esp

          P^ := i; inc(P);                         // push {MethodIndex}

          P^ := $e2895251; inc(P);                 // push ecx; push edx; mov edx,esp

          PByte(P)^ := $e8; inc(PByte(P));         // call FakeCall

          P^ := PtrUInt(@TInterfacedObjectFake.FakeCall)-PtrUInt(P)-4; inc(P);

          P^ := $c25dec89; inc(P);                 // mov esp,ebp; pop ebp

          P^ := fMethods[i].ArgsSizeInStack or $900000;  // ret {StackSize}; nop

          inc(PByte(P),3);

          {$endif CPUX86}

        end;

      end;

    finally

      InterfaceFactoryCache.Safe.UnLock;

    end;

  end;

  result := pointer(fFakeVTable);

end;





{$ifdef HASINTERFACERTTI} // see http://bugs.freepascal.org/view.php?id=26774



{ TInterfaceFactoryRTTI }



procedure TInterfaceFactoryRTTI.AddMethodsFromTypeInfo(aInterface: PTypeInfo);

var P: Pointer;

    PB: PByte absolute P;

    PI: PInterfaceTypeData absolute P;

    {$ifdef FPC}

    PIR: PRawInterfaceTypeData absolute P;

    {$endif}

    PW: PWord absolute P;

    PS: PShortString absolute P;

    PME: ^TIntfMethodEntryTail absolute P;

    PF: ^TParamFlags absolute P;

    PP: ^PPTypeInfo absolute P;

    Ancestor: PTypeInfo;

    {$ifdef FPC}

    propCount: integer;

    aResultType: PTypeInfo;

    {$else}

    Kind: TMethodKind;

    {$endif}

    f: TParamFlags;

    m,a: integer;

    n: cardinal;

    aURI: RawUTF8;



  procedure RaiseError(const Format: RawUTF8; const Args: array of const);

  begin

    raise EInterfaceFactoryException.CreateUTF8(

      '%.AddMethodsFromTypeInfo(%.%) failed - %',

      [self,fInterfaceName,aURI,FormatUTF8(Format,Args)]);

  end;



begin

  // handle interface inheritance via recursive calls

  P := aInterface^.ClassType;

  if PI^.IntfParent<>nil then

    Ancestor := Deref(PI^.IntfParent) else

    Ancestor := nil;

  if Ancestor<>nil then begin

    AddMethodsFromTypeInfo(Ancestor);

    inc(fAddMethodsLevel);

  end;

  // retrieve methods for this interface level

  {$ifdef FPC}

  if PI^.IntfUnit='System' then

    exit;

  if aInterface^.Kind=tkInterface then

    P := AlignToPtr(@PI^.IntfUnit[ord(PI^.IntfUnit[0])+1]) else

    P := AlignToPtr(@PIR^.IIDStr[ord(PIR^.IIDStr[0])+1]);

  propCount := PSmallInt(P)^; // FPC add property information -> ignore now

  inc(P,sizeOf(SmallInt));

  P := AlignToPtr(P);

  for a := 0 to propCount-1 do

    P := AlignToPtr(@PPropInfo(P)^.Name[ord(PPropInfo(P)^.Name[0])+1]);

  {$else}

  P := AlignToPtr(@PI^.IntfUnit[ord(PI^.IntfUnit[0])+1]);

  {$endif}

  n := PW^; inc(PW);

  if (PW^=$ffff) or (n=0) then

    exit; // no RTTI or no method at this level of interface

  inc(PW);

  p := aligntoptr(p);

  for m := fMethodsCount to fMethodsCount+n-1 do begin

    // retrieve method name, and add to the methods list (with hashing)

    SetString(aURI,PAnsiChar(@PS^[1]),ord(PS^[0]));

    with PServiceMethod(fMethod.AddUniqueName(aURI,

      '%.% method: duplicated name for %',[fInterfaceTypeInfo^.Name,aURI,self]))^ do begin

      HierarchyLevel := fAddMethodsLevel;

      {$ifdef FPC} // FPC has its own RTTI layout only since late 3.x

      inc(PB,ord(PS^[0])+1);

      inc(PB); // skip Version field (always 3)

      {$ifdef CPUINTEL}

      if PCallingConvention(P)^<>ccRegister then

         RaiseError('method shall use register calling convention',[]);

      {$endif CPUINTEL}

      inc(PB,sizeOf(TCallingConvention));

      P := AlignToPtr(P);// new Alignment

      aResultType := DeRef(PP^);

      inc(PP);

      inc(PW); // skip StackSize

      n := PB^;

      inc(PB);

      P := AlignToPtr(P);// new Alignment

      if aResultType<>nil then  // we have a function

        SetLength(Args,n+1) else

        SetLength(Args,n);

      if length(Args)>MAX_METHOD_ARGS then

         RaiseError('method has too many parameters: %>%',[Length(Args),MAX_METHOD_ARGS]);

      if aResultType<>nil then

      with Args[n] do begin

        ParamName := @CONST_PSEUDO_RESULT_NAME;

        ValueDirection := smdResult;

        ArgTypeInfo := aResultType;

        if ArgTypeInfo=TypeInfo(Integer) then // under FPC integer->'longint'

          ArgTypeName := @CONST_INTEGER_NAME else

          ArgTypeName := @ArgTypeInfo^.Name;

      end;

      for a := 0 to n-1 do

      with Args[a],PVmtMethodParam(P)^ do begin

        f := mORMot.TParamFlags(Flags);

        if pfVar in f then

          ValueDirection := smdVar else

        if pfOut in f then

          ValueDirection := smdOut;

        ArgsNotResultLast := a;

        if ValueDirection<>smdConst then

          ArgsOutNotResultLast := a;

          ArgTypeInfo := mORMot.PTypeInfo(Deref(mORMot.PPTypeInfo(ParamType)));

        ArgTypeName := @ArgTypeInfo^.Name;

        if a>0 then

        case TypeInfoToMethodValueType(ArgTypeInfo) of

        smvRecord,smvDynArray:

          if f*[pfConst,pfVar,pfOut{$IFDEF FPC_HAS_CONSTREF},pfConstRef{$endif}]=[] then

             RaiseError('%: % parameter should be declared as const, var or out',

               [ParamName^,ArgTypeName^]);

        smvInterface:

           if not (pfConst in f) then

             RaiseError('%: % parameter should be declared as const',

               [ParamName^,ArgTypeName^]);

        end;

        if Name='$self' then

          ParamName := @CONST_PSEUDO_SELF_NAME else

          ParamName := @Name;

        P := AlignToPtr(@Name[ord(Name[0])+1]);

      end;

      {$else FPC} // Delphi code

      PS := AlignToPtr(@PS^[ord(PS^[0])+1]);

      Kind := PME^.Kind;

      if PME^.CC<>ccRegister then

        RaiseError('method shall use register calling convention',[]);

      // retrieve method call arguments from RTTI

      n := PME^.ParamCount;

      inc(PME);

      if Kind=mkFunction then

        SetLength(Args,n+1) else

        SetLength(Args,n);

      if length(Args)>MAX_METHOD_ARGS then

        RaiseError('method has too many parameters: %>%',[Length(Args),MAX_METHOD_ARGS]);

      for a := 0 to n-1 do

      with Args[a] do begin

        f := PF^;

        inc(PF);

        if pfVar in f then

          ValueDirection := smdVar else

        if pfOut in f then

          ValueDirection := smdOut;

        ArgsNotResultLast := a;

        if ValueDirection<>smdConst then

          ArgsOutNotResultLast := a;

        ParamName := PS;

        PS := AlignToPtr(@PS^[ord(PS^[0])+1]);

        SetFromRTTI(PB);

        {$ifdef ISDELPHIXE}

        inc(PB,PW^); // skip custom attributes

        {$endif}

        if a>0 then

        case TypeInfoToMethodValueType(ArgTypeInfo) of

        smvRecord,smvDynArray:

          if f*[pfConst,pfVar,pfOut]=[] then

            RaiseError('%: % parameter should be declared as const, var or out',

              [ParamName^,ArgTypeName^]);

        smvInterface:

          if not (pfConst in f) then

            RaiseError('%: % parameter should be declared as const',

              [ParamName^,ArgTypeName^]);

        end;

      end;

      // add a pseudo argument after all arguments for functions

      if Kind=mkFunction then

        with Args[n] do begin

          ParamName := @CONST_PSEUDO_RESULT_NAME;

          ValueDirection := smdResult;

          SetFromRTTI(PB);

        end;

      {$ifdef ISDELPHIXE}

      inc(PB,PW^); // skip custom attributes

      {$endif}

      {$endif FPC}

      // go to next method

    end;

  end;

end;



{$endif HASINTERFACERTTI} // see http://bugs.freepascal.org/view.php?id=26774





{ TInterfaceFactoryGenerated }



procedure TInterfaceFactoryGenerated.AddMethod(

  const aName: RawUTF8; const aParams: array of const);

const ARGPERARG = 3; // [ 0,'n1',TypeInfo(Integer), ... ]

var meth: PServiceMethod;

    arg: ^TServiceMethodArgument;

    na,ns,a: integer;

    u: RawUTF8;

begin

  if Length(aParams) mod ARGPERARG<>0 then

    raise EInterfaceFactoryException.CreateUTF8(

      '%: invalid aParams count for %.AddMethod("%")',[fInterfaceName,self,aName]);

  meth := fMethod.AddUniqueName(aName,'%.% method: duplicated generated name for %',

    [fInterfaceName,aName,self]);

  na := length(aParams) div ARGPERARG;

  SetLength(meth^.Args,na+1); // leave Args[0]=self

  with meth^.Args[0] do begin

    ParamName := @CONST_PSEUDO_SELF_NAME;

    ArgTypeInfo := fInterfaceTypeInfo;

    ArgTypeName := @ArgTypeInfo^.Name;

  end;

  ns := length(fTempStrings);

  SetLength(fTempStrings,ns+na);

  for a := 0 to na-1 do begin

    arg := @meth^.Args[a+1];

    if aParams[a*ARGPERARG].VType<>vtInteger then

      raise EInterfaceFactoryException.CreateUTF8('%: invalid param type #% for %.AddMethod("%")',

        [fInterfaceTypeInfo^.Name,a,self,aName]);

    arg^.ValueDirection := TServiceMethodValueDirection(aParams[a*ARGPERARG].VInteger);

    VarRecToUTF8(aParams[a*ARGPERARG+1],u);

    if u='' then

      raise EInterfaceFactoryException.CreateUTF8('%: invalid param name #% for %.AddMethod("%")',

        [fInterfaceTypeInfo^.Name,a,self,aName]);

    insert(AnsiChar(Length(u)),u,1); // create fake PShortString

    arg^.ParamName := pointer(u);

    fTempStrings[ns+a] := u;

    if aParams[a*ARGPERARG+2].VType<>vtPointer then

      raise EInterfaceFactoryException.CreateUTF8('%: expect TypeInfo() at #% for %.AddMethod("%")',

        [fInterfaceTypeInfo^.Name,a,self,aName]);

    arg^.ArgTypeInfo := aParams[a*ARGPERARG+2].VPointer;

    {$ifdef FPC} // under FPC, TypeInfo(Integer)=TypeInfo(Longint)

    if arg^.ArgTypeInfo=TypeInfo(Integer) then

      arg^.ArgTypeName := @CONST_INTEGER_NAME else

    {$endif}

      arg^.ArgTypeName := @arg^.ArgTypeInfo^.Name;

  end;

end;



class procedure TInterfaceFactoryGenerated.RegisterInterface(aInterface: PTypeInfo);

var i: integer;

begin

  if (aInterface=nil) or (self=TInterfaceFactoryGenerated) then

    raise EInterfaceFactoryException.CreateUTF8('%.RegisterInterface(nil)',[self]);

  EnterInterfaceFactoryCache;

  try

    for i := 0 to InterfaceFactoryCache.Count-1 do

      if TInterfaceFactory(InterfaceFactoryCache.List[i]).fInterfaceTypeInfo=aInterface then

        raise EInterfaceFactoryException.CreateUTF8('Duplicated %.RegisterInterface(%)',

          [self,aInterface^.Name]);

    InterfaceFactoryCache.Add(Create(aInterface));

  finally

    InterfaceFactoryCache.Safe.UnLock;

  end;

end;





{ TInterfaceStubRules }



function TInterfaceStubRules.FindRuleIndex(const aParams: RawUTF8): integer;

begin

  for result := 0 to length(Rules)-1 do

    if Rules[result].Params=aParams then

      exit;

  result := -1;

end;



function TInterfaceStubRules.FindStrongRuleIndex(const aParams: RawUTF8): integer;

begin

  for result := 0 to length(Rules)-1 do

    if (Rules[result].Kind<>isUndefined) and (Rules[result].Params=aParams) then

      exit;

  result := -1;

end;



procedure TInterfaceStubRules.AddRule(Sender: TInterfaceStub;

  aKind: TInterfaceStubRuleKind; const aParams, aValues: RawUTF8;

  const aEvent: TNotifyEvent; aExceptionClass: ExceptClass;

  aExpectedPassCountOperator: TSQLQueryOperator; aValue: cardinal);

var n,ndx: integer;

begin

  ndx := FindRuleIndex(aParams);

  n := length(Rules);

  if ndx<0 then

    SetLength(Rules,n+1) else

    n := ndx;

  if (aParams='') and (aKind<>isUndefined) then

    DefaultRule := n;

  with Rules[n] do begin

    Params := aParams;

    case aKind of

    isUndefined:

      ; // do not overwrite Values for weak rules like ExpectsCount/ExpectsTrace

    isReturns:

      Values := '['+AValues+']';

    isFails:

      Values := RawUTF8(Sender.ClassName)+' returned error: '+aValues;

    else

      Values := aValues;

    end;

    if aKind=isUndefined then

      if aExpectedPassCountOperator=qoContains then

        ExpectedTraceHash := aValue else begin

        ExpectedPassCountOperator := aExpectedPassCountOperator;

        ExpectedPassCount := aValue;

      end else begin

      Kind := aKind;

      Execute := TMethod(aEvent);

      ExceptionClass := aExceptionClass;

    end;

  end;

end;





{ TInterfaceStub }



constructor EInterfaceStub.Create(Sender: TInterfaceStub;

  const Method: TServiceMethod; const Error: RawUTF8);

begin

  inherited CreateUTF8('Error in % for %.% - %',

    [Sender,Sender.fInterface.fInterfaceName,Method.URI,Error]);

end;



constructor EInterfaceStub.Create(Sender: TInterfaceStub;

  const Method: TServiceMethod; const Format: RawUTF8; const Args: array of const);

begin

  Create(Sender,Method,FormatUTF8(Format,Args));

end;



function TInterfaceStubLog.Results: RawUTF8;

begin

  if CustomResults='' then

    result := Method^.DefaultResult else

    result := CustomResults;

end;



procedure TInterfaceStubLog.AddAsText(WR: TTextWriter; aScope: TInterfaceStubLogLayouts;

  SepChar: AnsiChar=',');

begin

  if wName in aScope then

    WR.AddString(Method^.URI);

  if wParams in aScope then begin

    WR.Add('(');

    WR.AddString(Params);

    WR.Add(')');

  end;

  if WasError then begin

    WR.AddShort(' error "');

    WR.AddString(CustomResults);

    WR.Add('"');

  end else

  if (wResults in aScope) and (Method^.ArgsResultIndex>=0) then begin

    if (wName in aScope) or (wParams in aScope) then

      WR.Add('=');

    if CustomResults='' then

      WR.AddString(Method^.DefaultResult) else

      WR.AddString(CustomResults);

  end;

  WR.Add(SepChar);

end;



constructor TOnInterfaceStubExecuteParamsAbstract.Create(aSender: TInterfaceStub;

  aMethod: PServiceMethod; const aParams,aEventParams: RawUTF8);

begin

  fSender := aSender;

  fMethod := aMethod;

  fParams := aParams;

  fEventParams := aEventParams;

end;



procedure TOnInterfaceStubExecuteParamsAbstract.Error(

  const Format: RawUTF8; const Args: array of const);

begin

  Error(FormatUTF8(Format,Args));

end;



procedure TOnInterfaceStubExecuteParamsAbstract.Error(const aErrorMessage: RawUTF8);

begin

  fFailed := true;

  fResult := aErrorMessage;

end;



function TOnInterfaceStubExecuteParamsAbstract.GetSenderAsMockTestCase: TSynTestCase;

begin

  result := (fSender as TInterfaceMock).TestCase;

end;



procedure TOnInterfaceStubExecuteParamsJSON.Returns(const Values: array of const);

begin

  JSONEncodeArrayOfConst(Values,false,fResult);

end;



procedure TOnInterfaceStubExecuteParamsJSON.Returns(const ValuesJsonArray: RawUTF8);

begin

  fResult := ValuesJsonArray;

end;



{$ifndef NOVARIANTS}



constructor TOnInterfaceStubExecuteParamsVariant.Create(aSender: TInterfaceStub;

  aMethod: PServiceMethod; const aParams, aEventParams: RawUTF8);

var i: integer;

    P: PUTF8Char;

    tmp: TSynTempBuffer;

begin

  inherited;

  SetLength(fInput,fMethod^.ArgsInputValuesCount);

  tmp.Init(aParams);

  try

    P := tmp.buf;

    for i := 0 to fMethod^.ArgsInputValuesCount-1 do

      P := VariantLoadJSON(fInput[i],P,nil,@aSender.fInterface.DocVariantOptions);

  finally

    tmp.Done;

  end;

  SetLength(fOutput,fMethod^.ArgsOutputValuesCount);

end;



function TOnInterfaceStubExecuteParamsVariant.GetInput(Index: Integer): variant;

begin

  if cardinal(Index)>=fMethod^.ArgsInputValuesCount then

    raise EInterfaceStub.Create(fSender,fMethod^,'Input[%>=%]',

      [Index,fMethod^.ArgsInputValuesCount]) else

    result := fInput[Index];

end;



procedure TOnInterfaceStubExecuteParamsVariant.SetOutput(Index: Integer;

  const Value: variant);

begin

  if cardinal(Index)>=fMethod^.ArgsOutputValuesCount then

    raise EInterfaceStub.Create(fSender,fMethod^,'Output[%>=%]',

      [Index,fMethod^.ArgsOutputValuesCount]) else

    fOutput[Index] := Value;

end;



function TOnInterfaceStubExecuteParamsVariant.GetInNamed(const aParamName: RawUTF8): variant;

var L,a,ndx: integer;

begin

  L := Length(aParamName);

  ndx := 0;

  if (L>0) and (fInput<>nil) then

    for a := fMethod^.ArgsInFirst to fMethod^.ArgsInLast do

      with fMethod^.Args[a] do

      if ValueDirection in [smdConst,smdVar] then begin

        if IdemPropName(ParamName^,pointer(aParamName),L) then begin

          result := fInput[ndx];

          exit;

        end;

        inc(ndx);

        if cardinal(ndx)>=cardinal(fMethod^.ArgsInputValuesCount) then

          break;

      end;

  raise EInterfaceStub.Create(fSender,fMethod^,'unknown input parameter "%"',[aParamName]);

end;



procedure TOnInterfaceStubExecuteParamsVariant.SetOutNamed(const aParamName: RawUTF8;

  const Value: variant);

var L,a,ndx: integer;

begin

  L := Length(aParamName);

  ndx := 0;

  if (L>0) and (fOutput<>nil) then

    for a := fMethod^.ArgsOutFirst to fMethod^.ArgsOutLast do

      with fMethod^.Args[a] do

      if ValueDirection<>smdConst then begin

        if IdemPropName(ParamName^,pointer(aParamName),L) then begin

          fOutput[ndx] := Value;

          exit;

        end;

        inc(ndx);

        if cardinal(ndx)>=cardinal(fMethod^.ArgsOutputValuesCount) then

          break;

      end;

  raise EInterfaceStub.Create(fSender,fMethod^,'unknown output parameter "%"',[aParamName]);

end;



procedure TOnInterfaceStubExecuteParamsVariant.SetResultFromOutput;

var a,ndx: integer;

    W: TJSONSerializer;

begin

  fResult := '';

  if fOutput=nil then

    exit;

  W := TJSONSerializer.CreateOwnedStream;

  try

    W.Add('[');

    ndx := 0;

    for a := fMethod^.ArgsOutFirst to fMethod^.ArgsOutLast do

    with fMethod^.Args[a] do

    if ValueDirection<>smdConst then begin

      if TVarData(fOutput[ndx]).VType=varEmpty then

        AddDefaultJSON(W) else begin

        W.AddVariant(fOutput[ndx],twJSONEscape);

        W.Add(',');

      end;

      inc(ndx);

      if cardinal(ndx)>=cardinal(fMethod^.ArgsOutputValuesCount) then

        break;

    end;

    W.CancelLastComma;

    W.Add(']');

    W.SetText(fResult);

  finally

    W.Free;

  end;

end;



function TOnInterfaceStubExecuteParamsVariant.InputAsDocVariant(

  Kind: TServiceMethodParamsDocVariantKind; Options: TDocVariantOptions): variant;

begin

  VarClear(result);

  fMethod^.ArgsValuesAsDocVariant(Kind,TDocVariantData(Result),fInput,true,Options);

end;



function TOnInterfaceStubExecuteParamsVariant.OutputAsDocVariant(

  Kind: TServiceMethodParamsDocVariantKind; Options: TDocVariantOptions): variant;

begin

  VarClear(result);

  fMethod^.ArgsValuesAsDocVariant(Kind,TDocVariantData(Result),fOutput,false,Options);

end;



{$endif NOVARIANTS}



constructor TInterfaceStub.Create(aFactory: TInterfaceFactory;

  const aInterfaceName: RawUTF8);

var i: integer;

begin

  if aFactory=nil then

    raise EInterfaceStub.CreateUTF8(

      '%.Create(%): Interface not registered - you could use '+

      'TInterfaceFactory.RegisterInterfaces()',[self,aInterfaceName]);

  fInterface := aFactory;

  SetLength(fRules,fInterface.MethodsCount);

  for i := 0 to fInterface.MethodsCount-1 do

    fRules[i].DefaultRule := -1;

  fLog.Init(TypeInfo(TInterfaceStubLogDynArray),fLogs,@fLogCount);

end;



procedure TInterfaceStub.InternalGetInstance(out aStubbedInterface);

var fake: TInterfacedObjectFake;

begin

  fake := TInterfacedObjectFake.Create(fInterface,[ifoJsonAsExtended],Invoke,InstanceDestroyed);

  pointer(aStubbedInterface) := @fake.fVTable;

  fake._AddRef;

  fLastInterfacedObjectFake := fake;

end;



function TInterfaceStub.InternalCheck(aValid,aExpectationFailed: boolean;

  const aErrorMsgFmt: RawUTF8; const aErrorMsgArgs: array of const): boolean;

begin

  result := aValid;

  if aExpectationFailed and not aValid then

    raise EInterfaceStub.CreateUTF8('%.InternalCheck(%) failed: %',

      [self,fInterface.fInterfaceName,FormatUTF8(aErrorMsgFmt,aErrorMsgArgs)]);

end;



constructor TInterfaceStub.Create(const aInterfaceName: RawUTF8; out aStubbedInterface);

begin

  Create(TInterfaceFactory.Get(aInterfaceName),aInterfaceName);

  InternalGetInstance(aStubbedInterface);

end;



constructor TInterfaceStub.Create(const aGUID: TGUID; out aStubbedInterface);

begin

  Create(TInterfaceFactory.Get(aGUID),GUIDToRawUTF8(aGUID));

  InternalGetInstance(aStubbedInterface);

end;



constructor TInterfaceStub.Create(aInterface: PTypeInfo; out aStubbedInterface);

begin

  Create(aInterface);

  InternalGetInstance(aStubbedInterface);

end;



constructor TInterfaceStub.Create(aInterface: PTypeInfo);

begin

  Create(TInterfaceFactory.Get(aInterface),ToUTF8(aInterface^.Name));

end;



constructor TInterfaceStub.Create(const aGUID: TGUID);

begin

  Create(TInterfaceFactory.Get(aGUID),ToUTF8(aGUID));

end;



procedure TInterfaceStub.IntSetOptions(Options: TInterfaceStubOptions);

begin

  if Options=fOptions then

    exit;

  fOptions := Options;

end;



procedure TInterfaceStub.IntCheckCount(aMethodIndex, aComputed: cardinal;

  aOperator: TSQLQueryOperator; aCount: cardinal);

const

  OPERATORS: array[qoEqualTo..qoGreaterThanOrEqualTo] of RawUTF8 = (

    '=','<>','<','<=','>','>=');

function SQLQueryCompare(aOperator: TSQLQueryOperator; A,B: cardinal): boolean;

begin

  case aOperator of

  qoEqualTo:              result := A=B;

  qoNotEqualTo:           result := A<>B;

  qoLessThan:             result := A<B;

  qoLessThanOrEqualTo:    result := A<=B;

  qoGreaterThan:          result := A>B;

  qoGreaterThanOrEqualTo: result := A>=B;

  else raise EInterfaceStub.CreateUTF8('%.IntCheckCount(): Unexpected % operator',

    [self,Ord(aOperator)]);

  end;

end;

begin

  InternalCheck(SQLQueryCompare(aOperator,aComputed,aCount),True,

   'ExpectsCount(''%'',%,%) failed: count=%',[fInterface.Methods[aMethodIndex].URI,

    ToText(aOperator)^,aCount,aComputed]);

end;



procedure TInterfaceStub.InstanceDestroyed(aClientDrivenID: cardinal);

var m,r,asmndx: integer;

    num: cardinal;

begin

  if self<>nil then

  try

    if eCount in fHasExpects then

      for m := 0 to fInterface.MethodsCount-1 do

      with fRules[m] do

        for r := 0 to high(Rules) do

        with Rules[r] do

          if ExpectedPassCountOperator<>qoNone then begin

            if Params='' then

              num := MethodPassCount else

              num := RulePassCount;

            IntCheckCount(m,num,ExpectedPassCountOperator,ExpectedPassCount);

          end;

    if fInterfaceExpectedTraceHash<>0 then

      InternalCheck(LogHash=fInterfaceExpectedTraceHash,True,

        'ExpectsTrace(%) returned %',[fInterfaceExpectedTraceHash,LogHash]);

    if eTrace in fHasExpects then

      for m := 0 to fInterface.MethodsCount-1 do

      with fRules[m] do begin

        asmndx := m+RESERVED_VTABLE_SLOTS;

        for r := 0 to high(Rules) do

        with Rules[r] do

        if ExpectedTraceHash<>0 then

          InternalCheck(ExpectedTraceHash=Hash32(IntGetLogAsText(

             asmndx,Params,[wName,wParams,wResults],',')),True,

            'ExpectsTrace(''%'') failed',[fInterface.Methods[m].URI]);

      end;

  finally

    if not (imoFakeInstanceWontReleaseTInterfaceStub in Options) then

      Free; // creature will release its creator

  end;

end;



function TInterfaceStub.SetOptions(Options: TInterfaceStubOptions): TInterfaceStub;

begin

  IntSetOptions(Options);

  result := self;

end;



function TInterfaceStub.Executes(const aMethodName, aParams: RawUTF8;

  aEvent: TOnInterfaceStubExecuteJSON; const aEventParams: RawUTF8): TInterfaceStub;

begin

  fRules[fInterface.CheckMethodIndex(aMethodName)].

    AddRule(self,isExecutesJSON,aParams,aEventParams,TNotifyEvent(aEvent));

  result := self;

end;



function TInterfaceStub.Executes(const aMethodName: RawUTF8;

  aEvent: TOnInterfaceStubExecuteJSON; const aEventParams: RawUTF8): TInterfaceStub;

begin

  result := Executes(aMethodName,'',aEvent,aEventParams);

end;



function TInterfaceStub.Executes(const aMethodName: RawUTF8;

  const aParams: array of const; aEvent: TOnInterfaceStubExecuteJSON;

  const aEventParams: RawUTF8): TInterfaceStub;

begin

  result := Executes(aMethodName,JSONEncodeArrayOfConst(aParams,true),

    aEvent,aEventParams);

end;



{$ifndef NOVARIANTS}



function TInterfaceStub.Executes(const aMethodName, aParams: RawUTF8;

  aEvent: TOnInterfaceStubExecuteVariant; const aEventParams: RawUTF8): TInterfaceStub;

begin

  fRules[fInterface.CheckMethodIndex(aMethodName)].

    AddRule(self,isExecutesVariant,aParams,aEventParams,TNotifyEvent(aEvent));

  result := self;

end;



function TInterfaceStub.Executes(const aMethodName: RawUTF8;

  aEvent: TOnInterfaceStubExecuteVariant; const aEventParams: RawUTF8): TInterfaceStub;

begin

  result := Executes(aMethodName,'',aEvent,aEventParams);

end;



function TInterfaceStub.Executes(const aMethodName: RawUTF8;

  const aParams: array of const; aEvent: TOnInterfaceStubExecuteVariant;

  const aEventParams: RawUTF8): TInterfaceStub;

begin

  result := Executes(aMethodName,JSONEncodeArrayOfConst(aParams,true),

    aEvent,aEventParams);

end;



function TInterfaceStub.Executes(aEvent: TOnInterfaceStubExecuteVariant;

  const aEventParams: RawUTF8): TInterfaceStub;

var i: integer;

begin

  for i := 0 to fInterface.MethodsCount-1 do

    fRules[i].AddRule(self,isExecutesVariant,'',aEventParams,TNotifyEvent(aEvent));

  result := self;

end;



type

  TInterfaceStubExecutesToLog = packed record

    Log: TSynLogClass;

    LogLevel: TSynLogInfo;

    Kind: TServiceMethodParamsDocVariantKind;

  end;

  PInterfaceStubExecutesToLog = ^TInterfaceStubExecutesToLog;



procedure TInterfaceStub.OnExecuteToLog(Ctxt: TOnInterfaceStubExecuteParamsVariant);

begin

  if length(Ctxt.EventParams)=sizeof(TInterfaceStubExecutesToLog) then

    with PInterfaceStubExecutesToLog(Ctxt.EventParams)^ do

      Log.Add.Log(LogLevel,'% %',[Ctxt.Method^.InterfaceDotMethodName,

        Ctxt.InputAsDocVariant(Kind,JSON_OPTIONS_FAST_EXTENDED)]);

end;



function TInterfaceStub.Executes(aLog: TSynLogClass; aLogLevel: TSynLogInfo;

   aKind: TServiceMethodParamsDocVariantKind): TInterfaceStub;

var tmp: RawUTF8;

begin

  SetLength(tmp,SizeOf(TInterfaceStubExecutesToLog));

  with PInterfaceStubExecutesToLog(tmp)^ do begin

    Log := aLog;

    LogLevel := aLogLevel;

    Kind := aKind;

  end;

  Executes(OnExecuteToLog,tmp);

  result := self;

end;





{$endif NOVARIANTS}



function TInterfaceStub.ExpectsCount(const aMethodName: RawUTF8; aOperator: TSQLQueryOperator;

  aValue: cardinal): TInterfaceStub;

begin

  result := ExpectsCount(aMethodName,'',aOperator,aValue);

end;



function TInterfaceStub.ExpectsCount(const aMethodName, aParams: RawUTF8; aOperator: TSQLQueryOperator;

  aValue: cardinal): TInterfaceStub;

var ndx: integer;

begin

  ndx := fInterface.CheckMethodIndex(aMethodName);

  if aOperator in [qoEqualTo..qoGreaterThanOrEqualTo] then

    with fRules[ndx] do

      AddRule(self,isUndefined,aParams,'',nil,nil,aOperator,aValue) else

    raise EInterfaceStub.Create(self,fInterface.fMethods[ndx],

      'ExpectsCount(aOperator=%)',[ord(aOperator)]);

  include(fHasExpects,eCount);

  result := self;

end;



function TInterfaceStub.ExpectsCount(const aMethodName: RawUTF8;

  const aParams: array of const; aOperator: TSQLQueryOperator; aValue: cardinal): TInterfaceStub;

begin

  result := ExpectsCount(aMethodName,JSONEncodeArrayOfConst(aParams,true),aOperator,aValue);

end;



function TInterfaceStub.ExpectsTrace(aValue: cardinal): TInterfaceStub;

begin

  include(fOptions,imoLogMethodCallsAndResults);

  fInterfaceExpectedTraceHash := aValue;

  result := self;

end;



function TInterfaceStub.ExpectsTrace(const aMethodName: RawUTF8; aValue: cardinal): TInterfaceStub;

begin

  result := ExpectsTrace(aMethodName,'',aValue);

end;



function TInterfaceStub.ExpectsTrace(const aMethodName, aParams: RawUTF8;

  aValue: cardinal): TInterfaceStub;

begin

  fRules[fInterface.CheckMethodIndex(aMethodName)].

    AddRule(self,isUndefined,aParams,'',nil,nil,qoContains,aValue);

  include(fOptions,imoLogMethodCallsAndResults);

  include(fHasExpects,eTrace);

  result := self;

end;



function TInterfaceStub.ExpectsTrace(const aMethodName: RawUTF8;

  const aParams: array of const; aValue: cardinal): TInterfaceStub;

begin

  result := ExpectsTrace(aMethodName,JSONEncodeArrayOfConst(aParams,true),aValue);

end;



function TInterfaceStub.ExpectsTrace(const aValue: RawUTF8): TInterfaceStub;

begin

  result := ExpectsTrace(Hash32(aValue));

end;



function TInterfaceStub.ExpectsTrace(const aMethodName, aValue: RawUTF8): TInterfaceStub;

begin

  result := ExpectsTrace(aMethodName,Hash32(aValue));

end;



function TInterfaceStub.ExpectsTrace(const aMethodName, aParams, aValue: RawUTF8): TInterfaceStub;

begin

  result := ExpectsTrace(aMethodName,aParams,Hash32(aValue));

end;



function TInterfaceStub.ExpectsTrace(const aMethodName: RawUTF8; const aParams: array of const;

  const aValue: RawUTF8): TInterfaceStub;

begin

  result := ExpectsTrace(aMethodName,aParams,Hash32(aValue));

end;



function TInterfaceStub.Fails(const aMethodName, aErrorMsg: RawUTF8): TInterfaceStub;

begin

  result := Fails(aMethodName,'',aErrorMsg);

end;



function TInterfaceStub.Fails(const aMethodName, aParams, aErrorMsg: RawUTF8): TInterfaceStub;

begin

  fRules[fInterface.CheckMethodIndex(aMethodName)].

    AddRule(self,isFails,aParams,aErrorMsg);

  result := self;

end;



function TInterfaceStub.Fails(const aMethodName: RawUTF8; const aParams: array of const;

  const aErrorMsg: RawUTF8): TInterfaceStub;

begin

  result := Fails(aMethodName,JSONEncodeArrayOfConst(aParams,true),aErrorMsg);

end;



function TInterfaceStub.Raises(const aMethodName, aParams: RawUTF8;

  aException: ExceptClass; const aMessage: string): TInterfaceStub;

begin

  fRules[fInterface.CheckMethodIndex(aMethodName)].

    AddRule(self,isRaises,aParams,StringToUTF8(aMessage),nil,aException);

  result := self;

end;



function TInterfaceStub.Raises(const aMethodName: RawUTF8;

  const aParams: array of const; aException: ExceptClass;

  const aMessage: string): TInterfaceStub;

begin

  result := Raises(aMethodName,JSONEncodeArrayOfConst(aParams,true),

    aException,aMessage);

end;



function TInterfaceStub.Raises(const aMethodName: RawUTF8;

  aException: ExceptClass; const aMessage: string): TInterfaceStub;

begin

  result := Raises(aMethodName,'',aException,aMessage);

end;



function TInterfaceStub.Returns(const aMethodName, aParams,

  aExpectedResults: RawUTF8): TInterfaceStub;

begin

  fRules[fInterface.CheckMethodIndex(aMethodName)].

    AddRule(self,isReturns,aParams,aExpectedResults);

  result := self;

end;



function TInterfaceStub.Returns(const aMethodName: RawUTF8; const aParams,

  aExpectedResults: array of const): TInterfaceStub;

begin

  result := Returns(aMethodName,JSONEncodeArrayOfConst(aParams,true),

    JSONEncodeArrayOfConst(aExpectedResults,true));

end;



function TInterfaceStub.Returns(const aMethodName,

  aExpectedResults: RawUTF8): TInterfaceStub;

begin

  result := Returns(aMethodName,'',aExpectedResults);

end;



function TInterfaceStub.Returns(const aMethodName: RawUTF8;

  const aExpectedResults: array of const): TInterfaceStub;

begin

  result := Returns(aMethodName,'',JSONEncodeArrayOfConst(aExpectedResults,true));

end;



function TInterfaceStub.Invoke(const aMethod: TServiceMethod;

  const aParams: RawUTF8; aResult, aErrorMsg: PRawUTF8;

  aClientDrivenID: PCardinal; aServiceCustomAnswer: PServiceCustomAnswer): boolean;

var ndx: cardinal;

    rule: integer;

    ExecutesCtxtJSON: TOnInterfaceStubExecuteParamsJSON;

    ExecutesCtxtVariant: TOnInterfaceStubExecuteParamsVariant;

    Log: TInterfaceStubLog;

begin

  ndx := aMethod.ExecutionMethodIndex-RESERVED_VTABLE_SLOTS;

  if ndx>=fInterface.MethodsCount then

    result := false else

    with fRules[ndx] do begin

      inc(MethodPassCount);

      rule := FindStrongRuleIndex(aParams);

      if rule<0 then begin

        rule := FindRuleIndex(aParams);

        if (rule>=0) and (DefaultRule>=0) then

          inc(Rules[rule].RulePassCount);

        rule := DefaultRule;

      end;

      if rule<0 then

        if imoRaiseExceptionIfNoRuleDefined in Options then

          raise EInterfaceStub.Create(self,aMethod,'No rule defined') else begin

        rule := FindRuleIndex(aParams);

        if rule>=0 then

          inc(Rules[rule].RulePassCount);

        if imoReturnErrorIfNoRuleDefined in Options then begin

          result := false;

          Log.CustomResults := FormatUTF8('No stubbing rule defined for %.%',

            [fInterface.fInterfaceName,aMethod.URI]);

        end else

          result := true;

      end else

      with Rules[rule] do begin

        inc(RulePassCount);

        case Kind of

        isExecutesJSON: begin

          ExecutesCtxtJSON := TOnInterfaceStubExecuteParamsJSON.Create(

            self,@aMethod,aParams,Values);

          try

            TOnInterfaceStubExecuteJSON(Execute)(ExecutesCtxtJSON);

            result := not ExecutesCtxtJSON.Failed;

            Log.CustomResults := ExecutesCtxtJSON.Result;

          finally

            ExecutesCtxtJSON.Free;

          end;

        end;

        {$ifndef NOVARIANTS}

        isExecutesVariant: begin

          ExecutesCtxtVariant := TOnInterfaceStubExecuteParamsVariant.Create(

            self,@aMethod,aParams,Values);

          try

            TOnInterfaceStubExecuteVariant(Execute)(ExecutesCtxtVariant);

            result := not ExecutesCtxtVariant.Failed;

            if result then begin

              ExecutesCtxtVariant.SetResultFromOutput;

              Log.CustomResults := ExecutesCtxtVariant.Result;

            end;

          finally

            ExecutesCtxtVariant.Free;

          end;

        end;

        {$endif}

        isRaises:

          raise ExceptionClass.Create(UTF8ToString(Values));

        isReturns: begin

          result := true;

          Log.CustomResults := Values;

        end;

        isFails: begin

          result := InternalCheck(false,false,'%',[Values]);

          if not result then

            Log.CustomResults := Values;

        end;

        else

          result := true; // ignore isUndefined (ExpectsCount only) rules

        end;

      end;

      if result then begin

        if aResult<>nil then // make unique due to JSONDecode()

          if Log.CustomResults='' then

            SetString(aResult^,PAnsiChar(pointer(aMethod.DefaultResult)),

              length(aMethod.DefaultResult)) else

            SetString(aResult^,PAnsiChar(pointer(Log.CustomResults)),

              length(Log.CustomResults));

      end else

      if aErrorMsg<>nil then

        aErrorMsg^ := Log.CustomResults;

      if imoLogMethodCallsAndResults in Options then begin

        Log.TimeStamp64 := GetTickCount64;

        Log.WasError := not result;

        Log.Method := @aMethod;

        Log.Params := aParams;

        fLog.Add(Log);

      end;

    end;

end;



function TInterfaceStub.LogAsText(SepChar: AnsiChar): RawUTF8;

begin

  result := IntGetLogAsText(0,'',[wName,wParams,wResults],SepChar);

end;



procedure TInterfaceStub.ClearLog;

begin

  fLog.Clear;

end;



function TInterfaceStub.IntGetLogAsText(asmndx: integer; const aParams: RawUTF8;

  aScope: TInterfaceStubLogLayouts; SepChar: AnsiChar): RawUTF8;

var i: integer;

    WR: TTextWriter;

    Log: ^TInterfaceStubLog;

begin

  if fLogCount=0 then

    result := '' else begin

    WR := TTextWriter.CreateOwnedStream;

    try

      Log := Pointer(fLogs);

      if asmndx<RESERVED_VTABLE_SLOTS then

        for i := 1 to fLogCount do begin

          Log^.AddAsText(WR,aScope,SepChar);

          inc(Log);

        end else

        for i := 1 to fLogCount do begin

          if Log^.Method^.ExecutionMethodIndex=asmndx then

            if (aParams='') or (Log^.Params=aParams) then

              Log^.AddAsText(WR,aScope,SepChar);

          inc(Log);

        end;

      WR.CancelLastChar(SepChar);

      WR.SetText(result);

    finally

      WR.Free;

    end;

  end;

end;



function TInterfaceStub.GetLogHash: cardinal;

begin

  result := Hash32(LogAsText);

end;



function TInterfaceStub.TryResolve(aInterface: PTypeInfo; out Obj): boolean;

begin

  if aInterface<>fInterface.fInterfaceTypeInfo then

    result := false else begin

    InternalGetInstance(Obj);

    result := true;

  end;

end;



function TInterfaceStub.Implements(aInterface: PTypeInfo): boolean;

begin

  result := fInterface.fInterfaceTypeInfo=aInterface;

end;





{ TInterfaceMock }



constructor TInterfaceMock.Create(aInterface: PTypeInfo;

  out aMockedInterface; aTestCase: TSynTestCase);

begin

  inherited Create(aInterface,aMockedInterface);

  fTestCase := aTestCase;

end;



constructor TInterfaceMock.Create(const aGUID: TGUID; out aMockedInterface;

  aTestCase: TSynTestCase);

begin

  inherited Create(aGUID,aMockedInterface);

  fTestCase := aTestCase;

end;



constructor TInterfaceMock.Create(const aInterfaceName: RawUTF8;

  out aMockedInterface; aTestCase: TSynTestCase);

begin

  inherited Create(aInterfaceName,aMockedInterface);

  fTestCase := aTestCase;

end;



constructor TInterfaceMock.Create(aInterface: PTypeInfo; aTestCase: TSynTestCase);

begin

  inherited Create(aInterface);

  fTestCase := aTestCase;

end;



constructor TInterfaceMock.Create(const aGUID: TGUID; aTestCase: TSynTestCase);

begin

  inherited Create(aGUID);

  fTestCase := aTestCase;

end;



function TInterfaceMock.InternalCheck(aValid,aExpectationFailed: boolean;

  const aErrorMsgFmt: RawUTF8; const aErrorMsgArgs: array of const): boolean;

begin

  if fTestCase=nil then

    result := inherited InternalCheck(aValid,aExpectationFailed,aErrorMsgFmt,aErrorMsgArgs) else begin

    if aValid xor (imoMockFailsWillPassTestCase in Options) then

      fTestCase.Check(true) else

      fTestCase.Check(false,UTF8ToString(FormatUTF8(aErrorMsgFmt,aErrorMsgArgs)));

    result := true; // do not raise any exception at this stage for TInterfaceMock

  end;

end;





{ TInterfaceMockSpy }



constructor TInterfaceMockSpy.Create(aFactory: TInterfaceFactory;

  const aInterfaceName: RawUTF8);

begin

  inherited Create(aFactory,aInterfaceName);

  include(fOptions,imoLogMethodCallsAndResults);

end;



procedure TInterfaceMockSpy.IntSetOptions(Options: TInterfaceStubOptions);

begin

  include(Options,imoLogMethodCallsAndResults);

  inherited IntSetOptions(Options);

end;



procedure TInterfaceMockSpy.Verify(const aMethodName: RawUTF8;

  const aParams: array of const; aOperator: TSQLQueryOperator;

  aCount: cardinal);

begin

  Verify(aMethodName,JSONEncodeArrayOfConst(aParams,true),aOperator,aCount);

end;



procedure TInterfaceMockSpy.Verify(const aMethodName: RawUTF8;

  const aParams: array of const; const aTrace: RawUTF8);

begin

  Verify(aMethodName,JSONEncodeArrayOfConst(aParams,true),aTrace);

end;



procedure TInterfaceMockSpy.Verify(const aMethodName: RawUTF8;

  aOperator: TSQLQueryOperator; aCount: cardinal);

var m: integer;

begin

  m := fInterface.CheckMethodIndex(aMethodName);

  IntCheckCount(m,fRules[m].MethodPassCount,aOperator,aCount);

end;



procedure TInterfaceMockSpy.Verify(const aMethodName, aParams: RawUTF8;

  aOperator: TSQLQueryOperator; aCount: cardinal);

var asmndx, i: integer;

    c: cardinal;

begin

  asmndx := fInterface.CheckMethodIndex(aMethodName)+RESERVED_VTABLE_SLOTS;

  if aParams='' then

    c := fRules[asmndx-RESERVED_VTABLE_SLOTS].MethodPassCount else begin

    c := 0;

    for i := 0 to fLogCount-1 do

      with fLogs[i] do

      if (Method.ExecutionMethodIndex=asmndx) and (Params=aParams) then

        inc(c);

  end;

  IntCheckCount(asmndx-RESERVED_VTABLE_SLOTS,c,aOperator,aCount);

end;



procedure TInterfaceMockSpy.Verify(const aTrace: RawUTF8;

  aScope: TInterfaceMockSpyCheck);

const

  VERIFY_SCOPE: array[TInterfaceMockSpyCheck] of TInterfaceStubLogLayouts = (

    [wName], [wName, wParams], [wName, wParams, wResults]);

begin

  InternalCheck(IntGetLogAsText(0,'',VERIFY_SCOPE[aScope],',')=aTrace,true,

    'Verify(''%'',%) failed',[aTrace,ToText(aScope)^]);

end;



procedure TInterfaceMockSpy.Verify(const aMethodName, aParams, aTrace: RawUTF8);

var m: integer;

begin

  m := fInterface.CheckMethodIndex(aMethodName);

  InternalCheck(

    IntGetLogAsText(m+RESERVED_VTABLE_SLOTS,aParams,[wResults],',')=aTrace,True,

    'Verify(''%'',''%'',''%'') failed',[aMethodName,aParams,aTrace]);

end;



procedure TInterfaceMockSpy.Verify(const aMethodName, aTrace: RawUTF8;

  aScope: TInterfaceMockSpyCheck);

const

  VERIFY_SCOPE: array[TInterfaceMockSpyCheck] of TInterfaceStubLogLayouts = (

    [], [wParams], [wParams, wResults]);

var m: integer;

begin

  m := fInterface.CheckMethodIndex(aMethodName);

  if aScope=chkName then

    raise EInterfaceStub.Create(self,fInterface.Methods[m],'Invalid scope for Verify()');

  InternalCheck(

    IntGetLogAsText(m+RESERVED_VTABLE_SLOTS,'',VERIFY_SCOPE[aScope],',')=aTrace,True,

    'Verify(''%'',''%'',%) failed',[aMethodName,aTrace,ToText(aScope)^]);

end;





{ TInterfaceResolverForSingleInterface }



constructor TInterfaceResolverForSingleInterface.Create(

  aInterface: PTypeInfo; aImplementation: TInterfacedObjectClass);

var guid: PGUID;

begin

  fInterfaceTypeInfo := aInterface;

  guid := aInterface^.InterfaceGUID;

  if guid=nil then

    raise EInterfaceResolverException.CreateUTF8('%.Create expects an Interface',[self]);

  fImplementationEntry := aImplementation.GetInterfaceEntry(guid^);

  if fImplementationEntry=nil then

    raise EInterfaceResolverException.CreateUTF8('%.Create: % does not implement %',

      [self,aImplementation,fInterfaceTypeInfo^.Name]);

  aInterface^.InterfaceAncestors(fInterfaceAncestors,aImplementation,

    fInterfaceAncestorsImplementationEntry);

  fImplementation.Init(aImplementation);

end;



constructor TInterfaceResolverForSingleInterface.Create(const aInterface: TGUID;

  aImplementation: TInterfacedObjectClass);

begin

  Create(TInterfaceFactory.GUID2TypeInfo(aInterface),aImplementation);

end;



function TInterfaceResolverForSingleInterface.CreateInstance: TInterfacedObject;

begin

  result := TInterfacedObject(fImplementation.CreateNew);

end;



function TInterfaceResolverForSingleInterface.GetImplementationName: string;

begin

  if self=nil then

    result := '' else

    result := string(fImplementation.ItemClass.ClassName);

end;



function TInterfaceResolverForSingleInterface.GetOneInstance(out Obj): boolean;

begin

  if self=nil then

    result := false else

    // here we now that CreateInstance will implement the interface

    result := GetInterfaceFromEntry(CreateInstance,fImplementationEntry,Obj);

end;



function TInterfaceResolverForSingleInterface.TryResolve(

  aInterface: PTypeInfo; out Obj): boolean;

var i: integer;

begin

  if fInterfaceTypeInfo=aInterface then

    result := GetInterfaceFromEntry(

      CreateInstance,fImplementationEntry,Obj) else begin

    // if not found exact interface, try any parent/ancestor interface

    for i := 0 to length(fInterfaceAncestors)-1 do

      if fInterfaceAncestors[i]=aInterface then begin

        // here we know that CreateInstance will implement fInterfaceAncestors[]

        result := GetInterfaceFromEntry(

          CreateInstance,fInterfaceAncestorsImplementationEntry[i],Obj);

        exit;

      end;

    result := false;

  end;

end;



function TInterfaceResolverForSingleInterface.Implements(aInterface: PTypeInfo): boolean;

var i: integer;

begin

  if fInterfaceTypeInfo=aInterface then

    result := true else begin

    // if not found exact interface, try any parent/ancestor interface

    for i := 0 to length(fInterfaceAncestors)-1 do

      if fInterfaceAncestors[i]=aInterface then begin

        result := true;

        exit;

      end;

    result := false;

  end;

end;





{ TInterfaceResolverInjected }



var

  GlobalInterfaceResolutionLock: TRTLCriticalSection;

  GlobalInterfaceResolution: array of record

    TypeInfo: PTypeInfo;

    ImplementationClass: TInterfacedObjectWithCustomCreateClass;

    ImplementationInstance: TInterfacedObject;

    InterfaceEntry: PInterfaceEntry;

  end;



class function TInterfaceResolverInjected.RegisterGlobalCheck(aInterface: PTypeInfo;

  aImplementationClass: TClass): PInterfaceEntry;

var i: integer;

begin

  if (aInterface=nil) or (aImplementationClass=nil) then

    raise EInterfaceResolverException.CreateUTF8('%.RegisterGlobal(nil)',[self]);

  if aInterface^.Kind<>tkInterface then

    raise EInterfaceResolverException.CreateUTF8(

      '%.RegisterGlobal(%): % is not an interface',

      [self,aInterface^.Name,aInterface^.Name]);

  //alfchange

  //result := aImplementationClass.GetInterfaceEntry(

  //  PInterfaceTypeData(aInterface^.ClassType)^.IntfGuid);

  result := aImplementationClass.GetInterfaceEntry(aInterface^.InterfaceGUID^);

  if result=nil then

    raise EInterfaceResolverException.CreateUTF8(

      '%.RegisterGlobal(): % does not implement %',

      [self,aImplementationClass,aInterface^.Name]);

  EnterCriticalSection(GlobalInterfaceResolutionLock);

  for i := 0 to length(GlobalInterfaceResolution)-1 do

    if GlobalInterfaceResolution[i].TypeInfo=aInterface then begin

      LeaveCriticalSection(GlobalInterfaceResolutionLock); // release fSafe.Lock now

      raise EInterfaceResolverException.CreateUTF8(

        '%.RegisterGlobal(%): % already registered',

        [self,aImplementationClass,aInterface^.Name]);

    end;

end; // caller should explicitly call finally LeaveCriticalSection(...) end;



class procedure TInterfaceResolverInjected.RegisterGlobal(

  aInterface: PTypeInfo; aImplementationClass: TInterfacedObjectWithCustomCreateClass);

var aInterfaceEntry: PInterfaceEntry;

    n: integer;

begin

  aInterfaceEntry := RegisterGlobalCheck(aInterface,aImplementationClass);

  try // here we are protected within a EnterCriticalSection() call

    n := length(GlobalInterfaceResolution);

    SetLength(GlobalInterfaceResolution,n+1);

    with GlobalInterfaceResolution[n] do begin

      TypeInfo := aInterface;

      ImplementationClass := aImplementationClass;

      InterfaceEntry := aInterfaceEntry;

    end;

  finally

    LeaveCriticalSection(GlobalInterfaceResolutionLock);

  end;

end;



class procedure TInterfaceResolverInjected.RegisterGlobal(

  aInterface: PTypeInfo; aImplementation: TInterfacedObject);

var aInterfaceEntry: PInterfaceEntry;

    n: integer;

begin

  aInterfaceEntry := RegisterGlobalCheck(aInterface,aImplementation.ClassType);

  try // here we are protected within a EnterCriticalSection() call

    n := length(GlobalInterfaceResolution);

    SetLength(GlobalInterfaceResolution,n+1);

    with GlobalInterfaceResolution[n] do begin

      TypeInfo := aInterface;

      IInterface(aImplementation)._AddRef;

      ImplementationInstance := aImplementation;

      InterfaceEntry := aInterfaceEntry;

    end;

  finally

    LeaveCriticalSection(GlobalInterfaceResolutionLock);

  end;

end;



class procedure TInterfaceResolverInjected.RegisterGlobalDelete(aInterface: PTypeInfo);

var i: integer;

begin

  if (aInterface=nil) or (aInterface^.Kind<>tkInterface) then

    raise EInterfaceResolverException.CreateUTF8('%.RegisterGlobalDelete(?)',[self]);

  EnterCriticalSection(GlobalInterfaceResolutionLock);

  try

    for i := 0 to length(GlobalInterfaceResolution)-1 do

      with GlobalInterfaceResolution[i] do

      if TypeInfo=aInterface then

        if ImplementationInstance=nil then

          raise EInterfaceResolverException.CreateUTF8(

            '%.RegisterGlobalDelete(%) does not match an instance, but a class',

            [self,aInterface^.Name]) else begin

          IInterface(ImplementationInstance)._Release;

          exit;

        end;

  finally

    LeaveCriticalSection(GlobalInterfaceResolutionLock);

  end;

end;



procedure FinalizeGlobalInterfaceResolution;

var i: Integer;

begin

  for i := length(GlobalInterfaceResolution)-1 downto 0 do

    with GlobalInterfaceResolution[i] do

      if ImplementationInstance<>nil then

      try

        ImplementationInstance.Free;

      except

      end;

  DeleteCriticalSection(GlobalInterfaceResolutionLock);

end;



function TInterfaceResolverInjected.TryResolve(aInterface: PTypeInfo; out Obj): boolean;

var i: integer;

begin

  if aInterface<>nil then begin

    result := true;

    if self<>nil then begin // first check local DI/IoC

      if fResolvers<>nil then

      for i := 0 to length(fResolvers)-1 do

        if fResolvers[i].TryResolve(aInterface,Obj) then

          exit;

      if fDependencies<>nil then

      for i := 0 to Length(fDependencies)-1 do

        if fDependencies[i].GetInterface(aInterface^.InterfaceGUID^,Obj) then

          exit;

    end;

    EnterCriticalSection(GlobalInterfaceResolutionLock); // shared DI/IoC

    try

      for i := 0 to length(GlobalInterfaceResolution)-1 do

        with GlobalInterfaceResolution[i] do

        if TypeInfo=aInterface then

          if ImplementationInstance<>nil then begin

            if GetInterfaceFromEntry(ImplementationInstance,InterfaceEntry,Obj) then

              exit;

          end else

            if GetInterfaceFromEntry(ImplementationClass.Create,InterfaceEntry,Obj) then

              exit;

    finally

      LeaveCriticalSection(GlobalInterfaceResolutionLock);

    end;

  end;

  result := false;

end;



function TInterfaceResolverInjected.TryResolveInternal(aInterface: PTypeInfo; out Obj): boolean;

var i: integer;

begin

  result := true;

  if (self<>nil) and (aInterface<>nil) and (fResolvers<>nil) then

    for i := 0 to length(fResolvers)-1 do

      if fResolvers[i].TryResolve(aInterface,Obj) then

        exit;

  result := false;

end;



function TInterfaceResolverInjected.Implements(aInterface: PTypeInfo): boolean;

var i: integer;

begin

  result := true;

  if (self<>nil) and (aInterface<>nil) and (fResolvers<>nil) then

    for i := 0 to length(fResolvers)-1 do

      if fResolvers[i].Implements(aInterface) then

        exit;

  result := false;

end;



procedure TInterfaceResolverInjected.InjectStub(const aStubsByGUID: array of TGUID);

var i: integer;

begin

  for i := 0 to high(aStubsByGUID) do

    InjectResolver([TInterfaceStub.Create(aStubsByGUID[i])]);

end;



procedure TInterfaceResolverInjected.InjectResolver(

  const aOtherResolvers: array of TInterfaceResolver;

  OwnOtherResolvers: boolean);

var i: integer;

begin

  for i := 0 to high(aOtherResolvers) do

  if aOtherResolvers[i]<>nil then begin

    if aOtherResolvers[i].InheritsFrom(TInterfaceStub) then begin

      include(TInterfaceStub(aOtherResolvers[i]).fOptions,

        imoFakeInstanceWontReleaseTInterfaceStub);

      ObjArrayAdd(fResolversToBeReleased,aOtherResolvers[i]);

    end else

    if OwnOtherResolvers then

      ObjArrayAdd(fResolversToBeReleased,aOtherResolvers[i]);

    ObjArrayAddOnce(fResolvers,aOtherResolvers[i]);

  end;

end;



procedure TInterfaceResolverInjected.InjectInstance(

  const aDependencies: array of TInterfacedObject);

var i: integer;

begin

  for i := 0 to high(aDependencies) do

  if aDependencies[i]<>nil then begin

    IInterface(aDependencies[i])._AddRef; // Destroy will do _Release

    ObjArrayAdd(fDependencies,aDependencies[i]);

  end;

end;



destructor TInterfaceResolverInjected.Destroy;

var i: integer;

begin

  try

    ObjArrayClear(fResolversToBeReleased);

    for i := 0 to length(fDependencies)-1 do

      IInterface(fDependencies[i])._Release;

  finally

    inherited Destroy;

  end;

end;



function TInterfaceResolverInjected.Resolve(aInterface: PTypeInfo; out Obj): boolean;

begin

  if self=nil then

    result := false else

    result := TryResolve(aInterface,Obj);

end;



function TInterfaceResolverInjected.Resolve(const aGUID: TGUID; out Obj): boolean;

var known: TInterfaceFactory;

begin

  if self=nil then

    result := false else begin

    known := TInterfaceFactory.Get(aGUID);

    if known<>nil then

      result := Resolve(known.fInterfaceTypeInfo,Obj) else

      result := false;

  end;

end;



procedure TInterfaceResolverInjected.ResolveByPair(

  const aInterfaceObjPairs: array of pointer; aRaiseExceptionIfNotFound: boolean);

var n,i: integer;

begin

  n := length(aInterfaceObjPairs);

  if (n=0) or (n and 1=1) then

    raise EServiceException.CreateUTF8('%.Resolve([odd])',[self]);

  for i := 0 to (n shr 1)-1 do

    if not Resolve(aInterfaceObjPairs[i*2],aInterfaceObjPairs[i*2+1]^) then

      if aRaiseExceptionIfNotFound then

        raise EServiceException.CreateUTF8('%.ResolveByPair(%) unsatisfied',

          [self,PTypeInfo(aInterfaceObjPairs[i*2])^.Name]);

end;



procedure TInterfaceResolverInjected.Resolve(const aInterfaces: array of TGUID;

  const aObjs: array of pointer; aRaiseExceptionIfNotFound: boolean);

var n,i: integer;

    info: PTypeInfo;

begin

  n := length(aInterfaces);

  if (n=0) or (n<>length(aObjs)) then

    raise EServiceException.CreateUTF8('%.Resolve([?,?])',[self]);

  for i := 0 to n-1 do

  if PPointer(aObjs[i])^=nil then begin

    info := TInterfaceFactory.GUID2TypeInfo(aInterfaces[i]);

    if not Resolve(info,aObjs[i]^) then

      if aRaiseExceptionIfNotFound then

        raise EServiceException.CreateUTF8('%.Resolve(%) unsatisfied',[self,info^.Name]);

  end;

end;





{ TInjectableObject }



function TInjectableObject.TryResolve(aInterface: PTypeInfo; out Obj): boolean;

begin

  if (self<>nil) and (aInterface<>nil) and (fResolver<>nil) then

    result := fResolver.TryResolve(aInterface,Obj) else

    result := false;

end;



procedure TInjectableObject.Resolve(aInterface: PTypeInfo; out Obj);

begin

  if not TryResolve(aInterface,Obj) then

    raise EServiceException.CreateUTF8('%.Resolve(%) unsatisfied',[self,aInterface^.Name]);

end;



procedure TInjectableObject.Resolve(const aGUID: TGUID; out Obj);

var info: PTypeInfo;

begin

  info := TInterfaceFactory.GUID2TypeInfo(aGUID);

  if not TryResolve(info,Obj) then

    raise EServiceException.CreateUTF8(

      '%.Resolve(%): Interface not registered',[self,info^.Name]);

end;



procedure TInjectableObject.ResolveByPair(const aInterfaceObjPairs: array of pointer);

begin

  if fResolver.InheritsFrom(TInterfaceResolverInjected) then

    TInterfaceResolverInjected(fResolver).ResolveByPair(aInterfaceObjPairs) else

  if high(aInterfaceObjPairs)=1 then

    Resolve(aInterfaceObjPairs[0],aInterfaceObjPairs[1]^) else

    raise EServiceException.CreateUTF8('%.ResolveByPair(?)',[self]);

end;



procedure TInjectableObject.Resolve(const aInterfaces: array of TGUID;

  const aObjs: array of pointer);

begin

  if fResolver.InheritsFrom(TInterfaceResolverInjected) then

    TInterfaceResolverInjected(fResolver).Resolve(aInterfaces,aObjs) else

  if (high(aInterfaces)=0) and (high(aObjs)=0) then

    Resolve(aInterfaces[0],aObjs[0]^) else

    raise EServiceException.CreateUTF8('%.Resolve(?,?)',[self]);

end;



procedure TInjectableObject.AutoResolve(aRaiseEServiceExceptionIfNotFound: boolean);

var i: integer;

    CT: TClass;

    P: PPropInfo;

    addr: pointer;

begin

  if (self=nil) or (fResolver=nil) then

    raise EServiceException.CreateUTF8('%.AutoResolve with no prior registration',[self]);

  CT := ClassType;

  if CT<>TInjectableObject then

  repeat

    for i := 1 to InternalClassPropInfo(CT,P) do begin

      if P^.PropType^.Kind=tkInterface then

        if P^.GetterIsField then begin

          addr := P^.GetterAddr(self);

          if not TryResolve(P^.TypeInfo,addr^) then

            if aRaiseEServiceExceptionIfNotFound then

              raise EServiceException.CreateUTF8(

                '%.AutoResolve: impossible to resolve published property %: %',

                [self,P^.Name,P^.PropType^.Name]);

        end else

          raise EServiceException.CreateUTF8(

            '%.AutoResolve: published property %: % should directly read the field',

            [self,P^.Name,P^.PropType^.Name]);

      P := P^.Next;

    end;

    CT := CT.ClassParent;

  until CT=TInjectableObject;

end;



constructor TInjectableObject.CreateInjected(const aStubsByGUID: array of TGUID;

  const aOtherResolvers: array of TInterfaceResolver;

  const aDependencies: array of TInterfacedObject;

  aRaiseEServiceExceptionIfNotFound: boolean);

begin

  fResolver := TInterfaceResolverInjected.Create;

  fResolverOwned := true;

  TInterfaceResolverInjected(fResolver).InjectStub(aStubsByGUID);

  TInterfaceResolverInjected(fResolver).InjectResolver(aOtherResolvers);

  TInterfaceResolverInjected(fResolver).InjectInstance(aDependencies);

  Create;

  AutoResolve(aRaiseEServiceExceptionIfNotFound);

end;



constructor TInjectableObject.CreateWithResolver(aResolver: TInterfaceResolver;

  aRaiseEServiceExceptionIfNotFound: boolean);

begin

  if fResolver<>nil then

    exit; // inject once!

  if aResolver=nil then

    raise EServiceException.CreateUTF8('%.CreateWithResolver(nil)',[self]);

  fResolver := aResolver; // may be needed by overriden Create

  Create;

  AutoResolve(aRaiseEServiceExceptionIfNotFound);

end;



destructor TInjectableObject.Destroy;

begin

  inherited Destroy;

  CleanupInstance; // ensure creatures are released before their creator

  if fResolverOwned then

    FreeAndNil(fResolver); // let the creator move away

end;





{ TServiceFactory }



function TServiceFactory.GetInterfaceTypeInfo: PTypeInfo;

begin

  if (Self<>nil) and (fInterface<>nil) then

    result := fInterface.fInterfaceTypeInfo else

    result := nil;

end;



function TServiceFactory.GetInterfaceIID: TGUID;

begin

  result := fInterface.fInterfaceIID;

end;



constructor TServiceFactory.Create(aRest: TSQLRest;

  aInterface: PTypeInfo; aInstanceCreation: TServiceInstanceImplementation;

  const aContractExpected: RawUTF8);

var m,j: integer;

begin

  // check supplied interface

  if (aRest=nil) or (aInterface=nil) then

    raise EServiceException.CreateUTF8('Invalid %.Create(%,%)',[self,aRest,aInterface]);

  inherited Create;

  fInterface := TInterfaceFactory.Get(aInterface);

  fRest := aRest;

  fInstanceCreation := aInstanceCreation;

  fInterfaceMangledURI := BinToBase64URI(@fInterface.fInterfaceIID,sizeof(TGUID));

  fInterfaceURI := ToUTF8(aInterface^.Name);

  if fInterfaceURI[1] in ['I','i'] then

    delete(fInterfaceURI,1,1);

  if fRest.Model.GetTableIndex(fInterfaceURI)>=0 then

    raise EServiceException.CreateUTF8('%.Create: "%" interface name '+

      'is already used by a SQL table name',[self,fInterfaceURI]);

  for m := 0 to fInterface.fMethodsCount-1 do

  with fInterface.fMethods[m] do begin

    if ArgsResultIndex>=0 then

    with Args[ArgsResultIndex] do

    case ValueType of

    smvNone, smvObject, smvInterface:

      raise EServiceException.CreateUTF8('%.Create: %.% unexpected result type %',

        [self,fInterface.fInterfaceName,URI,ArgTypeName^]);

    smvRecord:

      if ArgTypeInfo=System.TypeInfo(TServiceCustomAnswer) then

        if InstanceCreation=sicClientDriven then

          raise EServiceException.CreateUTF8('%.Create: %.% '+

            'sicClientDriven mode not allowed with TServiceCustomAnswer result',

            [self,fInterface.fInterfaceName,URI]) else begin

        for j := ArgsOutFirst to ArgsOutLast do

          if Args[j].ValueDirection in [smdVar,smdOut] then

            raise EServiceException.CreateUTF8('%.Create: %.% '+

              'var/out parameter "%" not allowed with TServiceCustomAnswer result',

              [self,fInterface.fInterfaceName,URI,Args[j].ParamName^]);

        ArgsResultIsServiceCustomAnswer := true;

      end;

    end;

  end;

  SetLength(fExecution,fInterface.fMethodsCount);

  // compute interface signature (aka "contract"), serialized as a JSON object

  fContract := FormatUTF8('{"contract":"%","implementation":"%","methods":%}',

      [InterfaceURI,LowerCase(TrimLeftLowerCaseShort(ToText(InstanceCreation))),

       fInterface.fContract]);

  fContractHash := '"'+CardinalToHex(Hash32(fContract))+

    CardinalToHex(CRC32string(fContract))+'"'; // 2 hashes to avoid collision

  if aContractExpected<>'' then // override default contract

    fContractExpected := aContractExpected else

    fContractExpected := fContractHash; // for security

end;





{ TServiceContainerServer }



function TServiceContainerServer.AddImplementation(

  aImplementationClass: TInterfacedClass; const aInterfaces: array of PTypeInfo;

  aInstanceCreation: TServiceInstanceImplementation;

  aSharedImplementation: TInterfacedObject; const aContractExpected: RawUTF8): TServiceFactoryServer;

var C: TClass;

    T: PInterfaceTable;

    i, j: integer;

    UID: array of ^TGUID;

    F: TServiceFactoryServer;

begin

  result := nil;

  // check input parameters

  if (self=nil) or (aImplementationClass=nil) or (high(aInterfaces)<0) then

    exit;

  if aSharedImplementation<>nil then

    if (aSharedImplementation.ClassType<>aImplementationClass) or

       (aInstanceCreation<>sicShared) then

      raise EServiceException.CreateUTF8('%.AddImplementation: invalid % class',

        [self,aSharedImplementation]);

  CheckInterface(aInterfaces);

  SetLength(UID,length(aInterfaces));

  for j := 0 to high(aInterfaces) do

    UID[j] := pointer(aInterfaces[j]^.InterfaceGUID);

    //UID[j] := @PInterfaceTypeData(aInterfaces[j]^.ClassType)^.IntfGuid;

  // check that all interfaces are implemented by this class

  if (aSharedImplementation<>nil) and

     aSharedImplementation.InheritsFrom(TInterfacedObjectFake) then begin

    if IsEqualGUID(UID[0]^,TInterfacedObjectFake(aSharedImplementation).

        fFactory.fInterfaceIID) then

      UID[0] := nil; // mark TGUID implemented by this fake interface

  end else begin

    C := aImplementationClass; // search all implemented TGUID for this class

    repeat

      T := C.GetInterfaceTable;

      if T<>nil then

        for i := 0 to T^.EntryCount-1 do

          with T^.Entries[i] do

          for j := 0 to high(aInterfaces) do

            if (UID[j]<>nil) and IsEqualGUID(UID[j]^,IID{$ifdef FPC}^{$endif}) then begin

              UID[j] := nil; // mark TGUID found

              break;

            end;

      C := C.ClassParent;

    until C=nil;

  end;

  for j := 0 to high(aInterfaces) do

    if UID[j]<>nil then

      raise EServiceException.CreateUTF8('%.AddImplementation: % not found in %',

        [self,aInterfaces[j]^.Name,aImplementationClass]);

  // register this implementation class

  for j := 0 to high(aInterfaces) do begin

    F := TServiceFactoryServer.Create(Rest as TSQLRestServer,aInterfaces[j],

      aInstanceCreation,aImplementationClass,aContractExpected,1800,aSharedImplementation);

    if result=nil then begin

      result := F; // returns the first registered interface

      if (aInstanceCreation=sicShared) and (aSharedImplementation=nil) then

        aSharedImplementation := F.fSharedInstance; // re-use existing instance

    end;

    AddServiceInternal(F);

  end;

end;



procedure TServiceContainerServer.OnCloseSession(aSessionID: cardinal);

var i: Integer;

    Inst: TServiceFactoryServerInstance;

begin

  Inst.InstanceID := aSessionID;

  for i := 0 to Count-1 do

    with TServiceFactoryServer(Index(i)) do

    if InstanceCreation=sicPerSession then

      InternalInstanceRetrieve(Inst,SERVICE_METHODINDEX_FREEINSTANCE);

end;



destructor TServiceContainerServer.Destroy;

var i: integer;

begin

  if fFakeCallbacks<>nil then begin

    for i := 0 to fFakeCallbacks.Count-1 do // prevent GPF in Destroy

      TInterfacedObjectFakeServer(fFakeCallbacks.List[i]).fServer := nil;

    FreeAndNil(fFakeCallbacks); // do not own objects

  end;

  fRecordVersionCallback := nil; // to be done after fFakeCallbacks[].fServer := nil

  inherited Destroy;

end;



procedure TServiceContainerServer.FakeCallbackAdd(aFakeInstance: TObject);

begin

  if self=nil then

    exit;

  if fFakeCallbacks=nil then

    fFakeCallbacks := TObjectListLocked.Create(false);

  fFakeCallbacks.Safe.Lock;

  fFakeCallbacks.Add(aFakeInstance);

  fFakeCallbacks.Safe.UnLock;

end;



procedure TServiceContainerServer.FakeCallbackRemove(aFakeInstance: TObject);

var i,callbackID: integer;

    connectionID: Int64;

    fake: TInterfacedObjectFakeServer;

    server: TSQLRestServer;

begin

  if (self=nil) or (fFakeCallbacks=nil) then

    exit;

  connectionID := 0;

  callbackID := 0;

  fFakeCallbacks.Safe.Lock;

  try

    i := fFakeCallbacks.IndexOf(aFakeInstance);

    if i>=0 then begin

      fake := fFakeCallbacks.List[i];

      if not fake.fReleasedOnClientSide then begin

        connectionID := fake.fLowLevelConnectionID;

        callbackID := fake.ClientDrivenID;

        if Assigned(OnCallbackReleasedOnServerSide) then

          OnCallbackReleasedOnServerSide(self,fake,fake.fFakeInterface);

      end;

      fFakeCallbacks.Delete(i);

    end;

  finally

    fFakeCallbacks.Safe.UnLock;

  end;

  if connectionID<>0 then begin

    server := fRest as TSQLRestServer;

    if Assigned(server.OnNotifyCallback) then

      server.OnNotifyCallback(server,SERVICE_PSEUDO_METHOD[imFree],'',

        connectionID,callbackID,nil,nil);

  end;

end;



procedure TServiceContainerServer.FakeCallbackRelease(Ctxt: TSQLRestServerURIContext);

var i: integer;

    fake: TInterfacedObjectFakeServer;

    connectionID: Int64;

    fakeID: PtrUInt;

    Values: TNameValuePUTF8CharDynArray;

    withLog: boolean; // avoid stack overflow

begin

  if (self=nil) or (fFakeCallbacks=nil) or (Ctxt=nil) then

    exit;

  connectionID := Ctxt.Call^.LowLevelConnectionID;

  JSONDecode(pointer(Ctxt.Call^.InBody),Values);

  if length(Values)<>1 then

    exit;

  fakeID := GetCardinal(Values[0].Value);

  if (fakeID=0) or (connectionID=0) or (Values[0].Name=nil) then

    exit;

  withLog := not IdemPropNameU('ISynLogCallback',Values[0].Name,StrLen(Values[0].Name));

  if withLog then // avoid stack overflow ;)

    fRest.InternalLog('%.FakeCallbackRelease(%,"%") remote call',

      [ClassType,fakeID,Values[0].Name],sllDebug);

  try

    fFakeCallbacks.Safe.Lock;

    for i := 0 to fFakeCallbacks.Count-1 do begin

      fake := fFakeCallbacks.List[i];

      if (fake.fLowLevelConnectionID=connectionID) and

         (fake.ClientDrivenID=fakeID) then begin

        fake.fReleasedOnClientSide := true;

        if Assigned(OnCallbackReleasedOnClientSide) then

          OnCallbackReleasedOnClientSide(self,fake,fake.fFakeInterface);

        if fake.fService.fInterface.MethodIndexCallbackReleased>=0 then begin

          // emulate a call to CallbackReleased(callback,'ICallbackName')

          Ctxt.ServiceMethodIndex := fake.fService.fInterface.MethodIndexCallbackReleased;

          Ctxt.ServiceExecution := @fake.fService.fExecution[Ctxt.ServiceMethodIndex];

          Ctxt.Service := fake.fService;

          fake._AddRef; // IInvokable=pointer in Ctxt.ExecuteCallback

          Ctxt.ServiceParameters := pointer(FormatUTF8('[%,"%"]',

              [PtrInt(fake.fFakeInterface),Values[0].Name]));

          fake.fService.ExecuteMethod(Ctxt);

          if withLog then

            fRest.InternalLog('I%() returned %',[Ctxt.Service.fInterface.

              Methods[Ctxt.ServiceMethodIndex].InterfaceDotMethodName,

              Ctxt.Call^.OutStatus],sllDebug);

        end else

          Ctxt.Success;

        exit;

      end;

    end;

  finally

    fFakeCallbacks.Safe.UnLock;

  end;

end;



function TServiceContainerServer.RecordVersionSynchronizeSubscribeMaster(

  TableIndex: integer; RecordVersion: TRecordVersion;

  const SlaveCallback: IServiceRecordVersionCallback): boolean;

var instance: TObject;

begin

  result := false;

  if (self=nil) or (cardinal(TableIndex)>cardinal(fRest.Model.TablesMax)) then

    exit;

  fRest.fAcquireExecution[execORMWrite].fSafe.Lock;

  try

    if RecordVersion<>(fRest as TSQLRestServer).fRecordVersionMax then

      exit; // there are some missing items on the client side

    if fRecordVersionCallback=nil then

      SetLength(fRecordVersionCallback,fRest.Model.TablesMax+1);

    InterfaceArrayAdd(fRecordVersionCallback[TableIndex],SlaveCallback);

    instance := ObjectFromInterface(SlaveCallback);

    if (instance<>nil) and

       (instance.ClassType=TInterfacedObjectFakeServer) then

      TInterfacedObjectFakeServer(instance).fRaiseExceptionOnInvokeError := True;

  finally

    fRest.fAcquireExecution[execORMWrite].Safe.UnLock;

  end;

  result := true;

end;



class function TServiceContainerServer.CallbackReleasedOnClientSide(

  const callback: IInterface): boolean;

var instance: TObject;

begin

  instance := ObjectFromInterface(callback);

  result := (instance<>nil) and

            (instance.ClassType=TInterfacedObjectFakeServer) and

            TInterfacedObjectFakeServer(instance).fReleasedOnClientSide;

end;



procedure TServiceContainerServer.RecordVersionCallbackNotify(TableIndex: integer;

  Occasion: TSQLOccasion; const DeletedID: TID; const DeletedRevision: TRecordVersion;

  const AddUpdateJson: RawUTF8);

var i: integer;

    arr: ^IServiceRecordVersionCallbackDynArray;

begin

  try

    fRest.fAcquireExecution[execORMWrite].fSafe.Lock;

    try

      arr := @fRecordVersionCallback[TableIndex];

      for i := length(arr^)-1 downto 0 do // downto: InterfaceArrayDelete() below

        if CallbackReleasedOnClientSide(arr^[i]) then

          // automatic removal of any released callback

          InterfaceArrayDelete(arr^,i) else

          try

            case Occasion of

            soInsert: arr^[i].Added(AddUpdateJson);

            soUpdate: arr^[i].Updated(AddUpdateJson);

            soDelete: arr^[i].Deleted(DeletedID,DeletedRevision);

            end;

          except // on notification error -> delete this entry

            InterfaceArrayDelete(arr^,i);

          end;

    finally

      fRest.fAcquireExecution[execORMWrite].Safe.UnLock;

    end;

  except // ignore any exception here

  end;

end;



procedure TServiceContainerServer.RecordVersionNotifyAddUpdate(

  Occasion: TSQLOccasion; TableIndex: integer; const Document: TDocVariantData);

var json: RawUTF8;

begin

  if (Occasion in [soInsert,soUpdate]) and

     (fRecordVersionCallback<>nil) and

     (fRecordVersionCallback[TableIndex]<>nil) then begin

    json := Document.ToJSON;

    RecordVersionCallbackNotify(TableIndex,Occasion,0,0,json);

   end;

end;



procedure TServiceContainerServer.RecordVersionNotifyAddUpdate(

  Occasion: TSQLOccasion; TableIndex: integer; const Decoder: TJSONObjectDecoder);

var json: RawUTF8;

begin

  if (Occasion in [soInsert,soUpdate]) and

     (fRecordVersionCallback<>nil) and

     (fRecordVersionCallback[TableIndex]<>nil) then begin

    Decoder.EncodeAsJSON(json);

    RecordVersionCallbackNotify(TableIndex,Occasion,0,0,json);

   end;

end;



procedure TServiceContainerServer.RecordVersionNotifyDelete(

  TableIndex: integer; const ID: TID; const Revision: TRecordVersion);

begin

  if (fRecordVersionCallback<>nil) and

     (fRecordVersionCallback[TableIndex]<>nil) then

    RecordVersionCallbackNotify(TableIndex,soDelete,ID,Revision,'');

end;



procedure TServiceContainerServer.SetServiceLog(aLogRest: TSQLRest;

  aLogClass: TSQLRecordServiceLogClass; const aExcludedMethodNamesCSV: RawUTF8);

var i,n: integer;

    fact: TServiceFactory;

    excluded: TServiceContainerInterfaceMethodBits;

    methods: TInterfaceFactoryMethodBits;

    somemethods: boolean;

begin

  somemethods := aExcludedMethodNamesCSV<>'';

  if somemethods then

    SetInterfaceMethodBits(pointer(aExcludedMethodNamesCSV),true,excluded) else

    FillcharFast(methods,sizeof(methods),255);

  n := fListInterfaceMethods.Count;

  i := 0;

  while i<n do begin

    fact := fListInterfaceMethod[i].InterfaceService;

    if somemethods then begin

      FillcharFast(methods,sizeof(methods),0);

      somemethods := false;

    end;

    repeat

      if (aExcludedMethodNamesCSV<>'') and not (i in excluded) then begin

        include(methods,fListInterfaceMethod[i].

          InterfaceMethodIndex-SERVICE_PSEUDO_METHOD_COUNT);

        somemethods := true;

      end;

      inc(i);

    until (i>=n) or (fListInterfaceMethod[i].InterfaceService<>fact);

    if (aExcludedMethodNamesCSV='') or somemethods then

      TServiceFactoryServer(fact).SetServiceLogByIndex(methods,aLogRest,aLogClass);

  end;

end;





{ TServiceFactoryServer }



type

  PCallMethodArgs = ^TCallMethodArgs;

  {$ifdef FPC}

  {$PACKRECORDS 16}

  {$endif}

  TCallMethodArgs = record

    StackSize: integer;

    StackAddr, method: PtrInt;

    ParamRegs: packed array[PARAMREG_FIRST..PARAMREG_LAST] of PtrInt;

    {$ifdef HAS_FPREG}

    FPRegs: packed array[FPREG_FIRST..FPREG_LAST] of Double;

    {$endif}

    res64: Int64Rec;

    resKind: TServiceMethodValueType;

  end;

  {$ifdef FPC}

  {$PACKRECORDS DEFAULT}

  {$endif}



procedure CallMethod(var Args: TCallMethodArgs);



// ARM/AARCH64 code below provided by ALF, greatly inspired by pascalscript

{$ifdef CPUARM}

assembler; nostackframe;

label stack_loop,load_regs,asmcall_end,float_result;

asm

   //name  r#(normally, darwin can differ)

   //a1    0           argument 1 / integer result / scratch register

   //a2    1           argument 2 / scratch register

   //a3    2           argument 3 / scratch register

   //a4    3           argument 4 / scratch register

   //v1    4           register variable

   //v2    5           register variable

   //v3    6           register variable

   //v4    7           register variable

   //v5    8           register variable

   //sb    9           static base / register variable

   //sl    10          stack limit / stack chunk handle / reg. variable

   //fp    11          frame pointer

   //ip    12          scratch register / new-sb in inter-link-unit calls

   //sp    13          lower end of current stack frame

   //lr    14          link address / scratch register

   //pc    15          program counter



   // prolog

   mov	 ip, sp // sp is the stack pointer ; ip is the Intra-Procedure-call scratch register

   stmfd sp!, {v1, v2, sb, sl, fp, ip, lr, pc}

   sub	 fp, ip, #4

   // make space on stack

   sub	 sp, sp, #MAX_EXECSTACK

   mov   v2, Args

   // copy (push) stack content (if any)

   ldr   a1, [v2,#TCallMethodArgs.StackSize]

   // if there is no stack content, do nothing

   cmp  a1, #0

   beq  load_regs

   // point a2 to bottom of stack.

   mov  a2, sp

   // load a3 with CallMethod stack address

   ldr  a3, [v2,#TCallMethodArgs.StackAddr]

stack_loop:

   // copy a3 to a4 and increment a3 (a3 = StackAddr)

   ldmia a3!, {a4}

   // copy a4 to a2 and increment a2 (a2 = StackPointer)

   stmia a2!, {a4}

   // decrement stacksize counter, with update of flags for loop

   subs  a1, a1, #1

   bne  stack_loop

load_regs:

   ldr   r0, [v2,#TCallMethodArgs.ParamRegs+REGR0*4-4]

   ldr   r1, [v2,#TCallMethodArgs.ParamRegs+REGR1*4-4]

   ldr   r2, [v2,#TCallMethodArgs.ParamRegs+REGR2*4-4]

   ldr   r3, [v2,#TCallMethodArgs.ParamRegs+REGR3*4-4]

   vldr  d0, [v2,#TCallMethodArgs.FPRegs+REGD0*8-8]

   vldr  d1, [v2,#TCallMethodArgs.FPRegs+REGD1*8-8]

   vldr  d2, [v2,#TCallMethodArgs.FPRegs+REGD2*8-8]

   vldr  d3, [v2,#TCallMethodArgs.FPRegs+REGD3*8-8]

   vldr  d4, [v2,#TCallMethodArgs.FPRegs+REGD4*8-8]

   vldr  d5, [v2,#TCallMethodArgs.FPRegs+REGD5*8-8]

   vldr  d6, [v2,#TCallMethodArgs.FPRegs+REGD6*8-8]

   vldr  d7, [v2,#TCallMethodArgs.FPRegs+REGD7*8-8]

   ldr   v1, [v2,#TCallMethodArgs.method]

   blx   v1

   str   a1, [v2,#TCallMethodArgs.res64.Lo]

   str   a2, [v2,#TCallMethodArgs.res64.Hi]

   ldr   a3, [v2,#TCallMethodArgs.resKind]

   cmp   a3, smvDouble

   beq   float_result

   cmp   a3, smvDateTime

   beq   float_result

   cmp   a3, smvCurrency

   bne   asmcall_end

   // store double result in res64

float_result:

   vstr  d0, [v2,#TCallMethodArgs.res64]

asmcall_end:

   // epilog

   ldmea fp, {v1, v2, sb, sl, fp, sp, pc}

end;

{$endif CPUARM}



{$ifdef CPUAARCH64}

assembler; nostackframe;

label stack_loop,load_regs,asmcall_end,float_result;

asm

   // inspired by pascal script

   // fp       x29

   // lr       x30

   // sp       sp

   stp	fp, lr, [sp, #-16]!

   stp	x19, x20, [sp, #-16]!

   mov	fp, sp

   // make space on stack

   sub	sp, sp, #MAX_EXECSTACK

   mov  x19, Args

   ldr  x20, [x19,#TCallMethodArgs.method]

   // prepare to copy (push) stack content (if any)

   ldr  x2, [x19,#TCallMethodArgs.StackSize]

   // if there is no stack content, do nothing

   cmp	x2, #0

   b.eq	load_regs

   // point x3 to bottom of stack.

   mov	x3, sp

   // load x4 with CallMethod stack address

   ldr	x4, [x19,#TCallMethodArgs.StackAddr]

stack_loop:

   // load x5 and x6 with stack contents

   ldr  x5, [x4]

   ldr  x6, [x4,#8]

   // store contents at "real" stack and increment address counter x3

   stp	x5, x6, [x3], #16

   // with update of flags for loop

   // (mandatory: stacksize must be a multiple of 2 [16 bytes] !!)

   // inc stackaddr counter by 16 (2 registers are pushed every loop)

   add	x4, x4, #16

   // decrement stacksize counter by 2 (2 registers are pushed every loop),

   // with update of flags for loop

   subs	x2, x2, #2

   b.ne stack_loop

load_regs:

   ldr  x0, [x19,#TCallMethodArgs.ParamRegs+REGX0*8-8]

   ldr  x1, [x19,#TCallMethodArgs.ParamRegs+REGX1*8-8]

   ldr  x2, [x19,#TCallMethodArgs.ParamRegs+REGX2*8-8]

   ldr  x3, [x19,#TCallMethodArgs.ParamRegs+REGX3*8-8]

   ldr  x4, [x19,#TCallMethodArgs.ParamRegs+REGX4*8-8]

   ldr  x5, [x19,#TCallMethodArgs.ParamRegs+REGX5*8-8]

   ldr  x6, [x19,#TCallMethodArgs.ParamRegs+REGX6*8-8]

   ldr  x7, [x19,#TCallMethodArgs.ParamRegs+REGX7*8-8]

   ldr  d0, [x19,#TCallMethodArgs.FPRegs+REGD0*8-8]

   ldr  d1, [x19,#TCallMethodArgs.FPRegs+REGD1*8-8]

   ldr  d2, [x19,#TCallMethodArgs.FPRegs+REGD2*8-8]

   ldr  d3, [x19,#TCallMethodArgs.FPRegs+REGD3*8-8]

   ldr  d4, [x19,#TCallMethodArgs.FPRegs+REGD4*8-8]

   ldr  d5, [x19,#TCallMethodArgs.FPRegs+REGD5*8-8]

   ldr  d6, [x19,#TCallMethodArgs.FPRegs+REGD6*8-8]

   ldr  d7, [x19,#TCallMethodArgs.FPRegs+REGD7*8-8]

   // call TCallMethodArgs.method

   blr  x20

   // store normal result

   str  x0, [x19, #TCallMethodArgs.res64]

   ldr  x20, [x19, #TCallMethodArgs.resKind]

   cmp  x20, smvDouble

   b.eq float_result

   cmp  x20, smvDateTime

   b.eq float_result

   cmp  x20, smvCurrency

   b.ne asmcall_end

   // store double result in res64

float_result:

   str  d0, [x19,#TCallMethodArgs.res64]

asmcall_end:

   // give back space on stack (add sp,sp,#MAX_EXECSTACK)

   mov	sp, fp

   ldp	x19, x20, [sp], #16

   ldp	fp, lr, [sp], #16

   ret

end;

{$endif CPUAARCH64}



{$ifdef CPUX64} assembler;

{$ifdef FPC}

  nostackframe;

asm

    push rbp

    push r12

    mov rbp,rsp

    // simulate .params 60 ... size for 60 parameters

    lea rsp,[rsp-MAX_EXECSTACK]

    // align stack

    and rsp, -16

{$else DELPHI} // ensure we use regular .params command for easier debugging

asm

    .params 64    // size for 64 parameters

    .pushnv r12   // generate prolog+epilog to save and restore non-volatile r12

{$endif FPC}

    // get Args

    mov r12, Args

    // copy (push) stack content (if any)

    mov ecx, [r12].TCallMethodArgs.StackSize

    mov rdx, [r12].TCallMethodArgs.StackAddr

    jmp @checkstack

@addstack:

    push qword ptr [rdx]

    dec ecx

    sub rdx,8

@checkstack:

    or ecx, ecx

    jnz @addstack

    // fill registers and call method

    {$ifdef LINUX}

    // Linux/BSD System V AMD64 ABI

    mov rdi, [r12+TCallMethodArgs.ParamRegs+REGRDI*8-8]

    mov rsi, [r12+TCallMethodArgs.ParamRegs+REGRSI*8-8]

    mov rdx, [r12+TCallMethodArgs.ParamRegs+REGRDX *8-8]

    mov rcx, [r12+TCallMethodArgs.ParamRegs+REGRCX *8-8]

    mov r8, [r12+TCallMethodArgs.ParamRegs+REGR8*8-8]

    mov r9, [r12+TCallMethodArgs.ParamRegs+REGR9*8-8]

    movsd xmm0, qword ptr [r12+TCallMethodArgs.FPRegs+REGXMM0*8-8]

    movsd xmm1, qword ptr [r12+TCallMethodArgs.FPRegs+REGXMM1*8-8]

    movsd xmm2, qword ptr [r12+TCallMethodArgs.FPRegs+REGXMM2*8-8]

    movsd xmm3, qword ptr [r12+TCallMethodArgs.FPRegs+REGXMM3*8-8]

    movsd xmm4, qword ptr [r12+TCallMethodArgs.FPRegs+REGXMM4*8-8]

    movsd xmm5, qword ptr [r12+TCallMethodArgs.FPRegs+REGXMM5*8-8]

    movsd xmm6, qword ptr [r12+TCallMethodArgs.FPRegs+REGXMM6*8-8]

    movsd xmm7, qword ptr [r12+TCallMethodArgs.FPRegs+REGXMM7*8-8]

    call [r12].TCallMethodArgs.method

    {$else}

    // Win64 ABI

    mov rcx, [r12+TCallMethodArgs.ParamRegs+REGRCX*8-8]

    mov rdx, [r12+TCallMethodArgs.ParamRegs+REGRDX*8-8]

    mov r8, [r12+TCallMethodArgs.ParamRegs+REGR8 *8-8]

    mov r9, [r12+TCallMethodArgs.ParamRegs+REGR9 *8-8]

    movsd xmm0, qword ptr [r12+TCallMethodArgs.FPRegs+REGXMM0*8-8]

    movsd xmm1, qword ptr [r12+TCallMethodArgs.FPRegs+REGXMM1*8-8]

    movsd xmm2, qword ptr [r12+TCallMethodArgs.FPRegs+REGXMM2*8-8]

    movsd xmm3, qword ptr [r12+TCallMethodArgs.FPRegs+REGXMM3*8-8]

    sub rsp,8*4   // reserve shadow-space for RCX,RDX,R8,R9 registers

    call [r12].TCallMethodArgs.method

    add rsp,8*4

    {$endif LINUX}

    // retrieve result

    mov [r12].TCallMethodArgs.res64, rax

    mov cl, [r12].TCallMethodArgs.resKind

    cmp cl, smvDouble

    je @d

    cmp cl, smvDateTime

    je @d

    cmp cl, smvCurrency

    jne @e

@d: movlpd qword ptr [r12].TCallMethodArgs.res64, xmm0

@e:

{$ifdef FPC}

    mov rsp, rbp

    pop r12

    pop rbp

{$endif}

end;

{$endif CPUX64}



{$ifdef CPUX86}

asm

    push esi

    push ebp

    mov ebp,esp

    mov esi,Args

    // copy stack content (if any)

    mov eax,[esi].TCallMethodArgs.StackSize

    mov edx,dword ptr [esi].TCallMethodArgs.StackAddr

    add edx,eax // pascal/register convention = left-to-right

    shr eax,2

    jz @z

@n: sub edx,4

    mov ecx,[edx]

    push ecx

    dec eax

    jnz @n

    // call method

@z: mov eax,[esi+TCallMethodArgs.ParamRegs+REGEAX*4-4]

    mov edx,[esi+TCallMethodArgs.ParamRegs+REGEDX*4-4]

    mov ecx,[esi+TCallMethodArgs.ParamRegs+REGECX*4-4]

    call [esi].TCallMethodArgs.method

    // retrieve result

    mov cl,[esi].TCallMethodArgs.resKind

    cmp cl,smvDouble

    je @d

    cmp cl,smvDateTime

    je @d

    cmp cl,smvCurrency

    jne @i

    fistp qword [esi].TCallMethodArgs.res64

    jmp @e

@d: fstp qword [esi].TCallMethodArgs.res64

    jmp @e

@i: mov [esi].TCallMethodArgs.res64.Lo,eax

    mov [esi].TCallMethodArgs.res64.Hi,edx

@e: mov esp,ebp

    pop ebp

    pop esi

end;

{$endif CPUX86}



procedure BackgroundExecuteProc(Call: pointer);

var synch: PBackgroundLauncher absolute Call;

    threadContext: PServiceRunningContext;

    backup: TServiceRunningContext;

begin

  threadContext := @ServiceContext; // faster to use a pointer than GetTls()

  backup := threadContext^;

  threadContext^.Factory := synch^.Context^.Factory;

  threadContext^.Request := synch^.Context^.Request;

  try

    case synch^.Action of

    doCallMethod:

      CallMethod(PCallMethodArgs(synch^.CallMethodArgs)^);

    doInstanceRelease:

      synch^.Instance.InternalRelease;

    doThreadMethod:

      synch^.ThreadMethod;

    end;

  finally

    threadContext^ := backup;

  end;

end;



constructor TServiceFactoryServer.Create(aRestServer: TSQLRestServer; aInterface: PTypeInfo;

  aInstanceCreation: TServiceInstanceImplementation;

  aImplementationClass: TInterfacedClass; const aContractExpected: RawUTF8;

  aTimeOutSec: cardinal; aSharedInstance: TInterfacedObject);

begin

  // extract RTTI from the interface

  if aInstanceCreation<>sicPerThread then

    InitializeCriticalSection(fInstanceLock);

  inherited Create(aRestServer,aInterface,aInstanceCreation,aContractExpected);

  if fRest.MethodAddress(ShortString(InterfaceURI))<>nil then

    raise EServiceException.CreateUTF8('%.Create: I% already exposed as % published method',

      [self,InterfaceURI,fRest]) else

  fImplementationClass := aImplementationClass;

  if fImplementationClass.InheritsFrom(TInterfacedObjectFake) then begin

    fImplementationClassKind := ickFake;

    if aSharedInstance=nil then

      raise EServiceException.CreateUTF8('%.Create: no Shared Instance for %/I%',

        [self,fImplementationClass,fInterfaceURI]);

    if (aSharedInstance as TInterfacedObjectFake).Factory.fInterfaceTypeInfo<>aInterface then

      raise EServiceException.CreateUTF8('%.Create: shared % instance does not implement I%',

        [self,fImplementationClass,fInterfaceURI]) else

  end else begin

    if aRestServer.Services.Implements(fInterface.fInterfaceTypeInfo) then

      fImplementationClassKind := ickFromInjectedResolver else

    if fImplementationClass.InheritsFrom(TInjectableObjectRest) then

      fImplementationClassKind := ickInjectableRest else

    if fImplementationClass.InheritsFrom(TInjectableObject) then

      fImplementationClassKind := ickInjectable else

    if fImplementationClass.InheritsFrom(TInterfacedObjectWithCustomCreate) then

      fImplementationClassKind := ickWithCustomCreate;

    fImplementationClassInterfaceEntry :=

      fImplementationClass.GetInterfaceEntry(fInterface.fInterfaceIID);

    if fImplementationClassInterfaceEntry=nil then

      raise EServiceException.CreateUTF8('%.Create: % does not implement I%',

        [self,fImplementationClass,fInterfaceURI]) else

  end;

  if (fInterface.MethodIndexCallbackReleased>=0) and

     (InstanceCreation<>sicShared) then

    raise EServiceException.CreateUTF8('%.Create: I%() should be run as sicShared',

      [self,fInterface.fMethods[fInterface.MethodIndexCallbackReleased].

       InterfaceDotMethodName]);

  // initialize the shared instance or client driven parameters

  case InstanceCreation of

  sicShared: begin

    if aSharedInstance=nil then

      fSharedInstance := CreateInstance(false) else

      if aSharedInstance.InheritsFrom(fImplementationClass) then

        fSharedInstance := aSharedInstance else

        raise EServiceException.CreateUTF8('%.Create: % shared instance '+

          'does not inherit from %',[self,aSharedInstance,fImplementationClass]);

    if fImplementationClassKind<>ickFake then

      if (fSharedInstance=nil) or

         not GetInterfaceFromEntry(

           fSharedInstance,fImplementationClassInterfaceEntry,fSharedInterface) then

        raise EServiceException.CreateUTF8('%.Create: % is no implementation of I%',

          [self,fSharedInstance,fInterfaceURI]);

  end;

  sicClientDriven, sicPerSession, sicPerUser, sicPerGroup, sicPerThread:

    if (aTimeOutSec=0) and (InstanceCreation<>sicPerThread) then

      fInstanceCreation := sicSingle else begin

      // only instances list is protected, since client calls shall be pipelined

      fInstance.InitSpecific(TypeInfo(TServiceFactoryServerInstanceDynArray),

        fInstances,djCardinal,@fInstancesCount); // sort by InstanceID: cardinal

      fInstanceTimeOut := aTimeOutSec*1000;

    end;

  end;

  SetLength(fStats,fInterface.MethodsCount);

end;



procedure TServiceFactoryServer.SetTimeoutSecInt(value: cardinal);

begin

  if (self=nil) or not (InstanceCreation in [

     sicClientDriven,sicPerSession,sicPerUser,sicPerGroup,sicPerThread]) then

    raise EServiceException.CreateUTF8('%.SetTimeoutSecInt() with %',

      [self,ToText(InstanceCreation)^]);

  fInstanceTimeOut := value*1000;

end;



function TServiceFactoryServer.GetTimeoutSec: cardinal;

begin

  if (self=nil) or not (InstanceCreation in [

     sicClientDriven,sicPerSession,sicPerUser,sicPerGroup,sicPerThread]) then

    result := 0 else

    result := fInstanceTimeout div 1000;

end;



function TServiceFactoryServer.GetStat(const aMethod: RawUTF8): TSynMonitorInputOutput;

begin

  result := fStats[fInterface.CheckMethodIndex(aMethod)];

end;



destructor TServiceFactoryServer.Destroy;

var i: integer;

begin

  try

    for i := 0 to High(fLogRestBatch) do begin

      with fLogRestBatch[i] do begin

        Safe.Lock;

        try

          if Count>0 then

            Rest.BatchSend(fLogRestBatch[i]);

        finally

          Safe.Unlock;

        end;

      end;

      FreeAndNil(fLogRestBatch[i]);

    end;

    if InstanceCreation<>sicPerThread then

      EnterCriticalSection(fInstanceLock);

    try // release any internal instance (should have been done by client)

      try

        for i := 0 to fInstancesCount-1 do

          if fInstances[i].Instance<>nil then

            fInstances[i].SafeFreeInstance(self);

      finally

        {$ifndef LVCL}

        FreeAndNil(fBackgroundThread);

        {$endif}

      end;

    except

      ; // better ignore any error in business logic code

    end;

  finally

    if InstanceCreation<>sicPerThread then

      LeaveCriticalSection(fInstanceLock);

  end;

  if InstanceCreation<>sicPerThread then

    DeleteCriticalSection(fInstanceLock);

  ObjArrayClear(fStats);

  inherited;

end;



function TServiceFactoryServer.Get(out Obj): Boolean;

var Inst: TServiceFactoryServerInstance;

begin

  result := false;

  if self=nil then

    exit;

  case fInstanceCreation of

  sicShared:

  if fSharedInterface<>nil then begin

    IInterface(Obj) := fSharedInterface; // copy implementation interface

    result := true;

  end;

  sicPerThread: begin

    Inst.Instance := nil;

    Inst.InstanceID := PtrUInt(GetCurrentThreadId);

    if not InternalInstanceRetrieve(Inst,0) and (Inst.Instance<>nil) then

      result := GetInterfaceFromEntry(Inst.Instance,fImplementationClassInterfaceEntry,Obj);

  end;

  else begin // no user/group/session on pure server-side -> always sicSingle

    Inst.Instance := CreateInstance(false);

    if Inst.Instance<>nil then

      result := GetInterfaceFromEntry(Inst.Instance,fImplementationClassInterfaceEntry,Obj);

  end;

  end;

  if result then

    with PServiceRunningContext(@ServiceContext)^ do

      if Factory=nil then

        Factory := self;

end;



function TServiceFactoryServer.RetrieveSignature: RawUTF8;

begin

  if self=nil then

    result := '' else

    result := Contract; // just return the current value

end;



procedure TServiceFactoryServerInstance.SafeFreeInstance(Factory: TServiceFactoryServer);

var Obj: TInterfacedObject;

begin

  InstanceID := 0;

  Obj := Instance;

  Instance := nil;

  {$ifndef LVCL}

  if (optFreeInMainThread in Factory.fAnyOptions) and

     (GetCurrentThreadID<>MainThreadID) then

    BackgroundExecuteInstanceRelease(Obj,nil) else

  {$endif}

  if (optFreeInPerInterfaceThread in Factory.fAnyOptions) and

     Assigned(Factory.fBackgroundThread) then

    BackgroundExecuteInstanceRelease(Obj,Factory.fBackgroundThread) else

    IInterface(Obj)._Release;

end;



function TServiceFactoryServer.InternalInstanceRetrieve(

  var Inst: TServiceFactoryServerInstance; aMethodIndex: integer): boolean;

procedure AddNew;

var i: integer;

    P: ^TServiceFactoryServerInstance;

begin

  Inst.Instance := CreateInstance(true);

  if Inst.Instance=nil then

    exit;

  fRest.InternalLog('%.InternalInstanceRetrieve: Adding % instance (id=%)',

    [ClassType,fInterfaceURI,Inst.InstanceID],sllDebug);

  P := pointer(fInstances);

  for i := 1 to fInstancesCount do

    if P^.InstanceID=0 then begin

      P^ := Inst; // found an empty entry -> re-use it

      exit;

    end else

    inc(P);

  fInstance.Add(Inst); // append a new entry

end;

var i: integer;

begin

  result := false;

  if InstanceCreation<>sicPerThread then

    EnterCriticalSection(fInstanceLock);

  try

    Inst.LastAccess64 := GetTickCount64;

    // first release any deprecated instances

    if fInstanceTimeout<>0 then

    for i := fInstancesCount-1 downto 0 do

      with fInstances[i] do

      if InstanceID<>0 then

      if Inst.LastAccess64>LastAccess64+fInstanceTimeout then begin

        // deprecated -> mark this entry as empty

        fRest.InternalLog(

          '%.InternalInstanceRetrieve: Deleted % instance (id=%) after % ms timeout (max % ms)',

          [ClassType,fInterfaceURI,InstanceID,Inst.LastAccess64-LastAccess64,fInstanceTimeOut],sllDebug);

        SafeFreeInstance(self);

      end;

    if Inst.InstanceID=0 then begin

      // retrieve or initialize a sicClientDriven instance

      if (cardinal(aMethodIndex)>=fInterface.fMethodsCount) or

         (InstanceCreation<>sicClientDriven) then

        exit;

      // initialize the new instance

      inc(fInstanceCurrentID);

      Inst.InstanceID := fInstanceCurrentID;

      AddNew;

    end else begin

      // search the instance corresponding to Inst.InstanceID

      for i := 0 to fInstancesCount-1 do

        with fInstances[i] do

        if InstanceID=Inst.InstanceID then begin

          if aMethodIndex=SERVICE_METHODINDEX_FREEINSTANCE then begin

            // aMethodIndex=-1 for {"method":"_free_", "params":[], "id":1234}

            SafeFreeInstance(self);

            result := true; // notify caller that successfully released instance

            exit;

          end;

          LastAccess64 := Inst.LastAccess64;

          Inst.Instance := Instance;

          exit;

        end;

      // add any new session/user/group instance if necessary

      if (InstanceCreation<>sicClientDriven) and

         (cardinal(aMethodIndex)<fInterface.fMethodsCount) then

        AddNew;

    end;

  finally

    if InstanceCreation<>sicPerThread then

      LeaveCriticalSection(fInstanceLock);

  end;

end;



function TServiceFactoryServer.RestServer: TSQLRestServer;

begin

  if self<>nil then

    result := TSQLRestServer(fRest) else

    result := nil;

end;



function TServiceFactoryServer.CreateInstance(AndIncreaseRefCount: boolean): TInterfacedObject;

var dummyObj: pointer;

begin

  case fImplementationClassKind of

  ickWithCustomCreate:

    result := TInterfacedObjectWithCustomCreateClass(fImplementationClass).Create;

  ickInjectable, ickInjectableRest: begin

    result := TInjectableObjectClass(fImplementationClass).

       CreateWithResolver(Rest.Services,true);

    if fImplementationClassKind=ickInjectableRest then begin

      TInjectableObjectRest(result).fFactory := self;

      TInjectableObjectRest(result).fServer := RestServer;

    end;

  end;

  ickFromInjectedResolver: begin

    dummyObj := nil;

    if not TSQLRestServer(Rest).Services.

       TryResolveInternal(fInterface.fInterfaceTypeInfo,dummyObj) then

      raise EInterfaceFactoryException.CreateUTF8(

        'ickFromInjectedResolver: TryResolveInternal(%)=false',

        [fInterface.fInterfaceName]);

    result := TInterfacedObject(ObjectFromInterface(IInterface(dummyObj)));

    if AndIncreaseRefCount then // RefCount=1 after TryResolveInternal() 

      AndIncreaseRefCount := false else

      dec(TInterfacedObjectHooked(result).FRefCount);

  end;

  else

    result := fImplementationClass.Create;

  end;

  if Assigned(TSQLRestServer(Rest).OnServiceCreateInstance) then

    TSQLRestServer(Rest).OnServiceCreateInstance(self,result);

  if AndIncreaseRefCount then

    IInterface(result)._AddRef; // allow passing self to sub-methods

end;



procedure TServiceFactoryServer.OnLogRestExecuteMethod(Sender: TServiceMethodExecute;

  Step: TServiceMethodExecuteEventStep);

var W: TTextWriter;

    a: integer;

begin

  W := Sender.TempTextWriter;

  with Sender.Method^ do

    case Step of

    smsBefore: begin

      W.CancelAll;

      W.AddShort('"POST",{Method:"');

      W.AddString(InterfaceDotMethodName);

      W.AddShort('",Input:{'); // as TSQLPropInfoRTTIVariant.GetJSONValues

      if optNoLogInput in Sender.fOptions then

        W.AddShort('optNoLogInput: true') else

        for a := ArgsInFirst to ArgsInLast do

        with Args[a] do

        if (ValueDirection<>smdOut) and (ValueType<>smvInterface) then begin

          W.AddShort(ParamName^); // in JSON_OPTIONS_FAST_EXTENDED format

          W.Add(':');

          AddJSON(W,Sender.Values[a]);

        end;

      W.CancelLastComma;

    end;

    smsAfter: begin

      W.AddShort('},Output:{');

      if optNoLogOutput in Sender.fOptions then

        W.AddShort('optNoLogOutput: true') else

        for a := ArgsOutFirst to ArgsOutLast do

        with Args[a] do

        if ValueDirection in [smdVar,smdOut,smdResult] then begin

          W.AddShort(ParamName^);

          W.Add(':');

          AddJSON(W,Sender.Values[a]);

        end;

      W.CancelLastComma;

    end;

    smsError: begin

      W.AddShort('},Output:{');

      W.AddClassName(Sender.LastException.ClassType);

      W.Add(':','"');

      W.AddJSONEscapeString(Sender.LastException.Message);

      W.Add('"');

    end;

    end;

end;



procedure TServiceFactoryServer.ExecuteMethod(Ctxt: TSQLRestServerURIContext);

var Inst: TServiceFactoryServerInstance;

    WR: TJSONSerializer;

    entry: PInterfaceEntry;

    instancePtr: pointer;

    dolock: boolean;

    exec: TServiceMethodExecute;

    timeStart,timeEnd: Int64;

    stats: TSynMonitorInputOutput;

    m: integer;



  function GetFullMethodName: RawUTF8;

  begin

    if cardinal(Ctxt.ServiceMethodIndex)<fInterface.fMethodsCount then

      result := fInterface.fMethods[Ctxt.ServiceMethodIndex].InterfaceDotMethodName else

      result := fInterface.fInterfaceName;

  end;

  procedure Error(const Msg: RawUTF8; Status: integer=HTML_BADREQUEST);

  begin

    Ctxt.Error('(%) % for %',[ToText(InstanceCreation)^,Msg,GetFullMethodName],Status);

  end;

  function StatsCreate: TSynMonitorInputOutput;

  begin

    result := TSynMonitorInputOutput.Create(GetFullMethodName);

  end;

  procedure FinalizeLogRest;

  var W: TTextWriter;

      context: PServiceRunningContext;

  begin

    W := exec.TempTextWriter;

    if exec.CurrentStep<smsBefore then begin

      W.CancelAll;

      W.Add('"POST",{Method:"%",Input:{',[exec.Method^.InterfaceDotMethodName]);

    end;

    if exec.CurrentStep<smsAfter then

      W.AddShort('},Output:{Failed:"Probably due to wrong input"');

    W.Add('},Session:%,User:%,Time:%,MicroSec:%},',

      [integer(Ctxt.Session),Ctxt.SessionUser,TimeLogNowUTC,timeEnd]);

    with Ctxt.ServiceExecution^ do

    try

      LogRestBatch.Safe.Lock;

      LogRestBatch.RawAppend.AddNoJSONEscape(W);

      if (LogRestBatch.Count>=500) or // write every second or after 500 rows

         (GetTickCount64-LogRestBatch.ResetTix>1000) then begin

        context := @ServiceContext;

        context^.Request := nil; // avoid IsNotAllowed unexpected failure

        try

          LogRest.BatchSend(LogRestBatch);

          LogRestBatch.Reset;

        finally

          context^.Request := Ctxt;

        end;

      end;

    finally

      LogRestBatch.Safe.UnLock;

    end;

  end;



begin

  if mlInterfaces in TSQLRestServer(Rest).StatLevels then

    QueryPerformanceCounter(timeStart);

  // 1. initialize Inst.Instance and Inst.InstanceID

  Inst.InstanceID := 0;

  Inst.Instance := nil;

  case InstanceCreation of

    sicSingle:

      Inst.Instance := CreateInstance(true);

    sicShared:

      Inst.Instance := fSharedInstance;

    sicClientDriven, sicPerSession, sicPerUser, sicPerGroup, sicPerThread: begin

      case InstanceCreation of

      sicClientDriven:

        Inst.InstanceID := Ctxt.ServiceInstanceID;

      sicPerThread:

        Inst.InstanceID := PtrUInt(GetCurrentThreadId);

      else

        if Ctxt.Session>CONST_AUTHENTICATION_NOT_USED then

          case InstanceCreation of // authenticated user -> handle context

          sicPerSession: Inst.InstanceID := Ctxt.Session;

          sicPerUser:    Inst.InstanceID := Ctxt.SessionUser;

          sicPerGroup:   Inst.InstanceID := Ctxt.SessionGroup;

          end else begin

            Error('mode expects an authenticated session',HTML_UNAUTHORIZED);

            exit;

          end;

      end;

      if InternalInstanceRetrieve(Inst,Ctxt.ServiceMethodIndex) then begin

        Ctxt.Success; // was SERVICE_METHODINDEX_FREEINSTANCE

        exit;         // {"method":"_free_", "params":[], "id":1234}

      end;

    end;

  end;

  if Inst.Instance=nil then begin

    Error('instance not found or deprecated',HTML_BADREQUEST);

    exit;

  end;

  Ctxt.ServiceInstanceID := Inst.InstanceID;

  // 2. call method implementation

  if (Ctxt.ServiceExecution=nil) or

     (cardinal(Ctxt.ServiceMethodIndex)>=fInterface.fMethodsCount) then begin

    Error('ServiceExecution=nil',HTML_SERVERERROR);

    exit;

  end;

  if mlInterfaces in TSQLRestServer(Rest).StatLevels then begin

    stats := fStats[Ctxt.ServiceMethodIndex];

    if stats=nil then begin

      stats := StatsCreate;

      fStats[Ctxt.ServiceMethodIndex] := stats;

    end;

    stats.Processing := true;

  end else

    stats := nil;

  exec := nil;

  try

    if fImplementationClassKind=ickFake then

      if Inst.Instance<>fSharedInstance then

        exit else

        instancePtr := @TInterfacedObjectFake(Inst.Instance).fVTable else begin

      if PClass(Inst.Instance)^=fImplementationClass then

        entry := fImplementationClassInterfaceEntry else begin

        entry := Inst.Instance.GetInterfaceEntry(fInterface.fInterfaceIID);

        if entry=nil then

          exit;

      end;

      instancePtr := PAnsiChar(Inst.Instance)+entry^.IOffset;

    end;

    if optExecInPerInterfaceThread in Ctxt.ServiceExecution.Options then

      if fBackgroundThread=nil then

        fBackgroundThread := Rest.NewBackgroundThreadMethod(

          '% %',[self,fInterface.fInterfaceName]);

    WR := TJSONSerializer.CreateOwnedStream;

    try

      Ctxt.fThreadServer^.Factory := self;

      if (Ctxt.Call.InHead='') or (Ctxt.ClientKind=ckFramework) then

        include(WR.fCustomOptions,twoForceJSONExtended) else

        include(WR.fCustomOptions,twoForceJSONStandard); // AJAX

      // root/calculator {"method":"add","params":[1,2]} -> {"result":[3],"id":0}

      Ctxt.ServiceResultStart(WR);

      dolock := optExecLockedPerInterface in Ctxt.ServiceExecution.Options;

      if dolock then

        EnterCriticalSection(fInstanceLock);

      exec := TServiceMethodExecute.Create(@fInterface.fMethods[Ctxt.ServiceMethodIndex]);

      try

        exec.fOptions := Ctxt.ServiceExecution.Options;

        {$ifndef LVCL}

        exec.fBackgroundExecutionThread := fBackgroundThread;

        {$endif}

        exec.fOnCallback := Ctxt.ExecuteCallback;

        if fOnExecute<>nil then

          MultiEventMerge(exec.fOnExecute,fOnExecute);

        if Ctxt.ServiceExecution.LogRest<>nil then

          exec.AddInterceptor(OnLogRestExecuteMethod);

        if exec.ExecuteJson([instancePtr],Ctxt.ServiceParameters,WR,Ctxt.ForceServiceResultAsJSONObject) then begin

          Ctxt.Call.OutHead := exec.ServiceCustomAnswerHead;

          Ctxt.Call.OutStatus := exec.ServiceCustomAnswerStatus;

        end else begin

          Error('execution failed (probably due to bad input parameters)',HTML_NOTACCEPTABLE);

          exit; // wrong request

        end;

      finally

        if dolock then

          LeaveCriticalSection(fInstanceLock);

      end;

      if Ctxt.Call.OutHead='' then begin // <>'' for TServiceCustomAnswer

        Ctxt.ServiceResultEnd(WR,Inst.InstanceID);

        Ctxt.Call.OutHead := JSON_CONTENT_TYPE_HEADER_VAR;

        Ctxt.Call.OutStatus := HTML_SUCCESS;

      end;

      WR.SetText(Ctxt.Call.OutBody);

    finally

      Ctxt.fThreadServer^.Factory := nil;

      WR.Free;

    end;

  finally

    if InstanceCreation=sicSingle then

      Inst.SafeFreeInstance(self); // always release single shot instance

    if stats<>nil then begin

      QueryPerformanceCounter(timeEnd);

      dec(timeEnd,timeStart);

      Ctxt.StatsFromContext(stats,timeEnd,false);

      if Ctxt.Server.StatUsage<>nil then

        Ctxt.Server.StatUsage.Modified(stats,[]);

      if (mlSessions in TSQLRestServer(Rest).StatLevels) and (Ctxt.fAuthSession<>nil) then begin

        if Ctxt.fAuthSession.fInterfaces=nil then

          SetLength(Ctxt.fAuthSession.fInterfaces,length(Rest.Services.fListInterfaceMethod));

        m := Ctxt.fServiceListInterfaceMethodIndex;

        if m<0 then

          m := Rest.Services.fListInterfaceMethods.FindHashed(

            fInterface.fMethods[Ctxt.ServiceMethodIndex].InterfaceDotMethodName);

        if m>=0 then

        with Ctxt.fAuthSession do begin

          stats := fInterfaces[m];

          if stats=nil then begin

            stats := StatsCreate;

            fInterfaces[m] := stats;

          end;

          Ctxt.StatsFromContext(stats,timeEnd,true);

          // mlSessions stats are not yet tracked per Client

        end;

      end;

    end else

      timeEnd := 0;

    if exec<>nil then begin

      if Ctxt.ServiceExecution.LogRest<>nil then

        FinalizeLogRest;

      exec.Free;

    end;

  end;

end;



function TServiceFactoryServer.AllowAll: TServiceFactoryServer;

var m: integer;

begin

  if self<>nil then

    for m := 0 to fInterface.fMethodsCount-1 do

      FillcharFast(fExecution[m].Denied,sizeof(fExecution[m].Denied),0);

  result := self;

end;



function TServiceFactoryServer.AllowAllByID(const aGroupID: array of TID): TServiceFactoryServer;

var m,g: integer;

begin

  if self<>nil then

    for m := 0 to fInterface.fMethodsCount-1 do

    with fExecution[m] do

      for g := 0 to high(aGroupID) do

        exclude(Denied,aGroupID[g]-1);

  result := self;

end;



function TServiceFactoryServer.AllowAllByName(const aGroup: array of RawUTF8): TServiceFactoryServer;

var IDs: TIDDynArray;

begin

  if self<>nil then

    if RestServer.MainFieldIDs(RestServer.fSQLAuthGroupClass,aGroup,IDs) then

      AllowAllByID(IDs);

  result := self;

end;



function TServiceFactoryServer.DenyAll: TServiceFactoryServer;

var m: integer;

begin

  if self<>nil then

    for m := 0 to fInterface.fMethodsCount-1 do

      FillcharFast(fExecution[m].Denied,sizeof(fExecution[m].Denied),255);

  result := self;

end;



function TServiceFactoryServer.DenyAllByID(const aGroupID: array of TID): TServiceFactoryServer;

var m,g: integer;

begin

  if self<>nil then

    for m := 0 to fInterface.fMethodsCount-1 do

    with fExecution[m] do

      for g := 0 to high(aGroupID) do

        include(Denied,aGroupID[g]-1);

  result := self;

end;



function TServiceFactoryServer.DenyAllByName(const aGroup: array of RawUTF8): TServiceFactoryServer;

var IDs: TIDDynArray;

begin

  if self<>nil then

    if RestServer.MainFieldIDs(RestServer.fSQLAuthGroupClass,aGroup,IDs) then

      DenyAllByID(IDs);

  result := self;

end;



function TServiceFactoryServer.Allow(const aMethod: array of RawUTF8): TServiceFactoryServer;

var m: integer;

begin

  if self<>nil then

    for m := 0 to high(aMethod) do

      FillcharFast(fExecution[fInterface.CheckMethodIndex(aMethod[m])].Denied,

        sizeof(fExecution[0].Denied),0);

  result := self;

end;



function TServiceFactoryServer.AllowByID(const aMethod: array of RawUTF8;

  const aGroupID: array of TID): TServiceFactoryServer;

var m,g: integer;

begin

  if self<>nil then

    if high(aGroupID)>=0 then

    for m := 0 to high(aMethod) do

      with fExecution[fInterface.CheckMethodIndex(aMethod[m])] do

        for g := 0 to high(aGroupID) do

          exclude(Denied,aGroupID[g]-1);

  result := self;

end;



function TServiceFactoryServer.AllowByName(const aMethod: array of RawUTF8; const aGroup: array of RawUTF8): TServiceFactoryServer;

var IDs: TIDDynArray;

begin

  if self<>nil then

    if RestServer.MainFieldIDs(RestServer.fSQLAuthGroupClass,aGroup,IDs) then

      AllowByID(aMethod,IDs);

  result := self;

end;



function TServiceFactoryServer.Deny(const aMethod: array of RawUTF8): TServiceFactoryServer;

var m: integer;

begin

  if self<>nil then

    for m := 0 to high(aMethod) do

      FillcharFast(fExecution[fInterface.CheckMethodIndex(aMethod[m])].Denied,

        sizeof(fExecution[0].Denied),255);

  result := self;

end;



function TServiceFactoryServer.DenyByID(const aMethod: array of RawUTF8;

  const aGroupID: array of TID): TServiceFactoryServer;

var m,g: integer;

begin

  if self<>nil then

    for m := 0 to high(aMethod) do

      with fExecution[fInterface.CheckMethodIndex(aMethod[m])] do

        for g := 0 to high(aGroupID) do

          include(Denied,aGroupID[g]-1);

  result := self;

end;



function TServiceFactoryServer.DenyByName(const aMethod: array of RawUTF8; const aGroup: array of RawUTF8): TServiceFactoryServer;

var IDs: TIDDynArray;

begin

  if self<>nil then

    if RestServer.MainFieldIDs(RestServer.fSQLAuthGroupClass,aGroup,IDs) then

      DenyByID(aMethod,IDs);

  result := self;

end;



function TServiceFactoryServer.SetOptions(const aMethod: array of RawUTF8;

  aOptions: TServiceMethodOptions): TServiceFactoryServer;

var m,i: integer;

begin

  if self<>nil then begin

    if (fInstanceCreation=sicPerThread) and (optExecLockedPerInterface in aOptions) then

      raise EServiceException.CreateUTF8('%.SetOptions(I%,optExecLockedPerInterface)'+

        ' not compatible with sicPerThread',[self,fInterfaceURI]);

    if (fInstanceCreation=sicPerThread) and

       ([{$ifndef LVCL}optExecInMainThread,optFreeInMainThread,{$endif}

         optExecInPerInterfaceThread,optFreeInPerInterfaceThread]*aOptions<>[]) then

      raise EServiceException.CreateUTF8('%.SetOptions(I%,opt*In*Thread) '+

        'not compatible with sicPerThread',[self,fInterfaceURI]);

    {$ifndef LVCL}

    if (optExecLockedPerInterface in aOptions) and

       ([optExecInMainThread,optFreeInMainThread,

         optExecInPerInterfaceThread,optFreeInPerInterfaceThread]*aOptions<>[]) then

      raise EServiceException.CreateUTF8('%.SetOptions(I%,optExecLockedPerInterface)'+

        ' with opt*In*Thread options',[self,fInterfaceURI]);

    {$endif}

    if high(aMethod)<0 then

      for i := 0 to fInterface.fMethodsCount-1 do

        fExecution[i].Options := aOptions else

      for m := 0 to high(aMethod) do

        fExecution[fInterface.CheckMethodIndex(aMethod[m])].Options := aOptions;

    fAnyOptions := [];

    for i := 0 to fInterface.fMethodsCount-1 do

      fAnyOptions := fAnyOptions+fExecution[i].Options;

    if (optFreeInPerInterfaceThread in fAnyOptions) and

       not (optExecInPerInterfaceThread in fAnyOptions) then

      raise EServiceException.CreateUTF8('%.SetOptions(I%,optFreeInPerInterfaceThread)'+

        ' without optExecInPerInterfaceThread',[self,fInterfaceURI]);

    {$ifndef LVCL}

    if ([optExecInMainThread,optFreeInMainThread]*fAnyOptions<>[]) and

       ([optExecInPerInterfaceThread,optFreeInPerInterfaceThread]*fAnyOptions<>[]) then

      raise EServiceException.CreateUTF8('%.SetOptions(I%): concurrent '+

        'opt*InMainThread and opt*InPerInterfaceThread',[self,fInterfaceURI]);

    {$endif}

  end;

  result := self;

end;



function TServiceFactoryServer.SetTimeoutSec(value: cardinal): TServiceFactoryServer;

begin

  SetTimeoutSecInt(value);

  result := self;

end;



function TServiceFactoryServer.SetServiceLog(const aMethod: array of RawUTF8;

  aLogRest: TSQLRest; aLogClass: TSQLRecordServiceLogClass): TServiceFactoryServer;

var bits: TInterfaceFactoryMethodBits;

begin

  if self<>nil then begin

    fInterface.CheckMethodIndexes(aMethod,true,bits);

    SetServiceLogByIndex(bits,aLogRest,aLogClass);

  end;

  result := self;

end;



procedure TServiceFactoryServer.SetServiceLogByIndex(

  const aMethods: TInterfaceFactoryMethodBits; aLogRest: TSQLRest;

  aLogClass: TSQLRecordServiceLogClass);

  procedure SetEntry(i,ndx: integer);

  var j: integer;

  begin

    with fExecution[i] do begin

      if LogRestBatch.Count>0 then begin

        LogRest.BatchSend(LogRestBatch);

        LogRestBatch.Reset;

      end;

      LogRest := aLogRest;

      LogClassModelIndex := ndx;

      if LogRest=nil then

        exit;

      for j := 0 to High(fLogRestBatch) do

        if fLogRestBatch[j].Rest=LogRest then begin

          LogRestBatch := fLogRestBatch[j];

          exit; // already assigned to the very same TSQLRest instance

        end;

      LogRestBatch := TSQLRestBatchLocked.Create(LogRest,

        LogRest.Model.Tables[ndx],10000);

      ObjArrayAdd(fLogRestBatch,LogRestBatch);

    end;

  end;

var i,ndx: integer;

begin

  if aLogRest=nil then

    ndx := -1 else

    with aLogRest.Model do

      if aLogClass=nil then begin

        ndx := GetTableIndexInheritsFrom(TSQLRecordServiceLog);

        if ndx<0 then

          raise EModelException.CreateUTF8('%.SetServiceLog: Missing '+

            'TSQLRecordServiceLog class in %.Model',[self,aLogRest]);

      end else

        ndx := GetTableIndexExisting(aLogClass);

  for i := 0 to fInterface.fMethodsCount-1 do

    if i in aMethods then

      SetEntry(i,ndx);

end;



procedure TServiceFactoryServer.AddInterceptor(const Hook: TServiceMethodExecuteEvent);

begin

  MultiEventAdd(fOnExecute,TMethod(Hook));

end;





{ TServiceRecordVersion }



function TServiceRecordVersion.Subscribe(const SQLTableName: RawUTF8;

  const revision: TRecordVersion; const callback: IServiceRecordVersionCallback): boolean;

var tableIndex: integer;

    tableRemote: TSQLRest;

    tableServer: TSQLRestServer;

begin

  if Server<>nil then begin

     tableIndex := Server.Model.GetTableIndex(SQLTableName);

     if tableIndex>=0 then begin

       tableRemote := Server.GetRemoteTable(tableIndex);

       if (tableRemote=nil) or not tableRemote.InheritsFrom(TSQLRestServer) then

         tableServer := Server else

         tableServer := TSQLRestServer(tableRemote);

       result := tableServer.RecordVersionSynchronizeSubscribeMaster(

         Server.Model.Tables[tableindex],revision,callback);

       exit;

     end;

  end;

  result := false;

end;





{ TServiceMethodArgument }



{$ifndef FPC}

procedure TServiceMethodArgument.SetFromRTTI(var P: PByte);

var PS: PShortString absolute P;

    PP: ^PPTypeInfo absolute P;

begin

  ArgTypeName := PS;

  PS := AlignToPtr(@PS^[ord(PS^[0])+1]);

  if PP^=nil then

    {$ifndef ISDELPHI2010}

    if IdemPropName(ArgTypeName^,'TGUID') then

      ArgTypeInfo := @GUID_FAKETYPEINFO else

    {$endif}

      raise EInterfaceFactoryException.CreateUTF8(

       '"%: %" parameter has no RTTI',[ParamName^,ArgTypeName^]) else

    ArgTypeInfo := PP^^;

  inc(PP);

end;

{$endif FPC}



procedure TServiceMethodArgument.SerializeToContract(WR: TTextWriter);

const

  CONST_ARGDIRTOJSON: array[TServiceMethodValueDirection] of string[4] = (

    // convert into generic in/out direction (assume result is out)

    'in','both','out','out');

  // AnsiString (Delphi <2009) may loose data depending on the client

  CONST_ARGTYPETOJSON: array[TServiceMethodValueType] of string[8] = (

    '??','self','boolean', '', '','integer','cardinal','int64',

    'double','datetime','currency','utf8','utf8','utf8','utf8','',

    {$ifndef NOVARIANTS}'variant',{$endif}'','json','','');

begin

  WR.AddShort('{"argument":"');

  WR.AddShort(ParamName^);

  WR.AddShort('","direction":"');

  WR.AddShort(CONST_ARGDIRTOJSON[ValueDirection]);

  WR.AddShort('","type":"');

  if CONST_ARGTYPETOJSON[ValueType]='' then

    WR.AddShort(ArgTypeInfo^.Name) else

    WR.AddShort(CONST_ARGTYPETOJSON[ValueType]);

  WR.AddShort('"},');

end;



procedure TServiceMethodArgument.AddJSON(WR: TTextWriter; V: pointer);

begin

  if vIsString in ValueKindAsm then

    WR.Add('"');

  case ValueType of

  smvBoolean:   WR.Add(PBoolean(V)^);

  smvEnum..smvInt64:

  case SizeInStorage of

    1: WR.Add(PByte(V)^);

    2: WR.Add(PWord(V)^);

    4: if ValueType=smvInteger then

         WR.Add(PInteger(V)^) else

         WR.AddU(PCardinal(V)^);

    8: WR.Add(PInt64(V)^);

  end;

  smvDouble, smvDateTime: WR.AddDouble(PDouble(V)^);

  smvCurrency:   WR.AddCurr64(PInt64(V)^);

  smvRawUTF8:    WR.AddJSONEscape(PPointer(V)^);

  smvRawJSON:    WR.AddNoJSONEscape(PPointer(V)^,length(PRawUTF8(V)^));

  smvString:     {$ifdef UNICODE}

                 WR.AddJSONEscapeW(pointer(PString(V)^));

                 {$else}

                 WR.AddJSONEscapeAnsiString(PString(V)^);

                 {$endif}

  smvRawByteString: WR.WrBase64(PPointer(V)^,length(PRawBytestring(V)^),false);

  smvWideString: WR.AddJSONEscapeW(PPointer(V)^);

  smvObject:     WR.WriteObject(PPointer(V)^);

  smvInterface:  WR.AddShort('null'); // or written by InterfaceWrite()

  smvRecord:     WR.AddRecordJSON(V^,ArgTypeInfo);

  smvDynArray:   WR.AddDynArrayJSON(ArgTypeInfo,V^);

  {$ifndef NOVARIANTS}

  smvVariant:    WR.AddVariant(PVariant(V)^,twJSONEscape);

  {$endif}

  end;

  if vIsString in ValueKindAsm then

    WR.Add('"',',') else

    WR.Add(',');

end;



procedure TServiceMethodArgument.AsJson(var DestValue: RawUTF8; V: pointer);

var W: TTextWriter;

begin

  case ValueType of // some direct conversion of simple types

  smvBoolean:

    JSONBoolean(PBoolean(V)^,DestValue);

  smvEnum..smvInt64:

  case SizeInStorage of

    1: UInt32ToUtf8(PByte(V)^,DestValue);

    2: UInt32ToUtf8(PWord(V)^,DestValue);

    4: if ValueType=smvInteger then

         Int32ToUtf8(PInteger(V)^,DestValue) else

         UInt32ToUtf8(PCardinal(V)^,DestValue);

    8: Int64ToUtf8(PInt64(V)^,DestValue);

  end;

  smvDouble, smvDateTime:

    ExtendedToStr(PDouble(V)^,DOUBLE_PRECISION,DestValue);

  smvCurrency:

    Curr64ToStr(PInt64(V)^,DestValue);

  smvRawJSON:

    DestValue := PRawUTF8(V)^;

  else begin // use generic AddJSON() method

    W := TJSONSerializer.CreateOwnedStream(512);

    try

      AddJSON(W,V);

      W.SetText(DestValue);

    finally

      W.Free;

    end;

  end;

  end;

end;



procedure TServiceMethodArgument.AddJSONEscaped(WR: TTextWriter; V: pointer);

var W: TTextWriter;

begin

  if ValueType in [smvBoolean..smvCurrency,smvInterface] then // no need to escape those

    AddJSON(WR,V) else begin

    W := WR.InternalJSONWriter;

    AddJSON(W,V);

    WR.AddJSONEscape(W);

  end;

end;



procedure TServiceMethodArgument.AddValueJSON(WR: TTextWriter; const Value: RawUTF8);

begin

  if vIsString in ValueKindAsm then begin

    WR.Add('"');

    WR.AddJSONEscape(pointer(Value),length(Value));

    WR.Add('"',',');

  end else begin

    WR.AddString(Value);

    WR.Add(',');

  end;

end;



procedure TServiceMethodArgument.AddDefaultJSON(WR: TTextWriter);

begin

  case ValueType of

  smvBoolean:   WR.AddShort('false,');

  smvObject:    WR.AddShort('null,'); // may raise an error on the client side

  smvInterface: WR.AddShort('0,');

  smvDynArray:  WR.AddShort('[],');

  smvRecord:   begin

    WR.AddVoidRecordJSON(ArgTypeInfo);

    WR.Add(',');

  end;

  {$ifndef NOVARIANTS}

  smvVariant: WR.AddShort('null,');

  {$endif}

  else

    if vIsString in ValueKindAsm then

      WR.AddShort('"",') else

      WR.AddShort('0,');

  end;

end;



{$ifndef NOVARIANTS}



procedure TServiceMethodArgument.AsVariant(var DestValue: variant; V: pointer;

  Options: TDocVariantOptions);

var tmp: RawUTF8;

begin

  case ValueType of // some direct conversion of simple types

  smvBoolean:

    DestValue := PBoolean(V)^;

  smvEnum..smvInt64:

  case SizeInStorage of

    1: DestValue := PByte(V)^;

    2: DestValue := PWord(V)^;

    4: if ValueType=smvInteger then

         DestValue := PInteger(V)^ else

         DestValue := PCardinal(V)^;

    8: DestValue := PInt64(V)^;

  end;

  smvDouble, smvDateTime:

    DestValue := PDouble(V)^;

  smvCurrency:

    DestValue := PCurrency(V)^;

  smvRawUTF8:

    RawUTF8ToVariant(PRawUTF8(V)^,DestValue);

  smvString: begin

    StringToUTF8(PString(V)^,tmp);

    RawUTF8ToVariant(tmp,DestValue);

  end;

  smvWideString: begin

    RawUnicodeToUtf8(PPointer(V)^,length(PWideString(V)^),tmp);

    RawUTF8ToVariant(tmp,DestValue);

  end;

  smvVariant:

    DestValue := PVariant(V)^;

  else begin // use generic AddJSON() method

    AsJson(tmp,V);

    VariantLoadJSON(DestValue,pointer(tmp),nil,@Options);

  end;

  end;

end;



procedure TServiceMethodArgument.AddAsVariant(var Dest: TDocVariantData; V: pointer);

var tmp: variant;

begin

  AsVariant(tmp,V,Dest.Options);

  if Dest.Kind=dvArray then

    Dest.AddItem(tmp) else

    Dest.AddValue(ShortStringToAnsi7String(ParamName^),tmp);

end;



procedure TServiceMethodArgument.FixValueAndAddToObject(const Value: variant;

  var DestDoc: TDocVariantData);

var tempCopy: variant;

begin

  tempCopy := Value;

  FixValue(tempCopy);

  DestDoc.AddValue(ShortStringToAnsi7String(ParamName^),tempCopy);

end;



procedure TServiceMethodArgument.FixValue(var Value: variant);

var enum: Int64;

    obj: TObject;

    arr: pointer;

    dyn: TDynArray;

    rec: TByteDynArray;

    json: RawUTF8;

begin

  case ValueType of

  smvEnum:

    if VariantToInt64(Value,enum) then

      Value := PTypeInfo(ArgTypeInfo)^.EnumBaseType^.GetEnumNameOrd(enum)^;

  smvSet:

    if VariantToInt64(Value,enum) then

      Value := PTypeInfo(ArgTypeInfo)^.SetEnumType^.GetSetNameAsDocVariant(enum);

  smvObject: begin

    obj := ArgTypeInfo^.ClassCreate;

    try

      if DocVariantToObject(_Safe(Value)^,obj) then

        Value := _ObjFast(obj,[woEnumSetsAsText]);

    finally

      obj.Free;

    end;

  end;

  smvDynArray:

    if _Safe(Value)^.Kind=dvArray then begin

      arr := nil;

      dyn.Init(ArgTypeInfo,arr);

      try

        VariantSaveJSON(Value,twJSONEscape,json);

        dyn.LoadFromJSON(pointer(json));

        json := dyn.SaveToJSON(true);

        Value := _JsonFast(json);

      finally

        dyn.Clear;

      end;

    end;

  smvRecord:

    if _Safe(Value)^.Kind=dvObject then begin

      SetLength(rec,ArgTypeInfo^.RecordType^.Size);

      try

        VariantSaveJSON(Value,twJSONEscape,json);

        RecordLoadJSON(rec[0],pointer(json),ArgTypeInfo);

        json := RecordSaveJSON(rec[0],ArgTypeInfo,true);

        Value := _JsonFast(json);

      finally

        RecordClear(rec[0],ArgTypeInfo);

      end;

    end;

  end;

end;



{$endif NOVARIANTS}





{ TAutoCreateFields }



type // use AutoTable VMT entry to store a cache of the needed fields RTTI

  TAutoCreateFields = class

  public

    ClassesCount: integer;

    ObjArraysCount: integer;

    Classes: array of record

      Offset: cardinal;

      Instance: TClassInstance;

    end;

    ObjArraysOffset: array of cardinal;

    constructor Create(aClass: TClass);

  end;



constructor TAutoCreateFields.Create(aClass: TClass);

var i: integer;

    P: PPropInfo;

begin

  repeat

    for i := 1 to InternalClassPropInfo(aClass,P) do begin

      case P^.PropType^.Kind of

      tkClass: begin

        if (P^.SetProc<>0) or not P^.GetterIsField then

          raise EModelException.CreateUTF8('%.%: % is an auto-created instance '+

            'so should not have any "write" defined',[aClass,P^.Name,P^.PropType^.Name]);

        SetLength(Classes,ClassesCount+1);

        with Classes[ClassesCount] do begin

          Offset := PtrUInt(P^.GetterAddr(nil));

          Instance.Init(P^.PropType^.ClassType^.ClassType);

        end;

        inc(ClassesCount);

      end;

      tkDynArray:

        if (ObjArraySerializers.Find(P^.TypeInfo)<>nil)

           and P^.GetterIsField then begin

          SetLength(ObjArraysOffset,ObjArraysCount+1);

          ObjArraysOffset[ObjArraysCount] := PtrUInt(P^.GetterAddr(nil));

          inc(ObjArraysCount);

        end;

      end;

      P := P^.Next;

    end;

    aClass := aClass.ClassParent;

  until aClass=TObject;

end;



type

  TSimpleMethodCall = procedure(self: TObject);



procedure AutoCreateFields(self: TObject);

var fields: TAutoCreateFields;

    PVMT: PPointer;

    i: integer;

begin

  PVMT := pointer(PPtrInt(self)^+vmtAutoTable);

  fields := PVMT^;

  if fields=nil then begin

    // first time access: compute RTTI cache

    fields := TAutoCreateFields.Create(PClass(self)^);

    // store the RTTI cache into the AutoTable VMT entry of this class

    PatchCodePtrUInt(pointer(PVMT),PtrUInt(fields),true);

    GarbageCollectorFreeAndNil(PVMT^,fields);

  end else

    if PClass(fields)^<>TAutoCreateFields then

      raise EModelException.CreateUTF8('%.AutoTable VMT entry already set',[self]);

  // auto-create published persistent class instances

  for i := 0 to fields.ClassesCount-1 do

    with fields.Classes[i] do

      PObject(PtrUInt(self)+Offset)^ := Instance.CreateNew;

end;



procedure AutoDestroyFields(self: TObject);

 {$ifdef HASINLINE}inline;{$endif}

var i: integer;

    fields: TAutoCreateFields;

begin

  fields := PPointer(PPtrInt(self)^+vmtAutoTable)^;

  if fields=nil then

    exit; // may happen in a weird finalization code

  // auto-release published persistent class instances

  for i := 0 to fields.ClassesCount-1 do

    PObject(PtrUInt(self)+fields.Classes[i].Offset)^.Free;

  // auto-release published T*ObjArray instances

  for i := 0 to fields.ObjArraysCount-1 do

    ObjArrayClear(pointer(PtrUInt(self)+fields.ObjArraysOffset[i])^);

end;





{ TPersistentAutoCreateFields }



constructor TPersistentAutoCreateFields.Create;

begin

  AutoCreateFields(self);

  inherited Create; // always call the virtual constructor

end;



destructor TPersistentAutoCreateFields.Destroy;

begin

  AutoDestroyFields(self);

  inherited Destroy;

end;





{ TSynAutoCreateFields }



{$ifdef FPC_OR_PUREPASCAL}



constructor TSynAutoCreateFields.Create;

begin

  AutoCreateFields(self);

  inherited Create; // always call the virtual constructor

end;



{$else}



class function TSynAutoCreateFields.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

        push eax

        call AutoCreateFields

        pop eax

end; // ignore vmtIntfTable for this class hierarchy (won't implement interfaces)



{$endif}



destructor TSynAutoCreateFields.Destroy;

begin

  AutoDestroyFields(self);

  inherited Destroy;

end;





{ TSynAutoCreateFieldsLocked }



constructor TSynAutoCreateFieldsLocked.Create;

begin

  inherited Create;

  fSafe.Init;

end;



destructor TSynAutoCreateFieldsLocked.Destroy;

begin

  inherited Destroy;

  fSafe.Done;

end;



procedure TSynAutoCreateFieldsLocked.Lock;

begin

  if self<>nil then

    fSafe.Lock;

end;



procedure TSynAutoCreateFieldsLocked.UnLock;

begin

  if self<>nil then

    fSafe.UnLock;

end;





{ TInterfacedObjectAutoCreateFields }



constructor TInterfacedObjectAutoCreateFields.Create;

begin

  AutoCreateFields(self);

  inherited Create; // always call the virtual constructor

end;



destructor TInterfacedObjectAutoCreateFields.Destroy;

begin

  AutoDestroyFields(self);

  inherited Destroy;

end;





{ TInjectableAutoCreateFields }



constructor TInjectableAutoCreateFields.Create;

var Inject: IAutoCreateFieldsResolve;

begin

  AutoCreateFields(self);

  inherited Create; // overriden method will inject its dependencies (DI/IoC)

  if TryResolve(TypeInfo(IAutoCreateFieldsResolve),Inject) then

    Inject.SetProperties(self);

end;



destructor TInjectableAutoCreateFields.Destroy;

begin

  AutoDestroyFields(self);

  inherited Destroy;

end;





{$ifndef LVCL}



{ TInterfacedCollection }



constructor TInterfacedCollection.Create;

begin

  inherited Create(GetClass);

end;





{ TCollectionItemAutoCreateFields }



constructor TCollectionItemAutoCreateFields.Create(Collection: TCollection);

begin

  AutoCreateFields(self);

  inherited Create(Collection);

end;



destructor TCollectionItemAutoCreateFields.Destroy;

begin

  AutoDestroyFields(self);

  inherited Destroy;

end;



{$endif LVCL}





{ TRawUTF8ObjectCacheSettings }



constructor TRawUTF8ObjectCacheSettings.Create;

begin

  inherited Create;

  // release after 2 minutes of inactivity by default

  fTimeOutMS := 2 * 60 * 1000;

  // 1 second periodicity of purge is small enough to be painless

  fPurgePeriodMS := 1000;

end;





{ TRawUTF8ObjectCache }



constructor TRawUTF8ObjectCache.Create(aOwner: TRawUTF8ObjectCacheList;

  const aKey: RawUTF8);

begin

  inherited Create;

  fOwner := aOwner;

  fKey := aKey;

  fOwner.Log('%.Create(%)', [ClassType, fKey]);

  fTimeoutMS := fOwner.fSettings.TimeOutMS;

end;



destructor TRawUTF8ObjectCache.Destroy;

begin

  fOwner.Log('%.Destroy %', [ClassType, fKey]);

  CacheClear;

  inherited Destroy;

end;



procedure TRawUTF8ObjectCache.CacheSet;

begin // gives some addition TTL time

  fTimeoutTix := GetTickCount64 + fTimeoutMS;

end;



procedure TRawUTF8ObjectCache.CacheClear;

begin

  fTimeoutTix := 0; // indicates no service is available

end;



function TRawUTF8ObjectCache.Resolve(const aInterface: TGUID; out Obj): boolean;

begin

  if Assigned(fOwner.OnKeyResolve) then

    result := fOwner.OnKeyResolve(aInterface,fKey,Obj) else

    result := false;

end;





{ TRawUTF8ObjectCacheList }



constructor TRawUTF8ObjectCacheList.Create(aClass: TRawUTF8ObjectCacheClass;

  aSettings: TRawUTF8ObjectCacheSettings; aLog: TSynLogFamily; aLogEvent: TSynLogInfo;

  const aOnKeyResolve: TOnKeyResolve);

begin

  inherited Create(true);

  fClass := aClass;

  fSettings := aSettings;

  if (fClass = nil) or (fClass = TRawUTF8ObjectCache) or (fSettings = nil) then

    raise ESynException.CreateUTF8('%.Create(nil)', [self]);

  if (fSettings.PurgePeriodMS > 0) and (fSettings.TimeOutMS > 0) then

    fNextPurgeTix := GetTickCount64 + fSettings.PurgePeriodMS;

  fLog := aLog;

  fLogEvent := aLogEvent;

  fOnKeyResolve := aOnKeyResolve;

end;



procedure TRawUTF8ObjectCacheList.Log(const TextFmt: RawUTF8; const TextArgs: array of const;

  Level: TSynLogInfo);

begin

  if (self=nil) or (fLog=nil) then

    exit;

  if Level=sllNone then

    Level := fLogEvent;

  fLog.SynLog.Log(Level, TextFmt, TextArgs, self);

end;



function TRawUTF8ObjectCacheList.NewObjectCache(const Key: RawUTF8): TRawUTF8ObjectCache;

begin

  result := fClass.Create(self, Key);

end;



procedure TRawUTF8ObjectCacheList.TryPurge;

begin

  fSafe.Lock;

  try

    if (fNextPurgeTix <> 0) and (GetTickCount64 > fNextPurgeTix) then

      DoPurge;

  finally

    fSafe.UnLock;

  end;

end;



procedure TRawUTF8ObjectCacheList.ForceCacheClear;

var i: integer;

    cache: TRawUTF8ObjectCache;

begin

  fSafe.Lock;

  try

    fLog.SynLog.Enter('ForceCacheClear of % entries',[fCount],self);

    for i := 0 to fCount - 1 do begin

      cache := TRawUTF8ObjectCache(fObjects[i]);

      cache.fSafe.Lock;

      try

        cache.CacheClear;

      finally

        cache.fSafe.UnLock;

      end;

    end;

  finally

    fSafe.UnLock;

  end;

end;



procedure TRawUTF8ObjectCacheList.DoPurge;

var tix: Int64;

    i: integer;

    purged: RawUTF8;

    log: ISynLog;

    cache: TRawUTF8ObjectCache;

begin // called within fSafe.Lock

  tix := GetTickCount64;

  try

    for i := 0 to fCount - 1 do begin

      cache := TRawUTF8ObjectCache(fObjects[i]);

      if (cache.fTimeoutTix > 0) and (tix > cache.fTimeoutTix) then

        try // test again the timeout after acquiring the TRawUTF8ObjectCache lock

          cache.Safe.Lock;

          if (cache.fTimeoutTix > 0) and (tix > cache.fTimeoutTix) then begin

            if log = nil then

              log := fLog.SynLog.Enter(self);

            cache.CacheClear; // would set fTimeoutTix := 0

            purged := purged + ' ' + cache.fKey;

          end;

        finally

          cache.Safe.UnLock;

        end;

    end;

    if log <> nil then

      log.Log(fLogEvent, '%.ReleaseServices:% - count=%', [fClass, purged, fCount], self);

  finally

    fNextPurgeTix := tix + fSettings.PurgePeriodMS;

  end;

end;



function TRawUTF8ObjectCacheList.GetLocked(const Key: RawUTF8;

  out cache: TRawUTF8ObjectCache; onlyexisting: boolean): boolean;

var

  added: boolean;

begin

  result := false;

  if Key = '' then

    exit;

  fSafe.Lock;

  try

    if (fNextPurgeTix <> 0) and (GetTickCount64 > fNextPurgeTix) then

      DoPurge;  // inline TryPurge within the locked list

    cache := TRawUTF8ObjectCache(GetObjectByName(Key));

    if cache = nil then begin

      if onlyexisting then begin

        Log('GetLocked(%): onlyexisting=true -> no new %', [Key, fClass]);

        exit;

      end;

      cache := NewObjectCache(Key);

      if cache = nil then begin

        Log('GetLocked: Invalid key - NewObjectCache(%) returned no %', [Key, fClass]);

        exit;

      end;

      AddObjectIfNotExisting(Key, cache, @added);

      if added then

        Log('GetLocked: Added %[%] - count=%', [fClass, Key, fCount])

      else

        raise ESynException.CreateUTF8('%.GetLocked(%) new %', [self, Key, cache]);

    end

    else if cache.fTimeOutTix = 0 then

      Log('GetLocked: Using blank %[%]', [fClass, Key])

    else

      Log('GetLocked: Using %[%] with timeout in % ms',

        [fClass, Key, cache.fTimeOutTix - GetTickCount64]);

    cache.fSafe.Lock;

    result := true;

  finally

    fSafe.UnLock;

  end;

end;





{ TServiceMethod }



type

  TDynArrayFake = record

    Value: Pointer;

    Wrapper: TDynArray;

  end;



function TServiceMethod.ArgIndex(ArgName: PUTF8Char; ArgNameLen: integer;

  Input: boolean): integer;

begin

  if ArgNameLen>0 then

    if Input then begin

      for result := ArgsInFirst to ArgsInLast do

        with Args[result] do

        if IdemPropName(ParamName^,ArgName,ArgNameLen) then

          if ValueDirection in [smdConst,smdVar] then

            exit else // found

            break; // right name, but wrong direction

    end else

    for result := ArgsOutFirst to ArgsOutLast do

      with Args[result] do

      if IdemPropName(ParamName^,ArgName,ArgNameLen) then

        if ValueDirection in [smdVar,smdOut,smdResult] then

          exit else // found

          break; // right name, but wrong direction

  result := -1;

end;



function TServiceMethod.ArgNext(var arg: integer; Input: boolean): boolean;

begin

  result := true;

  inc(arg);

  if Input then

    while arg<=ArgsInLast do

      if Args[arg].ValueDirection in [smdConst,smdVar] then

        exit else

        inc(arg) else

    while arg<=ArgsOutLast do

      if Args[arg].ValueDirection in [smdVar,smdOut,smdResult] then

        exit else

        inc(arg);

  result := false;

end;



function TServiceMethod.ArgsArrayToObject(P: PUTF8Char; Input: boolean): RawUTF8;

var i: integer;

    W: TTextWriter;

    Value: PUTF8Char;

begin

  W := TTextWriter.CreateOwnedStream;

  try

    W.Add('{');

    if (P=nil) or (P^<>'[') then

      P := nil else

      inc(P);

    for i := 1 to length(Args)-1 do

    if P=nil then

      break else

      with Args[i] do begin

        if Input then begin

          if ValueDirection in [smdOut,smdResult] then

            continue;

        end else

          if ValueDirection=smdConst then

            continue;

        W.AddPropName(ParamName^);

        P := GotoNextNotSpace(P);

        Value := P;

        P := GotoEndJSONItem(P);

        if P^=',' then

          inc(P); // include ending ','

        W.AddNoJsonEscape(Value,P-Value);

      end;

    W.CancelLastComma;

    W.Add('}');

    W.SetText(result);

  finally

    W.Free;

  end;

end;



function TServiceMethod.ArgsNames(Input: Boolean): TRawUTF8DynArray;

var a,n: integer;

begin

  if Input then begin

    SetLength(result,ArgsInputValuesCount);

    n := 0;

    for a := ArgsInFirst to ArgsInLast do

      if Args[a].ValueDirection in [smdConst,smdVar] then begin

        ShortStringToAnsi7String(Args[a].ParamName^,result[n]);

        inc(n);

      end;

  end else begin

    SetLength(result,ArgsOutputValuesCount);

    n := 0;

    for a := ArgsOutFirst to ArgsOutLast do

      if Args[a].ValueDirection in [smdVar,smdOut,smdResult] then begin

        ShortStringToAnsi7String(Args[a].ParamName^,result[n]);

        inc(n);

      end;

  end;

end;





{$ifndef NOVARIANTS}



procedure TServiceMethod.ArgsStackAsDocVariant(const Values: TPPointerDynArray;

  out Dest: TDocVariantData; Input: Boolean);

var a: integer;

begin

  if Input then begin

    for a := ArgsInFirst to ArgsInLast do

      if Args[a].ValueDirection in [smdConst,smdVar] then

        Args[a].AddAsVariant(Dest,Values[a]);

  end else begin

    for a := ArgsOutFirst to ArgsOutLast do

      if Args[a].ValueDirection in [smdVar,smdOut,smdResult] then

        Args[a].AddAsVariant(Dest,Values[a]);

  end;

end;



procedure TServiceMethod.ArgsValuesAsDocVariant(Kind: TServiceMethodParamsDocVariantKind;

  out Dest: TDocVariantData; const Values: TVariantDynArray; Input: boolean;

  Options: TDocVariantOptions);

begin

  case Kind of

  pdvObject, pdvObjectFixed: begin

    Dest.InitObjectFromVariants(ArgsNames(Input),Values,Options);

    if Kind=pdvObjectFixed then

      ArgsAsDocVariantFix(Dest,Input);

  end;

  pdvArray:

    Dest.InitArrayFromVariants(Values,Options);

  else

    Dest.Init(Options);

  end;

end;



procedure TServiceMethod.ArgsAsDocVariantObject(const ArgsParams: TDocVariantData;

  var ArgsObject: TDocVariantData; Input: boolean);

var a,n: integer;

begin

  if (ArgsParams.Count=0) or (ArgsParams.Kind<>dvArray) then

    exit;

  if ArgsObject.Kind=dvUndefined then

    ArgsObject.Init(ArgsParams.Options);

  ArgsObject.Capacity := ArgsObject.Count+ArgsParams.Count;

  n := 0;

  if Input then begin

    if ArgsParams.Count=integer(ArgsInputValuesCount) then

      for a := ArgsInFirst to ArgsInLast do

        if Args[a].ValueDirection in [smdConst,smdVar] then begin

          ArgsObject.AddValue(ShortStringToAnsi7String(Args[a].ParamName^),

            ArgsParams.Values[n]);

          inc(n);

        end;

  end else begin

    if ArgsParams.Count=integer(ArgsOutputValuesCount) then

      for a := ArgsOutFirst to ArgsOutLast do

        if Args[a].ValueDirection in [smdVar,smdOut,smdResult] then begin

          ArgsObject.AddValue(ShortStringToAnsi7String(Args[a].ParamName^),

            ArgsParams.Values[n]);

          inc(n);

        end;

  end;

end;



procedure TServiceMethod.ArgsAsDocVariantFix(var ArgsObject: TDocVariantData;

  Input: boolean);

var a,ndx: integer;

    doc: TDocVariantData;

begin

  if ArgsObject.Count>0 then

  case ArgsObject.Kind of

  dvObject:

  for a := 0 to ArgsObject.Count-1 do begin

    ndx := ArgIndex(pointer(ArgsObject.Names[a]),length(ArgsObject.Names[a]),Input);

    if ndx>=0 then

      Args[ndx].FixValue(ArgsObject.Values[a]);

  end;

  dvArray:

    if Input then begin

      if ArgsObject.Count<>integer(ArgsInputValuesCount) then

        exit;

      doc.Init(ArgsObject.Options);

      for a := ArgsInFirst to ArgsInLast do

        if Args[a].ValueDirection in [smdConst,smdVar] then

          Args[a].FixValueAndAddToObject(ArgsObject.Values[doc.Count],doc);

      ArgsObject := doc;

    end else begin

      if ArgsObject.Count<>integer(ArgsOutputValuesCount) then

        exit;

      doc.Init(ArgsObject.Options);

      for a := ArgsOutFirst to ArgsOutLast do

        if Args[a].ValueDirection in [smdVar,smdOut,smdResult] then

          Args[a].FixValueAndAddToObject(ArgsObject.Values[doc.Count],doc);

      ArgsObject := doc;

    end;

  end;

end;



{$endif NOVARIANTS}





{ TServiceMethodExecute }



constructor TServiceMethodExecute.Create(aMethod: PServiceMethod);

var a: integer;

begin

  with aMethod^ do begin

    if ArgsUsedCount[smvv64]>0 then

      SetLength(fInt64s,ArgsUsedCount[smvv64]);

    if ArgsUsedCount[smvvObject]>0 then

      SetLength(fObjects,ArgsUsedCount[smvvObject]);

    if ArgsUsedCount[smvvInterface]>0 then

      SetLength(fInterfaces,ArgsUsedCount[smvvInterface]);

    if ArgsUsedCount[smvvRecord]>0 then

      SetLength(fRecords,ArgsUsedCount[smvvRecord]);

    if ArgsUsedCount[smvvDynArray]>0 then

      SetLength(fDynArrays,ArgsUsedCount[smvvDynArray]);

    SetLength(fValues,length(Args));

    for a := ArgsManagedFirst to ArgsManagedLast do

    with Args[a] do

      case ValueType of

      smvDynArray:

        with fDynArrays[IndexVar] do begin

          Wrapper.Init(ArgTypeInfo,Value);

          Wrapper.IsObjArray := vIsObjArray in ValueKindAsm; // no need to search

        end;

      smvRecord:

        SetLength(fRecords[IndexVar],ArgTypeInfo^.RecordType^.Size);

      {$ifndef NOVARIANTS}

      smvVariant:

        SetLength(fRecords[IndexVar],sizeof(Variant));

      {$endif}

      end;

  end;

  fMethod := aMethod;

end;



destructor TServiceMethodExecute.Destroy;

begin

  fTempTextWriter.Free;

  inherited Destroy;

end;



procedure TServiceMethodExecute.AddInterceptor(const Hook: TServiceMethodExecuteEvent);

begin

  MultiEventAdd(fOnExecute,TMethod(Hook));

end;



procedure TServiceMethodExecute.BeforeExecute;

var a: integer;

begin

  with fMethod^ do begin

    if ArgsUsedCount[smvvRawUTF8]>0 then

      SetLength(fRawUTF8s,ArgsUsedCount[smvvRawUTF8]);

    if ArgsUsedCount[smvvString]>0 then

      SetLength(fStrings,ArgsUsedCount[smvvString]);

    if ArgsUsedCount[smvvWideString]>0 then

      SetLength(fWideStrings,ArgsUsedCount[smvvWideString]);

    if fAlreadyExecuted then begin

      if ArgsUsedCount[smvvObject]>0 then

        FillcharFast(fObjects,ArgsUsedCount[smvvObject]*sizeof(TObject),0);

      if ArgsUsedCount[smvv64]>0 then

        FillcharFast(fInt64s,ArgsUsedCount[smvv64]*sizeof(Int64),0);

      if ArgsUsedCount[smvvInterface]>0 then

        FillcharFast(fInterfaces,ArgsUsedCount[smvvInterface]*sizeof(pointer),0);

      if ArgsUsedCount[smvvDynArray]>0 then

        FillcharFast(fDynArrays,ArgsUsedCount[smvvDynArray]*sizeof(TDynArrayFake),0);

    end;

    for a := ArgsManagedFirst to ArgsManagedLast do

    with Args[a] do

      case ValueType of

      smvObject:

        fObjects[IndexVar] := ArgTypeInfo^.ClassCreate;

      smvRecord:

        if fAlreadyExecuted then

          FillcharFast(fRecords[IndexVar],ArgTypeInfo^.RecordType^.Size,0);

      end;

    if optInterceptInputOutput in Options then begin

      Input.InitFast(ArgsInputValuesCount,dvObject);

      Output.InitFast(ArgsOutputValuesCount,dvObject);

    end;

  end;

  fAlreadyExecuted := true;

end;



procedure TServiceMethodExecute.RawExecute(const Instances: PPointerArray;

  InstancesLast: integer);

var Value: pointer;

    a,i,e: integer;

    call: TCallMethodArgs;

    Stack: packed array[0..MAX_EXECSTACK-1] of byte;

begin

  FillcharFast(call,SizeOf(call),0);

  with fMethod^ do begin

    // create the stack and register content

    {$ifdef CPUX86}

    call.StackAddr := PtrInt(@Stack[0]);

    call.StackSize := ArgsSizeInStack;

    {$else}

    {$ifdef CPUINTEL}

    call.StackSize := ArgsSizeInStack shr 3;

    // ensure stack aligned on 16 bytes (paranoid)

    if call.StackSize and 1 <> 0 then

      inc(call.StackSize);

    // stack is filled reversed (RTL)

    call.StackAddr := PtrInt(@Stack[call.StackSize*8-8]);

    {$else}

    // stack is filled normally (LTR)

    call.StackAddr := PtrInt(@Stack[0]);

    call.StackSize := ArgsSizeInStack shr 2;

    {$ifdef CPUAARCH64}

    call.StackSize := ArgsSizeInStack shr 3;

    // ensure stack aligned on 16 bytes (mandatory: needed for correct low level asm)

    if call.StackSize and 1 <> 0 then

      inc(call.StackSize);

    {$endif}

    {$endif CPUINTEL}

    {$endif CPUX86}

    for a := 1 to high(Args) do

    with Args[a] do begin

      case ValueVar of

      smvvSelf:       continue; // call.Regs[REG_FIRST] := Instance[i] below

      smvv64:         Value := @fInt64s[IndexVar];

      smvvRawUTF8:    Value := @fRawUTF8s[IndexVar];

      smvvString:     Value := @fStrings[IndexVar];

      smvvWideString: Value := @fWideStrings[IndexVar];

      smvvObject:     Value := @fObjects[IndexVar];

      smvvInterface:  Value := @fInterfaces[IndexVar];

      smvvRecord:     Value := pointer(fRecords[IndexVar]);

      smvvDynArray:   Value := @fDynArrays[IndexVar].Value;

      else raise EInterfaceFactoryException.CreateUTF8(

        'Invalid % argument type = %',[ParamName^,ord(ValueType)]);

      end;

      fValues[a] := Value;

      if (ValueDirection<>smdConst) or

         (ValueType in [smvRecord{$ifndef NOVARIANTS},smvVariant{$endif}]) then begin

          // pass by reference

          if (RegisterIdent=0) and (FPRegisterIdent=0) and (SizeInStack>0) then

          MoveFast(Value,Stack[InStackOffset],SizeInStack) else begin

            if RegisterIdent>0 then

              call.ParamRegs[RegisterIdent] := PtrInt(Value);

            if FPRegisterIdent>0 then

              raise EInterfaceFactoryException.CreateUTF8('Unexpected % FPReg=%',

                [ParamName^,FPRegisterIdent]); // should never happen

          end;

        end

        else begin

          // pass by value

          if (RegisterIdent=0) AND (FPRegisterIdent=0) AND (SizeInStack>0) then

          MoveFast(Value^,Stack[InStackOffset],SizeInStack) else begin

            if (RegisterIdent>0) then begin

              call.ParamRegs[RegisterIdent] := PPtrInt(Value)^;

              {$ifdef CPUARM}

              // for e.g. INT64 on 32 bit ARM systems; these are also passed in the normal registers

              if SizeInStack>PTRSIZ then

                call.ParamRegs[RegisterIdent+1] := PPtrInt(Value+PTRSIZ)^;

              {$endif}

            end;

            {$ifndef CPUX86}

            if FPRegisterIdent>0 then

              call.FPRegs[FPRegisterIdent] := PDouble(Value)^;

            {$endif}

            if (RegisterIdent>0) and (FPRegisterIdent>0) then

              raise EInterfaceFactoryException.CreateUTF8('Unexpected % reg=% FP=%',

                [ParamName^,RegisterIdent,FPRegisterIdent]); // should never happen

          end;

        end;

    end;

    // execute the method

    for i := 0 to InstancesLast do begin

      // handle method execution interception

      fCurrentStep := smsBefore;

      if fOnExecute<>nil then begin

        if (Input.Count=0) and (optInterceptInputOutput in Options) then

          ArgsStackAsDocVariant(fValues,fInput,true);

        for e := 0 to length(fOnExecute)-1 do

        try

          fOnExecute[e](self,smsBefore);

        except // ignore any exception during interception

        end;

      end;

      // prepare the low-level call context for the asm stub

      {$ifndef CPUAARCH64}

      call.ParamRegs[PARAMREG_FIRST] := PtrInt(Instances[i]);

      {$else}

      // alf note for FPC on Linux aarch64:

      // the above is not true for aarch64, when a function result is a pointer 

      // the function result pointer is placed in REGX0 and self in REGX1

      // thus, in that case: call.ParamRegs[REGX1] := PtrInt(Instances[i]);

       if call.ParamRegs[PARAMREG_FIRST]=0 then

          call.ParamRegs[PARAMREG_FIRST] := PtrInt(Instances[i]) else

          call.ParamRegs[REGX1] := PtrInt(Instances[i]);

      {$endif}

      call.method := PPtrIntArray(PPointer(Instances[i])^)^[ExecutionMethodIndex];

      if ArgsResultIndex>=0 then

        call.resKind := Args[ArgsResultIndex].ValueType else

        call.resKind := smvNone;

      // launch the asm stub in the expected execution context

      try

        {$ifndef LVCL}

        if (optExecInMainThread in Options) and

           (GetCurrentThreadID<>MainThreadID) then

          BackgroundExecuteCallMethod(@call,nil) else

        {$endif}

        if optExecInPerInterfaceThread in Options then

          if Assigned(BackgroundExecutionThread) then

            BackgroundExecuteCallMethod(@call,BackgroundExecutionThread) else

            raise EInterfaceFactoryException.Create('optExecInPerInterfaceThread'+

              ' with BackgroundExecutionThread=nil') else

          CallMethod(call);

        if (ArgsResultIndex>=0) and (Args[ArgsResultIndex].ValueVar=smvv64) then

          PInt64Rec(fValues[ArgsResultIndex])^ := call.res64;

        // handle method execution interception

        fCurrentStep := smsAfter;

        if fOnExecute<>nil then begin

          if (Output.Count=0) and (optInterceptInputOutput in Options) then

            ArgsStackAsDocVariant(fValues,fOutput,false);

          for e := 0 to length(fOnExecute)-1 do

          try

            fOnExecute[e](self,smsAfter);

          except // ignore any exception during interception

          end;

        end;

      except // also intercept any error during method execution

        on Exc: Exception do begin

          if fOnExecute<>nil then begin

            fCurrentStep := smsError;

            fLastException := Exc;

            for e := 0 to length(fOnExecute)-1 do

            try

              fOnExecute[e](self,smsError);

            except // ignore any exception during interception

            end;

            fLastException := nil;

          end;

          raise; // caller expects the exception to be propagated

        end;

      end;

    end;

  end;

end;



function TServiceMethodExecute.TempTextWriter: TJSONSerializer;

begin

  if fTempTextWriter=nil then begin

    fTempTextWriter := TJSONSerializer.CreateOwnedStream;

    include(fTempTextWriter.fCustomOptions,twoForceJSONExtended); // shorter

  end;

  result := fTempTextWriter;

end;



procedure TServiceMethodExecute.AfterExecute;

var i,a: integer;

begin

  Finalize(fRawUTF8s);

  Finalize(fStrings);

  Finalize(fWideStrings);

  with fMethod^ do

  if ArgsManagedFirst>=0 then begin

    for i := 0 to ArgsUsedCount[smvvObject]-1 do

      fObjects[i].Free;

    for i := 0 to ArgsUsedCount[smvvInterface]-1 do

      IUnknown(fInterfaces[i]) := nil;

    for i := 0 to ArgsUsedCount[smvvDynArray]-1 do

      fDynArrays[i].Wrapper.Clear; // will handle T*ObjArray as expected

    if fRecords<>nil then begin

      i := 0;

      for a := ArgsManagedFirst to ArgsManagedLast do

      with Args[a] do

      case ValueType of

      smvRecord: begin

        RecordClear(fRecords[i][0],ArgTypeInfo);

        inc(i);

      end;

      {$ifndef NOVARIANTS}

      smvVariant: begin

        VarClear(PVariant(fRecords[i])^); // fast, even for simple types

        inc(i);

      end;

      {$endif}

      end;

    end;

  end;

end;



function TServiceMethodExecute.ExecuteJson(const Instances: array of pointer; Par: PUTF8Char;

  Res: TTextWriter; ResAsJSONObject: boolean): boolean;

var a,a1: integer;

    wasString, valid: boolean;

    Val: PUTF8Char;

    Name: PUTF8Char;

    NameLen: integer;

    EndOfObject: AnsiChar;

    ParObjValues: TPUTF8CharDynArray;

begin

  //alfchange

  ParObjValues:=nil;

  result := false;

  if high(Instances)<0 then

    exit;

  BeforeExecute;

  with fMethod^ do

  try

    // validate input parameters

    if (ArgsInputValuesCount<>0) and (Par<>nil) then begin

      if Par^ in [#1..' '] then repeat inc(Par) until not(Par^ in [#1..' ']);

      case Par^ of

      '[': // input arguments as a JSON array , e.g. '[1,2,"three"]' (default)

        inc(Par);

      '{': begin // retrieve parameters values from JSON object

        inc(Par);

        SetLength(ParObjValues,ArgsInLast+1); // nil will set default value

        a1 := ArgsInFirst;

        repeat

          Name := GetJSONPropName(Par);

          if Name=nil then

            exit; // invalid JSON object in input

          NameLen := StrLen(Name);

          Val := Par;

          Par := GotoNextJSONItem(Par,1,@EndOfObject);

          for a := a1 to ArgsInLast do

          with Args[a] do

          if ValueDirection<>smdOut then

            if IdemPropName(ParamName^,Name,NameLen) then begin

              ParObjValues[a] := Val; // fast redirection, without allocation

              if a=a1 then

                inc(a1); // enable optimistic O(1) search for in-order input

              break;

            end;

        until (Par=nil) or (EndOfObject='}');

        Par := nil;

      end;

      else exit; // only support JSON array or JSON object as input

      end;

    end;

    // decode input parameters (if any) in f*[]

    if (Par=nil) and (ParObjValues=nil) then begin

      if (ArgsInputValuesCount>0) and (optErrorOnMissingParam in Options) then

        exit; // paranoid setting

    end else

      for a := ArgsInFirst to ArgsInLast do

      with Args[a] do

      if ValueDirection<>smdOut then begin

        if ParObjValues<>nil then

          if ParObjValues[a]=nil then // missing parameter in input JSON

            if optErrorOnMissingParam in Options then

              exit else     // paranoid setting

              continue else // ignore and use void value by default

            Par := ParObjValues[a]; // value is to be retrieved from JSON object

        case ValueType of

        smvObject: begin

          Par := JSONToObject(fObjects[IndexVar],Par,valid,nil,JSONTOOBJECT_TOLERANTOPTIONS);

          if not valid then

            exit;

          IgnoreComma(Par);

        end;

        smvInterface:

          if Assigned(OnCallback) then

            OnCallback(Par,ArgTypeInfo,fInterfaces[IndexVar]) else

            raise EInterfaceFactoryException.CreateUTF8(

              'Unhandled %(%: %) parameter',[URI,ParamName^,ArgTypeName^]);

        smvRawJSON:

          GetJSONItemAsRawJSON(Par,RawJSON(fRawUTF8s[IndexVar]));

        smvDynArray: begin

          Par := fDynArrays[IndexVar].Wrapper.LoadFromJSON(Par);

          IgnoreComma(Par);

        end;

        smvRecord:

          Par := RecordLoadJSON(pointer(fRecords[IndexVar])^,Par,ArgTypeInfo);

        {$ifndef NOVARIANTS}

        smvVariant:

          Par := VariantLoadJSON(PVariant(pointer(fRecords[IndexVar]))^,Par,nil,

            @JSON_OPTIONS[optVariantCopiedByReference in Options]);

        {$endif}

        smvBoolean..smvWideString: begin

          Val := GetJSONField(Par,Par,@wasString,@EndOfObject);

          if (Val=nil) and (Par=nil) and (EndOfObject<>'}') then

            exit;  // 'null' will set Val=nil and Par<>nil

          if (Val<>nil) and (wasString and not (vIsString in ValueKindAsm)) then

            exit;

          case ValueType of

          smvBoolean:

            fInt64s[IndexVar] := byte((Val<>nil) and

              ((PWord(Val)^=ord('1'))or(PInteger(Val)^=TRUE_LOW)));

          smvEnum..smvInt64:

            SetInt64(Val,fInt64s[IndexVar]);

          smvDouble,smvDateTime:

            PDouble(@fInt64s[IndexVar])^ := GetExtended(Val);

          smvCurrency:

            fInt64s[IndexVar] := StrToCurr64(Val);

          smvRawUTF8:

            SetString(fRawUTF8s[IndexVar],Val,StrLen(Val));

          smvString:

            UTF8DecodeToString(Val,StrLen(Val),fStrings[IndexVar]);

          smvRawByteString:

            Base64ToBin(PAnsiChar(Val),StrLen(Val),RawByteString(fRawUTF8s[IndexVar]));

          smvWideString:

            UTF8ToWideString(Val,StrLen(Val),fWideStrings[IndexVar]);

          else exit; // should not happen

          end;

          continue; // here Par=nil or Val=nil is correct

        end;

        else continue;

        end;

        if Par=nil then

          exit;

      end;

    // execute the method, using prepared values in f*[]

    RawExecute(@Instances[0],high(Instances));

    // send back any result

    if Res<>nil then begin

      // handle custom content (not JSON array/object answer)

      if ArgsResultIsServiceCustomAnswer then

        with PServiceCustomAnswer(fValues[ArgsResultIndex])^ do

        if Header<>'' then begin

          fServiceCustomAnswerHead := Header;

          Res.ForceContent(Content);

          if Status=0 then // Values[]=@Records[] is filled with 0 by default

            fServiceCustomAnswerStatus := HTML_SUCCESS else

            fServiceCustomAnswerStatus := Status;

          Result := true;

          exit;

        end;

      // write the '{"result":[...' array or object

      for a := ArgsOutFirst to ArgsOutLast do

      with Args[a] do

      if ValueDirection in [smdVar,smdOut,smdResult] then begin

        if ResAsJSONObject then

          Res.AddPropName(ParamName^);

        AddJSON(Res,fValues[a]);

      end;

      Res.CancelLastComma;

    end;

    Result := true;

  finally

    Finalize(ParObjValues);

    AfterExecute;

  end;

end;





{ TSQLRecordServiceLog }



class procedure TSQLRecordServiceLog.InitializeTable(

  Server: TSQLRestServer; const FieldName: RawUTF8;

  Options: TSQLInitializeTableOptions);

begin

  inherited;

  if FieldName='' then

    Server.CreateSQLMultiIndex(Self,['Method','MicroSec'],false);

end;



class procedure TSQLRecordServiceLog.InternalDefineModel(Props: TSQLRecordProperties);

begin

  Props.SetVariantFieldsDocVariantOptions(JSON_OPTIONS_FAST_EXTENDED);

  Props.SetCustomCollationForAll(sftUTF8Text,'NOCASE'); // slightly faster

end;





{ TSQLRecordServiceNotifications }



class procedure TSQLRecordServiceNotifications.InitializeTable(

  Server: TSQLRestServer; const FieldName: RawUTF8;

  Options: TSQLInitializeTableOptions);

begin

  inherited;

  if (FieldName='') or (FieldName='Sent') then

    Server.CreateSQLMultiIndex(Self,['Sent'],false);

end;



class function TSQLRecordServiceNotifications.LastEventsAsObjects(Rest: TSQLRest;

  LastKnownID: TID; Limit: integer; Service: TInterfaceFactory; out Dest: TDocVariantData;

  const MethodName: RawUTF8; IDAsHexa: boolean): boolean;

var res: TSQLRecordServiceNotifications;

begin

  res := CreateAndFillPrepare(Rest,'ID > ? order by ID limit %',[Limit],

    [LastKnownID],'ID,Method,Input');

  try

    if res.FillTable.RowCount > 0 then begin

      res.SaveFillInputsAsObjects(Service,Dest,MethodName,IDAsHexa);

      result := true;

    end else

      result := false;

  finally

    res.Free;

  end;

end;



function TSQLRecordServiceNotifications.SaveInputAsObject(Service: TInterfaceFactory;

  const MethodName: RawUTF8; IDAsHexa: boolean): variant;

var m: integer;

begin

  VarClear(result);

  with TDocVariantData(result) do

    if IDAsHexa then

      InitObject(['ID',Int64ToHex(fID),MethodName,Method],JSON_OPTIONS_FAST) else

      InitObject(['ID',fID,MethodName,Method],JSON_OPTIONS_FAST);

  m := Service.FindMethodIndex(Method);

  if m>=0 then

    Service.Methods[m].ArgsAsDocVariantObject(_Safe(fInput)^,TDocVariantData(result),true);

end;



procedure TSQLRecordServiceNotifications.SaveFillInputsAsObjects(Service: TInterfaceFactory;

  out Dest: TDocVariantData; const MethodName: RawUTF8; IDAsHexa: boolean);

begin

  Dest.InitFast(FillTable.RowCount,dvArray);

  while FillOne do

    Dest.AddItem(SaveInputAsObject(Service,MethodName,IDAsHexa));

end;





{ TServiceContainerClient }



function TServiceContainerClient.Info(aTypeInfo: PTypeInfo): TServiceFactory;

begin

  result := inherited Info(aTypeInfo);

  if (result=nil) and (not fDisableAutoRegisterAsClientDriven) then

    result := AddInterface(aTypeInfo,sicClientDriven);

end;



function TServiceContainerClient.CallBackUnRegister(const Callback: IInvokable): boolean;

begin

  if Assigned(Callback) then

    result := (fRest as TSQLRestClientURI).fFakeCallbacks.UnRegister(pointer(Callback)) else

    result := false;

end;





{ TInterfacedCallback }



constructor TInterfacedCallback.Create(aRest: TSQLRest; const aGUID: TGUID);

begin

  inherited Create;

  fRest := aRest;

  fInterface := aGUID;

end;



procedure TInterfacedCallback.CallbackRestUnregister;

var Obj: pointer; // to avoid unexpected (recursive) Destroy call

begin

  if (fRest<>nil) and (fRest.Services<>nil) and not IsNullGUID(fInterface) then 

    if GetInterface(fInterface,Obj) then begin

      fRest.Services.CallBackUnRegister(IInvokable(Obj));

      dec(fRefCount); // GetInterface() did increase the refcount

      fRest := nil; // notify once

    end;

end;



destructor TInterfacedCallback.Destroy;

begin

  CallbackRestUnregister;

  inherited Destroy;

end;





{ TBlockingCallback }



constructor TBlockingCallback.Create(aTimeOutMs: integer;

   aRest: TSQLRest; const aGUID: TGUID);

begin

  inherited Create(aRest,aGUID);

  fProcess := TBlockingProcess.Create(aTimeOutMs,fSafe);

end;



destructor TBlockingCallback.Destroy;

begin

  FreeAndNil(fProcess);

  inherited Destroy;

end;



procedure TBlockingCallback.CallbackFinished(aRestForLog: TSQLRest;

  aServerUnregister: boolean);

begin

  if fProcess.NotifyFinished then begin

    {$ifdef WITHLOG}

    if aRestForLog<>nil then

      aRestForLog.LogClass.Add.Log(sllTrace,self);

    {$endif}

    if aServerUnregister then

      CallbackRestUnregister;

  end;

end;



function TBlockingCallback.WaitFor: TBlockingEvent;

begin

  result := fProcess.WaitFor;

end;



function TBlockingCallback.Reset: boolean;

begin

  result := fProcess.Reset;

end;



function TBlockingCallback.GetEvent: TBlockingEvent;

begin

  result := fProcess.Event;

end;





{ TServiceRecordVersionCallback }



constructor TServiceRecordVersionCallback.Create(aSlave: TSQLRestServer;

  aMaster: TSQLRestClientURI; aTable: TSQLRecordClass; aOnNotify: TOnBatchWrite);

begin

  if aSlave=nil then

    raise EServiceException.CreateUTF8('%.Create(%): Slave=nil',[self,aTable]);

  fSlave := aSlave;

  fRecordVersionField := aTable.RecordProps.RecordVersionField;

  if fRecordVersionField=nil then

    raise EServiceException.CreateUTF8('%.Create: % has no TRecordVersion field',

      [self,aTable]);

  fTableDeletedIDOffset := Int64(fSlave.Model.GetTableIndexExisting(aTable))

    shl SQLRECORDVERSION_DELETEID_SHIFT;

  inherited Create(aMaster,IServiceRecordVersionCallback);

  fTable := aTable;

  fOnNotify := aOnNotify;

end;



procedure TServiceRecordVersionCallback.SetCurrentRevision(

  const Revision: TRecordVersion; Event: TSQLOccasion);

begin

  if (Revision<fSlave.fRecordVersionMax) or

     ((Revision=fSlave.fRecordVersionMax) and (Event<>soInsert)) then

    raise EServiceException.CreateUTF8('%.SetCurrentRevision(%) on %: previous was %',

      [self,Revision,fTable,fSlave.fRecordVersionMax]);

  fSlave.fRecordVersionMax := Revision;

end;



procedure TServiceRecordVersionCallback.Added(const NewContent: RawJSON);

var rec: TSQLRecord;

    fields: TSQLFieldBits;

begin

  rec := fTable.Create;

  try

    rec.FillFrom(NewContent,@fields);

    if fBatch=nil then

      fSlave.Add(rec,true,true,true) else

      fBatch.Add(rec,true,true,fields,true);

    SetCurrentRevision(fRecordVersionField.PropInfo.GetInt64Prop(rec),soInsert);

    if Assigned(fOnNotify) then

      fOnNotify(fBatch,soInsert,fTable,rec.IDValue,rec,fields);

  finally

    rec.Free;

  end;

end;



procedure TServiceRecordVersionCallback.Updated(const ModifiedContent: RawJSON);

var rec: TSQLRecord;

    fields: TSQLFieldBits;

begin

  rec := fTable.Create;

  try

    rec.FillFrom(ModifiedContent,@fields);

    if fBatch=nil then

      fSlave.Update(rec,fields,true) else

      fBatch.Update(rec,fields,true);

    SetCurrentRevision(fRecordVersionField.PropInfo.GetInt64Prop(rec),soUpdate);

    if Assigned(fOnNotify) then

      fOnNotify(fBatch,soUpdate,fTable,rec.IDValue,rec,fields);

  finally

    rec.Free;

  end;

end;



procedure TServiceRecordVersionCallback.Deleted(const ID: TID;

  const Revision: TRecordVersion);

var del: TSQLRecordTableDeleted;

begin

  del := TSQLRecordTableDeleted.Create;

  try

    del.IDValue := fTableDeletedIDOffset+Revision;

    del.Deleted := ID;

    if fBatch=nil then

    try

      fSlave.fAcquireExecution[execORMWrite].fSafe.Lock;

      fSlave.fRecordVersionDeleteIgnore := true;

      fSlave.Add(del,true,true,true);

      fSlave.Delete(fTable,ID);

    finally

      fSlave.fRecordVersionDeleteIgnore := false;

      fSlave.fAcquireExecution[execORMWrite].Safe.UnLock;

    end else begin

      fBatch.Add(del,true,true);

      fBatch.Delete(fTable,ID);

    end;

    SetCurrentRevision(Revision,soDelete);

    if Assigned(fOnNotify) then

      fOnNotify(fBatch,soDelete,fTable,ID,nil,[]);

  finally

    del.Free;

  end;

end;



procedure TServiceRecordVersionCallback.CurrentFrame(isLast: boolean);

procedure Error(const msg: RawUTF8);

begin

  fRest.InternalLog('%.CurrentFrame(%) on %: %',[self,isLast,fTable,msg],sllError);

end;

begin

  if isLast then begin

    if fBatch=nil then

      Error('unexpected last frame');

  end else

    if fBatch<>nil then

      Error('previous active BATCH -> send pending');

  if fBatch<>nil then

  try

    fSlave.fAcquireExecution[execORMWrite].fSafe.Lock;

    fSlave.fRecordVersionDeleteIgnore := true;

    fSlave.BatchSend(fBatch);

  finally

    fSlave.fRecordVersionDeleteIgnore := false;

    fSlave.fAcquireExecution[execORMWrite].Safe.UnLock;

    FreeAndNil(fBatch);

  end;

  if not isLast then

    fBatch := TSQLRestBatch.Create(fSlave,nil,10000);

end;



destructor TServiceRecordVersionCallback.Destroy;

var timeOut: Int64;

begin

  try

    if fBatch<>nil then begin

      timeOut := GetTickCount64+2000;

      repeat

        sleep(1); // allow 2 seconds to process all pending frames

        if fBatch=nil then

          exit;

      until GetTickCount64>timeOut;

      fSlave.InternalLog('%.Destroy on %: active BATCH',[self,fTable],sllError);

      fSlave.BatchSend(fBatch);

      fBatch.Free;

    end;

  finally

    inherited Destroy;

  end;

end;





{ TServiceFactoryClient }



function TServiceFactoryClient.CreateFakeInstance: TInterfacedObject;

var notify: TOnFakeInstanceDestroy;

begin

  if fInstanceCreation=sicClientDriven then

    notify := NotifyInstanceDestroyed else

    notify := nil;

  result := TInterfacedObjectFakeClient.Create(self,Invoke,notify);

end;



type

  TServiceFactoryClientNotificationThread = class(TSQLRestThread)

  protected

    fClient: TServiceFactoryClient;

    fRemote: TSQLRestClientURI;

    fRetryPeriodSeconds: Integer;

    fPending: integer;

    procedure InternalExecute; override;

    procedure ProcessPendingNotification;

    function GetPendingCountFromDB: Int64;

  public

    constructor Create(aClient: TServiceFactoryClient; aRemote: TSQLRestClientURI;

      aRetryPeriodSeconds: Integer); reintroduce;

  end;



constructor TServiceFactoryClientNotificationThread.Create(

  aClient: TServiceFactoryClient; aRemote: TSQLRestClientURI; aRetryPeriodSeconds: Integer);

begin

  fClient := aClient; // cross-platform may run Execute as soon as Create is called

  if (fClient=nil) or (fClient.fSendNotificationsRest=nil) or

     (fClient.fSendNotificationsLogClass=nil) then

    raise EServiceException.CreateUTF8('%.Create(fClient.fSendNotifications=nil)',[self]);

  if aRetryPeriodSeconds<=0 then

    fRetryPeriodSeconds := 1 else

    fRetryPeriodSeconds := aRetryPeriodSeconds;

  if aRemote=nil then

    fRemote := fClient.fClient else

    fRemote := aRemote;

  fPending := GetPendingCountFromDB;

  inherited Create(fClient.fClient,false,false);

end;



function TServiceFactoryClientNotificationThread.GetPendingCountFromDB: Int64;

begin

  if not fClient.fSendNotificationsRest.OneFieldValue(

      fClient.fSendNotificationsLogClass,'count(*)','Sent=?',[],[0],result) then

    result := 0;

end;



procedure TServiceFactoryClientNotificationThread.ProcessPendingNotification;

var pending: TSQLRecordServiceNotifications;

    params,error: RawUTF8;

    client: cardinal;

    count: integer;

    timer: TPrecisionTimer;

begin // one at a time, since InternalInvoke() is the bottleneck

  pending := fClient.fSendNotificationsLogClass.Create(

    fClient.fSendNotificationsRest,'Sent=? order by id limit 1',[0]);

  try

    if pending.IDValue=0 then begin

      fPending := GetPendingCountFromDB;

      if fPending=0 then

        exit else

        raise EServiceException.CreateUTF8(

          '%.ProcessPendingNotification pending=% with no DB row',[self,fPending]);

    end;

    timer.Start;

    VariantSaveJson(pending.Input,twJSONEscape,params);

    if (params<>'') and (params[1]='[') then

      params := copy(params,2,length(params)-2); // trim [..] for URI call

    client := pending.Session;

    if not fClient.InternalInvoke(pending.Method,params,nil,@error,@client,nil,fRemote) then begin

      if _Safe(pending.fOutput)^.GetAsInteger('errorcount',count) then

        inc(count) else

        count := 1;

      VarClear(pending.fOutput);        

      TDocVariantData(pending.fOutput).InitObject(['errorcount',count,

        'lasterror',error,'lasttime',NowUTCToString(true,'T'),

        'lastelapsed',timer.Stop],JSON_OPTIONS_FAST_EXTENDED);

      fClient.fSendNotificationsRest.Update(pending,'Output',true);

      raise EServiceException.CreateUTF8(

        '%.ProcessPendingNotification failed for %(%) [ID=%,pending=%] on %: %',

        [self,pending.Method,params,pending.IDValue,fPending,fRemote,error]);

    end;

    fClient.fClient.InternalLog('ProcessPendingNotification %(%) in % [ID=%,pending=%]',

      [pending.Method,params,timer.Stop,pending.IDValue,fPending],sllTrace);

    pending.Sent := TimeLogNowUTC;

    pending.MicroSec := timer.LastTimeInMicroSec;

    fClient.fSendNotificationsRest.Update(pending,'MicroSec,Sent',true);

    InterlockedDecrement(fPending);

  finally

    pending.Free;

  end;

end;



procedure TServiceFactoryClientNotificationThread.InternalExecute;

var delay: integer;

begin

  delay := 50;

  while not Terminated do begin

    while fPending>0 do

    try

      ProcessPendingNotification;

      delay := 0;

      if Terminated then

        exit;

    except

      SleepOrTerminated(fRetryPeriodSeconds*1000); // wait before retry

    end;

    if Terminated then

      exit;

    if delay<50 then

      inc(delay);

    SleepHiRes(delay);

  end;

end;



function TServiceFactoryClient.Invoke(const aMethod: TServiceMethod;

  const aParams: RawUTF8; aResult: PRawUTF8; aErrorMsg: PRawUTF8;

  aClientDrivenID: PCardinal; aServiceCustomAnswer: PServiceCustomAnswer): boolean;

  procedure SendNotificationsLog;

  var pending: TSQLRecordServiceNotifications;

      json: RawUTF8;

  begin

    pending := fSendNotificationsLogClass.Create;

    try

      pending.Method := aMethod.URI;

      json := '['+aParams+']';

      TDocVariantData(pending.fInput).InitJSONInPlace(pointer(json),JSON_OPTIONS_FAST_EXTENDED);

      if aClientDrivenID<>nil then

        pending.Session := aClientDrivenID^;

      fSendNotificationsRest.Add(pending,true);

    finally

      pending.Free;

    end;

  end;

begin

  if (fSendNotificationsRest<>nil) and (aMethod.ArgsOutputValuesCount=0) then begin

    SendNotificationsLog;

    if fSendNotificationsThread<>nil then

      InterlockedIncrement(TServiceFactoryClientNotificationThread(

        fSendNotificationsThread).fPending);

    result := true;

  end else

    result := InternalInvoke(

      aMethod.URI,aParams,aResult,aErrorMsg,aClientDrivenID,aServiceCustomAnswer);

end;



class function TServiceFactoryClient.GetErrorMessage(status: integer): RawUTF8;

begin

  case status of

    HTML_UNAVAILABLE: result := 'Check the communication parameters';

    HTML_NOTIMPLEMENTED: result := 'Server not reachable';

    HTML_NOTALLOWED: result := 'Method forbidden for this User group';

    HTML_UNAUTHORIZED: result := 'No active session';

    HTML_NOTACCEPTABLE: result := 'Invalid input parameters';

    else result := '';

  end;

end;



function TServiceFactoryClient.InternalInvoke(const aMethod: RawUTF8;

  const aParams: RawUTF8; aResult: PRawUTF8; aErrorMsg: PRawUTF8;

  aClientDrivenID: PCardinal; aServiceCustomAnswer: PServiceCustomAnswer;

  aClient: TSQLRestClientURI): boolean;

var uri,sent,resp,head,clientDrivenID: RawUTF8;

    Values: TPUtf8CharDynArray;

    status,m: integer;

    {$ifdef WITHLOG}

    Log: ISynLog; // for Enter auto-leave to work with FPC

    p: RawUTF8;

    {$endif}

begin

  result := false;

  if Self=nil then

    exit;

  if fClient=nil then

    fClient := fRest as TSQLRestClientURI;

  if aClient=nil then

    aClient := fClient;

  if (aClientDrivenID<>nil) and (aClientDrivenID^>0) then

    UInt32ToUTF8(aClientDrivenID^,clientDrivenID);

  m := fInterface.FindMethodIndex(aMethod);

  {$ifdef WITHLOG}

  if (m<0) or not (optNoLogInput in fExecution[m].Options) then

    p := aParams else

    p := 'optNoLogInput';

  Log := fRest.LogClass.Enter('InternalInvoke I%.%(%) %',

    [fInterfaceURI,aMethod,p,clientDrivenID],self);

  {$endif}

  // compute URI according to current routing scheme

  if fForcedURI<>'' then

    uri := fForcedURI else

    if fRest.Services.ExpectMangledURI then

      uri := aClient.Model.Root+'/'+fInterfaceMangledURI else

      uri := aClient.Model.Root+'/'+fInterfaceURI;

  fRest.ServicesRouting.ClientSideInvoke(uri,aMethod,aParams,clientDrivenID,sent);

  if ParamsAsJSONObject and (clientDrivenID='') then

    if m>=0 then  // ParamsAsJSONObject won't apply to _signature_ e.g.

      sent := fInterface.Methods[m].ArgsArrayToObject(Pointer(sent),true);

  // call remote server

  status := aClient.URI(uri,'POST',@resp,@head,@sent).Lo;

  // decode result

  if aServiceCustomAnswer=nil then begin

    // handle errors at REST level

    if not StatusCodeIsSuccess(status) then begin

      if aErrorMsg<>nil then begin

        if resp='' then begin

          StatusCodeToErrorMsg(status,resp);

          head := GetErrorMessage(status);

          if head<>'' then

            head := ' - '+head;

          aErrorMsg^ := FormatUTF8('URI % % returned status ''%'' (%%)',

            [uri,sent,resp,status,head]);

        end else

          aErrorMsg^ := resp;

      end;

      exit; // leave result=false

    end;

    // decode JSON object

    {$ifdef WITHLOG}

    if (m<0) or not (optNoLogOutput in fExecution[m].Options) then

    with fRest.fLogFamily do

      if (sllServiceReturn in Level) and (resp<>'') then

        SynLog.Log(sllServiceReturn,resp,self,MAX_SIZE_RESPONSE_LOG);

    {$endif}

    if fResultAsJSONObject then begin

      if aResult<>nil then

        aResult^ := resp;

      if aClientDrivenID<>nil then

        aClientDrivenID^ := 0;

    end else

    if (resp<>'') and (aClientDrivenID=nil) and

       not IdemPChar(GotoNextNotSpace(pointer(resp)),'{"RESULT":') then begin

      if aResult<>nil then

        aResult^ := resp; // e.g. when client retrieves the contract

    end else begin

      JSONDecode(pointer(resp),['result','id'],Values,True);

      if Values[0]=nil then begin // no "result":... layout

        if aErrorMsg<>nil then

          aErrorMsg^ :=

            'Invalid returned JSON content: expects {"result":...}, got '+resp;

        exit; // leave result=false

      end;

      if aResult<>nil then

        SetString(aResult^,Values[0],StrLen(Values[0]));

      if aClientDrivenID<>nil then // assume ID=0 if no "id":... value

        aClientDrivenID^ := GetCardinal(Values[1]);

    end;

  end else begin

    // custom answer returned in TServiceCustomAnswer

    fRest.InternalLog('TServiceCustomAnswer(%) returned status=% len=%',

      [head,status,length(resp)],sllServiceReturn);

    aServiceCustomAnswer^.Status := status;

    aServiceCustomAnswer^.Header := head;

    aServiceCustomAnswer^.Content := resp;

    if aClientDrivenID<>nil then

      aClientDrivenID^ := 0;

  end;

  result := true;

end;



procedure TServiceFactoryClient.NotifyInstanceDestroyed(aClientDrivenID: cardinal);

begin

  if aClientDrivenID<>0 then

    InternalInvoke(SERVICE_PSEUDO_METHOD[imFree],'',nil,nil,@aClientDrivenID);

end;



constructor TServiceFactoryClient.Create(aRest: TSQLRest;

  aInterface: PTypeInfo; aInstanceCreation: TServiceInstanceImplementation;

  const aContractExpected: RawUTF8);

var Error, RemoteContract: RawUTF8;

begin

  // extract interface RTTI and create fake interface (and any shared instance)

  if not aRest.InheritsFrom(TSQLRestClientURI) then

    EServiceException.CreateUTF8('%.Create(): % interface needs a Client connection',

      [self,aInterface^.Name]);

  inherited Create(aRest,aInterface,aInstanceCreation,aContractExpected);

  // initialize a shared instance (if needed)

  if fInstanceCreation in [sicShared,sicPerSession,sicPerUser,sicPerGroup,sicPerThread] then begin

    // the instance shall remain active during the whole client session

    fSharedInstance := CreateFakeInstance;

    TInterfacedObjectFake(fSharedInstance)._AddRef; // force stay alive

  end;

  // check if this interface is supported on the server

  if ContractExpected<>SERVICE_CONTRACT_NONE_EXPECTED then begin

    if not InternalInvoke(SERVICE_PSEUDO_METHOD[imContract],

       TSQLRestClientURI(fRest).fServicePublishOwnInterfaces,@RemoteContract,@Error) then

      raise EServiceException.CreateUTF8('%.Create(): I% interface or % routing not '+

        'supported by server: %',[self,fInterfaceURI,fRest.ServicesRouting,Error]);

    if ('['+ContractExpected+']'<>RemoteContract) and

       ('{"contract":'+ContractExpected+'}'<>RemoteContract) then

      raise EServiceException.CreateUTF8('%.Create(): server''s I% contract '+

        'differs from client''s: expected [%], received %',

        [self,fInterfaceURI,ContractExpected,RemoteContract]);

  end;

end;



destructor TServiceFactoryClient.Destroy;

begin

  FreeAndNil(fSendNotificationsThread);

  if fSharedInstance<>nil then

  with TInterfacedObjectFake(fSharedInstance) do

    if fRefCount<>1 then

      raise EServiceException.CreateUTF8('%.Destroy with RefCount=%: you must release '+

        'I% interface (setting := nil) before Client.Free',[self,fRefCount,fInterfaceURI]) else

      _Release; // bonne nuit les petits

  inherited;

end;



function TServiceFactoryClient.RetrieveSignature: RawUTF8;

begin

  result := '';

  if InternalInvoke(SERVICE_PSEUDO_METHOD[imSignature],'',@result) and

     (result<>'') then

    if result[1]='[' then

      result := copy(result,2,length(result)-2) else

    if IdemPChar(pointer(result),'{"SIGNATURE":') then

      result := copy(result,14,length(result)-14);

end;



function TServiceFactoryClient.Get(out Obj): Boolean;

var O: TInterfacedObjectFake;

begin

  result := false;

  if Self=nil then

    exit;

  case fInstanceCreation of

  sicShared, sicPerSession, sicPerUser, sicPerGroup, sicPerThread:

    O := TInterfacedObjectFake(fSharedInstance);

  sicSingle, sicClientDriven:

    O := TInterfacedObjectFake(CreateFakeInstance);

  else exit;

  end;

  if O=nil then

    exit;

  pointer(Obj) := @O.fVTable;

  O._AddRef;

  result := true;

end;



procedure TServiceFactoryClient.StoreNotifications(aRest: TSQLRest;

  aLogClass: TSQLRecordServiceNotificationsClass);

var c: TClass;

begin

  if (aRest=fSendNotificationsRest) and (aLogClass=fSendNotificationsLogClass) then

    exit;

  fSendNotificationsRest := aRest;

  fSendNotificationsLogClass := aLogClass;

  if aRest=nil then

    c := nil else

    c := aRest.ClassType;

  fClient.InternalLog('%.StoreNotifications(%,%) for I%',

    [ClassType,c,aLogClass,fInterfaceURI],sllTrace);

end;



procedure TServiceFactoryClient.SendNotifications(aRest: TSQLRest;

  aLogClass: TSQLRecordServiceNotificationsClass;

  aRetryPeriodSeconds: Integer; aRemote: TSQLRestClientURI);

begin

  if (self=nil) or (aRest=nil) or (aLogClass=nil) then

    raise EServiceException.CreateUTF8('%.SendNotifications invalid call',[self]);

  if fSendNotificationsThread<>nil then

    if (aRest=fSendNotificationsRest) and (aLogClass=fSendNotificationsLogClass) then begin

      fClient.InternalLog('%.SendNotifications(%,%) I% twice -> ignored',

        [ClassType,aRest.ClassType,aLogClass,fInterfaceURI],sllInfo);

      exit;

    end else

      raise EServiceException.CreateUTF8('%.SendNotifications twice',[self]);

  StoreNotifications(aRest,aLogClass);

  fSendNotificationsThread :=

    TServiceFactoryClientNotificationThread.Create(self,aRemote,aRetryPeriodSeconds);

end;



function TServiceFactoryClient.SendNotificationsPending: integer;

begin

  if (self=nil) or (fSendNotificationsThread=nil) then

    result := 0 else

    result := TServiceFactoryClientNotificationThread(fSendNotificationsThread).

      GetPendingCountFromDB;

end;



procedure TServiceFactoryClient.SendNotificationsWait(aTimeOutSeconds: integer);

var timeOut: Int64;

begin

  if SendNotificationsPending=0 then

    exit;

  {$ifdef WITHLOG}

  fClient.LogClass.Enter;

  {$endif}

  timeOut := GetTickCount64+aTimeOutSeconds*1000;

  repeat

    Sleep(5);

    if SendNotificationsPending=0 then

      exit;

  until GetTickCount64>timeOut;

end;



procedure TServiceFactoryClient.SetOptions(const aMethod: array of RawUTF8;

  aOptions: TServiceMethodOptions);

var o: TServiceMethodOption;

    m,i: integer;

begin

  for o := low(o) to high(o) do

    if (o in aOptions) and not (o in [optNoLogInput,optNoLogOutput]) then

      raise EServiceException.CreateUTF8('%.SetOptions(%) not supported',

        [self,GetEnumName(TypeInfo(TServiceMethodOption),ord(o))^]);

  if high(aMethod)<0 then

    for i := 0 to fInterface.fMethodsCount-1 do

      fExecution[i].Options := aOptions else

    for m := 0 to high(aMethod) do

      fExecution[fInterface.CheckMethodIndex(aMethod[m])].Options := aOptions;

end;





function ObjectFromInterface(const aValue: IInterface): TObject;

{$ifndef HASINTERFACEASTOBJECT}

type

  TObjectFromInterfaceStub = packed record

    Stub: cardinal;

    case integer of

    0: (ShortJmp: shortint);

    1: (LongJmp:  longint)

  end;

  PObjectFromInterfaceStub = ^TObjectFromInterfaceStub;

{$endif}

begin

  if aValue<>nil then

    {$ifdef HASINTERFACEASTOBJECT}

    result := aValue as TObject else // slower but always working

    {$else}

    with PObjectFromInterfaceStub(PPointer(PPointer(aValue)^)^)^ do

    case Stub of // address of VMT[0] entry, i.e. QueryInterface

      $04244483: begin

        result := pointer(PtrInt(aValue)+ShortJmp);

        exit;

      end;

      $04244481: begin

        result := pointer(PtrInt(aValue)+LongJmp);

        exit;

      end;

      else // recognize TInterfaceFactory.CreateFakeInstance() stub/mock

      if Stub=PCardinal(@TInterfacedObjectFake.FakeQueryInterface)^ then begin

        result := TInterfacedObjectFake(pointer(aValue)).SelfFromInterface;

        exit;

      end else begin

        result := nil;

        exit;

      end;

    end else

    {$endif}

    result := nil;

end;



function ObjectFromInterfaceImplements(const aValue: IInterface;

  const aInterface: TGUID): boolean;

var obj: TObject;

begin

  obj := ObjectFromInterface(aValue);

  if obj=nil then

    result := false else

    result := obj.GetInterfaceEntry(aInterface)<>nil;

end;



procedure SetWeak(aInterfaceField: PIInterface; const aValue: IInterface);

begin

  PPointer(aInterfaceField)^ := Pointer(aValue);

end;



type

  TSetWeakZeroInstance = class(TObjectListHashed)

  protected

    fInstance: TObject;

  public

    constructor Create(aObject: TObject; aReference: pointer);

    destructor Destroy; override;

    property Instance: TObject read fInstance;

  end;



  TSetWeakZeroClass = class(TObjectListPropertyHashed)

  protected

    fHookedFreeInstance: PtrUInt;

    fLock: TRTLCriticalSection;

    procedure HookedFreeInstance;

  public

    constructor Create(aClass: TClass);

    destructor Destroy; override;

    function Find(aObject: TObject): TSetWeakZeroInstance;

    function FindOrAdd(aObject: TObject; aReference: pointer): TSetWeakZeroInstance;

  end;





{ TSetWeakZeroInstance }



constructor TSetWeakZeroInstance.Create(aObject: TObject; aReference: pointer);

var wasAdded: boolean;

begin

  inherited Create(false);

  fInstance := aObject;

  Add(aReference,wasAdded);

  //assert(IndexOf(aReference)>=0);

end;



destructor TSetWeakZeroInstance.Destroy;

var i: integer;

begin

  for i := 0 to Count-1 do

    PPointer(List[i])^ := nil;

  inherited;

end;





{ TSetWeakZeroClass }



function WeakZeroClassSubProp(aObject: TObject): TObject;

begin

  result := TSetWeakZeroInstance(aObject).fInstance;

end;



constructor TSetWeakZeroClass.Create(aClass: TClass);

var PVMT: ^TObject;

    P: PPtrUInt;

begin

  inherited Create(@WeakZeroClassSubProp);

  PVMT := pointer(PtrInt(aClass)+vmtAutoTable);

  if PVMT^=nil then begin

    PatchCodePtrUInt(pointer(PVMT),PtrUInt(self),true); // LeaveUnprotected=true

    GarbageCollectorFreeAndNil(PVMT^,self); // set to nil at finalization

  end else

    if TClass(PPointer(PVMT^)^)=TSQLRecordProperties then

      GarbageCollectorFreeAndNil(  // set to nil at finalization

        TSQLRecordProperties(PVMT^).fWeakZeroClass,self) else

      raise EORMException.CreateUTF8(

        '%.Create: %.AutoTable VMT entry already used',[self,aClass]);

  InitializeCriticalSection(fLock);

  EnterCriticalSection(fLock);

  {$WARN SYMBOL_DEPRECATED OFF}

  P := pointer(PtrInt(aClass)+vmtFreeInstance);

  {$WARN SYMBOL_DEPRECATED ON}

  fHookedFreeInstance := P^;

  PatchCodePtrUInt(P,PtrUInt(@TSetWeakZeroClass.HookedFreeInstance));

end;



destructor TSetWeakZeroClass.Destroy;

begin

  DeleteCriticalSection(fLock);

  inherited;

end;



function EnterWeakZeroClass(aObject: TObject; CreateIfNonExisting: boolean): TSetWeakZeroClass;

 {$ifdef HASINLINE}inline;{$endif}

begin

  result := PPointer(PPtrInt(aObject)^+vmtAutoTable)^;

  if (result<>nil) and (TClass(PPointer(result)^)=TSQLRecordProperties) then

    result := TSetWeakZeroClass(TSQLRecordProperties(result).fWeakZeroClass);

  if result<>nil then

    EnterCriticalSection(result.fLock) else

    if CreateIfNonExisting then

      result := TSetWeakZeroClass.Create(PPointer(aObject)^);

end;



procedure TSetWeakZeroClass.HookedFreeInstance;

begin

  with EnterWeakZeroClass(self,false) do begin // if hooked -> never nil

    try

      Delete(self);

    finally

      LeaveCriticalSection(fLock);

    end;

    TSimpleMethodCall(fHookedFreeInstance)(self);

  end;

end;



function TSetWeakZeroClass.Find(aObject: TObject): TSetWeakZeroInstance;

var i: integer;

begin

  i := IndexOf(aObject); // search List[i].fInstance=aObject

  if i>=0 then

    result := TSetWeakZeroInstance(List[i]) else

    result := nil;

end;



function TSetWeakZeroClass.FindOrAdd(aObject: TObject; aReference: pointer): TSetWeakZeroInstance;

var wasAdded: boolean;

    i: integer;

begin

  i := inherited Add(aObject,wasAdded);

  if wasAdded then begin

    result := TSetWeakZeroInstance.Create(aObject,aReference);

    List[i] := result;

    //assert(IndexOf(aObject)>=0);

  end else begin

    result := TSetWeakZeroInstance(List[i]);

    result.Add(aReference,wasAdded);

  end;

  //assert(result.IndexOf(aReference)>=0);

  //assert(result.fInstance=aObject);

end;



procedure SetWeakZero(aObject: TObject; aObjectInterfaceField: PIInterface;

  const aValue: IInterface);

var aObjectWeakClass, aObjectInterfaceWeakClass: TSetWeakZeroClass;

    aObjectInterfaceObject, aValueObject: TObject;

begin

  if (aObjectInterfaceField=nil) or (aObject=nil) or (aObjectInterfaceField^=aValue) then

    exit;

  aObjectWeakClass := EnterWeakZeroClass(aObject,false);

  try

    if aObjectInterfaceField^<>nil then begin

      if aValue=nil then

        aObjectWeakClass.Delete(TObject(aObjectInterfaceField));

      aObjectInterfaceObject := ObjectFromInterface(aObjectInterfaceField^);

      if aObjectInterfaceObject<>nil then begin

        aObjectInterfaceWeakClass := EnterWeakZeroClass(aObjectInterfaceObject,false);

        if aObjectInterfaceWeakClass<>nil then

        try

          aObjectInterfaceWeakClass.Find(aObjectInterfaceObject).Delete(TObject(aObjectInterfaceField));

        finally

          LeaveCriticalSection(aObjectInterfaceWeakClass.fLock);

        end;

      end;

      SetWeak(aObjectInterfaceField,nil);

      if aValue=nil then

        exit;

    end;

    if aObjectWeakClass=nil then // for faster Delete() just above

      aObjectWeakClass := TSetWeakZeroClass.Create(PPointer(aObject)^);

    aObjectWeakClass.FindOrAdd(aObject,aObjectInterfaceField);

    aValueObject := ObjectFromInterface(aValue);

    if aValueObject<>nil then

      with EnterWeakZeroClass(aValueObject,true) do

      try

        FindOrAdd(aValueObject,aObjectInterfaceField);

      finally

        LeaveCriticalSection(fLock);

      end;

    SetWeak(aObjectInterfaceField,aValue);

  finally

    if aObjectWeakClass<>nil then

      LeaveCriticalSection(aObjectWeakClass.fLock);

  end;

end;



{$ifdef ISDELPHIXE}

procedure TWeakZeroInterfaceHelper.SetWeak0(aObjectInterfaceField: PIInterface;

  const aValue: IInterface);

begin

  SetWeakZero(self,aObjectInterfaceField,aValue);

end;

{$endif}



function ObjArraySearch(const aSQLRecordObjArray; aID: TID): TSQLRecord;

var i: integer;

    a: TSQLRecordObjArray absolute aSQLRecordObjArray;

begin

  for i := 0 to length(a)-1 do

    if a[i].IDValue=aID then begin

      result := a[i];

      exit;

    end;

  result := nil;

end;



procedure ObjArrayRecordIDs(const aSQLRecordObjArray; out result: TInt64DynArray);

var

  i, n: integer;

  a: TSQLRecordObjArray absolute aSQLRecordObjArray;

begin

  n := length(a);

  SetLength(result,n);

  for i := 0 to n-1 do

    result[i] := a[i].IDValue;

end;



procedure InterfaceArrayDeleteAfterException(var aInterfaceArray;

  const aItemIndex: integer; aLog: TSynLogFamily; const aLogMsg: RawUTF8;

  aInstance: TObject);

begin

  try

    {$ifdef WITHLOG}

    aLog.SynLog.Log(sllWarning,'InterfaceArrayDeleteAfterException %',[aLogMsg],aInstance);

    {$endif}

    InterfaceArrayDelete(aInterfaceArray,aItemIndex);

  except

    on E: Exception do

      aLog.SynLog.Log(sllDebug,'Callback unstability at deletion: %',[E],aInstance);

  end;

end;



procedure SetThreadNameWithLog(ThreadID: TThreadID; const Name: RawUTF8);

begin

  {$ifdef WITHLOG}

  if (SetThreadNameLog<>nil) and (ThreadID=GetCurrentThreadId) then

    SetThreadNameLog.Add.LogThreadName(Name);

  {$endif}

  SetThreadNameDefault(ThreadID,Name);

end;



initialization

  pointer(@SQLFieldTypeComp[sftAnsiText]) := @AnsiIComp;

  pointer(@SQLFieldTypeComp[sftUTF8Custom]) := @AnsiIComp;

  pointer(@SQLFieldTypeComp[sftObject]) := @StrComp;

  {$ifndef NOVARIANTS}

  pointer(@SQLFieldTypeComp[sftVariant]) := @StrComp;

  pointer(@SQLFieldTypeComp[sftNullable]) := @StrComp;

  {$endif}

  {$ifndef USENORMTOUPPER}

  pointer(@SQLFieldTypeComp[sftUTF8Text]) := @AnsiIComp;

  {$endif}

  SetThreadNameDefault(GetCurrentThreadID,'Main Thread');

  SetThreadNameInternal := SetThreadNameWithLog;

  TTextWriter.SetDefaultJSONClass(TJSONSerializer);

  TJSONSerializer.RegisterObjArrayForJSON(

    [TypeInfo(TSQLModelRecordPropertiesObjArray),TSQLModelRecordProperties]);

  TJSONSerializer.RegisterCustomJSONSerializerFromText(

    [TypeInfo(TServicesPublishedInterfaces),_TServicesPublishedInterfaces,

     TypeInfo(TSQLRestServerURI),_TSQLRestServerURI]);

  SynCommons.DynArrayIsObjArray := InternalIsObjArray;

  InitializeCriticalSection(GlobalInterfaceResolutionLock);

  TInterfaceResolverInjected.RegisterGlobal(TypeInfo(IAutoLocker),TAutoLocker);

  TInterfaceResolverInjected.RegisterGlobal(TypeInfo(ILockedDocVariant),TLockedDocVariant);

  assert(sizeof(TServiceMethod)and 3=0,'wrong padding');

  TSQLRestServerFullMemory.RegisterClassNameForDefinition;

  {$ifdef MSWINDOWS}

  TSQLRestClientURINamedPipe.RegisterClassNameForDefinition;

  TSQLRestClientURIMessage.RegisterClassNameForDefinition;

  {$endif}



finalization

  FinalizeGlobalInterfaceResolution;

end.