Vichingo455-RePacks
/
xtool
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases 1 Wiki Activity
xtool/contrib/mORMot/SQLite3/mORMot.pas

61883 lines
2.4 MiB
Raw Blame History

/// 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) 2022 Arnaud Bouchez
Synopse Informatique - https://synopse.info
*** BEGIN LICENSE BLOCK *****
Version: MPL 1.1/GPL 2.0/LGPL 2.1
The contents of this file are subject to the Mozilla Public License Version
1.1 (the "License"); you may not use this file except in compliance with
the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
for the specific language governing rights and limitations under the License.
The Original Code is Synopse mORMot framework.
The Initial Developer of the Original Code is Arnaud Bouchez.
Portions created by the Initial Developer are Copyright (C) 2022
the Initial Developer. All Rights Reserved.
Contributor(s):
Alexander (chaa)
Alfred Glaenzer (alf)
Daniel Kuettner
DigDiver
EgorovAlex
Emanuele (lele9)
Esmond
Goran Despalatovic (gigo)
Jordi Tudela
Jean-Baptiste Roussia (jbroussia)
Lagodny
Maciej Izak (hnb)
Martin Suer
Michalis Kamburelis
MilesYou
Ondrej
Pavel Mashlyakovskii (mpv)
Sabbiolina
Svetozar Belic (transmogrifix)
Uian2000
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 *****
*)
{$I ..\Synopse.inc} // define HASINLINE CPU32 CPU64
{.$define PUREPASCAL} // 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 https://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'
// - Setting NOSSPIAUTH conditional will disable this feature
{$else}
{$define GSSAPIAUTH}
// if defined, the Kerberos authentication (using gssapi library) will be used
// along with the usual one
// - In this case, in table TSQLAuthUser should be an entry for the
// domain user, with the LoginName in form 'username@DOMAIN.TLD'
// - Linux server should joind a domain before using this
// - KRB5_KTNAME environment variable or ServerForceKeytab shoud point
// to valid readable keytab file with correct server credentials
// - For more information on how to prepare server read an article on how to
// configure MS SQL Server on Linux to use Windows authentication
// https://www.mssqltips.com/sqlservertip/5075/configure-sql-server-on-linux-to-use-windows-authentication
// - Setting NOGSSAPIAUTH conditional will disable this feature
// Limitations:
// - no NTLM support - this is a deprecated and vulnerable protocol
{$endif MSWINDOWS}
{$ifdef KYLIX3}
{$define NOGSSAPIAUTH} // SynGSSAPI.pas unit is not Kylix-compatible
{$endif}
{$ifdef Android}
{$define NOGSSAPIAUTH} // SynGSSAPI.pas unit is not Android-compatible [anymore]
{$endif}
{$ifdef SSPIAUTH}
{$undef GSSAPIAUTH} // exclusive
{$ifdef NOSSPIAUTH}
{$undef SSPIAUTH} // force disable
{$undef DOMAINAUTH}
{$else}
{$define DOMAINAUTH}
{$endif}
{$endif}
{$ifdef GSSAPIAUTH}
{$undef SSPIAUTH} // exclusive
{$ifdef NOGSSAPIAUTH}
{$undef GSSAPIAUTH} // force disable
{$undef DOMAINAUTH}
{$else}
{$define DOMAINAUTH}
{$endif}
{$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
{$ifndef LVCL}
SyncObjs, // for TEvent
Contnrs, // for TObjectList
{$ifndef NOVARIANTS}
Variants,
{$endif}
{$endif LVCL}
SysUtils,
{$ifdef SSPIAUTH}
SynSSPI,
SynSSPIAuth,
{$endif}
{$ifdef GSSAPIAUTH}
SynGSSAPI,
SynGSSAPIAuth,
{$endif}
{$ifdef FPC}
SynFPCTypInfo, // small wrapper unit around FPC's TypInfo.pp
{$endif}
SynCommons,
SynTable, // for SynTable, TSynFilter and TSynValidate
SynLog,
SynCrypto, // SHA-256 and IProtocol
SynTests; // for mocks integration
{ ************ 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;
/// pointer to a dynamic array of ORM primary keys, i.e. TSQLRecord.ID
PIDDynArray = ^TIDDynArray;
/// 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+) - you may inherit
// from TSQLRecordNoCase to use the NOCASE standard SQLite3 collation
//- 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
// - sftDateTimeMS is a ISO 8601 encoded (SQLite3 compatible) TEXT field,
// corresponding to a TDateTimeMS Delphi property, i.e. a TDateTime with
// millisecond resolution, serialized with '.sss' suffix: 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 will 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)
// - sftUnixTime is an INTEGER field for coding a date and time as second-based
// Unix Time (SQLite3 compatible), which should be defined as TUnixTime=Int64
// TSQLRecord property
// - sftUnixMSTime is an INTEGER field for coding a date and time as
// millisecond-based Unix Time (JavaScript compatible), which should be
// defined as TUnixMSTime=Int64 TSQLRecord property
// - WARNING: do not change the order of items below, otherwise some methods
// (like TSQLRecordProperties.CheckBinaryHeader) may be broken and fail
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,
sftDateTimeMS,
sftUnixTime,
sftUnixMSTime);
/// 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
Comp: TUTF8Compare;
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];
/// kind of fields which will be stored as TEXT values
// - i.e. RAWTEXT_FIELDS and TDateTime/TDateTimeMS
STRING_FIELDS: TSQLFieldTypes = [sftAnsiText,sftUTF8Text,sftUTF8Custom,
sftDateTime,sftDateTimeMS];
{$ifndef NOVARIANTS}
/// 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];
{$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); overload;
/// 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; Value: TID); overload;
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 will force the JSON to unquote the column names,
// e.g. writing col1:...,col2:... instead of "col1":...,"col2"...
// - boPostNoSimpleFields will avoid to send a TSQLRestBach.Add() with simple
// fields as "SIMPLE":[val1,val2...] or "SIMPLE@tablename":[val1,val2...],
// without the field names
// - boPutNoCacheFlush won't force the associated Cache entry to be flushed:
// it is up to the caller to ensure cache coherency
// - boRollbackOnError will raise an exception and Rollback any transaction
// if any step failed - default if to continue batch processs, but setting
// a value <> 200/HTTP_SUCCESS in Results[]
TSQLRestBatchOption = (
boInsertOrIgnore, boInsertOrReplace,
boExtendedJSON, boPostNoSimpleFields, boPutNoCacheFlush,
boRollbackOnError);
/// 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
{$ifdef USERECORDWITHMETHODS}TJSONObjectDecoder = record
{$else}TJSONObjectDecoder = object{$endif}
public
/// 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: TJSONObjectDecoderParams;
/// internal pointer over field names to be used after Decode() call
// - either FieldNames, either Fields[] array as defined in Decode(), or
// external names as set by TSQLRestStorageExternal.JSONDecodedPrepareToSQL
DecodedFieldNames: PRawUTF8Array;
/// the ID=.. value as sent within the JSON object supplied to Decode()
DecodedRowID: TID;
/// internal pointer over field types to be used after Decode() call
// - to create 'INSERT INTO ... SELECT UNNEST(...)' or 'UPDATE ... FROM
// SELECT UNNEST(...)' statements for very efficient bulk writes in a
// PostgreSQL database
// - as set by TSQLRestStorageExternal.JSONDecodedPrepareToSQL when
// cPostgreBulkArray flag is detected (for SynDBPostgres)
DecodedFieldTypesToUnnest: PSQLDBFieldTypeArray;
/// 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-bit integer) value from the numerical text stored in P^
// - just a redirection to SynCommons.SetInt64()
procedure SetID(P: PUTF8Char; var result: TID); overload;
{$ifdef HASINLINENOTX86}inline;{$endif}
/// set the TID (=64-bit 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 HASINLINENOTX86}inline;{$endif}
/// TDynArraySortCompare compatible function, sorting by TSQLRecord.ID
function TSQLRecordDynArrayCompare(const Item1,Item2): integer;
/// TDynArrayHashOne compatible function, hashing TSQLRecord.ID
function TSQLRecordDynArrayHashOne(const Elem; Hasher: THasher): cardinal;
/// 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 a ID/RowID>0 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;
{$ifdef HASINLINE}inline;{$endif}
/// 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
procedure BlobToTSQLRawBlob(P: PUTF8Char; var result: 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;
/// compute 'PropName in (...)' where clause for a SQL statement
// - if Values has no value, returns ''
// - if Values has a single value, returns 'PropName="Values0"' or inlined
// 'PropName=:("Values0"):' if ValuesInlined is true
// - if Values has more than one value, returns 'PropName in ("Values0","Values1",...)'
// or 'PropName in (:("Values0"):,:("Values1"):,...)' if length(Values)<ValuesInlinedMax
// - PropName can be used as a prefix to the 'in ()' clause, in conjunction
// with optional Suffix value
function SelectInClause(const PropName: RawUTF8; const Values: array of RawUTF8;
const Suffix: RawUTF8=''; ValuesInlinedMax: integer=0): RawUTF8; overload;
/// compute 'PropName in (...)' where clause for a SQL statement
// - if Values has no value, returns ''
// - if Values has a single value, returns 'PropName=Values0' or inlined
// 'PropName=:(Values0):' if ValuesInlined is bigger than 1
// - if Values has more than one value, returns 'PropName in (Values0,Values1,...)'
// or 'PropName in (:(Values0):,:(Values1):,...)' if length(Values)<ValuesInlinedMax
// - PropName can be used as a prefix to the 'in ()' clause, in conjunction
// with optional Suffix value
function SelectInClause(const PropName: RawUTF8; const Values: array of Int64;
const Suffix: RawUTF8=''; ValuesInlinedMax: integer=0): RawUTF8; overload;
/// 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, sftModTime/sftCreateTime/sftTimeLog or
// sftUnixTime/sftUnixMSTime 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 will 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);
/// returns TRUE on a nil instance or if all its published properties are default/0
// - calls internally TPropInfo.IsDefaultOrVoid()
function IsObjectDefaultOrVoid(Value: TObject): boolean;
/// will reset all the object properties to their default
// - strings will be set to '', numbers to 0
// - if FreeAndNilNestedObjects is the default FALSE, will recursively reset
// all nested class properties values
// - if FreeAndNilNestedObjects is TRUE, will FreeAndNil() all the nested
// class properties
// - for a 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"}',
// and append .map/.mab source code line number for ESynException
function ObjectToJSONDebug(Value: TObject; Options: TTextWriterWriteObjectOptions=
[woDontStoreDefault,woHumanReadable,woStoreClassName,woStorePointer]): 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 -
// this option will also ignore read-only properties (i.e. with only a getter)
// - by default, function will check that the supplied JSON value will
// be a JSON string when the property is a string, unless j2oIgnoreStringType
// is defined and JSON numbers are accepted and stored as text
// - by default any unexpected value for enumerations will 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 will 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, and
// j2oSetterNoCreate to avoid the published field instance creation
// - set j2oAllowInt64Hex to let Int64/QWord fields accept hexadecimal string
// (as generated e.g. via the woInt64AsHex option)
TJSONToObjectOption = (
j2oIgnoreUnknownProperty, j2oIgnoreStringType, j2oIgnoreUnknownEnum,
j2oHandleCustomVariants, j2oHandleCustomVariantsWithinString,
j2oSetterExpectsToFreeTempInstance, j2oSetterNoCreate, j2oAllowInt64Hex);
/// 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
// TInterfacedObjectFake.FakeCall/TServiceMethodExecute.ExecuteJson methods
JSONTOOBJECT_TOLERANTOPTIONS = [j2oHandleCustomVariants,j2oIgnoreUnknownEnum,
j2oIgnoreUnknownProperty,j2oIgnoreStringType,j2oAllowInt64Hex];
/// read an object properties, as saved by ObjectToJSON function
// - ObjectInstance must be an existing TObject instance
// - the data inside From^ is modified in-place (unescaped and transformed):
// calling JSONToObject(pointer(JSONRawUTF8)) will change the JSONRawUTF8
// variable content, which may not be what you expect - consider using the
// ObjectLoadJSON() function instead
// - handle Integer, Int64, enumerate (including boolean), set, floating point,
// TDateTime, TCollection, TStrings, TRawUTF8List, variant, and string properties
// (excluding ShortString, but including WideString and UnicodeString under
// Delphi 2009+)
// - TList won't be handled since it may leak memory when calling TList.Clear
// - won't handle TObjectList (even if ObjectToJSON is able to serialize
// them) since has no way of knowing the object type to add (TCollection.Add
// is missing), unless: 1. you set the TObjectListItemClass property as expected,
// and provide a TObjectList object, or 2. woStoreClassName option has been
// used at ObjectToJSON() call and the corresponding classes have been previously
// registered by 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; out Valid: boolean;
TObjectListItemClass: TClass=nil; Options: TJSONToObjectOptions=[]): PUTF8Char;
/// parse the supplied JSON with some tolerance about Settings format
// - will make a TSynTempBuffer copy for parsing, and un-comment it
// - returns true if the supplied JSON was successfully retrieved
// - returns false and set InitialJsonContent := '' on error
function JSONSettingsToObject(var InitialJsonContent: RawUTF8; Instance: TObject): boolean;
/// read an object properties, as saved by ObjectToJSON function
// - ObjectInstance must be an existing TObject instance
// - this overloaded version will make a private copy of the supplied JSON
// content (via TSynTempBuffer), to ensure the original buffer won't be modified
// during process, before calling safely JSONToObject()
// - will return TRUE on success, or FALSE if the supplied JSON was invalid
function ObjectLoadJSON(var ObjectInstance; const JSON: RawUTF8;
TObjectListItemClass: TClass=nil; Options: 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 will speed up the creation process
// - any virtual constructor will be used, including for TCollection types
{$ifdef USERECORDWITHMETHODS}TClassInstance = record
{$else}TClassInstance = object{$endif}
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;
/// compute the custom JSON commentary corresponding to this class
procedure SetCustomComment(var CustomComment: RawUTF8);
end;
/// points to information about a class, able to create new instances
PClassInstance = ^TClassInstance;
{$ifdef FPC}
{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} // e.g. for ARM
{$PACKRECORDS C}
{$else}
{$A-}
{$endif}
{$else}
{$A-} // Delphi compiler use packed/unaligned structs for most internal types
{$endif FPC}
type
{$ifndef FPC}
PMethod = ^TMethod; // not defined on older Delphi revisions
{$endif FPC}
PTypeInfo = ^TTypeInfo;
{$ifdef HASDIRECTTYPEINFO} // you should use inlined Deref() function below
PPTypeInfo = PTypeInfo;
{$else}
PPTypeInfo = ^PTypeInfo;
{$endif HASDIRECTTYPEINFO}
PTypeInfoDynArray = array of PTypeInfo;
PPropInfo = ^TPropInfo;
PMethodInfo = ^TMethodInfo;
TClassArray = array[0..MaxInt div SizeOf(TClass)-1] of TClass;
PClassArray = ^TClassArray;
/// 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
{$ifdef USERECORDWITHMETHODS}TClassProp = record
{$else}TClassProp = object{$endif}
public
/// 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
{$ifdef USERECORDWITHMETHODS}TClassType = record
{$else}TClassType = object{$endif}
public
/// 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
{$ifdef USERECORDWITHMETHODS}TEnumType = record
{$else}TEnumType = object{$endif}
public
/// specify ordinal storage size and sign
// - is prefered to MaxValue to identify the number of stored bytes
OrdType: TOrdType;
{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
EnumDummy: DWORD; // needed on ARM for correct alignment !!??
{$endif}
{ 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_REQUIRES_PROPER_ALIGNMENT}
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
// - those shortstrings are not aligned whatsoever (even if
// FPC_REQUIRES_PROPER_ALIGNMENT is set)
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; const Suffix: RawUTF8='';
trimedValues: boolean=false; unCamelCased: boolean=false); overload;
/// retrieve all trimed element names as CSV
procedure GetEnumNameTrimedAll(var result: RawUTF8; const Prefix: RawUTF8='';
quotedValues: boolean=false; const Suffix: RawUTF8='');
/// get all enumeration names as a JSON array of strings
function GetEnumNameAllAsJSONArray(TrimLeftLowerCase: boolean;
UnCamelCased: boolean=false): RawUTF8;
/// get the corresponding enumeration ordinal value, from its name
// - if EnumName does start with lowercases 'a'..'z', they will be searched:
// e.g. GetEnumNameValue('sllWarning') will find sllWarning item
// - if Value does not start with lowercases 'a'..'z', they will be ignored:
// e.g. GetEnumNameValue('Warning') will find sllWarning item
// - return -1 if not found (don't use directly this value to avoid any GPF)
function GetEnumNameValue(const EnumName: ShortString): Integer; overload;
{$ifdef 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);
/// 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; ValueLen: integer=0): Integer; overload;
/// compute how many bytes this type will use to be stored as a enumerate
function SizeInStorageAsEnum: Integer;
/// compute how many bytes this type will use to be stored as a set
function SizeInStorageAsSet: Integer;
/// store an enumeration value from its ordinal representation
procedure SetEnumFromOrdinal(out Value; Ordinal: Integer);
end;
TRecordField = record
TypeInfo: PPTypeInfo;
{$ifdef FPC}
Offset: SizeInt;
{$else}
Offset: Cardinal;
{$endif FPC}
end;
TRecordType = record
{$ifdef FPC_NEWRTTI}
RecInitInfo: Pointer;
{$endif FPC_NEWRTTI}
Size: cardinal;
Count: integer;
Fields: array[word] of TRecordField;
end;
PRecordField = ^TRecordField;
PRecordType = ^TRecordType;
TIntfFlag = (ifHasGuid,ifDispInterface,ifDispatch{$ifdef FPC},ifHasStrGUID{$endif});
TIntfFlags = set of TIntfFlag;
/// a wrapper to interface type information, as defined by the Delphi RTTI
TInterfaceTypeData = record
IntfParent: PPTypeInfo; // ancestor
IntfFlags: TIntfFlags;
IntfGuid: TGUID;
IntfUnit: ShortString;
end;
PInterfaceTypeData = ^TInterfaceTypeData;
/// 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;
{$ifdef FPC}
{$push}
{$PACKRECORDS 1}
{$endif}
{$ifdef USERECORDWITHMETHODS}TTypeInfo = record
{$else}TTypeInfo = object{$endif}
public
/// 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 HASINLINENOTX86}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;
/// 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}
/// return TRUE if the property is an unsigned 64-bit field
function IsQWord: boolean; {$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 HASINLINENOTX86}inline;{$endif}
/// get the record type information
function RecordType: PRecordType; {$ifdef HASINLINENOTX86}inline;{$endif}
/// get the interface type information
function InterfaceType: PInterfaceTypeData; {$ifdef HASINLINENOTX86}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 HASINLINENOTX86}inline;{$endif}
/// get the SQL type of the items of a dynamic array
function DynArraySQLFieldType: TSQLFieldType;
/// 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 will be added
// - if OnlyImplementedBy is not nil, only the interface explicitly
// implemented by this class will be added, and AncestorsImplementedEntry[]
// will contain the corresponding PInterfaceEntry values
procedure InterfaceAncestors(out Ancestors: PTypeInfoDynArray;
OnlyImplementedBy: TInterfacedObjectClass;
out AncestorsImplementedEntry: TPointerDynArray);
{$ifdef FPC_PROVIDE_ATTR_TABLE}
/// type attributes, introduced since SVN 42356-42411 (2019/07)
function AttributeTable: PFPCAttributeTable; inline;
{$endif FPC_PROVIDE_ATTR_TABLE}
end;
/// how a RTTI property definition access its value
// - as returned by TPropInfo.Getter/Setter methods
TPropInfoCall = (
picNone, picField, picMethod, picIndexed);
/// a wrapper containing a RTTI property definition
// - used for direct Delphi / UTF-8 SQL type mapping/conversion
// - doesn't depend on RTL's TypInfo unit, to enhance cross-compiler support
{$ifdef USERECORDWITHMETHODS}TPropInfo = packed record
{$else}TPropInfo = object{$endif} { "packed" above is needed on ARM (alf) }
public
/// raw retrieval of the property read access definition
// - note: 'var Call' generated incorrect code on Delphi XE4 -> use PMethod
function Getter(Instance: TObject; Call: PMethod): TPropInfoCall; {$ifdef HASINLINE}inline;{$endif}
/// raw retrieval of the property access definition
function Setter(Instance: TObject; Call: PMethod): TPropInfoCall; {$ifdef HASINLINE}inline;{$endif}
/// raw retrieval of tkInteger,tkEnumeration,tkSet,tkChar,tkWChar,tkBool
// - rather call GetOrdValue/GetInt64Value
function GetOrdProp(Instance: TObject): PtrInt;
/// raw assignment of tkInteger,tkEnumeration,tkSet,tkChar,tkWChar,tkBool
// - rather call SetOrdValue/SetInt64Value
procedure SetOrdProp(Instance: TObject; Value: PtrInt);
/// raw retrieval of tkClass
function GetObjProp(Instance: TObject): TObject;
/// raw retrieval of tkInt64,tkQWord
// - rather call GetInt64Value
function GetInt64Prop(Instance: TObject): Int64;
/// raw assignment of tkInt64,tkQWord
// - rather call SetInt64Value
procedure SetInt64Prop(Instance: TObject; const Value: Int64);
/// raw retrieval of tkLString
procedure GetLongStrProp(Instance: TObject; var Value: RawByteString);
/// raw assignment of tkLString
procedure SetLongStrProp(Instance: TObject; const Value: RawByteString);
/// raw copy of tkLString
procedure CopyLongStrProp(Source,Dest: TObject);
/// raw retrieval of tkString into an Ansi7String
procedure GetShortStrProp(Instance: TObject; var Value: RawByteString);
/// raw retrieval of tkWString
procedure GetWideStrProp(Instance: TObject; var Value: WideString);
/// raw assignment of tkWString
procedure SetWideStrProp(Instance: TObject; const Value: WideString);
{$ifdef HASVARUSTRING}
/// raw retrieval of tkUString
procedure GetUnicodeStrProp(Instance: TObject; var Value: UnicodeString);
/// raw assignment of tkUString
procedure SetUnicodeStrProp(Instance: TObject; const Value: UnicodeString);
{$endif HASVARUSTRING}
/// raw retrieval of tkFloat/currency
// - use instead GetCurrencyValue
function GetCurrencyProp(Instance: TObject): currency;
/// raw assignment of tkFloat/currency
procedure SetCurrencyProp(Instance: TObject; const Value: Currency);
/// raw retrieval of tkFloat/double
function GetDoubleProp(Instance: TObject): double;
/// raw assignment of tkFloat/double
procedure SetDoubleProp(Instance: TObject; Value: Double);
/// raw retrieval of tkFloat - with conversion to 64-bit double
// - use instead GetDoubleValue
function GetFloatProp(Instance: TObject): double;
/// raw assignment of tkFloat
// - use instead SetDoubleValue
procedure SetFloatProp(Instance: TObject; Value: TSynExtended);
{$ifndef NOVARIANTS}
/// raw retrieval of tkVariant
procedure GetVariantProp(Instance: TObject; var result: Variant);
/// raw assignment of tkVariant
procedure SetVariantProp(Instance: TObject; const Value: Variant);
{$endif NOVARIANTS}
public
/// the type definition of this property
// - call TPropInfo.TypeInfo for cross-compiler access to this information
PropType: PPTypeInfo;
/// contains the offset of a field, or the getter method set by 'read' declaration
// - if this field is 0 (no 'read' was specified), raw access methods will
// use SetProc to get the field memory address to read from
// - call TPropInfo.Getter for cross-compiler access to this information
GetProc: PtrUInt;
/// contains the offset of a field, or the setter method set by 'write' declaration
// - if this field is 0 (no 'write' was specified), raw access methods will
// use GetProc to get the field memory address to save into
// - call TPropInfo.Setter for cross-compiler access to this information
SetProc: PtrUInt;
/// 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[]
// - call TPropInfo.IsStored for cross-compiler access to this information
StoredProc: PtrUInt;
/// 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 (NO_DEFAULT=$80000000 indicates none set)
// when an ordinal or set property is saved as TPersistent
// - see TPropInfo.DefaultOr0/DefaultOrVoid for easy use
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
// - rather call TPropInfo.Getter/Setter for cross-compiler access
PropProcs: Byte;
{$ifdef FPC_PROVIDE_ATTR_TABLE}
/// property attributes, introduced since FPC SVN 42356-42411 (2019/07)
AttributeTable: PFPCAttributeTable;
{$endif FPC_PROVIDE_ATTR_TABLE}
{$endif FPC}
/// the property definition Name
Name: ShortString;
/// the type information of this property
// - will de-reference the PropType pointer on Delphi and newer FPC compilers
function TypeInfo: PTypeInfo; {$ifdef HASINLINENOTX86}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 HASINLINENOTX86}inline;{$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}
/// return the Default RTTI value defined for this property, or 0 if not set
function DefaultOr0: integer; {$ifdef HASINLINE}inline;{$endif}
/// return TRUE if the property has its Default RTTI value, or is 0/""/nil
// - will call function IsObjectDefaultOrVoid() for class properties
function IsDefaultOrVoid(Instance: TObject): boolean;
/// compute in how many bytes this property is stored
function RetrieveFieldSize: integer;
/// 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 GetDoubleValue(Instance: TObject): double;
/// low-level setter of the floating-point property value of a given instance
// - this method will check if the corresponding property is floating-point
procedure SetDoubleValue(Instance: TObject; const Value: double);
/// low-level getter of the long string property 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 HASVARUSTRING}
/// 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 property has no getter but direct field read
function GetterIsField: boolean;
{$ifdef HASINLINE}inline;{$endif}
/// return TRUE if the property has no setter but direct field write
function SetterIsField: boolean;
{$ifdef HASINLINE}inline;{$endif}
/// return TRUE if the property has a write setter or direct field
function WriteIsDefined: boolean;
{$ifdef HASINLINE}inline;{$endif}
/// returns the low-level field read address, if GetterIsField is TRUE
function GetterAddr(Instance: pointer): pointer; {$ifdef HASINLINENOTX86}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
// - will optionally make some conversion if the property type doesn't
// match the variant type, e.g. a text variant could be converted to integer
// when setting a tkInteger kind of property
// - a tkDynArray property is expected to be a T*ObjArray and will be
// converted from a TDocVariant using a newly allocated T*ObjArray
procedure SetFromVariant(Instance: TObject; const Value: variant);
/// low-level getter of the property value into a variant value
// - a tkDynArray property is expected to be a T*ObjArray and will be
// converted into a TDocVariant using a temporary JSON serialization
procedure GetVariant(Instance: TObject; var Dest: variant);
{$endif NOVARIANTS}
/// low-level setter of the property value from its text representation
/// - handle published integer, Int64, floating point values, (wide)string,
// enumerates (e.g. boolean), variant properties of the object
// - for variant properties, could unserialize the Text as JSON into a
// TDocVariantData if TryCustomVariants (and AllowDouble) are set
// - dynamic arrays are unserialized from JSON [...], unless a
// TRawUTF8DynArray property has been stored as CSV
procedure SetFromText(Instance: TObject; const Text: RawUTF8;
TryCustomVariants: PDocVariantOptions=nil; AllowDouble: boolean=false);
/// low-level appender of the property value to a text buffer
// - write the published integer, Int64, floating point values, (wide)string,
// enumerates (e.g. boolean), variant properties of the object
// - dynamic arrays will be serialized as JSON, unless RawUTF8DynArrayAsCSV
// is set, and a TRawUTF8DynArray property will be stored as CSV
procedure GetToText(Instance: TObject; WR: TTextWriter; RawUTF8DynArrayAsCSV: boolean=false;
Escape: TTextWriterKind=twNone);
/// 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 will be created if a published field
// has a setter, and the instance is expected to be released later by the
// owner class: you can set the j2oSetterExpectsToFreeTempInstance option
// to let this method release it when the setter returns
function ClassFromJSON(Instance: TObject; From: PUTF8Char; var Valid: boolean;
Options: TJSONToObjectOptions=[]): PUTF8Char;
end;
{$ifdef FPC}
{$pop}
{$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
{$ifdef FPC}, ccCppdecl, ccFar16, ccOldFPCCall, ccInternProc,
ccSysCall, ccSoftFloat, ccMWPascal{$endif FPC});
/// the available kind of method parameters
TParamFlag = (pfVar, pfConst, pfArray, pfAddress, pfReference, pfOut
{$ifdef FPC}
,pfConstRef
{$ifdef FPC_NEWRTTI}
,pfHidden,pfHigh,pfSelf,pfVmt,pfResult
{$endif FPC_NEWRTTI}
{$else}
,pfResult
{$endif});
/// a set of kind of method parameters
TParamFlags = set of TParamFlag;
PReturnInfo = ^TReturnInfo;
PCallingConvention = ^TCallingConvention;
PParamInfo = ^TParamInfo;
/// a wrapper around method returned result definition
{$ifdef USERECORDWITHMETHODS}TReturnInfo = record
{$else}TReturnInfo = object{$endif}
public
/// 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 wrapper around an individual method parameter definition
{$ifdef USERECORDWITHMETHODS}TParamInfo = record
{$else}TParamInfo = object{$endif}
public
/// 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 wrapper around a method definition
{$ifdef USERECORDWITHMETHODS}TMethodInfo = packed record
{$else}TMethodInfo = object{$endif}
public
{$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}
const
ptField = 0;
ptStatic = 1;
ptVirtual = 2;
ptConst = 3;
NO_INDEX = 0;
{$PACKRECORDS DEFAULT} // back to normal alignment
{$else}
const
NO_INDEX = longint($80000000);
ptField = $ff;
ptVirtual = $fe;
type
/// used to map a TPropInfo.GetProc/SetProc and retrieve its kind
// - defined here for proper Delphi inlining
PropWrap = packed record
FillBytes: array [0..SizeOf(Pointer)-2] of byte;
/// =$ff for a ptField address, or =$fe for a ptVirtual method
Kind: byte;
end;
{$A+} // back to normal alignment
{$endif FPC}
const
NO_DEFAULT = longint($80000000);
type
TJSONSerializer = class;
/// ORM attributes for a TSQLPropInfo definition
TSQLPropInfoAttribute = (
aIsUnique, aAuxiliaryRTreeField, aBinaryCollation);
/// 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 will 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 will 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 write 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;
/// returns TRUE if value is 0 or ''
function IsValueVoid(Instance: TObject): boolean;
/// append the property value into a binary buffer
procedure GetBinary(Instance: TObject; W: TFileBufferWriter); virtual; abstract;
/// read the property value from a binary buffer
// - PEnd should point to the end of the P input buffer, to avoid any overflow
// - returns next char in input buffer on success, or nil in case of invalid
// content supplied e.g.
function SetBinary(Instance: TObject; P,PEnd: 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()
// will handle the incoming RTTI
TSQLPropInfoListOptions = set of (
pilRaiseEORMExceptionIfNotHandled, pilAllowIDFields,
pilSubClassesFlattening, pilIgnoreIfGetter,
pilSingleHierarchyLevel, pilAuxiliaryFields);
/// parent information about a published property retrieved from RTTI
TSQLPropInfoRTTI = class(TSQLPropInfo)
protected
fPropInfo: PPropInfo;
fPropType: PTypeInfo;
fFlattenedProps: PPropInfoDynArray;
fGetterIsFieldPropOffset: PtrUInt;
fInPlaceCopySameClassPropOffset: PtrUInt;
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;
/// register this class corresponding to the RTTI TypeInfo() pointer
// - could be used e.g. to define custom serialization and process of
// any custom type
class procedure RegisterTypeInfo(aTypeInfo: Pointer);
/// 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; aOptions: TSQLPropInfoListOptions); 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
fUnsigned: boolean;
procedure CopySameClassProp(Source: TObject; DestInfo: TSQLPropInfo; Dest: TObject); override;
public
constructor Create(aPropInfo: PPropInfo; aPropIndex: integer;
aSQLFieldType: TSQLFieldType; aOptions: TSQLPropInfoListOptions); 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,PEnd: 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; aOptions: TSQLPropInfoListOptions); 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; aOptions: TSQLPropInfoListOptions); 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
fIsQWord: boolean;
procedure CopySameClassProp(Source: TObject; DestInfo: TSQLPropInfo; Dest: TObject); override;
public
constructor Create(aPropInfo: PPropInfo; aPropIndex: integer;
aSQLFieldType: TSQLFieldType; aOptions: TSQLPropInfoListOptions); 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,PEnd: 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 PtrInt published property, according to the native CPU
// - not a real stand-alone class, but a convenient wrapper type
TSQLPropInfoRTTIPtrInt = {$ifdef CPU64}TSQLPropInfoRTTIInt64{$else}TSQLPropInfoRTTIInt32{$endif};
/// information about a TTimeLog published property
// - stored as an Int64, but with a specific class
TSQLPropInfoRTTITimeLog = class(TSQLPropInfoRTTIInt64);
/// information about a TUnixTime published property
// - stored as an Int64, but with a specific class
TSQLPropInfoRTTIUnixTime = class(TSQLPropInfoRTTIInt64);
/// information about a TUnixMSTime published property
// - stored as an Int64, but with a specific class
TSQLPropInfoRTTIUnixMSTime = 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,PEnd: 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;
function GetHash(Instance: TObject; CaseInsensitive: boolean): cardinal; 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,PEnd: 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;
function GetHash(Instance: TObject; CaseInsensitive: boolean): cardinal; 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; aOptions: TSQLPropInfoListOptions); 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,PEnd: 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
// - will also serialize a RawJSON property without JSON escape
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 SetBinary(Instance: TObject; P,PEnd: PAnsiChar): PAnsiChar; 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,PEnd: 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,PEnd: 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;
fWrapper: TDynArray;
procedure GetDynArray(Instance: TObject; var result: TDynArray);
{$ifdef HASINLINE}inline;{$endif}
function GetDynArrayElemType: PTypeInfo;
{$ifdef HASINLINE}inline;{$endif}
/// 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; aOptions: TSQLPropInfoListOptions); 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,PEnd: 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; aOptions: TSQLPropInfoListOptions); 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,PEnd: 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 will 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,PEnd: 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,PEnd: 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,PEnd: 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;
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 properties of the object in INI text format
// - i.e. append PropertyName=PropertyValue lines
// - add a new INI-like section with [Value.ClassName] if WithSection is true
// - use internally TPropInfo.GetToText for the conversion to text
// - Value object must have been compiled with the $M+ define, i.e. must
// inherit from TPersistent, TSynPersistent or TSQLRecord
// - the enumerates properties are stored with their integer index value
// - dynamic arrays will be serialized as JSON, unless RawUTF8DynArrayAsCSV
// is set, and a TRawUTF8DynArray property will be stored as CSV
// - content can be read back using overloaded procedures ReadObject()
procedure WriteObject(Value: TObject; const SubCompName: RawUTF8='';
WithSection: boolean=true; RawUTF8DynArrayAsCSV: boolean=false); 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 will 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 will be written by TJSONSerializer
TJSONSerializerSQLRecordOptions = set of TJSONSerializerSQLRecordOption;
/// simple writer to a Stream, specialized for writing an object as JSON
// - override WriteObject() to use class RTTI process of this unit, and
// allow custom JSON serialization
// - this is the full-feature JSON serialization class
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;
/// customize TSQLRecord.GetJSONValues serialization process
// - jwoAsJsonNotAsString will force TSQLRecord.GetJSONValues to serialize
// nested property instances as a JSON object/array, not a JSON string:
// i.e. root/table/id REST will be ready-to-be-consumed from AJAX clients
// (e.g. TSQLPropInfoRTTIObject.GetJSONValues as a JSON object, and
// TSQLPropInfoRTTIDynArray.GetJSONValues as a JSON array)
// - jwoID_str will 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
// - this method is thread-safe, but should be called before any serialization
class procedure RegisterCustomSerializer(aClass: TClass;
aReader: TJSONSerializerCustomReader; aWriter: TJSONSerializerCustomWriter);
/// define custom serialization of field names for a given class
// - any aClassField[] property name will be serialized using aJsonFields[]
// - if any aJsonFields[] equals '', this published property will be
// excluded from the serialization object
// - aJsonFields[] is expected to be only plain pascal identifier, i.e.
// A-Z a-z 0-9 and _ characters, up to 63 in length
// - setting both aClassField=aJsonFields=[] will return back to the default
// class serialization (i.e. serialization with published properties names)
// - by design, this customization excludes RegisterCustomSerializer() with
// custom reader/writer callbacks
// - note that any inherited classes will be serialized as the parent class
// - this method is thread-safe, but should be called before any serialization
class procedure RegisterCustomSerializerFieldNames(aClass: TClass;
const aClassFields, aJsonFields: array of ShortString);
/// 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
// - this method is thread-safe, but should be called before any serialization
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
// - this method is thread-safe, but should be called before any serialization
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
// - this method is thread-safe, but should be called before any serialization
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
// - will use the default published properties serializer, unless you specify
// your custom Reader/Write callbacks
class procedure RegisterObjArrayForJSON(aDynArray: PTypeInfo;
aItem: TClass; aReader: TDynArrayJSONCustomReader=nil; aWriter: TDynArrayJSONCustomWriter=nil);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;
/// retrieve the T*ObjArray dynamic array type RTTI for a given item class
// - 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 RegisterObjArrayFindTypeInfo(aClass: TClass): PTypeInfo;
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);
/// returns the interface name of a registered GUID, or its hexadecimal value
function ToText({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF}
aGUID: TGUID): TGUIDShortString; overload;
/// 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 aPropName: shortstring;
aCaseSensitive: boolean=false): PPropInfo;
/// retrieve an integer/Int64 Field propery value from a Property Name
// - this version also search into parent properties
// - returns TRUE and set PropValue if a matching property was found
function ClassFieldInt64(Instance: TObject; const PropName: ShortString;
out PropValue: Int64): boolean;
/// retrieve a class Field property instance from a Property Name
// - this 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; aCaseSensitive: boolean=false): PPropInfo;
/// retrieve a Field property RTTI information searching for an exact Property class type
// - this special version also search into parent properties
function ClassFieldPropWithParentsFromClassType(aClassType,aSearchedClassType: TClass): PPropInfo;
/// retrieve a Field property RTTI information searching for an inherited Property class type
// - this special version also search into parent properties
function ClassFieldPropWithParentsInheritsFromClassType(aClassType,aSearchedClassType: TClass): PPropInfo;
/// retrieve a Field property RTTI information searching for an exact Property offset address
// - this special version also search into parent properties
function ClassFieldPropWithParentsFromClassOffset(aClassType: TClass;
aSearchedOffset: pointer): 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 all class Field property instances from a Property class type
// - this version also search into parent properties
// - returns all matching property instances found
function ClassFieldInstances(Instance: TObject; PropClassType: TClass): TObjectDynArray;
/// retrieve a class instance property value matching a class type
// - if aSearchedInstance is aSearchedClassType, will return aSearchedInstance
// - if aSearchedInstance is not aSearchedClassType, it will try all nested
// properties of aSearchedInstance for a matching aSearchedClassType: if no
// exact match is found, will return aSearchedInstance
function ClassFieldPropInstanceMatchingClass(aSearchedInstance: TObject;
aSearchedClassType: TClass): TObject;
/// retrieve the total number of properties for a class, including its parents
function ClassFieldCountWithParents(ClassType: TClass;
onlyWithoutGetter: boolean=false): integer;
/// returns TRUE if the class has some published fields, including its parents
function ClassHasPublishedFields(ClassType: TClass): boolean;
/// retrieve all class hierachy types which have some published properties
function ClassHierarchyWithField(ClassType: TClass): TClassDynArray;
/// retrieve the 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;{$else}{$ifdef HASINLINENOTX86}inline;{$endif}{$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 := GetClassParent(CT);
// ! 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;
{$ifndef NOVARIANTS}
/// 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;
/// will convert a blank TObject into a TDocVariant document instance
function ObjectDefaultToVariant(aClass: TClass; aOptions: TDocVariantOptions): variant; overload;
{$endif}
{ ************ 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 class
// published properties, then release them (and any T*ObjArray) when freed
// - could be used for gathering of TCollectionItem properties, e.g. for
// Domain objects in DDD, especially for list of value objects
// - consider using T*ObjArray dynamic array published properties in your
// value types instead of TCollection storage: T*ObjArray have a lower overhead
// and are easier to work with, once TJSONSerializer.RegisterObjArrayForJSON
// is called to register the T*ObjArray type
// - note that non published (e.g. public) properties won't be instantiated,
// serialized, nor released - but may contain weak references to other classes
// - please take care that you will not create any endless recursion: you should
// ensure that at one level, nested published properties won't have any class
// instance refering to its owner (there is no weak reference - remember!)
// - since the destructor will release all nested properties, you should
// never store a reference to any of those nested instances if this owner
// may be freed before
TCollectionItemAutoCreateFields = class(TCollectionItem)
public
/// this overriden constructor will instantiate all its nested
// TPersistent/TSynPersistent/TSynAutoCreateFields 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, thanks to its
// lower overhead
// - note that non published (e.g. public) properties won't be instantiated,
// serialized, nor released - but may contain weak references to other classes
// - please take care that you will not create any endless recursion: you should
// ensure that at one level, nested published properties won't have any class
// instance refering to its owner (there is no weak reference - remember!)
// - since the destructor will release all nested properties, you should
// never store a reference to any of those nested instances if this owner
// may be freed before
TPersistentAutoCreateFields = class(TPersistentWithCustomCreate)
public
/// this overriden constructor will instantiate all its nested
// TPersistent/TSynPersistent/TSynAutoCreateFields published properties
constructor Create; override;
/// finalize the instance, and release its published properties
destructor Destroy; override;
end;
/// our own empowered TPersistentAutoCreateFields-like parent class
// - this class is a perfect parent to store any data by value, e.g. DDD Value
// Objects, Entities or Aggregates
// - is defined as an abstract class able with a virtual constructor, RTTI
// for published properties, and automatic memory management of all nested
// class published properties: any class defined as a published property will
// be owned by this instance - i.e. with strong reference
// - will also release any T*ObjArray dynamic array storage of persistents,
// previously registered via TJSONSerializer.RegisterObjArrayForJSON()
// - nested published classes (or T*ObjArray) don't need to inherit from
// TSynAutoCreateFields: they may be from any TPersistent/TSynPersistent type
// - note that non published (e.g. public) properties won't be instantiated,
// serialized, nor released - but may contain weak references to other classes
// - please take care that you will not create any endless recursion: you should
// ensure that at one level, nested published properties won't have any class
// instance refering to its owner (there is no weak reference - remember!)
// - since the destructor will release all nested properties, you should
// never store a reference to any of those nested instances if this owner
// may be freed before
// - TPersistent/TPersistentAutoCreateFields have an unexpected speed overhead
// due a giant lock introduced to manage property name fixup resolution
// (which we won't use outside the VCL) - this class is definitively faster
TSynAutoCreateFields = class(TSynPersistent)
public
/// this overriden constructor will instantiate all its nested
// TPersistent/TSynPersistent/TSynAutoCreateFields 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;
/// virtual method allowing instance customization after initialization
// - called e.g. by JsonToObject, but may be executed after manual fields
// assignment
// - do nothing by default
// - may be overriden for string interning or content customization
procedure AfterLoad; virtual;
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
// - will handle automatic memory management of all nested class and T*ObjArray
// published properties: any class or T*ObjArray defined as a published
// property will be owned by this instance - i.e. with strong reference
// - non published properties (e.g. public) won't be instantiated, so may
// store weak class references
// - could be used for gathering of TCollectionItem properties, e.g. for
// Domain objects in DDD, especially for list of value objects, with some
// additional methods defined by an Interface
// - since the destructor will release all nested properties, you should
// never store a reference to any of those nested instances if this owner
// may be freed before
TInterfacedObjectAutoCreateFields = class(TInterfacedObjectWithCustomCreate)
public
/// this overriden constructor will instantiate all its nested
// TPersistent/TSynPersistent/TSynAutoCreateFields class and T*ObjArray
// published properties
constructor Create; override;
/// finalize the instance, and release its published properties
destructor Destroy; override;
end;
/// abstract parent class able to store settings as JSON file
TSynJsonFileSettings = class(TSynAutoCreateFields)
protected
fInitialJsonContent: RawUTF8;
fFileName: TFileName;
public
/// read existing settings from a JSON content
function LoadFromJson(var aJson: RawUTF8): boolean;
/// read existing settings from a JSON file
function LoadFromFile(const aFileName: TFileName): boolean; virtual;
/// persist the settings as a JSON file, named from LoadFromFile() parameter
procedure SaveIfNeeded; virtual;
/// optional persistence file name, as set by LoadFromFile()
property FileName: TFileName read fFileName;
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 will be limited to 10 minutes
// - default is 120000, i.e. 2 minutes
property TimeOutMS: integer read fTimeOutMS write fTimeOutMS;
// period after which TRawUTF8ObjectCacheList will 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
// - will 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
// - will maintain a list of TRawUTF8ObjectCache instances
TRawUTF8ObjectCacheList = class(TRawUTF8List)
protected
fSettings: TRawUTF8ObjectCacheSettings;
fLog: TSynLogFamily;
fLogEvent: TSynLogInfo;
fClass: TRawUTF8ObjectCacheClass;
fNextPurgeTix: Int64;
fPurgeForceList: TRawUTF8List;
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;
/// finalize the cache information
destructor Destroy; override;
/// 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 will be performed, if needed
// - on success (true), output cache instance will 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
// will check for its TimeOutMS and call CacheClear if information is outdated
procedure TryPurge;
/// register a key identifier so that next TryPurge will flush the entry
// - a direct CacheClear may trigger a race condition in NewObjectCache:
// so you may use this function e.g. from a SOA callback
procedure AddToPurge(const Key: RawUTF8); virtual;
/// this method will clear all associated information
// - a regular Clear will destroy all TRawUTF8ObjectCache instances,
// whereas this method will call CacheClear on each entry, so will
// 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;
var
/// acccess to Zip Deflate compression in level 6 as a TAlgoCompress class
AlgoDeflate: TAlgoCompress;
/// acccess to Zip Deflate compression in level 1 as a TAlgoCompress class
AlgoDeflateFast: TAlgoCompress;
const
/// void HTTP Status Code (not a standard value, for internal use only)
HTTP_NONE = 0;
/// HTTP Status Code for "Continue"
HTTP_CONTINUE = 100;
/// HTTP Status Code for "Switching Protocols"
HTTP_SWITCHINGPROTOCOLS = 101;
/// HTTP Status Code for "Success"
HTTP_SUCCESS = 200;
/// HTTP Status Code for "Created"
HTTP_CREATED = 201;
/// HTTP Status Code for "Accepted"
HTTP_ACCEPTED = 202;
/// HTTP Status Code for "Non-Authoritative Information"
HTTP_NONAUTHORIZEDINFO = 203;
/// HTTP Status Code for "No Content"
HTTP_NOCONTENT = 204;
/// HTTP Status Code for "Reset Content"
HTTP_RESETCONTENT = 205;
/// HTTP Status Code for "Partial Content"
HTTP_PARTIALCONTENT = 206;
/// HTTP Status Code for "Multiple Choices"
HTTP_MULTIPLECHOICES = 300;
/// HTTP Status Code for "Moved Permanently"
HTTP_MOVEDPERMANENTLY = 301;
/// HTTP Status Code for "Found"
HTTP_FOUND = 302;
/// HTTP Status Code for "See Other"
HTTP_SEEOTHER = 303;
/// HTTP Status Code for "Not Modified"
HTTP_NOTMODIFIED = 304;
/// HTTP Status Code for "Use Proxy"
HTTP_USEPROXY = 305;
/// HTTP Status Code for "Temporary Redirect"
HTTP_TEMPORARYREDIRECT = 307;
/// HTTP Status Code for "Bad Request"
HTTP_BADREQUEST = 400;
/// HTTP Status Code for "Unauthorized"
HTTP_UNAUTHORIZED = 401;
/// HTTP Status Code for "Forbidden"
HTTP_FORBIDDEN = 403;
/// HTTP Status Code for "Not Found"
HTTP_NOTFOUND = 404;
// HTTP Status Code for "Method Not Allowed"
HTTP_NOTALLOWED = 405;
// HTTP Status Code for "Not Acceptable"
HTTP_NOTACCEPTABLE = 406;
// HTTP Status Code for "Proxy Authentication Required"
HTTP_PROXYAUTHREQUIRED = 407;
/// HTTP Status Code for "Request Time-out"
HTTP_TIMEOUT = 408;
/// HTTP Status Code for "Conflict"
HTTP_CONFLICT = 409;
/// HTTP Status Code for "Payload Too Large"
HTTP_PAYLOADTOOLARGE = 413;
/// HTTP Status Code for "Internal Server Error"
HTTP_SERVERERROR = 500;
/// HTTP Status Code for "Not Implemented"
HTTP_NOTIMPLEMENTED = 501;
/// HTTP Status Code for "Bad Gateway"
HTTP_BADGATEWAY = 502;
/// HTTP Status Code for "Service Unavailable"
HTTP_UNAVAILABLE = 503;
/// HTTP Status Code for "Gateway Timeout"
HTTP_GATEWAYTIMEOUT = 504;
/// HTTP Status Code for "HTTP Version Not Supported"
HTTP_HTTPVERSIONNONSUPPORTED = 505;
/// 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';
/// internal HTTP content-type for efficient static file sending
// - detected e.g. by http.sys' THttpApiServer.Request or via the NGINX
// X-Accel-Redirect header's THttpServer.Process for direct sending
// - 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';
/// internal HTTP content-type Header for efficient static file sending
STATICFILE_CONTENT_TYPE_HEADER = HEADER_CONTENT_TYPE+STATICFILE_CONTENT_TYPE;
/// uppercase version of HTTP header for static file content serving
STATICFILE_CONTENT_TYPE_HEADER_UPPPER = HEADER_CONTENT_TYPE_UPPER+STATICFILE_CONTENT_TYPE;
var
/// convert any HTTP_* constant to a short English text
// - see @http://www.w3.org/Protocols/rfc2616/rfc2616-sec10.html
// - if SynCrtSock is linked (i.e. set mORMotHttpClient or mORMotHttpServer),
// SynCrtSock StatusCodeToReason() function will be assigned, which is
// somewhat faster, and more complete
StatusCodeToErrorMessage: procedure(Code: integer; var result: RawUTF8);
/// convert any HTTP_* constant to an integer error code and its English text
// - see @http://www.w3.org/Protocols/rfc2616/rfc2616-sec10.html
// - will call StatusCodeToErrorMessage()
function StatusCodeToErrorMsg(Code: integer): shortstring;
/// returns true for successful HTTP status codes, i.e. in 200..399 range
// - will map mainly SUCCESS (200), CREATED (201), NOCONTENT (204),
// PARTIALCONTENT (206), NOTMODIFIED (304) or TEMPORARYREDIRECT (307) codes
// - any HTTP status not part of this range will be identified as erronous
// request in the internal server statistics
function StatusCodeIsSuccess(Code: integer): boolean;
{$ifdef HASINLINE}inline;{$endif}
/// check the supplied HTTP header to not contain more than one EOL
// - to avoid unexpected HTTP body injection, e.g. from unsafe business code
function IsInvalidHttpHeader(head: PUTF8Char; headlen: PtrInt): boolean;
/// computes an URI with optional jwt authentication parameter
// - if AuthenticationBearer is set, will add its values as additional parameter:
// $ URI?authenticationbearer=URIAuthenticationBearer
function AuthURI(const URI, URIAuthenticationBearer: RawUTF8): RawUTF8;
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 consider Create=mPOST, Read=mGET,
// Update=mPUT and Delete=mDELETE - even if it is not fully RESTful
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 ToMethod(const method: RawUTF8): TSQLURIMethod;
var
/// the options used by TSynJsonFileSettings.SaveIfNeeded
// - you can modify this global variable to customize the whole process
SETTINGS_WRITEOPTIONS: TTextWriterWriteObjectOptions =
[woHumanReadable, woStoreStoredFalse, woHumanReadableFullSetsAsStar,
woHumanReadableEnumSetAsComment, woInt64AsHex];
/// the options used by TServiceFactoryServer.OnLogRestExecuteMethod
// - you can modify this global variable to customize the whole process
SERVICELOG_WRITEOPTIONS: TTextWriterWriteObjectOptions =
[woDontStoreDefault, woDontStoreEmptyString, woDontStore0,
woHideSynPersistentPassword];
/// the options used by TObjArraySerializer, TInterfacedObjectFake and
// TServiceMethodExecute when serializing values as JSON
// - used as DEFAULT_WRITEOPTIONS[DontStoreVoidJSON]
// - you can modify this global variable to customize the whole process
DEFAULT_WRITEOPTIONS: array[boolean] of TTextWriterWriteObjectOptions = (
[woDontStoreDefault, woSQLRawBlobAsBase64],
[woDontStoreDefault, woDontStoreEmptyString, woDontStore0, woSQLRawBlobAsBase64]);
{$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[]) will identify mugDay, mugMonth and mugYear
// consolidated statistics
// - it will 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)
{$ifdef USERECORDWITHMETHODS}TSynMonitorUsageID = record
{$else}TSynMonitorUsageID = object{$endif}
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 will be ignored
// - mugHour granularity will 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 will be merged
// - mugDay granularity will 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 will be merged
// - mugMonth granularity will 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 will be merged
// - mugYear granularity will 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 will therefore be ignored
procedure FromTimeLog(const TimeLog: TTimeLog);
/// computes an ID corresponding to the current UTC date/time
// - minutes and seconds will be ignored
procedure FromNowUTC;
/// returns the date/time
// - minutes and seconds will 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 will 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; monthdaystartat0: boolean=false): 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;
ValueLast: 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(TSynPersistentLock)
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 will 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
// - will recognize the TSynMonitor* properties as TSynMonitorType from
// RTTI, using MonitorPropUsageValue(), within any (nested) object
// - the instance will be stored in fTracked[].Instance: ensure it will
// 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
// - will recognize the TSynMonitor* properties as TSynMonitorType from
// RTTI, using MonitorPropUsageValue(), within any (nested) object
// - instances will be stored in fTracked[].Instance: ensure they will
// 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
function Modified(Instance: TObject): integer; overload;
/// to be called when tracked properties changed on a tracked class instance
function Modified(Instance: TObject; const PropNames: array of RawUTF8;
ModificationTime: TTimeLog=0): integer; overload; virtual;
/// some custom text, associated with the current stored state
// - will 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 will have their values reset for each granularity level
// - will 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
// - will 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 will 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 = '*';
/// maximum number of methods handled by interfaces
// - if you think this constant is too low, you are about to break
// the "Interface Segregation" SOLID principle: so don't ask to increase
// this value, we won't allow to write un-SOLID code! :)
MAX_METHOD_COUNT = 128;
/// maximum number of method arguments handled by interfaces
// - if you consider this as a low value, you should better define some
// records/classes as DTOs instead of multiplicating parameters: so don't
// ask to increase this value, we rather encourage writing clean code
// - used e.g. to avoid creating dynamic arrays if not needed, and
// ease method calls
MAX_METHOD_ARGS = 32;
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 will 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 TSQLRestBatch problem
EORMBatchException = class(EORMException);
/// 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
TSQLPropInfoRTTIInstance = class(TSQLPropInfoRTTIPtrInt)
protected
fObjectClass: TClass;
public
/// will setup the corresponding ObjectClass property
constructor Create(aPropInfo: PPropInfo; aPropIndex: integer;
aSQLFieldType: TSQLFieldType; aOptions: TSQLPropInfoListOptions); 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; aOptions: TSQLPropInfoListOptions); 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 will match TSQLRecordClient
// - in addition, the '...ToBeDeletedID' name pattern will set CascadeDelete
constructor Create(aPropInfo: PPropInfo; aPropIndex: integer;
aSQLFieldType: TSQLFieldType; aOptions: TSQLPropInfoListOptions); 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 will 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)
// - equals TSQLRecord for plain TID field
// - equals nil if T*ID type name doesn't match any registered class
property RecordClass: TSQLRecordClass read fRecordClass;
/// TRUE if this sftTID type name follows the '...ToBeDeletedID' pattern
// - e.g. 'TSQLRecordClientToBeDeletedID' type name will 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 will 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,PEnd: 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,PEnd: PAnsiChar): PAnsiChar; override;
end;
TSQLPropInfoRTTIManyObjArray = array of TSQLPropInfoRTTIMany;
/// the kind of SQlite3 (virtual) table
// - TSQLRecordFTS3/4/5 will be associated with vFTS3/vFTS4/vFTS5 values,
// TSQLRecordRTree/TSQLRecordRTreeInteger with rRTree/rRTreeInteger, any native
// SQlite3 table as vSQLite3, and a TSQLRecordVirtualTable*ID as
// 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, rFTS5, rRTree, rRTreeInteger, 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: PtrInt;
/// 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 will 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
// - could be set in overridden class procedure TSQLRecord.InternalDefineModel
// 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
// - could be set in overridden class procedure TSQLRecord.InternalDefineModel
// so that it will be common to all database models, for both client and server
// - note that you may inherit from TSQLRecordNoCase to use the NOCASE
// standard SQLite3 collation for all descendant ORM objects
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)
// - see also TSQLRecordNoCaseExtended root class
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
// - you can use TSQLRecordProperties.FieldBitsFromCSV() or
// TSQLRecordProperties.FieldBitsFromRawUTF8() to compute aFields
function CreateJSONWriter(JSON: TStream; Expand, withID: boolean;
const aFields: TSQLFieldBits; KnownRowsCount: integer;
aBufSize: integer=8192): 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, withID: boolean;
const aFields: TSQLFieldIndexDynArray; KnownRowsCount: integer;
aBufSize: integer=8192): TJSONSerializer; overload;
/// create a TJSONWriter, ready to be filled with TSQLRecord.GetJSONValues(W)
// - this overloaded method will 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;
aBufSize: integer=8192): 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
// - used e.g. by TSQLRecord.Destroy to release all owned nested instances
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;
/// count of coordinate fields of a TSQLRecordRTree, before auxiliary columns
RTreeCoordBoundaryFields: 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
// - llfHttps will indicates that the communication was made over HTTPS
// - llfSecured is set if the transmission is encrypted or in-process,
// using e.g. HTTPS/SSL/TLS or our proprietary AES/ECDHE algorithms
// - llfWebsockets communication was made using WebSockets
TSQLRestURIParamsLowLevelFlag = (llfHttps, llfSecured, llfWebsockets);
/// some flags set by the caller to notify low-level context
TSQLRestURIParamsLowLevelFlags = set of TSQLRestURIParamsLowLevelFlag;
/// store all parameters for a Client or Server method call
// - as used by TSQLRestServer.URI or TSQLRestClientURI.InternalURI
{$ifdef USERECORDWITHMETHODS}TSQLRestURIParams = record
{$else}TSQLRestURIParams = object{$endif}
public
/// 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. to retrieve the remote IP:
// ! Call.Header(HEADER_REMOTEIP_UPPER)
// ! or FindNameValue(Call.InHead,HEADER_REMOTEIP_UPPER)
// but consider rather using TSQLRestServerURIContext.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 HTTP_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
// - HTTP_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
// - stores SynCrtSock's THttpServerConnectionID, i.e. a Int64 as expected
// by http.sys, or an incremental rolling sequence of 31-bit integers for
// THttpServer/TWebSocketServer, or maybe a raw PtrInt(self/THandle)
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;
/// check if the "Content-Type" value from InHead is JSON
// - if GuessJSONIfNoneSet is TRUE, assume JSON is used
function InBodyTypeIsJson(GuessJSONIfNoneSet: boolean=True): boolean;
/// 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;
/// check if the "Content-Type" value from OutHead is JSON
// - if GuessJSONIfNoneSet is TRUE, assume JSON is used
function OutBodyTypeIsJson(GuessJSONIfNoneSet: boolean=True): boolean;
/// just a wrapper around FindNameValue(InHead,UpperName)
// - use e.g. as
// ! Call.Header(HEADER_REMOTEIP_UPPER) or Call.Header(HEADER_BEARER_UPPER)
// - consider rather using TSQLRestServerURIContext.InHeader[] or even
// dedicated TSQLRestServerURIContext.RemoteIP/AuthenticationBearerToken
function Header(UpperName: PAnsiChar): RawUTF8;
{$ifdef HASINLINE}inline;{$endif}
/// wrap FindNameValue(InHead,UpperName) with a cache store
function HeaderOnce(var Store: RawUTF8; UpperName: PAnsiChar): RawUTF8;
end;
/// used to map set of parameters for a Client or Server method call
PSQLRestURIParams = ^TSQLRestURIParams;
/// callback event signature before/after a Client or Server method call
// - to allow low-level interception of the request bodies e.g. for low-level
// logging/audit, or on-the-fly encryption and/or signature of the content
// - used by TSQLRest.OnDecryptBody and TSQLRest.OnEncryptBody - so the very
// same callbacks may be used on both client and server sides
// - for server-only process (e.g. to check for authorization), see rather
// TSQLRestServer.OnBeforeURI and TSQLRestServer.OnAfterURI events
// - used e.g. by TSQLRest.SetCustomEncryption method
TNotifyRestBody = procedure(Sender: TSQLRest; var Body,Head,URL: RawUTF8) of object;
/// 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,
afSecureConnectionRequired, afJWTRequired);
/// 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, optForceStandardJSON, optDontStoreVoidJSON,
optIgnoreException);
/// how TServiceFactoryServer.SetOptions() will set the options value
TServiceMethodOptionsAction = (moaReplace, moaInclude, moaExclude);
/// 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 will 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 -
// consider using TInterfaceFactory.RegisterUnsafeSPIType() instead if you
// prefer a more tuned filtering, for specific high-level types
// - when parameters are transmitted as JSON object, any missing parameter
// will be replaced by their default value, unless optErrorOnMissingParam
// is defined to reject the call
// - by default, it wil check for the client user agent, and use extended
// JSON if none is found (e.g. from WebSockets), or if it contains 'mORMot':
// you can set optForceStandardJSON to ensure standard JSON is always returned
// - optDontStoreVoidJSON will reduce the JSON object verbosity by not writing
// void (e.g. 0 or '') properties when serializing objects and records
// - any exceptions will be propagated during execution, unless
// optIgnoreException is set and the exception is trapped (not to be used
// unless you know what you are doing)
TServiceMethodOptions = set of TServiceMethodOption;
/// 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;
/// 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
LogClass: TSQLRecordServiceLogClass;
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)
// - 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
// - 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
// - 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 will 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 will 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[]
{$ifdef USERECORDWITHMETHODS}TSQLAccessRights = record
{$else}TSQLAccessRights = object{$endif}
public
/// 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);
//// used to customize TSQLRestServerURIContext.ClientSideInvoke process
TSQLRestServerURIContextClientInvoke = set of (csiAsOctetStream);
/// 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 working inherited
// classes - NEVER set this abstract TSQLRestServerURIContext class to
// TSQLRest.ServicesRouting property !
TSQLRestServerURIContext = class
protected
fInput: TRawUTF8DynArray; // even items are parameter names, odd are values
fInputPostContentType: RawUTF8;
fInputCookiesRetrieved: boolean;
fInputCookies: array of record
Name, Value: RawUTF8; // only computed if InCookie[] is used
end;
fInHeaderLastName: RawUTF8;
fInHeaderLastValue: RawUTF8;
fOutSetCookie: RawUTF8;
fUserAgent: RawUTF8;
fAuthenticationBearerToken: RawUTF8;
fRemoteIP: RawUTF8;
fSession: TAuthSession; // not published to avoid unexpected GPF on access
fServiceListInterfaceMethodIndex: integer;
fClientKind: TSQLRestServerURIContextClientKind;
// just a wrapper over @ServiceContext threadvar
fThreadServer: PServiceRunningContext;
fSessionAccessRights: TSQLAccessRights; // fSession may be deleted meanwhile
{$ifndef NOVARIANTS}
function GetInput(const ParamName: RawUTF8): variant;
function GetInputOrVoid(const ParamName: RawUTF8): variant;
{$endif}
function GetInputNameIndex(const ParamName: RawUTF8): PtrInt;
function GetInputExists(const ParamName: RawUTF8): Boolean;
function GetInputInt(const ParamName: RawUTF8): Int64;
function GetInputDouble(const ParamName: RawUTF8): Double;
procedure GetInputByName(const ParamName,InputName: RawUTF8; var result: RawUTF8);
function GetInputUTF8(const ParamName: RawUTF8): RawUTF8; {$ifdef HASINLINE}inline;{$endif}
function GetInputString(const ParamName: RawUTF8): string;
function GetInputIntOrVoid(const ParamName: RawUTF8): Int64; {$ifdef HASINLINE}inline;{$endif}
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;
procedure RetrieveCookies;
function GetInCookie(CookieName: RawUTF8): RawUTF8;
procedure SetInCookie(CookieName, CookieValue: RawUTF8);
function GetUserAgent: RawUTF8; {$ifdef HASINLINE}inline;{$endif}
function GetRemoteIP: RawUTF8; {$ifdef HASINLINE}inline;{$endif}
function GetRemoteIPNotLocal: RawUTF8; {$ifdef HASINLINE}inline;{$endif}
function GetRemoteIPIsLocalHost: boolean; {$ifdef HASINLINE}inline;{$endif}
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);
/// 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 := HTTP_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 trailing /info and ?par1=.... parameters
// - can be either the table name (in RESTful protocol), or a service name
URI: RawUTF8;
/// same as Call^.URI, but without the &session_signature=... ending
URIWithoutSignature: RawUTF8;
/// points inside Call^.URI, after the 'root/' prefix
URIAfterRoot: PUTF8Char;
/// the optional Blob field name as specified in URI
// - e.g. retrieved from "ModelRoot/TableName/TableID/BlobFieldName"
URIBlobFieldName: RawUTF8;
/// decoded URI for rsoMethodUnderscoreAsSlashURI in Server.Options
// - e.g. 'Method_Name' from 'ModelRoot/Method/Name' URI
URIUnderscoreAsSlash: 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;
/// access to the raw PServiceMethod information of an interface-based URI
// - equals nil if ServiceMethodIndex in 0..2 (pseudo-methods)
ServiceMethod: pointer;
/// 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-SERVICE_PSEUDO_METHOD_COUNT]
ServiceExecution: PServiceFactoryExecution;
/// the current execution options of an interface-based service
// - contain ServiceExecution.Options including optNoLogInput/optNoLogOutput
// in case of TInterfaceFactory.RegisterUnsafeSPIType
ServiceExecutionOptions: TServiceMethodOptions;
/// 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, will 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 internal ID used to identify modelroot/_safe_ custom encryption
SafeProtocolID: integer;
/// 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)
// - contains e.g. TNotifyAuthenticationFailedReason text during
// TSQLRestServer.OnAuthenticationFailed event call, or the reason of a
// TSQLRestServer.RecordCanBeUpdated failure
CustomErrorMsg: RawUTF8;
/// high-resolution timimg of the execution command, in micro-seconds
// - only set when TSQLRestServer.URI finished
MicroSecondsElapsed: QWord;
/// JWT validation information, as filled by AuthenticationCheck()
JWTContent: TJWTContent;
{$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}
/// initialize the execution context
// - this method could have been declared as protected, since it should
// never be called outside the TSQLRestServer.URI() method workflow
// - should set Call, and Method members
constructor Create(aServer: TSQLRestServer; const aCall: TSQLRestURIParams); virtual;
/// 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...}
// - optionally with a PServiceMethod information about the actual values types
// - 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 will be Base64 encoded, so you should better
// use the InputAsMultiPart() method instead when working with binary
function GetInputAsTDocVariant(const Options: TDocVariantOptions; ServiceMethod: pointer): variant;
{$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
// - but rather call RemoteIP or UserAgent properties instead of
// InHeader['remoteip'] or InHeader['User-Agent']
property InHeader[const HeaderName: RawUTF8]: RawUTF8 read GetInHeader;
/// retrieve an incoming HTTP cookie value
// - cookie name are case-sensitive
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+'; HttpOnly'
property OutSetCookie: RawUTF8 read fOutSetCookie write SetOutSetCookie;
/// retrieve the "User-Agent" value from the incoming HTTP headers
property UserAgent: RawUTF8 read GetUserAgent;
/// retrieve the "RemoteIP" value from the incoming HTTP headers
property RemoteIP: RawUTF8 read GetRemoteIP;
/// true if the "RemoteIP" value from the incoming HTTP headers is '127.0.0.1'
property RemoteIPIsLocalHost: boolean read GetRemoteIPIsLocalHost;
/// "RemoteIP" value from the incoming HTTP headers but '' for '127.0.0.1'
property RemoteIPNotLocal: RawUTF8 read GetRemoteIPNotLocal;
/// retrieve the "Authorization: Bearer <token>" value from incoming HTTP headers
// - typically returns a JWT for statelesss self-contained authentication,
// as expected by TJWTAbstract.Verify method
// - as an alternative, a non-standard and slightly less safe way of
// token transmission may be to encode its value as ?authenticationbearer=....
// URI parameter (may be convenient when embedding resources in HTML DOM)
function AuthenticationBearerToken: RawUTF8;
/// validate "Authorization: Bearer <JWT>" content from incoming HTTP headers
// - returns true on success, storing the payload in the JWTContent field
// - set JWTContent.result = jwtNoToken if jwt is nil
// - on failure (i.e. returns false), will set the error context as
// 403 HTTP_FORBIDDEN so that you may directly write:
// ! procedure TMyDaemon.Files(Ctxt: TSQLRestServerURIContext);
// ! begin
// ! if Ctxt.AuthenticationCheck(fJWT) then
// ! Ctxt.ReturnFileFromFolder('c:\datafolder');
// ! end;
function AuthenticationCheck(jwt: TJWTAbstract): boolean; virtual;
/// 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 HTTP_SUCCESS, HTTP_NOTMODIFIED,
// HTTP_CREATED, or HTTP_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 HTTP_SUCCESS, the Result
// content will be hashed (using crc32c) and in case of no modification
// will return HTTP_NOTMODIFIED to the browser, without the actual result
// content (to save bandwidth)
// - set CacheControlMaxAge<>0 to include a Cache-Control: max-age=xxx header
procedure Returns(const Result: RawUTF8; Status: integer=HTTP_SUCCESS;
const CustomHeader: RawUTF8=''; Handle304NotModified: boolean=false;
HandleErrorAsRegularResult: boolean=false; CacheControlMaxAge: integer=0;
ServerHash: RawUTF8=''); 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 HTTP_SUCCESS or HTTP_CREATED
// - caller can set Handle304NotModified=TRUE for Status=HTTP_SUCCESS
procedure Returns(const NameValuePairs: array of const; Status: integer=HTTP_SUCCESS;
Handle304NotModified: boolean=false; HandleErrorAsRegularResult: boolean=false;
const CustomHeader: RawUTF8=''); 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=HTTP_SUCCESS;
Handle304NotModified: boolean=false;
SQLRecordOptions: TJSONSerializerSQLRecordOptions=[];
const CustomHeader: RawUTF8=''); 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=HTTP_SUCCESS;
Handle304NotModified: boolean=false; Escape: TTextWriterKind=twJSONEscape;
MakeHumanReadable: boolean=false; const CustomHeader: RawUTF8='');
/// 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 HTTP_NOTMODIFIED process will take place, to minimize
// bandwidth between the server and the client
// - set CacheControlMaxAge<>0 to include a Cache-Control: max-age=xxx header
procedure ReturnBlob(const Blob: RawByteString; Status: integer=HTTP_SUCCESS;
Handle304NotModified: boolean=true; const FileName: TFileName='';
CacheControlMaxAge: integer=0);
/// 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;
// set CacheControlMaxAge<>0 to include a Cache-Control: max-age=xxx header
// - 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 will 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='';
CacheControlMaxAge: integer=0);
/// use this method to send back a file from a local folder to the caller
// - URIBlobFieldName value, as parsed from the URI, will 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
// set CacheControlMaxAge<>0 to include a Cache-Control: max-age=xxx header
procedure ReturnFileFromFolder(const FolderName: TFileName;
Handle304NotModified: boolean=true; const DefaultFileName: TFileName='index.html';
const Error404Redirect: RawUTF8=''; CacheControlMaxAge: integer=0);
/// use this method notify the caller that the resource URI has changed
// - returns a HTTP_TEMPORARYREDIRECT status with the specified location,
// or HTTP_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 HTTP_SUCCESS or HTTP_CREATED
// - caller can set Handle304NotModified=TRUE for Status=HTTP_SUCCESS and/or
// set CacheControlMaxAge<>0 to include a Cache-Control: max-age=xxx header
procedure Results(const Values: array of const; Status: integer=HTTP_SUCCESS;
Handle304NotModified: boolean=false; CacheControlMaxAge: integer=0);
/// 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=HTTP_SUCCESS); virtual;
/// use this method to send back an error to the caller
// - expects Status to not be HTTP_SUCCESS neither HTTP_CREATED,
// and will send back a JSON error message to the caller, with the
// supplied error text
// - set CacheControlMaxAge<>0 to include a Cache-Control: max-age=xxx header
// - if no ErrorMessage is specified, will return a default text
// corresponding to the Status code
procedure Error(const ErrorMessage: RawUTF8='';
Status: integer=HTTP_BADREQUEST; CacheControlMaxAge: integer=0); 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=HTTP_BADREQUEST; CacheControlMaxAge: integer=0); 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=HTTP_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; ctxt: TSQLRestServerURIContextClientInvoke;
const method, params, clientDrivenID: RawUTF8; out sent,head: 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;
// will 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; ctxt: TSQLRestServerURIContextClientInvoke;
const method, params, clientDrivenID: RawUTF8; out sent,head: 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; ctxt: TSQLRestServerURIContextClientInvoke;
const method, params, clientDrivenID: RawUTF8; out sent,head: 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 HTTP_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 (do nothing
// on SQLite3, by design - but may be used for tables on external databases)
// - 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;
fInternalBufferSize: integer;
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 changes
// - 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
// - InternalBufferSize could be set to some high value (e.g. 10 shl 20),
// if you expect a very high number of rows in this BATCH
constructor Create(aRest: TSQLRest; aTable: TSQLRecordClass;
AutomaticTransactionPerRow: cardinal=0; Options: TSQLRestBatchOptions=[];
InternalBufferSize: cardinal=65536); virtual;
/// 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/4/5, 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
// - if not all fields are specified, will reset the cache entry associated
// with this value, unless ForceCacheUpdate is TRUE
function Update(Value: TSQLRecord; const CustomFields: TSQLFieldBits=[];
DoNotAutoComputeFields: boolean=false; ForceCacheUpdate: 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; ForceCacheUpdate: 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 will 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
// - returns the corresponding index in the current BATCH sequence, -1 on error
function RawAdd(const SentData: RawUTF8): integer;
/// 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
// - returns the corresponding index in the current BATCH sequence, -1 on error
function RawUpdate(const SentData: RawUTF8; ID: TID): integer;
/// 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;
/// 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;
published
/// read only access to the main associated TSQLRecord class (if any)
property Table: TSQLRecordClass read fTable;
/// 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;
end;
/// thread-safe class to store a BATCH sequence of writing operations
TSQLRestBatchLocked = class(TSQLRestBatch)
protected
fTix: Int64;
fSafe: TSynLocker;
fThreshold: integer;
public
/// initialize the BATCH instance
constructor Create(aRest: TSQLRest; aTable: TSQLRecordClass;
AutomaticTransactionPerRow: cardinal=0; Options: TSQLRestBatchOptions=[];
InternalBufferSize: cardinal=65536); override;
/// 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;
/// may be used to store a number of rows to flush the content
property Threshold: integer read fThreshold write fThreshold;
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
// - consider inherit from TSQLRecordNoCase and TSQLRecordNoCaseExtended if
// you expect regular NOCASE collation and smaller (but not standard JSON)
// variant fields persistence
// - is called TOrm in mORMot 2
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 GetFillReachedEnd: boolean;
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 will 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, or to call Props.SetCustomCollationForAll
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, or use a with TSQLRecord.AutoFree() do
// statement - see 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, or use a with TSQLRecord.AutoFree() do
// statement - see http://bugs.freepascal.org/view.php?id=26602
class function AutoFree(var localVariable): IAutoFree; overload;
/// read and protect one TSQLRecord local variable instance
// - is a wrapper around TAutoFree.Create(localVariable,Create(Rest,ID))
// - 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, or use a with TSQLRecord.AutoFree() do
// statement - see http://bugs.freepascal.org/view.php?id=26602
class function AutoFree(var localVariable; Rest: TSQLRest; ID: TID): IAutoFree; overload;
/// FillPrepare and protect one TSQLRecord local variable instance
// - is a wrapper around TAutoFree.Create(localVariable,CreateAndFillPrepare(Rest,...))
// - 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, or use a with TSQLRecord.AutoFree() do
// statement - see http://bugs.freepascal.org/view.php?id=26602
class function AutoFree(var localVariable; Rest: TSQLRest;
const FormatSQLWhere: RawUTF8; const BoundsSQLWhere: array of const;
const aCustomFieldsCSV: RawUTF8=''): IAutoFree; overload;
/// FillPrepare and protect one TSQLRecord local variable instance
// - is a wrapper around TAutoFree.Create(localVariable,CreateAndFillPrepare(Rest,...))
// - 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, or use a with TSQLRecord.AutoFree() do
// statement - see http://bugs.freepascal.org/view.php?id=26602
class function AutoFree(var localVariable; Rest: TSQLRest;
const FormatSQLWhere: RawUTF8; const ParamsSQLWhere,BoundsSQLWhere: array of const;
const aCustomFieldsCSV: RawUTF8=''): 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,
// within the context of an opened DB transaction, in which missing tables
// and fields have already been added
// - 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, which will use a private copy
// - 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, and prepares itself to loop
// through a specified JSON table buffer, which will be modified in-place
// - 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(aJSON: PUTF8Char; aJSONLen: integer); 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;
/// set the bits corresponding to non-void (0,'') copiable fields
function GetNonVoidFields: TSQLFieldBits;
/// 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
// - the JSON buffer will be finalized if needed (e.g. non expanded mode),
// and the supplied TJSONSerializer instance will be freed by this method
// - layout and fields should have been set at TJSONSerializer construction:
// to append some content to an existing TJsonSerializer, call the
// AppendAsJsonObject() 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 will 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, 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, 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, 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, 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=[]);
{$ifndef NOVARIANTS}
/// 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);
{$endif}
/// 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.)
// - PEnd should point just after the P input buffer, to avoid buffer overflow
// - 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; PEnd: 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.)
// - PEnd should point just after the P input buffer, to avoid buffer overflow
// - 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; PEnd: 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
// - PEnd should point to the end of the P input buffer, to avoid any overflow
function SetBinary(P,PEnd: PAnsiChar): Boolean; overload;
/// set the record fields from a binary buffer saved by GetBinary()
// - same as SetBinaryValues(), but also reading the ID field first
function SetBinary(const binary: RawByteString): Boolean; overload;
/// 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; replaceRowIDWithID: boolean=false): 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; ReplaceRowIDWithID: boolean=false); 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(aDest: TSQLRecord=nil): 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;
// you may use aRecord.GetNonVoidFields if you want to update some fields
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
// - instances must be of the same class type
// - only simple fields (i.e. not TSQLRawBlob/TSQLRecordMany) are compared
// - comparison is much faster than SameValues() below
function SameRecord(Reference: TSQLRecord): boolean;
/// 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;
/// clear the values of all published properties, and also the ID property
procedure ClearProperties; overload;
/// clear the values of specified published properties
// - '' will 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
// - use IDValue property for direct read/write access to the record's ID
// field, if you know that this TSQLRecord is a true allocated class instance
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-bit, then it will 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
// - on FPC, if you get an Error: Incompatible types: got "Pointer" expected
// "T...", then you are missing a {$mode Delphi} conditional in your unit:
// the easiest is to include {$I Synopse.inc} at the top of your unit
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;
/// this property is set to true, if all rows have been browsed after
// FillPrepare / while FillOne do ...
property FillReachedEnd: boolean read GetFillReachedEnd;
/// 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;
PSQLRecord = ^TSQLRecord;
TSQLRecordArray = array[0..MaxInt div SizeOf(TSQLRecord)-1] of TSQLRecord;
PSQLRecordArray = ^TSQLRecordArray;
/// root class for defining and mapping database records with case-insensitive
// NOCASE collation
// - abstract ancestor, from which you may inherit your own ORM classes
// - by default, any sftUTF8Text field (RawUTF8, UnicodeString, WideString
// properties) will use our Unicode SYSTEMNOCASE SQLite3 collation, which calls
// UTF8ILComp() to handle most western languages, but is not standard
// - you may inherit from this class to ensure any text field will use the
// faster and SQLite3 built-in NOCASE collation, handling only 7-bit A-Z chars
// - inherit from TSQLRecordNoCase or TSQLRecordCaseSensitive if you expect
// your text fields to contain only basic (un)accentued ASCCI characters, and
// to be opened by any standard/ SQlite3 library or tool (outside of
// SynSQLite3.pas/SynDBExplorer)
TSQLRecordNoCase = class(TSQLRecord)
protected
/// will call Props.SetCustomCollationForAll(sftUTF8Text,'NOCASE')
class procedure InternalDefineModel(Props: TSQLRecordProperties); override;
end;
/// root class for defining and mapping database records with case-sensitive
// BINARY collation
// - abstract ancestor, from which you may inherit your own ORM classes
// - by default, any sftUTF8Text field (RawUTF8, UnicodeString, WideString
// properties) will use our Unicode SYSTEMNOCASE SQLite3 collation, which calls
// UTF8ILComp() to handle most western languages, but is not standard
// - you may inherit from this class to ensure any text field will use the
// faster and SQLite3 built-in BINARY collation, which is case-sensitive
// - inherit from TSQLRecordNoCase or TSQLRecordCaseSensitive if you expect
// your text fields to contain only basic (un)accentued ASCCI characters, and
// to be opened by any standard/ SQlite3 library or tool (outside of
// SynSQLite3.pas/SynDBExplorer)
TSQLRecordCaseSensitive = class(TSQLRecord)
protected
/// will call Props.SetCustomCollationForAll(sftUTF8Text,'BINARY')
class procedure InternalDefineModel(Props: TSQLRecordProperties); override;
end;
/// database records with NOCASE collation and JSON_OPTIONS_FAST_EXTENDED variants
// - abstract ancestor, from which you may inherit your own ORM classes
TSQLRecordNoCaseExtended = class(TSQLRecordNoCase)
protected
/// will call Props.SetVariantFieldsDocVariantOptions(JSON_OPTIONS_FAST_EXTENDED);
class procedure InternalDefineModel(Props: TSQLRecordProperties); override;
end;
/// database records with BINARY collation and JSON_OPTIONS_FAST_EXTENDED variants
// - abstract ancestor, from which you may inherit your own ORM classes
TSQLRecordCaseSensitiveExtended = class(TSQLRecordCaseSensitive)
protected
/// will call Props.SetVariantFieldsDocVariantOptions(JSON_OPTIONS_FAST_EXTENDED);
class procedure InternalDefineModel(Props: TSQLRecordProperties); override;
end;
/// database records with NOCASE collation and JSON_OPTIONS_FAST_EXTENDED
// variants, and itoNoIndex4TID option to avoid indexes on TID/T*ID properties
// - abstract ancestor, from which you may inherit your own ORM classes
TSQLRecordNoCaseExtendedNoID = class(TSQLRecordNoCaseExtended)
public
/// overriden method forcing no index creation on TID/T*ID properties
class procedure InitializeTable(Server: TSQLRestServer; const FieldName: RawUTF8;
Options: TSQLInitializeTableOptions); override;
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) unless HumanFriendly is defined
// - e.g. TSQLTable.OnExportValue property will customize TSQLTable's
// GetJSONValues, GetHtmlTable, and GetCSVValues methods returned content
TOnSQLTableGetValue = function(Sender: TSQLTable; Row, Field: integer;
HumanFriendly: boolean): RawJSON of object;
/// store TSQLFieldType and RTTI for a given TSQLTable field
TSQLTableFieldType = record
/// the field kind, as in JSON (match TSQLPropInfo.SQLFieldTypeStored)
ContentType: TSQLFieldType;
/// how this field could be stored in a database
// - equals ftUnknown if InitFields guessed the field type, or for sftVariant
ContentDB: TSQLDBFieldType;
/// 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;
PSQLTableFieldType = ^TSQLTableFieldType;
/// 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, e.g. as returned by sqlite3_get_table()
fResults: PPUTF8CharArray;
fFieldType: array of TSQLTableFieldType;
fFieldTypeAllRows: boolean;
/// the field names
fFieldNames: TRawUTF8DynArray;
/// used by FieldIndex() for fast O(log(n)) binary search
fFieldNameOrder: TCardinalDynArray;
/// contain the fResults[] pointers, after a IDColumnHide() call
fIDColumn, fNotIDColumn: TPUTF8CharDynArray;
/// 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: TSynObjectList;
/// 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): 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; 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
// - sftDateTime/sftDateTimeMS 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
// - sftUnixTime/sftUnixMSTime field will call UnixTimeToDateTime/UnixMSTimeToDateTime
// - for sftTimeLog, sftModTime, sftCreateTime or sftUnixTime 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,
// sftUnixTime/sftUnixMSTime 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, sftDateTimeMS, sftTimeLog, sftModTime,
// sftCreateTime, sftUnixTime, sftUnixMSTime)
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;
/// 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
// - returns the number of rows in Values[]
function GetRowValues(Field: integer; out Values: TRawUTF8DynArray): integer; overload;
/// get all values for a specified field into a dynamic Integer array
// - returns the number of rows in Values[]
function GetRowValues(Field: integer; out Values: TInt64DynArray): integer; 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; const Sep: RawUTF8=',';
const Head: RawUTF8=''; const Trail: RawUTF8=''): RawUTF8; overload;
/// get all values lengths for a specified field into a PIntegerArray
// - returns the total length as result, and fill LenStore with all rows
// individual lengths using StrLen() - caller should eventually call
// LenStore.Done to release any temp memory
// - returns 0 if Field is invalid or no data is stored in this TSQLTable -
// don't call LenStore.Done in this case
function GetRowLengths(Field: integer; var LenStore: TSynTempBuffer): integer;
{$ifndef NOVARIANTS}
/// retrieve a field value in a variant
// - returns null if the row/field is incorrect
// - expand* methods will 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 will 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 TJSONWriter, with UTF-8 encoding, and not flushed
// - 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 W.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)
// - IDBinarySize will force the ID field to be stored as hexadecimal text
procedure GetJSONValues(W: TJSONWriter; RowFirst: integer=0;
RowLast: integer=0; IDBinarySize: integer=0); overload;
/// same as the overloaded method, but appending an array to a TStream
procedure GetJSONValues(JSON: TStream; Expand: boolean;
RowFirst: integer=0; RowLast: integer=0; IDBinarySize: integer=0); overload;
/// same as the overloaded method, but returning result into a RawUTF8
function GetJSONValues(Expand: boolean; IDBinarySize: integer=0;
BufferSize: integer=0): RawUTF8; 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 consumed by MS apps
// - see @https://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 consumed by MS apps
// - see @https://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 @https://synopse.info/forum/viewtopic.php?id=2133
function GetODSDocument(withColumnTypes: boolean=false): 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
// - returns the number of matching Field names
// - set -1 in FieldIndexes[]^ if not found, index (0..FieldCount-1) if found
function FieldIndex(const FieldNames: array of RawUTF8;
const FieldIndexes: array of PInteger): integer; 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 comparison 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[] arrays 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)
// - if CustomCompare=[], which use the default comparison function for the
// field type, unless you set as many custom comparison function items
// as in the Fields[] and Asc[] parameters
procedure SortFields(const Fields: array of integer;
const Asc: array of boolean; const CustomCompare: array of TUTF8Compare); 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; out FieldTypeInfo: PSQLTableFieldType): TSQLFieldType; overload;
/// get the appropriate Sort comparison 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;
/// set the exact type of all fields, from the DB-like information
procedure SetFieldTypes(const DBTypes: TSQLDBFieldTypeDynArray);
/// 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 UpperValue: 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 UpperValue: RawUTF8; StartRow: integer;
FieldIndex: PInteger; Client: TObject; Lang: TSynSoundExPronunciation=sndxNone;
UnicodeComparison: boolean=false): integer; overload;
/// search for a value inside the raw table data, using UTF8IComp/StrComp()
// - returns 0 if not found, or the matching Row number otherwise
function SearchFieldEquals(const Value: RawUTF8; FieldIndex: integer;
StartRow: integer=1; CaseSensitive: boolean=false): integer; overload;
/// search for a value inside the raw table data, using UTF8IComp/StrComp()
// - returns 0 if not found, or the matching Row number otherwise
function SearchFieldEquals(Value: PUTF8Char; FieldIndex: integer;
StartRow: integer=1; CaseSensitive: boolean=false): integer; overload;
/// search for a value inside the raw table data, using IdemPChar()
// - returns 0 if not found, or the matching Row number otherwise
function SearchFieldIdemPChar(const Value: RawUTF8; FieldIndex: integer;
StartRow: integer=1): integer;
/// search for a value using O(log(n)) binary search of a sorted field
// - here the content should have been previously sorted via Sort(),
// or CustomCompare should be defined, otherwise the SearchFieldEquals()
// slower O(n) method is called
// - returns 0 if not found, or the matching Row number otherwise
function SearchFieldSorted(const Value: RawUTF8; FieldIndex: integer;
CustomCompare: TUTF8Compare=nil): integer; overload;
/// search for a value using O(log(n)) binary search of a sorted field
// - here the content should have been previously sorted via Sort(),
// or CustomCompare should be defined, otherwise the SearchFieldEquals()
// slower O(n) method is called
// - returns 0 if not found, or the matching Row number otherwise
function SearchFieldSorted(Value: PUTF8Char; FieldIndex: integer;
CustomCompare: TUTF8Compare=nil): integer; overload;
/// 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, unless aNotFoundMinusOne is set, and then -1 is
// returned
function RowFromID(aID: TID; aNotFoundMinusOne: boolean=false): 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
function DeleteRow(Row: integer): boolean;
/// delete the specified Column text from the Table
// - don't delete the Column: only delete UTF-8 text in all rows for this field
function DeleteColumnValues(Field: integer): boolean;
/// retrieve QueryTables[0], if existing
function QueryRecordType: TSQLRecordClass;
/// create a new TSQLRecord instance for a specific Table
// - a void TSQLRecord instance is created, ready to be filled
// - use the specified TSQLRecord class or create one instance
// of the first associated record class (from internal QueryTables[])
// - the returned records will be managed by this TSQLTable: they will be
// freed when the TSQLTable is destroyed: you don't need to make a
// try..finally..Free..end block with them
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/2010 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 ISDELPHI2010}
/// 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}
/// read-only access to a particular field value, as RawUTF8
// - raise an ESQLTableException if called outside valid Step() sequence
// - similar to GetU() method, but for the current Step
function FieldAsRawUTF8(FieldIndex: Integer): RawUTF8; overload;
{$ifdef HASINLINE}inline;{$endif}
/// read-only access to a particular field value, as RawUTF8
// - raise an ESQLTableException if called outside valid Step() sequence
// - similar to GetU() method, but for the current Step
function FieldAsRawUTF8(const FieldName: RawUTF8): RawUTF8; overload;
{$ifdef HASINLINE}inline;{$endif}
/// read-only access to a particular field value, as VCL String
// - raise an ESQLTableException if called outside valid Step() sequence
// - similar to GetString() method, but for the current Step
function FieldAsString(FieldIndex: Integer): String; overload;
{$ifdef HASINLINE}inline;{$endif}
/// read-only access to a particular field value, as VCL String
// - raise an ESQLTableException if called outside valid Step() sequence
// - similar to GetString() method, but for the current Step
function FieldAsString(const FieldName: RawUTF8): String; 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
// - safely returns 0 if the TSQLTable instance is nil
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
function IntGet(var Dest: TVarData; const Instance: TVarData;
Name: PAnsiChar; NameLen: PtrInt): boolean; 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;
EObjectVariant = ESynException;
/// a custom variant type used to have direct access to object published properties
// - TObjectVariant provides lazy-loading to object properties from a Variant
// variable - which may be used with SynMustache or with late-binding
// - warning: this custom variant is just a wrapper around an existing TObject
// instance, which should remain available as long as the variant is used
// - if you want a per-representation stateless variant, use ObjectToVariant()
// which convert all properties into a TDocVariant, so may use more resource
TObjectVariant = class(TSynInvokeableVariantType)
protected
function IntGet(var Dest: TVarData; const Instance: TVarData;
Name: PAnsiChar; NameLen: PtrInt): boolean; override;
function IntSet(const Instance, Value: TVarData;
Name: PAnsiChar; NameLen: PtrInt): boolean; override;
public
/// initialize a new custom variant instance, wrapping the specified object
// - warning: this custom variant is just a wrapper around an existing TObject
// instance, which should remain available as long as the variant is used
class procedure New(var V: Variant; Obj: TObject);
/// will perform proper JSON serialization calling W.WriteObject()
procedure ToJSON(W: TTextWriter; const Value: variant; Escape: TTextWriterKind); override;
end;
{$endif NOVARIANTS}
/// store a read-only ORM result table from a JSON message
// - the JSON data is parsed and unescaped in-place, to enhanced performance
// and reduce resource consumption (mainly memory/heap fragmentation)
// - is used by the ORM for TSQLRecord.FillPrepare/FillOne methods for
// fast access to individual object values
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: TPUTF8CharDynArray;
/// 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 fPrivateCopy content changed (then fPrivateCopyHash
// will be updated using crc32c hash if aUpdateHash is set)
function PrivateCopyChanged(aJSON: PUTF8Char; aLen: integer;
aUpdateHash: boolean): 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 a const
// aJSON: RawUTF8 parameter to allocate and hold 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
// - 16 more bytes will be allocated, to allow e.g. proper SSE4.2 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;
/// store a writable ORM result table, optionally read from a JSON message
// - in respect to TSQLTableJSON, this class allows to modify field values,
// and add some new fields on the fly, even joined from another TSQLTable
TSQLTableWritable = class(TSQLTableJSON)
protected
fNewValues: TRawUTF8DynArray;
fNewValuesCount: integer;
fNewValuesInterning: TRawUTF8Interning;
public
/// modify a field value in-place, using a RawUTF8 text value
procedure Update(Row,Field: integer; const Value: RawUTF8); overload;
/// modify a field value in-place, using a RawUTF8 text value
procedure Update(Row: integer; const FieldName, Value: RawUTF8); overload;
{$ifndef NOVARIANTS}
/// modify a field value in-place, using a variant value
procedure Update(Row,Field: integer; const Value: variant); overload;
/// modify a field value in-place, using a variant value
procedure Update(Row: integer; const FieldName: RawUTF8; const Value: variant); overload;
{$endif NOVARIANTS}
/// define a new field to be stored in this table
// - returns the internal index of the newly created field
function AddField(const FieldName: RawUTF8): integer; overload;
/// define a new field to be stored in this table
// - returns the internal index of the newly created field
function AddField(const FieldName: RawUTF8; FieldType: TSQLFieldType;
FieldTypeInfo: pointer=nil; FieldSize: integer=-1): integer; overload;
/// define a new field to be stored in this table
// - returns the internal index of the newly created field
function AddField(const FieldName: RawUTF8; FieldTable: TSQLRecordClass;
const FieldTableName: RawUTF8=''): integer; overload;
/// append/merge data from a secondary TSQLTable
// - you should specify the primary keys on which the data rows are merged
// - merged data will point to From.fResults[] content: so the From instance
// should remain available as long as you use this TSQLTableWritable
// - warning: will call From.SortFields(FromKeyField) for faster process
procedure Join(From: TSQLTable; const FromKeyField, KeyField: RawUTF8);
/// optionaly de-duplicate Update() values
property NewValuesInterning: TRawUTF8Interning
read fNewValuesInterning write fNewValuesInterning;
/// how many values have been written via Update() overloaded methods
// - is not used if NewValuesInterning was defined
property NewValuesCount: integer read fNewValuesCount;
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
{$ifdef USERECORDWITHMETHODS}TSQLLocks = record
{$else}TSQLLocks = object{$endif}
public
/// 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() will 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
// - is defined as an object and not a record to allow easy inheritance for
// proper per-application customization - see e.g. FileTables.pas in main demo
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 will bypass the existing table check, e.g.
// to circumvent some specific DB provider or case sensitivity issue on tables
// - rpmNoCreateMissingField will 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 will be case insensitive, unless
// the rpmMissingFieldNameCaseSensitive option is set
// - rpmQuoteFieldName will quote the field names - to be used e.g. with
// FireBird in its Dialect 3
// - rpmClearPoolOnConnectionIssue will enable detecting connection loss
TSQLRecordPropertiesMappingOptions = set of (
rpmAutoMapKeywordFields,
rpmNoCreateMissingTable, rpmNoCreateMissingField,
rpmMissingFieldNameCaseSensitive, rpmQuoteFieldName,
rpmClearPoolOnConnectionIssue);
/// 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
{$ifdef USERECORDWITHMETHODS}TSQLRecordPropertiesMapping = record
{$else}TSQLRecordPropertiesMapping = object{$endif}
private
/// storage of main read-only properties
fProps: TSQLRecordProperties;
fConnectionProperties: TObject;
fTableName: RawUTF8;
fRowIDFieldName: RawUTF8;
fExtFieldNames: TRawUTF8DynArray;
fExtFieldNamesUnQuotedSQL: 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;
MappingOptions: TSQLRecordPropertiesMappingOptions);
/// 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 ExtFieldNames: TRawUTF8DynArray read fExtFieldNames;
/// the unquoted external field names, following fProps.Props.Field[] order
// - excluding ID/RowID field, which is stored in RowIDFieldName
// - in respect to ExtFieldNames[], this array will never quote the field name
property ExtFieldNamesUnQuotedSQL: TRawUTF8DynArray read fExtFieldNamesUnQuotedSQL;
/// 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 will 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;
/// will by-pass automated table and field creation for this TSQLRecord
// - may be used e.g. when the TSQLRecord is in fact mapped into a View,
// or is attached as external table and not a real local table
NoCreateMissingTable: boolean;
/// 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 will
// 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 FTS/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
/// refers to the source TSQLRecordClass as model Tables[] index
TableIndex: integer;
/// the property
FieldType: TSQLPropInfo;
/// the target TSQLRecordClass of the field
FieldTable: TSQLRecordClass;
/// the target TSQLRecordClass of the field, from its Tables[] index
FieldTableIndex: integer;
/// TRUE if this field is a TRecordReferenceToBeDeleted
CascadeDelete: boolean;
end;
PSQLModelRecordReference = ^TSQLModelRecordReference;
TSQLModelRecordReferenceDynArray = array of 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 O(log(n)) binary search
fSortedTablesNameUpper: TRawUTF8DynArray;
fSortedTablesNameIndex: TIntegerDynArray;
/// will contain the registered virtual table modules
fVirtualTableModule: array of TSQLVirtualTableClass;
/// all TRecordReference and TSQLRecord properties of the model
fRecordReferences: TSQLModelRecordReferenceDynArray;
fIDGenerator: array of TSynUniqueIdentifierGenerator;
procedure SetRoot(const aRoot: RawUTF8);
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
// will 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;
/// return any class inheriting from the given table in the model
// - if the model does not contain such table, supplied aTable is returned
function GetTableInherited(aTable: TSQLRecordClass): TSQLRecordClass;
/// 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 GetTableIndexPtr(SQLTableName: PUTF8Char): integer;
/// 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)
// - see also TSQLRecordNoCaseExtended root class
procedure SetVariantFieldsDocVariantOptions(const Options: TDocVariantOptions);
{$endif}
/// force a given table to use a TSynUniqueIdentifierGenerator for its IDs
/// - will 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, aExternalDataBase and aMappingOptions 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;
aMappingOptions: TSQLRecordPropertiesMappingOptions=[]): 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: integer; 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);
/// returns the Root property, or '' if the instance is nil
function SafeRoot: RawUTF8;
/// 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;
/// 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)
property RecordReferences: TSQLModelRecordReferenceDynArray read fRecordReferences;
{$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
// - this textual value will be used directly to compute the URI for REST
// routing, so it should contain only URI-friendly characters,
// i.e. only alphanumerical characters, excluding e.g. space or '+',
// otherwise an EModelException is raised
property Root: RawUTF8 read fRoot write SetRoot;
/// 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[]
{$ifdef FPC_OR_UNICODE}RecordRef = record
{$else}RecordRef = object{$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;
/// an abstract base class, corresponding to an R-Tree table of values
// - do not use this class, but either TSQLRecordRTree or TSQLRecordRTreeInteger
// - 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 as TSQLRecordRTree must have
// only sftFloat (double) fields (or integer fields for TSQLRecordRTreeInteger)
// grouped by pairs, each as minimum- and maximum-value, up to 5 dimensions
// (i.e. 11 columns, including the ID property)
// - since SQLite version 3.24.0 (2018-06-04), R-Tree tables can have
// auxiliary columns that store arbitrary data: such fields should appear after
// the boundary columns, and have their property name starting with '_' in the
// class definition; in both SQL and Where clause, the '_' will be trimmed - note
// that you should better use the SynSQLite3Static unit, since an external
// SQLite3 .dll/.so library as supplied by the system may be outdated
// - internally, the SQlite3 R-Tree extension will be implemented as a virtual
// table, storing coordinates/values as 32-bit floating point (single - as
// TSQLRecordRTree kind of ORM classes) or 32-bit integers (as TSQLRecordRTreeInteger),
// but will make all R-Tree computation using 64-bit floating point (double)
// - as with any virtual table, 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 - of
// course Auxiliary Columns could avoid to make the JOIN and call RTreeMatch
TSQLRecordRTreeAbstract = class(TSQLRecordVirtual)
public
/// override this class function to implement a custom SQL *_in() function
// - in practice, an R-Tree index does not normally provide the exact answer
// but merely reduces the set of potential answers from millions to dozens:
// this method will be called from the *_in() SQL function to actually
// return exact matches
// - by default, the BLOB array will be decoded via the BlobToCoord class
// procedure, and will create a SQL function from the class name
// - used e.g. by the TSQLRestClient.RTreeMatch method
class function ContainedIn(const BlobA,BlobB): boolean; virtual; abstract;
/// will return 'MapBox_in' e.g. for TSQLRecordMapBox
class function RTreeSQLFunctionName: RawUTF8; virtual;
end;
/// this kind of record array can be used for direct floating-point
// coordinates storage as in TSQLRecordRTree.BlobToCoord
TSQLRecordTreeCoords = array[0..RTREE_MAX_DIMENSION-1] of packed record
min, max: double; end;
/// a base record, corresponding to an R-Tree table of floating-point values
// - for instance, the following class will define a 2 dimensional RTree
// of floating point coordinates, and an associated 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;
// - since SQLite version 3.24.0, TSQLRecordRTree can have auxiliary columns
// that store arbitrary data, having their property name starting with '_'
// (only in this class definition: SQL and Where clauses will trim it)
TSQLRecordRTree = class(TSQLRecordRTreeAbstract)
public
/// 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
// - used e.g. by the TSQLRestClient.RTreeMatch method
class function ContainedIn(const BlobA,BlobB): boolean; override;
/// 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 TSQLRest.RTreeMatch method
class procedure BlobToCoord(const InBlob; var OutCoord: TSQLRecordTreeCoords); virtual;
end;
/// this kind of record array can be used for direct 32-bit integer
// coordinates storage as in TSQLRecordRTreeInteger.BlobToCoord
TSQLRecordTreeCoordsInteger = array[0..RTREE_MAX_DIMENSION-1] of packed record
min, max: integer; end;
/// a base record, corresponding to an R-Tree table of 32-bit integer values
// - for instance, the following class will define a 2 dimensional RTree
// of 32-bit integer coordinates, and an associated MapBox_in() function:
// ! TSQLRecordMapBox = class(TSQLRecordRTree)
// ! protected
// ! fMinX, fMaxX, fMinY, fMaxY: integer;
// ! published
// ! property MinX: integer read fMinX write fMinX;
// ! property MaxX: integer read fMaxX write fMaxX;
// ! property MinY: integer read fMinY write fMinY;
// ! property MaxY: integer read fMaxY write fMaxY;
// ! end;
// - since SQLite version 3.24.0, TSQLRecordRTreeInteger can have auxiliary
// columns that store arbitrary data, having their property name starting with '_'
// (only in this class definition: SQL and Where clauses will trim it)
TSQLRecordRTreeInteger = class(TSQLRecordRTreeAbstract)
public
/// 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
// - used e.g. by the TSQLRest.RTreeMatch method
class function ContainedIn(const BlobA,BlobB): boolean; override;
/// 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 integer
// - 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 integer properties
// - used e.g. by the TSQLRest.RTreeMatch method
class procedure BlobToCoord(const InBlob; var OutCoord: TSQLRecordTreeCoordsInteger); virtual;
end;
/// a base record, corresponding to a FTS3 table, i.e. implementing full-text
// - FTS3/FTS4/FTS5 tables are SQLite virtual tables allowing 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, or TSQLRecordFTS5 for the latest (and preferred) FTS5 engine
// - in order to make FTS 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[]
// - by convention, inherited class name could specify a custom stemming
// algorithm by starting with "TSQLRecordFTS3", and adding the algorithm name as
// suffix, e.g. TSQLRecordFTS3Porter will create a "tokenize=porter" virtual table
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
// - will generate tokenize=porter by convention from the class name
TSQLRecordFTS3Porter = class(TSQLRecordFTS3);
/// this base class will create a FTS3 table using the Unicode61 Stemming algorithm
// - see http://sqlite.org/fts3.html#tokenizer
// - will generate tokenize=unicode61 by convention from the class name
TSQLRecordFTS3Unicode61 = class(TSQLRecordFTS3);
/// a base record, corresponding 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, TSQLRecordFTS5 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
// - by convention, inherited class name could specify a custom stemming
// algorithm by starting with "TSQLRecordFTS4", and adding the algorithm name as
// suffix, e.g. TSQLRecordFTS'Porter will create a "tokenize=porter" virtual table
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
// - will generate tokenize=porter by convention from the class name
TSQLRecordFTS4Porter = class(TSQLRecordFTS4);
/// this base class will create a FTS4 table using the Unicode61 Stemming algorithm
// - see http://sqlite.org/fts3.html#tokenizer
// - will generate tokenize=unicode61 by convention from the class name
TSQLRecordFTS4Unicode61 = class(TSQLRecordFTS4);
/// a base record, corresponding to a FTS5 table, which is an enhancement to FTS4
// - FTS5 is a new version of FTS4 that includes various fixes and solutions for
// problems that could not be fixed in FTS4 without sacrificing backwards compatibility
// - for newer applications, TSQLRecordFTS5 is recommended; though if minimal
// disk usage or compatibility with older versions of SQLite are important,
// then TSQLRecordFTS3/TSQLRecordFTS4 will usually serve just as well
// - see https://sqlite.org/fts5.html#appendix_a
// - by convention, inherited class name could specify a custom stemming
// algorithm by starting with "TSQLRecordFTS5", and adding the algorithm name as
// suffix, e.g. TSQLRecordFTS5Porter will create a "tokenize=porter" virtual table
TSQLRecordFTS5 = class(TSQLRecordFTS4);
/// this base class will create a FTS5 table using the Porter Stemming algorithm
// - see https://sqlite.org/fts5.html#tokenizers
// - will generate tokenize=porter by convention from the class name
TSQLRecordFTS5Porter = class(TSQLRecordFTS5);
/// this base class will create a FTS5 table using the Unicode61 Stemming algorithm
// - see https://sqlite.org/fts5.html#tokenizers
// - will generate tokenize=unicode61 by convention from the class name
TSQLRecordFTS5Unicode61 = class(TSQLRecordFTS5);
/// class-reference type (metaclass) of a FTS3/FTS4/FTS5 virtual table
TSQLRecordFTS3Class = class of TSQLRecordFTS3;
/// class-reference type (metaclass) of a RTREE virtual table
// - either a TSQLRecordRTree or a TSQLRecordRTreeInteger
TSQLRecordRTreeClass = class of TSQLRecordRTreeAbstract;
/// 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 - note that by design, those source/dest tables are stored as
// pointers, so are limited to 32-bit ID values on 32-bit systems
// - 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;
function ComputeSignature(const UserName,Content: RawByteString): 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
// - 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 Signature;
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 will 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,
smvBinary,
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;
/// set of low-level processing options at assembly 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
// - vIsSPI indicates that the value contains some Sensitive Personal
// Information (e.g. a bank card number or a plain password), which type has
// been previously registered via TInterfaceFactory.RegisterUnsafeSPIType
// so that low-level logging won't include such values
// - vIsQword is set for ValueType=smvInt64 over a QWord unsigned 64-bit value
// - vIsDynArrayString is set for ValueType=smvDynArray of string values
// - vIsDateTimeMS is set for ValueType=smvDateTime and TDateTimeMS value
TServiceMethodValueAsm = set of (vIsString, vPassedByReference,
vIsObjArray, vIsSPI, vIsQword, vIsDynArrayString, vIsDateTimeMS);
/// describe a service provider method argument
{$ifdef USERECORDWITHMETHODS}TServiceMethodArgument = record
{$else}TServiceMethodArgument = object{$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
ValueKindAsm: TServiceMethodValueAsm;
/// 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 for D1, ..., 8 for D7 for armhf
// - contains 1 for V0, 2 for 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;
/// hexadecimal binary size (in bytes) of this smvv64 ordinal value
// - set only if ValueType=smvBinary
SizeInBinary: 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;
/// a TDynArray wrapper initialized properly for this smvDynArray
DynArrayWrapper: TDynArray;
{$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);
/// check if the supplied argument value is the default (e.g. 0, '' or null)
function IsDefault(V: pointer): boolean;
/// unserialize a JSON value into this argument
function FromJSON(const MethodName: RawUTF8; var R: PUTF8Char; V: pointer;
Error: PShortString{$ifndef NOVARIANTS}; DVO: TDocVariantOptions{$endif}): boolean;
/// append the JSON value corresponding to this argument
// - includes a pending ','
procedure AddJSON(WR: TTextWriter; V: pointer;
ObjectOptions: TTextWriterWriteObjectOptions=[woDontStoreDefault]);
/// 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 will 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 will 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 will be translated to strings (also in embedded
// objects and T*ObjArray)
procedure FixValueAndAddToObject(const Value: variant; var DestDoc: TDocVariantData);
{$endif}
end;
/// pointer to a service provider method argument
PServiceMethodArgument = ^TServiceMethodArgument;
/// 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 will 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
{$ifdef USERECORDWITHMETHODS}TServiceMethod = record
{$else}TServiceMethod = object{$endif}
public
/// the method URI, i.e. 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;
/// the directions of arguments with vIsSPI defined in Args[].ValueKindAsm
HasSPIParams: TServiceMethodValueDirections;
/// 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;
/// true if there is a single input parameter as RawByteString/TSQLRawBlob
// - TSQLRestRoutingREST.ExecuteSOAByInterface will identify binary input
// with mime-type 'application/octet-stream' as expected
ArgsInputIsOctetStream: 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;
/// convert parameters encoded as name=value or name='"value"' or name='{somejson}'
// into a JSON object
// - on Windows, use double-quotes ("") anywhere you expect single-quotes (")
// - as expected e.g. from a command line tool
// - if Input is TRUE, will handle const / var arguments
// - if Input is FALSE, will handle var / out / result arguments
function ArgsCommandLineToObject(P: PUTF8Char; Input: boolean;
RaiseExceptionOnUnknownParam: boolean=false): 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 will 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 will 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(TSQLRecordNoCaseExtended)
protected
fMethod: RawUTF8;
fInput: variant;
fOutput: variant;
fUser: integer;
fSession: integer;
fTime: TModTime;
fMicroSec: integer;
fIP: RawUTF8;
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;
/// if not localhost/127.0.0.1, the remote IP address
property IP: RawUTF8 read fIP write fIP;
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 will 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 will 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;
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;
fExecutedInstancesFailed: TRawUTF8DynArray;
procedure BeforeExecute;
procedure RawExecute(const Instances: PPointerArray; InstancesLast: integer); virtual;
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 will contain the execution data context when Hook is called
procedure AddInterceptor(const Hook: TServiceMethodExecuteEvent);
/// execute the corresponding method of weak IInvokable references
// - will retrieve a JSON array of parameters from Par (as [1,"par2",3])
// - 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
// - if one Instances[] is supplied, any exception will be propagated (unless
// optIgnoreException is set); if more than one Instances[] is supplied,
// corresponding ExecutedInstancesFailed[] property will be filled with
// the JSON serialized exception
function ExecuteJson(const Instances: array of pointer; Par: PUTF8Char;
Res: TTextWriter; Error: PShortString=nil; ResAsJSONObject: boolean=false): boolean;
/// execute the corresponding method of one weak IInvokable reference
// - exepect no output argument, i.e. no returned data, unless output is set
// - this version will identify TInterfacedObjectFake implementations,
// and will call directly fInvoke() if possible, to avoid JSON marshalling
// - expect params value to be without [ ], just like TOnFakeInstanceInvoke
function ExecuteJsonCallback(Instance: pointer; const params: RawUTF8;
output: PRawUTF8): boolean;
/// execute directly TInterfacedObjectFake.fInvoke()
// - expect params value to be with [ ], just like ExecuteJson
function ExecuteJsonFake(Instance: pointer; params: PUTF8Char): 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
// - contains a dvObject with output parameters as "argname":value pairs
// - this is a read-only property: you cannot change the output content
property Output: TDocVariantData read fOutput;
/// only set during AddInterceptor() callback execution, if 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;
/// contains exception serialization after ExecuteJson of multiple instances
// - follows the Instances[] order as supplied to RawExecute/ExecuteJson
// - if only a single Instances[] is supplied, the exception will be
// propagated to the caller, unless optIgnoreException option is defined
// - if more than one Instances[] is supplied, any raised Exception will
// be serialized using ObjectToJSONDebug(), or this property will be left
// to its default nil content if no exception occurred
property ExecutedInstancesFailed: TRawUTF8DynArray read fExecutedInstancesFailed;
/// allow to use an instance-specific temporary TJSONSerializer
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. JSON_CONTENT_TYPE_HEADER_VAR
// TEXT_CONTENT_TYPE_HEADER or BINARY_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 HTTP response code
// - if not overriden, will default to HTTP_SUCCESS = 200 on server side
// - on client side, will always contain HTTP_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 will 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: TInterfacedObjectClass); overload;
/// define a global instance for interface resolution
// - most of the time, you will 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 will 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 will 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 will 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 will 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
// - as called by TServiceFactoryServer.CreateInstance
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 will 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
/// initialize an instance, defining associated dependencies
// - the resolver may be e.g. a TServiceContainer
// - once the DI/IoC is defined, will call the AutoResolve() protected method
// - as called by TServiceFactoryServer.CreateInstance
constructor CreateWithResolverAndRest(aResolver: TInterfaceResolver;
aFactory: TServiceFactoryServer; aServer: TSQLRestServer;
aRaiseEServiceExceptionIfNotFound: boolean=true); virtual;
/// 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;
/// class-reference type (metaclass) of a TInjectableObjectRest type
TInjectableObjectRestClass = class of TInjectableObjectRest;
/// 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 will 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,
// without the [ ] characters (e.g. '1,"arg2",3')
// - 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
// - current implementation handles up to 128 methods, a limit above
// which "Interface Segregation" principles is obviously broken
TInterfaceFactoryMethodBits = set of 0..MAX_METHOD_COUNT-1;
/// 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;
fInterfaceURI: RawUTF8;
{$ifndef NOVARIANTS}
fDocVariantOptions: TDocVariantOptions;
{$endif}
fFakeVTable: array of pointer;
fFakeStub: PByteArray;
fMethodIndexCallbackReleased: Integer;
fMethodIndexCurrentFrameCallback: Integer;
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: TSynObjectListLocked;
/// add some TInterfaceFactory instances from their GUID
class procedure AddToObjArray(var Obj: TInterfaceFactoryObjArray;
const aGUIDs: array of TGUID);
/// register some TypeInfo() containing unsafe parameter values
// - i.e. any RTTI type containing Sensitive Personal Information, e.g.
// a bank card number or a plain password
// - such values will force associated values to be ignored during loging,
// as a more tuned alternative to optNoLogInput or optNoLogOutput
class procedure RegisterUnsafeSPIType(const Types: array of pointer);
/// 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 will try with a
// trailing underscore, so that e.g. /service/start will match IService._Start()
function FindMethodIndex(const aMethodName: RawUTF8): integer;
/// find a particular method in internal Methods[] list
// - just a wrapper around FindMethodIndex() returing a PServiceMethod
// - will return nil if the method is not known
function FindMethod(const aMethodName: RawUTF8): PServiceMethod;
/// 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;
/// the interface name, without its initial 'I'
// - e.g. ICalculator -> 'Calculator'
property InterfaceURI: RawUTF8 read fInterfaceURI write fInterfaceURI;
{$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 will perform its execution
// - by default, fInvoke() will receive standard JSON content, unless
// ifoJsonAsExtended is set, and extended JSON is used
// - ifoDontStoreVoidJSON will ensure objects and records won't include
// default void fields in JSON serialization
TInterfacedObjectFromFactoryOption = (ifoJsonAsExtended, ifoDontStoreVoidJSON);
/// defines how TInterfacedObjectFromFactory will 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 oldest FPC, which did 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 will be available
class procedure RegisterInterface(aInterface: PTypeInfo); virtual;
end;
/// abstract parameters used by TInterfaceStub.Executes() events callbacks
TOnInterfaceStubExecuteParamsAbstract = class
protected
fSender: TInterfaceStub;
fMethod: PServiceMethod;
fParams: RawUTF8;
fEventParams: RawUTF8;
fResult: RawUTF8;
fFailed: boolean;
function GetSenderAsMockTestCase: TSynTestCase;
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)
protected
fInput: TVariantDynArray;
fOutput: TVariantDynArray;
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);
function GetInUTF8(const ParamName: RawUTF8): RawUTF8;
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;
{$ifdef WITHLOG}
/// log the input or output parameters to a log instance
procedure AddLog(aLog: TSynLogClass; aOutput: boolean; aLevel: TSynLogInfo=sllTrace);
{$endif}
/// 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 will 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 will be used
property Named[const ParamName: RawUTF8]: variant read GetInNamed write SetOutNamed; default;
/// access to UTF-8 input 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)
// - slightly easier to use Ctxt.UTF8['str'] than ToUTF8(Ctxt.Named['str'])
property UTF8[const ParamName: RawUTF8]: RawUTF8 read GetInUTF8;
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
{$ifdef USERECORDWITHMETHODS}TInterfaceStubRules = record
{$else}TInterfaceStubRules = object{$endif}
public
/// 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
{$ifdef USERECORDWITHMETHODS}TInterfaceStubLog = record
{$else}TInterfaceStubLog = object{$endif}
public
/// 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, as JSON CSV (i.e. array without [ ])
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 if CustomResults=''
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);
public
/// low-level internal constructor
// - you should not call this method, but the overloaded alternatives
constructor Create(aFactory: TInterfaceFactory;
const aInterfaceName: RawUTF8); reintroduce; overload; virtual;
/// 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
// will 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 will 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 will 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;
public
/// this will set and force imoLogMethodCallsAndResults option as needed
// - you should not call this method, but the overloaded alternatives
constructor Create(aFactory: TInterfaceFactory;
const aInterfaceName: RawUTF8); override;
/// 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;
/// union of all fExecution[].Options
fAnyOptions: TServiceMethodOptions;
procedure ExecutionAction(const aMethod: array of RawUTF8;
aOptions: TServiceMethodOptions; aAction: TServiceMethodOptionsAction);
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
{$ifdef USERECORDWITHMETHODS}TServiceFactoryServerInstance = record
{$else}TServiceFactoryServerInstance = object{$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() timestamp corresponding to the last access of
// this instance
LastAccess64: Int64;
/// the associated client session
Session: cardinal;
/// 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
// to identify the executed method context
// - Method parameter will help identify easily the corresponding method, and
// will contain in fact PServiceMethod(Ctxt.ServiceMethod)^
// - 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',HTTP_NOTALLOWED);
// - i.e. called by TSQLRestServerURIContext.InternalExecuteSOAByInterface
TOnServiceCanExecute = function(Ctxt: TSQLRestServerURIContext;
const Method: TServiceMethod): boolean of object;
/// callbacked used by TServiceFactoryServer.RunOnAllInstances method
TOnServiceFactoryServerOne = function(Sender: TServiceFactoryServer;
var Instance: TServiceFactoryServerInstance; var Opaque): integer 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;
fInstanceCapacity: integer; // some void entries may have P^.InstanceID=0
fInstanceCount: 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;
fExcludeServiceLogCustomAnswer: boolean;
fBackgroundThread: TSynBackgroundThreadMethod;
fOnMethodExecute: TOnServiceCanExecute;
fOnExecute: array of TServiceMethodExecuteEvent;
procedure SetServiceLogByIndex(const aMethods: TInterfaceFactoryMethodBits;
aLogRest: TSQLRest; aLogClass: TSQLRecordServiceLogClass);
procedure SetTimeoutSecInt(value: cardinal);
function GetTimeoutSec: cardinal;
function GetStat(const aMethod: RawUTF8): TSynMonitorInputOutput;
// from client CacheFlush/_ping_
function RenewSession(aSession: cardinal): integer;
/// get an implementation Inst.Instance for the given Inst.InstanceID
// - is called by ExecuteMethod() in sicClientDrive mode
// - returns -1 on error, or aMethodIndex for successfull execution,
// e.g. 0 after {"method":"_free_".. call
// - otherwise, fill Inst.Instance with the matching implementation (or nil)
function InternalInstanceRetrieve(var Inst: TServiceFactoryServerInstance;
aMethodIndex,aSession: integer): integer;
/// call a given method of this service provider
// - here Ctxt.ServiceMethod points to the corresponding fInterface.Methods[]
// (i.e. excluding _free_/_contract_/_signature_ pseudo-methods)
// - Ctxt.ServiceMethodIndex=0=ord(imFree) will free/release
// the corresponding aInstanceID - as 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/HTTP_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; aSharedInstance: TInterfacedObject); 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;
aAction: TServiceMethodOptionsAction=moaReplace): 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 will 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 will be called directly
// before and after method execution
// - if optInterceptInputOutput is defined in Options, then Sender.Input/Output
// fields will 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 will 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;
/// call the supplied aEvent callback for all class instances implementing
// this service
function RunOnAllInstances(const aEvent: TOnServiceFactoryServerOne;
var aOpaque): integer;
/// 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
// - on client side, consider using TSQLRestClientURI.ServiceDefineSharedAPI
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 will be appended - but such rough XML will
// 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;
/// disable base64-encoded TSQLRecordServiceLog.Output for methods
// returning TServiceCustomAnswer record (to reduce storage size)
property ExcludeServiceLogCustomAnswer: boolean read fExcludeServiceLogCustomAnswer
write fExcludeServiceLogCustomAnswer;
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;
fDelayedInstance: boolean;
fNonBlockWithoutAnswer: 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
// - will recognize the HTTP_UNAVAILABLE, HTTP_NOTIMPLEMENTED, HTTP_NOTFOUND,
// HTTP_NOTALLOWED, HTTP_UNAUTHORIZED or HTTP_NOTACCEPTABLE errors, as
// generated by the TSQLRestServer side
// - is used by TServiceFactoryClient.InternalInvoke, but may be called
// on client side for TServiceCustomAnswer.Status <> HTTP_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,
// by design of "fake" interface remote execution
procedure SetOptions(const aMethod: array of RawUTF8; aOptions: TServiceMethodOptions;
aAction: TServiceMethodOptionsAction=moaReplace);
/// persist all service calls into a database instead of calling the client
// - expect a REST instance, which will 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 will 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
// - will call StoreNotifications() and start background notification
// - expect a REST instance, which will store all methods without any
// results (i.e. procedure without any var/out parameters) on the
// associated TSQLRecordServiceNotifications class
// - a background thread will 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 will write the pending calls to
// the aRest/aLogClass table, which will 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 will take place
procedure SendNotificationsWait(aTimeOutSeconds: integer);
published
/// could be used to force the remote URI to access the service
// - by default, the URI will 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, or when the mORMot server exposes a public API
// - defined e.g. by TSQLRestClientURI.ServiceDefineSharedAPI() method
property ParamsAsJSONObject: boolean read fParamsAsJSONObject write fParamsAsJSONObject;
/// set to TRUE if the interface's methods result is expected 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 or any public API
// - this value can be overridden by setting ForceServiceResultAsJSONObject
// for a given TSQLRestServerURIContext (e.g. for server-side JavaScript work)
// - defined e.g. by TSQLRestClientURI.ServiceDefineSharedAPI() method
property ResultAsJSONObjectWithoutResult: boolean read fResultAsJSONObject
write fResultAsJSONObject;
/// delay the sicClientDriven server-side instance to the first method call
// - by default, CreateFakeInstance will call _instance_ server pseudo-method
// to ensure a fClientDrivenID is safely and properly initialized
// - if you are sure that your client's interface variables will be thread-safe,
// you may define this property to TRUE so that the "id" field as returned
// at first method call will be used - makes sense only if a lot of short-live
// interface instances are expected to be generated by the client
property DelayedInstance: boolean read fDelayedInstance write fDelayedInstance;
/// if methods expecting no result (i.e. plain procedure without var/out
// parameters) should not block the client waiting for answer
// - may be handy e.g. when consuming an event-driven asynchronous service
// - will call CallbackNonBlockingSetHeader, currently implemented only in
// TSQLHttpClientWebsockets, with frame gathering
property NonBlockWithoutAnswer: boolean read fNonBlockWithoutAnswer write fNonBlockWithoutAnswer;
end;
/// class-reference type (metaclass) of a TServiceFactoryClient kind
TServiceFactoryClientClass = class of TServiceFactoryClient;
/// used to lookup one service in a global list of interface-based services
TServiceContainerInterface = record
/// one 'service' item, as set at URI, e.g. 'Calculator'
InterfaceName: RawUTF8;
/// the associated service provider
Service: TServiceFactory;
end;
/// pointer to one lookup in a global list of interface-based services
PServiceContainerInterface = ^TServiceContainerInterface;
/// used to store all s in a global list of interface-based services
TServiceContainerInterfaces = array of TServiceContainerInterface;
/// 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 services ['Calculator',...]
fInterface: TServiceContainerInterfaces;
fInterfaces: TDynArrayHashed;
// list of service.method ['Calculator.Add','Calculator.Multiply',...]
fInterfaceMethod: TServiceContainerInterfaceMethods;
fInterfaceMethods: TDynArrayHashed;
fExpectMangledURI: boolean;
fServicesFactoryClients: TServiceFactoryClientClass;
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); virtual;
/// release all registered services
destructor Destroy; override;
/// release all services of a TSQLRest instance before shutdown
// - will allow to properly release any pending callbacks
// - TSQLRest.Services.Release will call FreeAndNil(fServices)
procedure Release;
/// return the number of registered service interfaces
function Count: integer; {$ifdef HASINLINE}inline;{$endif}
/// 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 will
// 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;
/// the services factory client classes
// - by default, will use TServiceFactoryClient
property ServicesFactoryClients: TServiceFactoryClientClass read fServicesFactoryClients write fServicesFactoryClients;
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 will 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 will 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 will 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: TSynObjectListLocked; // TInterfacedObjectFakeServer instances
fOnCallbackReleasedOnClientSide: TOnCallbackReleased;
fOnCallbackReleasedOnServerSide: TOnCallbackReleased;
fCallbackOptions: TServiceCallbackOptions;
fRecordVersionCallback: array of IServiceRecordVersionCallbackDynArray;
fSessionTimeout: cardinal;
/// 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
// - can optionally append the callback class instance information to
// a local shortstring variable, e.g. for logging/debug purposes
class function CallbackReleasedOnClientSide(const callback: IInterface;
callbacktext: PShortString=nil): boolean; overload;
/// 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;
/// initialize the list
constructor Create(aRest: TSQLRest); override;
/// 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 will 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;
/// the default TServiceFactoryServer.TimeoutSec value
// - default is 30 minutes
// - you can customize each service using its corresponding TimeoutSec property
property SessionTimeout: cardinal read fSessionTimeout write fSessionTimeout;
/// 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 will 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 will notify a REST server when it is released
// - could be used when implementing event callbacks as interfaces, so that
// the other side instance will 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
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 will 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 will block via a WaitFor call, which will 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 will be used)
// - you can optionally set a REST and callback interface for automatic
// notification when this TInterfacedCallback will 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
// - will 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 will 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
// - will 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;
/// prototype of a class implementing redirection of a given interface
// - as returned e.g. by TSQLRest.MultiRedirect method
// - can be used as a main callback, then call Redirect() to manage
// an internal list of redirections
// - when you release this instance, will call Rest.Service.CallbackUnregister
// with the associated fake callback generated
IMultiCallbackRedirect = interface
['{E803A30A-8C06-4BB9-94E6-EB87EACFE980}']
/// add or remove an interface callback to the internal redirection list
// - will register a callback if aSubscribe is true
// - will unregister a callback if aSubscribe is false
// - supplied aCallback shoud implement the expected interface GUID
// - this method will be implemented as thread-safe
// - you can specify some method names, or all methods redirection if []
procedure Redirect(const aCallback: IInvokable;
const aMethodsNames: array of RawUTF8; aSubscribe: boolean=true); overload;
/// add or remove a class instance callback to the internal redirection list
// - will register a callback if aSubscribe is true
// - will unregister a callback if aSubscribe is false
// - supplied aCallback instance should implement the expected interface GUID
// - this method will be implemented as thread-safe
// - you can specify some method names, or all methods redirection if []
procedure Redirect(const aCallback: TInterfacedObject;
const aMethodsNames: array of RawUTF8; aSubscribe: boolean=true); overload;
end;
/// for TSQLRestCache, stores a table values
TSQLRestCacheEntryValue = packed record
/// corresponding ID
ID: TID;
/// GetTickCount64 shr 9 timestamp when this cached value was stored
// - resulting time period has therefore a resolution of 512 ms, and
// overflows after 70 years without computer reboot
// - equals 0 when there is no JSON value cached
Timestamp512: cardinal;
/// some associated unsigned integer value
// - not used by TSQLRestCache, but available at TSQLRestCacheEntry level
Tag: cardinal;
/// JSON encoded UTF-8 serialization of the record
JSON: RawUTF8;
end;
/// for TSQLRestCache, stores all tables values
TSQLRestCacheEntryValueDynArray = array of TSQLRestCacheEntryValue;
/// for TSQLRestCache, stores a table settings and values
{$ifdef USERECORDWITHMETHODS}TSQLRestCacheEntry = record
{$else}TSQLRestCacheEntry = object{$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; aTag: cardinal=0); 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; aTag: PCardinal=nil): boolean; overload;
/// unserialize a JSON cached record of a given ID
function RetrieveJSON(aID: TID; aValue: TSQLRecord; aTag: PCardinal=nil): boolean; overload;
/// compute how much memory stored entries are using
// - will also flush outdated entries
function CachedMemory(FlushedEntriesCount: PInteger=nil): cardinal;
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 into 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: integer; 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;
// - will fill the internal JSON cache of a given Table with data coming
// from a REST query
// - returns the number of TSQLRecord items actually cached
// - may be handy to pre-load a set of values (e.g. a lookup table) from a
// single REST query, without waiting for each record to be retrieved
function FillFromQuery(aTable: TSQLRecordClass; const FormatSQLWhere: RawUTF8;
const BoundsSQLWhere: array of const): integer;
/// 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
// - actual resolution is 512 ms
// - 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: integer; aID: TID); overload;
/// TSQLRest instance shall call this method when records are deleted
// - TSQLRecordClass to be specified as its index in Rest.Model.Tables[]
procedure NotifyDeletions(aTableIndex: integer; const aIDs: array of Int64); 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, owning the instances
TSQLRestObjArray = array of TSQLRest;
/// used to store the execution parameters for a TSQLRest instance
TSQLRestAcquireExecution = class(TSynPersistentLock)
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;
/// optionally called after TSQLRest.AsynchRedirect background execution
// - to retrieve any output result value, as JSON-encoded content
// - as used in TSQLRestBackgroundTimer.AsynchBackgroundExecute protected method
TOnAsynchRedirectResult = procedure(const aMethod: TServiceMethod;
const aInstance: IInvokable; const aParams, aResult: RawUTF8) of object;
/// TThread able to run one or several tasks at a periodic pace, or do
// asynchronous interface or batch execution, with proper TSQLRest integration
// - used e.g. by TSQLRest.TimerEnable/AsynchRedirect/AsynchBatchStart methods
// - TSQLRest.BackgroundTimer will define one instance, but you may create
// other dedicated instances to instantiate separated threads
TSQLRestBackgroundTimer = class(TSynBackgroundTimer)
protected
fRest: TSQLRest;
fBackgroundBatch: array of TSQLRestBatchLocked;
fBackgroundInterning: array of TRawUTF8Interning;
fBackgroundInterningMaxRefCount: integer;
// used by AsynchRedirect() and AsynchBatch()
function AsynchBatchIndex(aTable: TSQLRecordClass): integer;
function AsynchBatchLocked(aTable: TSQLRecordClass; out aBatch: TSQLRestBatchLocked): boolean;
procedure AsynchBatchUnLock(aBatch: TSQLRestBatchLocked);
procedure AsynchBatchExecute(Sender: TSynBackgroundTimer;
Event: TWaitResult; const Msg: RawUTF8);
procedure AsynchBackgroundExecute(Sender: TSynBackgroundTimer;
Event: TWaitResult; const Msg: RawUTF8);
procedure AsynchBackgroundInterning(Sender: TSynBackgroundTimer;
Event: TWaitResult; const Msg: RawUTF8);
public
/// initialize the thread for a periodic task processing
constructor Create(aRest: TSQLRest; const aThreadName: RawUTF8='';
aStats: TSynMonitorClass=nil); reintroduce; virtual;
/// finalize the thread
destructor Destroy; override;
/// define asynchronous execution of interface methods in a background thread
// - this method implements any interface via a fake class, which will
// redirect all methods calls into calls of another interface, but as a FIFO
// in a background thread, shared with TimerEnable/TimerDisable process
// - parameters will be serialized and stored as JSON in the queue
// - by design, only procedure methods without any output parameters are
// allowed, since their execution will take place asynchronously
// - of course, a slight delay is introduced in aDestinationInterface
// methods execution, but the main process thread is not delayed any more,
// and is free from potential race conditions
// - the returned fake aCallbackInterface should be freed before TSQLRest
// is destroyed, to release the redirection resources
// - it is an elegant resolution to the most difficult implementation
// problem of SOA callbacks, which is to avoid race condition on reentrance,
// e.g. if a callback is run from a thread, and then the callback code try
// to execute something in the context of the initial thread, protected
// by a critical section (mutex)
procedure AsynchRedirect(const aGUID: TGUID;
const aDestinationInterface: IInvokable; out aCallbackInterface;
const aOnResult: TOnAsynchRedirectResult=nil); overload;
/// define asynchronous execution of interface methods in a background thread
// - this method implements any interface via a fake class, which will
// redirect all methods calls into calls of another interface, but as a FIFO
// in a background thread, shared with TimerEnable/TimerDisable process
// - parameters will be serialized and stored as JSON in the queue
// - by design, only procedure methods without any output parameters are
// allowed, since their execution will take place asynchronously
// - of course, a slight delay is introduced in aDestinationInterface
// methods execution, but the main process thread is not delayed any more,
// and is free from potential race conditions
// - the returned fake aCallbackInterface should be freed before TSQLRest
// is destroyed, to release the redirection resources
// - it is an elegant resolution to the most difficult implementation
// problem of SOA callbacks, which is to avoid race condition on reentrance,
// e.g. if a callback is run from a thread, and then the callback code try
// to execute something in the context of the initial thread, protected
// by a critical section (mutex)
procedure AsynchRedirect(const aGUID: TGUID;
const aDestinationInstance: TInterfacedObject; out aCallbackInterface;
const aOnResult: TOnAsynchRedirectResult=nil); overload;
/// prepare an asynchronous ORM BATCH process, executed in a background thread
// - will initialize a TSQLRestBatch and call TimerEnable to initialize the
// background thread, following the given processing period (in seconds),
// or the TSQLRestBatch.Count threshold to call BatchSend
// - actual REST/CRUD commands will take place via AsynchBatchAdd,
// AsynchBatchUpdate and AsynchBatchDelete methods
// - only a single AsynchBatch() call per Table is allowed at a time, unless
// AsynchBatchStop method is used to flush the current asynchronous BATCH
// - using a BATCH in a dedicated thread will allow very fast bacgkround
// asynchronous process of ORM methods, sufficient for most use cases
function AsynchBatchStart(Table: TSQLRecordClass; SendSeconds: integer;
PendingRowThreshold: integer=500; AutomaticTransactionPerRow: integer=1000;
Options: TSQLRestBatchOptions=[boExtendedJSON]): boolean;
/// finalize asynchronous ORM BATCH process, executed in a background thread
// - should have been preceded by a call to AsynchBatch(), or returns false
// - Table=nil will release all existing batch instances
function AsynchBatchStop(Table: TSQLRecordClass): boolean;
/// create a new ORM member in a BATCH to be written in a background thread
// - should have been preceded by a call to AsynchBatchStart(), or returns -1
// - is a wrapper around TSQLRestBatch.Add() sent in the Timer thread,
// so will return the index in the BATCH rows, not the created TID
// - this method is thread-safe
function AsynchBatchAdd(Value: TSQLRecord; SendData: boolean;
ForceID: boolean=false; const CustomFields: TSQLFieldBits=[];
DoNotAutoComputeFields: boolean=false): integer;
/// append some JSON content in a BATCH to be writen in a background thread
// - could be used to emulate AsynchBatchAdd() with an already pre-computed
// JSON object
// - is a wrapper around TSQLRestBatch.RawAdd() sent in the Timer thread,
// so will return the index in the BATCH rows, not the created TID
// - this method is thread-safe
function AsynchBatchRawAdd(Table: TSQLRecordClass; const SentData: RawUTF8): integer;
/// append some JSON content in a BATCH to be writen in a background thread
// - could be used to emulate AsynchBatchAdd() with an already pre-computed
// JSON object, as stored in a TTextWriter instance
// - is a wrapper around TSQLRestBatch.RawAppend.AddNoJSONEscape(SentData)
// in the Timer thread
// - this method is thread-safe
procedure AsynchBatchRawAppend(Table: TSQLRecordClass; SentData: TTextWriter);
/// update an ORM member in a BATCH to be written in a background thread
// - should have been preceded by a call to AsynchBatchStart(), or returns -1
// - is a wrapper around the TSQLRestBatch.Update() sent in the Timer thread
// - this method is thread-safe
function AsynchBatchUpdate(Value: TSQLRecord; const CustomFields: TSQLFieldBits=[];
DoNotAutoComputeFields: boolean=false): integer;
/// delete an ORM member in a BATCH to be written in a background thread
// - should have been preceded by a call to AsynchBatchStart(), or returns -1
// - is a wrapper around the TSQLRestBatch.Delete() sent in the Timer thread
// - this method is thread-safe
function AsynchBatchDelete(Table: TSQLRecordClass; ID: TID): integer;
/// allows background garbage collection of specified RawUTF8 interning
// - will run Interning.Clean(2) every 5 minutes by default
// - set InterningMaxRefCount=0 to disable process of the Interning instance
procedure AsynchInterning(Interning: TRawUTF8Interning;
InterningMaxRefCount: integer=2; PeriodMinutes: integer=5);
published
/// the identifier of the thread, as logged
property Name: RawUTF8 read fThreadName;
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;
fServicesRouting: TSQLRestServerURIContextClass;
fBackgroundTimer: TSQLRestBackgroundTimer;
fOnDecryptBody, fOnEncryptBody: TNotifyRestBody;
fCustomEncryptAES: TAESAbstract;
fCustomEncryptSign: TSynSigner;
fCustomEncryptCompress: TAlgoCompress;
fCustomEncryptContentPrefix, fCustomEncryptContentPrefixUpper, fCustomEncryptUrlIgnore: RawUTF8;
fAcquireExecution: array[TSQLRestServerURIContextCommand] of TSQLRestAcquireExecution;
fPrivateGarbageCollector: TSynObjectList;
{$ifdef WITHLOG}
fLogClass: TSynLogClass; // =SQLite3Log by default
fLogFamily: TSynLogFamily; // =SQLite3Log.Family by default
procedure SetLogClass(aClass: TSynLogClass); virtual;
function GetLogClass: TSynLogClass;
{$endif}
procedure InternalCustomEncrypt(Sender: TSQLRest; var Body,Head,Url: RawUTF8);
procedure InternalCustomDecrypt(Sender: TSQLRest; var Body,Head,Url: RawUTF8);
function EnsureBackgroundTimerExists: TSQLRestBackgroundTimer;
/// 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=sllTrace); 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
// - warning: supplied JSON Data can be parsed in-place, so modified
function EngineBatchSend(Table: TSQLRecordClass; var 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: TSynObjectList 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; virtual;
/// 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 Int64 value of an unique field with a Where Clause
// - call internaly ExecuteList() to get the value
function OneFieldValueInt64(Table: TSQLRecordClass;
const FieldName, WhereClause: RawUTF8; Default: Int64=0): Int64;
/// 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 works for TSQLRecordFTS3, TSQLRecordFTS4 and TSQLRecordFTS5
// - 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 works for TSQLRecordFTS3, TSQLRecordFTS4 and TSQLRecordFTS5
// - 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 will be the fastest, but complex
// types like dynamic array will 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 will be the fastest, but complex
// types like dynamic array will 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 will be returned
// as a true array of values (in contrast to the RetrieveListJSON method)
// - warning: under FPC, we observed that assigning the result of this
// method to a local variable may circumvent a memory leak FPC bug
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 will be returned
// as a true array of values (in contrast to the RetrieveListJSON method)
// - warning: under FPC, we observed that assigning the result of this
// method to a local variable may circumvent a memory leak FPC bug
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 will 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 will 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='');
/// 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
// - as alternative, with SQLite3 >= 3.24.0, you may use Auxiliary Columns
// - 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;
/// 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;
ForceAJAX: Boolean=false; ReturnedRowCount: PPtrInt=nil): 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 FPC}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 FPC}inline;{$endif}
/// create a new member, including its BLOB fields
// - implements REST POST collection
// - this method will create a JSON representation of the document
// including the BLOB fields as Base64 encoded text, so will 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 AddSimple(aTable: TSQLRecordClass; const aSimpleFields: array of const;
ForcedID: TID=0): TID;
/// 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(); but
// it will notify the internal Cache
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(); but
// it will notify the internal Cache
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(); but
// it will notify the internal Cache
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, nor the
// internal table Cache: you should rather use a classic Retrieve()/FillPrepare()
// followed by an Update() of the whole record
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 will be much slower, even over a BATCH; anyway, it will update the
// internal Cache
// - will be executed as a regular SQL statement:
// $ UPDATE table SET fieldname=fieldvalue WHERE RowID IN (...)
// - warning: this method will call directly EngineExecute(), and will
// 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 into 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
// - will 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 will 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/HTTP_SUCCESS OK on success
// - a dynamic array of integers will be created in Results,
// containing all ROWDID created for each BatchAdd call, 200 (=HTTP_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),
// or boRollbackOnError should be set in TSQLRestBatchOptions
// - 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/2010 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 ISDELPHI2010}
/// you can call this method in TThread.Execute to ensure that
// the thread will be taken into 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 will do the main process
procedure EndCurrentThread(Sender: TThread); virtual;
/// enter the Mutex associated with the write operations of this instance
// - just a wrapper around fAcquireExecution[execORMWrite].Safe.Lock
procedure WriteLock;
/// leave the Mutex associated with the write operations of this instance
// - just a wrapper around fAcquireExecution[execORMWrite].Safe.UnLock
procedure WriteUnLock;
/// 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;
/// allows to safely execute a process in parallel
// - returns a TSynParallelProcess instance, ready to execute any task
// in parrallel in a thread-pool given by ThreadCount
// - will properly call BeginCurrentThread/EndCurrentThread methods
// - you should supply some runtime information to name the thread, for
// proper debugging
function NewParallelProcess(ThreadCount: integer; const Format: RawUTF8;
const Args: array of const): TSynParallelProcess;
/// define a task running on a periodic number of seconds in a background thread
// - could be used to run background maintenance or monitoring tasks on
// this TSQLRest instance, at a low pace (typically every few minutes)
// - will instantiate and run a shared TSynBackgroundTimer instance for this
// TSQLRest, so all tasks will share the very same thread
// - you can run BackgroundTimer.EnQueue or ExecuteNow methods to implement
// a FIFO queue, or force immediate execution of the process
// - will call BeginCurrentThread/EndCurrentThread as expected e.g. by logs
function TimerEnable(aOnProcess: TOnSynBackgroundTimerProcess;
aOnProcessSecs: cardinal): TSynBackgroundTimer;
/// undefine a task running on a periodic number of seconds
// - should have been registered by a previous call to TimerEnable() method
// - returns true on success, false if the supplied task was not registered
function TimerDisable(aOnProcess: TOnSynBackgroundTimerProcess): boolean;
/// define asynchronous execution of interface methods in a background thread
// - this class allows to implements any interface via a fake class, which will
// redirect all methods calls into calls of another interface, but as a FIFO
// in a background thread, shared with TimerEnable/TimerDisable process
// - it is an elegant resolution to the most difficult implementation
// problem of SOA callbacks, which is to avoid race condition on reentrance,
// e.g. if a callback is run from a thread, and then the callback code try
// to execute something in the context of the initial thread, protected
// by a critical section (mutex)
// - is a wrapper around BackgroundTimer.AsynchRedirect()
procedure AsynchRedirect(const aGUID: TGUID;
const aDestinationInterface: IInvokable; out aCallbackInterface;
const aOnResult: TOnAsynchRedirectResult=nil); overload;
/// define asynchronous execution of interface methods in a background thread
// - this class allows to implements any interface via a fake class, which will
// redirect all methods calls into calls of another interface, but as a FIFO
// in a background thread, shared with TimerEnable/TimerDisable process
// - it is an elegant resolution to the most difficult implementation
// problem of SOA callbacks, which is to avoid race condition on reentrance,
// e.g. if a callback is run from a thread, and then the callback code try
// to execute something in the context of the initial thread, protected
// by a critical section (mutex)
// - is a wrapper around BackgroundTimer.AsynchRedirect()
procedure AsynchRedirect(const aGUID: TGUID;
const aDestinationInstance: TInterfacedObject; out aCallbackInterface;
const aOnResult: TOnAsynchRedirectResult=nil); overload;
/// prepare an asynchronous ORM BATCH process, executed in a background thread
// - will initialize a TSQLRestBatch and call TimerEnable to initialize the
// background thread, following the given processing period (in seconds),
// or the TSQLRestBatch.Count threshold to call BatchSend
// - actual REST/CRUD commands will take place via AsynchBatchAdd,
// AsynchBatchUpdate and AsynchBatchDelete methods
// - only a single AsynchBatch() call per Table is allowed at a time, unless
// AsynchBatchStop method is used to flush the current asynchronous BATCH
// - using a BATCH in a dedicated thread will allow very fast bacgkround
// asynchronous process of ORM methods, sufficient for most use cases
// - is a wrapper around BackgroundTimer.AsynchBatchStart()
function AsynchBatchStart(Table: TSQLRecordClass; SendSeconds: integer;
PendingRowThreshold: integer=500; AutomaticTransactionPerRow: integer=1000;
Options: TSQLRestBatchOptions=[boExtendedJSON]): boolean;
/// finalize asynchronous ORM BATCH process, executed in a background thread
// - should have been preceded by a call to AsynchBatch(), or returns false
// - Table=nil will release all existing batch instances
// - is a wrapper around BackgroundTimer.AsynchBatchStop()
function AsynchBatchStop(Table: TSQLRecordClass): boolean;
/// create a new ORM member in a BATCH to be written in a background thread
// - should have been preceded by a call to AsynchBatchStart(), or returns -1
// - is a wrapper around BackgroundTimer.AsynchBatchAdd(),
// so will return the index in the BATCH rows, not the created TID
// - this method is thread-safe
function AsynchBatchAdd(Value: TSQLRecord; SendData: boolean;
ForceID: boolean=false; const CustomFields: TSQLFieldBits=[];
DoNotAutoComputeFields: boolean=false): integer;
/// append some JSON content in a BATCH to be written in a background thread
// - could be used to emulate AsynchBatchAdd() with an already pre-computed
// JSON object
// - is a wrapper around BackgroundTimer.AsynchBatchRawAdd(),
// so will return the index in the BATCH rows, not the created TID
// - this method is thread-safe
function AsynchBatchRawAdd(Table: TSQLRecordClass; const SentData: RawUTF8): integer;
/// append some JSON content in a BATCH to be writen in a background thread
// - could be used to emulate AsynchBatchAdd() with an already pre-computed
// JSON object, as stored in a TTextWriter instance
// - is a wrapper around BackgroundTimer.AsynchBatchRawAppend()
// - this method is thread-safe
procedure AsynchBatchRawAppend(Table: TSQLRecordClass; SentData: TTextWriter);
/// update an ORM member in a BATCH to be written in a background thread
// - should have been preceded by a call to AsynchBatchStart(), or returns -1
// - is a wrapper around BackgroundTimer.AsynchBatchUpdate()
// - this method is thread-safe
function AsynchBatchUpdate(Value: TSQLRecord; const CustomFields: TSQLFieldBits=[];
DoNotAutoComputeFields: boolean=false): integer;
/// delete an ORM member in a BATCH to be written in a background thread
// - should have been preceded by a call to AsynchBatchStart(), or returns -1
// - is a wrapper around the TSQLRestBatch.Delete() sent in the Timer thread
// - this method is thread-safe
function AsynchBatchDelete(Table: TSQLRecordClass; ID: TID): integer;
/// allows background garbage collection of specified RawUTF8 interning
// - will run Interning.Clean(2) every 5 minutes by default
// - set InterningMaxRefCount=0 to disable process of the Interning instance
// - note that InterningMaxRefCount and PeriodMinutes parameters (if not 0),
// are common for all TRawUTF8Interning instances (the latest value wins)
// - you may e.g. run the following to clean up TDocVariant interned RawUTF8:
// ! aRest.AsynchInterning(DocVariantType.InternNames);
// ! aRest.AsynchInterning(DocVariantType.InternValues);
procedure AsynchInterning(Interning: TRawUTF8Interning;
InterningMaxRefCount: integer=2; PeriodMinutes: integer=5);
/// define redirection of interface methods calls in one or several instances
// - this class allows to implements any interface via a fake class, which
// will redirect all methods calls to one or several other interfaces
// - returned aCallbackInterface will redirect all its methods (identified
// by aGUID) into an internal list handled by IMultiCallbackRedirect.Redirect
// - typical use is thefore:
// ! fSharedCallback: IMyService;
// ! fSharedCallbacks: IMultiCallbackRedirect;
// ! ...
// ! if fSharedCallbacks=nil then begin
// ! fSharedCallbacks := aRest.MultiRedirect(IMyService,fSharedCallback);
// ! aServices.SubscribeForEvents(fSharedCallback);
// ! end;
// ! fSharedCallbacks.Redirect(TMyCallback.Create,[]);
// ! // now each time fSharedCallback receive one event, all callbacks
// ! // previously registered via Redirect() will receive it
// ! ...
// ! fSharedCallbacks := nil; // will stop redirection
// ! // and unregister callbacks, if needed
function MultiRedirect(const aGUID: TGUID; out aCallbackInterface;
aCallBackUnRegisterNeeded: boolean=true): IMultiCallbackRedirect; overload;
/// will gather CPU and RAM information in a background thread
// - you can specify the update frequency, in seconds
// - access to the information via the returned instance, which maps
// the TSystemUse.Current class function
// - do nothing if global TSystemUse.Current was already assigned
function SystemUseTrack(periodSec: integer=10): TSystemUse;
/// initialize some custom AES encryption and/or digital signature, with
// optional compression
// - will intercept the calls by setting OnDecryptBody/OnEncryptBody events
// - will own the supplied aes instance or won't encrypt the content if nil
// - will digitally sign the content body and uri with the supplied
// TSynSigner, or won't compute any digital signature if sign=nil
// - if both aes and sign are nil, then call interception is disabled
// - you can optionally specify a compression algorithm (like AlgoSynLZ or
// AlgoDeflate/AlgoDeflateFast) to be applied before encryption
// - any URI starting with uriignore characters won't be encrypted: it could
// be used to define a method-based service for handshake and aes/sign
// mutual agreement
// - TSQLRestServer will require incoming requests to be of the corresponding
// [aesclass][signalgo]/[originaltype] HTTP content-type e.g.
// 'aesofb256sha256/application/json' - any plain request will be rejected
// - note that it will only encrypt and sign the HTTP requests bodies, so URI
// or plain GET won't be checked - as such, it is not a replacement of
// TSQLRestServerAuthentication nor TWebSocketProtocolBinary encryption,
// but a cheap alternative to HTTPS, when you need to protect HTTP flow
// from MiM attacks (e.g. in a IoT context) with simple and proven algorithms
procedure SetCustomEncryption(aes: TAESAbstract; sign: PSynSigner; comp: TAlgoCompress;
const uriignore: RawUTF8='');
/// 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 5000, i.e. TSQLRestServer.URI will wait up to 5 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 will 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 will 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 will rather use JSON/RPC alternative pattern
// - NEVER set the abstract TSQLRestServerURIContext class on this property
property ServicesRouting: TSQLRestServerURIContextClass
read fServicesRouting write SetRoutingClass;
/// low-level background timer thread associated with this TSQLRest
// - contains nil if TimerEnable/AsynchInvoke was never executed
// - you may instantiate your own TSQLRestBackgroundTimer instances, if
// more than one working thread is needed
property BackgroundTimer: TSQLRestBackgroundTimer read fBackgroundTimer;
/// the Database Model associated with this REST Client or Server
property Model: TSQLModel read fModel;
/// event called before TSQLRestServer.URI or after TSQLRestClientURI.URI
// - defined e.g. by SetCustomEncryption
property OnDecryptBody: TNotifyRestBody read fOnDecryptBody write fOnDecryptBody;
/// event called after TSQLRestServer.URI or before TSQLRestClientURI.URI
// - defined e.g. by SetCustomEncryption
property OnEncryptBody: TNotifyRestBody read fOnEncryptBody write fOnEncryptBody;
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;
fEvent: TEvent;
fExecuting: boolean;
/// allows customization in overriden Create (before Execute)
fThreadName: RawUTF8;
/// 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 will 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}
{$ifdef HASTTHREADTERMINATESET}
/// properly terminate the thread
// - called by TThread.Terminate
procedure TerminatedSet; override;
{$else}
/// properly terminate the thread
// - called by reintroduced Terminate
procedure TerminatedSet; virtual;
/// reintroduced to call TeminatedSet
procedure Terminate; reintroduce;
{$endif}
/// wait for Execute to be ended (i.e. fExecuting=false)
procedure WaitForNotExecuting(maxMS: integer=500);
/// 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 will 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;
/// a event associated to this thread
property Event: TEvent read fEvent;
/// publishes the thread running state
property Terminated;
/// publishes the thread executing state (set when Execute leaves)
property Executing: boolean read fExecuting;
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}
TSQLRestServerNamedPipeResponse = class;
/// Server thread accepting connections from named pipes
TSQLRestServerNamedPipe = class(TSQLRestThread)
private
protected
fServer: TSQLRestServer;
fChild: array of TSQLRestServerNamedPipeResponse;
fChildRunning: integer;
fPipeName: TFileName;
procedure InternalExecute; override;
public
/// register a new response thread
procedure AddChild(new: TSQLRestServerNamedPipeResponse);
/// unregister a new response thread
procedure RemoveChild(new: TSQLRestServerNamedPipeResponse);
/// 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;
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.fChildRunning
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: RawUTF8;
/// parameter name used to specify the request sort direction
// - default value is 'DIR='
Dir: RawUTF8;
/// parameter name used to specify the request starting offset
// - default value is 'STARTINDEX='
StartIndex: RawUTF8;
/// parameter name used to specify the request the page size (LIMIT clause)
// - default value is 'RESULTS='
Results: RawUTF8;
/// parameter name used to specify the request field names
// - default value is 'SELECT='
Select: RawUTF8;
/// parameter name used to specify the request WHERE clause
// - default value is 'WHERE='
Where: RawUTF8;
/// 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 will 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;
{$ifndef NOVARIANTS}
/// callback allowing to customize the information returned by root/timestamp/info
TOnInternalInfo = procedure(Sender: TSQLRestServer; var info: TDocVariantData) of object;
{$endif}
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;
/// 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 will 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
// and use the much safer PBKDF2_HMAC_SHA256 algorithm
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 will 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 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;
fID: RawUTF8;
fIDCardinal: cardinal;
fTimeOutTix: cardinal;
fTimeOutShr10: cardinal;
fPrivateKey: RawUTF8;
fPrivateSalt: RawUTF8;
fSentHeaders: RawUTF8;
fRemoteIP: RawUTF8;
fPrivateSaltHash: Cardinal;
fLastTimestamp: Cardinal;
fExpectedHttpAuthentication: RawUTF8;
fAccessRights: TSQLAccessRights;
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; PEnd: 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 shr 10
// timestamp + TimeoutSecs
property TimeOutTix: cardinal read fTimeOutTix;
/// 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 timestamp (in numbers of 1024 ms) until a session is kept alive
// - extracted from User.TSQLAuthGroup.SessionTimeout
// - is used for fast comparison with GetTickCount64 shr 10
property TimeoutShr10: cardinal read fTimeOutShr10;
/// 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;
fAlgoName: RawUTF8;
// 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 will 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;
/// Ctxt.Returns(['result',result,....[,'data',data]],200,header);
procedure SessionCreateReturns(Ctxt: TSQLRestServerURIContext;
Session: TAuthSession; const result, data, header: RawUTF8);
/// 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, and
// fill Ctxt.Session* members according to in-memory session information
// - returns nil if this remote request does not match this authentication
// - method execution should be 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
// - method execution should be protected by TSQLRestServer.fSessions.Lock
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;
/// algorithms known by TSQLRestServerAuthenticationSignedURI to digitaly
// compute the session_signature parameter value for a given URI
// - by default, suaCRC32 will compute fast but not cryptographically secure
// ! crc32(crc32(privatesalt,timestamp,8),url,urllen)
// - suaCRC32C and suaXXHASH will be faster and slightly safer
// - but you can select other stronger alternatives, which result will be
// reduced to 32-bit hexadecimal - suaMD5 will be the fastest cryptographic
// hash available on all platforms, for enhanced security, by calling e.g.
// ! (aServer.AuthenticationRegister(TSQLRestServerAuthenticationDefault) as
// ! TSQLRestServerAuthenticationDefault).Algorithm := suaMD5;
// - suaSHA1, suaSHA256 and suaSHA512 will be the slowest, to provide
// additional level of trust, depending on your requirements: note that
// since the hash is reduced to 32-bit resolution, those may not provide
// higher security than suaMD5
// - note that SynCrossPlatformRest clients only implements suaCRC32 yet
TSQLRestServerAuthenticationSignedURIAlgo =
(suaCRC32, suaCRC32C, suaXXHASH, suaMD5, suaSHA1, suaSHA256, suaSHA512);
/// function prototype for TSQLRestServerAuthenticationSignedURI computation
// of the session_signature parameter value
TSQLRestServerAuthenticationSignedURIComputeSignature = function(
privatesalt: cardinal; timestamp, url: PAnsiChar; urllen: integer): cardinal of object;
/// secure authentication scheme using URL-level digital signature
// - default suaCRC32 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;
fTimestampCoherencyTicks: cardinal;
fComputeSignature: TSQLRestServerAuthenticationSignedURIComputeSignature;
procedure SetNoTimestampCoherencyCheck(value: boolean);
procedure SetTimestampCoherencySeconds(value: cardinal);
procedure SetAlgorithm(value: TSQLRestServerAuthenticationSignedURIAlgo);
// class functions implementing TSQLRestServerAuthenticationSignedURIAlgo
class function ComputeSignatureCrc32(privatesalt: cardinal;
timestamp, url: PAnsiChar; urllen: integer): cardinal;
class function ComputeSignatureCrc32c(privatesalt: cardinal;
timestamp, url: PAnsiChar; urllen: integer): cardinal;
class function ComputeSignaturexxHash(privatesalt: cardinal;
timestamp, url: PAnsiChar; urllen: integer): cardinal;
class function ComputeSignatureMD5(privatesalt: cardinal;
timestamp, url: PAnsiChar; urllen: integer): cardinal;
class function ComputeSignatureSHA1(privatesalt: cardinal;
timestamp, url: PAnsiChar; urllen: integer): cardinal;
class function ComputeSignatureSHA256(privatesalt: cardinal;
timestamp, url: PAnsiChar; urllen: integer): cardinal;
class function ComputeSignatureSHA512(privatesalt: cardinal;
timestamp, url: PAnsiChar; urllen: integer): cardinal;
class function GetComputeSignature(algo: TSQLRestServerAuthenticationSignedURIAlgo): TSQLRestServerAuthenticationSignedURIComputeSignature;
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
// - method execution should be protected by TSQLRestServer.fSessions.Lock
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 SetTimestampCoherencySeconds;
/// customize the session_signature signing algorithm with a specific function
// - the very same function should be set on TSQLRestClientURI
// - to select a known hash algorithm, you may change the Algorithm property
property ComputeSignature: TSQLRestServerAuthenticationSignedURIComputeSignature
read fComputeSignature write fComputeSignature;
/// customize the session_signature signing algorithm
// - you need to set this value on the server side only; those known algorithms
// will be recognized by TSQLRestClientURI on the client side during the
// session handshake, to select the matching ComputeSignature function
property Algorithm: TSQLRestServerAuthenticationSignedURIAlgo write SetAlgorithm;
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
// - method execution should be protected by TSQLRestServer.fSessions.Lock
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
// - method execution should be protected by TSQLRestServer.fSessions.Lock
function RetrieveSession(Ctxt: TSQLRestServerURIContext): TAuthSession; override;
/// handle the Auth RESTful method with HTTP Basic
// - will first return HTTP_UNAUTHORIZED (401), then expect user and password
// to be supplied as incoming "Authorization: Basic ...." headers
function Auth(Ctxt: TSQLRestServerURIContext): boolean; override;
end;
{$ifdef DOMAINAUTH}
/// authentication of the current logged user using Windows Security Support
// Provider Interface (SSPI) or GSSAPI library on Linux
// - is able to authenticate the currently logged user on the client side,
// using either NTLM (Windows only) or Kerberos - it will 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
// will 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 DOMAINAUTH}
/// 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: RawUTF8;
FThreadCount: byte;
FHttps: boolean;
FHttpSysQueueName: SynUnicode;
FRemoteIPHeader: RawUTF8;
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 '*' if you want to be able to access the
// REST methods from an HTML5 application hosted in another location,
// or define a CSV white list of TMatch-compatible origins
// - will set e.g. the following HTTP header:
// ! Access-Control-Allow-Origin: *
property EnableCORS: RawUTF8 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;
/// the value of a custom HTTP header containing the real client IP
// - by default, the RemoteIP information will be retrieved from the socket
// layer - but if the server runs behind some proxy service, you should
// define here the HTTP header name which indicates the true remote client
// IP value, mostly as 'X-Real-IP' or 'X-Forwarded-For'
property RemoteIPHeader: RawUTF8 read fRemoteIPHeader write fRemoteIPHeader;
/// 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) will 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;
/// override this to customize fields intialization
class procedure InitializeFields(const Fields: array of const; var JSON: RawUTF8); virtual;
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 will 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(TSynPersistentLock)
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 will 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 will 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 will 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 will 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/HTTP_SUCCESS or 201/HTTP_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 in TSynMonitorUsageRest
// - the ID primary field is the TSynMonitorUsageID (accessible from UsageID
// public property) shifted by 16 bits (by default) to include a
// TSynUniqueIdentifierProcess value
TSQLMonitorUsage = class(TSQLRecordNoCaseExtended)
protected
fGran: TSynMonitorUsageGranularity;
fProcess: Int64;
fInfo: variant;
fComment: RawUTF8;
public
/// compute the corresponding 23 bit TSynMonitorUsageID.Value time slice
// - according to the stored Process field, after bit shift
// - allows a custom aProcessIDShift if it is not set as default 16 bits
function UsageID(aProcessIDShift: integer=16): integer;
published
/// the granularity of the statistics of this entry
property Gran: TSynMonitorUsageGranularity read fGran write fGran;
/// identify which application is monitored
// - match the lower bits of each record ID
// - by default, is expected to be a TSynUniqueIdentifierProcess 16-bit value
property Process: Int64 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;
/// will store TSynMonitorUsage information in TSQLMonitorUsage ORM tables
// - TSQLRecord.ID will be the TSynMonitorUsageID shifted by ProcessIDShift bits
TSynMonitorUsageRest = class(TSynMonitorUsage)
protected
fStorage: TSQLRest;
fProcessID: Int64;
fProcessIDShift: integer;
fStoredClass: TSQLMonitorUsageClass;
fStoredCache: array[mugHour..mugYear] of TSQLMonitorUsage;
fSaveBatch: TSQLRestBatch;
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 16-bit TSynUniqueIdentifierProcess is supplied, it will be used to
// identify the generating process by shifting TSynMonitorUsageID values
// by aProcessIDShift bits (default 16 but you may increase it up to 40 bits)
// - will use TSQLMonitorUsage table, unless another one is specified
constructor Create(aStorage: TSQLRest; aProcessID: Int64;
aStoredClass: TSQLMonitorUsageClass=nil; aProcessIDShift: integer=16); reintroduce; virtual;
/// finalize the process, saving pending changes
destructor Destroy; override;
/// you can set an optional Batch instance to speed up DB writing
// - when calling the Modified() method
property SaveBatch: TSQLRestBatch read fSaveBatch write fSaveBatch;
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
// - is by default a TSynUniqueIdentifierProcess value, but may be
// any integer up to ProcessIDShift bits as set in Create()
property ProcessID: Int64 read fProcessID;
/// how process ID are stored within the mORMot TSQLRecord.ID
// - equals 16 bits by default, to match TSynUniqueIdentifierProcess resolution
property ProcessIDShift: integer read fProcessIDShift;
end;
/// the flags used for TSQLRestServer.AddStats
TSQLRestServerAddStat = (withTables, withMethods, withInterfaces, withSessions);
/// some flags used for TSQLRestServer.AddStats
TSQLRestServerAddStats = set of TSQLRestServerAddStat;
/// 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
{$ifdef USERECORDWITHMETHODS}TSQLRestServerURI = record
{$else}TSQLRestServerURI = object{$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
{$ifdef USERECORDWITHMETHODS}TServicesPublishedInterfaces = record
{$else}TServicesPublishedInterfaces = object{$endif}
public
/// 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(TSynPersistentLock)
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 will 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 will 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 will 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 will 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 will 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 will 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 table containing the Users
// registered for authentication
// - see also TSQLRestServer.OnAuthenticationUserRetrieve custom event
TSQLAuthUserClass = class of TSQLAuthUser;
/// class-reference type (metaclass) of the table containing the available
// user access rights for authentication, defined as a group
TSQLAuthGroupClass = class of TSQLAuthGroup;
/// 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 will let ORM GET return to AJAX (non Delphi)
// clients JSON objects instead of the JSON text stored in database fields
// - rsoGetID_str will 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
// rsoHttp200WithNoBodyReturns204 so that any HTTP_SUCCESS (200) with no
// returned body will return a HTTP_NOCONTENT (204), as expected by
// some clients
// - by default, Add() or Update() will return HTTP_CREATED (201) or
// HTTP_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
// will set the fields on the server side by calling the TSQLRecord
// ComputeFieldsBeforeWrite virtual method, before writing to the database
// - rsoSecureConnectionRequired will ensure Call is flagged as llfSecured
// (i.e. in-process, HTTPS, or encrypted WebSockets) - with the only exception
// of the Timestamp method-based service (for monitoring purposes) - note that
// this option doesn't make sense behind a proxy, just with a true HTTPS server
// - by default, cookies will contain only 'Path=/Model.Root', but
// '; Path=/' may be also added setting rsoCookieIncludeRootPath
// - you can disable the 'HttpOnly' flag via rsoCookieHttpOnlyFlagDisable
// - TSQLRestServerURIContext.AuthenticationBearerToken will return the
// ?authenticationbearer=... URI parameter value alternatively to the HTTP
// header unless rsoAuthenticationURIDisable is set (for security reasons)
// - you can switch off root/timestamp/info URI via rsoTimestampInfoURIDisable
// - URI() header output will be sanitized for any EOL injection, unless
// rsoHttpHeaderCheckDisable is defined (to gain a few cycles?)
// - by default, TSQLAuthUser.Data blob is retrieved from the database,
// unless rsoGetUserRetrieveNoBlobData is defined
// - rsoNoInternalState could be state to avoid transmitting the
// 'Server-InternalState' header, e.g. if the clients wouldn't need it
// - rsoNoTableURI will disable any /root/tablename URI for safety
// - rsoMethodUnderscoreAsSlashURI will try to decode /root/method/name
// as 'method_name' method
TSQLRestServerOption = (
rsoNoAJAXJSON,
rsoGetAsJsonNotAsString,
rsoGetID_str,
rsoRedirectForbiddenToAuth,
rsoHttp200WithNoBodyReturns204,
rsoAddUpdateReturnsContent,
rsoComputeFieldsBeforeWriteOnServerSide,
rsoSecureConnectionRequired,
rsoCookieIncludeRootPath,
rsoCookieHttpOnlyFlagDisable,
rsoAuthenticationURIDisable,
rsoTimestampInfoURIDisable,
rsoHttpHeaderCheckDisable,
rsoGetUserRetrieveNoBlobData,
rsoNoInternalState,
rsoNoTableURI,
rsoMethodUnderscoreAsSlashURI);
/// 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;
/// the TSQLAuthUser and TSQLAuthGroup classes, as defined in model
fSQLAuthUserClass: TSQLAuthUserClass;
fSQLAuthGroupClass: TSQLAuthGroupClass;
fAfterCreation: boolean;
fOptions: TSQLRestServerOptions;
fJWTForUnauthenticatedRequest: TJWTAbstract;
/// 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
// - the very same TSQLRestStorage is handled in fStaticData
fStaticVirtualTable: TSQLRestDynArray;
/// in-memory storage of TAuthSession instances
fSessions: TSynObjectListLocked;
fSessionsDeprecatedTix: cardinal;
/// 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;
fPublishedMethodTimestampIndex: integer;
fPublishedMethodAuthIndex: integer;
fPublishedMethodBatchIndex: integer;
fPublicURI: TSQLRestServerURI;
fAssociatedServices: TServicesPublishedInterfacesList;
fStats: TSQLRestServerMonitor;
fStatLevels: TSQLRestServerMonitorLevels;
fStatUsage: TSynMonitorUsage;
fShutdownRequested: boolean;
fCreateMissingTablesOptions: TSQLInitializeTableOptions;
fRootRedirectGet: RawUTF8;
fSafeRootUpper: RawUTF8;
fSafeProtocol: IProtocol;
fSafeProtocolNext: IProtocol;
fSafeProtocols: TSynDictionary;
fRecordVersionMax: TRecordVersion;
fRecordVersionDeleteIgnore: boolean;
fOnIdleLastTix: cardinal;
fSQLRecordVersionDeleteTable: TSQLRecordTableDeletedClass;
fRecordVersionSlaveCallbacks: array of IServiceRecordVersionCallback;
fIPBan, fIPWhiteJWT: TIPBan;
// 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 AddStat(Flags: TSQLRestServerAddStats; W: TTextWriter);
{$ifndef NOVARIANTS}
procedure InternalInfo(var info: TDocVariantData); virtual;
{$endif}
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 GetStaticTable(aClass: TSQLRecordClass): TSQLRest;
{$ifdef HASINLINE}inline;{$endif}
/// overloaded method using table index in associated Model
function GetStaticTableIndex(aTableIndex: integer): TSQLRest;
overload; {$ifdef HASINLINE}inline;{$endif}
function GetStaticTableIndex(aTableIndex: integer;
out Kind: TSQLRestServerKind): TSQLRest; overload;
{$ifdef HASINLINE}inline;{$endif}
function GetRemoteTable(TableIndex: Integer): TSQLRest;
function IsInternalSQLite3Table(aTableIndex: integer): boolean;
/// intercepts all calls to TSQLRestServer.URI for fSafeProtocol
// - e.g. ModelRoot/_safe_ URI called by the clients to implement a secure
// custom encryption, by sending POST requests with an encrypted body as
// BINARY_CONTENT_TYPE ('application/octet-stream') input and output
procedure InternalSafeProtocol(var Call: TSQLRestURIParams; var SafeID: integer);
/// 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;
/// search for Ctxt.Session ID and fill Ctxt.Session* members if found
// - 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 Sessions.Lock/Unlock
function SessionAccess(Ctxt: TSQLRestServerURIContext): TAuthSession;
/// delete a session from its index in Sessions[]
// - will perform any needed clean-up, and log the event
// - this method is not thread-safe: caller should use Sessions.Lock/Unlock
procedure SessionDelete(aSessionIndex: integer; Ctxt: TSQLRestServerURIContext);
/// SessionAccess will detect and delete outdated sessions, but you can call
// this method to force checking for deprecated session now
// - may be used e.g. from OnSessionCreate to limit the number of active sessions
// - this method is not thread-safe: caller should use Sessions.Lock/Unlock
// - you can call it often: it will seek for outdated sessions once per second
// - returns the current system Ticks number (at second resolution)
function SessionDeleteDeprecated: cardinal;
/// 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; var 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 in Ctxt.RemoteIP
// or the text error message corresponding to Reason in Ctxt.CustomErrorMsg
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 will give access to the command about to
// be executed, e.g. Ctxt.Command=execSOAByInterface will 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',HTTP_NOTALLOWED);
// - since this event will be executed by every TSQLRestServer.URI call,
// it should better not make any slow process (like writing to a remote DB)
// - see also TSQLRest.OnDecryptBody, which is common to the client side, so
// may be a better place for implementing shared process (e.g. encryption)
OnBeforeURI: TNotifyBeforeURI;
/// event trigerred when URI() finished to process a request
// - the supplied Ctxt parameter will give access to the command which has
// been executed, e.g. via Ctxt.Call.OutStatus or Ctxt.MicroSecondsElapsed
// - since this event will be executed by every TSQLRestServer.URI call,
// it should better not make any slow process (like writing to a remote DB)
// - see also TSQLRest.OnDecryptBody/OnEncryptBody, which is common to the
// client side, so may be better to implement shared process (e.g. encryption)
OnAfterURI: TNotifyAfterURI;
/// event trigerred when URI() failed to process a request
// - if Ctxt.ExecuteCommand raised an execption, this callback will 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;
{$ifndef NOVARIANTS}
/// event to customize the information returned by root/timestamp/info
// - called by TSQLRestServer.InternalInfo method
// - you can add some application-level information for monitoring
OnInternalInfo: TOnInternalInfo;
{$endif}
/// 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;
/// overridden method for direct static class call (if any)
function MemberExists(Table: TSQLRecordClass; ID: TID): 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 will 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 will 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 will 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() will 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 will perform all update operations as expected
// - the callback process will 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 will work only for ORM sessions, NOT complex SOA state
// - this method is called by Destroy itself
procedure Shutdown(const aStateFileName: TFileName=''); virtual;
/// wait for the specified number of milliseconds
// - if Shutdown is called in-between, returns true
// - if the thread waited the supplied time, returns false
function SleepOrShutdown(MS: integer): boolean;
/// 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 will pass
// - this will enable easy creation of proxies, or local servers, with they
// own cache and data model - e.g. a branch office server which may serve
// its local clients over Ethernet, but communicating to a main mORMot
// server via Internet, storing the corporate data in the main office server
// - you may also share some tables (e.g. TSQLAuthUser and TSQLAuthGroup)
// between TSQLRestServer instances in a single service
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 into 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 authentication, e.g. if you have
// troubles with AJAX asynchronous callbacks:
// ! (aServer.AuthenticationRegister(TSQLRestServerAuthenticationDefault) as
// ! TSQLRestServerAuthenticationDefault).NoTimestampCoherencyCheck := true;
// or if you want to customize the session_signature parameter algorithm:
// ! (aServer.AuthenticationRegister(TSQLRestServerAuthenticationDefault) as
// ! TSQLRestServerAuthenticationDefault).Algorithm := suaMD5;
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;
/// (un)register a banned IPv4 value
// - any connection attempt from this IP Address will be rejected by
function BanIP(const aIP: RawUTF8; aRemoveBan: boolean=false): boolean;
/// (un)register a an IPv4 value to the JWT white list
// - by default, a JWT validated by JWTForUnauthenticatedRequest will be accepted
// - to avoid MiM (Man-In-the-Middle) attacks, if a JWT white list is defined
// using this method, any connection from a non registered IP will be rejected,
// even with a valid JWT
// - WebSockets connections are secure enough to bypass this list
function JWTForUnauthenticatedRequestWhiteIP(const aIP: RawUTF8; aRemoveWhite: boolean=false): boolean;
/// 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 will
// bypass the authenticaton process
// - returns the method index number
function ServiceMethodByPassAuthentication(const aMethodName: RawUTF8): integer;
/// 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 supported 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 will 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 will 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 calls internaly Sessions.Lock
// (the returned TSQLAuthUser is a private copy from Sessions[].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 Sessions.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 will 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 Sessions.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. corresponding to aInterfaces[0] - not to the others),
// 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 for aInterfaces[0] - warning: only the
// the first interface options are returned
// - 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)
// - will return the first of the registered TServiceFactoryServer created
// on success (i.e. corresponding to aInterfaces[0] - not to the others),
// 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 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),...]);
// - will return the first of the registered TServiceFactoryServer created
// on success (i.e. corresponding to aInterfaces[0] - not to the others),
// or nil if registration failed (e.g. if any of the supplied interfaces
// is not implemented by the given class)
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
// - will return the first of the registered TServiceFactoryServer created
// on success (i.e. corresponding to aInterfaces[0] - not to the others),
// or nil if registration failed (e.g. if any of the supplied interfaces
// is not implemented by the given class)
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 will 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 statistics about this server, as JSON
// - is a wrapper around the Stats() method-based service
function StatsAsJson(Flags: TSQLRestServerAddStats=[withTables..withSessions]): RawUTF8; virtual;
/// compute the statistics about this server, as a TDocVariant document
// - is a wrapper around the Stats() method-based service
function StatsAsDocVariant(Flags: TSQLRestServerAddStats=[withTables..withSessions]): variant;
/// read-only access to the internal list of sessions
// - ensure you protect its access calling Sessions.Lock/Sessions.Unlock
property Sessions: TSynObjectListLocked read fSessions;
/// 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;
/// define if unsecure connections (i.e. not in-process or encrypted
// WebSockets) with no session can be authenticated via JWT
// - once set, this instance will be owned by the TSQLRestServer
// - by definition, such JWT authentication won't identify any mORMot user
// nor session (it just has to be valid), so only sicSingle, sicShared or
// sicPerThread interface-based services execution are possible
// - typical usage is for a public API, in conjunction with
// ServiceDefine(...).ResultAsJSONObjectWithoutResult := true on the server
// side and TSQLRestClientURI.ServiceDefineSharedAPI() method for the client
// - see also JWTForUnauthenticatedRequestWhiteIP() for additional security
property JWTForUnauthenticatedRequest: TJWTAbstract
read fJWTForUnauthenticatedRequest write fJWTForUnauthenticatedRequest;
/// 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 will 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;
/// fast get the associated static server or virtual table, if any
// - same as a dual call to StaticDataServer[aClass] + StaticVirtualTable[aClass]
property StaticTable[aClass: TSQLRecordClass]: TSQLRest read GetStaticTable;
/// 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() will 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 HTTP_SUCCESS with no body should be translated into HTTP_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 will follow HandleAuthentication
/// setting: but you could define some HTTP verb to this property, which
// will 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 will
// 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 normally, because it will add unnecessary overhead)
property StaticVirtualTableDirect: boolean read fVirtualTableDirect
write fVirtualTableDirect;
/// 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;
/// 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;
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 will 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 will 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 won't require an authenticated client, since it is used to
// initiate authentication
// - 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 will not require an authenticated client
// - hidden ModelRoot/Timestamp/info command will 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 will 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
// - POST ModelRoot/CacheFlush/_callback_ URI will be called by the client
// to notify the server that an interface callback instance has been released
// - POST ModelRoot/CacheFlush/_ping_ URI will be called by the client after
// every half session timeout (or at least every hour) to notify the server
// that the connection is still alive
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 will 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 (HTTP_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;
fStoredClassMapping: PSQLRecordPropertiesMapping;
fStorageLockShouldIncreaseOwnerInternalState: boolean;
fStorageLockLogTrace: boolean;
fModified: boolean;
fOwner: TSQLRestServer;
fStorageCriticalSection: TRTLCriticalSection;
fStorageCriticalSectionCount: integer;
fBasicSQLCount: RawUTF8;
fBasicSQLHasRows: array[boolean] of RawUTF8;
fStorageVirtual: TSQLVirtualTable;
/// 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; const msg: RawUTF8); 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 into 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 will 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
// - used e.g. to hash TSQLRestStorageInMemory field values
TSQLRestStorageInMemoryUnique = class
protected
fHasher: TDynArrayHasher;
fOwner: TSQLRestStorageInMemory;
fPropInfo: TSQLPropInfo;
fCaseInsensitive: boolean;
fLastFindHashCode: cardinal;
function EventCompare(const A,B): integer; // match TEventDynArraySortCompare
function EventHash(const Elem): cardinal; // match TEventDynArrayHashOne
public
/// initialize a hash for a record array field
// - aField maps the "stored AS_UNIQUE" published property
constructor Create(aOwner: TSQLRestStorageInMemory; aField: TSQLPropInfo);
/// fast search using O(1) internal hash table
// - returns -1 if not found or not indexed (self=nil)
function Find(Rec: TSQLRecord): integer;
/// called by TSQLRestStorageInMemory.AddOne after a precious Find()
function AddedAfterFind(Rec: TSQLRecord): boolean;
/// the corresponding field RTTI
property PropInfo: TSQLPropInfo read fPropInfo;
/// if the string comparison shall be case-insensitive
property CaseInsensitive: boolean read fCaseInsensitive;
/// access to the internal hash table
property Hasher: TDynArrayHasher read fHasher;
end;
/// REST storage with direct access to a TObjectList memory-stored table
// - store the associated TSQLRecord values in memory
// - 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: TSQLRecordObjArray;
fCount: integer;
fFileName: TFileName;
fCommitShouldNotUpdateFile: boolean;
fBinaryFile: boolean;
fExpandedJSON: boolean;
fUnSortedID: boolean;
fSearchRec: TSQLRecord; // temporary record to store the searched value
fBasicUpperSQLSelect: array[boolean] of RawUTF8;
fUnique: array of TSQLRestStorageInMemoryUnique;
fMaxID: TID;
fValues: TDynArrayHashed; // hashed by ID
function UniqueFieldsUpdateOK(aRec: TSQLRecord; aUpdateIndex: integer): boolean;
function GetItem(Index: integer): TSQLRecord; {$ifdef HASINLINE}inline;{$endif}
function GetID(Index: integer): TID;
procedure SetFileName(const aFileName: TFileName);
procedure ComputeStateAfterLoad(var loaded: TPrecisionTimer; binary: boolean);
procedure SetBinaryFile(aBinary: boolean);
procedure GetJSONValuesEvent(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(andUpdateFile: boolean=true);
/// load the values from JSON data
// - a temporary copy of aJSON is made to ensure it won't be modified in-place
// - consider using the overlaoded PUTF8Char/len method if you don't need this copy
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
// - you can specify a library (dll) resource instance handle, if needed
procedure LoadFromResource(ResourceName: string=''; Instance: THandle=0);
/// 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 internally fast O(1) hashed search algorithm
// - warning: this method should be protected via StorageLock/StorageUnlock
function IDToIndex(ID: TID): PtrInt;
/// retrieve all IDs stored at once
// - will make a thread-safe copy, for unlocked use
procedure GetAllIDs(out ID: TIDDynArray);
/// low-level Add of a TSQLRecord instance
// - 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, since it will be owned by the storage
// - in practice, SentData is used only for OnUpdateEvent/OnBlobUpdateEvent
// and the history feature
// - 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;
/// overridden method for direct in-memory database engine call
function MemberExists(Table: TSQLRecordClass; ID: TID): 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: PtrInt): integer;
/// optimized search of WhereValue in WhereField (0=RowID,1..=RTTI)
// - will use fast O(1) hash for fUnique[] 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: PtrInt;
CaseInsensitive: boolean=true): PtrInt; overload;
/// optimized search of WhereValue in a field, specified by name
// - will use fast O(1) hash for fUnique[] 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
// - will 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);
/// low-level TFindWhereEqualEvent callback doing nothing
class procedure DoNothingEvent(aDest: pointer; aRec: TSQLRecord; aIndex: integer);
/// low-level TFindWhereEqualEvent callback setting PPointer(aDest)^ := aRec
class procedure DoInstanceEvent(aDest: pointer; aRec: TSQLRecord; aIndex: integer);
/// low-level TFindWhereEqualEvent callback setting PInteger(aDest)^ := aIndex
class procedure DoIndexEvent(aDest: pointer; aRec: TSQLRecord; aIndex: integer);
/// low-level TFindWhereEqualEvent callback setting PPointer(aDest)^ := aRec.CreateCopy
class procedure DoCopyEvent(aDest: pointer; aRec: TSQLRecord; aIndex: integer);
/// low-level TFindWhereEqualEvent callback calling TSynList(aDest).Add(aRec)
class procedure DoAddToListEvent(aDest: pointer; aRec: TSQLRecord; aIndex: integer);
/// 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 dynamic array storage
// - Items[] is preferred, since it will 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 Value: TSQLRecordObjArray read fValue;
/// read-only access to the ID of a TSQLRecord values
// - warning: this method should be protected via StorageLock/StorageUnlock
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
// will be marked as "modified" so that UpdateFile will 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
// will be marked as "modified" so that UpdateFile will 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 fCount;
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; const msg: RawUTF8); 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;
published
/// 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 will handle its partioned process
TSQLRestStorageShardOption = (ssoNoUpdate, ssoNoUpdateButLastShard,
ssoNoDelete, ssoNoDeleteButLastShard, ssoNoBatch,
ssoNoList, ssoNoExecute, ssoNoUpdateField, ssoNoConsolidateAtDestroy);
/// how TSQLRestStorageShard will 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 will allow to scale with typical BigData storage
// - this storage will add items on a server, initializing a new server
// when the ID reached a defined range
// - it will 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;
fShardOffset: integer;
fMaxShardCount: integer;
fLastID: TID;
fOptions: TSQLRestStorageShardOptions;
fShards: array of TSQLRest;
fShardLast: integer;
fShardLastID: TID;
fShardNextID: TID;
fShardTableIndex: TIntegerDynArray;
fShardBatch: array of TSQLRestBatch;
// will set Shards[],fShardLast,fShardLastID,fShardOffset
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 will 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 will be broken
constructor Create(aClass: TSQLRecordClass; aServer: TSQLRestServer;
aShardRange: TID; aOptions: TSQLRestStorageShardOptions;
aMaxShardCount: integer); 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 will allow e.g. to delete a *.dbs file at runtime, without
// restarting the server
// - this default implementation will free and nil fShard[aShardIndex],
// which is enough for most implementations (e.g. TSQLRestStorageShardDB)
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[]
// - warning: this method should be protected via StorageLock/StorageUnlock
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 will fail
// - each shard will hold [ShardIndex*ShardRange..(ShardIndex+1)*ShardRange-1] IDs
property ShardRange: TID read fShardRange;
/// how many shards should be maintained at most
// - if some older shards are available on disk, they won't be loaded by
// InitShards, and newly added shard via InitNewShard will trigger
// RemoveShard if the total number of shards
property MaxShardCount: integer read fMaxShardCount;
/// defines how this instance will handle its sharding process
// - by default, update/delete operations or per ID retrieval will take
// place on all shards, whereas EngineList and EngineExecute will 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 storage content
procedure DropDatabase; virtual;
/// direct access to the 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 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/HTTP_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/HTTP_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/HTTP_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/HTTP_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;
/// 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
// - here input/output parameters are defined as plain string, to match the
// type expected by the client's User Interface, via VCL properties, or
// e.g. from TLoginForm as defined in mORMotUILogin.pas unit
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 will be available in Sender's LastErrorCode and
// LastErrorMessage properties
// - if the error comes from an Exception, it will be supplied as parameter
// - the REST context (if any) will be supplied within the Call parameter,
// and in this case Call^.OutStatus=HTTP_NOTIMPLEMENTED indicates a broken
// connection
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;
/// weak 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(TSynPersistentLock)
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;
/// signature e.g. of the TSQLRestClientURI.OnSetUser event handler
TOnRestClientNotify = procedure(Sender: TSQLRestClientURI) of object;
/// 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
fComputeSignature: TSQLRestServerAuthenticationSignedURIComputeSignature;
fOnAuthentificationFailed: TOnAuthentificationFailed;
fOnSetUser: TOnRestClientNotify;
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;
fSessionServerTimeout: integer;
fSessionHeartbeatSeconds: integer;
/// 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;
fInternalState: set of (isOpened, isDestroying, isInAuth);
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;
procedure SetSessionHeartbeatSeconds(timeout: integer);
function InternalRemoteLogSend(const aText: RawUTF8): boolean;
procedure InternalNotificationMethodExecute(var Ctxt: TSQLRestURIParams); virtual;
procedure SetLastException(E: Exception=nil; ErrorCode: integer=HTTP_BADREQUEST;
Call: PSQLRestURIParams=nil);
/// will call timestamp/info if the session has currently not been retrieved
function GetSessionVersion: RawUTF8;
// register the user session to the TSQLRestClientURI instance
function SessionCreate(aAuth: TSQLRestServerAuthenticationClass;
var aUser: TSQLAuthUser; const aSessionKey: RawUTF8): boolean;
procedure SessionRenewEvent(Sender: TSynBackgroundTimer; Event: TWaitResult;
const Msg: RawUTF8);
/// 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; var 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;
/// customize the session_signature signing algorithm with a specific function
// - will be used by TSQLRestServerAuthenticationSignedURI classes,
// e.g. TSQLRestServerAuthenticationDefault instead of the algorithm
// specified by the server at session handshake
property ComputeSignature: TSQLRestServerAuthenticationSignedURIComputeSignature
read fComputeSignature write fComputeSignature;
/// save the TSQLRestClientURI properties into a persistent storage object
// - CreateFrom() will expect Definition.UserName/Password to store the
// credentials which will 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 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/HTTP_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 will 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; const FormatMsg: RawUTF8;
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=CONST_AUTHENTICATION_NOT_USED): 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.Delete() 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.Delete() 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/HTTP_SUCCESS OK on success
// - a dynamic array of integers will be created in Results,
// containing all ROWDID created for each BatchAdd call, 200 (=HTTP_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/HTTP_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/HTTP_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/HTTP_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;
/// to be called before CallBack() if the client could ignore the answer
// - do nothing by default, but overriden e.g. in TSQLHttpClientWebsockets
procedure CallbackNonBlockingSetHeader(out Header: RawUTF8); virtual;
/// 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=''; aIgnoreAnyException: boolean=true): 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 to have been registered previously:
// ! TInterfaceFactory.RegisterInterfaces([TypeInfo(IMyInterface),...]);
function ServiceDefine(const aInterface: TGUID;
aInstanceCreation: TServiceInstanceImplementation=sicSingle;
const aContractExpected: RawUTF8=''; aIgnoreAnyException: boolean=true): TServiceFactoryClient; overload;
/// register and retrieve the sicClientDriven Service instance
// - this method expects the interface to have been registered previously:
// ! TInterfaceFactory.RegisterInterfaces([TypeInfo(IMyInterface),...]);
function ServiceDefineClientDriven(const aInterface: TGUID; out Obj;
const aContractExpected: RawUTF8=''): boolean;
/// register a sicShared Service instance communicating via JSON objects
// - will force SERVICE_CONTRACT_NONE_EXPECTED, ParamsAsJSONObject=true and
// ResultAsJSONObjectWithoutResult=true
// - may be used e.g. for accessing a sessionless public REST/JSON API, i.e.
// ! TSQLRestServer.ServiceDefine(...).ResultAsJSONObjectWithoutResult := true
// - this method expects the interface to have been registered previously:
// ! TInterfaceFactory.RegisterInterfaces([TypeInfo(IMyInterface),...]);
// - aIgnoreAnyException may be set to TRUE if the server is likely
// to not propose this service, and any exception is to be catched
function ServiceDefineSharedAPI(const aInterface: TGUID;
const aContractExpected: RawUTF8=SERVICE_CONTRACT_NONE_EXPECTED;
aIgnoreAnyException: boolean=false): TServiceFactoryClient;
/// 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 will 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 will 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 HTTP_* constants
// - HTTP_SUCCESS or HTTP_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 HTTP_SUCCESS or HTTP_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 1, 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;
/// the remote server session tiemout in minutes, as retrieved after
// a SetUser() success
// - will be used to set SessionHeartbeatSeconds default
property SessionServerTimeout: integer read fSessionServerTimeout;
/// frequency of Callback/_ping_ calls to maintain session and services
// - will be used to call SessionRenewEvent at the specified period, so that
// the session and all sicClientDriven instances will be maintained on the
// server side as long as the client connection stands
// - equals half SessionServerTimeout or 25 minutes (if lower) by default -
// 25 minutes matches the default service timeout of 30 minutes
// - you may set 0 to disable this SOA-level heartbeat feature
property SessionHeartbeatSeconds: integer read fSessionHeartbeatSeconds
write SetSessionHeartbeatSeconds;
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;
/// access to the low-level HTTP header used for authentication
// - you can force here your own header, e.g. a JWT as authentication bearer
// or as in TSQLRestServerAuthenticationHttpAbstract.ClientSetUserHttpOnlyUser
property SessionHttpHeader: RawUTF8 read fSessionHttpHeader write fSessionHttpHeader;
{$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 HTTP_FORBIDDEN "403 Forbidden" error code
property OnAuthentificationFailed: TOnAuthentificationFailed
read fOnAuthentificationFailed write fOnAuthentificationFailed;
/// this Event is called if URI() was not successfull
// - the callback will have all needed information
// - e.g. Call^.OutStatus=HTTP_NOTIMPLEMENTED indicates a broken connection
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 Sender.SessionUser property pointing to the current
// authenticated user, or nil if authentication failed
// - could be used to refresh the User Interface layout according to
// current authenticated user rights, or to subscribe to some services
// via callbacks
property OnSetUser: TOnRestClientNotify 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 will be owned by this class
constructor Create(aModel: TSQLModel); overload; override;
/// will 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;
/// will pass all client commands to the supplied TSQLRestServer instance
// - aRedirected will 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 will be disabled and any URI() call
// will return an HTTP_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 HTTP_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 MSWINDOWS}
/// 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 Validate
// method call by TSQLRecord.Validate()
TSynValidateRest = class(TSynValidate)
protected
fProcessRest: TSQLRest;
fProcessRec: TSQLRecord;
function DoValidate(aFieldIndex: integer; const Value: RawUTF8; var ErrorMsg: string; aProcessRest: TSQLRest; aProcessRec: TSQLRecord): boolean; virtual; abstract;
public
function Process(aFieldIndex: integer; const Value: RawUTF8; var ErrorMsg: string): boolean; override;
function Validate(aFieldIndex: integer; const Value: RawUTF8; var ErrorMsg: string; aProcessRest: TSQLRest; aProcessRec: TSQLRecord): boolean;
/// the associated TSQLRest instance
// - this value is updated by Validate with the current
// TSQLRest used for the validation
// - it can be used in the overridden DoValidate method
property ProcessRest: TSQLRest read fProcessRest;
/// the associated TSQLRecord instance
// - this value is updated by Validate with the current
// TSQLRecord instance to be validated
// - it can be used in the overridden DoValidate 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)
protected
/// perform the unique field validation action to the specified value
function DoValidate(aFieldIndex: integer; const Value: RawUTF8; var ErrorMsg: string; aProcessRest: TSQLRest; aProcessRec: TSQLRecord): 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;
/// perform the unique fields validation action to the specified value
function DoValidate(aFieldIndex: integer; const Value: RawUTF8; var ErrorMsg: string; aProcessRest: TSQLRest; aProcessRec: TSQLRecord): boolean; override;
public
/// 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
{$ifdef USERECORDWITHMETHODS}TSQLVirtualTablePrepared = record
{$else}TSQLVirtualTablePrepared = object{$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}
procedure SetColumnDate(var aResult: TSQLVar; const aValue: TDateTime;
aWithMS: boolean); {$ifdef HASINLINE}inline;{$endif}
procedure SetColumnCurr64(var aResult: TSQLVar; aValue64: PInt64);
{$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 comparison function for sorting ftRecord (TRecordReference/RecordRef)
// UTF-8 encoded values in the SQLite3 database or JSON content
function UTF8CompareRecord(P1,P2: PUTF8Char): PtrInt;
/// special comparison function for sorting sftBoolean
// UTF-8 encoded values in the SQLite3 database or JSON content
function UTF8CompareBoolean(P1,P2: PUTF8Char): PtrInt;
/// special comparison 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 comparison function for sorting sftInteger, sftTID, sftRecordVersion
// sftTimeLog/sftModTime/sftCreateTime or sftUnixTime/sftUnixMSTime UTF-8 encoded
// values in the SQLite3 database or JSON content
function UTF8CompareInt64(P1,P2: PUTF8Char): PtrInt;
/// special comparison function for sorting sftCurrency
// UTF-8 encoded values in the SQLite3 database or JSON content
function UTF8CompareCurr64(P1,P2: PUTF8Char): PtrInt;
/// special comparison function for sorting sftFloat
// UTF-8 encoded values in the SQLite3 database or JSON content
function UTF8CompareDouble(P1,P2: PUTF8Char): PtrInt;
/// special comparison function for sorting sftDateTime or sftDateTimeMS
// 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 will set a varEmpty (Unassigned) value
// - typeInfo may be used for sftBlobDynArray conversion to a TDocVariant array
procedure ValueVarToVariant(Value: PUTF8Char; ValueLen: integer; 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 FTS virtual table
IS_FTS = [rFTS3, rFTS4, rFTS5];
/// 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, rFTS5, rRTree, rRTreeInteger, 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];
/// default hashed password set by TSQLAuthGroup.InitializeTable for all users
// - contains TSQLAuthUser.ComputeHashedPassword('synopse')
// - override AuthAdminDefaultPassword, AuthSupervisorDefaultPassword and
// AuthUserDefaultPassword values to follow your own application expectations
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 timeout period set by TSQLAuthGroup.InitializeTable for 'Admin' group
// - you can override this value to follow your own application expectations
AuthAdminGroupDefaultTimeout: integer = 10;
/// default timeout period set by TSQLAuthGroup.InitializeTable for 'Supervisor' group
// - you can override this value to follow your own application expectations
// - note that clients will maintain the session alive using CacheFlush/_ping_
AuthSupervisorGroupDefaultTimeout: integer = 60;
/// default timeout period set by TSQLAuthGroup.InitializeTable for 'User' group
// - you can override this value to follow your own application expectations
// - note that clients will maintain the session alive using CacheFlush/_ping_
AuthUserGroupDefaultTimeout: integer = 60;
/// default timeout period set by TSQLAuthGroup.InitializeTable for 'Guest' group
// - you can override this value to follow your own application expectations
// - note that clients will maintain the session alive using CacheFlush/_ping_
AuthGuestGroupDefaultTimeout: integer = 60;
/// 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
{$ifndef DOMAINAUTH} // fallback is no SSPI library was made available
TSQLRestServerAuthenticationSSPI = nil;
{$endif DOMAINAUTH}
/// 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);
/// wrapper to create a new T*ObjArray with copied instances of a source T*ObjArray
// - use internally CopyObject() over aSourceObjArray[] instances
// - will clear aDestObjArray before items copy, if aDestObjArrayClear = TRUE
procedure ObjArrayCopy(const aSourceObjArray; var aDestObjArray;
aDestObjArrayClear: boolean=true);
/// 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
// - returns nil if aValue is nil or not recognized
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 HTTP_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 := context.Request.Call^.InBodyType;
// !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?)
// - for a cleaner SOA/DI approach, consider using TInjectableObjectRest
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;
/// returns a safe 256-bit hexadecimal nonce, changing every 5 minutes
// - as used e.g. by TSQLRestServerAuthenticationDefault.Auth
// - this function is very fast, even if cryptographically-level SHA-3 secure
function CurrentServerNonce(Previous: boolean=false): RawUTF8;
function ToText(ft: TSQLFieldType): PShortString; overload;
function ToText(vk: TSQLRecordVirtualKind): 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;
function ToText(a: TSQLRestServerAuthenticationSignedURIAlgo): PShortString; overload;
function ToText(res: TNotifyAuthenticationFailedReason): 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 = TSynLog;
{$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
{$ifdef FPC}
uses
{$ifndef MSWINDOWS}
SynFPCLinux, // includes minimal redirection to FPC's TypInfo.pp unit
BaseUnix,
Unix,
{$endif}
dynlibs;
{$endif FPC}
// ************ some RTTI and SQL mapping routines
procedure SetID(P: PUTF8Char; var result: TID);
{$ifdef CPU64}
begin // PtrInt is already int64 -> call PtrInt version
result := GetInteger(P);
{$else}
{$ifdef HASINLINENOTX86}
begin
{$ifdef VER3_0} // FPC issue woraround
SetInt64(P,result);
{$else}
SetInt64(P,PInt64(@result)^);
{$endif}
{$else}
asm
jmp SynCommons.SetInt64
{$endif HASINLINENOTX86}
{$endif CPU64}
end;
procedure SetID(const U: RawByteString; var result: TID);
{$ifdef CPU64}
begin // PtrInt is already int64 -> call PtrInt version
result := GetInteger(pointer(U));
{$else}
{$ifdef HASINLINENOTX86}
begin
SetID(pointer(U),result);
{$else}
asm
jmp SynCommons.SetInt64
{$endif HASINLINENOTX86}
{$endif CPU64}
end;
function TSQLRecordDynArrayCompare(const Item1,Item2): integer;
{$ifdef CPUX64} // very efficient branchless asm - rcx/rdi=Item1 rdx/rsi=Item2
{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC}
mov rcx, qword ptr[Item1]
mov rdx, qword ptr[Item2]
mov rcx, qword ptr[rcx+TSQLRecord.fID]
mov rdx, qword ptr[rdx+TSQLRecord.fID]
xor eax, eax
cmp rcx, rdx
seta al
sbb eax, 0
end;
{$else}
begin // we assume Item1<>nil and Item2<>nil
result := {$ifdef HASINLINE}CompareQWord{$else}SortDynArrayQWord{$endif}(
TSQLRecord(Item1).fID,TSQLRecord(Item2).fID);
end;
{$endif CPUX64}
function TSQLRecordDynArrayHashOne(const Elem; Hasher: THasher): cardinal;
begin
with PQWordRec(@TSQLRecord(Elem).fID)^ do
result := crc32cBy4(L,H);
end;
{$ifdef HASDIRECTTYPEINFO}
type
Deref = PTypeInfo;
{$else}
function Deref(Info: PPTypeInfo): PTypeInfo;
{$ifdef HASINLINENOTX86} 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 HASINLINENOTX86}
{$endif HASDIRECTTYPEINFO}
{$ifndef FPC} /// no RTTI alignment under Delphi - see also SynFPCTypInfo
type
AlignToPtr = pointer;
AlignTypeData = pointer;
AlignTypeDataClean = pointer;
UnalignToDouble = Double;
{$endif FPC}
{ some inlined methods }
function GetTypeData(const info: TTypeInfo): pointer;
{$ifdef HASINLINE}inline;{$endif}
begin
result := AlignTypeData(PAnsiChar(@info)+2+PByte(PAnsiChar(@info)+1)^);
end;
function GetTypeDataClean(const info: TTypeInfo): pointer;
{$ifdef HASINLINE}inline;{$endif}
begin
result := AlignTypeDataClean(PAnsiChar(@info)+2+PByte(PAnsiChar(@info)+1)^);
end;
function TTypeInfo.ClassType: PClassType;
{$ifdef HASINLINENOTX86}
begin
result := GetTypeData(self);
end;
{$else}
asm // very fast code
movzx edx, byte ptr[eax].TTypeInfo.Name
lea eax, [eax + edx].TTypeInfo.Name[1]
end;
{$endif}
function TTypeInfo.RecordType: PRecordType;
{$ifdef HASINLINENOTX86}
begin
result := GetTypeData(self);
end;
{$else}
asm // very fast code
movzx edx, byte ptr[eax].TTypeInfo.Name
lea eax, [eax + edx].TTypeInfo.Name[1]
end;
{$endif}
function TTypeInfo.InterfaceType: PInterfaceTypeData;
{$ifdef HASINLINENOTX86}
begin
result := GetTypeData(self);
end;
{$else}
asm // very fast code
movzx edx, byte ptr[eax].TTypeInfo.Name
lea eax, [eax + edx].TTypeInfo.Name[1]
end;
{$endif}
function TTypeInfo.FloatType: TFloatType;
begin
result := PFloatType(GetTypeData(self))^;
end;
function TTypeInfo.OrdType: TOrdType;
begin
result := POrdType(GetTypeData(self))^;
end;
function TTypeInfo.IsQWord: boolean;
begin
{$ifdef FPC}
result := Kind=tkQWord;
{$else}
if @self=TypeInfo(QWord) then
result := true else
{$ifdef UNICODE}if Kind=tkInt64 then // check MinInt64Value>MaxInt64Value
with PHash128Rec(PAnsiChar(@Name[1])+ord(Name[0]))^ do
result := Lo>Hi else {$endif}
result := false;
{$endif}
end;
function TPropInfo.Getter(Instance: TObject; Call: PMethod): TPropInfoCall;
begin
if GetProc=0 then begin // no 'read' was defined -> try from 'write' field
if (SetProc<>0) and
({$ifdef FPC}(PropProcs shr 2)and 3{$else}PropWrap(SetProc).Kind{$endif}=ptField) then begin
Call.Data := pointer(PtrUInt(Instance)+SetProc{$ifndef FPC}and $00ffffff{$endif});
result := picField;
end else
result := picNone;
exit;
end else
case {$ifdef FPC}integer(PropProcs)and 3{$else}PropWrap(GetProc).Kind{$endif} of
ptField: begin // GetProc is an offset to the instance fields
Call.Data := pointer(PtrUInt(Instance)+GetProc{$ifndef FPC}and $00ffffff{$endif});
result := picField;
exit;
end;
ptVirtual: // GetProc is an offset to the class VMT
Call.Code := PPointer(PPtrUInt(Instance)^+{$ifndef FPC}word{$endif}(GetProc))^;
{$ifdef FPC} ptConst: exit(picNone); {$endif} // never happen on properties?
else // ptStatic: GetProc is the method code itself
Call.Code := pointer(GetProc);
end;
Call.Data := Instance;
if {$ifdef FPC}(PropProcs shr 6)and 1{$else}Index{$endif}<>NO_INDEX then
result := picIndexed else
result := picMethod;
end;
function TPropInfo.Setter(Instance: TObject; Call: PMethod): TPropInfoCall;
begin
if SetProc=0 then begin // no 'write' was defined -> try from 'read' field
if (GetProc<>0) and
({$ifdef FPC}integer(PropProcs)and 3{$else}PropWrap(GetProc).Kind{$endif}=ptField) then begin
Call.Data := pointer(PtrUInt(Instance)+GetProc{$ifndef FPC}and $00ffffff{$endif});
result := picField;
end else
result := picNone;
exit;
end else
case {$ifdef FPC}(PropProcs shr 2)and 3{$else}PropWrap(SetProc).Kind{$endif} of
ptField: begin // SetProc is an offset to the instance fields
Call.Data := pointer(PtrUInt(Instance)+SetProc{$ifndef FPC}and $00ffffff{$endif});
result := picField;
exit;
end;
ptVirtual: // SetProc is an offset to the class VMT
Call.Code := PPointer(PPtrUInt(Instance)^+{$ifndef FPC}word{$endif}(SetProc))^;
{$ifdef FPC} ptConst: exit(picNone); {$endif}
else // ptStatic: SetProc is the method code itself
Call.Code := pointer(SetProc);
end;
Call.Data := Instance;
if {$ifdef FPC}(PropProcs shr 6)and 1{$else}Index{$endif}<>NO_INDEX then
result := picIndexed else
result := picMethod;
end;
function TPropInfo.GetterAddr(Instance: pointer): pointer;
{$ifdef HASINLINENOTX86}
begin
result := Pointer(PtrUInt(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(PtrUInt(Instance)+SetProc{$ifndef FPC} and $00ffffff{$endif});
end;
function TPropInfo.TypeInfo: PTypeInfo;
{$ifdef HASINLINENOTX86}
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: db $f3 // rep ret
end;
{$endif HASINLINENOTX86}
function TPropInfo.GetterIsField: boolean;
begin
result := {$ifdef FPC}integer(PropProcs)and 3{$else}PropWrap(GetProc).Kind{$endif}=ptField;
end;
function TPropInfo.SetterIsField: boolean;
begin
result := {$ifdef FPC}(PropProcs shr 2)and 3{$else}PropWrap(SetProc).Kind{$endif}=ptField;
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;
{$ifdef HASINLINENOTX86}
function TPropInfo.Next: PPropInfo;
begin
result := AlignToPtr(PAnsiChar(@Name[0]) + SizeOf(Name[0]) + Length(Name));
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 HASINLINENOTX86}
function TPropInfo.WriteIsDefined: boolean;
begin
{$ifdef FPC} // see typinfo.IsWriteableProp
result := (SetProc<>0) and ((PropProcs shr 2)and 3 in [ptField..ptVirtual]);
{$else}
result := SetProc<>0;
{$endif}
end;
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=ptVirtual 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(PtrUInt(Instance))+Entry^.IOffset);
if Pointer(Obj)<>nil then
IInterface(Obj)._AddRef;
end
{$ifndef FPC} else
if PropWrap(Entry^.ImplGetter).Kind=ptField 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(PtrUInt(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 := GetClassParent(aClassType); // vmtParent slot is reference on FPC
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 := pointer(PAnsiChar(@Name[1])+ord(Name[0]));
if PtrUInt(result)-PtrUInt(@self)=Len then
result := nil; // no method details available
{$endif FPC}
end else
result := @self;
end;
function TReturnInfo.Param: PParamInfo;
begin
result := Pointer(PtrUInt(@self)+SizeOf(TReturnInfo));
end;
function TParamInfo.Next: PParamInfo;
begin
result := AlignToPtr(PAnsiChar(@Name[1])+ord(Name[0]));
{$ifdef ISDELPHI2010}
inc(PByte(result),PWord(result)^); // ignore optional attributes
{$endif}
end;
function InternalClassProp(ClassType: TClass): PClassProp;
{$ifdef FPC}
begin
with PTypeInfo(PPointer(PtrUInt(ClassType)+vmtTypeInfo)^)^.ClassType^ do
result := AlignToPtr(PAnsiChar(@UnitName[1])+ord(UnitName[0]));
{$else}
{$ifdef HASINLINENOTX86}
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 HASINLINENOTX86}
{$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 FPC}
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 := GetClassParent(ClassType);
end;
end;
function ClassHasPublishedFields(ClassType: TClass): boolean;
var CP: PClassProp;
begin
result := true;
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
exit;
ClassType := GetClassParent(ClassType);
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(GetClassParent(C),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;
P := AlignToPtr(PAnsiChar(@P^.Name[1])+ord(P^.Name[0])); // := P^.Next
end;
end;
ClassType := GetClassParent(ClassType);
end;
SetLength(result,n);
end;
function ClassFieldNamesAllProps(ClassType: TClass; IncludePropType: boolean;
Types: TTypeKinds): TRawUTF8DynArray;
var props: PPropInfoDynArray;
n,i: integer;
begin
result := nil;
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 aPropName: shortstring;
aCaseSensitive: boolean): PPropInfo;
var n, i: integer;
begin
while aClassType<>nil do begin
n := InternalClassPropInfo(aClassType,result);
if n<>0 then
if aCaseSensitive then
for i := 1 to n do
if result^.Name=aPropName then
exit else
result := result^.Next else
for i := 1 to n do
if (result^.Name[0]=aPropName[0]) and
IdemPropNameUSameLen(@result^.Name[1],@aPropName[1],ord(aPropName[0])) then
exit else
result := result^.Next;
aClassType := GetClassParent(aClassType);
end;
result := nil;
end;
function ClassFieldPropWithParentsFromUTF8(aClassType: TClass; PropName: PUTF8Char;
PropNameLen: integer; aCaseSensitive: boolean): PPropInfo;
var n, i: integer;
begin
if PropNameLen<>0 then
while aClassType<>nil do begin
n := InternalClassPropInfo(aClassType,result);
if n<>0 then
if aCaseSensitive then
for i := 1 to n do
if (result^.Name[0]=AnsiChar(PropNameLen)) and
CompareMemFixed(@result^.Name[1],PropName,PropNameLen) then
exit else
result := result^.Next else
for i := 1 to n do
if (result^.Name[0]=AnsiChar(PropNameLen)) and
IdemPropNameUSameLen(@result^.Name[1],PropName,PropNameLen) then
exit else
result := result^.Next;
aClassType := GetClassParent(aClassType);
end;
result := nil;
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 := GetClassParent(aClassType);
end;
result := nil;
end;
function ClassFieldPropWithParentsInheritsFromClassType(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^.InheritsFrom(aSearchedClassType)) then
exit else
result := result^.Next;
aClassType := GetClassParent(aClassType);
end;
result := nil;
end;
function ClassFieldPropWithParentsFromClassOffset(aClassType: TClass; aSearchedOffset: pointer): PPropInfo;
var i: integer;
begin
if aSearchedOffset<>nil then
while aClassType<>nil do begin
for i := 1 to InternalClassPropInfo(aClassType,result) do
if result^.GetFieldAddr(nil)=aSearchedOffset then
exit else
result := result^.Next;
aClassType := GetClassParent(aClassType);
end;
result := nil;
end;
function ClassFieldInstance(Instance: TObject; const PropName: shortstring;
PropClassType: TClass; out PropInstance): boolean;
var P: PPropInfo;
begin
result := false;
if Instance=nil then
exit;
P := ClassFieldPropWithParents(PPointer(Instance)^,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;
var P: PPropInfo;
begin
result := false;
if Instance=nil then
exit;
P := ClassFieldPropWithParentsFromClassType(PPointer(Instance)^,PropClassType);
if P=nil then
exit;
TObject(PropInstance) := P^.GetObjProp(Instance);
result := true;
end;
function ClassFieldInt64(Instance: TObject; const PropName: ShortString;
out PropValue: Int64): boolean;
var P: PPropInfo;
begin
result := false;
if Instance=nil then
exit;
P := ClassFieldPropWithParents(PPointer(Instance)^,PropName);
if P=nil then
exit;
PropValue := P^.GetInt64Value(Instance);
result := true;
end;
function ClassFieldInstances(Instance: TObject; PropClassType: TClass): TObjectDynArray;
var nested: PPropInfoDynArray;
i: integer;
begin
result := nil;
if Instance=nil then
exit;
nested := ClassFieldAllProps(PPointer(Instance)^,[tkClass]);
for i := 0 to high(nested) do
with nested[i]^ do
if PropType^.InheritsFrom(PropClassType) then
ObjArrayAdd(result,GetObjProp(Instance));
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;
{$ifndef NOVARIANTS}
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 not(dvoIsArray in arr.Options) 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;
function ObjectDefaultToVariant(aClass: TClass; aOptions: TDocVariantOptions): variant;
var instance: TClassInstance;
temp: TObject;
json: RawUTF8;
begin
VarClear(result);
instance.Init(aClass);
temp := instance.CreateNew;
try
json := ObjectToJSON(temp,[woDontStoreDefault]);
PDocVariantData(@result)^.InitJSONInPlace(pointer(json),aOptions);
finally
temp.Free;
end;
end;
{$endif}
type // those classes will be used to register globally some classes for JSON
TJSONSerializerRegisteredClassAbstract = class(TSynList)
protected
fLastClass: TClass;
fSafe: TSynLocker;
public
constructor Create; override;
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_STR_VAR;
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 NOVARIANTS}
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
ftDate, // sftDateTimeMS
ftInt64, // sftUnixTime = TUnixTime
ftInt64); // sftUnixMSTime = TUnixMSTime
function SQLFieldTypeToDBField(aSQLFieldType: TSQLFieldType; aTypeInfo: pointer): TSQLDBFieldType;
{$ifdef HASINLINE}inline;{$endif}
begin
{$ifndef NOVARIANTS}
if aSQLFieldType=sftNullable then
aSQLFieldType := NullableTypeToSQLFieldType(aTypeInfo);
{$endif}
result := SQLFIELDTYPETODBFIELDTYPE[aSQLFieldType];
end;
constructor TSQLPropInfo.Create(const aName: RawUTF8; aSQLFieldType: TSQLFieldType;
aAttributes: TSQLPropInfoAttributes; aFieldWidth, aPropertyIndex: integer);
begin
if aName='' then
raise EORMException.CreateUTF8('Void name for %.Create',[self]);
if aAuxiliaryRTreeField in aAttributes then
fName := copy(aName,2,MaxInt) else
fName := aName;
fNameUnflattened := fName;
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 tmp<>'' then
W.AddJSONEscape(pointer(tmp));
W.Add('"');
end else
W.AddRawJSON(tmp);
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.Options := [];
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:
if temp='' then
aValue.VType := ftNull else 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.IsValueVoid(Instance: TObject): boolean;
var temp: RawUTF8;
wasString: boolean;
begin
GetValueVar(Instance,true,temp,@wasString);
if wasString then
result := temp='' else
result := GetInt64(pointer(temp))=0;
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,'T',svoDateWithMS in aValue.Options),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; ValueLen: integer; 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,
varInt64,varInt64,varBoolean, varDouble, varDate,
// sftTimeLog, sftCurrency, sftObject,
varInt64, varCurrency, varNull,
// sftVariant, sftNullable sftBlob,sftBlobDynArray,
{$ifndef NOVARIANTS} varNull, varNull, {$endif} varString, varNull,
// sftBlobCustom, sftUTF8Custom, sftMany, sftModTime, sftCreateTime, sftTID,
varString, varString, varEmpty, varInt64, varInt64, varInt64,
// sftRecordVersion, sftSessionUserID, sftDateTimeMS, sftUnixTime, sftUnixMSTime
varInt64, varInt64, varDate, varInt64, varInt64);
procedure Complex;
var tmp: TSynTempBuffer;
begin
if (fieldType=sftBlobDynArray) and (typeInfo<>nil) and
(Value<>nil) and (Value^<>'[') and
Base64MagicCheckAndDecode(Value,tmp) then
Value := pointer(DynArrayBlobSaveJSON(typeInfo,tmp.buf)) else
if createValueTempCopy then
Value := tmp.Init(Value) else
tmp.buf := nil;
GetVariantFromJSON(Value,false,variant(result),@options);
tmp.Done;
end;
var err: integer;
begin
VarClear(variant(result));
result.VType := SQL_ELEMENTTYPES[fieldType];
result.VAny := nil; // avoid GPF
case fieldType of
sftCurrency:
result.VInt64 := StrToCurr64(Value);
sftFloat: begin
result.VDouble := GetExtended(Value,err);
if err<>0 then begin
result.VType := varString;
FastSetString(RawUTF8(result.VAny),Value,ValueLen);
end;
end;
sftDateTime, sftDateTimeMS:
Iso8601ToDateTimePUTF8CharVar(Value,0,result.VDate);
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, sftUnixTime, sftUnixMSTime:
SetInt64(Value,result.VInt64);
sftAnsiText, sftUTF8Text:
FastSetString(RawUTF8(result.VAny),Value,ValueLen);
sftBlobCustom, sftBlob:
BlobToTSQLRawBlob(Value,TSQLRawBlob(result.VAny));
{$ifndef NOVARIANTS}sftVariant, sftNullable,{$endif}
sftBlobDynArray, sftObject, sftUTF8Custom:
Complex;
end;
end;
function ObjectLoadVariant(var ObjectInstance; const aDocVariant: variant;
TObjectListItemClass: TClass; Options: TJSONToObjectOptions): boolean;
var tmp: RawUTF8;
begin
result := false;
if _Safe(aDocVariant)^.Kind=dvObject then
VariantSaveJSON(aDocVariant,twJSONEscape,tmp) else
if VariantToUTF8(aDocVariant, tmp) and (tmp<>'') and (tmp[1]='{') then
UniqueRawUTF8(tmp) else
exit;
JSONToObject(ObjectInstance,pointer(tmp),result,TObjectListItemClass,Options);
end;
procedure TSQLPropInfo.GetVariant(Instance: TObject; var Dest: Variant);
var temp: RawUTF8;
begin
GetValueVar(Instance,true,temp,nil);
ValueVarToVariant(pointer(temp),Length(temp),fSQLFieldTypeStored,TVarData(Dest),false,nil);
end;
procedure TSQLPropInfo.SetVariant(Instance: TObject; const Source: Variant);
begin
SetValueVar(Instance,VariantToUTF8(Source),
(TVarData(Source).VType=varOleStr) or (TVarData(Source).VType>=varString));
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;
{$ifndef NOVARIANTS}
val: variant;
{$endif}
begin
{$ifndef NOVARIANTS} // force JSON serialization, e.g. for dynamic arrays
if (DestInfo.SQLFieldType=sftVariant) or (SQLfieldType=sftVariant) then begin
GetVariant(Source,val);
DestInfo.SetVariant(Dest,val);
exit;
end;
{$endif}
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 }
var
SQLPropInfoRegistration: TSynDictionary = nil;
class procedure TSQLPropInfoRTTI.RegisterTypeInfo(aTypeInfo: Pointer);
begin
if SQLPropInfoRegistration=nil then
GarbageCollectorFreeAndNil(SQLPropInfoRegistration,
TSynDictionary.Create(TypeInfo(TPointerDynArray),TypeInfo(TPointerDynArray)));
SQLPropInfoRegistration.AddOrUpdate(aTypeInfo,self);
end;
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,aOptions);
end;
{$endif NOVARIANTS}
if result=nil then begin
aSQLFieldType := aType^.GetSQLFieldType;
C := nil;
if (SQLPropInfoRegistration=nil) or
not SQLPropInfoRegistration.FindAndCopy(aType,C) then
case aSQLFieldType of
sftUnknown, sftBlobCustom:
; // will raise an EORMException
sftBoolean, sftEnumerate:
C := TSQLPropInfoRTTIEnum;
sftTimeLog, sftModTime, sftCreateTime: // specific class for further use
C := TSQLPropInfoRTTITimeLog;
sftUnixTime: // specific class for further use
C := TSQLPropInfoRTTIUnixTime;
sftUnixMSTime:
C := TSQLPropInfoRTTIUnixMSTime;
sftCurrency:
C := TSQLPropInfoRTTICurrency;
sftDateTime, sftDateTimeMS:
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 NOVARIANTS}
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 matched type from RTTI 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},tkLStringOld{$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,aOptions);
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),length(temp),fSQLFieldTypeStored,TVarData(Dest),false,fPropInfo);
end;
{$endif NOVARIANTS}
constructor TSQLPropInfoRTTI.Create(aPropInfo: PPropInfo; aPropIndex: integer;
aSQLFieldType: TSQLFieldType; aOptions: TSQLPropInfoListOptions);
var attrib: TSQLPropInfoAttributes;
begin
byte(attrib) := 0;
if aPropInfo^.IsStored(nil)=AS_UNIQUE then
Include(attrib,aIsUnique); // property MyProperty: RawUTF8 stored AS_UNIQUE;
if (pilAuxiliaryFields in aOptions) and (aPropInfo^.Name[1] = '_') then
Include(attrib,aAuxiliaryRTreeField);
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 }
constructor TSQLPropInfoRTTIInt32.Create(aPropInfo: PPropInfo; aPropIndex: integer;
aSQLFieldType: TSQLFieldType; aOptions: TSQLPropInfoListOptions);
begin
inherited Create(aPropInfo,aPropIndex,aSQLFieldType,aOptions);
fUnsigned := fPropType^.OrdType in [otUByte,otUWord,otULong];
end;
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;
var v: integer;
begin
v := fPropInfo.GetOrdProp(Instance);
result := crc32cBy4(0,v); // better hash distribution using crc32c
end;
procedure TSQLPropInfoRTTIInt32.GetJSONValues(Instance: TObject; W: TJSONSerializer);
var v: integer;
begin
v := fPropInfo.GetOrdProp(Instance);
if fUnsigned then
W.AddU(cardinal(v)) else
W.Add(v);
end;
procedure TSQLPropInfoRTTIInt32.GetValueVar(Instance: TObject;
ToSQL: boolean; var result: RawUTF8; wasSQLString: PBoolean);
var v: integer;
begin
if wasSQLString<>nil then
wasSQLString^ := false;
v := fPropInfo.GetOrdProp(Instance);
if fUnsigned then
UInt32ToUtf8(cardinal(v),result) else
Int32ToUtf8(v,result);
end;
procedure TSQLPropInfoRTTIInt32.NormalizeValue(var Value: RawUTF8);
var err,v: integer;
begin
v := GetInteger(pointer(Value),err);
if err<>0 then
Value := '' else
if fUnsigned then
UInt32ToUtf8(cardinal(v),Value) else
Int32ToUtf8(v,Value);
end;
function TSQLPropInfoRTTIInt32.CompareValue(Item1, Item2: TObject; CaseInsensitive: boolean): PtrInt;
var A,B: integer;
begin
if Item1=Item2 then
result := 0 else
if Item1=nil then
result := -1 else
if Item2=nil then
result := 1 else begin
A := fPropInfo.GetOrdProp(Item1);
B := fPropInfo.GetOrdProp(Item2);
result := {$ifdef HASINLINE}CompareInteger{$else}SortDynArrayInteger{$endif}(A,B);
end;
end;
function TSQLPropInfoRTTIInt32.SetBinary(Instance: TObject; P,PEnd: PAnsiChar): PAnsiChar;
var c: cardinal;
begin
if P<>nil then begin
P := pointer(FromVarUInt32Safe(pointer(P),pointer(PEnd),c));
if P<>nil then
fPropInfo.SetOrdProp(Instance,integer(c));
end;
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);
var v: integer;
begin
aValue.Options := [];
aValue.VType := ftInt64;
v := fPropInfo.GetOrdProp(Instance);
if fUnsigned then
aValue.VInt64 := cardinal(v) else
aValue.VInt64 := v;
end;
{ TSQLPropInfoRTTISet }
constructor TSQLPropInfoRTTISet.Create(aPropInfo: PPropInfo; aPropIndex: integer;
aSQLFieldType: TSQLFieldType; aOptions: TSQLPropInfoListOptions);
begin
inherited Create(aPropInfo,aPropIndex,aSQLFieldType,aOptions);
fSetEnumType := fPropType^.SetEnumType;
end;
{ TSQLPropInfoRTTIEnum }
constructor TSQLPropInfoRTTIEnum.Create(aPropInfo: PPropInfo; aPropIndex: integer;
aSQLFieldType: TSQLFieldType; aOptions: TSQLPropInfoListOptions);
begin
inherited Create(aPropInfo,aPropIndex,aSQLFieldType,aOptions);
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
result := BOOL_UTF8[i<>0] else
UInt32ToUtf8(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
UInt32ToUtf8(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_STR_VAR;
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 }
constructor TSQLPropInfoRTTIInt64.Create(aPropInfo: PPropInfo; aPropIndex: integer;
aSQLFieldType: TSQLFieldType; aOptions: TSQLPropInfoListOptions);
begin
inherited Create(aPropInfo,aPropIndex,aSQLFieldType,aOptions);
fIsQWord := fPropType^.IsQword;
end;
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 V64: TQWordRec;
begin
if fGetterIsFieldPropOffset<>0 then
V64.V := PInt64(PtrUInt(Instance)+fGetterIsFieldPropOffset)^ else
V64.V := fPropInfo.GetInt64Prop(Instance);
result := crc32cBy4(V64.L,V64.H); // better hash distribution using crc32c
end;
procedure TSQLPropInfoRTTIInt64.GetJSONValues(Instance: TObject; W: TJSONSerializer);
var V64: Int64;
begin
if fGetterIsFieldPropOffset<>0 then
V64 := PInt64(PtrUInt(Instance)+fGetterIsFieldPropOffset)^ else
V64 := fPropInfo.GetInt64Prop(Instance);
if fIsQWord then
W.AddQ(V64) else
W.Add(V64);
end;
procedure TSQLPropInfoRTTIInt64.GetValueVar(Instance: TObject;
ToSQL: boolean; var result: RawUTF8; wasSQLString: PBoolean);
var V64: Int64;
begin
if wasSQLString<>nil then
wasSQLString^ := false;
if fGetterIsFieldPropOffset<>0 then
V64 := PInt64(PtrUInt(Instance)+fGetterIsFieldPropOffset)^ else
V64 := fPropInfo.GetInt64Prop(Instance);
if fIsQWord then
UInt64ToUtf8(V64,result) else
Int64ToUtf8(V64,result);
end;
procedure TSQLPropInfoRTTIInt64.NormalizeValue(var Value: RawUTF8);
var err: integer;
V64: Int64;
begin
if fIsQWord then begin
V64 := GetQWord(pointer(Value),err);
if err<>0 then
Value := '' else
UInt64ToUtf8(V64,Value);
end else begin
V64 := GetInt64(pointer(Value),err);
if err<>0 then
Value := '' else
Int64ToUtf8(V64,Value);
end;
end;
function TSQLPropInfoRTTIInt64.CompareValue(Item1, Item2: TObject; CaseInsensitive: boolean): PtrInt;
var V1,V2: 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 begin
V1 := PInt64(PtrUInt(Item1)+fGetterIsFieldPropOffset)^;
V2 := PInt64(PtrUInt(Item2)+fGetterIsFieldPropOffset)^;
end else begin
V1 := fPropinfo.GetInt64Prop(Item1);
V2 := fPropinfo.GetInt64Prop(Item2);
end;
if fIsQWord then
result := {$ifdef HASINLINE}CompareQWord{$else}SortDynArrayQWord{$endif}(V1,V2) else
result := {$ifdef HASINLINE}CompareInt64{$else}SortDynArrayInt64{$endif}(V1,V2);
end;
end;
function TSQLPropInfoRTTIInt64.SetBinary(Instance: TObject; P,PEnd: PAnsiChar): PAnsiChar;
begin
if P=nil then
result := nil else begin
result := P+SizeOf(Int64);
if result>PEnd then
result := nil else
fPropInfo.SetInt64Prop(Instance,PInt64(P)^);
end;
end;
procedure TSQLPropInfoRTTIInt64.SetValue(Instance: TObject; Value: PUTF8Char;
wasString: boolean);
var V64: Int64;
begin
if fIsQWord then
SetQWord(Value,PQword(@V64)^) else
SetInt64(Value,V64);
fPropInfo.SetInt64Prop(Instance,V64);
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.Options := [];
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
DoubleToStr(fPropInfo.GetDoubleProp(Instance),result);
if wasSQLString<>nil then
wasSQLString^ := (result='') or not (result[1] in ['0'..'9']);
end;
procedure TSQLPropInfoRTTIDouble.NormalizeValue(var Value: RawUTF8);
var VFloat: TSynExtended;
err: integer;
begin
VFloat := GetExtended(pointer(Value),err);
if err<>0 then
Value := '' else
DoubleToStr(VFloat,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;
begin
if Item1=Item2 then
result := 0 else
if Item1=nil then
result := -1 else
if Item2=nil then
result := 1 else
result := CompareFloat(fPropInfo.GetDoubleProp(Item1),fPropInfo.GetDoubleProp(Item2));
end;
function TSQLPropInfoRTTIDouble.GetHash(Instance: TObject; CaseInsensitive: boolean): cardinal;
var V: double;
begin
V := fPropInfo.GetDoubleProp(Instance);
with PQWordRec(@V)^ do
result := crc32cBy4(L,H); // better hash distribution using crc32c
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,PEnd: PAnsiChar): PAnsiChar;
begin
if P=nil then
result := nil else begin
result := P+SizeOf(double);
if result>PEnd then
result := nil else
fPropInfo.SetDoubleProp(Instance,unaligned(PDouble(P)^));
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.Options := [];
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 := CompareInt64(PInt64(@V1)^,PInt64(@V2)^);
end;
end;
function TSQLPropInfoRTTICurrency.GetHash(Instance: TObject; CaseInsensitive: boolean): cardinal;
var V: currency;
begin
V := fPropInfo.GetCurrencyProp(Instance);
with PQWordRec(@V)^ do
result := crc32cBy4(L,H); // better hash distribution using crc32c
end;
procedure TSQLPropInfoRTTICurrency.GetFieldSQLVar(Instance: TObject; var aValue: TSQLVar;
var temp: RawByteString);
begin
aValue.Options := [];
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,PEnd: PAnsiChar): PAnsiChar;
begin
if P=nil then
result := nil else begin
result := P+SizeOf(Currency);
if result>PEnd then
result := nil else
fPropInfo.SetCurrencyProp(Instance,PCurrency(P)^);
end;
end;
{ TSQLPropInfoRTTIDateTime }
procedure TSQLPropInfoRTTIDateTime.GetJSONValues(Instance: TObject; W: TJSONSerializer);
begin
W.Add('"');
W.AddDateTime(fPropInfo.GetDoubleProp(Instance),fSQLFieldType=sftDateTimeMS);
W.Add('"');
end;
function TSQLPropInfoRTTIDateTime.CompareValue(Item1,Item2: TObject; CaseInsensitive: boolean): PtrInt;
const PRECISION: array[boolean] of double = (1/SecsPerDay, 1/MSecsPerDay);
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,PRECISION[fSQLFieldType=sftDateTimeMS]) then
result := 0 else
if V1>V2 then
result := 1 else
result := -1;
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,fSQLFieldType=sftDateTimeMS);
end;
procedure TSQLPropInfoRTTIDateTime.NormalizeValue(var Value: RawUTF8);
begin
DateTimeToIso8601TextVar(Iso8601ToDateTime(Value),'T',Value,fSQLFieldType=sftDateTimeMS);
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
if fSQLFieldType=sftDateTimeMS then
aValue.Options := [svoDateWithMS] else
aValue.Options := [];
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,PEnd: PAnsiChar): PAnsiChar;
begin
result := P;
end;
{ TSQLPropInfoRTTIInstance }
constructor TSQLPropInfoRTTIInstance.Create(aPropInfo: PPropInfo; aPropIndex: integer;
aSQLFieldType: TSQLFieldType; aOptions: TSQLPropInfoListOptions);
begin
inherited Create(aPropInfo,aPropIndex,aSQLFieldType,aOptions);
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; aOptions: TSQLPropInfoListOptions);
begin
inherited Create(aPropInfo,aPropIndex,aSQLFieldType,aOptions);
fCascadeDelete := IdemPropName(fPropType^.Name,'TRecordReferenceToBeDeleted')
end;
{ TSQLPropInfoRTTITID }
constructor TSQLPropInfoRTTITID.Create(aPropInfo: PPropInfo; aPropIndex: integer;
aSQLFieldType: TSQLFieldType; aOptions: TSQLPropInfoListOptions);
var TypeName: PShortString;
ItemClass: TClass;
begin
inherited Create(aPropInfo,aPropIndex,aSQLFieldType,aOptions);
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;
tmp: TSynTempBuffer;
begin
tmp.Init(Value); // private copy since the buffer will be modified
try
PropInfo^.ClassFromJSON(Instance,tmp.buf,valid,JSONTOOBJECT_TOLERANTOPTIONS);
finally
tmp.Done;
end;
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,PEnd: PAnsiChar): PAnsiChar;
var valid: boolean;
tmp: TSynTempBuffer;
begin
// unserialize object from JSON UTF-8 TEXT - not fast, but works
FromVarString(PByte(P),PByte(PEnd),tmp);
try
PropInfo^.ClassFromJSON(Instance,tmp.buf,valid,JSONTOOBJECT_TOLERANTOPTIONS);
finally
tmp.Done;
end;
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; aOptions: TSQLPropInfoListOptions);
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,PEnd: PAnsiChar): PAnsiChar;
var tmp: RawByteString;
begin
FromVarString(PByte(P),PByte(PEnd),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 tmp<>'' 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.Options := [];
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 // don't know why, but fInPlaceCopySameClassPropOffset trick leaks memory :(
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
fPropInfo.GetLongStrProp(Instance,tmp);
if fPropType=TypeInfo(RawJSON) then
W.AddRawJSON(tmp) else begin
W.Add('"');
if tmp<>'' then
W.AddJSONEscape(pointer(tmp));
W.Add('"');
end;
end;
procedure TSQLPropInfoRTTIRawUTF8.GetValueVar(Instance: TObject;
ToSQL: boolean; var result: RawUTF8; wasSQLString: PBoolean);
begin
if wasSQLString<>nil then
wasSQLString^ := fPropType<>TypeInfo(RawJSON);
fPropInfo.GetLongStrProp(Instance,RawByteString(result));
end;
function TSQLPropInfoRTTIRawUTF8.SetBinary(Instance: TObject; P,PEnd: PAnsiChar): PAnsiChar;
begin
fPropInfo.SetLongStrProp(Instance,FromVarString(PByte(P),PByte(PEnd)));
result := P;
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.Options := [];
aValue.VType := ftUTF8;
aValue.VText := Pointer(temp);
end;
function TSQLPropInfoRTTIRawUTF8.CompareValue(Item1, Item2: TObject;
CaseInsensitive: boolean): PtrInt;
function CompareWithLocalTempCopy: PtrInt;
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;
var
offs: PtrUInt;
p1,p2: pointer;
begin
if Item1=Item2 then
result := 0 else
if Item1=nil then
result := -1 else
if Item2=nil then
result := 1 else begin
offs := fGetterIsFieldPropOffset;
if offs<>0 then begin // avoid any temporary variable
p1 := PPointer(PtrUInt(Item1)+offs)^;
p2 := PPointer(PtrUInt(Item2)+offs)^;
if CaseInsensitive then
result := UTF8IComp(p1,p2) else
result := StrComp(p1,p2);
end else
result := CompareWithLocalTempCopy;
end;
end;
procedure TSQLPropInfoRTTIRawUTF8.SetValue(Instance: TObject; Value: PUTF8Char;
wasString: boolean);
var tmp: RawUTF8;
begin
if Value<>nil then
FastSetString(tmp,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);
aValue.Options := [];
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,PEnd: PAnsiChar): PAnsiChar;
begin
fPropInfo.SetWideStrProp(Instance,
UTF8ToWideString(FromVarString(PByte(P),pointer(PEnd))));
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);
var tmp: UnicodeString;
begin
fPropInfo.GetUnicodeStrProp(Source,tmp);
TSQLPropInfoRTTIUnicode(DestInfo).fPropInfo.SetUnicodeStrProp(Dest,tmp);
end;
procedure TSQLPropInfoRTTIUnicode.GetBinary(Instance: TObject; W: TFileBufferWriter);
var tmp: UnicodeString;
begin
fPropInfo.GetUnicodeStrProp(Instance,tmp);
W.Write(UnicodeStringToUtf8(tmp));
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
fPropInfo.GetUnicodeStrProp(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 TSQLPropInfoRTTIUnicode.GetValueVar(Instance: TObject;
ToSQL: boolean; var result: RawUTF8; wasSQLString: PBoolean);
var tmp: UnicodeString;
begin
fPropInfo.GetUnicodeStrProp(Instance,tmp);
RawUnicodeToUtf8(pointer(tmp),length(tmp),result);
if wasSQLString<>nil then
wasSQLString^ := true;
end;
procedure TSQLPropInfoRTTIUnicode.GetJSONValues(Instance: TObject; W: TJSONSerializer);
var tmp: UnicodeString;
begin
W.Add('"');
fPropInfo.GetUnicodeStrProp(Instance,tmp);
if tmp<>'' 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
fPropInfo.GetUnicodeStrProp(Item1,tmp1);
fPropInfo.GetUnicodeStrProp(Item2,tmp2);
if CaseInsensitive then
result := AnsiICompW(pointer(tmp1),pointer(tmp2)) else
result := StrCompW(pointer(tmp1),pointer(tmp2));
end;
end;
function TSQLPropInfoRTTIUnicode.SetBinary(Instance: TObject; P,PEnd: PAnsiChar): PAnsiChar;
begin
fPropInfo.SetUnicodeStrProp(Instance,
UTF8DecodeToUnicodeString(FromVarString(PByte(P),pointer(PEnd))));
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);
var tmp: UnicodeString;
begin
fPropInfo.GetUnicodeStrProp(Instance,tmp);
RawUnicodeToUtf8(pointer(tmp),length(tmp),RawUTF8(temp));
aValue.Options := [];
aValue.VType := ftUTF8;
aValue.VText := Pointer(temp);
end;
{$endif HASVARUSTRING}
type
TObjArraySerializer = class(TPointerClassHashed)
protected
procedure DefaultCustomWriter(const aWriter: TTextWriter; const aValue);
function DefaultCustomReader(P: PUTF8Char; var aValue; out aValid: Boolean{$ifndef NOVARIANTS};
CustomVariantOptions: PDocVariantOptions{$endif}): PUTF8Char;
public
Instance: TClassInstance;
CustomReader: TDynArrayJSONCustomReader;
CustomWriter: TDynArrayJSONCustomWriter;
constructor Create(aInfo: pointer; aItem: TClass;
aReader: TDynArrayJSONCustomReader; aWriter: TDynArrayJSONCustomWriter); reintroduce;
end;
PTObjArraySerializer = ^TObjArraySerializer;
constructor TObjArraySerializer.Create(aInfo: pointer; aItem: TClass;
aReader: TDynArrayJSONCustomReader; aWriter: TDynArrayJSONCustomWriter);
begin
inherited Create(aInfo);
Instance.Init(aItem);
if Assigned(aReader) then
CustomReader := aReader else
CustomReader := DefaultCustomReader;
if Assigned(aWriter) then
CustomWriter := aWriter else
CustomWriter := DefaultCustomWriter;
end;
function HasDefaultObjArrayWriter(var dyn: TDynArray): boolean;
var CustomReader: TDynArrayJSONCustomReader;
CustomWriter, DefaultWriter: TDynArrayJSONCustomWriter;
begin
result := TTextWriter.GetCustomJSONParser(dyn,CustomReader,CustomWriter);
if result then begin
DefaultWriter := TObjArraySerializer(nil).DefaultCustomWriter;
result := PMethod(@CustomWriter)^.Code=PMethod(@DefaultWriter)^.Code;
end;
end;
procedure TObjArraySerializer.DefaultCustomWriter(const aWriter: TTextWriter; const aValue);
var opt: TTextWriterWriteObjectOptions;
begin
opt := DEFAULT_WRITEOPTIONS[twoIgnoreDefaultInRecord in aWriter.CustomOptions];
if twoEnumSetsAsTextInRecord in aWriter.CustomOptions then
include(opt,woEnumSetsAsText);
aWriter.WriteObject(TObject(aValue),opt);
end;
function TObjArraySerializer.DefaultCustomReader(P: PUTF8Char; var aValue;
out aValid: Boolean{$ifndef NOVARIANTS}; CustomVariantOptions: PDocVariantOptions{$endif}): PUTF8Char;
begin
if TObject(aValue)=nil then
TObject(aValue) := Instance.CreateNew;
result := JSONToObject(aValue,P,aValid,nil,JSONTOOBJECT_TOLERANTOPTIONS);
end;
function InternalIsObjArray(aDynArrayTypeInfo: pointer): TPointerClassHashed;
begin
result := ObjArraySerializers.Find(aDynArrayTypeInfo);
end;
{ TSQLPropInfoRTTIDynArray }
constructor TSQLPropInfoRTTIDynArray.Create(aPropInfo: PPropInfo;
aPropIndex: integer; aSQLFieldType: TSQLFieldType; aOptions: TSQLPropInfoListOptions);
var dummy: pointer;
begin
inherited Create(aPropInfo,aPropIndex,aSQLFieldType,aOptions);
fObjArray := aPropInfo^.DynArrayIsObjArrayInstance;
if fObjArray<>nil then
fSQLDBFieldType := ftUTF8; // matches GetFieldSQLVar() below
if fGetterIsFieldPropOffset=0 then
raise EModelException.CreateUTF8('%.Create(%) getter!',[self,fPropType^.Name]);
fWrapper.Init(fPropType,dummy);
fWrapper.IsObjArray := fObjArray<>nil;
fWrapper.HasCustomJSONParser; // set fWrapper.fParser
end;
procedure TSQLPropInfoRTTIDynArray.GetDynArray(Instance: TObject; var result: TDynArray);
begin // fast assignment of fWrapper pre-initialized RTTI
result.InitFrom(fWrapper,pointer(PtrUInt(Instance)+fGetterIsFieldPropOffset)^);
end;
procedure TSQLPropInfoRTTIDynArray.Serialize(Instance: TObject;
var data: RawByteString; ExtendedJson: boolean);
var da: TDynArray;
temp: TTextWriterStackBuffer;
begin
GetDynArray(Instance,da);
if da.Count=0 then
data := '' else
if fObjArray<>nil then
with TJSONSerializer.CreateOwnedStream(temp) 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 sda,dda: TDynArray;
begin
GetDynArray(Source,sda);
TSQLPropInfoRTTIDynArray(DestInfo).GetDynArray(Dest,dda);
if (fObjArray<>nil) or (TSQLPropInfoRTTIDynArray(DestInfo).fObjArray<>nil) or
(sda.ArrayType<>dda.ArrayType) then
dda.LoadFromJSON(pointer(sda.SaveToJSON)) else
dda.Copy(sda);
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;
da: TDynArray;
begin
GetDynArray(Instance,da);
json := da.SaveToJSON;
VarClear(Dest);
TDocVariantData(Dest).InitJSONInPlace(pointer(json),JSON_OPTIONS_FAST);
end;
procedure TSQLPropInfoRTTIDynArray.SetVariant(Instance: TObject; const Source: Variant);
var json: RawUTF8;
da: TDynArray;
begin
GetDynArray(Instance,da);
VariantSaveJSON(Source,twJSONEscape,json);
da.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;
i: integer;
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);
result := da1.Count-da2.Count;
if result<>0 then
exit;
result := PtrInt(Item1)-PtrInt(Item2); // pseudo comparison
if fObjArray<>nil then begin
for i := 0 to da1.Count-1 do
if not ObjectEquals(PObjectArray(da1.Value^)[i],PObjectArray(da2.Value^)[i]) then
exit;
end else
if not da1.Equals(da2) then
exit;
result := 0;
end;
end;
function TSQLPropInfoRTTIDynArray.SetBinary(Instance: TObject; P,PEnd: 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),PByte(PEnd),tmp);
try // T*ObjArray use JSON serialization
da.LoadFromJSON(tmp.buf);
finally
tmp.Done;
end;
result := P;
end else
// regular dynamic arrays use our binary encoding
result := da.LoadFrom(P,nil,{nohash=}true,PEnd);
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,nil,{nohash=}true,PAnsiChar(tmp.buf)+tmp.len) else
da.LoadFromJSON(tmp.Init(Value));
finally
tmp.Done;
end;
end;
function TSQLPropInfoRTTIDynArray.SetFieldSQLVar(Instance: TObject;
const aValue: TSQLVar): boolean;
var da: TDynArray;
begin
if aValue.VType=ftBlob then begin
GetDynArray(Instance,da);
result := da.LoadFrom(aValue.VBlob,nil,{nohash=}true,
PAnsiChar(aValue.VBlob)+aValue.VBlobLen)<>nil;
end 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);
aValue.Options := [];
if temp='' then
aValue.VType := ftNull else
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 := fWrapper.ElemType;
end;
{$ifndef NOVARIANTS}
{ TSQLPropInfoRTTIVariant }
constructor TSQLPropInfoRTTIVariant.Create(aPropInfo: PPropInfo; aPropIndex: integer;
aSQLFieldType: TSQLFieldType; aOptions: TSQLPropInfoListOptions);
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 value: Variant;
begin
fPropInfo.GetVariantProp(Instance,value);
result := VariantHash(value,CaseInsensitive);
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 will 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;
function CompareWithLocalTempCopy: PtrInt;
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
result := CompareWithLocalTempCopy;
end;
function TSQLPropInfoRTTIVariant.SetBinary(Instance: TObject; P,PEnd: PAnsiChar): PAnsiChar;
var value: Variant;
begin // use our VariantLoad() binary serialization
if fSQLFieldType=sftNullable then
result := VariantLoad(value,P,nil,PEnd) else
result := VariantLoad(value,P,@DocVariantOptions,PEnd);
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
if fSQLDBFieldType=ftDate then begin // decode as date/time variant
TVarData(V).VType := varDate;
TVarData(V).VDate := Iso8601ToDateTimePUTF8Char(Value,ValueLen);
end else
GetVariantFromJSON(tmp.buf,wasString,V,nil) else begin
if wasString and (GotoNextNotSpace(Value)^ in ['{','[']) then
wasString := false; // allow to create a TDocVariant stored as DB text
GetVariantFromJSON(tmp.buf,wasString,V,@DocVariantOptions);
end;
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 EModelException.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 tmp: TSynTempBuffer;
begin
RecordSave(GetFieldAddr(Instance)^,tmp,fTypeInfo);
result := crc32c(0,tmp.buf,tmp.len);
tmp.Done;
end;
{$ifndef NOVARIANTS}
procedure TSQLPropInfoRecordRTTI.GetVariant(Instance: TObject; var Dest: Variant);
begin
RawByteStringToVariant(RecordSave(GetFieldAddr(Instance)^,fTypeInfo),Dest);
end;
procedure TSQLPropInfoRecordRTTI.SetVariant(Instance: TObject; const Source: Variant);
var tmp: RawByteString;
begin
VariantToRawByteString(Source,tmp);
RecordLoad(GetFieldAddr(Instance)^,tmp,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,PEnd: PAnsiChar): PAnsiChar;
begin // use our RecordLoad() binary serialization
result := RecordLoad(GetFieldAddr(Instance)^,P,fTypeInfo,nil,PEnd);
end;
procedure TSQLPropInfoRecordRTTI.SetValue(Instance: TObject; Value: PUTF8Char;
wasString: boolean);
var data: RawByteString;
begin
TextToBinary(Value,data);
RecordLoad(GetFieldAddr(Instance)^,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.Options := [];
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
FastSetString(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,PEnd: PAnsiChar): PAnsiChar;
begin
result := P+fRecordSize;
if result>PEnd then
result := nil else
MoveFast(P^,GetFieldAddr(Instance)^,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.Options := [];
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,PEnd: PAnsiChar): PAnsiChar;
var tmp: TSynTempBuffer;
begin // stored as JSON VarString in the binary stream
if FromVarString(PByte(P),PByte(PEnd),tmp) then
try
SetValue(Instance,tmp.buf,false);
finally
tmp.Done;
end else
P := nil;
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;
temp: TTextWriterStackBuffer;
begin
W := TJSONSerializer.CreateOwnedStream(temp);
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;
B: PUTF8Char;
len: PtrInt;
tmp: RawUTF8;
begin
Data := GetFieldAddr(Instance);
if Value<>nil then begin // exact JSON string, array of objet ?
B := GotoNextJSONObjectOrArray(Value);
if (B=nil) and (Value^='"') then begin
B := GotoEndOfJSONString(Value);
if B^<>'"' then
B := nil;
end;
len := StrLen(Value);
if (B=nil) or (B-Value<>len) then begin
QuotedStrJSON(Value,len,tmp); // need escaping as JSON string
Value := pointer(tmp);
end;
end;
fCustomParser.ReadOneLevel(Value,Data,
[soReadIgnoreUnknownFields,soCustomVariantCopiedByReference],nil);
end;
{ TSQLPropInfoList }
constructor TSQLPropInfoList.Create(aTable: TClass; aOptions: TSQLPropInfoListOptions);
begin
fTable := aTable;
fOptions := aOptions;
if aTable.InheritsFrom(TSQLRecordRTreeAbstract) then
include(fOptions,pilAuxiliaryFields);
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(GetClassParent(aClassType),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 not(pilIgnoreIfGetter in fOptions) or P^.GetterIsField then
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(GetClassParent(aClassType));
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,NextGrow(result));
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
raise 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 J - L < R - I then begin // use recursion only for smaller range
if L < J then
QuickSortByName(L, J);
L := I;
end else begin
if I < R then
QuickSortByName(I, R);
R := J;
end;
until L >= 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 // fast O(log(n)) binary search
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 O(log(n)) 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 // O(n) iteration
exit;
end else begin
result := IndexByName(pointer(aName)); // faster O(log(n)) binary search
if result>=0 then
exit;
end;
raise EORMException.CreateUTF8(
'%.IndexByNameUnflattenedOrExcept(%): unkwnown field in %',[self,aName,fTable]);
end;
procedure StatusCodeToErrorMsgBasic(Code: integer; var result: RawUTF8);
begin // only basic verbs here -> SynCrtSock.StatusCodeToReason() used instead
case Code of
HTTP_CONTINUE: result := 'Continue';
HTTP_SUCCESS: result := 'OK';
HTTP_CREATED: result := 'Created';
HTTP_NOCONTENT: result := 'No Content';
HTTP_MOVEDPERMANENTLY: result := 'Moved Permanently';
HTTP_NOTMODIFIED: result := 'Not Modified';
HTTP_BADREQUEST: result := 'Bad Request';
HTTP_UNAUTHORIZED: result := 'Unauthorized';
HTTP_FORBIDDEN: result := 'Forbidden';
HTTP_NOTFOUND: result := 'Not Found';
HTTP_NOTALLOWED: result := 'Method Not Allowed';
HTTP_NOTACCEPTABLE: result := 'Not Acceptable';
HTTP_TIMEOUT: result := 'Request Timeout';
HTTP_SERVERERROR: result := 'Internal Server Error';
HTTP_NOTIMPLEMENTED: result := 'Not Implemented';
HTTP_GATEWAYTIMEOUT: result := 'Gateway Timeout';
HTTP_UNAVAILABLE: result := 'Service Unavailable';
else if StatusCodeIsSuccess(Code) then
result := 'Success' else
result := 'Invalid Request';
end;
end;
function StatusCodeToErrorMsg(Code: integer): shortstring;
var msg: RawUTF8;
begin
StatusCodeToErrorMessage(Code,msg);
FormatShort('HTTP Error % - %',[Code,msg],result);
end;
function StatusCodeIsSuccess(Code: integer): boolean;
begin
result := (Code>=HTTP_SUCCESS) and (Code<HTTP_BADREQUEST); // 200..399
end;
function AuthURI(const URI, URIAuthenticationBearer: RawUTF8): RawUTF8;
begin
if URIAuthenticationBearer='' then
result := URI else
if PosExChar('?',URI)=0 then
result := URI+'?authenticationbearer='+URIAuthenticationBearer else
result := URI+'&authenticationbearer='+URIAuthenticationBearer
end;
function ToMethod(const method: RawUTF8): TSQLURIMethod;
const NAME: array[mGET..high(TSQLURIMethod)] of string[10] = ( // 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 L: PtrInt;
N: PShortString;
begin
L := Length(method);
if L<11 then begin
N := @NAME;
for result := low(NAME) to high(NAME) do
if (L=ord(N^[0])) and IdemPropNameUSameLen(@N^[1],pointer(method),L) then
exit else
inc(PByte(N),11);
end;
result := mNone;
end;
function IsInvalidHttpHeader(head: PUTF8Char; headlen: PtrInt): boolean;
var i: PtrInt;
begin
result := true;
for i := 0 to headlen-3 do
if (PInteger(head+i)^=$0a0d0a0d) or
(PWord(head+i)^=$0d0d) or (PWord(head+i)^=$0a0a) then
exit;
result := false;
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
if typ=TypeInfo(TSynMonitorOneCount) then
result := smvOneCount 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;
ctp: TClass;
begin
n := length(Props);
while ClassType<>nil do begin
ctp := GetClassParent(ClassType);
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 (ctp<>nil) and (FindPropName(['Bytes','MicroSec'],p^.Name)>=0) then
ToText(ctp,p^.Name); // meaningful property name = parent name
for g := low(p^.Values) to high(p^.Values) do
SetLength(p^.Values[g],USAGE_VALUE_LEN[g]);
p^.ValueLast := nfo^.GetInt64Value(Instance);
inc(n);
end;
nfo := nfo^.Next;
end;
ClassType := ctp;
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
ToText(Instance.ClassType,instanceName);
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(PPointer(Instance)^,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;
function TSynMonitorUsage.Modified(Instance: TObject): integer;
begin
if self<>nil then
result := Modified(Instance,[]) else
result := 0;
end;
procedure TSynMonitorUsage.SetCurrentUTCTime(out minutes: TTimeLogBits);
begin
minutes.FromUTCTime;
end;
function TSynMonitorUsage.Modified(Instance: TObject;
const PropNames: array of RawUTF8; ModificationTime: TTimeLog): integer;
procedure save(const track: TSynMonitorUsageTrack);
function scope({$ifndef CPU64}var{$endif} 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
if ModificationTime=0 then
SetCurrentUTCTime(time) else
time.Value := ModificationTime;
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);
diff := v-ValueLast;
if diff<>0 then begin
inc(result);
ValueLast := v;
if Kind in SYNMONITORVALUE_CUMULATIVE then begin
inc(Values[mugHour][min],diff);
inc(Values[mugDay][time.Hour],diff); // propagate
inc(Values[mugMonth][time.Day-1],diff);
inc(Values[mugYear][time.Month-1],diff);
end else
for k := min to 59 do // make instant values continuous
Values[mugHour][k] := v;
end;
end;
end;
var i: integer;
begin
result := 0;
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
if Gran<low(fValues) then
raise ESynException.CreateUTF8('%.Save(%) unexpected',[self,ToText(Gran)^]);
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,true)] :=
Values[Gran][ID.GetTime(pred(Gran),true)];
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 (dvoIsArray in int^.Options) 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;
monthdaystartat0: boolean): 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:
if not monthdaystartat0 then
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;
function TSQLTable.FieldIndex(const FieldNames: array of RawUTF8;
const FieldIndexes: array of PInteger): integer;
var i: PtrInt;
begin
result := 0;
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 begin
FieldIndexes[i]^ := FieldIndex(pointer(FieldNames[i]));
if FieldIndexes[i]^>=0 then
inc(result);
end;
end;
procedure TSQLTable.FieldIndexExisting(const FieldNames: array of RawUTF8;
const FieldIndexes: array of PInteger);
var i: PtrInt;
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: TPUTF8CharDynArray;
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 GetBitPtr(@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 GetBitPtr(@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
SetBitPtr(@Bits,i); // slow but accurate
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 GetBitPtr(@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 GetBitPtr(@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;
IDmax: integer;
// AllID: : TIDDynArray;
begin
if length(IDs)=fRowCount then begin // all selected -> all bits set to 1
FillCharFast(Bits,(fRowCount shr 3)+1,255);
exit;
end;
FillCharFast(Bits,(fRowCount shr 3)+1,0);
if IDs=nil then
exit; // no selected -> all bits left to 0
// we sort IDs to use FastFindInt64Sorted() and its O(log(n)) binary search
ID := @IDs[0];
IDmax := length(IDs)-1;
QuickSortInt64(ID,0,IDmax);
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 fRowCount do
if FastFindInt64Sorted(ID,IDmax,GetInt64(fIDColumn[i]))>=0 then
SetBitPtr(@Bits,i-1);
end else begin
U := @fResults[FID+FieldCount]; // U^ = ID column UTF-8 content
for i := 0 to fRowCount-1 do begin
if FastFindInt64Sorted(ID,IDmax,GetInt64(U^))>=0 then
SetBitPtr(@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; aNotFoundMinusOne: boolean): 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;
if aNotFoundMinusOne then
result := -1 else
result := fRowCount; // not found -> return last row index
end;
function TSQLTable.DeleteRow(Row: integer): boolean;
begin
if (self=nil) or (Row<1) or (Row>fRowCount) then begin
result := false;
exit; // out of range
end;
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);
result := true;
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
FastSetString(fFieldNames[f],P,StrLen(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 fFieldType=nil 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
id.ToVariant(value) 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 then
case ContentType of
sftTimeLog,sftModTime,sftCreateTime,sftUnixTime: begin
SetInt64(V,t.Value);
if t.Value=0 then
value := 0 else begin
if ContentType=sftUnixTime then
t.FromUnixTime(t.Value);
TDocVariantData(value).InitObject(['Time',t.Text(true),'Value',t.Value],JSON_OPTIONS_FAST);
end;
exit;
end;
sftUnixMSTime: begin // no TTimeLog use for milliseconds resolution
SetInt64(V,t.Value);
if t.Value=0 then
value := 0 else
TDocVariantData(value).InitObject(['Time',UnixMSTimeToString(t.Value),'Value',t.Value],JSON_OPTIONS_FAST);
exit;
end;
end;
ValueVarToVariant(V,StrLen(V),ContentType,TVarData(value),true,ContentTypeInfo,options);
end;
end;
procedure TSQLTable.ToDocVariant(Row: integer; out doc: variant;
options: TDocVariantOptions; expandTimeLogAsText,expandEnumsAsText,
expandHugeIDAsUniqueIdentifier: boolean);
var f: integer;
v: TVariantDynArray;
begin
if (self=nil) or (Row<1) or (Row>fRowCount) then
exit; // out of range
SetLength(v,fFieldCount);
for f := 0 to fFieldCount-1 do
GetAsVariant(Row,f,v[f],expandTimeLogAsText,expandEnumsAsText,
expandHugeIDAsUniqueIdentifier,options);
if length(fFieldNames)<>fFieldCount then
InitFieldNames;
TDocVariantData(doc).InitObjectFromVariants(fFieldNames,v,JSON_OPTIONS_FAST);
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}
function TSQLTable.DeleteColumnValues(Field: integer): boolean;
var i: integer;
U: PPUTF8Char;
begin
if cardinal(Field)>=cardinal(FieldCount) then begin
result := false;
exit; // out of range
end;
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;
result := true;
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;
result := sftUnknown;
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 := PosExChar('.',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;
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 else
if Field>=length(fFieldType) then
SetLength(fFieldType,Field+1); // e.g. from TSQLTableWritable.AddField
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;
{$ifndef NOVARIANTS}
sftNullable: begin
ContentTypeInfo := FieldTypeInfo;
ContentType := NullableTypeToSQLFieldType(FieldTypeInfo);
if ContentType=sftUnknown then
ContentType := sftNullable;
end;
{$endif NOVARIANTS}
end;
{$ifndef NOVARIANTS}
if ContentType in [sftVariant,sftNullable] then
ContentDB := ftUnknown else // ftUTF8/ftNull are not precise enough
{$endif NOVARIANTS}
ContentDB := SQLFIELDTYPETODBFIELDTYPE[ContentType];
TableIndex := FieldTableIndex;
end;
end;
procedure TSQLTable.SetFieldType(const FieldName: RawUTF8; FieldType: TSQLFieldType;
FieldTypeInfo: pointer; FieldSize: integer);
begin
SetFieldType(FieldIndex(FieldName),FieldType,FieldTypeInfo,FieldSize);
end;
const
DBTOFIELDTYPE: array[TSQLDBFieldType] of TSQLFieldType = (sftUnknown,
sftUnknown,sftInteger,sftFloat,sftCurrency,sftDateTime,sftUTF8Text,sftBlob);
procedure TSQLTable.SetFieldTypes(const DBTypes: TSQLDBFieldTypeDynArray);
var f: integer;
begin
if length(DBTypes)<>FieldCount then
raise ESQLTableException.CreateUTF8('%.SetFieldTypes(DBTypes?)',[self]);
for f := 0 to FieldCount-1 do
SetFieldType(f,DBTOFIELDTYPE[DBTypes[f]]);
end;
function TSQLTable.GetRowCount: integer;
begin
if self=nil then
result := 0 else
result := fRowCount;
end;
procedure TSQLTable.InitFieldTypes;
var f,i,len: integer;
sft: TSQLFieldType;
info: pointer;
prop: TSQLPropInfo;
size,tableindex: integer;
U: PPUTF8Char;
guessed: boolean;
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
prop := nil;
info := nil;
size := -1;
tableindex := -1;
guessed := false;
// init fFieldType[] from fQueryTables/fQueryColumnTypes[]
if Assigned(fQueryColumnTypes) then
sft := fQueryColumnTypes[f] else
if Assigned(QueryTables) then begin // retrieve column info from field name
sft := FieldPropFromTables(fResults[f],prop,tableindex);
if prop<>nil then begin
if prop.InheritsFrom(TSQLPropInfoRTTI) then
info := TSQLPropInfoRTTI(prop).PropType;
size := prop.FieldWidth;
end;
end else
sft := sftUnknown;
if sft=sftUnknown then
// not found in fQueryTables/fQueryColumnTypes[]: guess from content
if IsRowID(fResults[f]) then
sft := sftInteger else begin
guessed := true;
if f in fFieldParsedAsString then begin
// the parser identified string values -> check if was sftDateTime
sft := 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
sft := sftDateTime else // e.g. YYYYMMDD date (Y=1800..2100)
if len>=15 then
sft := sftDateTime; // e.g. YYYYMMDDThhmmss date/time value
break;
end;
end else begin
U := @fResults[FieldCount+f];
for i := 1 to fRowCount do begin
sft := UTF8ContentNumberType(U^);
inc(U,FieldCount);
if sft=sftUnknown then
continue else // null -> search for a non void column
if sft=sftInteger then // may be a floating point with no decimal
if FieldTypeIntegerDetectionOnAllRows then
continue else
// we only checked the first field -> best guess...
sft := sftCurrency;
break; // found a non-integer content (e.g. sftFloat/sftUtf8Text)
end;
end;
end;
SetFieldType(f,sft,info,size,tableindex);
if guessed then
fFieldType[f].ContentDB := ftUnknown; // may fail on some later row
end;
end;
function TSQLTable.FieldType(Field: integer): TSQLFieldType;
begin
if (self<>nil) and (cardinal(Field)<cardinal(FieldCount)) then begin
if fFieldType=nil then
InitFieldTypes;
result := fFieldType[Field].ContentType;
end else
result := sftUnknown;
end;
function TSQLTable.FieldType(Field: integer; out FieldTypeInfo: PSQLTableFieldType): TSQLFieldType;
begin
if (self<>nil) and (cardinal(Field)<cardinal(FieldCount)) then begin
if fFieldType=nil then
InitFieldTypes;
FieldTypeInfo := @fFieldType[Field];
result := FieldTypeInfo^.ContentType;
end else begin
FieldTypeInfo := nil;
result := sftUnknown;
end;
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];
FastSetString(Result,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));
sftUnixTime:
result := UnixTimeToDateTime(GetInt64(P));
sftUnixMSTime:
result := UnixMSTimeToDateTime(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;
begin
BlobToTSQLRawBlob(P,result);
end;
procedure BlobToTSQLRawBlob(P: PUTF8Char; var result: TSQLRawBlob);
var Len, LenHex: integer;
begin
result := '';
Len := StrLen(P);
if Len=0 then
exit;
if Len>=3 then
if (P[0] in ['x','X']) and (P[1]='''') and (P[Len-1]='''') then begin
// BLOB literals are string literals containing hexadecimal data and
// preceded by a single "x" or "X" character. For example: X'53514C697465'
LenHex := (Len-3) shr 1;
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
Base64ToBinSafe(@P[3],Len-3,RawByteString(result)) then
exit; // safe decode Base-64 content ('\uFFF0base64encodedbinary')
// 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 Len>=3 then
if (P[0] in ['x','X']) and (P[1]='''') and (P[Len-1]='''') then begin
// BLOB literals are string literals containing hexadecimal data and
// preceded by a single "x" or "X" character. For example: X'53514C697465'
LenHex := (Len-3) shr 1;
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
Base64ToBinSafe(@P[3],Len-3,RawByteString(result)) then
exit; // safe decode Base-64 content ('\uFFF0base64encodedbinary')
// 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 Len>=3 then
if (P[0] in ['x','X']) and (P[1]='''') and (P[Len-1]='''') then begin
// BLOB literals format
LenResult := (Len-3)shr 1;
SetLength(Result,LenResult);
if 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;
// 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^<=' ') and (P^<>#0) do inc(P);
if (P[0] in ['x','X']) and (P[1]='''') then begin
Len := (StrLen(P)-3) shr 1;
result := (P[Len-1]='''') and 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;
function TSQLTable.GetDateTime(Row, Field: integer): TDateTime;
begin
result := Iso8601ToDateTimePUTF8Char(Get(Row,Field),0)
end;
function TSQLTable.GetRowValues(Field: integer; out Values: TRawUTF8DynArray): integer;
var i: integer;
U: PPUTF8Char;
begin
result := 0;
if (self=nil) or (cardinal(Field)>cardinal(FieldCount)) or (fRowCount=0) then
exit;
SetLength(Values,fRowCount);
U := @fResults[FieldCount+Field]; // start reading after first Row (= Field Names)
for i := 0 to fRowCount-1 do begin
FastSetString(Values[i],U^,StrLen(U^));
inc(U,FieldCount); // go to next row
end;
result := fRowCount;
end;
function TSQLTable.GetRowValues(Field: integer; out Values: TInt64DynArray): integer;
var i: integer;
U: PPUTF8Char;
begin
result := 0;
if (self=nil) or (cardinal(Field)>cardinal(FieldCount)) or (fRowCount=0) 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;
result := fRowCount;
end;
function TSQLTable.GetRowLengths(Field: integer; var LenStore: TSynTempBuffer): integer;
var len: PInteger;
i: integer;
U: PPUTF8Char;
begin
result := 0;
if (self=nil) or (cardinal(Field)>cardinal(FieldCount)) or (fRowCount=0) then begin
LenStore.buf := nil; // avoid GPF in LenStore.Done
exit;
end;
U := @fResults[FieldCount+Field]; // start reading after first Row (= Field Names)
len := LenStore.Init(fRowCount*SizeOf(len^));
for i := 1 to fRowCount do begin
len^ := StrLen(U^);
inc(result,len^);
inc(len);
inc(U,FieldCount); // go to next row
end;
end;
function TSQLTable.GetRowValues(Field: integer; const Sep,Head,Trail: RawUTF8): RawUTF8;
var i, L, SepLen: integer;
U: PPUTF8Char;
P: PUTF8Char;
len: PInteger;
tmp: TSynTempBuffer;
begin
L := GetRowLengths(Field,tmp);
if L=0 then begin
result := Head+Trail;
exit;
end;
SepLen := length(Sep);
inc(L,length(Head)+SepLen*(fRowCount-1)+length(Trail));
FastSetString(result,nil,L);
P := AppendRawUTF8ToBuffer(pointer(result),Head);
U := @fResults[FieldCount+Field]; // start reading after first Row (= Field Names)
len := tmp.buf;
for i := 2 to fRowCount do begin
MoveFast(U^^,P^,len^);
inc(P,len^);
if SepLen>0 then begin
MoveSmall(pointer(Sep),P,SepLen);
inc(P,SepLen);
end;
inc(len);
inc(U,FieldCount); // go to next row
end;
MoveFast(U^^,P^,len^); // last row without Sep
if Trail<>'' then
MoveFast(pointer(Trail)^,P[len^],length(Trail));
tmp.Done;
end;
procedure TSQLTable.GetJSONValues(W: TJSONWriter; RowFirst, RowLast, IDBinarySize: integer);
var U: PPUTF8Char;
f,r: PtrInt;
i64: Int64;
label nostr,str;
begin
if (self=nil) or (FieldCount<=0) or (fRowCount<=0) then begin
W.Add('[',']');
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 fFieldType=nil then
InitFieldTypes;
SetLength(W.ColNames,FieldCount);
for f := 0 to FieldCount-1 do begin
W.ColNames[f] := fResults[f]; // first Row is field Names
if not Assigned(OnExportValue) then
if (f=fFieldIndexID) and (IDBinarySize>0) then
W.ColNames[f] := 'id'; // ajax-friendly
end;
W.AddColumns(RowLast-RowFirst+1); // write or init field names (see JSON Expand)
if W.Expand then
W.Add('[');
// write rows data
U := @fResults[FieldCount*RowFirst];
for r := RowFirst to RowLast do begin
if W.Expand then
W.Add('{');
for f := 0 to FieldCount-1 do begin
if W.Expand then
W.AddString(W.ColNames[f]); // '"'+ColNames[]+'":'
if Assigned(OnExportValue) then
W.AddString(OnExportValue(self,r,f,false)) else
if (IDBinarySize>0) and (f=fFieldIndexID) then begin
SetInt64(U^,i64);
W.AddBinToHexDisplayQuoted(@i64,IDBinarySize);
end else
if U^=nil then
W.AddShort('null') else
case fFieldType[f].ContentDB of
ftInt64,ftDouble,ftCurrency:
nostr: W.AddNoJSONEscape(U^,StrLen(U^));
ftDate,ftUTF8,ftBlob: begin
str: W.Add('"');
W.AddJSONEscape(U^);
W.Add('"');
end;
else if IsStringJSON(U^) then // fast and safe enough
goto str else
goto nostr;
end;
W.Add(',');
inc(U); // points to next value
end;
W.CancelLastComma;
if W.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,false); // "RowCount": set by W.AddColumns() above
end;
procedure TSQLTable.GetJSONValues(JSON: TStream; Expand: boolean;
RowFirst, RowLast, IDBinarySize: integer);
var W: TJSONWriter;
tmp: TTextWriterStackBuffer;
begin
W := TJSONWriter.Create(JSON,Expand,false,nil,0,@tmp);
try
GetJSONValues(W,RowFirst,RowLast,IDBinarySize);
W.FlushFinal;
finally
W.Free;
end;
end;
function TSQLTable.GetJSONValues(Expand: boolean; IDBinarySize, BufferSize: integer): RawUTF8;
var W: TJSONWriter;
tmp: TTextWriterStackBuffer;
begin
if BufferSize<SizeOf(tmp) then
W := TJSONWriter.CreateOwnedStream(tmp) else
W := TJSONWriter.CreateOwnedStream(BufferSize);
try
W.Expand := Expand;
GetJSONValues(W,0,0,IDBinarySize); // create JSON data in MS
W.SetText(result);
finally
W.Free;
end;
end;
procedure TSQLTable.GetCSVValues(Dest: TStream; Tab: boolean; CommaSep: AnsiChar;
AddBOM: boolean; RowFirst,RowLast: integer);
var U: PPUTF8Char;
F,R,FMax: integer;
W: TTextWriter;
temp: TTextWriterStackBuffer;
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,@temp,SizeOf(temp));
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,false)) 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; RowFirst,RowLast: integer): 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: TTextWriter;
f,r: integer;
U: PPUTF8Char;
begin
W := TTextWriter.Create(Dest,32768);
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 fFieldType=nil then
InitFieldTypes;
// 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[fFieldType[f].ContentDB]);
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('=','"');
W.AddXmlEscape(U^);
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(withColumnTypes: boolean): 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('" />');
if (self<>nil) and ((FieldCount>0) or (fRowCount>0)) then begin
if withColumnTypes and (fFieldType=nil) then
InitFieldTypes;
U := pointer(fResults);
for r := 0 to fRowCount do begin
W.AddShort('<table:table-row>');
if withColumnTypes and (r>0) then begin
for f := 0 to FieldCount-1 do begin
W.AddShort('<table:table-cell office:value-type="');
case fFieldType[f].ContentDB of
ftInt64,ftDouble,ftCurrency: begin
W.AddShort('float" office:value="');
W.AddXmlEscape(U^);
W.AddShort('" />');
end;
ftDate: begin
W.AddShort('date" office:date-value="');
W.AddXmlEscape(U^);
W.AddShort('" />');
end;
else begin //ftUnknown,ftNull,ftUTF8,ftBlob:
W.AddShort('string"><text:p>');
W.AddXmlEscape(U^);
W.AddShort('</text:p></table:table-cell>');
end;
end;
inc(U); // points to next value
end;
end else
for f := 0 to FieldCount-1 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);
end;
W.AddShort('</table:table-row>');
end;
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;
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,true),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;
temp: TTextWriterStackBuffer;
begin
W := TTextWriter.CreateOwnedStream(temp);
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;
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: TDateTime;
begin
if P1=P2 then begin
result := 0;
exit;
end;
Iso8601ToDateTimePUTF8CharVar(P1,0,V1);
Iso8601ToDateTimePUTF8CharVar(P2,0,V2);
if (V1=0) or (V2=0) then // any invalid date -> compare as strings
result := StrComp(P1,P2) else
if SameValue(V1,V2,1/MSecsPerDay) then
result := 0 else
if V1<V2 then
result := -1 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 NOVARIANTS}
nil, // Blob
nil, // BlobDynArray
nil, // BlobCustom
nil, // UTF8Custom
nil,
UTF8CompareInt64, // TModTime
UTF8CompareInt64, // TCreateTime
UTF8CompareInt64, // TID
UTF8CompareInt64, // TRecordVersion
UTF8CompareInt64, // TSessionUserID
UTF8CompareISO8601, // TDateTimeMS
UTF8CompareInt64, // TUnixTime
UTF8CompareInt64); // TUnixMSTime
type
/// a static object is used for smaller recursive stack size and faster code
// - these special sort implementation do the comparison 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...
{$ifdef USERECORDWITHMETHODS}TUTF8QuickSort = record
{$else}TUTF8QuickSort = object{$endif}
public
// sort parameters
Results: PPUtf8CharArray;
IDColumn: PPUtf8CharArray;
Params: TSQLTableSortParams;
CurrentRow: PtrInt;
// avoid multiplications to calculate data memory position from index
FieldCountNextPtr, FieldFirstPtr, FieldIDPtr: PtrUInt;
// temp vars (avoid stack usage):
PID: Int64;
PP, CI, CJ: PPUTF8Char;
I, J: PtrInt;
/// recursively perform the sort
procedure Sort(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(PtrUInt(aPP)-FieldIDPtr)^,PID);
end;
function TUTF8QuickSort.CompI: integer;
var i64: Int64;
begin
result := Params.Comp(CI^,PP^);
if result=0 then begin
// same value -> sort by ID
if Assigned(IDColumn) then
SetInt64(IDColumn[I],i64) else
SetInt64(PPUTF8Char(PtrUInt(CI)-FieldIDPtr)^,i64);
if i64<PID then
result := -1 else
if i64<>PID then
result := +1;
end;
end;
function TUTF8QuickSort.CompJ: integer;
var i64: Int64;
begin
result := Params.Comp(CJ^,PP^);
if result=0 then begin
// same value -> sort by ID
if Assigned(IDColumn) then
SetInt64(IDColumn[J],i64) else
SetInt64(PPUTF8Char(PtrUInt(CJ)-FieldIDPtr)^,i64);
if i64<PID then
result := -1 else
if i64<>PID then
result := +1;
end;
end;
procedure ExchgFields(P1,P2: PPointer; FieldCount: PtrUInt);
{$ifdef CPUX86} {$ifdef FPC} nostackframe; assembler; {$endif}
asm // eax=P1 edx=P2 ecx=FieldCount
push esi
push edi
@1: mov esi, [eax]
mov edi, [edx]
mov [edx], esi
mov [eax], edi
add eax, 4
add edx, 4
dec ecx
jnz @1
pop edi
pop esi
end;
{$else} inline;
var p: pointer;
begin
repeat
p := P1^;
P1^ := P2^;
P2^ := p;
inc(P1);
inc(P2);
dec(FieldCount);
until FieldCount=0;
end;
{$endif CPUX86}
procedure ExchgPointer(p1,p2: PPointer); {$ifdef HASINLINE}inline;{$endif}
var p: pointer;
begin
p := p2^;
p2^ := p1^;
p1^ := p;
end;
procedure TUTF8QuickSort.Sort(L, R: Integer);
var P: PtrInt;
begin
if @Params.Comp<>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 compIJ
if Params.Asc then begin // ascending order comparison
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 comparison
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
ExchgFields(pointer(PtrUInt(CI)-FieldFirstPtr),pointer(PtrUInt(CJ)-FieldFirstPtr),
Params.FieldCount); // exchange PUTF8Char for whole I,J rows
if Assigned(IDColumn) then // exchange hidden ID column also
ExchgPointer(@IDColumn[I],@IDColumn[J]);
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;
if J - L < R - I then begin // use recursion only for smaller range
P := I; // I,J will be overriden in QuickSort() call
if L < J then
Sort(L, J);
L := P;
end else begin
P := J;
if I < R then
Sort(I, R);
R := P
end;
until L >= R;
end;
procedure TSQLTable.SortFields(const FieldName: RawUTF8; Asc: boolean;
PCurrentRow: PInteger; FieldType: TSQLFieldType; CustomCompare: TUTF8Compare);
begin
SortFields(FieldIndex(FieldName),Asc,PCurrentRow,FieldType,CustomCompare);
end;
procedure TSQLTable.SortFields(Field: integer; Asc: boolean; PCurrentRow: PInteger;
FieldType: TSQLFieldType; CustomCompare: TUTF8Compare);
var quicksort: 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);
// store sorting parameters for re-sort in TSQLTableJSON.FillFrom()
if Assigned(CustomCompare) then
fSortParams.Comp := CustomCompare else begin
fSortParams.Comp := SQLFieldTypeComp[FieldType];
if @fSortParams.Comp=nil then
exit;
end;
fSortParams.FieldType := FieldType;
fSortParams.FieldCount := FieldCount;
fSortParams.FieldIndex := Field;
fSortParams.Asc := Asc;
// this sort routine is very fast, thanks to the dedicated static object
quicksort.Params := fSortParams;
quicksort.Results := fResults;
quicksort.IDColumn := @fIDColumn[0];
quicksort.FieldCountNextPtr := FieldCount*SizeOf(PtrInt);
quicksort.FieldFirstPtr := Field*SizeOf(PtrInt);
if fFieldIndexID<0 then // if no ID colum, assume first
quicksort.FieldIDPtr := quicksort.FieldFirstPtr else
quicksort.FieldIDPtr := (Field-fFieldIndexID)*SizeOf(PtrInt);
if PCurrentRow=nil then
quicksort.CurrentRow := -1 else
quicksort.CurrentRow := PCurrentRow^;
if fRowCount>1 then // ignore first row = field names -> (1,RowCount)
quicksort.Sort(1,fRowCount);
if PCurrentRow<>nil then
PCurrentRow^ := quicksort.CurrentRow;
end;
function TSQLTable.SearchFieldSorted(const Value: RawUTF8; FieldIndex: integer;
CustomCompare: TUTF8Compare): integer;
begin
result := SearchFieldSorted(pointer(Value),FieldIndex,CustomCompare);
end;
function TSQLTable.SearchFieldSorted(Value: PUTF8Char; FieldIndex: integer;
CustomCompare: TUTF8Compare): integer;
var L,R,cmp: integer;
begin
if (self<>nil) and (Value<>nil) and (fRowCount>0) and
(cardinal(FieldIndex)<cardinal(fFieldCount)) then begin
if not Assigned(CustomCompare) then
CustomCompare := fSortParams.Comp;
if Assigned(CustomCompare) then begin // fast binary search
L := 1;
R := fRowCount;
repeat
result := (L+R) shr 1;
cmp := CustomCompare(fResults[result*fFieldCount+FieldIndex],Value);
if cmp=0 then
exit;
if cmp<0 then
L := result+1 else
R := result-1;
until L>R;
result := 0;
end else
result := SearchFieldEquals(Value,FieldIndex);
end else
result := 0;
end;
type
{$ifdef USERECORDWITHMETHODS}TUTF8QuickSortMulti = record
{$else}TUTF8QuickSortMulti = object{$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 Sort(L, R: Integer);
end;
function TUTF8QuickSortMulti.Compare(A,B: integer): integer;
var i: PtrInt;
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.Sort(L, R: Integer);
var I,J,P: integer;
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
ExchgFields(pointer(PtrUInt(@Results[I*FieldCount])),
pointer(PtrUInt(@Results[J*FieldCount])),FieldCount);
if Assigned(IDColumn) then // update hidden ID column also
ExchgPointer(@IDColumn[I],@IDColumn[J]);
end;
if P=I then
P := J else
if P=J then
P := I;
inc(I);
dec(J);
end;
until I>J;
if J - L < R - I then begin // use recursion only for smaller range
if L < J then
Sort(L, J);
L := I;
end else begin
if I < R then
Sort(I, R);
R := J;
end;
until L >= R;
end;
procedure TSQLTable.SortFields(const Fields: array of integer;
const Asc: array of boolean; const CustomCompare: array of TUTF8Compare);
var quicksort: TUTF8QuickSortMulti;
i: integer;
begin
if (self=nil) or (fRowCount<=1) or (FieldCount<=0) or (length(Fields)=0) then
exit;
quicksort.FieldCount := FieldCount;
quicksort.IndexMax := high(Fields);
SetLength(quicksort.Index,quicksort.IndexMax+1);
for i := 0 to quicksort.IndexMax do
with quicksort.Index[i] do begin
if i<=high(CustomCompare) then
Comp := CustomCompare[i];
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
if @Comp=nil then
Comp := @UTF8CompareInt64;
end;
continue;
end;
if @Comp=nil then
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<=quicksort.IndexMax) and not Asc[i] then
quicksort.Index[i].Desc := true;
quicksort.Results := fResults;
quicksort.IDColumn := @fIDColumn[0];
quicksort.Sort(1,fRowCount); // ignore first row = field names -> (1,RowCount)
end;
function TSQLTable.SortCompare(Field: integer): TUTF8Compare;
begin
result := SQLFieldTypeComp[FieldType(Field)];
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 Destroy;
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): 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 := TSynObjectList.Create;
fOwnedRecords.Add(result);
end;
{$ifdef ISDELPHI2010} // Delphi 2009/2010 generics are buggy
function TSQLTable.ToObjectList<T>: TObjectList<T>;
var R,Item: TSQLRecord;
row: PPUtf8Char;
i: integer;
{$ifdef ISDELPHIXE3}rec: PSQLRecordArray;{$endif}
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()
rec := pointer(result.List);
for i := 0 to fRowCount-1 do begin
Item := TSQLRecordClass(T).Create;
rec[i] := Item;
{$else}
for i := 1 to fRowCount do begin
Item := TSQLRecordClass(T).Create;
Result.Add(Item);
{$endif}
R.fFill.Fill(pointer(row),Item);
Item.fInternalState := fInternalState; // set InternalState property
Inc(row,FieldCount); // next data row
end;
finally
R.Free;
end;
end;
{$endif}
procedure TSQLTable.ToObjectList(DestList: TObjectList; RecordType: TSQLRecordClass);
var R: TSQLRecord;
row: PPUtf8Char;
rec: PSQLRecord;
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()
rec := pointer(DestList.List);
row := @fResults[FieldCount]; // row^ points to first row of data
for i := 1 to fRowCount do begin
rec^ := RecordType.Create; // TObjectList will own and free each instance
R.fFill.Fill(pointer(row),rec^);
rec^.fInternalState := fInternalState; // set InternalState property
inc(rec);
inc(row,FieldCount); // next data row
end;
finally
R.Free;
end;
end;
function TSQLTable.ToObjArray(var ObjArray; RecordType: TSQLRecordClass): boolean;
var R: TSQLRecord;
Row: PPUtf8Char;
i: integer;
arr: TSQLRecordObjArray absolute ObjArray;
begin
result := false;
ObjArrayClear(arr);
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 ObjArrayAdd()
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): TObjectList;
begin
result := TObjectList.Create;
ToObjectList(result,RecordType);
end;
function TSQLTable.Step(SeekFirst: boolean; RowVariant: PVariant): 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;
function TSQLTable.FieldAsRawUTF8(FieldIndex: Integer): RawUTF8;
var buf: PUTF8Char;
begin
buf := FieldBuffer(FieldIndex);
FastSetString(result,buf,StrLen(buf));
end;
function TSQLTable.FieldAsRawUTF8(const FieldName: RawUTF8): RawUTF8;
var buf: PUTF8Char;
begin
buf := FieldBuffer(FieldName);
FastSetString(result,buf,StrLen(buf));
end;
function TSQLTable.FieldAsString(FieldIndex: Integer): String;
var buf: PUTF8Char;
begin
buf := FieldBuffer(FieldIndex);
UTF8DecodeToString(buf,StrLen(buf),result);
end;
function TSQLTable.FieldAsString(const FieldName: RawUTF8): String;
var buf: PUTF8Char;
begin
buf := FieldBuffer(FieldName);
UTF8DecodeToString(buf,StrLen(buf),result);
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,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 fFieldType=nil 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 fFieldType=nil 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 fFieldType=nil 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 UpperValue: RawUTF8;
StartRow, FieldIndex: integer; Client: TObject; Lang: TSynSoundExPronunciation;
UnicodeComparison: boolean): integer;
var U: PPUTF8Char;
Kind: TSQLFieldType;
Search: PAnsiChar;
UpperUnicode: RawUnicode;
UpperUnicodeLen: integer;
info: PSQLTableFieldType;
Val64: Int64;
ValTimeLog: TTimelogBits absolute Val64;
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 (UpperValue='') or
(cardinal(FieldIndex)>=cardinal(FieldCount)) then
exit;
Search := pointer(UpperValue);
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,info);
U := @fResults[FieldCount*StartRow+FieldIndex];
// search in one specified field value
if (Kind=sftEnumerate) and (info.ContentTypeInfo<>nil) then begin
// for enumerates: first search in all available values
Int64(EnumValues) := 0;
P := @PEnumType(info.ContentTypeInfo)^.NameList;
for i := 0 to PEnumType(info.ContentTypeInfo)^.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);
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,sftUnixTime,sftUnixMSTime] then
while cardinal(result)<=cardinal(fRowCount) do begin
SetInt64(U^,Val64);
if Val64<>0 then begin
case Kind of
sftUnixTime:
ValTimeLog.FromUnixTime(Val64);
sftUnixMSTime: // seconds resolution is enough for value search
ValTimeLog.FromUnixMSTime(Val64);
end;
tmp[ValTimeLog.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 UpperValue: 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 (UpperValue='') then
exit;
// search in all fields values
for F := 0 to FieldCount-1 do begin
Row := SearchValue(UpperValue,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 Value: RawUTF8; FieldIndex, StartRow: integer;
CaseSensitive: boolean): integer;
begin
result := SearchFieldEquals(pointer(Value),FieldIndex,StartRow,CaseSensitive);
end;
function TSQLTable.SearchFieldEquals(Value: PUTF8Char; FieldIndex, StartRow: integer;
CaseSensitive: boolean): integer;
var U: PPUTF8Char;
begin
if (self<>nil) and (Value<>nil) and (cardinal(FieldIndex)<cardinal(fFieldCount)) then begin
U := @fResults[FieldCount*StartRow+FieldIndex];
if CaseSensitive then
for result := StartRow to fRowCount do
if StrComp(U^,Value)=0 then
exit else
inc(U,FieldCount) else
for result := StartRow to fRowCount do
if UTF8IComp(U^,Value)=0 then
exit else
inc(U,FieldCount);
end;
result := 0;
end;
function TSQLTable.SearchFieldIdemPChar(const Value: RawUTF8; FieldIndex, StartRow: integer): integer;
var U: PPUTF8Char;
up: RawUTF8;
begin
if (self<>nil) and (Value<>'') and (cardinal(FieldIndex)<cardinal(fFieldCount)) then begin
UpperCaseCopy(Value,up);
U := @fResults[FieldCount*StartRow+FieldIndex];
for result := StartRow to fRowCount do
if IdemPChar(U^,pointer(up)) then
exit else
inc(U,FieldCount);
end;
result := 0;
end;
{$ifndef NOVARIANTS}
function TSQLTable.GetVariant(Row, Field: integer): Variant;
begin
GetVariant(Row,Field,result);
end;
procedure TSQLTable.GetVariant(Row,Field: integer; var result: variant);
var aType: TSQLFieldType;
info: PSQLTableFieldType;
U: PUTF8Char;
begin
if Row=0 then // Field Name
RawUTF8ToVariant(GetU(0,Field),result) else begin
aType := FieldType(Field,info);
U := Get(Row,Field);
ValueVarToVariant(U,StrLen(U),aType,TVarData(result),true,info.ContentTypeInfo);
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,Result);
end;
{$endif NOVARIANTS}
function TSQLTable.ExpandAsString(Row, Field: integer; Client: TObject;
out Text: string; const CustomFormat: string): TSQLFieldType;
var info: PSQLTableFieldType;
err: integer;
Value: Int64;
ValueTimeLog: TTimeLogBits absolute Value;
ValueDateTime: TDateTime;
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,info);
case result of
sftDateTime, sftDateTimeMS: begin
Value := Iso8601ToTimeLogPUTF8Char(Get(Row,Field),0);
IsDateTime:
if Value<>0 then begin
{$ifndef LVCL}
if CustomFormat<>'' then begin
Text := FormatDateTime(CustomFormat,ValueTimeLog.ToDateTime);
if Text<>CustomFormat then
exit; // valid conversion
end;
{$endif LVCL}
Text := ValueTimeLog.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, sftUnixTime, sftUnixMSTime: 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:
if info.ContentTypeInfo<>nil then begin
Text := PEnumType(info.ContentTypeInfo)^.GetCaption(Value);
exit;
end;
sftTimeLog, sftModTime, sftCreateTime:
goto IsDateTime;
sftUnixTime: begin
ValueTimeLog.FromUnixTime(Value);
goto IsDateTime;
end;
sftUnixMSTime:
if Value<>0 then begin
ValueDateTime := UnixMSTimeToDateTime(Value);
{$ifndef LVCL}
if CustomFormat<>'' then begin
Text := FormatDateTime(CustomFormat,ValueDateTime);
if Text<>CustomFormat then
exit; // valid conversion
end;
{$endif LVCL}
Text := DateTimeToi18n(ValueDateTime);
exit;
end;
{ 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);
StringToSynUnicode(s,Text);
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 }
function TSQLTableRowVariant.IntGet(var Dest: TVarData;
const Instance: TVarData; Name: PAnsiChar; NameLen: PtrInt): boolean;
var r,f: integer;
rv: TSQLTableRowVariantData absolute Instance;
begin
if rv.VTable=nil then
raise ESQLTableException.CreateUTF8('Invalid %.% call',[self,Name]);
r := rv.VRow;
if r<0 then begin
r := rv.VTable.fStepRow;
if (r=0) or (r>rv.VTable.fRowCount) then
raise ESQLTableException.CreateUTF8('%.%: no previous Step',[self,Name]);
end;
f := rv.VTable.FieldIndex(PUTF8Char(Name));
result := f>=0;
if f>=0 then
rv.VTable.GetVariant(r,f,Variant(Dest));
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);
if AVarType=DocVariantVType then begin
VarClear(variant(Dest));
TDocVariantData(Dest) := TDocVariantData(tmp);
end else
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;
{ TObjectVariant }
var
ObjectVariantType: TCustomVariantType;
class procedure TObjectVariant.New(var V: Variant; Obj: TObject);
begin
VarClear(V);
if ObjectVariantType=nil then
ObjectVariantType := SynRegisterCustomVariantType(TObjectVariant);
TVarData(V).VType := ObjectVariantType.VarType;
TVarData(V).VPointer := Obj;
end;
procedure TObjectVariant.ToJSON(W: TTextWriter; const Value: variant; Escape: TTextWriterKind);
begin
W.WriteObject(TVarData(Value).VPointer);
end;
const
_INTGETOBJECTPROPINFO_ID = pointer(1);
function IntGetObjectPropInfo(o: TObject; Name: pointer; NameLen: PtrInt): PPropInfo;
begin
if (o=nil) or (Name=nil) then
raise EObjectVariant.CreateUTF8('Invalid TObjectVariant.% call',[Name]);
result := ClassFieldPropWithParentsFromUTF8(PPointer(o)^,Name,NameLen);
if (result=nil) and IsRowID(Name,NameLen) and o.InheritsFrom(TSQLRecord) then
result := _INTGETOBJECTPROPINFO_ID;
end;
function TObjectVariant.IntGet(var Dest: TVarData; const Instance: TVarData;
Name: PAnsiChar; NameLen: PtrInt): boolean;
var info: PPropInfo;
o: TObject;
begin
o := Instance.VPointer;
info := IntGetObjectPropInfo(o,Name,NameLen);
result := info<>nil;
if info<>nil then
if info=_INTGETOBJECTPROPINFO_ID then
variant(Dest) := TSQLRecord(o).IDValue else
if info^.PropType^.Kind=tkClass then
New(Variant(Dest),info^.GetObjProp(o)) else
info^.GetVariant(o,Variant(Dest));
end;
function TObjectVariant.IntSet(const Instance, Value: TVarData;
Name: PAnsiChar; NameLen: PtrInt): boolean;
var info: PPropInfo;
o: TObject;
begin
o := Instance.VPointer;
info := IntGetObjectPropInfo(o,Name,NameLen);
if info=nil then
result := false else begin
if info=_INTGETOBJECTPROPINFO_ID then
VariantToInt64(Variant(Value),PInt64(@TSQLRecord(o).fID)^) else
info^.SetFromVariant(o,Variant(Value));
result := true;
end;
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 = [',',']','}',':'];
procedure GetJSONArrayOrObject(P: PUTF8Char; out PDest: PUTF8Char;
EndOfObject: PUTF8Char; var result: 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;
FastSetString(result,Beg,P-Beg);
end;
procedure GetJSONArrayOrObjectAsQuotedStr(P: PUTF8Char; out PDest: PUTF8Char;
EndOfObject: PUTF8Char; var result: 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;
QuotedStr(Beg,'''',result);
end;
procedure TJSONObjectDecoder.Decode(var P: PUTF8Char; const Fields: TRawUTF8DynArray;
Params: TJSONObjectDecoderParams; const RowID: TID; ReplaceRowIDWithID: boolean);
var EndOfObject: AnsiChar;
procedure GetSQLValue(ndx: PtrInt);
var wasString: boolean;
res: PUTF8Char;
resLen, c: integer;
begin
res := P;
if res=nil then begin
FieldTypeApproximation[ndx] := ftaNull;
FieldValues[ndx] := NULL_STR_VAR;
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_STR_VAR;
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
GetJSONArrayOrObject(res,P,@EndOfObject,FieldValues[ndx]) else
GetJSONArrayOrObjectAsQuotedStr(res,P,@EndOfObject,FieldValues[ndx]);
end;
'[': begin // will work e.g. for custom variant types
FieldTypeApproximation[ndx] := ftaArray;
if params=pNonQuoted then
GetJSONArrayOrObject(res,P,@EndOfObject,FieldValues[ndx]) else
GetJSONArrayOrObjectAsQuotedStr(res,P,@EndOfObject,FieldValues[ndx]);
end;
else begin
// handle JSON string, number or false/true in P
res := GetJSONField(res,P,@wasString,@EndOfObject,@resLen);
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
Base64ToBin(PAnsiChar(res)+3,resLen-3,RawByteString(FieldValues[ndx]));
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
FastSetString(FieldValues[ndx],res,resLen) 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
FieldTypeApproximation[ndx] := ftaNull;
FieldValues[ndx] := NULL_STR_VAR;
end else // avoid GPF, but will return invalid SQL
// non string params (numeric or false/true) are passed untouched
if PInteger(res)^=FALSE_LOW then begin
FieldValues[ndx] := SmallUInt32UTF8[0];
FieldTypeApproximation[ndx] := ftaBoolean;
end else
if PInteger(res)^=TRUE_LOW then begin
FieldValues[ndx] := SmallUInt32UTF8[1];
FieldTypeApproximation[ndx] := ftaBoolean;
end else begin
FastSetString(FieldValues[ndx],res,resLen);
FieldTypeApproximation[ndx] := ftaNumber;
end;
end;
end;
end;
end;
var FN: PUTF8Char;
F, FNlen: integer;
FieldIsRowID: Boolean;
begin
FieldCount := 0;
DecodedRowID := 0;
DecodedFieldTypesToUnnest := nil;
FillCharFast(FieldTypeApproximation,SizeOf(FieldTypeApproximation),ord(ftaNumber{TID}));
InlinedParams := Params;
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';
Int64ToUtf8(RowID,FieldValues[0]);
FieldCount := 1;
DecodedRowID := RowID;
end;
repeat
if P=nil then
break;
FN := GetJSONPropName(P,@FNlen);
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 begin
FN := 'ID';
FNlen := 2;
end;
FastSetString(FieldNames[FieldCount],FN,FNlen);
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; ReplaceRowIDWithID: Boolean);
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;
{$ifdef ISDELPHI20062007}
{$WARNINGS OFF} // circument Delphi 2007 false positive warning
{$endif}
const
PG_FT: array[TSQLDBFieldType] of string[9] = (
'int4', 'text', 'int8', 'float8', 'numeric', 'timestamp', 'text', 'bytea');
function TJSONObjectDecoder.EncodeAsSQLPrepared(const TableName: RawUTF8;
Occasion: TSQLOccasion; const UpdateIDFieldName: RawUTF8;
BatchOptions: TSQLRestBatchOptions): RawUTF8;
var F: integer;
W: TTextWriter;
temp: TTextWriterStackBuffer;
begin
W := TTextWriter.CreateOwnedStream(temp);
try
case Occasion of
soUpdate: begin
if FieldCount=0 then
raise EORMException.Create('Invalid EncodeAsSQLPrepared(0)');
W.AddShort('update ');
W.AddString(TableName);
if DecodedFieldTypesToUnnest<>nil then begin
// PostgreSQL bulk update via nested array binding
W.AddShort(' as t set ');
for F := 0 to FieldCount-1 do begin
W.AddString(DecodedFieldNames^[F]);
W.AddShort('=v.');
W.AddString(DecodedFieldNames^[F]);
W.Add(',');
end;
W.CancelLastComma;
W.AddShort(' from ( select');
for F := 0 to FieldCount-1 do begin
W.AddShort(' unnest(?::');
W.AddShort(PG_FT[DecodedFieldTypesToUnnest^[F]]);
W.AddShort('[]),');
end;
W.AddShort(' unnest(?::int8[]) ) as v('); // last param is ID
for F := 0 to FieldCount-1 do begin
W.AddString(DecodedFieldNames^[F]);
W.Add(',');
end;
W.AddString(UpdateIDFieldName);
W.AddShort(') where t.');
W.AddString(UpdateIDFieldName);
W.AddShort('=v.');
W.AddString(UpdateIDFieldName);
end else begin
// regular UPDATE statement
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('=','?'); // last param is ID
end;
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 (');
if DecodedFieldTypesToUnnest<>nil then
// PostgreSQL bulk insert via nested array binding
for F := 0 to FieldCount-1 do begin
W.AddShort('unnest(?::');
W.AddShort(PG_FT[DecodedFieldTypesToUnnest^[F]]);
W.AddShort('[]),');
end else
// regular INSERT statement
W.AddStrings('?,',FieldCount);
W.CancelLastComma;
W.Add(')');
end;
end;
else
raise EORMException.CreateUTF8('Unexpected EncodeAsSQLPrepared(%)',[ord(Occasion)]);
end;
W.SetText(result);
finally
W.Free;
end;
end;
{$ifdef ISDELPHI20062007}
{$WARNINGS ON}
{$endif}
function TJSONObjectDecoder.EncodeAsSQL(Update: boolean): RawUTF8;
var F: integer;
W: TTextWriter;
temp: TTextWriterStackBuffer;
procedure AddValue;
begin
if InlinedParams=pInlined then
W.AddShort(':(');
W.AddString(FieldValues[F]);
if InlinedParams=pInlined then
W.AddShort('):,') else
W.Add(',');
end;
begin
result := '';
if FieldCount=0 then
exit;
W := TTextWriter.CreateOwnedStream(temp);
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;
temp: TTextWriterStackBuffer;
begin
if FieldCount=0 then
exit;
W := TTextWriter.CreateOwnedStream(temp);
try
W.Add('{');
for F := 0 to FieldCount-1 do begin
W.AddFieldName(DecodedFieldNames^[F]);
if FieldTypeApproximation[F] in [ftaBlob,ftaDate,ftaString] then
if InlinedParams=pNonQuoted then
W.AddJSONString(FieldValues[F]) else
W.AddQuotedStringAsJSON(FieldValues[F]) else
W.AddString(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(%) max=%',
[FieldName,MAX_SQLFIELDS]);
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; ReplaceRowIDWithID: Boolean): 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; ReplaceRowIDWithID: Boolean): RawUTF8;
var Decoder: TJSONObjectDecoder;
begin
Decoder.Decode(JSON,nil,FROMINLINED[InlinedParams],RowID,ReplaceRowIDWithID);
result := Decoder.EncodeAsSQL(Update);
end;
function Expect(var P: PUTF8Char; Value: PUTF8Char; ValueLen: PtrInt): boolean;
{$ifdef HASINLINE}inline;{$endif}
var i: PtrInt;
begin // ValueLen is at least 8 bytes long
result := false;
if P=nil then
exit;
while (P^<=' ') and (P^<>#0) do inc(P);
if PPtrInt(P)^=PPtrInt(Value)^ then begin
for i := SizeOf(PtrInt) to ValueLen - 1 do
if P[i]<>Value[i] then
exit;
inc(P,ValueLen);
result := true;
end;
end;
function GetJSONIntegerVar(var P: PUTF8Char): PtrInt;
var c: PtrUInt;
begin
while (P^<=' ') and (P^<>#0) do inc(P);
c := byte(P^)-48;
if c>9 then
result := 0 else begin
result := c;
inc(P);
repeat
c := byte(P^)-48;
if c>9 then
break;
result := result*10+PtrInt(c);
inc(P);
until false;
end;
end;
function GetJSONInt64Var(var P: PUTF8Char): Int64;
var c: PtrUInt;
begin
while (P^<=' ') and (P^<>#0) do inc(P);
c := byte(P^)-48;
if c>9 then
result := 0 else begin
result := c;
inc(P);
repeat
c := byte(P^)-48;
if c>9 then
break;
result := result*10+Int64(c);
inc(P);
until false;
end;
end;
const
FIELDCOUNT_PATTERN: PUTF8Char = '{"fieldCount":'; // 14 chars
ROWCOUNT_PATTERN: PUTF8Char = ',"rowCount":'; // 12 chars
VALUES_PATTERN: PUTF8Char = ',"values":['; // 11 chars
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,14) 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;
if GetJSONPropName(P)<>nil then // ignore field name
result := GetJSONField(P,P); // get field value
end;
function IsNotAjaxJSON(P: PUTF8Char): Boolean;
begin
result := Expect(P,FIELDCOUNT_PATTERN,14);
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 CompareMemFixed(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,14) then begin
result := false;
exit;
end;
FieldCount := GetJSONIntegerVar(P);
if Expect(P,ROWCOUNT_PATTERN,12) 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,11);
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 := ID>0;
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 := ID>0;
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 := ID>0;
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 := ID>0;
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;
while (P^<=' ') and (P^<>#0) do inc(P);
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
if PC=nil then
exit;
PC^ := '{';
FastSetString(result,PC,P-PC-1);
exit;
end;
FastSetString(result,Beg,P-Beg-1);
end;
end;
{ TSQLTableJSON }
function TSQLTableJSON.PrivateCopyChanged(aJSON: PUTF8Char; aLen: integer;
aUpdateHash: boolean): boolean;
var Hash: cardinal;
begin
if aUpdateHash then begin
Hash := crc32c(0,pointer(aJSON),aLen);
result := (fPrivateCopyHash=0) or (Hash=0) or (Hash<>fPrivateCopyHash);
if not result then
exit;
fPrivateCopyHash := Hash;
end else
result := true; // from Create() for better performance on single use
FastSetString(fPrivateCopy,nil,aLen+16); // +16 for SSE4.2 read-ahead
MoveFast(pointer(aJSON)^,pointer(fPrivateCopy)^,aLen+1); // +1 for trailing #0
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 (more optimized) format as array of values
(* {"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 as array of objects (each with field names)
(* [{"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
for f := 0 to nfield-1 do begin
if nrow=0 then // get field name from 1st Row
fJSONResults[f] := GetJSONPropName(P) else
P := GotoNextJSONItem(P); // ignore field name for later rows
// warning: field order if not checked, and should be as expected
if max>=resmax then begin // check space inside loop for GPF security
resmax := NextGrow(resmax);
SetLength(fJSONResults,resmax); // enough space for 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);
if (EndOfObject='}') and (f<nfield-1) then begin
inc(max,nfield-f);
break; // allow some missing fields in the input object
end;
inc(max);
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,{updatehash=}true) 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);
PrivateCopyChanged(pointer(aJSON),len,{updatehash=}false);
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);
PrivateCopyChanged(pointer(aJSON),len,{updatehash=}false);
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);
PrivateCopyChanged(pointer(aJSON),len,{updatehash=}false);
CreateWithColumnTypes(ColumnTypes,aSQL,pointer(fPrivateCopy),len);
end;
{ TSQLTableWritable }
function TSQLTableWritable.AddField(const FieldName: RawUTF8): integer;
var prev: TPUTF8CharDynArray;
rowlen,i: integer;
S,D: PByte;
begin
if (FieldName='') or (FieldIndex(FieldName)>=0) then
raise ESQLTableException.CreateUTF8('%.AddField(%) invalid fieldname',[self,FieldName]);
result := fFieldCount;
inc(fFieldCount);
SetLength(fFieldNames,fFieldCount);
fFieldNames[result] := FieldName;
fFieldNameOrder := nil;
prev := fJSONResults;
fJSONResults := nil;
SetLength(fJSONResults,(fRowCount+1)*fFieldCount);
fResults := pointer(fJSONResults);
S := pointer(prev);
D := pointer(fJSONResults);
rowlen := result*SizeOf(pointer);
MoveFast(S^,D^,rowlen);
inc(S,rowlen);
inc(D,rowlen);
PPUTF8Char(D)^ := pointer(FieldName);
inc(D,SizeOf(pointer));
for i := 1 to fRowCount do begin
MoveFast(S^,D^,rowlen);
inc(S,rowlen);
inc(D,rowlen+SizeOf(pointer)); // leave new field value as D^=nil
end;
end;
procedure TSQLTableWritable.Update(Row: integer; const FieldName, Value: RawUTF8);
begin
Update(Row,FieldIndexExisting(FieldName),Value);
end;
procedure TSQLTableWritable.Update(Row, Field: integer; const Value: RawUTF8);
var U: PPUTF8Char;
begin
if (self=nil) or (fResults=nil) or (Row<=0) or (Row>fRowCount) or
(cardinal(Field)>=cardinal(FieldCount)) then
exit;
U := @fResults[Row*FieldCount+Field];
if (U^=nil) or (StrComp(U^,pointer(Value))<>0) then
if fNewValuesInterning<>nil then
U^ := pointer(fNewValuesInterning.Unique(Value)) else begin
AddRawUTF8(fNewValues,fNewValuesCount,Value);
U^ := pointer(Value);
end;
end;
function TSQLTableWritable.AddField(const FieldName: RawUTF8;
FieldType: TSQLFieldType; FieldTypeInfo: pointer; FieldSize: integer): integer;
begin
result := AddField(FieldName);
SetFieldType(result,FieldType,FieldTypeInfo,FieldSize);
end;
function TSQLTableWritable.AddField(const FieldName: RawUTF8;
FieldTable: TSQLRecordClass; const FieldTableName: RawUTF8=''): integer;
var prop: TSQLPropInfo;
nfo: pointer;
begin
result := AddField(FieldName);
if FieldTable=nil then
exit;
with FieldTable.RecordProps.Fields do
if FieldTableName<>'' then
prop := ByRawUTF8Name(FieldTableName) else
prop := ByRawUTF8Name(FieldName);
if prop = nil then
exit;
if prop.InheritsFrom(TSQLPropInfoRTTI) then
nfo := TSQLPropInfoRTTI(prop).PropType else
nfo := nil;
SetFieldType(result,prop.SQLFieldTypeStored,nfo,prop.FieldWidth,
PtrArrayAddOnce(fQueryTables,FieldTable));
end;
{$ifndef NOVARIANTS}
procedure TSQLTableWritable.Update(Row: integer; const FieldName: RawUTF8;
const Value: variant);
begin
Update(Row,FieldIndexExisting(FieldName),Value);
end;
procedure TSQLTableWritable.Update(Row, Field: integer; const Value: variant);
var U: RawUTF8;
wasString: boolean;
begin
VariantToUTF8(Value,U,wasString);
Update(Row,Field,U);
end;
{$endif NOVARIANTS}
procedure TSQLTableWritable.Join(From: TSQLTable; const FromKeyField, KeyField: RawUTF8);
var fk,dk,f,i,k,ndx: integer;
n,fn: RawUTF8;
info: PSQLTableFieldType;
new: TIntegerDynArray;
begin
dk := FieldIndexExisting(KeyField);
SetLength(new,FieldCount);
fk := From.FieldIndexExisting(FromKeyField);
From.SortFields(fk); // faster merge with O(log(n)) binary search
for f := 0 to From.FieldCount-1 do // add From fields (excluding FromKeyField)
if f<>fk then begin
n := From.FieldNames[f];
fn := n;
if FieldIndex(fn)>=0 then // ensure unique name
for i := 2 to 100 do begin
fn := n+SmallUInt32UTF8[i];
if FieldIndex(fn)<0 then
break;
end;
if From.FieldType(f,info)=sftUnknown then // set TSQLTableFieldType
i := AddField(fn) else
if info.TableIndex>=0 then
i := AddField(fn,From.QueryTables[info.TableIndex],n) else begin
i := AddField(fn);
if i>=length(fFieldType) then
SetLength(fFieldType,i+1);
fFieldType[i] := info^;
end;
new[f] := i;
end;
ndx := FieldCount;
for i := 1 to fRowCount do begin // merge data
k := From.SearchFieldSorted(fResults[ndx+dk],fk);
if k>0 then begin
k := k*From.FieldCount;
for f := 0 to From.FieldCount-1 do
if f<>fk then
fResults[ndx+new[f]] := From.fResults[k+f]; // fast PUTF8Char copy
end;
inc(ndx,FieldCount);
end;
end;
{ TINIWriter }
procedure TINIWriter.WriteObject(Value: TObject; const SubCompName: RawUTF8;
WithSection, RawUTF8DynArrayAsCSV: boolean);
var CT: TClass;
P: PPropInfo;
Obj: TObject;
i: integer;
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#10'[%]'#13#10,[ClassNameShort(Value)^]);
CT := Value.ClassType;
repeat
for i := 1 to InternalClassPropInfo(CT,P) do begin
if P^.PropType^.Kind=tkClass then begin // recursive serialization
Obj := P^.GetObjProp(Value);
if (Obj<>nil) and ClassHasPublishedFields(PPointer(Obj)^) then
WriteObject(Obj,SubCompName+ToUTF8(P^.Name)+'.',false);
end else begin // regular properties
Add('%%=%'#13#10,[SubCompName,P^.Name]);
P^.GetToText(Value,self,RawUTF8DynArrayAsCSV,twNone);
AddCR;
end;
P := P^.Next;
end;
CT := GetClassParent(CT);
until CT=TObject;
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
while (P^<=' ') and (P^<>#0) do inc(P);
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;
{$ifndef FPC}tmp: TObject;{$endif}
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 WriteIsDefined and not (j2oSetterNoCreate in Options) 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 FPC}
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) then
if {$ifdef HASINLINE}PropType^.FloatType{$else}
PFloatType(@PropType^.Name[ord(PropType^.Name[0])+1])^{$endif}=ftCurr then
result := GetCurrencyProp(Instance) else
result := GetFloatProp(Instance) else
result := 0;
end;
function TPropInfo.GetDoubleValue(Instance: TObject): double;
begin
if (Instance<>nil) and (@self<>nil) and (PropType^.Kind=tkFloat) then
result := GetFloatProp(Instance) else
result := 0;
end;
procedure TPropInfo.SetDoubleValue(Instance: TObject; const Value: double);
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;
WS: WideString;
{$ifdef HASVARUSTRING}US: UnicodeString;{$endif}
cp: integer;
begin
if (Instance<>nil) and (@self<>nil) then
case PropType^.Kind of
{$ifdef FPC}tkLStringOld,{$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: begin
GetUnicodeStrProp(Instance,US);
RawUnicodeToUtf8(pointer(US),length(US),result);
end;
{$endif HASVARUSTRING}
tkWString: begin
GetWideStrProp(Instance,WS);
RawUnicodeToUtf8(pointer(WS),length(WS),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}tkLStringOld,{$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);
{$ifdef FPC}
// an FPC quirck ... and Alf work-around ... ;-)
if cp=CP_UTF16 then begin
Setlength(tmp,length(tmp)+1);
tmp[length(tmp)] := #0;
end;
{$endif}
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}tkLStringOld,{$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;
procedure TPropInfo.CopyLongStrProp(Source,Dest: TObject);
var tmp: RawByteString;
begin
GetLongStrProp(Source,tmp);
SetLongStrProp(Dest,tmp);
end;
{$ifndef NOVARIANTS}
procedure TPropInfo.SetFromVariant(Instance: TObject; const Value: variant);
var i: integer;
i64: Int64;
u: RawUTF8;
d: double;
c: PClassInstance;
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 VariantToUTF8(Value,u) then begin
if PropType^.Kind=tkEnumeration then
i := PropType^.EnumBaseType^.GetEnumNameValue(pointer(u),length(u)) else
i := UTF8ToInteger(u,-1);
if i>=0 then
SetOrdProp(Instance,i)
end;
tkInt64{$ifdef FPC},tkQWord{$endif}:
if VariantToInt64(Value,i64) or (VariantToUTF8(Value,u) and ToInt64(u,i64)) then
SetInt64Prop(Instance,i64);
{$ifdef HASVARUSTRING}tkUString,{$endif}
tkLString, tkWString {$ifdef FPC},tkLStringOld{$endif}:
if VariantToUTF8(Value,u) then
SetLongStrValue(Instance,u);
tkFloat:
if VariantToDouble(Value,d) or (VariantToUTF8(Value,u) and ToDouble(u,d)) then
SetFloatProp(Instance,d);
tkVariant:
SetVariantProp(Instance,Value);
tkClass:
DocVariantToObject(_Safe(Value)^,GetObjProp(Instance));
tkDynArray: begin
c := TJSONSerializer.RegisterObjArrayFindType(TypeInfo);
if c<>nil then
DocVariantToObjArray(_Safe(Value)^,GetFieldAddr(Instance)^,c) else begin
U := _Safe(Value)^.ToJSON;
GetDynArray(Instance).LoadFromJSON(pointer(U));
end;
end;
{$ifdef PUBLISHRECORD}
tkRecord{$ifdef FPC},tkObject{$endif}: begin
VariantSaveJSON(Value,twJSONEscape,u);
RecordLoadJSON(GetFieldAddr(Instance)^,pointer(u),TypeInfo);
end;
{$endif}
end;
end;
procedure TPropInfo.GetVariant(Instance: TObject; var Dest: variant);
var i: PtrInt;
U: RawUTF8;
begin
if (Instance<>nil) and (@self<>nil) then
case PropType^.Kind of
tkInteger,tkEnumeration,tkSet,tkChar,tkWChar{$ifdef FPC},tkBool{$endif}: begin
i := GetOrdProp(Instance);
case PropType^.Kind of
tkInteger,tkSet: Dest := integer(i);
tkChar: Dest := AnsiChar(i);
tkWChar: Dest := WideChar(i);
{$ifdef FPC}
tkBool: Dest := boolean(i);
tkEnumeration: Dest := integer(i);
{$else}
tkEnumeration:
if TypeInfo=system.TypeInfo(boolean) then
Dest := boolean(i) else
Dest := integer(i);
{$endif FPC}
end;
end;
tkInt64{$ifdef FPC},tkQWord{$endif}:
Dest := GetInt64Prop(Instance);
tkLString,tkWString{$ifdef HASVARUSTRING},tkUString{$endif}{$ifdef FPC},tkLStringOld{$endif}: begin
GetLongStrValue(Instance,U);
RawUTF8ToVariant(U,Dest);
end;
tkFloat: Dest := GetFloatProp(Instance);
tkVariant: GetVariantProp(Instance,Dest);
tkClass: ObjectToVariant(GetObjProp(Instance),Dest);
tkDynArray: begin
GetDynArray(Instance).SaveToJSON(U); // works for T*ObjArray and records
TDocVariantData(Dest).InitJSONInPlace(pointer(U),JSON_OPTIONS_FAST);
end;
else VarClear(Dest);
end;
end;
{$endif NOVARIANTS}
procedure TPropInfo.SetFromText(Instance: TObject; const Text: RawUTF8;
TryCustomVariants: PDocVariantOptions; AllowDouble: boolean);
{$ifndef NOVARIANTS}var tmp: variant;{$endif}
begin
if (Instance<>nil) and (@self<>nil) then
case PropType^.Kind of
tkChar,tkWChar:
if Text<>'' then
SetOrdProp(Instance,ord(Text[1]));
tkInteger,tkEnumeration,tkSet{$ifdef FPC},tkBool{$endif}:
SetOrdProp(Instance,GetIntegerDef(pointer(Text),DefaultOr0));
tkInt64{$ifdef FPC},tkQWord{$endif}:
SetInt64Prop(Instance,GetInt64(pointer(Text)));
tkLString,{$ifdef FPC}tkLStringOld,{$endif}{$ifdef HASVARUSTRING}tkUString,{$endif}tkWString:
SetLongStrValue(Instance,Text);
tkFloat:
if PropType^.FloatType=ftCurr then
SetCurrencyProp(Instance,StrToCurrency(pointer(Text))) else
SetFloatProp(Instance,GetExtended(pointer(Text)));
{$ifndef NOVARIANTS}
tkVariant: begin
if TryCustomVariants<>nil then
GetVariantFromJSON(pointer(Text),TextToVariantNumberType(pointer(Text))=varString,
tmp,TryCustomVariants,{allowdouble=}true) else
RawUTF8ToVariant(Text,tmp);
SetVariantProp(Instance,tmp);
end;
{$endif NOVARIANTS}
tkDynArray:
if Text<>'' then
if IsRawUTF8DynArray(TypeInfo) and (Text[1]<>'[') then
CSVToRawUTF8DynArray(pointer(Text),PRawUTF8DynArray(GetFieldAddr(Instance))^) else
GetDynArray(Instance).LoadFromJSON(pointer(Text)); // T*ObjArray and records
end;
end;
procedure TPropInfo.GetToText(Instance: TObject; WR: TTextWriter;
RawUTF8DynArrayAsCSV: boolean; Escape: TTextWriterKind);
var i: integer;
tmp: RawUTF8;
a: PRawUTF8DynArray;
da: TDynArray;
{$ifndef NOVARIANTS}v: variant;{$endif}
begin
if (Instance<>nil) and (@self<>nil) and (WR<>nil) then
case PropType^.Kind of
tkInteger,tkEnumeration,tkSet,tkChar,tkWChar{$ifdef FPC},tkBool{$endif}: begin
i := GetOrdProp(Instance);
case PropType^.Kind of
tkChar: WR.Add(AnsiChar(i));
tkWChar: WR.AddNoJSONEscapeW(@i,1);
else WR.Add(i);
end;
end;
tkInt64{$ifdef FPC},tkQWord{$endif}:
WR.Add(GetInt64Prop(Instance));
tkLString,{$ifdef FPC}tkLStringOld,{$endif}{$ifdef HASVARUSTRING}tkUString,{$endif}tkWString: begin
GetLongStrValue(Instance,tmp);
WR.Add(pointer(tmp),length(tmp),Escape);
end;
tkFloat:
if PropType^.FloatType=ftCurr then
WR.AddCurr64(GetCurrencyProp(Instance)) else
WR.AddDouble(GetFloatProp(Instance));
{$ifndef NOVARIANTS}
tkVariant: begin
GetVariantProp(Instance,v);
WR.AddVariant(v,Escape);
end;
{$endif NOVARIANTS}
tkDynArray: begin
if RawUTF8DynArrayAsCSV and IsRawUTF8DynArray(TypeInfo) then begin
a := GetFieldAddr(Instance);
if (a<>nil) and (a^<>nil) then begin
for i := 0 to length(a^)-1 do begin
WR.AddString(a^[i]);
WR.Add(',');
end;
WR.CancelLastComma;
end;
end else begin
GetDynArray(Instance,da);
WR.AddDynArrayJSON(da); // works for T*ObjArray and records
end;
end;
end;
end;
procedure TPropInfo.SetDefaultValue(Instance: TObject; FreeAndNilNestedObjects: boolean);
var obj: 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,DefaultOr0);
tkInt64{$ifdef FPC},tkQWord{$endif}:
SetInt64Prop(Instance,0);
tkLString{$ifdef FPC},tkLStringOld{$endif}:
SetLongStrProp(Instance,'');
{$ifdef HASVARUSTRING}
tkUString:
SetUnicodeStrProp(Instance,'');
{$endif HASVARUSTRING}
tkWString:
SetWideStrProp(Instance,'');
tkFloat:
SetFloatProp(Instance,0);
{$ifndef NOVARIANTS}
tkVariant:
SetVariantProp(Instance,SynCommons.Null);
{$endif}
tkClass: begin
obj := GetObjProp(Instance);
if obj<>nil then
if FreeAndNilNestedObjects then begin
SetOrdProp(Instance,0); // mimic FreeAndNil()
obj.Free;
end else
ClearObject(obj,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) or not(PropType^.Kind in [{$ifdef FPC}tkLStringOld,{$endif}
{$ifdef HASVARUSTRING}tkUString,{$endif} tkLString, tkWString]) then
result := '' else begin
GetLongStrValue(Instance,tmp);
result := UTF8ToString(tmp);
end;
end;
procedure TPropInfo.SetGenericStringValue(Instance: TObject; const Value: string);
begin
if (Instance<>nil) and (@self<>nil) then
case PropType^.Kind of
{$ifdef FPC}tkLStringOld,{$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
GetUnicodeStrProp(Instance,result) else
result := '';
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 := PInt64(GetterAddr(Source))^=PInt64(DestInfo.GetterAddr(Dest))^ else
result := GetCurrencyProp(Source)=DestInfo^.GetCurrencyProp(Dest);
exit;
end;
ftDoub: begin
if GetterIsField and ((@self=DestInfo) or DestInfo^.GetterIsField) then
result := PInt64(GetterAddr(Source))^=PInt64(DestInfo.GetterAddr(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;
{$ifdef HASVARUSTRING} US: UnicodeString; {$endif}
{$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 QWord, 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));
tkLString{$ifdef FPC},tkLStringOld{$endif}:
if kD=kS 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 begin
GetUnicodeStrProp(Source,US);
DestInfo.SetUnicodeStrProp(Dest,US);
end 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.IsBlob: boolean;
begin
result := (@self<>nil) and (TypeInfo=system.TypeInfo(TSQLRawBlob));
end;
function TPropInfo.DefaultOr0: integer;
begin
if Default=NO_DEFAULT then
result := 0 else
result := Default;
end;
function TPropInfo.IsDefaultOrVoid(Instance: TObject): boolean;
var p: PPointer;
begin
case PropType^.Kind of
tkInteger,tkEnumeration,tkSet,tkChar,tkWChar{$ifdef FPC},tkBool{$endif}:
result := GetOrdProp(Instance)=DefaultOr0;
tkFloat:
result := GetFloatProp(Instance)=0;
tkInt64{$ifdef FPC},tkQWord{$endif}:
result := GetInt64Prop(Instance)=0;
tkLString,{$ifdef HASVARUSTRING}tkUString,{$endif}{$ifdef FPC}tkLStringOld,{$endif}
tkWString,tkDynArray,tkInterface: begin
p := GetFieldAddr(Instance);
result := (p<>nil) and (p^=nil);
end;
tkVariant: begin
p := GetFieldAddr(Instance);
result := (p<>nil) and VarDataIsEmptyOrNull(p);
end;
tkClass:
result := IsObjectDefaultOrVoid(GetObjProp(Instance));
else result := false;
end;
end;
function TPropInfo.RetrieveFieldSize: integer;
begin
case PropType^.Kind of
tkInteger,tkEnumeration,tkSet,tkChar,tkWChar{$ifdef FPC},tkBool{$endif}:
result := ORDTYPE_SIZE[PropType^.OrdType];
tkFloat:
case PropType^.FloatType of
ftSingle: result := 4;
ftExtended: result := 10;
else result := 8;
end;
tkLString,{$ifdef HASVARUSTRING}tkUString,{$endif}{$ifdef FPC}tkLStringOld,{$endif}
tkWString,tkClass,tkInterface,tkDynArray:
result := SizeOf(pointer);
tkInt64{$ifdef FPC},tkQWord{$endif}: result := 8;
tkVariant: result := SizeOf(variant);
else result := 0;
end;
end;
function FromOrdType(o: TOrdType; P: pointer): PtrInt;
{$ifdef HASINLINE}inline;{$endif} // shared by GetOrdProp/GetEnumName
begin
case o 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)^;
{$ifdef FPC_NEWRTTI} otSQWord, otUQWord: result := PInt64(P)^; {$endif}
else result := 0; // should not happen
end;
end;
procedure ToOrdType(o: TOrdType; P: pointer; Value: PtrInt);
{$ifdef HASINLINE}inline;{$endif}
begin
case o of
otUByte,otSByte: PByte(P)^ := Value;
otUWord,otSWord: PWord(P)^ := Value;
otULong,otSLong: PCardinal(P)^ := Value;
{$ifdef FPC_NEWRTTI}otSQWord, otUQWord: PInt64(P)^ := Value;{$endif}
end;
end;
function TPropInfo.IsStored(Instance: TObject): boolean;
type
TGetProc = function: boolean of object;
TGetIndexed = function(Index: integer): boolean of object;
var pt: byte;
call: TMethod;
begin
pt := {$ifdef FPC}(PropProcs shr 4)and 3{$else}PropWrap(StoredProc).Kind{$endif};
if {$ifdef FPC}pt=ptConst{$else}(StoredProc and (not PtrInt($ff)))=0{$endif} then
result := boolean(StoredProc) else begin
case pt of
ptField: begin
result := PBoolean(PtrUInt(Instance)+StoredProc{$ifndef FPC}and $00ffffff{$endif})^;
exit;
end;
ptVirtual:
call.Code := PPointer(PPtrUInt(Instance)^+{$ifndef FPC}word{$endif}(StoredProc))^;
else
call.Code := pointer(StoredProc);
end;
call.Data := Instance;
if {$ifdef FPC}(PropProcs shr 6)and 1{$else}Index{$endif}<>NO_INDEX then
result := TGetIndexed(call)(Index) else
result := TGetProc(call);
end;
end;
function TPropInfo.GetObjProp(Instance: TObject): TObject;
type
TGetProc = function: TObject of object;
TGetIndexed = function(Index: Integer): TObject of object;
var call: TMethod;
begin
case Getter(Instance,@call) of
picField: result := PObject(call.Data)^;
picMethod: result := TGetProc(call);
picIndexed: result := TGetIndexed(call)(Index);
else result := nil;
end;
end;
function TPropInfo.GetOrdProp(Instance: TObject): PtrInt;
type
TGetProc = function: Pointer of object; // pointer result is a PtrInt register
TGetIndexed = function(Index: Integer): Pointer of object;
var call: TMethod;
begin
case Getter(Instance,@call) of
picField: call.Code := PPointer(call.Data)^;
picMethod: call.Code := TGetProc(call);
picIndexed: call.Code := TGetIndexed(call)(Index);
else call.Code := nil; // call.Code is used to store the raw value
end;
if PropType^.Kind in [tkClass,tkDynArray,tkInterface] then
result := PtrInt(call.Code) else
result := FromOrdType({$ifdef HASINLINE}PropType^.OrdType{$else}
POrdType(@PropType^.Name[ord(PropType^.Name[0])+1])^{$endif},@call.Code);
end;
procedure TPropInfo.SetOrdProp(Instance: TObject; Value: PtrInt);
type
TSetProc = procedure(Value: PtrInt) of object;
TSetIndexed = procedure(Index: integer; Value: PtrInt) of object;
var call: TMethod;
begin
case Setter(Instance,@call) of
picField: if PropType^.Kind=tkClass then
PPTrInt(call.Data)^ := Value else
ToOrdType(PropType^.OrdType,call.Data,Value);
picMethod: TSetProc(call)(Value);
picIndexed: TSetIndexed(call)(Index,Value);
end;
end;
function TPropInfo.GetInt64Prop(Instance: TObject): Int64;
type
TGetProc = function: Int64 of object;
TGetIndexed = function(Index: Integer): Int64 of object;
var call: TMethod;
begin
case Getter(Instance,@call) of
picField: result := PInt64(call.Data)^;
picMethod: result := TGetProc(call);
picIndexed: result := TGetIndexed(call)(Index);
else result := 0;
end;
end;
procedure TPropInfo.SetInt64Prop(Instance: TObject; const Value: Int64);
type
TSetProc = procedure(Value: Int64) of object;
TSetIndexed = procedure(Index: integer; Value: Int64) of object;
var call: TMethod;
begin
case Setter(Instance,@call) of
picField: PInt64(call.Data)^ := Value;
picMethod: TSetProc(call)(Value);
picIndexed: TSetIndexed(call)(Index,Value);
end;
end;
procedure TPropInfo.GetShortStrProp(Instance: TObject; var Value: RawByteString);
type
TGetProc = function: ShortString of object;
TGetIndexed = function(Index: Integer): ShortString of object;
var call: TMethod;
tmp: ShortString;
begin
case Getter(Instance,@call) of
picField: tmp := PShortString(call.Data)^;
picMethod: tmp := TGetProc(call);
picIndexed: tmp := TGetIndexed(call)(Index);
else tmp := '';
end;
ShortStringToAnsi7String(tmp,RawUTF8(Value));
end; // no SetShortStrProp() by now
procedure TPropInfo.GetLongStrProp(Instance: TObject; var Value: RawByteString);
procedure SubProc(pic: TPropInfoCall; const call: TMethod);
type
TGetProc = function: RawByteString of object;
TGetIndexed = function(Index: Integer): RawByteString of object;
begin
case pic of
picMethod: value := TGetProc(call);
picIndexed: value := TGetIndexed(call)(Index);
else value := '';
end;
end;
var pic: TPropInfoCall;
call: TMethod;
begin
pic := Getter(Instance,@call);
if pic=picField then
value := PRawByteString(call.Data)^ else
SubProc(pic,call); // avoid try..finally
end;
procedure TPropInfo.SetLongStrProp(Instance: TObject; const Value: RawByteString);
type
TSetProc = procedure(const Value: RawByteString) of object;
TSetIndexed = procedure(Index: integer; const Value: RawByteString) of object;
var call: TMethod;
begin
case Setter(Instance,@call) of
picField: PRawByteString(call.Data)^ := Value;
picMethod: TSetProc(call)(Value);
picIndexed: TSetIndexed(call)(Index,Value);
end;
end;
procedure TPropInfo.GetWideStrProp(Instance: TObject; var Value: WideString);
type
TGetProc = function: WideString of object;
TGetIndexed = function(Index: Integer): WideString of object;
var call: TMethod;
begin
case Getter(Instance,@call) of
picField: value := PWideString(call.Data)^;
picMethod: value := TGetProc(call);
picIndexed: value := TGetIndexed(call)(Index);
else value := '';
end;
end;
procedure TPropInfo.SetWideStrProp(Instance: TObject; const Value: WideString);
type
TSetProc = procedure(const Value: WideString) of object;
TSetIndexed = procedure(Index: integer; const Value: WideString) of object;
var call: TMethod;
begin
case Setter(Instance,@call) of
picField: PWideString(call.Data)^ := Value;
picMethod: TSetProc(call)(Value);
picIndexed: TSetIndexed(call)(Index,Value);
end;
end;
{$ifdef HASVARUSTRING}
procedure TPropInfo.GetUnicodeStrProp(Instance: TObject; var Value: UnicodeString);
procedure SubProc(pic: TPropInfoCall; const call: TMethod); // avoid try..finally
type
TGetProc = function: UnicodeString of object;
TGetIndexed = function(Index: Integer): UnicodeString of object;
begin
case pic of
picMethod: Value := TGetProc(call);
picIndexed: Value := TGetIndexed(call)(Index);
else Value := '';
end;
end;
var pic: TPropInfoCall;
call: TMethod;
begin
pic := Getter(Instance,@call);
if pic=picField then
Value := PUnicodeString(call.Data)^ else
SubProc(pic,call);
end;
procedure TPropInfo.SetUnicodeStrProp(Instance: TObject; const Value: UnicodeString);
type
TSetProc = procedure(const Value: UnicodeString) of object;
TSetIndexed = procedure(Index: integer; const Value: UnicodeString) of object;
var call: TMethod;
begin
case Setter(Instance,@call) of
picField: PUnicodeString(call.Data)^ := Value;
picMethod: TSetProc(call)(Value);
picIndexed: TSetIndexed(call)(Index,Value);
end;
end;
{$endif HASVARUSTRING}
function TPropInfo.GetCurrencyProp(Instance: TObject): currency;
type
TGetProc = function: currency of object;
TGetIndexed = function(Index: Integer): currency of object;
var call: TMethod;
begin
case Getter(Instance,@call) of
picField: result := PCurrency(call.Data)^;
picMethod: result := TGetProc(call);
picIndexed: result := TGetIndexed(call)(Index);
else result := 0;
end;
end;
procedure TPropInfo.SetCurrencyProp(Instance: TObject; const Value: Currency);
type
TSetProc = procedure(const Value: currency) of object;
TSetIndexed = procedure(Index: integer; const Value: currency) of object;
var call: TMethod;
begin
case Setter(Instance,@call) of
picField: PCurrency(call.Data)^ := Value;
picMethod: TSetProc(call)(Value);
picIndexed: TSetIndexed(call)(Index,Value);
end;
end;
function TPropInfo.GetDoubleProp(Instance: TObject): double;
type
TGetProc = function: double of object;
TGetIndexed = function(Index: Integer): double of object;
var call: TMethod;
begin
case Getter(Instance,@call) of
picField: result := unaligned(PDouble(call.Data)^);
picMethod: result := TGetProc(call);
picIndexed: result := TGetIndexed(call)(Index);
else result := 0;
end;
end;
procedure TPropInfo.SetDoubleProp(Instance: TObject; Value: Double);
type
TSetProc = procedure(const Value: double) of object;
TSetIndexed = procedure(Index: integer; const Value: double) of object;
var call: TMethod;
begin
case Setter(Instance,@call) of
picField: unaligned(PDouble(call.Data)^) := Value;
picMethod: TSetProc(call)(Value);
picIndexed: TSetIndexed(call)(Index,Value);
end;
end;
function TPropInfo.GetFloatProp(Instance: TObject): double;
type
TSingleProc = function: Single of object;
TSingleIndexed = function(Index: Integer): Single of object;
TDoubleProc = function: Double of object;
TDoubleIndexed = function(Index: Integer): Double of object;
TExtendedProc = function: Extended of object;
TExtendedIndexed = function(Index: Integer): Extended of object;
TCurrencyProc = function: Currency of object;
TCurrencyIndexed = function(Index: Integer): Currency of object;
var call: TMethod;
ft: TFloatType;
begin
result := 0;
ft := {$ifdef HASINLINE}PropType^.FloatType{$else}
PFloatType(@PropType^.Name[ord(PropType^.Name[0])+1])^{$endif};
case Getter(Instance,@call) of
picField:
case ft of
ftSingle: result := PSingle(call.Data)^;
ftDoub: result := unaligned(PDouble(call.Data)^);
ftExtended: result := PExtended(call.Data)^;
ftCurr: result := PCurrency(call.Data)^;
end;
picMethod:
case ft of
ftSingle: result := TSingleProc(call);
ftDoub: result := TDoubleProc(call);
ftExtended: result := TExtendedProc(call);
ftCurr: result := TCurrencyProc(call);
end;
picIndexed:
case ft of
ftSingle: result := TSingleIndexed(call)(Index);
ftDoub: result := TDoubleIndexed(call)(Index);
ftExtended: result := TExtendedIndexed(call)(Index);
ftCurr: result := TCurrencyIndexed(call)(Index);
end;
end;
end;
procedure TPropInfo.SetFloatProp(Instance: TObject; Value: TSynExtended);
type
TSingleProc = procedure(const Value: Single) of object;
TSingleIndexed = procedure(Index: integer; const Value: Single) of object;
TDoubleProc = procedure(const Value: double) of object;
TDoubleIndexed = procedure(Index: integer; const Value: double) of object;
TExtendedProc = procedure(const Value: Extended) of object;
TExtendedIndexed = procedure(Index: integer; const Value: Extended) of object;
TCurrencyProc = procedure(const Value: Currency) of object;
TCurrencyIndexed = procedure(Index: integer; const Value: Currency) of object;
var call: TMethod;
ft: TFloatType;
begin
ft := {$ifdef HASINLINE}PropType^.FloatType{$else}
PFloatType(@PropType^.Name[ord(PropType^.Name[0])+1])^{$endif};
case Setter(Instance,@call) of
picField:
case ft of
ftSingle: PSingle(call.Data)^ := Value;
ftDoub: unaligned(PDouble(call.Data)^) := Value;
ftExtended: PExtended(call.Data)^ := Value;
ftCurr: PCurrency(call.Data)^ := Value;
end;
picMethod:
case ft of
ftSingle: TSingleProc(call)(Value);
ftDoub: TDoubleProc(call)(Value);
ftExtended: TExtendedProc(call)(Value);
ftCurr: TCurrencyProc(call)(Value);
end;
picIndexed:
case ft of
ftSingle: TSingleIndexed(call)(Index,Value);
ftDoub: TDoubleIndexed(call)(Index,Value);
ftExtended: TExtendedIndexed(call)(Index,Value);
ftCurr: TCurrencyIndexed(call)(Index,Value);
end;
end;
end;
{$ifndef NOVARIANTS}
procedure TPropInfo.GetVariantProp(Instance: TObject; var result: Variant);
procedure SubProc(pic: TPropInfoCall; const call: TMethod); // avoid try..finally
type
TGetProc = function: variant of object;
TGetIndexed = function(Index: Integer): variant of object;
begin
case pic of
picMethod: result := TGetProc(call);
picIndexed: result := TGetIndexed(call)(Index);
else result := '';
end;
end;
var pic: TPropInfoCall;
call: TMethod;
begin
pic := Getter(Instance,@call);
if pic=picField then
SetVariantByValue(PVariant(call.Data)^,result) else
SubProc(pic,call);
end;
procedure TPropInfo.SetVariantProp(Instance: TObject; const Value: Variant);
type
TSetProc = procedure(const Value: variant) of object;
TSetIndexed = procedure(Index: integer; const Value: variant) of object;
var call: TMethod;
begin
case Setter(Instance,@call) of
picField: PVariant(call.Data)^ := Value;
picMethod: TSetProc(call)(Value);
picIndexed: TSetIndexed(call)(Index,Value);
end;
end;
{$endif NOVARIANTS}
{ 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;
begin
result := GetEnumNameOrd(FromOrdType(OrdType,@Value));
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
inc(PByte(result),ord(result^[0])+1);
dec(Value);
end else
result := @NULL_SHORTSTRING;
end;
{$else} {$ifdef FPC} nostackframe; assembler; {$endif}
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;
temp: TTextWriterStackBuffer;
begin
W := TTextWriter.CreateOwnedStream(temp);
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 GetAllBits(Value,MaxValue+1) then
W.AddShort('"*"') else begin
PS := @NameList;
for j := MinValue to MaxValue do begin
if GetBitPtr(@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 GetAllBits(Value,MaxValue+1) then
arr.AddItem('*') else begin
PS := @NameList;
for j := MinValue to MaxValue do begin
if GetBitPtr(@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; const Suffix: RawUTF8);
begin
GetEnumNameAll(result,Prefix,quotedValues,Suffix,{trimed=}true);
end;
function TEnumType.GetEnumNameAllAsJSONArray(TrimLeftLowerCase, UnCamelCased: boolean): RawUTF8;
begin
GetEnumNameAll(result,'[',{quoted=}true,']',TrimLeftLowerCase,UnCamelCased);
end;
procedure TEnumType.GetEnumNameAll(var result: RawUTF8; const Prefix: RawUTF8;
quotedValues: boolean; const Suffix: RawUTF8; trimedValues, unCamelCased: boolean);
var i: integer;
V: PShortString;
uncamel: string;
temp: TTextWriterStackBuffer;
begin
with TTextWriter.CreateOwnedStream(temp) do
try
AddString(Prefix);
V := @NameList;
for i := MinValue to MaxValue do begin
if quotedValues then
Add('"');
if unCamelCased then begin
GetCaptionFromTrimmed(V,uncamel);
AddNoJSONEscapeString(uncamel);
end else
if trimedValues then
AddTrimLeftLowerCase(V) else
AddShort(V^);
if quotedValues then
Add('"');
Add(',');
inc(PByte(V),length(V^)+1);
end;
CancelLastComma;
AddString(Suffix);
SetText(result);
finally
Free;
end;
end;
procedure TEnumType.GetEnumNameAll(var result: TRawUTF8DynArray;
TrimLeftLowerCase: boolean);
var max,i: integer;
V: PShortString;
begin
Finalize(result);
max := MaxValue-MinValue;
SetLength(result,max+1);
V := @NameList;
for i := 0 to max do begin
if TrimLeftLowerCase then
result[i] := TrimLeftLowerCaseShort(V) else
result[i] := RawUTF8(V^);
inc(PByte(V),length(V^)+1);
end;
end;
procedure TEnumType.AddCaptionStrings(Strings: TStrings; UsedValuesBits: Pointer);
var i, L: PtrInt;
Line: array[byte] of AnsiChar;
P: PAnsiChar;
V: PShortString;
s: string;
begin
if @self=nil then
exit;
{$ifndef LVCL}
Strings.BeginUpdate;
try
{$endif}
V := @NameList;
for i := MinValue to MaxValue do begin
if (UsedValuesBits=nil) or
GetBitPtr(UsedValuesBits,i) then begin
L := ord(V^[0]);
P := @V^[1];
while (L>0) and (P^ in ['a'..'z']) do begin // ignore left lowercase chars
inc(P);
dec(L);
end;
if L=0 then begin
L := ord(V^[0]);
P := @V^[1];
end;
Line[L] := #0; // GetCaptionFromPCharLen() expect it as ASCIIZ
MoveFast(P^,Line,L);
GetCaptionFromPCharLen(Line,s);
Strings.AddObject(s,pointer(i));
end;
inc(PByte(V),length(V^)+1);
end;
{$ifndef LVCL}
finally
Strings.EndUpdate;
end;
{$endif}
end;
function TEnumType.GetCaptionStrings(UsedValuesBits: Pointer): 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 := GetEnumNameTrimedValue(@EnumName[1],ord(EnumName[0]));
end;
function TEnumType.GetEnumNameTrimedValue(Value: PUTF8Char; ValueLen: integer): Integer;
begin
if Value=nil then
result := -1 else begin
if ValueLen=0 then
ValueLen := StrLen(Value);
result := FindShortStringListTrimLowerCase(@NameList,MaxValue,Value,ValueLen);
if result<0 then
result := FindShortStringListExact(@NameList,MaxValue,Value,ValueLen);
end;
end;
function TEnumType.SizeInStorageAsEnum: Integer;
begin
result := ORDTYPE_SIZE[OrdType]; // MaxValue does not work e.g. with WordBool
end;
procedure TEnumType.SetEnumFromOrdinal(out Value; Ordinal: Integer);
begin
ToOrdType(OrdType,@Value,Ordinal); // MaxValue does not work e.g. with WordBool
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;
{ TTypeInfo - not inlined methods }
function TTypeInfo.ClassCreate: TObject;
var instance: TClassInstance;
begin
instance.Init(ClassType^.ClassType);
result := instance.CreateNew;
end;
function TTypeInfo.ClassFieldCount(onlyWithoutGetter: boolean): integer;
begin
result := ClassFieldCountWithParents(ClassType^.ClassType,onlyWithoutGetter);
end;
function TTypeInfo.ClassSQLFieldType: TSQLFieldType;
const T_: array[0..5{$ifndef LVCL}+1{$endif}] of TClass = (
TSQLRecordMany,TSQLRecord,TRawUTF8List,TStrings,TObjectList,TObject
{$ifndef LVCL},TCollection{$endif});
var CT: PClassType;
C: TClass;
T: PClassArray;
begin
CT := AlignTypeData(PAnsiChar(@Name[1])+ord(Name[0])); // inlined ClassType
C := CT^.ClassType;
T := @T_;
result := sftUnknown;
while true do // unrolled several InheritsFrom() calls
if C<>T[0] then
if C<>T[1] then
if (C<>T[2]) and (C<>T[3]) and (C<>T[4]){$ifndef LVCL}and (C<>T[6]){$endif} then
if CT^.ParentInfo<>nil then begin
if CT^.PropCount>0 then
result := sftObject; // identify any class with published properties
{$ifdef HASDIRECTTYPEINFO}
with PTypeInfo(CT^.ParentInfo)^ do
{$else} // circumvent weird Delphi inlining compiler random bug
with CT^.ParentInfo^^ do
{$endif} // get parent ClassType
CT := AlignTypeData(PAnsiChar(@Name[1])+ord(Name[0]));
C := CT^.ClassType;
if C<>T[5] then
continue else
break;
end else break
else begin
result := sftObject; // TStrings,TObjectList,TRawUTF8List or TCollection
break;
end else begin
result := sftID; // TSQLRecord field is pointer(RecordID), not an Instance
break;
end else begin
result := sftMany; // no data is stored here, but in a pivot table
break;
end;
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; // works also for otSQWord,otUQWord
exit; // direct exit is faster in generated asm code
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(TUnixTime) then begin
result := sftUnixTime;
exit;
end else
if @self=TypeInfo(TUnixMSTime) then begin
result := sftUnixMSTime;
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;
tkQWord: begin
result := sftInteger;
exit;
end;
{$endif FPC}
tkSet: begin
result := sftSet;
exit;
end;
tkEnumeration:
{$ifndef FPC}
if @self=TypeInfo(Boolean) then begin
result := sftBoolean;
exit;
end else
{$endif FPC}
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
if @self=TypeInfo(TDateTimeMS) then begin
result := sftDateTimeMS;
exit;
end else begin
result := sftFloat;
exit;
end;
{$ifdef FPC}tkLStringOld,{$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 NOVARIANTS}
tkClass: begin
result := ClassSQLFieldType;
exit;
end;
// note: tkString (shortstring) and tkInterface not handled
else begin
result := sftUnknown;
exit;
end;
end;
end;
function TTypeInfo.EnumBaseType: PEnumType;
{$ifdef FPC}
var base: PTypeInfo;
begin
result := GetTypeData(self);
if Kind=tkBool then
exit; // circumvent diverse RTTI encoding
base := DeRef(result^.BaseType);
if (base<>nil) and (base<>@self) then // no redirection if already the base type
result := GetTypeData(base^);
end;
{$else}
{$ifdef HASINLINENOTX86}
begin
with PEnumType(@Name[ord(Name[0])+1])^.BaseType^^ do
result := @Name[ord(Name[0])+1];
end;
{$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]
end;
{$endif}
{$endif FPC}
function TTypeInfo.SetEnumType: PEnumType;
begin
if (@self=nil) or (Kind<>tkSet) then
result := nil else
{$ifdef FPC}
result := PTypeInfo(GetSetBaseEnum(@self))^.EnumBaseType;
{$else}
result := PPTypeInfo(PPointer(PtrUInt(@Name[ord(Name[0])+1])+SizeOf(TOrdType))^)^.EnumBaseType;
{$endif FPC}
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.DynArraySQLFieldType: TSQLFieldType;
var item: mORMot.PTypeInfo;
begin
if @self=nil then
result := sftUnknown else begin
item := DynArrayTypeInfoToRecordInfo(@self);
if item=nil then
result := sftUnknown else
result := item^.GetSQLFieldType;
end;
end;
function TTypeInfo.AnsiStringCodePage: integer;
begin
{$ifdef HASCODEPAGE}
if @self=TypeInfo(TSQLRawBlob) then
result := CP_SQLRAWBLOB else
if Kind=tkLString then // has tkLStringOld any codepage? -> UTF-8
result := PWord(GetTypeData(self))^ else
{$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) then
result := CP_ACP else
{$endif HASCODEPAGE}
result := CP_UTF8; // default is UTF-8
end;
function TTypeInfo.InterfaceGUID: PGUID;
begin
if (@self=nil) or (Kind<>tkInterface) then
result := nil else
result := @InterfaceType^.IntfGuid;
end;
function TTypeInfo.InterfaceUnitName: PShortString;
begin
if (@self=nil) or (Kind<>tkInterface) then
result := @NULL_SHORTSTRING else
result := @InterfaceType^.IntfUnit;
end;
function TTypeInfo.InterfaceAncestor: PTypeInfo;
begin
if (@self=nil) or (Kind<>tkInterface) then
result := nil else
result := Deref(InterfaceType^.IntfParent);
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;
typ := InterfaceType;
repeat
if typ^.IntfParent=nil then
exit;
nfo := Deref(typ^.IntfParent);
if nfo=TypeInfo(IInterface) then
exit;
typ := nfo^.InterfaceType;
if ifHasGuid in typ^.IntfFlags then begin
if OnlyImplementedBy<>nil then begin
entry := OnlyImplementedBy.GetInterfaceEntry(typ^.IntfGuid);
if entry=nil then
continue;
SetLength(AncestorsImplementedEntry,n+1);
AncestorsImplementedEntry[n] := entry;
end;
SetLength(Ancestors,n+1);
Ancestors[n] := nfo;
inc(n);
end;
until false;
end;
{$ifdef FPC_PROVIDE_ATTR_TABLE}
function TTypeInfo.AttributeTable: PFPCAttributeTable;
begin
result := GetTypeDataClean(self);
end;
{$endif FPC_PROVIDE_ATTR_TABLE}
{ 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 }
function TClassType.ClassProp: PClassProp;
begin
if pointer(@self)<>nil then
result := AlignToPtr(@UnitName[ord(UnitName[0])+1]) else
result := nil; // avoid GPF
end;
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;
function TClassType.InheritsFrom(AClass: TClass): boolean;
{$ifdef FPC_OR_PUREPASCAL}
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}
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}
function SQLWhereIsEndClause(const Where: RawUTF8): boolean;
begin
result := IdemPCharArray(GotoNextNotSpace(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 simple = all non-blob fields
result := SimpleFields else
result := Select;
result := 'SELECT '+result+' FROM '+TableName+SQLFromWhere(Where);
end;
function SelectInClause(const PropName: RawUTF8; const Values: array of RawUTF8;
const Suffix: RawUTF8; ValuesInlinedMax: integer): RawUTF8;
var n, i: integer;
temp: TTextWriterStackBuffer;
begin
n := length(Values);
if n>0 then
with TTextWriter.CreateOwnedStream(temp) do
try
AddString(PropName);
if n=1 then begin
if ValuesInlinedMax>1 then
AddShort('=:(') else
Add('=');
AddQuotedStr(pointer(Values[0]),'''');
if ValuesInlinedMax>1 then
AddShort('):');
end else begin
AddShort(' in (');
for i := 0 to n-1 do begin
if ValuesInlinedMax>n then
Add(':','(');
AddQuotedStr(pointer(Values[i]),'''');
if ValuesInlinedMax>n then
AddShort('):,') else
Add(',');
end;
CancelLastComma;
Add(')');
end;
AddString(Suffix);
SetText(result);
finally
Free;
end else
result := '';
end;
function SelectInClause(const PropName: RawUTF8; const Values: array of Int64;
const Suffix: RawUTF8; ValuesInlinedMax: integer): RawUTF8;
var n, i: integer;
temp: TTextWriterStackBuffer;
begin
n := length(Values);
if n>0 then
with TTextWriter.CreateOwnedStream(temp) do
try
AddString(PropName);
if n=1 then begin
if ValuesInlinedMax>1 then
AddShort('=:(') else
Add('=');
Add(Values[0]);
if ValuesInlinedMax>1 then
AddShort('):');
end else begin
AddShort(' in (');
for i := 0 to n-1 do begin
if ValuesInlinedMax>n then
Add(':','(');
Add(Values[i]);
if ValuesInlinedMax>n then
AddShort('):,') else
Add(',');
end;
CancelLastComma;
Add(')');
end;
AddString(Suffix);
SetText(result);
finally
Free;
end else
result := '';
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],TableIndex in fTable.fFieldParsedAsString);
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],TableIndex in fTable.fFieldParsedAsString);
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: RawUTF8;
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
Utf8ToRawUTF8(ColumnName,FieldName) else
if IdemPChar(ColumnName,pointer(Props.SQLTableNameUpperWithDot)) then
Utf8ToRawUTF8(ColumnName+length(Props.SQLTableNameUpperWithDot),FieldName) else
if aCheckTableName=ctnMustExist then
continue else
Utf8ToRawUTF8(ColumnName,FieldName);
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 length(fTableMapRecordManyInstances)-1 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: PtrInt;
begin
// auto-instanciate any TSQLRecordMany instance
with RecordProps do
if pointer(ManyFields)<>nil then
for i := 0 to length(ManyFields)-1 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: PtrInt;
begin
// create new instance
result := RecordClass.Create;
// copy properties content
result.fID := fID;
with RecordProps do
for f := 0 to length(CopiableFields)-1 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
if (f in CustomFields) and (f in CopiableFieldsBits) then
Fields.List[f].CopyValue(self,result);
end;
function TSQLRecord.GetNonVoidFields: TSQLFieldBits;
var f: integer;
begin
FillZero(result);
with RecordProps do
for f := 0 to Fields.Count-1 do
if (f in CopiableFieldsBits) and not Fields.List[f].IsValueVoid(self) then
include(result,f);
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);
begin
if (self<>nil) and (aRecord<>nil) then
FillFrom(aRecord, aRecord.RecordProps.CopiableFieldsBits);
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) or IsZero(aRecordFieldBits) 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; // work on a private copy
begin
tmp.Init(JSONTable);
try
Table := TSQLTableJSON.Create('',tmp.buf,tmp.len);
try
FillFrom(Table,Row);
finally
Table.Free;
end;
finally
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,14) then begin
// not expanded format
n := GetJSONIntegerVar(P)-1;
if cardinal(n)>high(F) then
exit;
if Expect(P,ROWCOUNT_PATTERN,12) then
GetJSONIntegerVar(P); // just ignore "rowCount":.. here
if not Expect(P,VALUES_PATTERN,11) 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;
var sqlwhere: RawUTF8;
begin
sqlwhere := FormatUTF8(FormatSQLWhere,[],BoundsSQLWhere);
result := FillPrepare(aClient,sqlwhere,aCustomFieldsCSV);
end;
function TSQLRecord.FillPrepare(aClient: TSQLRest;
const FormatSQLWhere: RawUTF8; const ParamsSQLWhere, BoundsSQLWhere: array of const;
const aCustomFieldsCSV: RawUTF8): boolean;
var sqlwhere: RawUTF8;
begin
sqlwhere := FormatUTF8(FormatSQLWhere,ParamsSQLWhere,BoundsSQLWhere);
result := FillPrepare(aClient,sqlwhere,aCustomFieldsCSV);
end;
const
INLINED_MAX = 10;
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,SelectInClause('id',aIDs,'',INLINED_MAX),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(aDest: TSQLRecord=nil): 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,aDest);
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 := length(Values)-1;
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,PEnd: PAnsiChar): Boolean;
begin
P := pointer(FromVarUInt64Safe(pointer(P),pointer(PEnd),PQWord(@fID)^));
result := SetBinaryValues(P,PEnd);
end;
function TSQLRecord.SetBinary(const binary: RawByteString): Boolean;
begin
result := SetBinary(pointer(binary),PAnsiChar(pointer(binary))+length(binary));
end;
function TSQLRecord.SetBinaryValues(var P: PAnsiChar; PEnd: PAnsiChar): boolean;
var f: integer;
begin
result := false;
if P=nil then
exit; // on error
with RecordProps do
for f := 0 to Fields.Count-1 do begin
P := Fields.List[f].SetBinary(self,P,PEnd);
if P=nil then
exit;
end;
result := true;
end;
function TSQLRecord.SetBinaryValuesSimpleFields(var P: PAnsiChar; PEnd: 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,PEnd);
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;
{$ifndef NOVARIANTS}
procedure TSQLRecord.ForceVariantFieldsOptions(aOptions: TDocVariantOptions);
var i: integer;
p: TSQLPropInfo;
begin
if self<>nil then
with RecordProps do
if sftVariant in HasTypeFields then
for i := 0 to Fields.Count-1 do
begin
p := Fields.List[i];
if (p.SQLFieldType=sftVariant) and p.InheritsFrom(TSQLPropInfoRTTIVariant) then
with TSQLPropInfoRTTIVariant(p) do
if PropInfo.GetterIsField then
with _Safe(PVariant(PropInfo.GetterAddr(self))^)^ do
if Count>0 then
Options := aOptions;
end;
end;
{$endif}
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, 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],{knownrows=}0);
serializer.SQLRecordOptions := SQLRecordOptions;
GetJSONValuesAndFree(serializer);
end;
function TSQLRecord.GetJSONValues(Expand, 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,{knownrows=}0);
serializer.SQLRecordOptions := SQLRecordOptions;
GetJSONValuesAndFree(serializer);
result := J.DataString;
finally
J.Free;
end;
end;
function TSQLRecord.GetJSONValues(Expand, 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, 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,soBeginning);
GetJSONValues(UsingStream,Expand,withID,Occasion,SQLRecordOptions);
FastSetString(result,UsingStream.Memory,UsingStream.Seek(0,soCurrent));
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;
c: TClass;
SQL, cname, tokenizer: RawUTF8;
M: TSQLVirtualTableClass;
Props: TSQLModelRecordProperties;
fields: TSQLPropInfoList;
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(';
rFTS5: result := result+'fts5(';
rRTree: result := result+'rtree(RowID,';
rRTreeInteger: result := result+'rtree_i32(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+'(';
end;
else raise EModelException.CreateUTF8('%.GetSQLCreate(%)?',[self,ToText(Props.Kind)^]);
end;
fields := Props.Props.Fields;
case Props.Kind of
rFTS3, rFTS4, rFTS5: begin
if (Props.fFTSWithoutContentFields<>'') and (Props.fFTSWithoutContentTableIndex>=0) then begin
result := FormatUTF8('%content="%",',[result,
aModel.Tables[Props.fFTSWithoutContentTableIndex].SQLTableName]);
if Props.Kind = rFTS5 then
result := FormatUTF8('%content_rowid="ID",',[result]);
end;
for i := 0 to fields.Count-1 do
result := result+fields.List[i].Name+',';
if Props.Kind=rFTS5 then // FTS5 knows ascii/porter/unicode61
tokenizer := 'ascii' else
tokenizer := 'simple'; // FTS3-4 know simple/porter/unicode61
c := self;
repeat
ToText(c,cname); // TSQLFTSTest = class(TSQLRecordFTS3Porter)
if IdemPChar(pointer(cname),'TSQLRECORDFTS') and
(cname[14] in ['3','4','5']) then begin
if length(cname)>14 then
tokenizer := copy(cname,15,100);
break; // e.g. TSQLRecordFTS3Porter -> 'Porter'
end;
c := GetClassParent(c);
until c=TSQLRecord;
result := FormatUTF8('% tokenize=%)',[result,LowerCaseU(tokenizer)]);
end;
rRTree, rRTreeInteger: begin
for i := 0 to fields.Count-1 do
with fields.List[i] do
if aAuxiliaryRTreeField in Attributes then // for SQlite3 >= 3.24.0
result := FormatUTF8('%+% %',[result,Name,Props.Props.SQLFieldTypeToSQL(i)]) else
result := result+Name+',';
result[length(result)] := ')';
end;
rCustomForcedID, rCustomAutoID:
result := result+GetVirtualTableSQLCreate(Props.Props);
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 length(SimpleFields)-1 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 length(SimpleFields)-1 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.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 length(SimpleFields)-1 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;
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 length(SimpleFields)-1 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
// comparison of all properties of Reference against self
This := RecordProps;
Ref := Reference.RecordProps;
for i := 0 to length(Ref.SimpleFields)-1 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;
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 length(CopiableFields)-1 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 length(CopiableFields)-1 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;
{$ifdef FPC} nostackframe; assembler; {$endif} 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;
{$ifdef FPC} nostackframe; assembler; {$endif} 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.CreateAndFillPrepare(aJSON: PUTF8Char; aJSONLen: integer);
var aTable: TSQLTable;
begin
Create;
aTable := TSQLTableJSON.CreateFromTables([RecordClass],'',aJSON,aJSONLen);
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 length(JoinedFieldsTable)-1 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 tcIdentifier in TEXT_CHARS[F^] 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 tcIdentifier in TEXT_CHARS[P^] do inc(P); // go to end of field name
FastSetString(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
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 length(ObjectsClass)-1 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 length(SimpleFields)-1 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 := '';
FormatUTF8(aFormatSQLJoin,aParamsSQLJoin,aSQLJoin);
JBeg := pointer(aSQLJoin);
repeat
J := JBeg;
while not (tcIdentifier in TEXT_CHARS[J^]) 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 ' ',')'..
FastSetString(aSQLFrom,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 MSWINDOWS}
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 CPU64}
result := pointer(PtrInt(fID));
{$else}
if PtrUInt(self)<$100000 then // rough estimation, but works in practice
result := self else
try
result := pointer(PtrInt(fID));
except
result := self;
end;
{$endif MSWINDOWS}
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.GetFillReachedEnd: boolean;
begin
result := (self=nil) or (fFill=nil) or (fFill.Table.fRowCount=0) or
(cardinal(fFill.FillCurrentRow)>cardinal(fFill.Table.fRowCount));
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; replaceRowIDWithID: boolean): variant;
begin
GetAsDocVariant(withID,withFields,result,options,replaceRowIDWithID);
end;
procedure TSQLRecord.GetAsDocVariant(withID: boolean;
const withFields: TSQLFieldBits; var result: variant; options: PDocVariantOptions;
replaceRowIDWithID: boolean);
const _ID: array[boolean] of RawUTF8 = ('RowID','ID');
var f,i: integer;
Fields: TSQLPropInfoList;
intvalues: TRawUTF8Interning;
doc: TDocVariantData absolute result;
begin
VarClear(result);
if self=nil then
exit;
Fields := RecordProps.Fields;
doc.InitFast(Fields.Count+1,dvObject);
intvalues := nil;
if options<>nil then begin // force options
PDocVariantData(@result)^.Options := options^;
if dvoInternValues in options^ then
intvalues := DocVariantType.InternValues;
end;
if withID then
doc.Values[doc.InternalAdd(_ID[replaceRowIDWithID])] := fID;
for f := 0 to Fields.Count-1 do
if f in withFields then begin
i := doc.InternalAdd(Fields.List[f].Name);
Fields.List[f].GetVariant(self,doc.Values[i]);
if intvalues<>nil then // doc.Values[i] set manually -> manual interning
intvalues.UniqueVariant(doc.Values[i]);
end;
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}
var
vmtAutoTableLock: TRTLCriticalSection; // atomic set of the VMT AutoTable entry
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;
EnterCriticalSection(vmtAutoTableLock);
try
// TSQLRecordProperties instance is stored into "AutoTable" unused VMT entry
PVMT := pointer(PtrInt(PtrUInt(aTable))+vmtAutoTable);
result := PPointer(PVMT)^;
if result=nil then begin // protect from (unlikely) concurrent call
// create the properties information from RTTI
result := TSQLRecordProperties.Create(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;
finally
LeaveCriticalSection(vmtAutoTableLock);
end;
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(PtrUInt(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 function TSQLRecord.AutoFree(var localVariable; Rest: TSQLRest;
const FormatSQLWhere: RawUTF8; const BoundsSQLWhere: array of const;
const aCustomFieldsCSV: RawUTF8): IAutoFree;
begin
result := TAutoFree.Create(localVariable,CreateAndFillPrepare(Rest,
FormatSQLWhere,BoundsSQLWhere,aCustomFieldsCSV));
end;
class function TSQLRecord.AutoFree(var localVariable; Rest: TSQLRest;
const FormatSQLWhere: RawUTF8; const ParamsSQLWhere,BoundsSQLWhere: array of const;
const aCustomFieldsCSV: RawUTF8): IAutoFree;
begin
result := TAutoFree.Create(localVariable,CreateAndFillPrepare(Rest,
FormatSQLWhere,ParamsSQLWhere,BoundsSQLWhere,aCustomFieldsCSV));
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;
valid: boolean;
begin
result := '';
if (self=nil) or IsZero(aFields) then
// avoid GPF and handle case if no field was selected
exit;
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);
if Validate.InheritsFrom(TSynValidateRest) then
valid := TSynValidateRest(Validate).Validate(f,Value,result, aRest, self)
else
valid := Validate.Process(f,Value,result);
if not valid 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;
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 := FormatString('"%": %',
[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 length(DynArrayFields)-1 do
with DynArrayFields[F] do
if IdemPropNameU(Name,DynArrayFieldName) then begin
GetDynArray(self,result);
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 length(DynArrayFields)-1 do
with DynArrayFields[F] do
if DynArrayIndex=DynArrayFieldIndex then begin
GetDynArray(self,result);
exit;
end;
result.Void;
end;
procedure TSQLRecord.ComputeFieldsBeforeWrite(aRest: TSQLRest; aOccasion: TSQLEvent);
var F: PtrInt;
types: TSQLFieldTypes;
i64: Int64;
p: TSQLPropInfo;
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 begin
p := Fields.List[F];
if p.SQLFieldType in types then
TSQLPropInfoRTTIInt64(p).fPropInfo.SetInt64Prop(self,i64);
end;
end;
if sftSessionUserID in HasTypeFields then begin
i64 := aRest.GetCurrentSessionUserID;
if i64<>0 then
for F := 0 to Fields.Count-1 do begin
p := Fields.List[F];
if p.SQLFieldType=sftSessionUserID then
TSQLPropInfoRTTIInt64(p).fPropInfo.SetInt64Prop(self,i64);
end;
end;
end;
end;
{ TSQLRecordNoCase }
class procedure TSQLRecordNoCase.InternalDefineModel(Props: TSQLRecordProperties);
begin
Props.SetCustomCollationForAll(sftUTF8Text,'NOCASE');
end;
{ TSQLRecordCaseSensitive }
class procedure TSQLRecordCaseSensitive.InternalDefineModel(
Props: TSQLRecordProperties);
begin
Props.SetCustomCollationForAll(sftUTF8Text,'BINARY');
end;
{ TSQLRecordNoCaseExtended }
class procedure TSQLRecordNoCaseExtended.InternalDefineModel(Props: TSQLRecordProperties);
begin
inherited InternalDefineModel(Props); // set NOCASE collation
Props.SetVariantFieldsDocVariantOptions(JSON_OPTIONS_FAST_EXTENDED);
end;
{ TSQLRecordCaseSensitiveExtended }
class procedure TSQLRecordCaseSensitiveExtended.InternalDefineModel(
Props: TSQLRecordProperties);
begin
inherited InternalDefineModel(Props); // set BINARY collation
Props.SetVariantFieldsDocVariantOptions(JSON_OPTIONS_FAST_EXTENDED);
end;
{ TSQLRecordNoCaseExtendedNoID }
class procedure TSQLRecordNoCaseExtendedNoID.InitializeTable(Server: TSQLRestServer;
const FieldName: RawUTF8; Options: TSQLInitializeTableOptions);
begin
inherited InitializeTable(Server, FieldName, Options + [itoNoIndex4TID]);
end;
{ TSQLRecordPropertiesMapping }
procedure TSQLRecordPropertiesMapping.Init(Table: TSQLRecordClass;
const MappedTableName: RawUTF8; MappedConnection: TObject;
AutoComputeSQL: boolean; MappingOptions: TSQLRecordPropertiesMappingOptions);
begin
fOptions := MappingOptions;
fProps := Table.RecordProps;
if MappedTableName='' then
fTableName := fProps.SQLTableName else
fTableName := MappedTableName;
fConnectionProperties := MappedConnection;
fRowIDFieldName := 'ID';
fProps.Fields.NamesToRawUTF8DynArray(fExtFieldNames);
fProps.Fields.NamesToRawUTF8DynArray(fExtFieldNamesUnQuotedSQL);
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
fExtFieldNames[int] := InternalExternalPairs[i*2+1];
fExtFieldNamesUnQuotedSQL[int] := UnQuotedSQLSymbolName(fExtFieldNames[int]);
if IdemPropNameU(fExtFieldNames[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(ExtFieldNames[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([ExtFieldNames[f],'=?,']);
UpdateSetAll:
W.AddStrings([ExtFieldNames[f],'=?,']);
InsertAll:
W.AddStrings([ExtFieldNames[f],',']);
end;
W.CancelLastComma;
W.SetText(result);
end;
var W: TTextWriter;
temp: TTextWriterStackBuffer;
begin
W := TTextWriter.CreateOwnedStream(temp);
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 := fExtFieldNames[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] := fExtFieldNames[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 length(fExtFieldNamesUnQuotedSQL)-1 do
if IdemPropNameU(ExtFieldName,fExtFieldNamesUnQuotedSQL[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(ExtFieldNames)) then
result := true else // FieldIndex out of range
Text := Text+ExtFieldNames[FieldIndex];
end;
function TSQLRecordPropertiesMapping.FieldNameByIndex(FieldIndex: Integer): RawUTF8;
begin
if FieldIndex=VIRTUAL_TABLE_ROWID_COLUMN then
result := RowIDFieldName else
if cardinal(FieldIndex)>=cardinal(Length(ExtFieldNames)) then
result := '' else // FieldIndex out of range
result := ExtFieldNames[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,','RowID,','RowID,');
// rSQLite3, rFTS3, rFTS4, rFTS5, rRTree, rRTreeInteger, 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 length(Props.SimpleFields)-1 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;
var f: integer;
expected: TSQLFieldType;
begin
case Value of // validates virtual table fields expectations
rFTS3, rFTS4, rFTS5: begin
if Props.Fields.Count=0 then
raise EModelException.CreateUTF8(
'Virtual FTS class % should have published properties',[Props.Table]);
for f := 0 to Props.Fields.Count-1 do
with Props.Fields.List[f] do
if SQLFieldTypeStored<>sftUTF8Text then
raise EModelException.CreateUTF8('%.%: FTS field must be RawUTF8',[Props.Table,Name])
end;
rRTree, rRTreeInteger: begin
Props.RTreeCoordBoundaryFields := 0;
if Value=rRTree then
expected := sftFloat else
expected := sftInteger;
for f := 0 to Props.Fields.Count-1 do
with Props.Fields.List[f] do
if aAuxiliaryRTreeField in Attributes then // https://sqlite.org/rtree.html#auxiliary_columns
expected := sftUnknown // will expect further columns to be auxiliary
else if SQLFieldTypeStored<>expected then
raise EModelException.CreateUTF8('%.%: RTREE field must be %',
[Props.Table,Name,ToText(expected)^]) else
inc(Props.RTreeCoordBoundaryFields);
if (Props.RTreeCoordBoundaryFields<2) or
(Props.RTreeCoordBoundaryFields>RTREE_MAX_DIMENSION*2) or
(Props.RTreeCoordBoundaryFields and 1<>0) then
raise EModelException.CreateUTF8('% has % fields: RTREE expects 2,4,6..% boundary columns',
[Props.Table,Props.RTreeCoordBoundaryFields,RTREE_MAX_DIMENSION*2]);
end;
end;
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 not(Kind in [rFTS4,rFTS5]) then
raise EModelException.CreateUTF8('FTS4WithoutContent: % is not a FTS4/5 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, TableID: TSQLRecordClass;
aTableName,aFieldName: RawUTF8;
Props: TSQLModelRecordProperties;
fields: TSQLPropInfoList;
W: TTextWriter;
procedure RegisterTableForRecordReference(aFieldType: TSQLPropInfo;
aFieldTable: TClass);
var R: integer;
begin
if (aFieldTable=nil) or (aFieldTable=TSQLRecord) 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(TSQLRecordFTS5) then
Kind := rFTS5 else
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(TSQLRecordRTreeInteger) then
Kind := rRTreeInteger 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;
UpperCaseCopy(aTableName,fSortedTablesNameUpper[aIndex]);
fSortedTablesNameIndex[aIndex] := aIndex;
fields := Props.Props.Fields;
for f := 0 to fields.Count-1 do
case fields.List[f].SQLFieldType of
sftRecord:
RegisterTableForRecordReference(fields.List[f],Table); // Table not used
sftID:
RegisterTableForRecordReference(
fields.List[f],(fields.List[f] as TSQLPropInfoRTTIInstance).ObjectClass);
sftTID: begin
TableID := (fields.List[f] as TSQLPropInfoRTTITID).RecordClass;
if TableID=nil then // T*ID name didn't match any TSQLRecord type
fields.List[f].fSQLFieldType := sftInteger else
RegisterTableForRecordReference(fields.List[f],TableID);
end;
sftMany:
GetTableIndexSafe(pointer((fields.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 length(SimpleFields)-1 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(fSortedTablesNameUpper,n);
SetLength(fSortedTablesNameIndex,n);
SetLength(fTableProps,n);
fTables[fTablesMax] := aTable;
SetTableProps(fTablesMax);
QuickSortRawUTF8(fSortedTablesNameUpper,fTablesMax+1,@fSortedTablesNameIndex);
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 EModelException.CreateUTF8('%.AddTableInherited(%)',[self,aTable]);
result := Tables[ndx];
end;
function TSQLModel.GetTableInherited(aTable: TSQLRecordClass): TSQLRecordClass;
var ndx: integer;
begin
ndx := GetTableIndexInheritsFrom(aTable);
if ndx<0 then
result := aTable else
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]);
SetRoot(CloneFrom.fRoot);
fActions := CloneFrom.fActions;
fEvents := CloneFrom.fEvents;
fRestOwner := CloneFrom.fRestOwner;
fSortedTablesNameUpper := CloneFrom.fSortedTablesNameUpper;
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;
function TSQLModel.SafeRoot: RawUTF8;
begin
if self=nil then
result := '' else
result := fRoot;
end;
procedure TSQLModel.SetRoot(const aRoot: RawUTF8);
var i: integer;
begin
for i := 1 to length(aRoot) do // allow RFC URI + '/' for URI-fragment
if not (aRoot[i] in ['0'..'9','a'..'z','A'..'Z','_','-','.','~',' ','/']) then
raise EModelException.CreateUTF8('%.Root="%" contains URI unfriendly chars',[self,aRoot]);
if (aRoot<>'') and (aRoot[length(aRoot)]='/') then
fRoot := copy(aRoot,1,Length(aRoot)-1) else
fRoot := aRoot;
UpperCaseCopy(fRoot,fRootUpper);
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('% % 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(fSortedTablesNameUpper,N);
SetLength(fSortedTablesNameIndex,N);
SetLength(fTableProps,N);
// initialize internal properties
for i := 0 to fTablesMax do
SetTableProps(i);
QuickSortRawUTF8(fSortedTablesNameUpper,fTablesMax+1,@fSortedTablesNameIndex);
// set the optional Root URI path of this Model
if aRoot<>'' then
SetRoot(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 tcIdentifier in TEXT_CHARS[SQL[i+j]] 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
FastSetString(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 tcIdentifier in TEXT_CHARS[SQL[i+j]] 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);
FastSetString(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
result := nil;
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: PtrInt;
Props: TSQLRecordProperties;
c: PSQLRecordClass;
begin
if (self<>nil) and (aTable<>nil) then begin
Props := PPointer(PtrInt(PtrUInt(aTable))+vmtAutoTable)^;
if (Props<>nil) and (Props.fModelMax<fTablesMax) then
// fastest O(1) search in all registered models (if worth it)
for i := 0 to Props.fModelMax do
with Props.fModel[i] do
if Model=self then begin
result := TableIndex; // almost always loop-free
exit;
end;
// manual search e.g. if fModel[] is not yet set
c := pointer(Tables);
for result := 0 to fTablesMax do
if c^=aTable then
exit else
inc(c);
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('%.GetTableIndexExisting(nil) %',[self,Root]);
result := GetTableIndex(aTable);
if result<0 then
raise EModelException.CreateUTF8('% is not part of % %',[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(PtrUInt(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
result := FastFindUpperPUTF8CharSorted( // O(log(n)) binary search
pointer(fSortedTablesNameUpper),fTablesMax,pointer(SQLTableName),length(SQLTableName));
if result>=0 then
result := fSortedTablesNameIndex[result];
end else
result := -1;
end;
function TSQLModel.GetTableIndexPtr(SQLTableName: PUTF8Char): integer;
begin
if (self<>nil) and (SQLTableName<>nil) then begin
result := FastFindUpperPUTF8CharSorted( // O(log(n)) binary search
pointer(fSortedTablesNameUpper),fTablesMax,SQLTableName,StrLen(SQLTableName));
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 IdemPChar(pointer(URI),pointer(fRootUpper)) then begin
URILen := length(fRoot);
if URI[URILen+1] in [#0,'/','?'] then
if CompareMemFixed(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: integer; 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: integer; 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: PtrInt;
begin
if fLocks<>nil then
for i := 0 to length(fLocks)-1 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: PtrInt;
begin
for i := 0 to length(fLocks)-1 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; aMappingOptions: TSQLRecordPropertiesMappingOptions): 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,aMappingOptions);
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;
InternalBufferSize: cardinal);
begin
if aRest=nil then
raise EORMException.CreateUTF8('%.Create(aRest=nil)',[self]);
fRest := aRest;
if InternalBufferSize<4096 then
InternalBufferSize := 4096;
fInternalBufferSize := InternalBufferSize;
Reset(aTable,AutomaticTransactionPerRow,Options);
end;
procedure TSQLRestBatch.Reset(aTable: TSQLRecordClass;
AutomaticTransactionPerRow: cardinal; Options: TSQLRestBatchOptions);
begin
fBatch.Free; // full reset for SetExpandedJSONWriter
fBatch := TJSONSerializer.CreateOwnedStream(fInternalBufferSize);
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;
function TSQLRestBatch.RawAdd(const SentData: RawUTF8): integer;
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(',');
result := fBatchCount;
inc(fBatchCount);
inc(fAddCount);
end;
function TSQLRestBatch.RawUpdate(const SentData: RawUTF8; ID: TID): integer;
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(',');
result := fBatchCount;
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,NextGrow(ValuesCount));
Values[ValuesCount] := Value;
inc(ValuesCount);
end;
procedure AddID(var Values: TIDDynArray; Value: TID);
var n: integer;
begin
n := length(Values);
SetLength(Values,n+1);
Values[n] := Value;
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.fCache.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,ForceCacheUpdate: 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*Props.CopiableFieldsBits else
FieldBits := CustomFields*Props.CopiableFieldsBits+Props.FieldBits[sftModTime];
SetExpandedJSONWriter(Props,fTablePreviousSendData<>PSQLRecordClass(Value)^,
{withID=}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
ForceCacheUpdate := true; // safe to update the cache with supplied values
if ForceCacheUpdate then
fRest.fCache.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,ForceCacheUpdate: boolean): integer;
begin
if (Value=nil) or (fBatch=nil) then
result := -1 else
result := Update(Value,Value.RecordProps.FieldBitsFromCSV(CustomCSVFields),
DoNotAutoComputeFields,ForceCacheUpdate);
end;
{ TSQLRestBatchLocked }
constructor TSQLRestBatchLocked.Create(aRest: TSQLRest; aTable: TSQLRecordClass;
AutomaticTransactionPerRow: cardinal; Options: TSQLRestBatchOptions;
InternalBufferSize: cardinal);
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 := TSynObjectList.Create;
fModel := aModel;
for cmd := Low(cmd) to high(cmd) do
fAcquireExecution[cmd] := TSQLRestAcquireExecution.Create;
AcquireWriteMode := amLocked;
AcquireWriteTimeOut := 5000; // default 5 seconds
fServicesRouting := TSQLRestRoutingREST;
{$ifdef WITHLOG}
SetLogClass(SQLite3Log); // by default
{$endif}
end;
destructor TSQLRest.Destroy;
var cmd: TSQLRestServerURIContextCommand;
i: integer;
begin
InternalLog('TSQLRest.Destroy %',[fModel.SafeRoot],sllInfo); // self->GPF
AsynchBatchStop(nil);
FreeAndNil(fBackgroundTimer);
FreeAndNil(fServices);
FreeAndNil(fCache);
FreeAndNil(fCustomEncryptAES);
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 WITHLOG}
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.NewParallelProcess(ThreadCount: integer; const Format: RawUTF8;
const Args: array of const): TSynParallelProcess;
begin
result := TSynParallelProcess.Create(ThreadCount,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;
function TSQLRest.EnsureBackgroundTimerExists: TSQLRestBackgroundTimer;
begin
if fBackgroundTimer=nil then
fBackgroundTimer := TSQLRestBackgroundTimer.Create(self);
result := fBackgroundTimer;
end;
function TSQLRest.TimerEnable(aOnProcess: TOnSynBackgroundTimerProcess;
aOnProcessSecs: cardinal): TSynBackgroundTimer;
begin
result := nil;
if self=nil then
exit;
if aOnProcessSecs=0 then begin
TimerDisable(aOnProcess);
exit;
end;
result := EnsureBackgroundTimerExists;
result.Enable(aOnProcess,aOnProcessSecs);
end;
function TSQLRest.TimerDisable(aOnProcess: TOnSynBackgroundTimerProcess): boolean;
begin
if (self=nil) or (fBackgroundTimer=nil) then
result := false else
result := fBackgroundTimer.Disable(aOnProcess);
end;
function TSQLRest.AsynchBatchStart(Table: TSQLRecordClass;
SendSeconds, PendingRowThreshold, AutomaticTransactionPerRow: integer;
Options: TSQLRestBatchOptions): boolean;
begin
if self=nil then
result := false else
result := EnsureBackgroundTimerExists.AsynchBatchStart(
Table,SendSeconds,PendingRowThreshold,AutomaticTransactionPerRow,Options);
end;
function TSQLRest.AsynchBatchStop(Table: TSQLRecordClass): boolean;
begin
if (self=nil) or (fBackgroundTimer=nil) or (fBackgroundTimer.fBackgroundBatch=nil) then
result := false else
result := fBackgroundTimer.AsynchBatchStop(Table);
end;
function TSQLRest.AsynchBatchAdd(Value: TSQLRecord; SendData,ForceID: boolean;
const CustomFields: TSQLFieldBits; DoNotAutoComputeFields: boolean): integer;
begin
if (self=nil) or (fBackgroundTimer=nil) or (fBackgroundTimer.fBackgroundBatch=nil) then
result := -1 else
result := fBackgroundTimer.AsynchBatchAdd(
Value,SendData,ForceID,CustomFields,DoNotAutoComputeFields);
end;
function TSQLRest.AsynchBatchRawAdd(Table: TSQLRecordClass; const SentData: RawUTF8): integer;
begin
if (self=nil) or (fBackgroundTimer=nil) or (fBackgroundTimer.fBackgroundBatch=nil) then
result := -1 else
result := fBackgroundTimer.AsynchBatchRawAdd(Table,SentData);
end;
procedure TSQLRest.AsynchBatchRawAppend(Table: TSQLRecordClass; SentData: TTextWriter);
begin
if (self<>nil) and (fBackgroundTimer<>nil) and (fBackgroundTimer.fBackgroundBatch<>nil) then
fBackgroundTimer.AsynchBatchRawAppend(Table,SentData);
end;
function TSQLRest.AsynchBatchUpdate(Value: TSQLRecord;
const CustomFields: TSQLFieldBits; DoNotAutoComputeFields: boolean): integer;
begin
if (self=nil) or (fBackgroundTimer=nil) or (fBackgroundTimer.fBackgroundBatch=nil) then
result := -1 else
result := fBackgroundTimer.AsynchBatchUpdate(Value,CustomFields,DoNotAutoComputeFields);
end;
function TSQLRest.AsynchBatchDelete(Table: TSQLRecordClass; ID: TID): integer;
begin
if (self=nil) or (fBackgroundTimer=nil) or (fBackgroundTimer.fBackgroundBatch=nil) then
result := -1 else
result := fBackgroundTimer.AsynchBatchDelete(Table,ID);
end;
procedure TSQLRest.AsynchRedirect(const aGUID: TGUID;
const aDestinationInterface: IInvokable; out aCallbackInterface;
const aOnResult: TOnAsynchRedirectResult);
begin
if self<>nil then
EnsureBackgroundTimerExists.AsynchRedirect(
aGUID,aDestinationInterface,aCallbackInterface,aOnResult);
end;
procedure TSQLRest.AsynchRedirect(const aGUID: TGUID;
const aDestinationInstance: TInterfacedObject; out aCallbackInterface;
const aOnResult: TOnAsynchRedirectResult);
begin
if self<>nil then
EnsureBackgroundTimerExists.AsynchRedirect(
aGUID,aDestinationInstance,aCallbackInterface,aOnResult);
end;
procedure TSQLRest.AsynchInterning(Interning: TRawUTF8Interning;
InterningMaxRefCount, PeriodMinutes: integer);
begin
if self<>nil then
EnsureBackgroundTimerExists.AsynchInterning(
Interning,InterningMaxRefCount,PeriodMinutes);
end;
function TSQLRest.SystemUseTrack(periodSec: integer): TSystemUse;
begin
result := nil;
if self=nil then
exit;
result := TSystemUse.Current;
if (result.Timer=nil) or
((BackgroundTimer<>nil) and (result.Timer=BackgroundTimer)) then begin
if periodSec>0 then
result.Timer := EnsureBackgroundTimerExists;
TimerEnable(result.BackgroundExecute,periodSec); // disable if periodSec=0
end;
end;
procedure DoSign(const signer: TSynSigner; const url,body: RawUTF8; bodylen: integer;
out hash: THash512Rec);
var L: integer;
P: PAnsiChar;
sign: TSynSigner;
begin
sign := signer; // thread-safe copy
P := pointer(url);
L := length(url);
if P^='/' then begin
inc(P);
dec(L);
end;
sign.Update(P,L);
sign.Update(pointer(body),bodylen);
sign.Final(hash);
end;
procedure TSQLRest.InternalCustomDecrypt(Sender: TSQLRest; var Body,Head,Url: RawUTF8);
var ct: RawUTF8;
L: integer;
hash: THash512Rec;
begin
if (fCustomEncryptContentPrefix='') or (Body='') or (Sender<>self) or
(Url='') or IdemPChar(pointer(Url),pointer(fCustomEncryptUrlIgnore)) then
exit;
FindNameValue(Head,HEADER_CONTENT_TYPE_UPPER,ct);
if IdemPChar(pointer(ct),pointer(fCustomEncryptContentPrefixUpper)) then begin
if fCustomEncryptAES<>nil then begin
// decrypt using PKCS7 + initial random/unique IV at the beginning
Body := fCustomEncryptAES.DecryptPKCS7(Body,true,false);
if Body='' then begin
InternalLog('CustomEncrypt %.DecryptPKCS7 reject',[fCustomEncryptAES.ClassType],sllUserAuth);
exit;
end;
end;
if fCustomEncryptCompress<>nil then begin
// optionally uncompresss Body+signature
Body := fCustomEncryptCompress.Decompress(Body);
if Body='' then begin
InternalLog('CustomEncrypt %.Decompress reject %',[fCustomEncryptCompress.ClassType]);
exit;
end;
end;
L := length(Body)-fCustomEncryptSign.SignatureSize;
if (L>0) and (fCustomEncryptSign.SignatureSize<>0) then begin
// validate the binary signature of supplied Url+Body at the Body end
DoSign(fCustomEncryptSign,Url,Body,L,hash);
if not CompareMemFixed(@hash,@PByteArray(Body)[L],fCustomEncryptSign.SignatureSize) then begin
Body := '';
InternalLog('CustomEncrypt % reject',[ToText(fCustomEncryptSign.Algo)^],sllUserAuth);
exit;
end;
SetLength(Body,L);
end;
system.delete(ct,1,length(fCustomEncryptContentPrefix));
UpdateIniNameValue(Head,'',HEADER_CONTENT_TYPE_UPPER,ct);
end else begin
Body := '';
InternalLog('CustomEncrypt no % -> reject',[fCustomEncryptContentPrefix]);
end;
end;
procedure TSQLRest.InternalCustomEncrypt(Sender: TSQLRest; var Body,Head,Url: RawUTF8);
var ct: RawUTF8;
L: integer;
hash: THash512Rec;
begin
if (fCustomEncryptContentPrefix='') or (Body='') or (Sender<>self) or
(Url='') or IdemPChar(pointer(Url),pointer(fCustomEncryptUrlIgnore)) then
exit;
if fCustomEncryptSign.SignatureSize<>0 then begin
// append the binary signature of supplied Url+Body to the Body
L := length(Body);
DoSign(fCustomEncryptSign,Url,Body,L,hash);
SetLength(Body,L+fCustomEncryptSign.SignatureSize);
MoveSmall(@hash,@PByteArray(Body)[L],fCustomEncryptSign.SignatureSize);
end;
if fCustomEncryptCompress<>nil then
// optionally compresss Body+signature
Body := fCustomEncryptCompress.Compress(Body);
if fCustomEncryptAES<>nil then
// encrypt using PKCS7 + initial random/unique IV at the beginning
Body := fCustomEncryptAES.EncryptPKCS7(Body,true);
FindNameValue(Head,HEADER_CONTENT_TYPE_UPPER,ct);
if ct='' then // not specified -> append 'application/json'
ct := JSON_CONTENT_TYPE_VAR;
UpdateIniNameValue(Head,HEADER_CONTENT_TYPE,HEADER_CONTENT_TYPE_UPPER,
fCustomEncryptContentPrefix+ct)
end;
procedure TSQLRest.SetCustomEncryption(aes: TAESAbstract; sign: PSynSigner;
comp: TAlgoCompress; const uriignore: RawUTF8);
var tmp: PShortString; // temp variable to circumvent FPC bug
s: RawUTF8;
begin
fCustomEncryptContentPrefix := ''; // disable encryption
fCustomEncryptCompress := nil;
fCustomEncryptUrlIgnore := '';
FreeAndNil(fCustomEncryptAES);
fOnDecryptBody := nil;
fOnEncryptBody := nil;
fCustomEncryptAES := aes;
if aes=nil then
if sign=nil then
exit else
fCustomEncryptContentPrefix := '0' else begin
tmp := ClassNameShort(aes); // TAESECB_API -> 'AESECB'
FastSetString(s,@tmp^[2],6);
fCustomEncryptContentPrefix := s+UInt32ToUtf8(aes.KeySize);
end;
if (sign=nil) or (sign^.SignatureSize=0) then begin
FillCharFast(fCustomEncryptSign,SizeOf(fCustomEncryptSign),0);
fCustomEncryptContentPrefix := fCustomEncryptContentPrefix+'0/';
end else begin
fCustomEncryptSign := sign^;
tmp := ToText(sign^.Algo); // saSha3384 -> 'sha3384'
FastSetString(s,@tmp^[3],ord(tmp^[0])-2);
fCustomEncryptContentPrefix := fCustomEncryptContentPrefix+s+'/';
end;
fCustomEncryptContentPrefix := LowerCase(fCustomEncryptContentPrefix);
fCustomEncryptContentPrefixUpper := UpperCase(fCustomEncryptContentPrefix);
fCustomEncryptCompress := comp;
fCustomEncryptUrlIgnore := UpperCase(uriignore);
fOnDecryptBody := InternalCustomDecrypt;
fOnEncryptBody := InternalCustomEncrypt;
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<>fServicesRouting then
if (aServicesRouting=nil) or (aServicesRouting=TSQLRestServerURIContext) then
raise EServiceException.CreateUTF8('Unexpected %.SetRoutingClass(%)',
[self,aServicesRouting]) else
fServicesRouting := 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.OneFieldValueInt64(Table: TSQLRecordClass; const FieldName,
WhereClause: RawUTF8; Default: Int64): Int64;
var Res: array[0..0] of RawUTF8;
begin
if not MultiFieldValue(Table,[FieldName],Res,WhereClause) or
not ToInt64(Res[0],result) then
result := Default;
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
if fCache.Retrieve(Model.GetTableIndexExisting(Table),ID)<>'' then
result := true else
result := OneFieldValue(Table,'RowID',ID)<>''; // try from DB
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 T: TSQLTableJSON;
begin
result := false;
T := MultiFieldValues(Table,FieldName,WhereClause);
if T<>nil then
try
result := T.GetRowValues(0,Data)>0;
finally
T.Free;
end;
end;
function TSQLRest.OneFieldValues(Table: TSQLRecordClass; const FieldName,
WhereClause: RawUTF8; Strings: TStrings; IDToIndex: PID): 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(PtrInt(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: PtrInt;
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 := SepLen*(T.fRowCount-1);
for i := 1 to T.fRowCount do begin
L := StrLen(T.fResults[i]); // ignore fResults[0] i.e. field name
inc(Len,L);
Lens[i-1] := L;
end;
SetLength(result,Len);
// add row values as CSV
P := pointer(result);
i := 1;
repeat
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);
inc(i);
until false;
//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) and (StrPosI('AND',P)=nil) and (StrPosI('OR',P)=nil) then
case P^ of
'=': begin // SELECT RowID from Table where RowID=10
P := GotoNextNotSpace(P+1);
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 (PosExChar(',',FieldNames)=0) and (PosExChar('(',FieldNames)=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;
var where: RawUTF8;
begin
where := FormatUTF8(WhereClauseFormat,[],BoundsSQLWhere);
result := MultiFieldValues(Table,FieldNames,where);
end;
function TSQLRest.MultiFieldValues(Table: TSQLRecordClass;
const FieldNames: RawUTF8; const WhereClauseFormat: RawUTF8;
const Args, Bounds: array of const): TSQLTableJSON;
var where: RawUTF8;
begin
where := FormatUTF8(WhereClauseFormat,Args,Bounds);
result := MultiFieldValues(Table,FieldNames,where);
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;
P: PUTF8Char;
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 begin
P := T.fResults[T.FieldCount+i];
FastSetString(FieldValue[i],P,StrLen(P));
end;
result := true;
finally
T.Free;
end;
end;
end;
function TSQLRest.Retrieve(const SQLWhere: RawUTF8; Value: TSQLRecord;
const aCustomFieldsCSV: RawUTF8): boolean;
var T: TSQLTable;
sql: RawUTF8;
begin
result := false;
if (self=nil) or (Value=nil) then
exit;
sql := Trim(SQLWhere);
if not EndWith(sql,' LIMIT 1') then
sql := sql+' LIMIT 1'; // we keep a single record below
T := MultiFieldValues(PSQLRecordClass(Value)^,aCustomFieldsCSV,sql);
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;
var where: RawUTF8;
begin
where := FormatUTF8(FormatSQLWhere,[],BoundsSQLWhere);
result := RetrieveListJSON(Table,where,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;
function TSQLRest.RTreeMatch(DataTable: TSQLRecordClass;
const DataTableBlobFieldName: RawUTF8; RTreeTable: TSQLRecordRTreeClass;
const DataTableBlobField: RawByteString; var DataID: TIDDynArray): boolean;
var Blob: PPropInfo;
Res: TSQLTableJSON;
BDouble: TSQLRecordTreeCoords;
BInteger: TSQLRecordTreeCoordsInteger absolute BDouble;
Where, SQL: 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;
if RTreeTable.InheritsFrom(TSQLRecordRTree) then begin
TSQLRecordRTree(RTreeTable).BlobToCoord(pointer(DataTableBlobField)^,BDouble);
for i := 0 to (RTree.RTreeCoordBoundaryFields shr 1)-1 do
Where := FormatUTF8('%%>=:(%): and %<=:(%): and ',
[Where,RTree.Fields.List[i*2].Name,BDouble[i].Min*(1-0.00000012),
RTree.Fields.List[i*2+1].Name,BDouble[i].Max*(1+0.00000012)]);
{ from http://sqlite.org/rtree.html:
For a "contained-within" style query, rounding the bounding boxes outward
might cause some entries to be excluded from the result set if the edge of
the entry bounding box corresponds to the edge of the query bounding box.
To guard against this, applications should expand their contained-within
query boxes slightly (by 0.000012%) by rounding down the lower coordinates
and rounding up the top coordinates, in each dimension. }
end else
if RTreeTable.InheritsFrom(TSQLRecordRTreeInteger) then begin
TSQLRecordRTreeInteger(RTreeTable).BlobToCoord(pointer(DataTableBlobField)^,BInteger);
for i := 0 to (RTree.RTreeCoordBoundaryFields shr 1)-1 do
Where := FormatUTF8('%%>=:(%): and %<=:(%): and ',
[Where,RTree.Fields.List[i*2].Name,BInteger[i].Min,
RTree.Fields.List[i*2+1].Name,BInteger[i].Max]);
end else
exit;
FormatUTF8('select %.RowID from %,% where %.RowID=%.RowID and %%(%,:(%):);',
[RTree.SQLTableName,Data.SQLTableName,RTree.SQLTableName,Data.SQLTableName,
Where,RTreeTable.RTreeSQLFunctionName,Data.SQLTableName,
BinToBase64WithMagic(DataTableBlobField)],sql);
Res := ExecuteList([DataTable,RTreeTable],sql);
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;
{$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,{readonly=}false); // not readonly -> 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.fRowCount,dvArray);
res.SetCount(T.fRowCount);
for row := 1 to T.fRowCount 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 fCache.IsCached(Table) and (length(BoundsSQLWhere)=1) and
VarRecToInt64(BoundsSQLWhere[0],Int64(ID)) and
FieldBitsFromCSV(CustomFieldsCSV,bits) and
(IdemPropNameU('RowID=?',FormatSQLWhere) or
IdemPropNameU('ID=?',FormatSQLWhere)) then begin
if IsZero(bits) then // get all simple fields, like MultiFieldValues()
bits := SimpleFieldsBits[soSelect];
if bits-SimpleFieldsBits[soSelect]=[] then begin
Rec := Table.Create(self,ID); // use the cache
try
Rec.GetAsDocVariant(true,bits,result,nil,{"id"=}true);
finally
Rec.Free;
end;
exit;
end;
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 := HTTP_BADREQUEST;
if (self=nil) or (Batch=nil) then // no opened BATCH sequence
exit;
InternalLog('BatchSend %',[Batch]);
if Batch.PrepareForSending(Data) then
if Data='' then // i.e. Batch.Count=0
result := HTTP_SUCCESS else
try
result := EngineBatchSend(Batch.Table,Data,Results,Batch.Count);
except
on Exception do // e.g. from TSQLRestServer.EngineBatchSend()
result := HTTP_SERVERERROR;
end;
end;
function TSQLRest.BatchSend(Batch: TSQLRestBatch): integer;
var DummyRes: TIDDynArray;
begin
result := BatchSend(Batch,DummyRes);
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);
fAcquireExecution[execORMWrite].fSafe.Lock;
try // may be within a batch in another thread
result := EngineDelete(tableIndex,ID);
finally
fAcquireExecution[execORMWrite].fSafe.Unlock;
end;
end;
end;
function TSQLRest.InternalDeleteNotifyAndGetIDs(Table: TSQLRecordClass;
const SQLWhere: RawUTF8; var IDs: TIDDynArray): boolean;
var tableIndex, i: integer;
begin
tableIndex := Model.GetTableIndexExisting(Table);
result := false;
if OneFieldValues(Table,'RowID',SQLWhere,TInt64DynArray(IDs)) and
(IDs<>nil) then begin
for i := 0 to length(IDs)-1 do
if not RecordCanBeUpdated(Table,IDs[i],seDelete) then
exit;
fCache.NotifyDeletions(tableIndex,TInt64DynArray(IDs));
end;
result := true;
end;
function TSQLRest.Delete(Table: TSQLRecordClass; const SQLWhere: RawUTF8): boolean;
var IDs: TIDDynArray;
begin
if InternalDeleteNotifyAndGetIDs(Table,SQLWhere,IDs) then begin
fAcquireExecution[execORMWrite].fSafe.Lock;
try // may be within a batch in another thread
result := EngineDeleteWhere(Model.GetTableIndexExisting(Table),SQLWhere,IDs);
finally
fAcquireExecution[execORMWrite].fSafe.Unlock;
end;
end else
result := false;
end;
function TSQLRest.Delete(Table: TSQLRecordClass; const FormatSQLWhere: RawUTF8;
const BoundsSQLWhere: array of const): boolean;
var where: RawUTF8;
begin
where := FormatUTF8(FormatSQLWhere,[],BoundsSQLWhere);
result := Delete(Table,where);
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);
fAcquireExecution[execORMWrite].fSafe.Lock;
try // may be within a batch in another thread
result := EngineUpdate(TableIndex,Value.fID,JSONValues);
finally
fAcquireExecution[execORMWrite].fSafe.UnLock;
end;
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;
var tableIndex: integer;
begin
tableIndex := Model.GetTableIndexExisting(Table);
result := UpdateField(Table,'RowID',[ID],FieldName,FieldValue);
if result then
fCache.NotifyDeletion(tableIndex,ID);
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);
// warning: this may not update the internal cache
end;
{$ifndef NOVARIANTS}
function TSQLRest.UpdateField(Table: TSQLRecordClass; ID: TID;
const FieldName: RawUTF8; const FieldValue: Variant): boolean;
var tableIndex: integer;
begin
tableIndex := Model.GetTableIndexExisting(Table);
result := UpdateField(Table,'RowID',ID,FieldName,FieldValue);
if result then
fCache.NotifyDeletion(tableIndex,ID);
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);
// warning: this may not update the internal cache
end;
function TSQLRest.UpdateField(Table: TSQLRecordClass; const IDs: array of Int64;
const FieldName: RawUTF8; const FieldValue: variant): boolean;
var SetValue,Where: RawUTF8;
tableindex: integer;
begin
tableIndex := Model.GetTableIndexExisting(Table);
VariantToInlineValue(FieldValue,SetValue);
Where := SelectInClause('RowID',IDs,'',INLINED_MAX);
if length(IDs)<=INLINED_MAX then
result := ExecuteFmt('update % set %=:(%): where %', [Table.SQLTableName,
FieldName,SetValue,Where]) else // don't cache such a statement
result := ExecuteFmt('update % set %=% where %', [Table.SQLTableName,
FieldName,SetValue,Where]);
if result then
fCache.NotifyDeletions(tableIndex,IDs);
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;
props: TSQLRecordProperties;
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
if (Value.fID=0) or not ForceID then begin
Value.fID := Model.fIDGenerator[TableIndex].ComputeNew;
ForceID := true;
end;
end else
if Value.fID=0 then
ForceID := false;
props := Value.RecordProps;
if CustomFields <> nil then
if DoNotAutoComputeFields then
fields := CustomFields^*props.CopiableFieldsBits else
fields := CustomFields^*props.CopiableFieldsBits+props.ComputeBeforeAddFieldsBits else
if withBlobs then
fields := props.CopiableFieldsBits else
fields := props.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
fAcquireExecution[execORMWrite].fSafe.Lock;
try // may be within a batch in another thread
result := EngineAdd(TableIndex,json); // will call static if necessary
finally
fAcquireExecution[execORMWrite].fSafe.Unlock;
end;
// 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('*') will 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.AddSimple(aTable: TSQLRecordClass; const aSimpleFields: array of const;
ForcedID: TID): 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
fAcquireExecution[execORMWrite].fSafe.Lock;
try // may be within a batch in another thread
result := EngineAdd(TableIndex,json); // will call static if necessary
finally
fAcquireExecution[execORMWrite].fSafe.Unlock;
end;
// 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;
if BlobStream.Write(pointer(BlobData)^,length(BlobData))<>length(BlobData) then
result := false;
BlobStream.Seek(0,soBeginning); // 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,soEnd);
SetLength(Blob,L);
BlobData.Seek(0,soBeginning);
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 length(BlobFields)-1 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 length(BlobFields)-1 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; ForceAJAX: Boolean; ReturnedRowCount: PPtrInt): RawJSON;
begin
result := EngineList(SQL,ForceAjax,ReturnedRowCount);
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): 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',
SelectInClause(Fields.List[aMainField].Name,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 := GetTickCount64 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 will be done e.g. in TSQLRestServer.EndCurrentThread
{$ifdef WITHLOG}
fLogFamily.OnThreadEnded(Sender);
{$endif WITHLOG}
end;
procedure TSQLRest.WriteLock;
begin
fAcquireExecution[execORMWrite].Safe.Lock;
end;
procedure TSQLRest.WriteUnLock;
begin
fAcquireExecution[execORMWrite].Safe.UnLock;
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; var Data: RawUTF8;
var Results: TIDDynArray; ExpectedResultsCount: integer): integer;
begin
raise EORMException.CreateUTF8('BATCH not supported by %',[self]);
end;
{$ifdef ISDELPHI2010} // Delphi 2009/2010 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 ISDELPHI2010}
{ 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
Timestamp512 := 0;
JSON := '';
Tag := 0;
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
Timestamp512 := 0;
JSON := '';
Tag := 0;
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.Timestamp512 := 0; // indicates no value cache yet
Rec.Tag := 0;
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; aTag: cardinal);
var Rec: TSQLRestCacheEntryValue;
i: integer;
begin
Rec.ID := aID;
Rec.JSON := aJSON;
Rec.Timestamp512 := GetTickCount64 shr 9;
Rec.Tag := aTag;
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;
aTag: PCardinal): boolean;
var i: integer;
begin
result := false;
Mutex.Lock;
try
i := Value.Find(aID); // fast O(log(n)) binary search by first ID field
if i>=0 then
with Values[i] do
if Timestamp512<>0 then // 0 when there is no JSON value cached
if (TimeOutMS<>0) and ((GetTickCount64-TimeOutMS) shr 9>Timestamp512) then
FlushCacheEntry(i) else begin
if aTag<>nil then
aTag^ := Tag;
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;
aTag: PCardinal): boolean;
var JSON: RawUTF8;
begin
if RetrieveJSON(aID,JSON,aTag) then begin
aValue.FillFrom(JSON);
aValue.fID := aID; // override RowID field (may be not present after Update)
result := true;
end else
result := false;
end;
function TSQLRestCacheEntry.CachedMemory(FlushedEntriesCount: PInteger): cardinal;
var i: integer;
tix512: cardinal;
begin
result := 0;
if CacheEnable and (Count>0) then begin
tix512 := (GetTickCount64-TimeOutMS) shr 9;
Mutex.Lock;
try
for i := Count-1 downto 0 do
with Values[i] do
if Timestamp512<>0 then
if (TimeOutMS<>0) and (tix512>Timestamp512) then begin
FlushCacheEntry(i);
if FlushedEntriesCount<>nil then
inc(FlushedEntriesCount^);
end else
inc(result,length(JSON)+(SizeOf(TSQLRestCacheEntryValue)+16));
finally
Mutex.UnLock;
end;
end;
end;
{ TSQLRestCache }
constructor TSQLRestCache.Create(aRest: TSQLRest);
var i: PtrInt;
begin
if aRest=nil then
EBusinessLayerException.CreateUTF8('%.Create',[self]);
fRest := aRest;
SetLength(fCache,length(fRest.Model.Tables));
for i := 0 to length(fCache)-1 do
fCache[i].Init;
end;
destructor TSQLRestCache.Destroy;
var i: PtrInt;
begin
for i := 0 to length(fCache)-1 do
fCache[i].Done;
inherited;
end;
function TSQLRestCache.CachedEntries: cardinal;
var i,j: PtrInt;
begin
result := 0;
if self<>nil then
for i := 0 to length(fCache)-1 do
with fCache[i] do
if CacheEnable then begin
Mutex.Lock;
try
for j := 0 to Count-1 do
if Values[j].Timestamp512<>0 then
inc(result);
finally
Mutex.UnLock;
end;
end;
end;
function TSQLRestCache.CachedMemory(FlushedEntriesCount: PInteger): cardinal;
var i: PtrInt;
begin
result := 0;
if FlushedEntriesCount<>nil then
FlushedEntriesCount^ := 0;
if self<>nil then
for i := 0 to length(fCache)-1 do
inc(result,fCache[i].CachedMemory(FlushedEntriesCount));
end;
function TSQLRestCache.SetTimeOut(aTable: TSQLRecordClass; aTimeoutMS: Cardinal): boolean;
var i: PtrInt;
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: PtrInt;
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;
procedure TSQLRestCache.Clear;
var i: PtrInt;
begin
if self<>nil then
for i := 0 to length(fCache)-1 do
fCache[i].Clear;
end;
function TSQLRestCache.FillFromQuery(aTable: TSQLRecordClass; const FormatSQLWhere: RawUTF8;
const BoundsSQLWhere: array of const): integer;
var rec: TSQLRecord;
cache: ^TSQLRestCacheEntry;
begin
result := 0;
if self=nil then
exit;
cache := @fCache[fRest.Model.GetTableIndexExisting(aTable)];
if not cache^.CacheEnable then
exit;
rec := aTable.CreateAndFillPrepare(fRest,FormatSQLWhere,BoundsSQLWhere);
try
while rec.FillOne do begin
cache^.SetJSON(rec);
inc(result);
end;
finally
rec.Free;
end;
end;
procedure TSQLRestCache.Flush;
var i: PtrInt;
begin
if self<>nil then
for i := 0 to length(fCache)-1 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: PtrInt;
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: integer; 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.NotifyDeletions(aTableIndex: integer; const aIDs: array of Int64);
var i: PtrInt;
begin
if (self<>nil) and (high(aIDs)>=0) and
(Cardinal(aTableIndex)<Cardinal(Length(fCache))) then
with fCache[aTableIndex] 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.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: integer; 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;
if fThreadName='' then
FormatUTF8('% %',[self,fRest.Model.Root],fThreadName);
fEvent := TEvent.Create(nil,false,false,'');
inherited Create(aCreateSuspended);
end;
procedure TSQLRestThread.WaitForNotExecuting(maxMS: integer);
var endtix: Int64;
begin
if fExecuting then begin
endtix := SynCommons.GetTickCount64+maxMS;
repeat
SleepHiRes(1); // wait for InternalExecute to finish
until not fExecuting or (SynCommons.GetTickCount64>=endtix);
end;
end;
destructor TSQLRestThread.Destroy;
begin
if fExecuting then begin
Terminate; // will notify Execute that the process is finished
WaitForNotExecuting;
end;
inherited Destroy;
if fOwnRest and (fRest<>nil) then begin
{$ifdef WITHLOG}
if GetCurrentThreadId=ThreadID then begin
fRest.fLogFamily := nil; // no log after fRest.EndCurrentThread(self)
fRest.fLogClass := nil;
end;
{$endif}
FreeAndNil(fRest);
end;
fSafe.Done;
fEvent.Free;
end;
function TSQLRestThread.SleepOrTerminated(MS: integer): boolean;
var endtix: Int64;
begin
result := true; // notify Terminated
if (self = nil) or Terminated then
exit;
endtix := SynCommons.GetTickCount64+MS;
repeat
FixedWaitFor(fEvent,MS);
if Terminated then
exit;
until (MS<32) or (SynCommons.GetTickCount64>=endtix);
result := false; // normal delay expiration
end;
procedure TSQLRestThread.Execute;
begin
{$ifdef WITHLOG}
fLog := fRest.LogClass.Add;
{$endif}
SetCurrentThreadName('%',[fThreadName]);
fRest.BeginCurrentThread(self);
try
fExecuting := true;
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);
fLog := nil; // no log after EndCurrentThread
fExecuting := false;
end;
end;
{$ifndef HASTTHREADSTART}
procedure TSQLRestThread.Start;
begin
Resume;
end;
{$endif}
{$ifndef HASTTHREADTERMINATESET}
procedure TSQLRestThread.Terminate;
begin
inherited Terminate; // FTerminated := True
TerminatedSet;
end;
{$endif}
procedure TSQLRestThread.TerminatedSet;
begin
fEvent.SetEvent;
end;
{ 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
FindNameValue(InHead,HEADER_CONTENT_TYPE_UPPER,result);
if GuessJSONIfNoneSet and (result='') then
result := JSON_CONTENT_TYPE_VAR;
end;
function TSQLRestURIParams.InBodyTypeIsJson(GuessJSONIfNoneSet: boolean): boolean;
begin
result := IdemPChar(pointer(InBodyType(GuessJSONIfNoneSet)),JSON_CONTENT_TYPE_UPPER);
end;
function TSQLRestURIParams.OutBodyType(GuessJSONIfNoneSet: boolean): RawUTF8;
begin
FindNameValue(OutHead,HEADER_CONTENT_TYPE_UPPER,result);
if GuessJSONIfNoneSet and (result='') then
result := JSON_CONTENT_TYPE_VAR;
end;
function TSQLRestURIParams.OutBodyTypeIsJson(GuessJSONIfNoneSet: boolean): boolean;
begin
result := IdemPChar(pointer(OutBodyType(GuessJSONIfNoneSet)),JSON_CONTENT_TYPE_UPPER);
end;
function TSQLRestURIParams.Header(UpperName: PAnsiChar): RawUTF8;
begin
FindNameValue(InHead,UpperName,result);
end;
function TSQLRestURIParams.HeaderOnce(var Store: RawUTF8; UpperName: PAnsiChar): RawUTF8;
begin
if (Store='') and (@self<>nil) then begin
FindNameValue(InHead,UpperName,result);
if result='' then
Store := NULL_STR_VAR else // ensure header is parsed only once
Store := result;
end else
if pointer(Store)=pointer(NULL_STR_VAR) then
result := '' else
result := Store;
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 [HTTP_SUCCESS,HTTP_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 [HTTP_SUCCESS,HTTP_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=HTTP_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 [HTTP_SUCCESS,HTTP_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=HTTP_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 [HTTP_SUCCESS,HTTP_NOCONTENT];
end;
{$ifdef MSWINDOWS}
type
TSQLRestClientURIServiceNotification = class(TServiceMethodExecute)
protected
fOwner: TSQLRestClientURI;
fInstance: pointer; // weak IInvokable reference
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, imInstance);
const
SERVICE_PSEUDO_METHOD: array[TServiceInternalMethod] of RawUTF8 = (
'_free_','_contract_','_signature_','_instance_');
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;
temp: TTextWriterStackBuffer;
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 := HTTP_BADREQUEST;
url := Ctxt.Url;
if (url='') or (isDestroying in fInternalState) 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 := HTTP_SUCCESS;
exit;
end;
if not fFakeCallbacks.FindEntry(callback) then
exit;
if (Ctxt.InHead<>'') and
(callback.Factory.MethodIndexCurrentFrameCallback>=0) then begin
FindNameValue(Ctxt.InHead,'SEC-WEBSOCKET-FRAME: ',frames);
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(temp);
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 := HTTP_SUCCESS;
end;
Ctxt.OutBody := WR.Text;
end else
Ctxt.OutStatus := HTTP_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 := HTTP_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;
procedure InternalExecute; override;
public
constructor Create(aClient: TSQLRestClientURI); reintroduce;
destructor Destroy; override;
procedure AddRow(const aText: RawUTF8);
end;
constructor TRemoteLogThread.Create(aClient: TSQLRestClientURI);
begin
fClient := aClient;
inherited Create(aClient,false,false);
end;
destructor TRemoteLogThread.Destroy;
var i: integer;
begin
if fPendingRows<>'' then begin
fEvent.SetEvent;
for i := 1 to 200 do begin
SleepHiRes(10);
if fPendingRows='' then
break;
end;
end;
inherited Destroy;
end;
procedure TRemoteLogThread.AddRow(const aText: RawUTF8);
begin
fSafe.Lock;
try
AddToCSV(aText,fPendingRows,#13#10);
finally
fSafe.UnLock;
end;
fEvent.SetEvent;
end;
procedure TRemoteLogThread.InternalExecute;
var aText: RawUTF8;
begin
while not Terminated do
if FixedWaitFor(fEvent,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;
const FormatMsg: RawUTF8; 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=HTTP_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: RawUTF8; const 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<>HTTP_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<>HTTP_SUCCESS then
exit else
InternalState := Hi;
result := TSQLTableJSON.CreateFromTables(Tables,SQL,Resp); // get data
end;
result.fInternalState := InternalState;
end;
procedure TSQLRestClientURI.SessionRenewEvent(Sender: TSynBackgroundTimer;
Event: TWaitResult; const Msg: RawUTF8);
var resp: RawUTF8;
status: integer;
begin
status := CallBack(mPOST,'CacheFlush/_ping_','',resp);
InternalLog('SessionRenewEvent(%) received status=% count=% from % % (timeout=% min)',
[Model.Root,status,JSONDecode(resp,'count'),
SessionServer,SessionVersion,fSessionServerTimeout],sllUserAuth);
end;
procedure TSQLRestClientURI.SetSessionHeartbeatSeconds(timeout: integer);
begin
if (timeout<0) or (timeout=fSessionHeartbeatSeconds) then
exit;
fSessionHeartbeatSeconds := timeout;
TimerEnable(SessionRenewEvent,timeout);
end;
function TSQLRestClientURI.SessionCreate(aAuth: TSQLRestServerAuthenticationClass;
var aUser: TSQLAuthUser; const aSessionKey: RawUTF8): boolean;
var period: integer;
begin
result := false;
fSessionID := GetCardinal(pointer(aSessionKey));
if fSessionID=0 then
exit;
fSessionIDHexa8 := CardinalToHexLower(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
if fSessionServerTimeout>0 then begin // call _ping_ every half timeout period
period := fSessionServerTimeout*(60 div 2);
if period>25*60 then
period := 25*60; // default REST heartbeat at least every 25 minutes
SetSessionHeartbeatSeconds(period);
end;
result := true;
end;
procedure TSQLRestClientURI.SessionClose;
var tmp: RawUTF8;
begin
if (self<>nil) and (fSessionUser<>nil) and
(fSessionID<>CONST_AUTHENTICATION_SESSION_NOT_STARTED) then
try
TimerDisable(SessionRenewEvent);
InternalLog('SessionClose: notify server', sllTrace);
CallBackGet('Auth',['UserName',fSessionUser.LogonName,'Session',fSessionID],tmp);
finally
fSessionID := CONST_AUTHENTICATION_SESSION_NOT_STARTED;
fSessionIDHexa8 := '';
fSessionPrivateKey := 0;
fSessionAuthentication := nil;
fSessionServer := '';
fSessionVersion := '';
FillZero(fSessionData);
fSessionData := '';
fSessionServerTimeout := 0;
FreeAndNil(fSessionUser);
fComputeSignature := TSQLRestServerAuthenticationSignedURI.ComputeSignatureCrc32;
end;
end;
function TSQLRestClientURI.GetCurrentSessionUserID: TID;
begin
if fSessionUser=nil then
result := 0 else
result := fSessionUser.IDValue;
end;
function TSQLRestClientURI.GetSessionVersion: RawUTF8;
var resp: RawUTF8;
begin
if self = nil then
result := '' else begin
if fSessionVersion = '' then // no session (e.g. API public URI) -> ask
if CallBackGet('timestamp/info', [], resp) = HTTP_SUCCESS then
fSessionVersion := JSONDecode(resp, 'version');
result := fSessionVersion;
end;
end;
constructor TSQLRestClientURI.Create(aModel: TSQLModel);
begin
inherited Create(aModel);
fMaximumAuthentificationRetry := 1;
fComputeSignature := TSQLRestServerAuthenticationSignedURI.ComputeSignatureCrc32;
fSessionID := CONST_AUTHENTICATION_NOT_USED;
fFakeCallbacks := TSQLRestClientCallbacks.Create(self);
{$ifdef USELOCKERDEBUG}
fSafe := TAutoLockerDebug.Create(fLogClass,aModel.Root); // more verbose
{$else}
fSafe := TAutoLocker.Create;
{$endif USELOCKERDEBUG}
end;
destructor TSQLRestClientURI.Destroy;
var t,i: integer;
aID: TID;
Table: TSQLRecordClass;
begin
include(fInternalState,isDestroying);
{$ifdef MSWINDOWS}
fServiceNotificationMethodViaMessages.Wnd := 0; // disable notification
{$endif}
{$ifdef WITHLOG}
if GarbageCollectorFreeing then // may be owned by a TSynLogFamily
SetLogClass(nil);
{$endif}
fBatchCurrent.Free;
FreeAndNil(fFakeCallbacks);
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 DOMAINAUTH}
const
SSPI_DEFINITION_USERNAME = '***SSPI***';
{$endif DOMAINAUTH}
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 DOMAINAUTH}
if aDefinition.User=SSPI_DEFINITION_USERNAME then
SetUser('',aDefinition.PasswordPlain) else
{$endif DOMAINAUTH}
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 DOMAINAUTH}
if fSessionAuthentication.InheritsFrom(TSQLRestServerAuthenticationSSPI) then
Definition.User := SSPI_DEFINITION_USERNAME else
{$endif DOMAINAUTH}
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 [HTTP_SUCCESS,HTTP_NOCONTENT] else
result := URI(Model.URI[aTable],'BEGIN').Lo in [HTTP_SUCCESS,HTTP_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 := HTTP_UNAVAILABLE else begin
url := Model.getURICallBack(aMethodName,aTable,aID);
if high(aNameValueParameters)>0 then
url := url+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 (log<>nil) and (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 DOMAINAUTH} // try Windows/GSSAPI authentication with the current logged user
result := true;
if (IsVoid(aUserName) or (PosExChar({$ifdef GSSAPIAUTH}'@'{$else}'\'{$endif},aUserName)>0)) and
TSQLRestServerAuthenticationSSPI.ClientSetUser(self,aUserName,aPassword,passKerberosSPN) then
exit;
{$endif DOMAINAUTH}
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
StatusCodeToErrorMessage(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 ((Sender=nil) or OnIdleBackgroundThreadActive) and
not(isDestroying in fInternalState) then begin
if (Call^.OutStatus=HTTP_NOTIMPLEMENTED) and (isOpened in fInternalState) then begin
InternalClose; // force recreate connection
Exclude(fInternalState,isOpened);
if ((Sender=nil) or OnIdleBackgroundThreadActive) then
InternalURI(Call^); // try request again
end;
if Call^.OutStatus<>HTTP_NOTIMPLEMENTED then
Include(fInternalState,isOpened);
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: PRawUTF8;
Head: PRawUTF8; SendData: PRawUTF8): Int64Rec;
var retry: Integer;
aUserName, aPassword: string;
StatusMsg: RawUTF8;
Call: TSQLRestURIParams;
aPasswordHashed: Boolean;
procedure CallInternalURI;
begin
Call.Url := url; // reset to allow proper re-sign
if fSessionAuthentication<>nil then
fSessionAuthentication.ClientSessionSign(self,Call);
Call.Method := method;
if SendData<>nil then
Call.InBody := SendData^;
if Assigned(fOnEncryptBody) then
fOnEncryptBody(self,Call.InBody,Call.InHead,Call.Url);
{$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 := HTTP_UNAVAILABLE;
end else
{$endif}
OnBackgroundProcess({SenderThread=}nil,@Call);
if Assigned(fOnDecryptBody) then
fOnDecryptBody(self,Call.OutBody,Call.OutHead,Call.Url);
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;
end;
begin
if self=nil then begin
Int64(result) := HTTP_UNAVAILABLE;
SetLastException(nil,HTTP_UNAVAILABLE);
exit;
end;
fLastErrorMessage := '';
fLastErrorException := nil;
if fServerTimestampOffset=0 then begin
if not ServerTimestampSynchronize then begin
Int64(result) := HTTP_UNAVAILABLE;
exit; // if Timestamp is not available,server is down!
end;
end;
Call.Init;
if (Head<>nil) and (Head^<>'') then
Call.InHead := Head^;
if fSessionHttpHeader<>'' then
Call.InHead := Trim(Call.InHead + #13#10 + fSessionHttpHeader);
try
CallInternalURI;
if (Call.OutStatus=HTTP_TIMEOUT) and RetryOnceOnTimeout then begin
InternalLog('% % returned "408 Request Timeout" -> RETRY',[method,url],sllError);
CallInternalURI;
end else
if (Call.OutStatus=HTTP_FORBIDDEN) and (MaximumAuthentificationRetry>0) and
Assigned(OnAuthentificationFailed) and not(isInAuth in fInternalState) then
try
Include(fInternalState,isInAuth);
retry := 1;
while retry<=MaximumAuthentificationRetry do begin
// "403 Forbidden" in case of authentication failure -> try relog
if OnAuthentificationFailed(retry,aUserName,aPassword,aPasswordHashed) and
SetUser(StringToUTF8(aUserName),StringToUTF8(aPassword),aPasswordHashed) then begin
CallInternalURI;
break;
end;
Inc(retry);
end;
finally
Exclude(fInternalState,isInAuth);
end;
if not StatusCodeIsSuccess(Call.OutStatus) then begin
StatusCodeToErrorMessage(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;
except
on E: Exception do begin
Int64(result) := HTTP_NOTIMPLEMENTED; // 501
SetLastException(E,HTTP_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)=HTTP_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;
var u, m: RawUTF8;
{$ifdef WITHLOG}
log: ISynLog; // for Enter auto-leave to work with FPC
{$endif}
begin
if (self=nil) or (method=mNone) then
result := HTTP_UNAVAILABLE else begin
u := Model.getURICallBack(aMethodName,aTable,aID);
{$ifdef WITHLOG}
log := fLogClass.Enter('Callback %',[u],self);
{$endif}
m := TrimLeftLowerCaseShort(GetEnumName(TypeInfo(TSQLURIMethod),ord(method)));
result := URI(u,m,@aResponse,aResponseHead,@aSentData).Lo;
InternalLog('% result=% resplen=%',[m,result,length(aResponse)],sllServiceReturn);
end;
end;
procedure TSQLRestClientURI.CallbackNonBlockingSetHeader(out Header: RawUTF8);
begin // nothing to do by default (plain REST/HTTP works in blocking mode)
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; aIgnoreAnyException: boolean): 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
if aIgnoreAnyException then
SetLastException(E) else
raise;
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; aIgnoreAnyException: boolean): TServiceFactoryClient;
begin
result := TServiceFactoryClient(
ServiceRegister(TInterfaceFactory.GUID2TypeInfo(aInterface),
aInstanceCreation,aContractExpected,aIgnoreAnyException));
end;
function TSQLRestClientURI.ServiceDefineClientDriven(const aInterface: TGUID;
out Obj; const aContractExpected: RawUTF8): boolean;
begin
result := ServiceRegisterClientDriven(
TInterfaceFactory.GUID2TypeInfo(aInterface),Obj,aContractExpected);
end;
function TSQLRestClientURI.ServiceDefineSharedAPI(const aInterface: TGUID;
const aContractExpected: RawUTF8; aIgnoreAnyException: boolean): TServiceFactoryClient;
begin
try
result := ServiceDefine(aInterface,sicShared,aContractExpected,aIgnoreAnyException);
if result<>nil then begin
result.ParamsAsJSONObject := true; // no contract -> explicit parameters
result.ResultAsJSONObjectWithoutResult := true;
end;
except
if aIgnoreAnyException then
result := nil else
raise;
end;
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)=HTTP_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<>HTTP_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 P^=#0;
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 [HTTP_SUCCESS,HTTP_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 [HTTP_SUCCESS,HTTP_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<>HTTP_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=HTTP_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=HTTP_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 [HTTP_SUCCESS,HTTP_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 [HTTP_SUCCESS,HTTP_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 [HTTP_SUCCESS,HTTP_NOCONTENT];
end;
end;
function TSQLRestClientURI.EngineBatchSend(Table: TSQLRecordClass; var 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<>HTTP_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 := HTTP_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] := HTTP_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 := HTTP_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 := HTTP_BADREQUEST;
end;
{ TSQLRestServer }
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) := HTTP_NOTIMPLEMENTED; // 501
exit;
end;
call.Init;
call.Url := url;
call.Method := method;
call.LowLevelConnectionID := PtrInt(GlobalURIRequestServer);
call.LowLevelFlags := [llfSecured]; // in-process communication is safe
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 (PosExChar(':',Param)=0) and (PosExChar(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(10); // 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}
const
ServerPipeNamePrefix: TFileName = '\\.\pipe\mORMot_';
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)
sleep(10); // allow the background thread to start
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 := HTTP_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 := HTTP_SUCCESS; // Send something back
call.Init;
GetNextItem(P,#1,call.Url);
GetNextItem(P,#1,call.Method);
GetNextItem(P,#1,call.InHead);
call.LowLevelConnectionID := Msg.From;
Header := 'RemoteIP: 127.0.0.1';
AddToCSV(Header,call.InHead,#13#10);
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}
FastSetString(ResStr,@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 not(rsoNoTableURI in fOptions) and (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 i: integer;
methods: TPublishedMethodInfoDynArray;
begin
if aInstance=nil then
exit;
if PosExChar('/',aPrefix)>0 then
raise EServiceException.CreateUTF8('%.ServiceMethodRegisterPublishedMethods'+
'("%"): prefix should not contain "/"',[self,aPrefix]);
for i := 0 to GetPublishedMethods(aInstance,methods)-1 do
with methods[i] do
ServiceMethodRegister(aPrefix+Name,TSQLRestServerCallBack(Method));
end;
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 := TSynObjectListLocked.Create; // needed by AuthenticationRegister() below
fSQLAuthUserClass := TSQLAuthUser;
fSQLAuthGroupClass := TSQLAuthGroup;
fModel := aModel;
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 DOMAINAUTH},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;
TAESPRNG.Main.Fill(@fSessionCounter,SizeOf(fSessionCounter));
if integer(fSessionCounter)<0 then // ensure positive 31-bit integer
fSessionCounter := -fSessionCounter;
// retrieve published methods
fPublishedMethods.InitSpecific(TypeInfo(TSQLRestServerMethods),
fPublishedMethod,djRawUTF8,nil,true);
ServiceMethodRegisterPublishedMethods('',self);
fPublishedMethodAuthIndex := ServiceMethodByPassAuthentication('Auth');
fPublishedMethodTimestampIndex := ServiceMethodByPassAuthentication('Timestamp');
tmp := 'Batch';
fPublishedMethodBatchIndex := fPublishedMethods.FindHashed(tmp);
if (fPublishedMethodBatchIndex<0) or (fPublishedMethodTimestampIndex<0) then
raise EORMException.CreateUTF8('%.Create: missing method!',[self]);
fSafeRootUpper := UpperCase(fModel.Root)+'/_SAFE_/';
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;
Options: TSQLInitializeTableOptions);
begin
fCreateMissingTablesOptions := Options;
end;
procedure TSQLRestServer.InitializeTables(Options: TSQLInitializeTableOptions);
var t: PtrInt;
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: PtrInt;
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}
AsynchBatchStop(nil); // may use fStaticData[]
FreeAndNil(fBackgroundTimer); // do it ASAP
fRecordVersionSlaveCallbacks := nil; // should be done before fServices.Free
for i := 0 to high(fStaticVirtualTable) do
if fStaticVirtualTable[i]<>nil then begin
// free all virtual TSQLRestStorage objects
fStaticVirtualTable[i].Free;
if fStaticData<>nil then
fStaticData[i] := nil; // free once
end;
for i := 0 to high(fStaticData) do
// free all TSQLRestStorage objects and update file if necessary
fStaticData[i].Free;
for i := 0 to fPublishedMethods.Count-1 do
fPublishedMethod[i].Stats.Free;
FreeAndNil(fSessions);
FreeAndNil(fAssociatedServices);
ObjArrayClear(fSessionAuthentication);
inherited Destroy; // calls fServices.Free which will update fStats
FreeAndNil(fJWTForUnauthenticatedRequest);
FreeAndNil(fStats);
end;
procedure TSQLRestServer.Shutdown(const aStateFileName: TFileName);
var timeout: Int64;
{$ifdef WITHLOG}
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=%',
[aStateFileName,fModel.Root,fStats.AddCurrentRequestCount(0)],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;
timeout := GetTickCount64+30000; // never wait forever
repeat
SleepHiRes(5);
until (fStats.AddCurrentRequestCount(0)=0) or (GetTickCount64>timeout);
if aStateFileName<>'' then
SessionsSaveToFile(aStateFileName);
end;
function TSQLRestServer.SleepOrShutdown(MS: integer): boolean;
var timeout: Int64;
begin
result := true;
timeout := GetTickCount64+MS;
repeat
if fShutdownRequested then
exit;
if MS<=10 then
SleepHiRes(MS) else
SleepHiRes(1);
if fShutdownRequested then
exit;
until (MS<=10) or (GetTickCount64>=timeout);
result := false;
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.GetStaticTable(aClass: TSQLRecordClass): TSQLRest;
begin
if (aClass=nil) or ((fStaticData=nil) and (fStaticVirtualTable=nil)) then
result := nil else
result := GetStaticTableIndex(Model.GetTableIndexExisting(aClass));
end;
function TSQLRestServer.GetStaticTableIndex(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.GetStaticTableIndex(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;
status: integer;
{$ifdef WITHLOG}
log: ISynLog; // for Enter auto-leave to work with FPC
{$endif}
begin
{$ifdef WITHLOG}
log := fLogClass.Enter('RecordVersionSynchronizeSlave %',[Table],self);
{$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;
status := BatchSend(Writer,IDs);
if status=HTTP_SUCCESS then begin
InternalLog('RecordVersionSynchronize(%) Added=% Updated=% Deleted=% on %',
[Table,Writer.AddCount,Writer.UpdateCount,Writer.DeleteCount,Master],sllDebug);
if ChunkRowLimit=0 then begin
result := fRecordVersionMax;
break;
end;
end else begin
InternalLog('RecordVersionSynchronize(%) BatchSend=%',[Table,status],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
{$endif}
begin
{$ifdef WITHLOG}
log := fLogClass.Enter('RecordVersionSynchronizeSlaveToBatch %',[Table],self);
{$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;
{$ifdef WITHLOG}
log: ISynLog; // for Enter auto-leave to work with FPC
{$endif}
begin
{$ifdef WITHLOG}
log := fLogClass.Enter('RecordVersionSynchronizeSlaveStart % over %',
[Table, MasterRemoteAccess],self);
{$endif}
callback := nil; // weird fix for FPC/ARM
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',
[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',
[Table],sllError);
exit;
end;
until current=previous;
// subscribe for any further modification
if callback=nil then
callback := TServiceRecordVersionCallback.Create(self,MasterRemoteAccess,Table,OnNotify);
InternalLog('RecordVersionSynchronizeSlaveStart(%) current=% Subscribe(%)',
[Table,current,pointer(callback)],sllDebug);
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 %',
[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',[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',[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);
fAcquireExecution[execORMWrite].fSafe.Lock;
try // may be within a batch in another thread
result := EngineDeleteWhere(TableIndex,SQLWhere,IDs);
finally
fAcquireExecution[execORMWrite].fSafe.Unlock;
end;
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 := GetStaticTable(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 := GetStaticTable(Table);
if Rest<>nil then // faster direct call
result := Rest.TableHasRows(Table) else
result := inherited TableHasRows(Table);
end;
function TSQLRestServer.MemberExists(Table: TSQLRecordClass; ID: TID): boolean;
var Rest: TSQLRest;
begin
Rest := GetStaticTable(Table);
if Rest<>nil then // faster direct call
result := Rest.MemberExists(Table,ID) else
result := inherited MemberExists(Table,ID);
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 := GetStaticTable(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 := GetStaticTable(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 := GetStaticTableIndex(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 %.%',
[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: PtrInt;
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: PtrInt;
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 -> return existing instance
end;
// create and initialize new authentication instance
result := aMethod.Create(self);
ObjArrayAdd(fSessionAuthentication,result); // will be owned by this array
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: PtrInt;
begin
for i := 0 to high(aMethods) do
AuthenticationRegister(aMethods[i]);
end;
procedure TSQLRestServer.AuthenticationUnregister(aMethod: TSQLRestServerAuthenticationClass);
var i: PtrInt;
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: PtrInt;
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;
try
ObjArrayClear(fSessionAuthentication);
fHandleAuthentication := false;
finally
fSessions.Safe.UnLock;
end;
end;
function TSQLRestServer.ServiceMethodByPassAuthentication(const aMethodName: RawUTF8): integer;
var i: PtrInt;
begin
result := -1;
if self=nil then
exit;
if aMethodName='' then
for i := 0 to fPublishedMethods.Count-1 do
fPublishedMethod[i].ByPassAuthentication := true else begin
result := fPublishedMethods.FindHashed(aMethodName);
if result>=0 then
fPublishedMethod[result].ByPassAuthentication := true;
end;
end;
function TSQLRestServer.BanIP(const aIP: RawUTF8; aRemoveBan: boolean): boolean;
begin
result := false;
if fIPBan=nil then begin
if aRemoveBan then
exit;
fIPBan := TIPBan.Create;
fPrivateGarbageCollector.Add(fIPBan);
end;
if aRemoveBan then
result := fIPBan.Delete(aIP) else
result := fIPBan.Add(aIP);
InternalLog('BanIP(%,%)=%',[aIP,BOOL_STR[aRemoveBan],BOOL_STR[result]]);
end;
function TSQLRestServer.JWTForUnauthenticatedRequestWhiteIP(const aIP: RawUTF8;
aRemoveWhite: boolean): boolean;
begin
result := false;
if fJWTForUnauthenticatedRequest=nil then
exit;
if fIPWhiteJWT=nil then begin
if aRemoveWhite then
exit;
fIPWhiteJWT := TIPBan.Create;
fPrivateGarbageCollector.Add(fIPWhiteJWT);
end;
if aRemoveWhite then
result := fIPWhiteJWT.Delete(aIP) else
result := fIPWhiteJWT.Add(aIP);
InternalLog('WhiteIP(%,%)=%',[aIP,BOOL_STR[aRemoveWhite],BOOL_STR[result]]);
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); // Delphi 5-6 tweak to access private fields
{$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
inherited Create;
Server := aServer;
Call := @aCall;
Method := ToMethod(aCall.Method);;
fThreadServer := @ServiceContext;
fThreadServer^.Request := self;
end;
destructor TSQLRestServerURIContext.Destroy;
begin
if fThreadServer<>nil then
fThreadServer^.Request := nil;
inherited Destroy;
end;
procedure TSQLRestServerURIContext.InternalSetTableFromTableName(TableName: PUTF8Char);
begin
TableEngine := Server;
if rsoNoTableURI in Server.Options then
TableIndex := -1 else
InternalSetTableFromTableIndex(Server.Model.GetTableIndexPtr(TableName));
if TableIndex<0 then
exit;
Static := Server.GetStaticTableIndex(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 := PosExChar('?',Call^.url);
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);
URIAfterRoot := PUTF8Char(pointer(Call^.url))+i-1;
// compute Table, TableID and URIBlobFieldName
slash := PosExChar('/',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 := PosExChar('/',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 else if rsoMethodUnderscoreAsSlashURI in Server.Options then begin
URIUnderscoreAsSlash := URI;
i := slash; // set e.g. 'Method_Name' from 'ModelRoot/Method/Name' URI
repeat
URIUnderscoreAsSlash[i] := '_';
i := PosEx('/',URI,i+1);
until i=0;
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
begin
// check URI as 'ModelRoot/MethodName'
MethodIndex := Server.fPublishedMethods.FindHashed(URI);
if (MethodIndex<0) and (URIUnderscoreAsSlash<>'') then
MethodIndex := Server.fPublishedMethods.FindHashed(URIUnderscoreAsSlash);
end 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}
if (aSession.RemoteIP<>'') and (aSession.RemoteIP<>'127.0.0.1') then
Log.Log(sllUserAuth,'%/% %',[aSession.User.LogonName,aSession.ID,
aSession.RemoteIP],self);
{$endif}
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);
var txt: PShortString;
begin
txt := ToText(Reason);
{$ifdef WITHLOG}
Log.Log(sllUserAuth,'AuthenticationFailed(%) for % (session=%)',
[txt^,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 := HTTP_FORBIDDEN;
FormatUTF8('Authentication Failed: % (%)',
[UnCamelCase(TrimLeftLowerCaseShort(txt)),ord(Reason)],CustomErrorMsg);
// 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 := HTTP_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 5 second by default
exit;
end;
SleepHiRes(1); // retry every 1 ms
until Server.fShutdownRequested;
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 Server.fShutdownRequested;
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,HTTP_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
if MethodIndex >= 0 then
with Server.fPublishedMethod[MethodIndex] do begin
if mlMethods in Server.StatLevels then begin
{$ifdef LINUX}QueryPerformanceMicroSeconds{$else}QueryPerformanceCounter{$endif}(timeStart);
if Stats=nil then begin
Server.fStats.Lock; // use this global lock
try
if Stats=nil then
Stats := TSynMonitorInputOutput.Create(Name);
finally
Server.fStats.UnLock;
end;
end;
Stats.Processing := true;
end;
if Parameters<>'' then
Server.InternalLog('% %',[Name,Parameters],sllServiceCall);
CallBack(self);
if Stats<>nil then begin
{$ifdef LINUX}QueryPerformanceMicroSeconds{$else}QueryPerformanceCounter{$endif}(timeEnd);
dec(timeEnd,timeStart);
StatsFromContext(Stats,timeEnd,false);
if Server.StatUsage<>nil then
Server.StatUsage.Modified(Stats,[]);
if (mlSessions in Server.StatLevels) and (fSession<>nil) then begin
if fSession.fMethods=nil then begin
Server.fStats.Lock;
try
if fSession.fMethods=nil then
SetLength(fSession.fMethods,length(Server.fPublishedMethod));
finally
Server.fStats.UnLock;
end;
end;
sessionstat := fSession.fMethods[MethodIndex];
if sessionstat=nil then begin
Server.fStats.Lock;
try
sessionstat := fSession.fMethods[MethodIndex];
if sessionstat=nil then begin
sessionstat := TSynMonitorInputOutput.Create(Name);
fSession.fMethods[MethodIndex] := sessionstat;
end;
finally
Server.fStats.UnLock;
end;
end;
StatsFromContext(sessionstat,timeEnd,true);
// mlSessions stats are not yet tracked per Client
end;
end;
end;
with Server.fStats do begin
fSafe^.Lock; // try...finally not mandatory (slow
inc(fServiceMethod); // TSQLRestServerMonitor.Changed method is void
fSafe^.UnLock;
end;
end;
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;
temp: TTextWriterStackBuffer;
begin
WR := TJSONSerializer.CreateOwnedStream(temp);
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
fSafe^.Lock;
inc(fServiceInterface);
Changed;
fSafe^.UnLock;
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; // {"method":"_free_", "params":[], "id":1234}
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;
ord(imInstance):
// "method":"_instance_" from TServiceFactoryClient.CreateFakeInstance
if not (Service.InstanceCreation in [sicClientDriven]) then begin
Error('_instance_ is not compatible with %',[ToText(Service.InstanceCreation)^]);
exit;
end else
if ServiceInstanceID<>0 then begin
Error('_instance_ with ServiceInstanceID=%',[ServiceInstanceID]);
exit;
end;
else // TServiceFactoryServer.ExecuteMethod() will use ServiceMethod(Index)
if ServiceMethod=nil then
raise EServiceException.CreateUTF8('%.InternalExecuteSOAByInterface: '+
'ServiceMethodIndex=% and ServiceMethod=nil',[self,ServiceMethodIndex]);
end;
if (Session>CONST_AUTHENTICATION_NOT_USED) and (ServiceExecution<>nil) and
(SessionGroup-1 in ServiceExecution.Denied) then begin
Error('Unauthorized method',HTTP_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, ServiceMethod(Index) to be set
m := ServiceMethodIndex-SERVICE_PSEUDO_METHOD_COUNT;
if m>=0 then begin
if ServiceMethod=nil then
ServiceMethod := @Service.fInterface.fMethods[m];
ServiceExecution := @Service.fExecution[m];
ServiceExecutionOptions := ServiceExecution.Options;
with PServiceMethod(ServiceMethod)^ do begin // log from Ctxt.ServiceExecutionOptions
if [smdConst,smdVar]*HasSPIParams<>[] then
include(ServiceExecutionOptions,optNoLogInput);
if [smdVar,smdOut,smdResult]*HasSPIParams<>[] then
include(ServiceExecutionOptions,optNoLogOutput);
end;
{$ifdef WITHLOG} // load method call and parameter values (if worth it)
if (sllServiceCall in Log.GenericFamily.Level) and (ServiceParameters<>nil) and
(PWord(ServiceParameters)^<>ord('[')+ord(']') shl 8) then
if optNoLogInput in ServiceExecutionOptions then
Log.Log(sllServiceCall,'%{}',
[PServiceMethod(ServiceMethod)^.InterfaceDotMethodName],Server) else
Log.Log(sllServiceCall,'%%',[Service.InterfaceFactory.GetFullMethodName(
ServiceMethodIndex),ServiceParameters],Server);
{$endif}
if Assigned(Service.OnMethodExecute) then
if not Service.OnMethodExecute(self,PServiceMethod(ServiceMethod)^) then
exit; // execution aborted by OnMethodExecute() callback event
end;
if Service.ResultAsXMLObjectIfAcceptOnlyXML then begin
FindNameValue(Call^.InHead,'ACCEPT:',xml);
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
CompareMemFixed(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,{knownrows=}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 := HTTP_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 := HTTP_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 := HTTP_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 := HTTP_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 := HTTP_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 := HTTP_SUCCESS; // 200 OK
end else
Call.OutStatus := HTTP_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 := HTTP_SUCCESS;
end else // 200 OK
Call.OutStatus := HTTP_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 := Select<>PAGINGPARAMETERS_YAHOO.Select;
NonStandardSQLWhereParameter := Where<>PAGINGPARAMETERS_YAHOO.Where;
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
(StrPosI('ORDER BY ',pointer(SQLWhere))=nil) 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 (StrPosI('LIMIT ',pointer(SQLWhere))=nil) 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 := HTTP_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 := HTTP_NOTFOUND;
end;
end;
if Call.OutStatus=HTTP_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 := HTTP_NOTALLOWED else
if (Table<>nil) and (TableID>0) and
Server.Model.UnLock(Table,TableID) then
Call.OutStatus := HTTP_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 := HTTP_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>=0) and (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 := HTTP_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 := HTTP_SUCCESS; // 200 OK
end else
Call.OutStatus := HTTP_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 := HTTP_CREATED; // 201 Created
FormatUTF8('Location: %/%',[URI,TableID],Call.OutHead);
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 := HTTP_SUCCESS; // 200 OK
end else
Call.OutStatus := HTTP_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 := HTTP_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 := HTTP_FORBIDDEN else begin
if TableEngine.EngineDelete(TableIndex,TableID) and
Server.AfterDeleteForceCoherency(TableIndex,TableID) then begin
Call.OutStatus := HTTP_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 := HTTP_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 := HTTP_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 := HTTP_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 := HTTP_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>=256 then // avoid DOS - see MAX_METHOD_ARGS for TInterfacedObjectFake
raise EParsingException.CreateUTF8(
'Security Policy: Accept up to 128 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;
v: RawUTF8;
begin
GetInputByName(ParamName,'Int',v);
result := GetInt64(pointer(v),err);
if err<>0 then
raise EParsingException.CreateUTF8('%.InputInt[%]: ''%'' is not an integer',
[self,ParamName,v]);
end;
function TSQLRestServerURIContext.GetInputDouble(const ParamName: RawUTF8): double;
var err: integer;
v: RawUTF8;
begin
GetInputByName(ParamName,'Double',v);
result := GetExtended(pointer(v),err);
if err<>0 then
raise EParsingException.CreateUTF8('%.InputDouble[%]: ''%'' is not a float',
[self,ParamName,v]);
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): PtrInt;
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;
procedure TSQLRestServerURIContext.GetInputByName(const ParamName,InputName: RawUTF8;
var result: RawUTF8);
var i: PtrInt;
begin
i := GetInputNameIndex(ParamName);
if i<0 then
raise EParsingException.CreateUTF8('%: missing Input%[%]',[self,InputName,ParamName]);
result := fInput[i*2+1];
end;
function TSQLRestServerURIContext.GetInputUTF8(const ParamName: RawUTF8): RawUTF8;
begin
GetInputByName(ParamName,'UTF8',result);
end;
function TSQLRestServerURIContext.GetInputUTF8OrVoid(const ParamName: RawUTF8): RawUTF8;
var i: PtrInt;
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: PtrInt;
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: PtrInt;
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: PtrInt;
begin
i := GetInputNameIndex(ParamName);
if i<0 then
raise EParsingException.CreateUTF8('%: missing InputString[%]',[self,ParamName]);
result := UTF8ToString(fInput[i*2+1]);
end;
function TSQLRestServerURIContext.GetInputStringOrVoid(const ParamName: RawUTF8): string;
var i: PtrInt;
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;
var v: RawUTF8;
begin
GetInputByName(ParamName,'',v);
GetVariantFromJSON(pointer(v),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 v: RawUTF8;
begin
result := InputUTF8OrError(ParamName,v,ErrorMessageForMissingParameter);
if result then
GetVariantFromJSON(pointer(v),false,Value);
end;
function TSQLRestServerURIContext.GetInputAsTDocVariant(const Options: TDocVariantOptions;
ServiceMethod: pointer): variant;
var ndx, a: PtrInt;
forcestring: boolean;
v: variant;
MultiPart: TMultiPartDynArray;
name: RawUTF8;
met: PServiceMethod absolute ServiceMethod;
res: TDocVariantData absolute result;
begin
VarClear(result);
FillInput;
if fInput<>nil then begin
res.Init(Options,dvObject);
for ndx := 0 to (length(fInput) shr 1)-1 do begin
name := fInput[ndx*2];
if met<>nil then begin
a := met.ArgIndex(pointer(name),length(name),{input=}true);
forcestring := (a>=0) and (vIsString in met.Args[a].ValueKindAsm);
end else
forcestring := false;
GetVariantFromJSON(pointer(fInput[ndx*2+1]),forcestring,v,@Options);
res.AddValue(name,v);
end;
end else
if InputAsMultiPart(MultiPart) then begin
res.Init(Options,dvObject);
for ndx := 0 to high(MultiPart) do
with MultiPart[ndx] do
if ContentType=TEXT_CONTENT_TYPE then begin
// append as regular "Name":"TextValue" field
RawUTF8ToVariant(Content,v);
res.AddValue(Name,v);
end else
// append binary file as an object, with Base64-encoded data
res.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
if fInHeaderLastName=HeaderName then
result := fInHeaderLastValue else begin
PWord(UpperCopy255(up,HeaderName))^ := ord(':');
FindNameValue(Call.InHead,up,result);
if result<>'' then begin
fInHeaderLastName := HeaderName;
fInHeaderLastValue := result;
end;
end;
end;
const
COOKIE_MAXCOUNT_DOSATTACK = 512;
procedure TSQLRestServerURIContext.RetrieveCookies;
var n: integer;
P: PUTF8Char;
cookie,cn,cv: RawUTF8;
begin
fInputCookiesRetrieved := true;
FindNameValue(Call.InHead,'COOKIE:',cookie);
P := pointer(cookie);
n := 0;
while P<>nil do begin
GetNextItemTrimed(P,'=',cn);
GetNextItemTrimed(P,';',cv);
if (cn='') and (cv='') then
break;
SetLength(fInputCookies,n+1);
fInputCookies[n].Name := cn;
fInputCookies[n].Value := cv;
inc(n);
if n>COOKIE_MAXCOUNT_DOSATTACK then
raise EParsingException.CreateUTF8('%.RetrieveCookies overflow: DOS?',[self]);
end;
end;
procedure TSQLRestServerURIContext.SetInCookie(CookieName, CookieValue: RawUTF8);
var i,n: integer;
begin
CookieName := trim(CookieName);
if (self=nil) or (CookieName='') then
exit;
if not fInputCookiesRetrieved then
RetrieveCookies;
n := length(fInputCookies);
for i := 0 to n-1 do
if fInputCookies[i].Name=CookieName then begin // cookies are case-sensitive
fInputCookies[i].Value := CookieValue; // in-place update
exit;
end;
SetLength(fInputCookies,n+1);
fInputCookies[n].Name := CookieName;
fInputCookies[n].Value := CookieValue;
end;
function TSQLRestServerURIContext.GetInCookie(CookieName: RawUTF8): RawUTF8;
var i: integer;
begin
result := '';
CookieName := trim(CookieName);
if (self=nil) or (CookieName='') then
exit;
if not fInputCookiesRetrieved then
RetrieveCookies;
for i := 0 to length(fInputCookies)-1 do
if fInputCookies[i].Name=CookieName then begin // cookies are case-sensitive
result := fInputCookies[i].Value;
exit;
end;
end;
procedure TSQLRestServerURIContext.SetOutSetCookie(aOutSetCookie: RawUTF8);
const
HTTPONLY: array[boolean] of RawUTF8 = ('; HttpOnly','');
begin
if self=nil then
exit;
aOutSetCookie := Trim(aOutSetCookie);
if not IsValidUTF8WithoutControlChars(aOutSetCookie) then
raise EBusinessLayerException.CreateUTF8('Unsafe %.SetOutSetCookie',[self]);
if PosExChar('=',aOutSetCookie)<2 then
raise EBusinessLayerException.CreateUTF8(
'"name=value" expected for %.SetOutSetCookie("%")',[self,aOutSetCookie]);
if StrPosI('; PATH=',pointer(aOutSetCookie))=nil then
FormatUTF8('%; Path=/%%',[aOutSetCookie,Server.Model.Root,
HTTPONLY[rsoCookieHttpOnlyFlagDisable in Server.fOptions]],fOutSetCookie) else
fOutSetCookie := aOutSetCookie;
end;
function TSQLRestServerURIContext.GetUserAgent: RawUTF8;
begin
result := Call^.HeaderOnce(fUserAgent,'USER-AGENT: ');
end;
function TSQLRestServerURIContext.GetRemoteIP: RawUTF8;
begin
result := Call^.HeaderOnce(fRemoteIP,HEADER_REMOTEIP_UPPER);
end;
function TSQLRestServerURIContext.GetRemoteIPNotLocal: RawUTF8;
begin
result := Call^.HeaderOnce(fRemoteIP,HEADER_REMOTEIP_UPPER);
if result='127.0.0.1' then
result := '';
end;
function TSQLRestServerURIContext.GetRemoteIPIsLocalHost: boolean;
begin
result := (GetRemoteIP='') or (fRemoteIP='127.0.0.1');
end;
function TSQLRestServerURIContext.AuthenticationBearerToken: RawUTF8;
begin
result := Call^.HeaderOnce(fAuthenticationBearerToken,HEADER_BEARER_UPPER);
if (result='') and not(rsoAuthenticationURIDisable in Server.Options) then begin
result := GetInputUTF8OrVoid('authenticationbearer');
if result<>'' then
fAuthenticationBearerToken := result;
end;
end;
function TSQLRestServerURIContext.AuthenticationCheck(jwt: TJWTAbstract): boolean;
begin
if jwt=nil then
JWTContent.result := jwtNoToken else
jwt.Verify(AuthenticationBearerToken,JWTContent);
result := JWTContent.result=jwtValid;
if not result then
Error('Invalid Bearer [%]',[ToText(JWTContent.result)^],HTTP_FORBIDDEN) else
if (Server.fIPWhiteJWT<>nil) and not Server.fIPWhiteJWT.Exists(RemoteIP) and
(fRemoteIP<>'') and (fRemoteIP<>'127.0.0.1') then begin
Error('Invalid IP [%]',[fRemoteIP],HTTP_FORBIDDEN);
result := false;
end;
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
// 'mORMot' set e.g. from XPOWEREDPROGRAM value in SynCrtSock
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;
CacheControlMaxAge: integer; ServerHash: RawUTF8);
var clientHash: 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 CacheControlMaxAge>0 then
Call.OutHead := Call.OutHead+#13#10'Cache-Control: max-age='+UInt32ToUtf8(CacheControlMaxAge);
if Handle304NotModified and (Status=HTTP_SUCCESS) and
(Length(Result)>64) then begin
FindNameValue(Call.InHead,'IF-NONE-MATCH: ',clientHash);
if ServerHash='' then
ServerHash := crc32cUTF8ToHex(Result);
ServerHash := '"'+ServerHash+'"';
if clientHash<>ServerHash then
Call.OutHead := Call.OutHead+#13#10'ETag: '+ServerHash else begin
Call.OutBody := ''; // save bandwidth for "304 Not Modified"
Call.OutStatus := HTTP_NOTMODIFIED;
end;
end;
end else
Error(Result,Status);
end;
procedure TSQLRestServerURIContext.Returns(Value: TObject; Status: integer;
Handle304NotModified: boolean; SQLRecordOptions: TJSONSerializerSQLRecordOptions;
const CustomHeader: RawUTF8);
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,CustomHeader,Handle304NotModified);
end;
procedure TSQLRestServerURIContext.ReturnsJson(const Value: Variant; Status: integer;
Handle304NotModified: boolean; Escape: TTextWriterKind; MakeHumanReadable: boolean;
const CustomHeader: RawUTF8);
var json: RawUTF8;
tmp: TSynTempBuffer;
begin
VariantSaveJSON(Value,Escape,json);
if MakeHumanReadable and (json<>'') and (json[1] in ['{','[']) then begin
tmp.Init(json);
try
JSONBufferReformat(tmp.buf,json);
finally
tmp.Done;
end;
end;
Returns(json,Status,CustomHeader,Handle304NotModified);
end;
procedure TSQLRestServerURIContext.ReturnBlob(const Blob: RawByteString;
Status: integer; Handle304NotModified: boolean; const FileName: TFileName;
CacheControlMaxAge: integer);
begin
if not ExistsIniName(pointer(Call.OutHead),HEADER_CONTENT_TYPE_UPPER) then
AddToCSV(GetMimeContentTypeHeader(Blob,FileName),Call.OutHead,#13#10);
Returns(Blob,Status,Call.OutHead,Handle304NotModified,false,CacheControlMaxAge);
end;
procedure TSQLRestServerURIContext.ReturnFile(const FileName: TFileName;
Handle304NotModified: boolean; const ContentType,AttachmentFileName,
Error404Redirect: RawUTF8; CacheControlMaxAge: integer);
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('',HTTP_NOTFOUND,CacheControlMaxAge) else begin
if not ExistsIniName(pointer(Call.OutHead),HEADER_CONTENT_TYPE_UPPER) then 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);
end;
if CacheControlMaxAge>0 then
Call.OutHead := Call.OutHead+#13#10'Cache-Control: max-age='+UInt32ToUtf8(CacheControlMaxAge);
Call.OutStatus := HTTP_SUCCESS;
if Handle304NotModified then begin
FindNameValue(Call.InHead,'IF-NONE-MATCH:',clientHash);
serverHash := '"'+DateTimeToIso8601(FileTime,false,'T',true)+'"';
Call.OutHead := Call.OutHead+#13#10'ETag: '+serverHash;
if clientHash=serverHash then begin
Call.OutStatus := HTTP_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; CacheControlMaxAge: integer);
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,CacheControlMaxAge);
end;
procedure TSQLRestServerURIContext.Redirect(const NewLocation: RawUTF8;
PermanentChange: boolean);
begin
if PermanentChange then
Call.OutStatus := HTTP_MOVEDPERMANENTLY else
Call.OutStatus := HTTP_TEMPORARYREDIRECT;
Call.OutHead := 'Location: '+NewLocation;
end;
procedure TSQLRestServerURIContext.Returns(const NameValuePairs: array of const;
Status: integer; Handle304NotModified,HandleErrorAsRegularResult: boolean;
const CustomHeader: RawUTF8);
begin
Returns(JSONEncode(NameValuePairs),Status,CustomHeader,Handle304NotModified,
HandleErrorAsRegularResult);
end;
procedure TSQLRestServerURIContext.Results(const Values: array of const;
Status: integer; Handle304NotModified: boolean; CacheControlMaxAge: integer);
var i,h: integer;
result: RawUTF8;
temp: TTextWriterStackBuffer;
begin
h := high(Values);
if h<0 then
result := '{"result":null}' else
with TJSONSerializer.CreateOwnedStream(temp) 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,false,CacheControlMaxAge);
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, CacheControlMaxAge: integer);
var msg: RawUTF8;
begin
FormatUTF8(Format,Args,msg);
Error(msg,Status,CacheControlMaxAge);
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, CacheControlMaxAge: integer);
var ErrorMsg: RawUTF8;
temp: TTextWriterStackBuffer;
begin
Call.OutStatus := Status;
if StatusCodeIsSuccess(Status) then begin // not an error
Call.OutBody := ErrorMessage;
if CacheControlMaxAge<>0 then // Cache-Control is ignored for errors
Call.OutHead := 'Cache-Control: max-age='+UInt32ToUtf8(CacheControlMaxAge);
exit;
end;
if ErrorMessage='' then
StatusCodeToErrorMessage(Status,ErrorMsg) else
ErrorMsg := ErrorMessage;
with TTextWriter.CreateOwnedStream(temp) 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.fInterfaceMethods.FindHashed(URI);
if i>=0 then // no specific message: it may be a valid request
with Server.Services.fInterfaceMethod[i] do begin
Service := TServiceFactoryServer(InterfaceService);
ServiceMethodIndex := InterfaceMethodIndex;
fServiceListInterfaceMethodIndex := i;
i := ServiceMethodIndex-SERVICE_PSEUDO_METHOD_COUNT;
if i>=0 then
ServiceMethod := @Service.fInterface.fMethods[i];
ServiceInstanceID := GetInteger(pointer(URIBlobFieldName));
end else
if URIBlobFieldName<>'' then begin
// check URI as '/Model/Interface/Method[/ClientDrivenID]''
i := Server.Services.fInterfaces.FindHashed(URI);
if i>=0 then begin // identified as a valid JSON-RPC service
Service := TServiceFactoryServer(Server.Services.fInterface[i].Service);
Split(URIBlobFieldName,'/',method,clientdrivenid);
ServiceMethodIndex := Service.InterfaceFactory.FindMethodIndex(method);
if ServiceMethodIndex<0 then
Service := nil else begin
ServiceMethod := @Service.fInterface.fMethods[ServiceMethodIndex];
inc(ServiceMethodIndex,SERVICE_PSEUDO_METHOD_COUNT);
fServiceListInterfaceMethodIndex := -1;
ServiceInstanceID := GetInteger(pointer(clientdrivenid));
end;
end;
end;
end;
end;
procedure TSQLRestRoutingREST.ExecuteSOAByInterface;
var JSON: RawUTF8;
procedure DecodeUriParametersIntoJSON(const input: TRawUTF8DynArray);
var a,i,iLow: Integer;
WR: TTextWriter;
argDone: boolean;
temp: TTextWriterStackBuffer;
begin
WR := TJSONSerializer.CreateOwnedStream(temp);
try // convert URI parameters into the expected ordered JSON array
WR.Add('[');
with PServiceMethod(ServiceMethod)^ 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(input) shr 1 do // search argument in URI
if IdemPropNameU(input[i*2],@ParamName^[1],ord(ParamName^[0])) then begin
AddValueJSON(WR,input[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;
var Par: PUTF8Char;
begin // here Ctxt.Service and ServiceMethod(Index) 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
// parameters sent as JSON array/object (the Delphi/AJAX way) or single blob
if (ServiceMethod<>nil) and PServiceMethod(ServiceMethod)^.ArgsInputIsOctetStream and
not Call.InBodyTypeIsJson then begin
JSON := BinToBase64(Call.InBody,'["','"]',false);
ServiceParameters := pointer(JSON); // as expected by InternalExecuteSOAByInterface
end else
ServiceParameters := pointer(Call.InBody) else begin
// no body -> try URI-encoded parameters (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
// 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) and (ServiceMethod<>nil) then
DecodeUriParametersIntoJSON(fInput);
end;
end;
ServiceParameters := pointer(JSON);
end;
// now Service, ServiceParameters, ServiceMethod(Index) are set
InternalExecuteSOAByInterface;
end;
class procedure TSQLRestRoutingREST.ClientSideInvoke(var uri: RawUTF8;
ctxt: TSQLRestServerURIContextClientInvoke;
const method, params, clientDrivenID: RawUTF8; out sent,head: RawUTF8);
begin
if clientDrivenID<>'' then
uri := uri+'.'+method+'/'+clientDrivenID else
uri := uri+'.'+method;
if (csiAsOctetStream in ctxt) and (length(params)>2) and (params[1]='"') then begin
sent := Base64ToBin(@params[2],length(params)-2);
if sent<>'' then begin
head := BINARY_CONTENT_TYPE_HEADER;
exit;
end;
end;
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.fInterfaces.FindHashed(URI);
if i>=0 then // identified as a valid JSON-RPC service
Service := TServiceFactoryServer(Server.Services.fInterface[i].Service);
end; // ServiceMethodIndex will be retrieved from "method": in body
end;
procedure TSQLRestRoutingJSON_RPC.ExecuteSOAByInterface;
var method: RawUTF8;
Values: array[0..2] of TValuePUTF8Char;
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].Value=nil then // Method name required
exit;
Values[0].ToUTF8(method);
ServiceParameters := Values[1].Value;
ServiceInstanceID := Values[2].ToCardinal; // 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, ServiceMethod(Index) are set
InternalExecuteSOAByInterface;
ServiceParameters := nil;
finally
tmp.Done; // release temp storage for Values[] = Service* fields
end;
end;
class procedure TSQLRestRoutingJSON_RPC.ClientSideInvoke(var uri: RawUTF8;
ctxt: TSQLRestServerURIContextClientInvoke;
const method, params, clientDrivenID: RawUTF8; out sent,head: 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;
var ti: PTypeInfoDynArray;
begin
ti := TInterfaceFactory.GUID2TypeInfo(aInterfaces);
result := ServiceRegister(aImplementationClass,ti,aInstanceCreation,aContractExpected);
end;
function TSQLRestServer.ServiceDefine(aSharedImplementation: TInterfacedObject;
const aInterfaces: array of TGUID; const aContractExpected: RawUTF8): TServiceFactoryServer;
var ti: PTypeInfoDynArray;
begin
ti := TInterfaceFactory.GUID2TypeInfo(aInterfaces);
result := ServiceRegister(aSharedImplementation,ti,aContractExpected);
end;
function TSQLRestServer.ServiceDefine(aClient: TSQLRest;
const aInterfaces: array of TGUID;
aInstanceCreation: TServiceInstanceImplementation;
const aContractExpected: RawUTF8): boolean;
var ti: PTypeInfoDynArray;
begin
ti := TInterfaceFactory.GUID2TypeInfo(aInterfaces);
result := ServiceRegister(aClient,ti,aInstanceCreation,aContractExpected);
end;
procedure TSQLRestServer.URI(var Call: TSQLRestURIParams);
const COMMANDTEXT: array[TSQLRestServerURIContextCommand] of string[9] =
('?','Method','Interface','Read','Write');
var Ctxt: TSQLRestServerURIContext;
timeStart,timeEnd: Int64;
elapsed, len: cardinal;
outcomingfile: boolean;
safeid: integer;
P: PUTF8Char;
{$ifdef WITHLOG}
log: ISynLog; // for Enter auto-leave to work with FPC
{$endif}
begin
{$ifdef WITHLOG}
log := fLogClass.Enter('URI % % in=%',[Call.Method,Call.Url,KB(Call.InBody)],self);
{$endif}
{$ifdef LINUX}QueryPerformanceMicroSeconds{$else}QueryPerformanceCounter{$endif}(timeStart);
fStats.AddCurrentRequestCount(1);
if Assigned(fOnDecryptBody) then
fOnDecryptBody(self,Call.InBody,Call.InHead,Call.Url);
Call.OutStatus := HTTP_BADREQUEST; // default error code is 400 BAD REQUEST
safeid := 0;
if (fSafeProtocol<>nil) and IdemPropNameU(Call.Method,'POST') then begin
P := pointer(Call.Url);
if P^='/' then
inc(P); // may be /modelroot/_safe_
if IdemPChar(P,pointer(fSafeRootUpper)) then begin // 'ROOT/_SAFE_/'
InternalSafeProtocol(Call,safeid);
if safeid=0 then
exit; // low-level error
end;
end;
Ctxt := ServicesRouting.Create(self,Call);
try
{$ifdef WITHLOG}
if log<>nil then
Ctxt.Log := log.Instance;
{$endif}
Ctxt.SafeProtocolID := safeID;
if fShutdownRequested then
Ctxt.Error('Server is shutting down',HTTP_UNAVAILABLE) else
if Ctxt.Method=mNone then
Ctxt.Error('Unknown Verb %',[Call.Method]) else
if (fIPBan<>nil) and fIPBan.Exists(Ctxt.RemoteIP) then
Ctxt.Error('Banned IP %',[Ctxt.fRemoteIP]) else
// 1. decode URI
if not Ctxt.URIDecodeREST then
Ctxt.Error('Invalid Root',HTTP_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 (rsoSecureConnectionRequired in fOptions) and
(Ctxt.MethodIndex<>fPublishedMethodTimestampIndex) and
not (llfSecured in Call.LowLevelFlags) then
Ctxt.AuthenticationFailed(afSecureConnectionRequired) else
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
if (Ctxt.Session<>CONST_AUTHENTICATION_NOT_USED) or
(fJWTForUnauthenticatedRequest=nil) or
(Ctxt.MethodIndex=fPublishedMethodTimestampIndex) or
((llfSecured in Call.LowLevelFlags) and
not (llfHttps in Call.LowLevelFlags)) or // HTTPS does not authenticate
Ctxt.AuthenticationCheck(fJWTForUnauthenticatedRequest) then
// 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
if E.ClassType=EInterfaceFactoryException then
Ctxt.Error(E,'',[],HTTP_NOTACCEPTABLE) else
Ctxt.Error(E,'',[],HTTP_SERVERERROR);
end;
end;
// 4. return 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=HTTP_SUCCESS) and
(rsoHttp200WithNoBodyReturns204 in fOptions) then
Call.OutStatus := HTTP_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 (rsoNoInternalState in fOptions) and (Ctxt.Method<>mSTATE) then
Call.OutInternalState := 0 // reduce headers verbosity
else 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 begin
Call.OutHead := Trim(Call.OutHead+#13#10'Set-Cookie: '+Ctxt.OutSetCookie);
if rsoCookieIncludeRootPath in fOptions then
Call.OutHead := Call.OutHead+'; Path=/'; // case-sensitive Path=/ModelRoot
end;
if not (rsoHttpHeaderCheckDisable in fOptions) and
IsInvalidHttpHeader(pointer(Call.OutHead), length(Call.OutHead)) then
Ctxt.Error('Unsafe HTTP header rejected [%]', [EscapeToShort(Call.OutHead)], HTTP_SERVERERROR);
finally
{$ifdef LINUX}QueryPerformanceMicroSeconds{$else}QueryPerformanceCounter{$endif}(timeEnd);
Ctxt.MicroSecondsElapsed := fStats.FromExternalQueryPerformanceCounters(timeEnd-timeStart);
{$ifdef WITHLOG}
InternalLog('% % % %/% %=% out=% in %',
[Ctxt.SessionUserName,Ctxt.RemoteIPNotLocal,Call.Method,Model.Root,Ctxt.URI,
COMMANDTEXT[Ctxt.Command],Call.OutStatus,KB(Call.OutBody),
MicroSecToString(Ctxt.MicroSecondsElapsed)],sllServer);
if (Call.OutBody<>'') and (sllServiceReturn in fLogFamily.Level) then
if not(optNoLogOutput in Ctxt.ServiceExecutionOptions) 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;
if Assigned(fOnEncryptBody) then
fOnEncryptBody(self,Call.OutBody,Call.OutHead,Call.Url);
Ctxt.Free;
end;
if safeid<>0 then
InternalSafeProtocol(Call,safeid); // encrypt Call.OutBody+OutHead
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.StatsAsJson(Flags: TSQLRestServerAddStats): RawUTF8;
var W: TTextWriter;
temp: TTextWriterStackBuffer;
begin // emulates root/stat?withall=1 method call
W := TJSONSerializer.CreateOwnedStream(temp);
try
AddStat(Flags,W);
W.SetText(result);
finally
W.Free;
end;
end;
function TSQLRestServer.StatsAsDocVariant(Flags: TSQLRestServerAddStats): variant;
begin
_Json(StatsAsJson(Flags),result,JSON_OPTIONS_FAST);
end;
{$ifndef NOVARIANTS}
procedure TSQLRestServer.InternalInfo(var info: TDocVariantData);
var cpu,mem,free: RawUTF8;
now: TTimeLogBits;
m: TSynMonitorMemory;
begin // called by root/Timestamp/info REST method
now.Value := ServerTimestamp;
cpu := TSystemUse.Current(false).HistoryText(0,15,@mem);
m := TSynMonitorMemory.Create({nospace=}true);
try
FormatUTF8('%/%',[m.PhysicalMemoryFree.Text,m.PhysicalMemoryTotal.Text],free);
info.AddNameValuesToObject(['nowutc',now.Text(true,' ') , 'timestamp',now.Value,
'exe',ExeVersion.ProgramName, 'version',ExeVersion.Version.DetailedOrVoid,
'host',ExeVersion.Host, 'cpu',cpu, {$ifdef MSWINDOWS}'mem',mem,{$endif}
'memused',KB(m.AllocatedUsed.Bytes), 'memfree',free,
'diskfree',GetDiskPartitionsText({nocache=}false,{withfree=}true,{nospace=}true),
'exception',GetLastExceptions(10)]);
finally
m.Free;
end;
Stats.Lock;
try
info.AddNameValuesToObject([
'started',Stats.StartDate, 'clients',Stats.ClientsCurrent,
'methods',Stats.ServiceMethod, 'interfaces',Stats.ServiceInterface,
'total',Stats.TaskCount, 'time',Stats.TotalTime.Text]);
finally
Stats.Unlock;
end;
if Assigned(OnInternalInfo) then
OnInternalInfo(self,info);
end;
{$endif}
procedure TSQLRestServer.InternalStat(Ctxt: TSQLRestServerURIContext; W: TTextWriter);
var flags: TSQLRestServerAddStats;
begin
if Ctxt.InputExists['withall'] then
flags := [low(TSQLRestServerAddStat)..high(TSQLRestServerAddStat)] else begin
flags := [];
if Ctxt.InputExists['withtables'] then
include(flags, withtables);
if Ctxt.InputExists['withmethods'] then
include(flags, withmethods);
if Ctxt.InputExists['withinterfaces'] then
include(flags, withinterfaces);
if Ctxt.InputExists['withsessions'] then
include(flags, withsessions);
end;
AddStat(flags,W);
end;
procedure TSQLRestServer.AddStat(Flags: TSQLRestServerAddStats; W: TTextWriter);
const READWRITE: array[boolean] of string[9] = ('{"read":','{"write":');
var s,i: integer;
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;
if (fBackgroundTimer<>nil) and (fBackgroundTimer.Stats<>nil) then begin
W.CancelLastComma;
W.AddShort(',"backgroundTimer":');
fBackgroundTimer.Stats.ComputeDetailsTo(W);
W.Add(',');
end;
if withtables in flags 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 withmethods in flags 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 withinterfaces in flags 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 (withsessions in flags) 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.fInterfaceMethod[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;
temp: TTextWriterStackBuffer;
begin
W := TJSONSerializer.CreateOwnedStream(temp);
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;
call.LowLevelFlags := [llfSecured]; // admin access considered as safe
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 := StatsAsJson;
3: result.Content := Services.AsJson;
4: result.Content := SessionsAsJson;
5,6: begin
PrepareCall;
GetNextItem(P,' ',call.Method); // 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);
{$ifndef NOVARIANTS}
procedure DoInfo;
var info: TDocVariantData;
begin
info.InitFast;
InternalInfo(info);
Ctxt.Returns(info.ToJSON('','',jsonHumanReadable));
end;
{$endif}
begin
{$ifndef NOVARIANTS}
if IdemPropNameU(Ctxt.URIBlobFieldName,'info') and
not (rsoTimestampInfoURIDisable in fOptions) then
DoInfo else
{$endif}
Ctxt.Returns(Int64ToUtf8(ServerTimestamp),HTTP_SUCCESS,TEXT_CONTENT_TYPE_HEADER);
end;
procedure TSQLRestServer.CacheFlush(Ctxt: TSQLRestServerURIContext);
var i,count: integer;
begin
case Ctxt.Method of
mGET: begin
if Ctxt.Table=nil then
fCache.Flush else
if Ctxt.TableID=0 then
fCache.Flush(Ctxt.Table) else
fCache.SetCache(Ctxt.Table,Ctxt.TableID);
Ctxt.Success;
end;
mPOST:
if Ctxt.URIBlobFieldName='_callback_' then
// as called from TSQLHttpClientWebsockets.FakeCallbackUnregister
(Services as TServiceContainerServer).FakeCallbackRelease(Ctxt) else
if Ctxt.URIBlobFieldName='_ping_' then begin
count := 0;
if Ctxt.Session>CONST_AUTHENTICATION_NOT_USED then
for i := 0 to Services.Count-1 do
inc(count,TServiceFactoryServer(Services.fInterface[i].Service).
RenewSession(Ctxt.Session));
InternalLog('Renew % authenticated session % from %: count=%',
[Model.Root,Ctxt.Session,Ctxt.RemoteIPNotLocal,count],sllUserAuth);
Ctxt.Returns(['count',count]);
end;
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],HTTP_SERVERERROR);
exit;
end;
end;
// send back operation status array
Ctxt.Call.OutStatus := HTTP_SUCCESS;
for i := 0 to length(Results)-1 do
if Results[i]<>HTTP_SUCCESS then begin
Ctxt.Call.OutBody := Int64DynArrayToCSV(pointer(Results),length(Results),'[',']');
exit;
end;
Ctxt.Call.OutBody := '["OK"]'; // to save bandwith if no adding
end;
var
ServerNonceHash: TSHA3; // faster than THMAC_SHA256 on small input
ServerNonceCache: array[boolean] of record
tix: cardinal;
res: RawUTF8;
end;
function CurrentServerNonce(Previous: boolean): RawUTF8;
var ticks: cardinal;
hash: TSHA3;
res: THash256;
begin
ticks := UnixTimeUTC div (60*5); // 5 minutes resolution
if Previous then
dec(ticks);
with ServerNonceCache[Previous] do
if ticks=tix then begin
result := res;
exit;
end;
if ServerNonceHash.Algorithm<>SHA3_256 then begin
ServerNonceHash.Init(SHA3_256);
TAESPRNG.Main.Fill(@res,SizeOf(res)); // ensure unpredictable nonce
ServerNonceHash.Update(@res,SizeOf(res));
end;
hash := ServerNonceHash; // thread-safe SHA-3 sponge reuse
hash.Update(@ticks,SizeOf(ticks));
hash.Final(res,true);
result := BinToHexLower(@res,SizeOf(res));
with ServerNonceCache[Previous] do begin
tix := ticks;
res := result;
end;
end;
procedure TSQLRestServer.SessionCreate(var User: TSQLAuthUser;
Ctxt: TSQLRestServerURIContext; out Session: TAuthSession);
var i: PtrInt;
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: PtrInt;
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.InternalSafeProtocol(var Call: TSQLRestURIParams;
var SafeID: integer);
var res: TProtocolResult;
P: PUTF8Char;
prot: IProtocol;
begin
if SafeID<>0 then begin
// todo: encrypt Call.OutBody+OutHeader
exit;
end;
P := pointer(Call.Url);
inc(P,length(fSafeRootUpper)); // IdemPChar() done by caller
if P^='/' then
inc(P);
if IdemPChar(P,'OPEN') then begin
if fSafeProtocolNext=nil then
fSafeProtocolNext := fSafeProtocol.Clone;
res := fSafeProtocolNext.ProcessHandshake(Call.InBody,Call.OutBody);
InternalLog('InternalSafeProtocol ProcessHandshake=%',[ToText(res)^]);
if not (res in [sprSuccess,sprUnsupported]) then
exit;
prot := fSafeProtocolNext;
fSafeProtocolNext := nil;
// todo: register the new connection and return new SafeID
exit;
end;
SafeID := GetCardinal(P);
if SafeID=0 then
exit;
// todo: store IProtocol instance in the associated session
// todo: decrypt Call.Url+Method+Inbody+InHeader or close connection
end;
procedure TSQLRestServer.SessionDelete(aSessionIndex: integer;
Ctxt: TSQLRestServerURIContext);
var sess: TAuthSession;
begin // caller made fSessions.Safe.Lock
if (self<>nil) and (cardinal(aSessionIndex)<cardinal(fSessions.Count)) then begin
sess := fSessions.List[aSessionIndex];
if Services<>nil then
(Services as TServiceContainerServer).OnCloseSession(sess.IDCardinal);
if Ctxt=nil then
InternalLog('Deleted session %:%/%',[sess.User.LogonName,sess.IDCardinal,
fSessions.Count],sllUserAuth) else
InternalLog('Deleted session %:%/% from %/%',[sess.User.LogonName,sess.IDCardinal,
fSessions.Count,sess.RemoteIP,Ctxt.Call^.LowLevelConnectionID],sllUserAuth);
if Assigned(OnSessionClosed) then
OnSessionClosed(self,sess,Ctxt);
fSessions.Delete(aSessionIndex);
fStats.ClientDisconnect;
end;
end;
function TSQLRestServer.SessionDeleteDeprecated: cardinal;
var i: PtrInt;
begin // caller made fSessions.Safe.Lock
result := GetTickCount64 shr 10;
if (self<>nil) and (fSessions<>nil) then begin
if result<>fSessionsDeprecatedTix then begin
fSessionsDeprecatedTix := result; // check sessions every second
for i := fSessions.Count-1 downto 0 do
if result>TAuthSession(fSessions.List[i]).TimeOutTix then
SessionDelete(i,nil);
end;
end;
end;
function TSQLRestServer.SessionAccess(Ctxt: TSQLRestServerURIContext): TAuthSession;
var i: integer;
tix, session: cardinal;
sessions: ^TAuthSession;
begin // caller made fSessions.Safe.Lock
if (self<>nil) and (fSessions<>nil) then begin
// check deprecated sessions every second
tix := SessionDeleteDeprecated;
// retrieve session from its ID
sessions := pointer(fSessions.List);
session := Ctxt.Session;
if session>CONST_AUTHENTICATION_NOT_USED then
for i := 1 to fSessions.Count do
if sessions^.IDCardinal=session then begin
result := sessions^;
result.fTimeOutTix := tix+result.TimeoutShr10;
Ctxt.fSession := result; // for TSQLRestServer internal use
// make local copy of TAuthSession information
Ctxt.SessionUser := result.User.fID;
Ctxt.SessionGroup := result.User.GroupRights.fID;
Ctxt.SessionUserName := result.User.LogonName;
if (result.RemoteIP<>'') and (Ctxt.fRemoteIP='') then
Ctxt.fRemoteIP := result.RemoteIP;
Ctxt.fSessionAccessRights := result.fAccessRights;
Ctxt.Call^.RestAccessRights := @Ctxt.fSessionAccessRights;
exit;
end else
inc(sessions);
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;
W: TJSONSerializer;
temp: TTextWriterStackBuffer;
begin
result := '';
if (self=nil) or (fSessions.Count=0) then
exit;
W := TJSONSerializer.CreateOwnedStream(temp);
try
fSessions.Safe.Lock;
try
W.Add('[');
for i := 0 to fSessions.Count-1 do begin
W.WriteObject(fSessions.List[i]);
W.Add(',');
end;
W.CancelLastComma;
W.Add(']');
W.SetText(RawUTF8(result));
finally
fSessions.Safe.UnLock;
end;
finally
W.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(fSessionCounter);
W.Write4(MAGIC_SESSION+1);
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,PEnd: 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(0,@PEnd);
fSessions.Clear;
for i := 1 to n do begin
fSessions.Add(fSessionClass.CreateFrom(P,PEnd,self));
fStats.ClientConnect;
end;
fSessionCounter := PCardinal(P)^;
inc(P,4);
if PCardinal(P)^<>MAGIC_SESSION+1 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;
id: TThreadID;
begin
tc := fStats.NotifyThreadCount(1);
id := GetCurrentThreadId;
if Sender=nil then
raise ECommunicationException.CreateUTF8('%.BeginCurrentThread(nil)',[self]);
InternalLog('BeginCurrentThread(%) root=% ThreadID=% ThreadCount=%',
[Sender.ClassType,Model.Root,pointer(id),tc]);
if Sender.ThreadID<>id then
raise ECommunicationException.CreateUTF8(
'%.BeginCurrentThread(Thread.ID=%) and CurrentThreadID=% should match',
[self,pointer(Sender.ThreadID),pointer(id)]);
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;
id: TThreadID;
Inst: TServiceFactoryServerInstance;
begin
tc := fStats.NotifyThreadCount(-1);
id := GetCurrentThreadId;
if Sender=nil then
raise ECommunicationException.CreateUTF8('%.EndCurrentThread(nil)',[self]);
InternalLog('EndCurrentThread(%) ThreadID=% ThreadCount=%',
[Sender.ClassType,pointer(id),tc]);
if Sender.ThreadID<>id then
raise ECommunicationException.CreateUTF8(
'%.EndCurrentThread(%.ID=%) should match CurrentThreadID=%',
[self,Sender,pointer(Sender.ThreadID),pointer(id)]);
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(id);
for i := 0 to Services.Count-1 do
with TServiceFactoryServer(Services.fInterface[i].Service) do
if InstanceCreation=sicPerThread then
InternalInstanceRetrieve(Inst,ord(imFree),0);
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;
class procedure TSQLRecordHistory.InitializeFields(const Fields: array of const;
var JSON: RawUTF8);
begin // you may use a TDocVariant to add some custom fields in your own class
JSON := JSONEncode(Fields);
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,PEnd: PAnsiChar;
begin
result := false;
if cardinal(Index)>=cardinal(HistoryCount) then
exit;
P := pointer(fHistoryUncompressed);
PEnd := P+length(fHistoryUncompressed);
inc(P,fHistoryUncompressedOffset[Index]);
if P>=PEnd then
exit;
Event := TSQLHistoryEvent(P^); inc(P);
P := pointer(FromVarUInt64Safe(pointer(P),pointer(PEnd),PQWord(@Timestamp)^));
if P=nil then
exit;
if (Rec<>nil) and (Rec.RecordClass=fHistoryTable) then begin
if Event=heDelete then
Rec.ClearProperties else
Rec.SetBinaryValuesSimpleFields(P,PEnd);
Rec.fID := ModifiedID;
if P=nil then
exit;
end;
result := true;
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
{$endif}
begin
{$ifdef WITHLOG}
log := fLogClass.Enter('TrackChangesFlush(%)',[aTableHistory],self);
{$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(Pointer(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(TableHistoryIndex: integer);
var TableHistoryClass: TSQLRecordHistoryClass;
JSON: RawUTF8;
Event: TSQLHistoryEvent;
begin
case aEvent of
seAdd: Event := heAdd;
seUpdate: Event := heUpdate;
seDelete: Event := heDelete;
else exit;
end;
TableHistoryClass := TSQLRecordHistoryClass(Model.Tables[TableHistoryIndex]);
TableHistoryClass.InitializeFields(['ModifiedRecord',aTableIndex+aID shl 6,
'Event',ord(Event),'SentDataJSON',aSentData,'Timestamp',ServerTimestamp],JSON);
fAcquireExecution[execORMWrite].Safe.Lock; // avoid race condition
try // low-level Add(TSQLRecordHistory) without cache
EngineAdd(TableHistoryIndex,JSON);
{ TODO: use a BATCH (in background thread) to speed up TSQLHistory storage? }
if fTrackChangesHistory[TableHistoryIndex].CurrentRow>
fTrackChangesHistory[TableHistoryIndex].MaxSentDataJsonRow then begin
// gather & compress TSQLRecordHistory.SentDataJson into History BLOB
TrackChangesFlush(TableHistoryClass);
fTrackChangesHistory[TableHistoryIndex].CurrentRow := 0;
end else
// fast append as JSON until reached MaxSentDataJsonRow
inc(fTrackChangesHistory[TableHistoryIndex].CurrentRow);
finally
fAcquireExecution[execORMWrite].Safe.UnLock;
end;
end;
var TableHistoryIndex: integer;
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
// track simple fields modification
if cardinal(aTableIndex)<fTrackChangesHistoryTableIndexCount then begin
TableHistoryIndex := fTrackChangesHistoryTableIndex[aTableIndex];
if TableHistoryIndex>=0 then
DoTrackChanges(TableHistoryIndex);
end;
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 := GetStaticTableIndex(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 := GetStaticTableIndex(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 := GetStaticTableIndex(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 := GetStaticTableIndex(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 := GetStaticTableIndex(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,fSQLRecordVersionDeleteTable,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 := GetStaticTableIndex(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 := GetStaticTableIndex(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 := GetStaticTableIndex(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 := GetStaticTableIndex(TableModelIndex);
if Rest=nil then
result := MainEngineUpdateFieldIncrement(TableModelIndex,ID,FieldName,Increment) else
result := Rest.EngineUpdateFieldIncrement(TableModelIndex,ID,FieldName,Increment);
end;
function TSQLRestServer.EngineBatchSend(Table: TSQLRecordClass;
var 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);
if RunTableTransactions[i]=self then
RunMainTransaction := false;
RunTableTransactions[i] := nil; // to acquire and begin a new transaction
end;
RowCountForCurrentTransaction := 0;
end;
function IsNotAllowed: boolean;
begin
result := (CurrentContext<>nil) and (CurrentContext.Command=execORMWrite) 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
{$endif}
begin
{$ifdef WITHLOG}
log := fLogClass.Enter('EngineBatchSend % inlen=%',[Table,length(Data)],self);
{$endif}
Sent := UniqueRawUTF8(Data); // parsed, therefore modified in-placed
if Sent=nil then
raise EORMBatchException.CreateUTF8('%.EngineBatchSend(%,"")',[self,Table]);
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;
CurrentContext := ServiceContext.Request;
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.GetTableIndexPtr(MethodTable+1);
if RunTableIndex<0 then
raise EORMBatchException.CreateUTF8('%.EngineBatchSend: Unknown %',
[self,MethodTable]);
RunTable := Model.Tables[RunTableIndex];
end;
RunStatic := GetStaticTableIndex(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 fShutdownRequested;
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,NextGrow(Count));
end;
// process CRUD method operation
OK := false;
Results[Count] := HTTP_NOTMODIFIED;
case URIMethod of
mDELETE: begin
if EngineDelete(RunTableIndex,ID) then begin
if fCache<>nil then
fCache.NotifyDeletion(RunTableIndex,ID);
if (RunningBatchRest<>nil) or
AfterDeleteForceCoherency(RunTableIndex,ID) then begin
Results[Count] := HTTP_SUCCESS; // 200 OK
OK := true;
end;
end;
end;
mPOST: begin
ID := EngineAdd(RunTableIndex,Value);
Results[Count] := ID;
if ID<>0 then begin
if fCache<>nil then
fCache.Notify(RunTableIndex,ID,Value,soInsert);
OK := true;
end;
end;
mPUT:
if EngineUpdate(RunTableIndex,ID,Value) then begin
Results[Count] := HTTP_SUCCESS; // 200 OK
OK := true;
if fCache<>nil then // JSON Value may be uncomplete -> delete from cache
if not (boPutNoCacheFlush in batchOptions) then
fCache.NotifyDeletion(RunTableIndex,ID);
end;
end;
if (boRollbackOnError in batchOptions) and not OK then
raise EORMBatchException.CreateUTF8('%.EngineBatchSend: Results[%]=% on % %',
[self,Count,Results[Count],Method,RunTable]);
inc(Count);
inc(counts[URIMethod]);
until EndOfObject=']';
if (AutomaticTransactionPerRow>0) and (RowCountForCurrentTransaction>0) then
// send pending rows within transaction
PerformAutomaticCommit;
finally
try
if RunningBatchRest<>nil then
RunningBatchRest.InternalBatchStop; // send pending rows, and release Safe.Lock
finally
fAcquireExecution[execORMWrite].fSafe.UnLock;
InternalLog('EngineBatchSend json=% add=% update=% delete=% %%',
[KB(Data),counts[mPOST],counts[mPUT],counts[mDELETE],MethodTable,Table]);
end;
end;
except
on E: 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);
UniqueRawUTF8ZeroToTilde(data,1 shl 16);
InternalLog('% -> PARTIAL rollback of latest auto-committed transaction data=%',
[E,data], 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 := HTTP_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(vk: TSQLRecordVirtualKind): PShortString;
begin
result := GetEnumName(TypeInfo(TSQLRecordVirtualKind),ord(vk));
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;
function ToText(a: TSQLRestServerAuthenticationSignedURIAlgo): PShortString;
begin
result := GetEnumName(TypeInfo(TSQLRestServerAuthenticationSignedURIAlgo),ord(a));
end;
function ToText(res: TNotifyAuthenticationFailedReason): PShortString;
begin
result := GetEnumName(TypeInfo(TNotifyAuthenticationFailedReason),ord(res));
end;
{ TSQLRestClientURIDll }
constructor TSQLRestClientURIDll.Create(aModel: TSQLModel; const DllName: TFileName);
var aRequest: TURIMapRequest;
{$ifdef FPC}
aDLL: TLibHandle;
{$else}
aDLL: THandle;
{$endif}
begin
{$ifdef KYLIX3}
aDLL := LoadLibrary(pointer(DllName));
{$else}
{$ifdef FPC}
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<>HTTP_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 := HTTP_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 := HTTP_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;
type
ACE_HEADER = record
AceType: BYTE;
AceFlags: BYTE;
AceSize: WORD;
end;
ACCESS_ALLOWED_ACE = record
Header: ACE_HEADER;
Mask: ACCESS_MASK;
SidStart: DWORD;
end;
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;
inherited Create(aServer,false,false);
end;
destructor TSQLRestServerNamedPipe.Destroy;
var i: integer;
begin
if fChildRunning>0 then begin
for i := 0 to length(fChild)-1 do // close any still opened pipe
if fChild[i]<>nil then
fChild[i].Terminate;
while fChildRunning>0 do
SleepHiRes(64); // wait for all TSQLRestServerNamedPipeResponse.Destroy
end;
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)
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;
procedure TSQLRestServerNamedPipe.AddChild(new: TSQLRestServerNamedPipeResponse);
var i: integer;
begin
InterlockedIncrement(fChildRunning);
i := ObjArrayFind(fChild,nil); // any free slot?
if i<0 then
ObjArrayAdd(fChild,new) else
fChild[i] := new;
end;
procedure TSQLRestServerNamedPipe.RemoveChild(new: TSQLRestServerNamedPipeResponse);
var i: integer;
begin
if self=nil then
exit;
new.fMasterThread := self;
i := ObjArrayFind(fChild,new);
if i>=0 then
fChild[i] := nil; // reuse slot
InterlockedDecrement(fChildRunning);
end;
{ TSQLRestServerNamedPipeResponse }
constructor TSQLRestServerNamedPipeResponse.Create(aServer: TSQLRestServer;
aMasterThread: TSQLRestServerNamedPipe; aPipe: cardinal);
begin
fServer := aServer;
fPipe := aPipe;
{$ifdef LVCL}
FOnTerminate := fServer.EndCurrentThread;
{$endif}
fMasterThread := aMasterThread;
fMasterThread.AddChild(self);
FreeOnTerminate := true;
inherited Create(fServer,false,false);
end;
destructor TSQLRestServerNamedPipeResponse.Destroy;
begin
fMasterThread.RemoveChild(self);
inherited;
end;
procedure TSQLRestServerNamedPipeResponse.InternalExecute;
var call: TSQLRestURIParams;
Sleeper, Code: integer;
Ticks64, ClientTimeOut64: Int64;
RemoteIPHeader: RawUTF8;
Available: cardinal;
begin
if (fPipe=0) or (fPipe=Cardinal(INVALID_HANDLE_VALUE)) or (fServer=nil) then
exit;
RemoteIPHeader := 'RemoteIP: 127.0.0.1';
call.Init;
call.LowLevelConnectionID := fPipe;
call.LowLevelFlags := [llfSecured]; // assume pipes communication is safe
Ticks64 := 0;
Sleeper := 0;
ClientTimeOut64 := GetTickCount64+30*60*1000; // disconnect after 30 min idle
try
while not Terminated and not fMasterThread.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);
AddToCSV(RemoteIPHeader,call.InHead,#13#10);
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;
Sleeper := 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 Sleeper<128 then
inc(Sleeper,8);
SleepHiRes(Sleeper); // doesn't slow down connection but decreases CSwitch
Ticks64 := 0;
if GetTickCount64>ClientTimeOut64 then begin
fServer.InternalLog('Disconnected % after 30 min of inactivity',[self]);
break;
end;
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, 'InternalCheckOpen');
{$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; // for Enter auto-leave to work with FPC
{$endif}
begin
{$ifdef WITHLOG}
log := fLogClass.Enter(self, 'InternalURI');
{$endif}
Call.OutStatus := HTTP_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 := HTTP_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 := HTTP_NOTFOUND;
{$endif}
except
on E: Exception do begin // error in ReadString()
InternalLog('% for PipeName=%',[E,fPipeName],sllLastError);
Call.OutStatus := HTTP_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
fSafe^.Lock;
try
inc(fSuccess);
if IsOutcomingFile then
inc(fOutcomingFiles);
Changed;
finally
fSafe^.UnLock;
end;
end;
procedure TSQLRestServerMonitor.NotifyORM(aMethod: TSQLURIMethod);
begin
fSafe^.Lock;
try
case aMethod of
mGET,mLOCK: inc(fRead);
mPOST: inc(fCreated);
mPUT: inc(fUpdated);
mDELETE: inc(fDeleted);
end;
Changed;
finally
fSafe^.UnLock;
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;
fSafe^.Lock;
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
fSafe^.UnLock;
end;
end;
function TSQLRestServerMonitor.NotifyThreadCount(delta: integer): integer;
begin
if self=nil then
result := 0 else begin
fSafe^.Lock;
try
inc(fCurrentThreadCount,delta);
result := fCurrentThreadCount;
if delta<>0 then
Changed;
finally
fSafe^.UnLock;
end;
end;
end;
{ TSQLMonitorUsage }
function TSQLMonitorUsage.UsageID(aProcessIDShift: integer): integer;
begin
result := fID shr aProcessIDShift;
end;
{ TSynMonitorUsageRest }
constructor TSynMonitorUsageRest.Create(aStorage: TSQLRest;
aProcessID: Int64; aStoredClass: TSQLMonitorUsageClass;
aProcessIDShift: integer);
var g: TSynMonitorUsageGranularity;
begin
if aStorage=nil then
raise ESynException.CreateUTF8('%.Create(nil)',[self]);
if aProcessIDShift<0 then
aProcessIDShift := 16 { see TSynUniqueIdentifierProcess } else
if aProcessIDShift>40 then
aProcessIDShift := 40;
fProcessIDShift := aProcessIDShift;
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; // will 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)) or (Gran>high(fStoredCache)) then begin
result := false;
exit;
end;
rec := fStoredCache[Gran];
recid := (Int64(ID) shl fProcessIDShift) 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)) or (Gran>high(fStoredCache)) then begin
result := false;
exit;
end;
rec := fStoredCache[Gran];
recid := (Int64(ID) shl fProcessIDShift) 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 fSaveBatch<>nil then
if update then
result := fSaveBatch.Update(rec)>=0 else
result := fSaveBatch.Add(rec,true,true)>=0 else
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 FindPropName(List[i].Names,aServiceName)>=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 FindPropName(List[i].Names,aServiceName)>=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 FindPropName(Names,aServiceName)>=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)=HTTP_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,'EngineAdd');
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,'EngineUpdate');
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,'UpdateOne');
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;
{ TSQLRestStorageInMemoryUnique }
constructor TSQLRestStorageInMemoryUnique.Create(aOwner: TSQLRestStorageInMemory;
aField: TSQLPropInfo);
begin
fOwner := aOwner;
fPropInfo := aField;
fCaseInsensitive := not(aBinaryCollation in aField.Attributes);
fHasher.Init(@fOwner.fValues,nil,EventHash,nil,nil,EventCompare,false);
end;
function TSQLRestStorageInMemoryUnique.EventCompare(const A,B): integer;
begin
result := fPropInfo.CompareValue(TSQLRecord(A),TSQLRecord(B),fCaseInsensitive);
end;
function TSQLRestStorageInMemoryUnique.EventHash(const Elem): cardinal;
begin
result := fPropInfo.GetHash(TSQLRecord(Elem),fCaseInsensitive);
end;
function TSQLRestStorageInMemoryUnique.Find(Rec: TSQLRecord): integer;
begin
if self=nil then // no Unique index for this field
result := -1 else begin
fLastFindHashCode := fPropInfo.GetHash(Rec,fCaseInsensitive);
result := fHasher.Find(@Rec,fLastFindHashCode);
end;
end;
function TSQLRestStorageInMemoryUnique.AddedAfterFind(Rec: TSQLRecord): boolean;
begin
fHasher.FindBeforeAdd(@Rec,result,fLastFindHashCode);
end;
{ TSQLRestStorageInMemory }
constructor TSQLRestStorageInMemory.Create(aClass: TSQLRecordClass; aServer: TSQLRestServer;
const aFileName: TFileName; aBinaryFile: boolean);
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;
fValues.Init(TypeInfo(TSQLRecordObjArray),fValue,TSQLRecordDynArrayHashOne,
TSQLRecordDynArrayCompare,nil,@fCount); // hashed and compared by ID
fValues.{$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$endif}IsObjArray := true;
fSearchRec := fStoredClass.Create;
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
with fStoredClassRecordProps.Fields do begin
SetLength(fUnique,Count);
for f := 0 to Count-1 do
if f in fIsUnique then
fUnique[f] := TSQLRestStorageInMemoryUnique.Create(self,List[f]);
end;
ReloadFromFile;
end;
destructor TSQLRestStorageInMemory.Destroy;
begin
UpdateFile;
ObjArrayClear(fUnique);
fValues.Clear; // to free all stored TSQLRecord instances
fSearchRec.Free;
inherited Destroy;
end;
function TSQLRestStorageInMemory.IDToIndex(ID: TID): PtrInt;
begin
if self<>nil then begin
fSearchRec.fID := ID;
result := fValues.FindHashed(fSearchRec);
end else
result := -1;
end;
function TSQLRestStorageInMemory.AddOne(Rec: TSQLRecord; ForceID: boolean;
const SentData: RawUTF8): TID;
var ndx, f: PtrInt;
added: boolean;
begin
result := -1; // error
if (self=nil) or (Rec=nil) then
exit;
// ensure no duplicated ID or unique field
for f := 0 to high(fUnique) do
if f in fIsUnique then begin
ndx := fUnique[f].Find(Rec);
if ndx>=0 then begin
InternalLog('AddOne: non unique %.% on % %',
[fStoredClass,fUnique[f].PropInfo.Name,fValue[ndx],Rec],sllDB);
exit;
end;
end;
if ForceID then begin
if Rec.fID<=0 then
raise EORMException.CreateUTF8('%.AddOne(%.ForceID=0)',[self,Rec]);
ndx := fValues.FindHashed(Rec);
if ndx>=0 then begin
InternalLog('AddOne: non unique %.ID on % %',[fStoredClass,fValue[ndx],Rec],sllDB);
exit;
end;
if Rec.fID>fMaxID then
fMaxID := Rec.fID else
fUnSortedID := true;
end else begin
inc(fMaxID); // increasing sequence
Rec.fID := fMaxID;
end;
// update internal hash tables and add to internal list
for f := 0 to high(fUnique) do
if f in fIsUnique then
if not fUnique[f].AddedAfterFind(Rec) then // paranoid
raise EORMException.CreateUTF8('%.AddOne on %.%',[self,Rec,fUnique[f].PropInfo.Name]);
ndx := fValues.FindHashedForAdding(Rec,added);
if added then
fValue[ndx] := Rec else
raise EORMException.CreateUTF8('%.AddOne % failed',[self,Rec]); // paranoid
result := Rec.fID; // success
fModified := true;
if Owner<>nil then
Owner.InternalUpdateEvent(seAdd,fStoredClassProps.TableIndex,result,SentData,nil);
end;
function TSQLRestStorageInMemory.UniqueFieldsUpdateOK(aRec: TSQLRecord; aUpdateIndex: integer): boolean;
var f,ndx: PtrInt;
begin
result := false;
for f := 0 to high(fUnique) do
if f in fIsUnique then begin
ndx := fUnique[f].Find(aRec);
if (ndx>=0) and (ndx<>aUpdateIndex) then begin
InternalLog('UniqueFieldsUpdateOK failed on % %',[fUnique[f].PropInfo.Name,aRec],sllDB);
exit;
end;
end;
result := true;
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,'EngineDelete');
try
result := DeleteOne(IDToIndex(ID));
finally
StorageUnLock;
end;
end;
end;
function FindMaxID(p: PSQLRecord; n: integer): TID;
var id: TID;
begin
result := 0;
if n>0 then
repeat
id := p^.fID;
if id>result then // branchless cmovg on 64-bit FPC
result := id;
inc(p);
dec(n);
until n=0;
end;
function FindMaxIDAndCheckSorted(p: PSQLRecord; n: integer; var unsorted: boolean): TID;
var id,prev: TID;
{$ifndef CPUX86} lastnotsorted: pointer; {$endif}
begin
prev := 0;
result := 0;
{$ifdef CPUX86} unsorted := false; {$else} lastnotsorted := nil; {$endif}
if n>0 then
repeat
id := p^.fID;
if id>result then // cmovg on 64-bit FPC
result := id;
if id<=prev then
{$ifdef CPUX86}
unsorted := true;
{$else}
lastnotsorted := p; // cmovle on 64-bit FPC
{$endif}
prev := id;
inc(p);
dec(n);
until n=0;
{$ifndef CPUX86} unsorted := lastnotsorted<>nil; {$endif}
end;
function TSQLRestStorageInMemory.DeleteOne(aIndex: integer): boolean;
var f: integer;
rec: TSQLRecord;
begin
if cardinal(aIndex)>=cardinal(fCount) then
result := false else begin
rec := fValue[aIndex];
if rec.fID=fMaxID then
fMaxID := 0; // recompute
if Owner<>nil then // notify BEFORE deletion
Owner.InternalUpdateEvent(seDelete,fStoredClassProps.TableIndex,rec.fID,'',nil);
for f := 0 to high(fUnique) do
if f in fIsUnique then
if fUnique[f].Hasher.FindBeforeDelete(@rec)<aIndex then
raise EORMException.CreateUTF8('%.DeleteOne(%) failed on %',
[self,aIndex,fUnique[f].PropInfo.Name]);
if fValues.FindHashedAndDelete(rec)<>aIndex then
raise EORMException.CreateUTF8('%.DeleteOne(%) failed',[self,aIndex]);
if fMaxID=0 then
fMaxID := FindMaxID(pointer(fValue),fCount);
fModified := true;
result := true;
end;
end;
function TSQLRestStorageInMemory.EngineDeleteWhere(TableModelIndex: Integer;
const SQLWhere: RawUTF8; const IDs: TIDDynArray): boolean;
var ndx: TIntegerDynArray;
n,i: PtrInt;
begin // RecordCanBeUpdated() has already been called
result := false;
n := length(IDs);
SetLength(ndx,n);
dec(n);
StorageLock(True,'EngineDeleteWhere');
try
for i := 0 to n do begin
if IDs[i]=fMaxID then
fMaxID := 0; // force recompute
ndx[i] := IDToIndex(IDs[i]);
if ndx[i]<0 then
exit;
end;
QuickSortInteger(pointer(ndx),0,n); // slightly faster in reverse order
for i := n downto 0 do
DeleteOne(ndx[i]);
if fMaxID=0 then
fMaxID := FindMaxID(pointer(fValue),fCount);
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;
function TSQLRestStorageInMemory.GetID(Index: integer): TID;
begin
if (self=nil) or (cardinal(Index)>=cardinal(fCount)) then
result := 0 else
result := fValue[Index].fID;
end;
function TSQLRestStorageInMemory.GetItem(Index: integer): TSQLRecord;
begin
if self<>nil then
if cardinal(Index)>=cardinal(fCount) then
raise EORMException.CreateUTF8('%.GetItem(%) out of range',[self,Index]) else
result := fValue[Index] else
result := nil;
end;
procedure TSQLRestStorageInMemory.GetJSONValuesEvent(aDest: pointer;
aRec: TSQLRecord; aIndex: integer);
var W: TJSONSerializer absolute aDest;
begin
aRec.GetJSONValues(W);
W.Add(',');
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);
GetNextItem(P,'=',Prop);
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: PtrInt; CaseInsensitive: boolean): PtrInt;
var i, currentRow, found: PtrInt;
v: Int64;
err: integer;
P: TSQLPropInfo;
nfo: PPropInfo;
offs: PtrUInt;
ot: TOrdType;
vp: PPtrUInt;
function FoundOneAndReachedLimit: boolean;
begin
result := false; // continue search
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,fValue[i],i);
inc(found);
if found>=FoundLimit then
result := true; // stop the loop
end;
begin
result := 0;
if fCount=0 then
exit;
if FoundLimit<=0 then
FoundLimit := maxInt;
if WhereField=SYNTABLESTATEMENTWHEREID then begin
if FoundOffset<=0 then begin // omit first FoundOffset rows
v := GetInt64(pointer(WhereValue),err);
if (err=0) and (v>0) then begin
i := IDToIndex(v); // use fast ID hash table
if i>=0 then begin
if Assigned(OnFind) then
OnFind(Dest,fValue[i],i);
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 fUnique[] hash array for O(1) search if available
if WhereField in fIsUnique then begin
if FoundOffset<=0 then begin // omit first FoundOffset rows
P.SetValueVar(fSearchRec,WhereValue,false); // private copy for comparison
i := fUnique[WhereField].Find(fSearchRec);
if i>=0 then begin
if Assigned(OnFind) then
OnFind(Dest,fValue[i],i);
inc(result);
end;
end;
exit;
end;
// full scan optimized search for a specified value
found := 0;
currentRow := 0;
if P.InheritsFrom(TSQLPropInfoRTTIInt32) and (TSQLPropInfoRTTIInt32(P).PropInfo^.
PropType^.Kind in [tkInteger,tkEnumeration,tkSet]) then begin // 8/16/32-bit
v := GetInt64(pointer(WhereValue),err); // 64-bit for cardinal
if err<>0 then
exit;
nfo := TSQLPropInfoRTTI(P).PropInfo;
offs := TSQLPropInfoRTTI(P).fGetterIsFieldPropOffset;
if offs<>0 then begin // plain field with no getter
ot := nfo^.PropType^.OrdType;
if ot in [otSLong,otULong] then begin // handle very common 32-bit Integer field
vp := pointer(fValue);
for i := 0 to fCount-1 do
if (PCardinal(vp^+offs)^=PCardinal(@v)^) and FoundOneAndReachedLimit then
break else
inc(vp);
end else // inlined GetOrdProp() for 8-bit or 16-bit values
for i := 0 to fCount-1 do
if (FromOrdType(ot,pointer(PtrUInt(fValue[i])+offs))=v) and FoundOneAndReachedLimit then
break;
end else // has getter -> use GetOrdProp()
for i := 0 to fCount-1 do
if (nfo^.GetOrdProp(fValue[i])=v) and FoundOneAndReachedLimit then
break;
end else
if P.InheritsFrom(TSQLPropInfoRTTIInt64) then begin // 64-bit integer
v := GetInt64(pointer(WhereValue),err);
if err<>0 then
exit;
nfo := TSQLPropInfoRTTI(P).PropInfo;
offs := TSQLPropInfoRTTI(P).fGetterIsFieldPropOffset;
if offs<>0 then begin // plain field with no getter
vp := pointer(fValue);
for i := 0 to fCount-1 do
if (PInt64(vp^+offs)^=v) and FoundOneAndReachedLimit then
break else
inc(vp);
end else // handle getter
for i := 0 to fCount-1 do
if (nfo^.GetInt64Prop(fValue[i])=v) and FoundOneAndReachedLimit then
break;
end else begin // generic search using fast CompareValue() overridden methods
P.SetValueVar(fSearchRec,WhereValue,false); // private copy for comparison
for i := 0 to fCount-1 do
if (P.CompareValue(fValue[i],fSearchRec,CaseInsensitive)=0) and
FoundOneAndReachedLimit then
break;
end;
result := found;
end;
function TSQLRestStorageInMemory.FindMax(WhereField: integer; out max: Int64): boolean;
var P: TSQLPropInfo;
nfo: PPropInfo;
i: PtrInt;
v: Int64;
begin
result := false;
max := low(Int64);
if fCount=0 then
exit;
if WhereField=SYNTABLESTATEMENTWHEREID then begin
max := fMaxID;
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 fCount-1 do begin
v := nfo.GetOrdProp(fValue[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 fCount-1 do begin
v := nfo.GetInt64Prop(fValue[i]);
if v>max then
max := v;
end;
result := true;
end;
end;
procedure TSQLRestStorageInMemory.ForEach(WillModifyContent: boolean;
OnEachProcess: TFindWhereEqualEvent; Dest: pointer);
var i: PtrInt;
begin
if (self=nil) or (fCount=0) or not Assigned(OnEachProcess) then
exit;
StorageLock(WillModifyContent,'ForEach');
try
for i := 0 to fCount-1 do
OnEachProcess(Dest,fValue[i],i);
finally
StorageUnLock;
end;
end;
function TSQLRestStorageInMemory.GetJSONValues(Stream: TStream;
Expand: boolean; Stmt: TSynTableStatement): PtrInt;
var ndx,KnownRowsCount: PtrInt;
{$ifndef NOVARIANTS}
j: PtrInt;
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 (fCount>Stmt.Limit) then
KnownRowsCount := Stmt.Limit else
KnownRowsCount := fCount else
KnownRowsCount := 0;
Stmt.SelectFieldBits(bits,withID);
W := fStoredClassRecordProps.CreateJSONWriter(Stream,Expand,withID,bits,
KnownRowsCount,{bufsize=}256 shl 10);
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
fValue[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
fValue[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 fCount-1 do
if TSQLPropInfoRTTIRawBlob(Prop).IsNull(fValue[ndx])=IsNull then begin
fValue[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;
procedure TSQLRestStorageInMemory.GetAllIDs(out ID: TIDDynArray);
var i: PtrInt;
begin
StorageLock(false,'GetAllIDs');
try
SetLength(ID,fCount);
for i := 0 to Count-1 do
ID[i] := fValue[i].fID;
finally
StorageUnlock;
end;
end;
function TSQLRestStorageInMemory.EngineList(const SQL: RawUTF8;
ForceAJAX: Boolean; ReturnedRowCount: PPtrInt): 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,'EngineList');
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; // unhandled Distinct() or other SQL functions
end;
finally
Stmt.Free;
end;
end;
finally
StorageUnLock;
end;
if ReturnedRowCount<>nil then
ReturnedRowCount^ := ResCount;
end;
procedure TSQLRestStorageInMemory.DropValues(andUpdateFile: boolean);
var f: PtrInt;
timer: TPrecisionTimer;
begin
StorageLock(true,'DropValues');
try
fUnSortedID := false;
fMaxID := 0;
if fCount>0 then begin
timer.Start;
for f := 0 to high(fUnique) do
if f in fIsUnique then
fUnique[f].Hasher.Clear;
fValues.Hasher.Clear;
fValues.Clear;
if andUpdateFile then begin
fModified := true;
UpdateFile;
end;
InternalLog('DropValues % in %',[fStoredClass,timer.Stop]);
end;
finally
StorageUnLock;
end;
end;
procedure TSQLRestStorageInMemory.LoadFromJSON(const aJSON: RawUTF8);
var tmp: TSynTempBuffer;
begin
tmp.Init(aJSON);
try
LoadFromJSON(tmp.buf,tmp.len);
finally
tmp.Done;
end;
end;
procedure TSQLRestStorageInMemory.ComputeStateAfterLoad(var loaded: TPrecisionTimer;
binary: boolean);
const _CALLER: array[boolean] of string[7] = ('JSON','Binary');
var f,c: PtrInt;
cf: RawUTF8;
timer: TPrecisionTimer;
begin // now fValue[] contains the just loaded data
loaded.Pause;
timer.Start;
fCount := length(fValue);
c := fValues.ReHash;
if c>0 then
cf := 'ID' else
for f := 0 to high(fUnique) do
if f in fIsUnique then begin
c := fUnique[f].Hasher.ReHash({forced=}true);
if c>0 then begin
cf := fUnique[f].PropInfo.Name;
break;
end;
end;
if c>0 then begin
DropValues({andupdatefile=}false);
raise EORMException.CreateUTF8('%.LoadFrom%: found % % in %.% field',
[self,_CALLER[binary],Plural('duplicate',c),fStoredClass,cf]);
end;
if binary then begin
fMaxID := FindMaxID(pointer(fValue),fCount);
fUnSortedID := false; // by SaveToBinary design
end else // JSON may have been tampered
fMaxID := FindMaxIDAndCheckSorted(pointer(fValue),fCount,fUnSortedID);
InternalLog('LoadFrom% % count=% load=% index=%',
[_CALLER[binary],fStoredClass,fCount,loaded.Stop,timer.Stop]);
end;
procedure TSQLRestStorageInMemory.LoadFromJSON(JSONBuffer: PUTF8Char; JSONBufferLen: integer);
var T: TSQLTableJSON;
timer: TPrecisionTimer;
begin
StorageLock(true,'LoadFromJSON');
try
timer.Start;
if fCount>0 then
DropValues({andupdatefile=}false);
fModified := false;
if JSONBuffer=nil then
exit;
T := TSQLTableJSON.CreateFromTables([fStoredClass],'',JSONBuffer,JSONBufferLen);
try
if T.fFieldIndexID<0 then // no ID field -> load is impossible
exit;
T.ToObjArray(fValue,fStoredClass);
finally
T.Free;
end;
ComputeStateAfterLoad(timer,{binary=}false);
finally
StorageUnLock;
end;
end;
procedure TSQLRestStorageInMemory.SaveToJSON(Stream: TStream; Expand: Boolean);
var i,j: PtrInt;
W: TJSONSerializer;
ndx: TIntegerDynArray;
begin
if self=nil then
exit;
StorageLock(false,'SaveToJSON');
try
if fUnSortedID then
fValues.CreateOrderedIndex(ndx,nil); // write in ascending ID order
W := fStoredClassRecordProps.CreateJSONWriter(
Stream,Expand,true,ALL_FIELDS,fCount,{bufsize=}1 shl 20);
try
if Expand then
W.Add('[');
for i := 0 to fCount-1 do begin
if Expand then
W.AddCR; // for better readability
if ndx=nil then
j := i else
j := ndx[i];
fValue[j].GetJSONValues(W);
W.Add(',');
end;
W.EndJSONObject(fCount,fCount);
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: PtrInt;
ID32: TIntegerDynArray;
P,PEnd: PAnsiChar;
rec: TSQLRecord;
id: TID;
s: RawUTF8;
prop: TSQLPropInfo;
timer: TPrecisionTimer;
begin
result := false;
if self=nil then
exit;
timer.Start;
MS := StreamUnSynLZ(Stream,TSQLRESTSTORAGEINMEMORY_MAGIC);
if MS=nil then
exit;
StorageLock(true,'LoadFromBinary');
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 fStoredClassRecordProps.CheckBinaryHeader(R) then
exit;
// create instances and read their IDs
if fCount>0 then
DropValues({andupdatefile=}false);
fModified := false;
n := R.ReadVarUInt32Array(ID32);
SetLength(fValue,abs(n)); // allocate all at once
if n<0 then begin // was wkFakeMarker -> TID were stored as VarUInt64 diffs
n := abs(n);
id := 0;
for i := 0 to n-1 do begin
rec := fStoredClass.Create; // avoid URW699 with Delphi6/Kylix
id := id+{$ifdef FPC_OR_UNICODE}TID{$endif}(R.ReadVarUInt64);
rec.fID := id;
fValue[i] := rec;
end;
end else
for i := 0 to n-1 do begin
rec := fStoredClass.Create;
rec.fID := ID32[i];
fValue[i] := rec;
end;
// read content, grouped by field (for better compression)
P := R.CurrentMemory(0,@PEnd);
for f := 0 to fStoredClassRecordProps.Fields.Count-1 do begin
prop := fStoredClassRecordProps.Fields.List[f];
for i := 0 to n-1 do begin
P := prop.SetBinary(fValue[i],P,PEnd);
if P=nil then begin
DropValues(false); // on error, reset all values
exit;
end;
end;
end;
ComputeStateAfterLoad(timer,{binary=}true);
Result := true;
finally
StorageUnlock;
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;
Instance: THandle);
var S: TStream;
begin
if ResourceName = '' then
ResourceName := fStoredClass.ClassName;
if Instance=0 then
Instance := HInstance;
S := TResourceStream.Create(Instance,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;
i,j,f: PtrInt;
hasInt64ID: boolean;
p: PID;
lastID,newID: TID;
ndx,id32: TIntegerDynArray;
begin
result := 0;
if (self=nil) or (Stream=nil) then
exit;
MS := THeapMemoryStream.Create;
W := TFileBufferWriter.Create(MS,1 shl 20);
try
StorageLock(false,'SaveToBinary');
try
// primitive magic and fields signature for file type identification
W.Write1(0); // ClassName='TSQLRecordProperties' in old buggy format
fStoredClassRecordProps.SaveBinaryHeader(W);
// write IDs - in increasing order
if fUnSortedID then
fValues.CreateOrderedIndex(ndx,nil);
SetLength(id32,fCount);
hasInt64ID := false;
for i := 0 to fCount-1 do begin
if ndx=nil then
j := i else
j := ndx[i];
p := @fValue[j].fID;
if p^>high(cardinal) then begin
hasInt64ID := true;
break;
end else
id32[i] := PInteger(p)^;
end;
if hasInt64ID then begin
W.WriteVarUInt32(fCount);
W.Write1(ord(wkFakeMarker)); // fake marker
lastID := 0;
for i := 0 to fCount-1 do begin // a bit less efficient than wkSorted
if ndx=nil then
j := i else
j := ndx[i];
newID := fValue[j].fID;
if newID<=lastID then
raise EORMException.CreateUTF8('%.SaveToBinary(%): duplicated ID',
[self,fStoredClass]);
W.WriteVarUInt64(newID-lastID);
lastID := newID;
end;
end else
W.WriteVarUInt32Values(pointer(id32),fCount,wkSorted); // very efficient
// write content, grouped by field (for better compression)
for f := 0 to fStoredClassRecordProps.Fields.Count-1 do
with fStoredClassRecordProps.Fields.List[f] do
if ndx=nil then
for i := 0 to fCount-1 do
GetBinary(fValue[i],W) else
for i := 0 to fCount-1 do
GetBinary(fValue[ndx[i]],W);
finally
StorageUnLock;
end;
W.Flush;
result := StreamSynLZ(MS,Stream,TSQLRESTSTORAGEINMEMORY_MAGIC);
finally
W.Free;
MS.Free;
end;
end;
function TSQLRestStorageInMemory.EngineRetrieve(TableModelIndex: integer; ID: TID): RawUTF8;
var i: integer;
begin // TableModelIndex is not useful here
StorageLock(false,'EngineRetrieve');
try
i := IDToIndex(ID);
if i<0 then
result := '' else
result := fValue[i].GetJSONValues(true,true,soSelect);
finally
StorageUnLock;
end;
end;
function TSQLRestStorageInMemory.GetOne(aID: TID): TSQLRecord;
var i: integer;
begin
if aID = 0 then
result := nil else begin
StorageLock(false,'GetOne');
try
i := IDToIndex(aID);
if i<0 then
result := nil else
result := fValue[i].CreateCopy;
finally
StorageUnLock;
end;
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;
if P.PropertyIndex in fIsUnique then begin
InternalLog('EngineUpdateFieldIncrement(%) on UNIQUE %.%',[ID,fStoredClass,P.Name],sllDB);
exit;
end;
StorageLock(false,'EngineUpdateFieldIncrement');
try
i := IDToIndex(ID);
if i<0 then begin
InternalLog('EngineUpdateFieldIncrement(%): %.ID=% not found',[P.Name,fStoredClass,ID],sllDB);
exit;
end;
P.GetValueVar(fValue[i],false,V,@wasstring);
int := GetInt64(pointer(V),err);
if wasString or (err<>0) then begin
InternalLog('EngineUpdateFieldIncrement: %.%=[%] not an integer',[fStoredClass,P.Name,V],sllDB);
exit;
end;
Int64ToUtf8(int+Increment,V);
P.SetValueVar(fValue[i],V,false);
fModified := true;
result := true;
finally
StorageUnLock;
end;
end;
function TSQLRestStorageInMemory.EngineUpdateField(TableModelIndex: integer;
const SetFieldName, SetValue, WhereFieldName, WhereValue: RawUTF8): boolean;
var P: TSQLPropInfo;
WhereValueString, SetValueString, SetValueJson: RawUTF8;
i, WhereFieldIndex: PtrInt;
SetValueWasString: boolean;
match: TSynList;
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
P := fStoredClassRecordProps.Fields.ByRawUTF8Name(SetFieldName);
if P=nil then
exit; // don't allow setting ID field, which is Read Only
if P.PropertyIndex in fIsUnique then begin
InternalLog('EngineUpdateField on UNIQUE %.%',[fStoredClass,P.Name],sllDB);
exit; { TODO : allow update UNIQUE field? }
end;
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
match := TSynList.Create;
StorageLock(true,'EngineUpdateField');
try
// find matching match[]
if FindWhereEqual(WhereFieldIndex,WhereValueString,DoAddToListEvent,match,0,0)=0 then
exit; // match.Count=0 -> nothing to update
// check that all records can be updated
for i := 0 to match.Count-1 do
if not RecordCanBeUpdated(fStoredClass,TSQLRecord(match.List[i]).fID,seUpdate) then
exit; // one record update fails -> abort all
// update field value
for i := 0 to match.Count-1 do begin
rec := match.List[i];
P.SetValueVar(rec,SetValueString,SetValueWasString);
if Owner<>nil then begin
if SetValueJson='' then
JSONEncodeNameSQLValue(P.Name,SetValue,SetValueJson);
Owner.InternalUpdateEvent(seUpdate,fStoredClassProps.TableIndex,rec.fID,SetValueJson,nil);
end;
end;
fModified := true;
result := true;
finally
StorageUnLock;
match.Free;
end;
end;
function TSQLRestStorageInMemory.EngineUpdate(TableModelIndex: integer; ID: TID;
const SentData: RawUTF8): boolean;
var i: PtrInt;
rec: TSQLRecord;
begin
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,'EngineUpdate');
try
i := IDToIndex(ID);
if (i<0) or not RecordCanBeUpdated(fStoredClass,ID,seUpdate) then
exit;
if fUnique<>nil then begin
rec := fValue[i].CreateCopy; // copy since can be a partial update
rec.FillFrom(SentData); // overwrite updated properties
if not UniqueFieldsUpdateOK(rec,i) then begin
rec.Free;
exit;
end;
fValue[i].Free; // avoid memory leak
fValue[i] := rec; // replace item in list
end else // direct in-place (partial) update
fValue[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: PtrInt;
begin
result := false;
if (Rec=nil) or (PSQLRecordClass(Rec)^<>fStoredClass) or (Rec.fID<=0) then
exit;
StorageLock(true,'UpdateOne');
try
i := IDToIndex(Rec.fID);
if (i<0) or not RecordCanBeUpdated(fStoredClass,Rec.fID,seUpdate) then
exit;
if (fUnique<>nil) and not UniqueFieldsUpdateOK(Rec,i) then
exit;
CopyObject(Rec,fValue[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: PtrInt;
rec: TSQLRecord;
begin
result := false;
if ID<=0 then
exit;
StorageLock(true,'UpdateOne');
try
i := IDToIndex(ID);
if (i<0) or not RecordCanBeUpdated(fStoredClass,ID,seUpdate) then
exit;
if fUnique<>nil then begin
rec := fValue[i].CreateCopy; // copy since can be a partial update
if not rec.SetFieldSQLVars(Values) or not UniqueFieldsUpdateOK(rec,i) then begin
rec.Free;
exit;
end;
fValue[i].Free; // avoid memory leak
fValue[i] := rec;
end else
if not fValue[i].SetFieldSQLVars(Values) then
exit;
fModified := true;
result := true;
if Owner<>nil then
Owner.InternalUpdateEvent(seUpdate,fStoredClassProps.TableIndex,ID,
fValue[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,'EngineRetrieveBlob');
try
i := IDToIndex(aID);
if i<0 then
exit;
// get result blob directly from RTTI property description
BlobField.GetLongStrProp(fValue[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,'RetrieveBlobFields');
try
i := IDToIndex(Value.fID);
if i<0 then
exit;
for f := 0 to high(BlobFields) do
BlobFields[f].CopyValue(fValue[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,'EngineUpdateBlob');
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[i],BlobData);
if Owner<>nil then begin
fStoredClassRecordProps.FieldBitsFromBlobField(BlobField,AffectedField);
Owner.InternalUpdateEvent(seUpdateBlob,fStoredClassProps.TableIndex,aID,'',@AffectedField);
end;
fModified := true;
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,'UpdateBlobFields');
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[i]);
if Owner<>nil then
Owner.InternalUpdateEvent(seUpdateBlob,fStoredClassProps.TableIndex,Value.fID,'',
@fStoredClassRecordProps.FieldBits[sftBlob]);
fModified := true;
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 := fCount;
end;
function TSQLRestStorageInMemory.TableHasRows(Table: TSQLRecordClass): boolean;
begin
result := (Table=fStoredClass) and (fCount>0);
end;
function TSQLRestStorageInMemory.MemberExists(Table: TSQLRecordClass; ID: TID): boolean;
begin
StorageLock(false,'UpdateFile');
try
result := (Table=fStoredClass) and (IDToIndex(ID)>=0);
finally
StorageUnLock;
end;
end;
procedure TSQLRestStorageInMemory.UpdateFile;
var F: TFileStream;
timer: TPrecisionTimer;
begin
if (self=nil) or not fModified or (FileName='') then
exit;
timer.Start;
StorageLock(false,'UpdateFile');
try
DeleteFile(FileName); // always erase previous file
if fCount>0 then begin
F := TFileStream.Create(FileName,fmCreate);
try
if BinaryFile then
SaveToBinary(F) else
SaveToJSON(F,true);
finally
F.Free;
end;
end;
fModified := false;
finally
StorageUnLock;
end;
InternalLog('UpdateFile % in %',[fStoredClass,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 := FileStreamSequentialRead(fFileName);
try
LoadFromBinary(Stream)
finally
Stream.Free;
end;
end else begin
JSON := AnyTextFileToRawUTF8(fFileName,true);
LoadFromJSON(pointer(JSON),length(JSON)); // buffer parsed in-place
end;
end;
end;
function TSQLRestStorageInMemory.SearchField(const FieldName, FieldValue: RawUTF8;
out ResultID: TIDDynArray): boolean;
var n, WhereField,i: integer;
match: TSynList;
begin
result := false;
if (self=nil) or (fCount=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;
match := TSynList.Create;
try
StorageLock(false,'SearchField');
try
n := FindWhereEqual(WhereField,FieldValue,DoAddToListEvent,match,0,0);
if n=0 then
exit;
result := true;
SetLength(ResultID,n);
for i := 0 to n-1 do
ResultID[i] := TSQLRecord(match.List[i]).fID;
finally
StorageUnLock;
end;
finally
match.Free;
end;
end;
function TSQLRestStorageInMemory.SearchEvent(const FieldName, FieldValue: RawUTF8;
OnFind: TFindWhereEqualEvent; Dest: pointer; FoundLimit,FoundOffset: PtrInt): integer;
begin
result := 0;
if (self=nil) or (fCount=0) or (FieldName='') then
exit;
StorageLock(false,'SearchEvent');
try
result := FindWhereEqual(FieldName,FieldValue,OnFind,Dest,FoundLimit,FoundOffset);
finally
StorageUnlock;
end;
end;
function TSQLRestStorageInMemory.SearchCopy(const FieldName, FieldValue: RawUTF8): pointer;
begin
if SearchEvent(FieldName,FieldValue,DoCopyEvent,@result,1,0)=0 then
result := nil;
end;
function TSQLRestStorageInMemory.SearchInstance(const FieldName, FieldValue: RawUTF8): pointer;
begin
if SearchEvent(FieldName,FieldValue,DoInstanceEvent,@result,1,0)=0 then
result := nil;
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;
class procedure TSQLRestStorageInMemory.DoNothingEvent(aDest: pointer;
aRec: TSQLRecord; aIndex: integer);
begin
end;
class procedure TSQLRestStorageInMemory.DoCopyEvent(aDest: pointer;
aRec: TSQLRecord; aIndex: integer);
begin
if aDest<>nil then
PPointer(aDest)^ := aRec.CreateCopy;
end;
class procedure TSQLRestStorageInMemory.DoAddToListEvent(aDest: pointer;
aRec: TSQLRecord; aIndex: integer);
begin
if aDest<>nil then
TSynList(aDest).Add(aRec);
end;
class procedure TSQLRestStorageInMemory.DoInstanceEvent(aDest: pointer;
aRec: TSQLRecord; aIndex: integer);
begin
if aDest<>nil then
PPointer(aDest)^ := aRec;
end;
class procedure TSQLRestStorageInMemory.DoIndexEvent(aDest: pointer; aRec: TSQLRecord;
aIndex: integer);
begin
if aDest<>nil then
PInteger(aDest)^ := aIndex;
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;
const msg: RawUTF8);
begin
inherited StorageLock(WillModifyContent,msg);
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;
aMaxShardCount: integer);
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 := -1;
fOptions := aOptions;
if aMaxShardCount<2 then
fMaxShardCount := 2 else
fMaxShardCount := aMaxShardCount;
InitShards; // set fShards[], fShardLast, fShardOffset and fShardLastID
n := length(fShards);
fShardNextID := (n+fShardOffset)*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);
InternalLog('Create(%,range=%,maxcount=%) [%..%]',[fStoredClass,fShardRange,
fMaxShardCount,fShardOffset,fShardOffset+n-1],sllDB);
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,'RemoveShard');
try
if (fShards<>nil) and (cardinal(aShardIndex)<=cardinal(fShardLast)) then begin
FreeAndNil(fShards[aShardIndex]);
fShardTableIndex[aShardIndex] := -1;
end;
finally
StorageUnLock;
end;
end;
procedure TSQLRestStorageShard.InternalAddNewShard;
var rest: TSQLRest;
i: integer;
{$ifdef WITHLOG}
log: ISynLog; // for Enter auto-leave to work with FPC
{$endif}
begin
{$ifdef WITHLOG}
log := 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);
if fShardLast>=fMaxShardCount then
for i := 0 to fShardLast do
if fShards[i]<>nil then begin
RemoveShard(i);
break;
end;
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;
ndx := ((aID-1) div fShardRange)-fShardOffset;
if (ndx<=cardinal(fShardLast)) and (fShards[ndx]<>nil) then begin
case aOccasion of
soUpdate:
if (ssoNoUpdateButLastShard in fOptions) and (ndx<>cardinal(fShardLast)) then
exit;
soDelete:
if (ssoNoDeleteButLastShard in fOptions) and (ndx<>cardinal(fShardLast)) then
exit;
end;
aShard := fShards[ndx];
aShardTableIndex := fShardTableIndex[ndx];
if aShardIndex<>nil then
aShardIndex^ := ndx;
result := true;
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,'EngineAdd');
try
inc(fShardLastID);
if fShardLastID>=fShardNextID then begin
InternalAddNewShard;
if fShardLastID>=fShardNextID then
raise EORMException.CreateUTF8('%.EngineAdd(%) fShardNextID',[self,fStoredClass]);
end;
result := fShardLastID;
i := PosExChar('{',SentData);
if i=0 then
FormatUTF8('{ID:%}',[result],data) 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 %.ID=%',[fStoredClass,result],sllDB);
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,'EngineDelete');
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
idn: TIntegerDynArray;
sql: RawUTF8;
begin
result := false;
if (IDs=nil) or (ssoNoDelete in fOptions) then
exit;
StorageLock(true,'EngineDeleteWhere');
try
SetLength(id,fShardLast+1);
SetLength(idn,fShardLast+1);
for i := 0 to high(IDs) do begin
ndx := ((IDs[i]-1) div fShardRange)-fShardOffset; // inlined ShardFromID()
if (ndx>=cardinal(fShardLast)) or (fShards[ndx]=nil) then
continue;
if (ssoNoDeleteButLastShard in fOptions) and (ndx<>cardinal(fShardLast)) then
continue;
AddInt64(id[ndx],idn[ndx],IDs[i]);
end;
result := true;
for i := 0 to high(id) do
if id[i]<>nil then begin
sql := Int64DynArrayToCSV(pointer(id[i]),idn[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,'EngineExecute');
try
if (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 // no StorageLock protection to avoid blocking
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,'EngineList');
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 (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,'EngineRetrieve');
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,'EngineRetrieveBlob');
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,'EngineUpdate');
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,'EngineUpdateBlob');
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,'EngineUpdateField');
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,'EngineUpdateFieldIncrement');
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,'InternalBatchStart'); // protected by try..finally in TSQLRestServer.RunBatch
try
if fShardBatch<>nil then
raise EORMException.CreateUTF8('%.InternalBatchStop should have been called',[self]);
if fShardLast<0 then // new DB -> force fShardBatch<>nil
SetLength(fShardBatch,1) else
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)>cardinal(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])<>HTTP_SUCCESS then
InternalLog('InternalBatchStop(%): %.BatchSend failed for shard #%',
[fStoredClass,fShards[i].ClassType,i],sllWarning);
finally
ObjArrayClear(fShardBatch);
StorageUnLock;
end;
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;
end else begin // fallback to an owned model instance
fModel := TSQLModel.Create([aClass]);
fModel.Owner := self;
end;
fStoredClassProps := fModel.Props[aClass];
fStoredClassMapping := @fStoredClassProps.ExternalDB;
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);
if fStorageVirtual<>nil then begin // no GPF e.g. if DB release after server
fStorageVirtual.fStatic := nil;
fStorageVirtual.fStaticStorage := nil;
end;
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;
const msg: RawUTF8);
begin
if fStorageLockLogTrace or (fStorageCriticalSectionCount>1) then
InternalLog('StorageLock % [%] %',[fStoredClass,msg,fStorageCriticalSectionCount]);
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]);
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
ToText(fStoredClass,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)=ToText(ClassType)+'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.GetTableIndexPtr(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: THandleStream;
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,ToText(ClassType)+'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.WriteBuffer(CHARS[0],1);
for t := 0 to fStaticDataCount-1 do
with TSQLRestStorageInMemory(fStaticData[t]) do begin
S.WriteBuffer(CHARS[1],2);
with fStoredClassRecordProps do
S.WriteBuffer(pointer(SQLTableName)^,length(SQLTableName));
S.WriteBuffer(CHARS[2],2);
SaveToJSON(S,true);
S.WriteBuffer(CHARS[5],1);
if t<integer(fStaticDataCount-1) then
S.WriteBuffer(CHARS[4],1);
end;
S.WriteBuffer(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);
inc(InternalState);
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.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_FIELDS,{knownrows=}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,soBeginning);
fLogTableStorage.WriteBuffer(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_FIELDS,{knownrows=}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;
FastSetString(result,Data+StartPosition,fLogTableStorage.Position-StartPosition);
// format as valid not expanded JSON table content:
if StartPosition<>0 then begin
FastSetString(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;
Cfrom,Cto,C: 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;
Cfrom := aFrom.ClassType;
Cto := aTo.ClassType;
if Cto.InheritsFrom(Cfrom) then // C = most common hierarchy level
C := Cfrom else
if Cfrom.InheritsFrom(Cto) then
C := Cto else begin
repeat // no common inheritance -> slower lookup by property name
for i := 1 to InternalClassPropInfo(Cfrom,P) do begin
P2 := ClassFieldPropWithParents(Cto,P^.Name);
if P2<>nil then
P^.CopyValue(aFrom,aTo,P2);
P := P^.Next;
end;
Cfrom := GetClassParent(Cfrom);
until Cfrom=TObject;
exit;
end;
repeat // fast process of inherited PPropInfo
for i := 1 to InternalClassPropInfo(C,P) do begin
P^.CopyValue(aFrom,aTo);
P := P^.Next;
end;
C := GetClassParent(C);
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);
var CT: TClass;
P: PPropInfo;
i, V: integer;
Obj: TObject;
tmp,field: RawUTF8;
begin
if Value=nil then
exit;
CT := Value.ClassType;
repeat
for i := 1 to InternalClassPropInfo(CT,P) do begin
field := SubCompName+ToUTF8(P^.Name);
case P^.PropType^.Kind of
tkInt64{$ifdef FPC}, tkQWord{$endif}:
UpdateIniEntry(IniContent,Section,field,
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,field,
Int32ToUtf8(V));
end;
{$ifdef HASVARUSTRING}tkUString,{$endif} {$ifdef FPC}tkLStringOld,{$endif}
tkLString, tkWString: begin
P^.GetLongStrValue(Value,tmp);
UpdateIniEntry(IniContent,Section,field,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,field+'.');
end;
// tkString (shortstring) and tkInterface are not handled
end;
P := P^.Next;
end;
CT := GetClassParent(CT);
until CT=TObject;
end;
function WriteObject(Value: TObject): RawUTF8;
var temp: TTextWriterStackBuffer;
begin
if Value<>nil then
with TIniWriter.CreateOwnedStream(temp) 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) or (Value1=Value2) 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 := GetClassParent(C1);
until C1=TObject;
result := true;
end;
end;
function ObjectToJSONDebug(Value: TObject; Options: TTextWriterWriteObjectOptions): RawUTF8;
begin
if Value=nil then
result := NULL_STR_VAR else
if Value.InheritsFrom(Exception) and not Value.InheritsFrom(ESynException) then
result := FormatUTF8('{"%":?}',[Value],[Exception(Value).Message],True) else
result := ObjectToJSON(Value,Options);
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;
type
TJSONObject =
(oNone, oObject, oException, oSynException, oList, oObjectList,
{$ifndef LVCL}oCollection,{$endif}
oUtfs, oStrings, oSQLRecord, oSQLMany, oPersistent, oSynAutoCreateFields,
oSynPersistentWithPassword, oSynMonitor, oSQLTable,
oCustomReaderWriter, oCustomPropName);
TShort63 = string[63];
TShort63DynArray = array of TShort63;
TJSONCustomParser = record
Reader: TJSONSerializerCustomReader;
Writer: TJSONSerializerCustomWriter;
Props: PPropInfoDynArray;
Fields: TShort63DynArray; // match Props[] order
Kind: TJSONObject;
end;
TJSONCustomParsers = array of TJSONCustomParser;
PJSONCustomParser = ^TJSONCustomParser;
var
JSONCustomParsers: TSynDictionary; // store TClass->TJSONCustomParser
function JSONObjectFromClass(aClassType: TClass; out aParser: PJSONCustomParser): TJSONObject;
const
MAX = {$ifdef LVCL}15{$else}16{$endif};
TYP: array[0..MAX] of TClass = ( // all classes types gathered in CPU L1 cache
TObject,Exception,ESynException,TList,TObjectList,TPersistent,TSynAutoCreateFields,
TSynPersistentWithPassword,TSynPersistent,TInterfacedObjectWithCustomCreate,
TSynMonitor,TSQLRecordMany,TSQLRecord,TStrings,TRawUTF8List,TSQLTable
{$ifndef LVCL},TCollection{$endif});
OBJ: array[0..MAX] of TJSONObject = ( // oPersistent = has published properties
oObject,oException,oSynException,oList,oObjectList,oPersistent,oSynAutoCreateFields,
oSynPersistentWithPassword,oPersistent,oPersistent,
oSynMonitor,oSQLMany,oSQLRecord,oStrings,oUtfs,oSQLTable
{$ifndef LVCL},oCollection{$endif});
var P: PJSONCustomParser;
added: boolean;
i: integer;
begin
result := oNone;
if aClassType<>nil then begin
JSONCustomParsers.Safe.Lock;
try
aParser := JSONCustomParsers.FindValueOrAdd(aClassType,added);
if not added then begin
result := aParser^.Kind;
if result<>oNone then // fast retrieval from cache
exit; // =oNone if has been unsubscribed
end;
repeat // search from RTTI and parent custom registration
i := PtrUIntScanIndex(@TYP,MAX+1,PtrUInt(aClassType));
if i>=0 then begin
result := OBJ[i];
aParser^.Kind := result; // default serialization from RTTI
exit;
end;
aClassType := GetClassParent(aClassType);
P := JSONCustomParsers.FindValue(aClassType);
if (P<>nil) and (P^.Kind in [oCustomReaderWriter,oCustomPropName]) then begin
aParser^ := P^; // copy from parent
result := P^.Kind;
exit;
end;
until aClassType=nil; // should never happen, since TObject exists in TYP[]
finally
JSONCustomParsers.Safe.UnLock;
end;
end else
aParser := nil;
end;
class procedure TJSONSerializer.RegisterCustomSerializer(aClass: TClass;
aReader: TJSONSerializerCustomReader; aWriter: TJSONSerializerCustomWriter);
var added: boolean;
P: PJSONCustomParser;
begin
JSONCustomParsers.Safe.Lock;
try
P := JSONCustomParsers.FindValueOrAdd(aClass,added);
P^.Writer := aWriter;
P^.Reader := aReader;
P^.Props := nil; // exclusive
P^.Fields := nil;
if Assigned(aWriter) or Assigned(aReader) then
P^.Kind := oCustomReaderWriter else
P^.Kind := oNone;
finally
JSONCustomParsers.Safe.UnLock;
end;
end;
function JSONCustomParsersFieldProp(ClassType: TClass; Parser: PJSONCustomParser;
PropName: PUTF8Char; PropNameLen: integer): PPropInfo;
var i: integer;
begin
if Parser^.Props<>nil then begin // search from RegisterCustomSerializerFieldNames()
for i := 0 to length(Parser^.Fields)-1 do
if IdemPropName(Parser^.Fields[i],PropName,PropNameLen) then begin
result := Parser^.Props[i];
exit;
end;
result := nil;
end else // a previous RegisterCustomSerializerFieldNames() was unregistered
result := ClassFieldPropWithParentsFromUTF8(ClassType,PropName,PropNameLen);
end;
class procedure TJSONSerializer.RegisterCustomSerializerFieldNames(aClass: TClass;
const aClassFields, aJsonFields: array of ShortString);
var prop: PPropInfoDynArray;
field: TShort63DynArray;
n,p,f: integer;
found: boolean;
parser: PJSONCustomParser;
begin
if high(aClassFields)<>high(aJsonFields) then
raise EParsingException.CreateUTF8('RegisterCustomSerializerFieldNames(%,%,%)'+
' fields count mismatch', [aClass,high(aClassFields),high(aJsonFields)]);
if aClass.InheritsFrom(TSQLRecord) then
raise EParsingException.CreateUTF8('RegisterCustomSerializerFieldNames(%)'+
' not allowed on ORM class', [aClass]);
prop := ClassFieldAllProps(aClass,[low(TTypeKind)..high(TTypeKind)]);
SetLength(field,length(prop));
n := 0;
for p := 0 to high(prop) do begin
found := false;
for f := 0 to high(aClassFields) do // check customized field name
if IdemPropName(prop[p].Name,aClassFields[f]) then begin
if aJsonFields[f]<>'' then begin // '' to ignore this property
field[n] := aJsonFields[f];
prop[n] := prop[p];
inc(n);
end;
found := true;
break;
end;
if not found then begin // default serialization of published property
field[n] := prop[p].Name;
prop[n] := prop[p];
inc(n);
end;
end;
SetLength(prop,n);
SetLength(field,n);
JSONCustomParsers.Safe.Lock;
try
parser := JSONCustomParsers.FindValueOrAdd(aClass,found);
@parser^.Writer := nil; // exclusive
@parser^.Reader := nil;
parser^.Props := prop;
parser^.Fields := field;
if Assigned(prop) then
parser^.Kind := oCustomPropName else
parser^.Kind := oNone;
finally
JSONCustomParsers.Safe.UnLock;
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(PtrUInt(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(PtrUInt(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(PtrUInt(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; aReader: TDynArrayJSONCustomReader; aWriter: TDynArrayJSONCustomWriter);
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,aItem,aReader,aWriter);
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 function TJSONSerializer.RegisterObjArrayFindTypeInfo(aClass: TClass): PTypeInfo;
var i: integer;
item: ^TObjArraySerializer;
begin
item := pointer(ObjArraySerializers.List);
for i := 1 to ObjArraySerializers.Count do
if item^.Instance.ItemClass=aClass then begin
result := item^.fInfo;
exit;
end else
inc(item);
result := nil;
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;
function PropIsIDTypeCastedField(Prop: PPropInfo; IsObj: TJSONObject;
Value: TObject): boolean;
begin // see [22ce911c715]
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; // real instance for regular classes
end else
result := false; // assume real instance by default
end;
type
/// wrapper object to ease JSONToObject() maintainability
TJSONToObject = object
public
// input parameters
From: PUTF8Char;
Value: TObject;
Options: TJSONToObjectOptions;
TObjectListItemClass: TClass;
// output parameters
Dest: PUTF8Char;
Valid: boolean;
procedure Parse;
private
ValueClass: TClass;
parser: PJSONCustomParser;
PropName, PropValue: PUTF8Char;
PropNameLen, PropValueLen: integer;
P: PPropInfo;
IsObj: TJSONObject;
Kind: TTypeKind;
EndOfObject: AnsiChar;
NestedValid, wasString: boolean;
{$ifndef NOVARIANTS}
procedure HandleVariant;
{$endif}
procedure HandleObjectList(Lst: TObjectList);
{$ifndef LVCL}
procedure HandleCollection(Coll: TCollection);
{$endif}
procedure HandleStrings(Str: TStrings);
procedure HandleUtfs(utf: TRawUTF8List);
procedure HandleProperty(var tmp: RawUTF8);
end;
function JSONToObject(var ObjectInstance; From: PUTF8Char; out Valid: boolean;
TObjectListItemClass: TClass; Options: TJSONToObjectOptions): PUTF8Char;
var parser: TJSONToObject;
begin
parser.From := From;
parser.Options := Options;
parser.TObjectListItemClass := TObjectListItemClass;
parser.Value := TObject(ObjectInstance);
parser.Parse;
Valid := parser.Valid;
TObject(ObjectInstance) := parser.Value; // e.g. 'null' -> FreeAndNil()
result := parser.Dest;
end;
function JSONSettingsToObject(var InitialJsonContent: RawUTF8; Instance: TObject): boolean;
var tmp: TSynTempBuffer;
begin
result := false;
if InitialJsonContent='' then
exit;
tmp.Init(InitialJsonContent);
try
RemoveCommentsFromJSON(tmp.buf);
JSONToObject(Instance,tmp.buf,result,nil,JSONTOOBJECT_TOLERANTOPTIONS);
if not result then
InitialJsonContent := '';
finally
tmp.Done;
end;
end;
function ObjectLoadJSON(var ObjectInstance; const JSON: RawUTF8;
TObjectListItemClass: TClass; Options: TJSONToObjectOptions): boolean;
var tmp: TSynTempBuffer;
begin
tmp.Init(JSON);
if tmp.len<>0 then
try
JSONToObject(ObjectInstance,tmp.buf,result,TObjectListItemClass,Options);
finally
tmp.Done;
end else
result := false;
end;
procedure TJSONToObject.HandleObjectList(Lst: TObjectList);
var Item: TObject;
ItemClass: TClass;
ItemInstance: TClassInstance;
begin
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
Dest := 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
Dest := 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}
procedure TJSONToObject.HandleCollection(Coll: TCollection);
var CollItem: TObject;
begin
Coll.BeginUpdate;
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
Dest := From;
CollItem := Coll.Add;
From := JSONToObject(CollItem,From,NestedValid,nil,Options);
if not NestedValid then begin
Dest := 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}
procedure TJSONToObject.HandleStrings(Str: TStrings);
var s: string;
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
Dest := From;
PropValue := GetJSONField(From,From,@wasString,@EndOfObject,@PropValueLen);
if (PropValue=nil) or not wasString then
exit;
UTF8DecodeToString(PropValue,PropValueLen,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;
procedure TJSONToObject.HandleUtfs(utf: TRawUTF8List);
var U: RawUTF8;
begin
utf.BeginUpdate;
try
utf.Clear;
repeat
while From^ in [#1..' '] do inc(From);
case From^ of
#0: exit;
']': begin
inc(From);
break;
end;
'"': begin
Dest := From;
PropValue := GetJSONField(From,From,@wasString,@EndOfObject,@PropValueLen);
if (PropValue=nil) or not wasString then
exit;
FastSetString(U,PropValue,PropValueLen);
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;
{$ifndef NOVARIANTS}
procedure TJSONToObject.HandleVariant;
var temp: variant;
opt: TDocVariantOptions;
begin
if j2oHandleCustomVariants in Options then begin
if j2oHandleCustomVariantsWithinString in Options then
opt := [dvoValueCopiedByReference,dvoAllowDoubleValue,dvoJSONObjectParseWithinString] else
opt := [dvoValueCopiedByReference,dvoAllowDoubleValue];
GetVariantFromJSON(PropValue,wasString,temp,@opt,false);
end else
GetVariantFromJSON(PropValue,wasString,temp,nil,false);
P^.SetVariantProp(Value,temp);
end;
{$endif NOVARIANTS}
procedure TJSONToObject.HandleProperty(var tmp: RawUTF8);
var V: PtrInt;
V64: Int64;
D: double;
err: integer;
begin
PropValue := GetJSONFieldOrObjectOrArray(From,@wasString,@EndOfObject,
{$ifdef NOVARIANTS}false{$else}Kind=tkVariant{$endif},true,@PropValueLen);
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 begin
if PropValue^=#0 then
V64 := 0 else
if not (j2oAllowInt64Hex in Options) or
not HexDisplayToBin(PAnsiChar(PropValue),@V64,SizeOf(V64)) then
exit;
P^.SetInt64Prop(Value,V64);
end else begin
if P^.PropType^.IsQWord then
V64 := GetQWord(PropValue,err) else
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,PropValueLen);
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}tkLStringOld,{$endif}{$ifdef HASVARUSTRING}tkUString,{$endif}
tkLString,tkWString: // handle all string types from temporary RawUTF8
if wasString or (j2oIgnoreStringType in Options) then begin
FastSetString(tmp,PropValue,PropValueLen);
P^.SetLongStrValue(Value,tmp);
end else
exit;
{$ifdef PUBLISHRECORD}
tkRecord{$ifdef FPC},tkObject{$endif}:
RecordLoadJSON(P^.GetFieldAddr(Value)^,PropValue,P^.TypeInfo);
{$endif}
{$ifndef NOVARIANTS}
tkVariant:
HandleVariant; // dedicated method for a local temporary variant
{$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^.SetDoubleProp(Value,Iso8601ToDateTimePUTF8Char(PropValue,PropValueLen));
end else
exit else
if wasString then
exit else
if P^.PropType^.FloatType=ftCurr then
P^.SetCurrencyProp(Value,StrToCurrency(pointer(PropValue))) else begin
D := GetExtended(pointer(PropValue),err);
if err<>0 then
exit else // invalid JSON content
P^.SetFloatProp(Value,D);
end;
else
exit; // unhandled type
end;
Dest := nil; // if we reached here, no error occured with this property
end;
procedure TJSONToObject.Parse;
var V: PtrInt;
DynArray: TDynArray;
U: RawUTF8;
Beg: PAnsiChar;
begin
Valid := false;
Dest := From;
if Value=nil then
exit;
ValueClass := PClass(Value)^;
IsObj := JSONObjectFromClass(ValueClass,parser);
if From=nil then begin
case IsObj of // handle '' as Clear for arrays
{$ifndef LVCL}
oCollection: TCollection(Value).Clear;
{$endif}
oStrings: TStrings(Value).Clear;
oUtfs: TRawUTF8List(Value).Clear;
oObjectList: TObjectList(Value).Clear;
end;
exit;
end;
if PInteger(From)^=NULL_LOW then begin
if (IsObj=oCustomReaderWriter) and Assigned(parser^.Reader) then
// custom JSON reader expects to be executed even if value is null
Dest := parser^.Reader(Value,From,Valid,Options) else begin
FreeAndNil(Value);
Dest := From+4;
Valid := true; // null is a valid JSON object
end;
exit;
end;
while From^ in [#1..' '] do inc(From);
if IsObj=oCustomReaderWriter then begin // may be from [array] or {object}
if Assigned(parser^.Reader) then // leave Valid=false if Reader=nil
Dest := parser^.Reader(Value,From,Valid,Options);
exit;
end;
if From^='[' then begin
// nested array = TObjectList, TCollection, TRawUTF8List or TStrings
inc(From);
case IsObj of
oObjectList: // TList leaks memory, but TObjectList uses "ClassName":..
HandleObjectList(TObjectList(Value));
{$ifndef LVCL}
oCollection:
HandleCollection(TCollection(Value));
{$endif}
oStrings:
HandleStrings(TStrings(Value));
oUtfs:
HandleUtfs(TRawUTF8List(Value));
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;
Dest := From;
exit; // a JSON array begin with [
end;
if From^<>'{' then begin
Dest := 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
// for each fields
repeat
wasString := false;
Dest := From;
PropName := GetJSONPropName(From,@PropNameLen); // get property name
if (From=nil) or (PropName=nil) then
exit; // invalid JSON content
if IdemPropName('ClassName',PropName,PropNameLen) then begin
// WriteObject() was called with woStoreClassName option -> ignore it
PropValue := GetJSONField(From,From,@wasString,@EndOfObject);
if (PropValue=nil) or not wasString or not (EndOfObject in ['}',',']) then
exit; // invalid JSON content
continue;
end;
if IsObj in [oSQLRecord,oSQLMany] then
if 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;
if IsObj=oCustomPropName then
P := JSONCustomParsersFieldProp(ValueClass,parser,PropName,PropNameLen) else
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);
Dest := 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 ['[','{']) {$ifndef NOVARIANTS}and (Kind<>tkVariant){$endif} then begin
if Kind=tkDynArray then begin
P^.GetDynArray(Value,DynArray);
From := DynArray.LoadFromJSON(From);
if From=nil then
exit; // invalid '[dynamic array]' content
end else
if P^.TypeInfo=TypeInfo(RawJSON) then begin
Beg := pointer(From);
From := GotoNextJSONObjectOrArray(From);
if From=nil then
exit;
FastSetString(U,Beg,From-Beg);
P^.SetLongStrProp(Value,U);
end else
if (Kind=tkSet) and (From^='[') then begin // set as string array
V := GetSetNameValue(P^.TypeInfo,From,EndOfObject);
if From=nil then
exit; // invalid '["setone","settwo"]' content
P^.SetOrdProp(Value,V);
if EndOfObject='}' then
break else
continue;
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
Dest := 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
HandleProperty(U);
if Dest<>nil then
exit; // an error occured
end;
until (From=nil) or (EndOfObject='}');
if IsObj=oSynAutoCreateFields then
TSynAutoCreateFields(Value).AfterLoad;
if From<>nil then begin
while From^ in [#1..' '] do inc(From);
if From^=#0 then
From := nil;
end;
Valid := (EndOfObject='}'); // mark parsing success
Dest := From;
end;
function UrlDecodeObject(U: PUTF8Char; Upper: PAnsiChar; var ObjectInstance;
Next: PPUTF8Char; 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; 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;
if humanread and (woHumanReadableEnumSetAsComment in Options) then
humanread := false else // JsonReformat() erases comments
Exclude(Options,woHumanReadable);
json := ObjectToJSON(Value,Options);
if humanread then
// woHumanReadable not working with custom JSON serializers, e.g. T*ObjArray
result := JSONBufferReformatToFile(pointer(json),JSONFile) else
result := FileFromString(json,JSONFile);
end;
procedure ReadObject(Value: TObject; From: PUTF8Char; const SubCompName: RawUTF8);
var CT: TClass;
P: PPropInfo;
i: integer;
Obj: TObject;
U: RawUTF8;
UpperName: array[byte] of AnsiChar;
begin
if Value=nil then // allow From=nil -> default values
exit;
CT := Value.ClassType;
repeat
for i := 1 to InternalClassPropInfo(CT,P) do begin
PWord(UpperCopyShort(UpperCopy255(UpperName,SubCompName),P^.Name))^ := ord('=');
U := FindIniNameValue(From,UpperName);
if P^.PropType^.Kind=tkClass then begin // recursive unserialization
Obj := P^.GetObjProp(Value);
if (Obj<>nil) and ClassHasPublishedFields(PPointer(Obj)^) then
ReadObject(Obj,From,SubCompName+ToUTF8(P^.Name)+'.');
end else
P^.SetFromText(Value,U,@JSON_OPTIONS[true],{allowdouble=}true);
P := P^.Next;
end;
CT := GetClassParent(CT);
until CT=TObject;
end;
procedure ReadObject(Value: TObject; const FromContent,SubCompName: RawUTF8);
var source: PUTF8Char;
UpperSection: array[byte] of AnsiChar;
begin
if Value=nil then
exit; // avoid GPF
PWord(UpperCopyShort(UpperSection,ClassNameShort(Value)^))^ := 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
tkEnumeration,tkSet,tkInteger,tkChar,tkWChar{$ifdef FPC},tkBool{$endif}:
if p^.Default<>NO_DEFAULT then
p^.SetOrdProp(Value,p^.Default);
tkClass:
SetDefaultValuesObject(p^.GetObjProp(Value));
end;
p := p^.Next;
end;
c := GetClassParent(c);
until c=TObject;
end;
function IsObjectDefaultOrVoid(Value: TObject): boolean;
var i: integer;
C: TClass;
P: PPropinfo;
begin
if Value<>nil then begin
result := false;
C := Value.ClassType;
repeat
for i := 1 to InternalClassPropInfo(C,P) do
if P^.IsDefaultOrVoid(Value) then
P := P^.Next else
exit;
C := GetClassParent(C);
until C=TObject;
end;
result := true;
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);
p := p^.Next;
end;
c := GetClassParent(c);
until c=TObject;
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 LVCL}
begin
{$ifdef FPC}
C := GetClassParent(C);
{$else}
C := PPointer(PtrInt(C)+vmtParent)^;
if C<>nil then
C := PPointer(C)^;
{$endif FPC}
if C<>nil then
continue else begin
ItemCreate := cicTObject;
exit;
end;
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 LVCL}
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;
procedure TClassInstance.SetCustomComment(var CustomComment: RawUTF8);
begin
FormatUTF8('array of {%}',[ClassFieldNamesAllPropsAsText(ItemClass,true)],
CustomComment);
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; // for Enter auto-leave to work with FPC
{$endif}
begin
{$ifdef WITHLOG}
log := fLogClass.Enter(self, 'InternalURI');
{$endif}
if (fClientWindow=0) or not InternalCheckOpen then begin
Call.OutStatus := HTTP_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
FastSetString(Msg,@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 := HTTP_TIMEOUT; // 408 Request Timeout Error
exit;
end;
until fCurrentResponse<>#0;
end;
// 3. return answer to caller
if length(fCurrentResponse)<=SizeOf(Int64) then
Call.OutStatus := HTTP_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 := HTTP_NOTFOUND else begin
GetNextItem(P,#1,Call.OutHead);
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 := HTTP_SUCCESS; // Send something back
if fCurrentResponse=#0 then // expect some response?
FastSetString(fCurrentResponse,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.ComputeSignature(const UserName,Content: RawByteString): RawUTF8;
var SHA: TSHA256;
Digest: TSHA256Digest;
begin
SHA.Init;
SHA.Update(TTimeLogBits(fSignatureTime).Text(false));
SHA.Update(ToText(ClassType));
SHA.Update(UserName);
SHA.Update(Content);
SHA.Final(Digest);
result := SHA256DigestToString(Digest);
end;
function TSQLRecordSigned.CheckSignature(const Content: RawByteString): boolean;
var i: integer;
sign: RawUTF8;
begin
result := false;
if self=nil then
exit;
i := PosExChar('/',fSignature);
if i=0 then
exit;
sign := ComputeSignature(copy(fSignature,1,i-1),Content);
if IdemPropNameU(sign,copy(fSignature,i+1,SizeOf(TSHA256Digest)*2)) then
result := true;
end;
function TSQLRecordSigned.SetAndSignContent(const UserName: RawUTF8;
const Content: RawByteString; ForcedSignatureTime: Int64): boolean;
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;
fSignature := UserName+'/'+ComputeSignature(UserName,Content);
end;
function TSQLRecordSigned.SignedBy: RawUTF8;
var i: integer;
begin
if self=nil then
i := 0 else
i := PosExChar('/',fSignature);
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}
{$ifdef FPC} nostackframe; assembler; {$endif} 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/5 table but source % is not '+
'a local SQLite3 table: FTS search will be unavailable',[self,main],sllWarning);
exit;
end;
fts := Props.Props.SQLTableName;
ftsfields := Props.Props.SQLTableSimpleFieldsNoRowID;
// see http://www.sqlite.org/fts3.html#*fts4content
if Props.Kind=rFTS5 then begin
// In fts 5 we can't use docid only rowid, also use insert() values('delete',) to delete record
Server.ExecuteFmt('CREATE TRIGGER %_bu BEFORE UPDATE ON % '+
'BEGIN INSERT INTO %(%,rowid,%) VALUES(''delete'',old.rowid%); END;',
[main,main,fts,fts,ftsfields, StringReplaceAll(Props.fFTSWithoutContentFields, 'new.', 'old.')]);
Server.ExecuteFmt('CREATE TRIGGER %_bd BEFORE DELETE ON % '+
'BEGIN INSERT INTO %(%,rowid,%) VALUES(''delete'',old.rowid%); END;',
[main,main,fts,fts,ftsfields, StringReplaceAll(Props.fFTSWithoutContentFields, 'new.', 'old.')]);
Server.ExecuteFmt('CREATE TRIGGER %_au AFTER UPDATE ON % '+
'BEGIN INSERT INTO %(rowid,%) VALUES(new.rowid%); END;',
[main,main,fts,ftsfields,Props.fFTSWithoutContentFields]);
Server.ExecuteFmt('CREATE TRIGGER %_ai AFTER INSERT ON % '+
'BEGIN INSERT INTO %(rowid,%) VALUES(new.rowid%); END;',
[main,main,fts,ftsfields,Props.fFTSWithoutContentFields]);
end else begin
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;
end;
{ TSQLRecordRTreeAbstract }
class function TSQLRecordRTreeAbstract.RTreeSQLFunctionName: RawUTF8;
begin
result := RecordProps.SQLTableName+'_in';
end;
{ TSQLRecordRTree }
class procedure TSQLRecordRTree.BlobToCoord(const InBlob;
var OutCoord: TSQLRecordTreeCoords);
begin // direct memory copy with no memory check
MoveFast(InBlob,OutCoord,(RecordProps.RTreeCoordBoundaryFields 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.RTreeCoordBoundaryFields 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;
{ TSQLRecordRTreeInteger }
class procedure TSQLRecordRTreeInteger.BlobToCoord(const InBlob;
var OutCoord: TSQLRecordTreeCoordsInteger);
begin // direct memory copy with no memory check
MoveFast(InBlob,OutCoord,(RecordProps.RTreeCoordBoundaryFields shr 1)*SizeOf(integer));
end;
class function TSQLRecordRTreeInteger.ContainedIn(const BlobA,BlobB): boolean;
var A,B: TSQLRecordTreeCoordsInteger;
i: integer;
begin
BlobToCoord(BlobA,A);
BlobToCoord(BlobB,B);
result := false;
for i := 0 to (RecordProps.RTreeCoordBoundaryFields 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;
{ 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 will 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 EModelException.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 EModelException.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;
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 NOVARIANTS}
' BLOB, ', // sftBlob
' BLOB, ', // sftBlobDynArray
' BLOB, ', // sftBlobCustom
' TEXT COLLATE NOCASE, ', // sftUTF8Custom
'', // sftMany
' INTEGER, ', // sftModTime
' INTEGER, ', // sftCreateTime
' INTEGER, ', // sftTID
' INTEGER, ', // sftRecordVersion
' INTEGER, ', // sftSessionUserID
' TEXT COLLATE ISO8601, ', // sftDateTimeMS
' INTEGER, ', // sftUnixTime
' INTEGER, '); // sftUnixMSTime
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;
with Fields.List[FieldIndex] do
if IdemPropNameU(aCollationName,'BINARY') then
include(fAttributes,aBinaryCollation) else
exclude(fAttributes,aBinaryCollation);
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) and not(aFieldType in [sftUnknown,sftMany]) then
for i := 0 to Fields.Count-1 do
if Fields.List[i].SQLFieldTypeStored=aFieldType then
SetCustomCollation(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
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,aBufSize: integer): TJSONSerializer;
begin
result := CreateJSONWriter(JSON,Expand,withID,
FieldBitsToIndex(aFields,Fields.Count),KnownRowsCount,aBufSize);
end;
function TSQLRecordProperties.CreateJSONWriter(JSON: TStream; Expand,
withID: boolean; const aFields: TSQLFieldIndexDynArray; KnownRowsCount,aBufSize: integer): TJSONSerializer;
begin
if (self=nil) or ((Fields.Count=0) and not withID) then // no data
result := nil else begin
result := TJSONSerializer.Create(JSON,Expand,withID,aFields,aBufSize);
SetJSONWriterColumnNames(result,KnownRowsCount);
end;
end;
function TSQLRecordProperties.CreateJSONWriter(JSON: TStream; Expand: boolean;
const aFieldsCSV: RawUTF8; KnownRowsCount,aBufSize: integer): TJSONSerializer;
var withID: boolean;
bits: TSQLFieldBits;
begin
FieldBitsFromCSV(aFieldsCSV,bits,withID);
result := CreateJSONWriter(JSON,Expand,withID,bits,KnownRowsCount,aBufSize);
end;
function TSQLRecordProperties.SaveSimpleFieldsFromJsonArray(var P: PUTF8Char;
var EndOfObject: AnsiChar; ExtendedJSON: boolean): RawUTF8;
var i: integer;
W: TJSONSerializer;
Start: PUTF8Char;
temp: TTextWriterStackBuffer;
begin
result := '';
if P=nil then
exit;
while (P^<=' ') and (P^<>#0) do inc(P);
if P^<>'[' then
exit;
repeat inc(P) until (P^>' ') or (P^=#0);
W := TJSONSerializer.CreateOwnedStream(temp);
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 (P^>' ') or (P^=#0);
end;
W.CancelLastComma;
W.Add('}');
W.SetText(result);
finally
W.Free;
end;
EndOfObject := P^;
if P^<>#0 then
repeat inc(P) until (P^>' ') or (P^=#0);
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]=')' then
case IdemPCharArray(pointer(PropName),['MAX(','MIN(','AVG(','SUM(',
'JSONGET(','JSONHAS(']) of
0..3:
result := IsFieldName(copy(PropName,5,L-5));
4..5:
result := IsFieldName(copy(PropName,9,PosExChar(',',PropName)-9));
else
result := IsFieldName(PropName);
end 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;
temp: TTextWriterStackBuffer;
begin
W := TTextWriter.CreateOwnedStream(temp);
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;
aData2Text: TOnSQLPropInfoRecord2Text; aText2Data: TOnSQLPropInfoRecord2Data);
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);
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);
begin
Fields.Add(TSQLPropInfoCustomJSON.Create(aTypeName,aName,Fields.Count,
aPropertyPointer,aAttributes,aFieldWidth));
end;
{ TSynValidateRest }
function TSynValidateRest.Process(aFieldIndex: integer; const Value: RawUTF8; var ErrorMsg: string): boolean;
begin
Result := DoValidate(aFieldIndex, Value, ErrorMsg, fProcessRest, fProcessRec);
end;
function TSynValidateRest.Validate(aFieldIndex: integer; const Value: RawUTF8; var ErrorMsg: string; aProcessRest: TSQLRest; aProcessRec: TSQLRecord): boolean;
begin
try
fProcessRest := aProcessRest;
fProcessRec := aProcessRec;
result := DoValidate(aFieldIndex,Value,ErrorMsg,aProcessRest,aProcessRec);
finally
fProcessRest := nil;
fProcessRec := nil;
end;
end;
{ TSynValidateUniqueField }
function TSynValidateUniqueField.DoValidate(aFieldIndex: integer; const Value: RawUTF8;
var ErrorMsg: string; aProcessRest: TSQLRest; aProcessRec: TSQLRecord): boolean;
var aID: TID;
begin
result := false;
if Value='' then
ErrorMsg := sValidationFieldVoid else
if (aProcessRest=nil) or (aProcessRec=nil) then
result := true else
with aProcessRec.RecordProps do
if cardinal(aFieldIndex)>=cardinal(Fields.Count) then
result := true else begin
SetID(aProcessRest.OneFieldValue(Table,'RowID',
Fields.List[aFieldIndex].Name+'=:('+QuotedStr(Value,'''')+'):'),aID);
if (aID>0) and (aID<>aProcessRec.fID) then
ErrorMsg := sValidationFieldDuplicate else
result := true;
end;
end;
{ TSynValidateUniqueFields }
procedure TSynValidateUniqueFields.SetParameters(const Value: RawUTF8);
var V: array[0..0] of TValuePUTF8Char;
tmp: TSynTempBuffer;
begin
tmp.Init(Value);
try
JSONDecode(tmp.buf,['FieldNames'],@V,True);
CSVToRawUTF8DynArray(V[0].Value,fFieldNames);
finally
tmp.Done;
end;
end;
function TSynValidateUniqueFields.DoValidate(aFieldIndex: integer;
const Value: RawUTF8; var ErrorMsg: string; aProcessRest: TSQLRest; aProcessRec: TSQLRecord): boolean;
var where: RawUTF8;
i: integer;
aID: TID;
begin
if (aProcessRest=nil) or (aProcessRec=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(aProcessRec.GetFieldValue(fFieldNames[i]),'''')+'):';
end;
SetID(aProcessRest.OneFieldValue(aProcessRec.RecordClass,'ID',where),aID);
if (aID>0) and (aID<>aProcessRec.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;
CustomPropName: PShortString;
IsObj: TJSONObject;
WS: WideString;
{$ifdef HASVARUSTRING} US: UnicodeString; {$endif}
tmp: RawByteString;
{$ifndef NOVARIANTS} VV: variant; {$endif}
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;
if CustomPropName<>nil then
AddPropName(CustomPropName^) else
AddPropName(P^.Name); // handle twoForceJSONExtended in CustomOptions
if woHumanReadable in Options then
Add(' ');
Added := true;
end;
procedure WriteProp(P: PPropInfo);
var D64: double;
V64: Int64;
Obj: TObject;
V, c, codepage: integer;
po: PObject;
Kind: TTypeKind;
PS: PShortString;
dyn: TDynArray;
dynObjArray: PClassInstance;
begin
if Assigned(OnWriteObject) and OnWriteObject(self,Value,P,Options) then
exit;
if IsObj in [oSQLRecord,oSQLMany] then begin // ignore "stored AS_UNIQUE"
if IsRowIDShort(P^.Name) then
exit; // should not happen
end else
if not (woStoreStoredFalse in Options) and
not P^.IsStored(Value) then
exit; // ignore regular "stored false" attribute
Added := false; // HR(P) will 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))) and
not ((V64=0) and (woDontStore0 in Options)) then begin
HR(P);
if woTimeLogAsText in Options then
case P^.PropType^.GetSQLFieldType of
sftTimeLog,sftModTime,sftCreateTime: begin
Add('"');
AddTimeLog(@V64);
Add('"',',');
exit;
end;
sftUnixTime: begin
Add('"');
AddUnixTime(@V64);
Add('"',',');
exit;
end;
sftUnixMSTime: begin
Add('"');
AddUnixMSTime(@V64);
Add('"',',');
exit;
end;
end;
if woInt64AsHex in Options then begin
Add('"');
if V64 <> 0 then
AddBinToHexDisplay(@V64,SizeOf(V64));
Add('"');
end else
if {$ifdef FPC}Kind=tkQWord{$else}P^.PropType^.IsQWord{$endif} then
AddQ(V64) else
Add(V64);
end;
end;
{$ifdef FPC} tkBool, {$endif}
tkEnumeration, tkInteger, tkSet: begin
V := P^.GetOrdProp(Value);
if not ((woDontStoreDefault in Options) and (V=P^.Default)) and
not ((V=0) and (woDontStore0 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}tkSString{$else}tkString{$endif}: begin
P^.GetShortStrProp(Value,tmp);
if (tmp<>'') or not (woDontStoreEmptyString in Options) then begin
HR(P);
Add('"');
AddJSONEscape(pointer(tmp));
Add('"');
end;
end; // no shortstring deserialization by now
{$ifdef FPC}tkLStringOld,{$endif} tkLString:
if P^.TypeInfo=TypeInfo(RawJSON) then begin
P^.GetLongStrProp(Value,tmp); // assume shortstring field is UTF-8 encoded
if tmp<>'' then begin
HR(P);
AddString(tmp);
end;
end else 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=oSynPersistentWithPassword) 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
if (P^.TypeInfo=TypeInfo(Currency)) and P^.GetterIsField then begin
V64 := PInt64(P^.GetterAddr(Value))^;
if not ((V64=0) and (woDontStore0 in Options)) then begin
HR(P);
AddCurr64(V64);
end;
end else
if P^.TypeInfo=TypeInfo(TDateTime) then begin
D64 := P^.GetDoubleProp(Value);
if not ((D64=0) and (woDontStore0 in Options)) then begin
HR(P);
if woDateTimeWithMagic in Options then
AddNoJSONEscape(@JSON_SQLDATE_MAGIC_QUOTE_VAR,4) else
Add('"');
AddDateTime(D64);
if woDateTimeWithZSuffix in Options then
if frac(D64)=0 then // FireFox can't decode short form "2017-01-01Z"
AddShort('T00:00:00Z') else // the same pattern for date and dateTime
Add('Z');
Add('"');
end;
end else begin
D64 := P^.GetFloatProp(Value);
if not ((woDontStore0 in Options) and (D64=0)) then begin
HR(P);
AddDouble(D64);
end;
end;
end;
{$ifdef HASVARUSTRING}
tkUString: begin // write converted to UTF-8
P^.GetUnicodeStrProp(Value,US);
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
P^.GetDynArray(Value,dyn);
if not ((woDontStore0 in Options) and (dyn.Count=0)) then begin
HR(P);
dynObjArray := P^.DynArrayIsObjArrayInstance;
if (dynObjArray<>nil) and HasDefaultObjArrayWriter(dyn) then begin
if dyn.Count=0 then begin
if woHumanReadableEnumSetAsComment in Options then
dynObjArray^.SetCustomComment(CustomComment);
Add('[',']');
end else begin // do not use AddDynArrayJSON to support HR
inc(fHumanReadableLevel);
Add('[');
po := dyn.Value^;
for c := 1 to dyn.Count do begin
WriteObject(po^,Options);
Add(',');
inc(po);
end;
CancelLastComma;
dec(fHumanReadableLevel);
HR;
Add(']');
end;
end else
AddDynArrayJSON(dyn); // not an ObjArray: record-based serialization
end;
end;
{$ifdef PUBLISHRECORD}
tkRecord{$ifdef FPC},tkObject{$endif}: begin
HR(P);
AddRecordJSON(P^.GetFieldAddr(Value)^,P^.PropType^);
end;
{$endif}
{$ifndef NOVARIANTS}
tkVariant: begin
P^.GetVariantProp(Value,VV);
if not ((TVarData(VV).VType<=varNull) and (woDontStore0 in Options)) then begin
HR(P);
AddVariant(VV,twJSONEscape); // stored as JSON, e.g. '1.234' or '"text"'
end;
end;
{$endif NOVARIANTS}
tkClass: begin
Obj := P^.GetObjProp(Value);
if Obj<>nil then
if PropIsIDTypeCastedField(P,IsObj,Value) then begin
HR(P);
Add(PtrInt(Obj)); // not true instances, but ID
end else
if not(woDontStore0 in Options) or not IsObjectDefaultOrVoid(Obj) then begin
HR(P); // TPersistent or any class defined with $M+
WriteObject(Obj,Options);
end;
end;
// tkString (shortstring) and tkInterface is not handled
end;
if Added then
Add(',');
end;
procedure WritePropsFromRTTI(aClassType: TClass);
var i: integer;
P: PPropInfo;
begin
repeat
for i := 1 to InternalClassPropInfo(aClassType,P) do begin
WriteProp(P);
P := P^.Next;
end;
if woDontStoreInherited in Options then
break;
aClassType := GetClassParent(aClassType);
until aClassType=TObject;
end;
var i, c: integer;
List: TList absolute Value;
{$ifndef LVCL}
Coll: TCollection absolute Value;
{$endif}
Str: TStrings absolute Value;
Utf: TRawUTF8List absolute Value;
Table: TSQLTable absolute Value;
parser: PJSONCustomParser;
aClassType: TClass;
UtfP: PPUtf8CharArray;
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;
CustomPropName := nil;
aClassType := PClass(Value)^;
IsObj := JSONObjectFromClass(aClassType,parser);
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
oCustomReaderWriter: begin
if Assigned(parser^.Writer) then
parser^.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.TextPtr;
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 // add TSQLRecord.ID property
HR;
AddPropName('ID');
if woHumanReadable in Options then
Add(' ');
Add(TSQLRecord(Value).fID);
Add(',');
if woIDAsIDstr in Options then begin
AddPropName('ID_str');
Add('"');
Add(TSQLRecord(Value).fID);
Add('"',',');
end;
end else begin
if woStorePointer in Options then begin
HR;
AddPropName('Address'); // "Address":"0431298a" field
Add('"');
if (IsObj=oSynException) and (ESynException(Value).RaisedAt<>nil) then
TSynMapFile.Log(self,PtrUInt(ESynException(Value).RaisedAt),false) else
AddPointer(PtrUInt(Value));
Add('"',',');
end;
case IsObj of
oException: begin
HR;
AddPropName('Message'); // not published property -> manual serialization
Add('"');
AddJSONEscapeString(Exception(Value).Message);
Add('"',',');
end;
end;
end;
if IsObj=oCustomPropName then begin
if parser^.Props=nil then // has been unregistered
WritePropsFromRTTI(aClassType) else
if woDontStoreInherited in Options then
raise EParsingException.CreateUTF8('%.WriteObject woDontStoreInherited '+
'after RegisterCustomSerializerFieldNames(%)', [self,aClassType]) else
for i := 0 to length(parser^.Props)-1 do begin
CustomPropName := @parser^.Fields[i];
WriteProp(parser^.Props[i]);
end;
end else
WritePropsFromRTTI(aClassType);
CancelLastComma;
dec(fHumanReadableLevel);
HR;
Add('}');
if woFullExpand in Options then
Add('}');
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;
fStaticStorage := TSQLRestStorage(fStatic);
fStaticStorage.fStorageVirtual := self;
end;
end;
end;
destructor TSQLVirtualTable.Destroy;
var t,n: 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)
t := Model.GetTableIndex(TableName);
n := length(fStaticVirtualTable);
if t<n then begin
fStaticVirtualTable[t] := nil;
if IsZero(pointer(fStaticVirtualTable),n*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
ToText(self,result);
system.delete(result,1,LEN[IdemPCharArray(pointer(result),
['TSQLVIRTUALTABLE','TSQLVIRTUAL','TSQL'])]);
end;
end;
class function TSQLVirtualTable.StructureFromClass(aClass: TSQLRecordClass;
const aTableName: RawUTF8): RawUTF8;
begin
FormatUTF8('CREATE TABLE % (%',[aTableName,
GetVirtualTableSQLCreate(aClass.RecordProps)],result);
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.Options := [];
aResult.VType := ftInt64;
aResult.VInt64 := aValue;
end;
procedure TSQLVirtualTableCursor.SetColumn(var aResult: TSQLVar; const aValue: double);
begin
aResult.Options := [];
aResult.VType := ftDouble;
aResult.VDouble := aValue;
end;
procedure TSQLVirtualTableCursor.SetColumn(var aResult: TSQLVar; const aValue: RawUTF8);
begin
aResult.Options := [];
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.Options := [];
aResult.VType := ftUTF8;
FastSetString(RawUTF8(fColumnTemp),aValue,aValueLength); // temporary copy
aResult.VText := pointer(fColumnTemp);
end;
procedure TSQLVirtualTableCursor.SetColumnBlob(var aResult: TSQLVar;
aValue: pointer; aValueLength: integer);
begin
aResult.Options := [];
aResult.VType := ftBlob;
SetString(fColumnTemp,PAnsiChar(aValue),aValueLength); // temporary copy
aResult.VBlob := pointer(fColumnTemp);
aResult.VBlobLen := aValueLength;
end;
procedure TSQLVirtualTableCursor.SetColumnDate(var aResult: TSQLVar; const aValue: TDateTime;
aWithMS: boolean);
begin
if aWithMS then
aResult.Options := [svoDateWithMS] else
aResult.Options := [];
aResult.VType := ftDate;
aResult.VDateTime := aValue;
end;
procedure TSQLVirtualTableCursor.SetColumnCurr64(var aResult: TSQLVar; aValue64: PInt64);
begin
aResult.Options := [];
aResult.VType := ftCurrency;
PInt64(@aResult.VCurrency)^ := aValue64^;
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 := true;
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.DropValues({andupdatefile=}true);
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 (Column>=0) and (Column in fStaticInMemory.fIsUnique) 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;
end;
end;
function TSQLVirtualTableJSON.Update(oldRowID, newRowID: Int64;
var Values: TSQLVarDynArray): boolean;
var i: PtrInt;
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(fStaticInMemory.fValue[i],soUpdate);
end;
result := true;
end;
end;
{ TSQLVirtualTableCursorJSON }
function TSQLVirtualTableCursorJSON.Column(aColumn: integer;
var aResult: TSQLVar): boolean;
var store: TSQLRestStorageInMemory;
begin
if (self=nil) or (fCurrent>fMax) or
(TSQLVirtualTableJSON(Table).Static=nil) then begin
result := false;
exit;
end;
store := TSQLVirtualTableJSON(Table).fStaticInMemory;
if Cardinal(fCurrent)>=Cardinal(store.fCount) then
result := false else begin
if aColumn=VIRTUAL_TABLE_ROWID_COLUMN then begin
aResult.VType := ftInt64;
aResult.VInt64 := store.fValue[fCurrent].fID;
end else
with store.fStoredClassRecordProps.Fields do
if cardinal(aColumn)>=cardinal(Count) then
aResult.VType := ftNull else
List[aColumn].GetFieldSQLVar(store.fValue[fCurrent],aResult,fColumnTemp);
result := true;
end;
end;
function TSQLVirtualTableCursorJSON.Search(const Prepared: TSQLVirtualTablePrepared): boolean;
var store: TSQLRestStorageInMemory;
begin
result := false;
inherited Search(Prepared); // mark EOF by default
if not Table.InheritsFrom(TSQLVirtualTableJSON) then
exit;
store := TSQLVirtualTableJSON(Table).fStaticInMemory;
if store=nil then
exit;
if store.fCount>0 then
// if something to search in
if Prepared.IsWhereIDEquals(false) then begin // ID=?
fMax := store.IDToIndex(Prepared.Where[0].Value.VInt64); // binary search
if fMax>=0 then
fCurrent := fMax; // ID found
end else begin
fMax := store.fCount-1; // loop all records in ID order by default
if Prepared.IsWhereOneFieldEquals then
with Prepared.Where[0] do
if Column in store.fIsUnique then begin
store.fStoredClassRecordProps.Fields.List[Column].
SetFieldSQLVar(store.fSearchRec,Value);
fMax := store.fUnique[Column].Find(store.fSearchRec);
if fMax>=0 then
fCurrent := fMax; // value found with O(1) search
end;
end;
result := true; // no DB error
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: SetColumnDate(aResult,LogFile.EventDateTime(fCurrent),true);
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
fTimeOutShr10 := (QWord(User.GroupRights.SessionTimeout)*(1000*60))shr 10;
fTimeOutTix := GetTickCount64 shr 10+fTimeOutShr10;
fAccessRights := User.GroupRights.SQLAccessRights;
fPrivateSalt := fID+'+'+fPrivateKey;
fPrivateSaltHash :=
crc32(crc32(0,pointer(fPrivateSalt),length(fPrivateSalt)),
pointer(User.PasswordHashHexa),length(User.PasswordHashHexa));
end;
constructor TAuthSession.Create(aCtxt: TSQLRestServerURIContext; aUser: TSQLAuthUser);
var GID: TSQLAuthGroup;
rnd: THash256;
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
TAESPRNG.Main.Fill(@rnd,SizeOf(rnd));
fPrivateKey := BinToHex(@rnd,SizeOf(rnd));
if not (rsoGetUserRetrieveNoBlobData in aCtxt.Server.Options) then
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;
fRemoteIP := aCtxt.RemoteIP;
{$ifdef WITHLOG}
aCtxt.Log.Log(sllUserAuth,
'New [%] session %/% created at %/% running %',
[User.GroupRights.Ident,User.LogonName,fIDCardinal,fRemoteIP,
aCtxt.Call^.LowLevelConnectionID,aCtxt.GetUserAgent],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 will 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; PEnd: PAnsiChar; Server: TSQLRestServer);
procedure RaiseError;
begin
raise ESynException.CreateUTF8('%.CreateFrom() with invalid format',[self]);
end;
var PB: PByte absolute P;
i32: cardinal;
begin
if PB^=TAUTHSESSION_MAGIC then
inc(PB) else
RaiseError;
PB := FromVarUInt32Safe(PB,pointer(PEnd),fIDCardinal);
if PB=nil then
RaiseError;
UInt32ToUtf8(fIDCardinal,fID);
fUser := Server.SQLAuthUserClass.Create;
PB := FromVarUInt32Safe(PB,pointer(PEnd),i32);
if PB=nil then
RaiseError;
fUser.fID := i32;
fUser.SetBinaryValues(P,PEnd); // fUser.fGroup will be overriden by true instance
fUser.fGroup := Server.SQLAuthGroupClass.Create;
PB := FromVarUInt32Safe(PB,pointer(PEnd),i32);
if PB=nil then
RaiseError;
fUser.fGroup.fID := i32;
fUser.fGroup.SetBinaryValues(P,PEnd);
fPrivateKey := FromVarString(PB,pointer(PEnd));
fSentHeaders := FromVarString(PB,pointer(PEnd));
if PB=nil then
RaiseError;
ComputeProtectedValues;
FindNameValue(fSentHeaders,HEADER_REMOTEIP_UPPER,fRemoteIP);
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
FormatUTF8('%,%,%,%,%', [Byte(AllowRemoteExecute),
GetBitCSV(GET,MAX_SQLTABLES), GetBitCSV(POST,MAX_SQLTABLES),
GetBitCSV(PUT,MAX_SQLTABLES), GetBitCSV(DELETE,MAX_SQLTABLES)],result);
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 := AuthAdminGroupDefaultTimeout;
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 := AuthSupervisorGroupDefaultTimeout;
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 := AuthUserGroupDefaultTimeout;
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 := AuthGuestGroupDefaultTimeout;
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
Ctxt.fSession := nil; // avoid GPF
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
SessionCreateReturns(Ctxt,Session,Session.fPrivateSalt,'','');
finally
User.Free;
end;
end;
procedure TSQLRestServerAuthentication.SessionCreateReturns(
Ctxt: TSQLRestServerURIContext; Session: TAuthSession; const result, data, header: RawUTF8);
var body: TDocVariantData;
begin
body.InitFast(10,dvObject);
if result='' then
body.AddValue('result',Session.IDCardinal) else
body.AddValue('result',RawUTF8ToVariant(result));
if data<>'' then
body.AddValue('data',RawUTF8ToVariant(data));
if fAlgoName<>'' then // match e.g. TSQLRestServerAuthenticationSignedURIAlgo
body.AddValue('algo',RawUTF8ToVariant(fAlgoName));
with Session.User do
body.AddNameValuesToObject(['logonid',IDValue,'logonname',LogonName,
'logondisplay',DisplayName,'logongroup',GroupRights.IDValue,
'timeout',GroupRights.SessionTimeout,
'server',ExeVersion.ProgramName,'version',ExeVersion.Version.DetailedOrVoid]);
Ctxt.ReturnsJson(variant(body),HTTP_SUCCESS,false,twJSONEscape,false,header);
end;
class function TSQLRestServerAuthentication.ClientGetSessionKey(
Sender: TSQLRestClientURI; User: TSQLAuthUser; const aNameValueParameters: array of const): RawUTF8;
var resp: RawUTF8;
values: array[0..9] of TValuePUTF8Char;
a: integer;
algo: TSQLRestServerAuthenticationSignedURIAlgo absolute a;
begin
if (Sender.CallBackGet('Auth',aNameValueParameters,resp)<>HTTP_SUCCESS) or
(JSONDecode(pointer(resp),['result','data','server','version','logonid',
'logonname','logondisplay','logongroup','timeout','algo'],@values)=nil) then begin
Sender.fSessionData := ''; // reset temporary 'data' field
result := '';
end else begin
values[0].ToUTF8(result);
Base64ToBin(PAnsiChar(values[1].Value),values[1].ValueLen,Sender.fSessionData);
values[2].ToUTF8(Sender.fSessionServer);
values[3].ToUTF8(Sender.fSessionVersion);
SetID(values[4].Value,User.fID);
values[5].ToUTF8(User.fLogonName); // set/fix using values from server
values[6].ToUTF8(User.fDisplayName);
User.GroupRights := pointer(values[7].ToInteger);
Sender.fSessionServerTimeout := values[8].ToInteger;
if Sender.fSessionServerTimeout<=0 then
Sender.fSessionServerTimeout := 60; // default 1 hour if not suppplied
a := GetEnumNameValueTrimmed(TypeInfo(TSQLRestServerAuthenticationSignedURIAlgo),
values[9].Value,values[9].ValueLen);
if a>=0 then
Sender.fComputeSignature := TSQLRestServerAuthenticationSignedURI.GetComputeSignature(algo);
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; // ensure Sender.SessionUser=nil
U := TSQLAuthUser(Sender.Model.GetTableInherited(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 PosExChar('?',Call.url)=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);
fComputeSignature := TSQLRestServerAuthenticationSignedURI.ComputeSignatureCrc32;
TimestampCoherencySeconds := 5;
end;
procedure TSQLRestServerAuthenticationSignedURI.SetNoTimestampCoherencyCheck(
value: boolean);
begin
if self<>nil then
fNoTimestampCoherencyCheck := value;
end;
procedure TSQLRestServerAuthenticationSignedURI.SetTimestampCoherencySeconds(
value: cardinal);
begin
if self=nil then
exit;
fTimestampCoherencySeconds := value;
fTimestampCoherencyTicks := round(value*(1000/256)); // 256 ms resolution
end;
procedure TSQLRestServerAuthenticationSignedURI.SetAlgorithm(
value: TSQLRestServerAuthenticationSignedURIAlgo);
begin
fComputeSignature := GetComputeSignature(value);
if value=suaCRC32 then
fAlgoName := '' else
fAlgoName := SynCommons.LowerCase(TrimLeftLowerCaseShort(ToText(value)));
end;
class function TSQLRestServerAuthenticationSignedURI.GetComputeSignature(
algo: TSQLRestServerAuthenticationSignedURIAlgo): TSQLRestServerAuthenticationSignedURIComputeSignature;
begin // FPC doesn't allow to use constants for procedure of object
case algo of
suaCRC32C: result := ComputeSignatureCrc32c;
suaXXHASH: result := ComputeSignaturexxHash;
suaMD5: result := ComputeSignatureMD5;
suaSHA1: result := ComputeSignatureSHA1;
suaSHA256: result := ComputeSignatureSHA256;
suaSHA512: result := ComputeSignatureSHA512;
else result := ComputeSignatureCrc32; // default/fallback
end;
end;
class function TSQLRestServerAuthenticationSignedURI.ComputeSignatureCrc32(
privatesalt: cardinal; timestamp, url: PAnsiChar; urllen: integer): cardinal;
begin // historical algorithm
result := crc32(crc32(privatesalt,timestamp,8),url,urllen);
end;
class function TSQLRestServerAuthenticationSignedURI.ComputeSignatureCrc32c(
privatesalt: cardinal; timestamp, url: PAnsiChar; urllen: integer): cardinal;
begin // faster on SSE4.2 CPU, and slightly more secure if not cascaded
result := crc32c(privatesalt,timestamp,8) xor crc32c(privatesalt,url,urllen);
end;
class function TSQLRestServerAuthenticationSignedURI.ComputeSignaturexxHash(
privatesalt: cardinal; timestamp, url: PAnsiChar; urllen: integer): cardinal;
begin // xxHash32 has no immediate reverse function
result := xxHash32(privatesalt,timestamp,8) xor xxHash32(privatesalt,url,urllen);
end;
class function TSQLRestServerAuthenticationSignedURI.ComputeSignatureMD5(
privatesalt: cardinal; timestamp, url: PAnsiChar; urllen: integer): cardinal;
var digest: THash128Rec;
MD5: TMD5;
i: integer;
begin
MD5.Init;
MD5.Update(privatesalt,4);
MD5.Update(timestamp^,8);
MD5.Update(url^,urllen);
MD5.Final(digest.b);
result := digest.c[0];
for i := 1 to high(digest.c) do
result := result xor digest.c[i];
end;
class function TSQLRestServerAuthenticationSignedURI.ComputeSignatureSHA1(
privatesalt: cardinal; timestamp, url: PAnsiChar; urllen: integer): cardinal;
var digest: array[0..(SizeOf(TSHA1Digest)div 4)-1] of cardinal;
SHA1: TSHA1;
i: integer;
begin
SHA1.Init;
SHA1.Update(@privatesalt,4);
SHA1.Update(timestamp,8);
SHA1.Update(url,urllen);
SHA1.Final(TSHA1Digest(digest));
result := digest[0];
for i := 1 to high(digest) do
result := result xor digest[i];
end;
class function TSQLRestServerAuthenticationSignedURI.ComputeSignatureSHA256(
privatesalt: cardinal; timestamp, url: PAnsiChar; urllen: integer): cardinal;
var digest: THash256Rec;
SHA256: TSHA256;
i: integer;
begin
SHA256.Init;
SHA256.Update(@privatesalt,4);
SHA256.Update(timestamp,8);
SHA256.Update(url,urllen);
SHA256.Final(digest.b);
result := digest.c[0];
for i := 1 to high(digest.c) do
result := result xor digest.c[i];
end;
class function TSQLRestServerAuthenticationSignedURI.ComputeSignatureSHA512(
privatesalt: cardinal; timestamp, url: PAnsiChar; urllen: integer): cardinal;
var digest: THash512Rec;
SHA512: TSHA512;
i: integer;
begin
SHA512.Init;
SHA512.Update(@privatesalt,4);
SHA512.Update(timestamp,8);
SHA512.Update(url,urllen);
SHA512.Final(digest.b);
result := digest.c[0];
for i := 1 to high(digest.c) do
result := result xor digest.c[i];
end;
function TSQLRestServerAuthenticationSignedURI.RetrieveSession(
Ctxt: TSQLRestServerURIContext): TAuthSession;
var aTimestamp, aSignature, aMinimalTimestamp, 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)
aMinimalTimestamp := result.fLastTimestamp-fTimestampCoherencyTicks;
if HexDisplayToCardinal(PTimestamp,aTimestamp) and
(fNoTimestampCoherencyCheck or (integer(aMinimalTimestamp)<0) or // <0 just after login
(aTimestamp>=aMinimalTimestamp)) then begin
aExpectedSignature := fComputeSignature(result.fPrivateSaltHash,PTimestamp,
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 %',
[aMinimalTimestamp,Int64(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 PosExChar('?',Call.url)=0 then
Call.url := Call.Url+'?session_signature=' else
Call.url := Call.Url+'&session_signature=';
with Sender do begin
fSessionLastTick64 := GetTickCount64;
nonce := CardinalToHexLower(fSessionLastTick64 shr 8); // 256 ms resolution
Call.url := Call.url+fSessionIDHexa8+nonce+CardinalToHexLower(
Sender.fComputeSignature(fSessionPrivateKey,Pointer(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([CurrentServerNonce]) 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 := IsHex(aPassword,SizeOf(THash256)) and
(IdemPropNameU(aPassWord,SHA256(fServer.Model.Root+CurrentServerNonce(false)+aSalt)) or
// if current nonce failed, tries with previous 5 minutes' nonce
IdemPropNameU(aPassWord,SHA256(fServer.Model.Root+CurrentServerNonce(true)+aSalt)));
end;
class function TSQLRestServerAuthenticationDefault.ClientComputeSessionKey(
Sender: TSQLRestClientURI; User: TSQLAuthUser): RawUTF8;
var aServerNonce, aClientNonce: RawUTF8;
rnd: THash256;
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 := BinToHexLower(@rnd,SizeOf(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; // ensure Sender.SessionUser=nil
try // inherited ClientSetUser() won't fit with Auth() method below
ClientSetUserHttpOnly(Sender,aUserName,aPassword);
Sender.fSessionAuthentication := self; // to enable ClientSessionSign()
U := TSQLAuthUser(Sender.Model.GetTableInherited(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 (result.fExpectedHttpAuthentication<>'') and
(result.fExpectedHttpAuthentication=Ctxt.InHeader['Authorization']) then
exit; // already previously authenticated for this session
if GetUserPassFromInHead(Ctxt,userPass,user,pass) then
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;
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 := IdemPropNameU(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+'=')+CardinalToHexLower(Session.IDCardinal));
if (rsoRedirectForbiddenToAuth in fServer.Options) and (Ctxt.ClientKind=ckAjax) then
Ctxt.Redirect(fServer.Model.Root) else
SessionCreateReturns(Ctxt,Session,'','','');
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('',HTTP_UNAUTHORIZED); // 401 will popup for credentials in browser
end;
end;
{$ifdef DOMAINAUTH}
{ 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: PtrInt;
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
FindNameValue(Ctxt.Call.InHead,SECPKGNAMEHTTPAUTHORIZATION,InDataEnc);
if InDataEnc = '' then begin
// no auth data sent, reply with supported auth methods
Ctxt.Call.OutHead := SECPKGNAMEHTTPWWWAUTHENTICATE;
Ctxt.Call.OutStatus := HTTP_UNAUTHORIZED; // (401)
StatusCodeToErrorMessage(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 := HTTP_UNAUTHORIZED; // (401)
StatusCodeToErrorMessage(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
SessionCreateReturns(Ctxt,Session,Session.fPrivateSalt,'',
(SECPKGNAMEHTTPWWWAUTHENTICATE+' ')+BinToBase64(OutData)) else
SessionCreateReturns(Ctxt,Session,
BinToBase64(SecEncrypt(fSSPIAuthContexts[SecCtxIdx],Session.fPrivateSalt)),
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;
WithPassword: Boolean;
OutData: RawByteString;
begin
result := '';
InvalidateSecContext(SecCtx,0);
WithPassword := User.LogonName<>'';
Sender.fSessionData := '';
try
repeat
if WithPassword 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 begin
OutData := Base64ToBin(result);
result := SecDecrypt(SecCtx,{$ifdef MSWINDOWS}TSSPIBuffer{$endif}(OutData));
end;
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: PtrInt;
begin
for i := 0 to High(fSSPIAuthContexts) do
FreeSecContext(fSSPIAuthContexts[i]);
inherited;
end;
{$endif DOMAINAUTH}
{ 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 := fServicesFactoryClients.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 := fServicesFactoryClients.Create(Rest,aInterface,aInstanceCreation,aContractExpected);
AddServiceInternal(result);
end;
function TServiceContainer.Count: integer;
begin
if self=nil then
result := 0 else
result := length(fInterface);
end;
constructor TServiceContainer.Create(aRest: TSQLRest);
begin
fRest := aRest;
fInterfaces.InitSpecific(TypeInfo(TServiceContainerInterfaces),
fInterface,djRawUTF8,nil,{caseinsensitive=}true);
fInterfaceMethods.InitSpecific(TypeInfo(TServiceContainerInterfaceMethods),
fInterfaceMethod,djRawUTF8,nil,{caseinsensitive=}true);
fServicesFactoryClients := TServiceFactoryClient;
end;
destructor TServiceContainer.Destroy;
var i: PtrInt;
begin
for i := 0 to high(fInterface) do
fInterface[i].Service.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);
var p: PServiceContainerInterfaceMethod;
begin
p := fInterfaceMethods.AddUniqueName(aInterfaceDotMethodName);
p^.InterfaceService := aService;
p^.InterfaceMethodIndex := MethodIndex;
inc(MethodIndex);
end;
var aURI: RawUTF8;
internal: TServiceInternalMethod;
m: integer;
begin
if (self=nil) or (aService=nil) then
result := 0 else
// add service factory
if ExpectMangledURI then
aURI := aService.fInterfaceMangledURI else
aURI := aService.fInterfaceURI;
PServiceContainerInterface(fInterfaces.AddUniqueName(aURI,@result))^.Service := 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 aService.fInterface.fMethodsCount-1 do
AddOne(aURI+aService.fInterface.fMethods[m].URI);
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 i: Integer;
toregisteragain: TServiceContainerInterfaces;
begin
if aValue=fExpectMangledURI then
exit;
fExpectMangledURI := aValue;
toregisteragain := fInterface; // same services, but other URIs
fInterface := nil;
fInterfaces.InitSpecific(TypeInfo(TServiceContainerInterfaces),
fInterface,djRawUTF8,nil,{caseinsensitive=}not aValue);
fInterfaceMethod := nil;
fInterfaceMethods.InitSpecific(TypeInfo(TServiceContainerInterfaceMethods),
fInterfaceMethod,djRawUTF8,nil,not aValue);
for i := 0 to high(toregisteragain) do
AddServiceInternal(toregisteragain[i].Service);
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(fInterfaceMethod);
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 fInterfaceMethod[i].InterfaceMethodIndex<SERVICE_PSEUDO_METHOD_COUNT then
include(bits,i);
while MethodNamesCSV<>nil do begin
GetNextItem(MethodNamesCSV,',',method);
if PosExChar('.',method)=0 then begin
for i := 0 to n-1 do
with fInterfaceMethod[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 := fInterfaceMethods.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(fInterfaceMethod)) then
result := '' else
with fInterfaceMethod[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 := fInterfaces.FindHashed(aURI);
if i>=0 then
result := fInterface[i].Service else
result := nil;
end else
result := nil;
end;
function TServiceContainer.Info(aTypeInfo: PTypeInfo): TServiceFactory;
var i: PtrInt;
p: PServiceContainerInterface;
begin
if self<>nil then begin
p := pointer(fInterface);
for i := 1 to length(fInterface) do begin
result := p^.Service;
if result.fInterface.fInterfaceTypeInfo=aTypeInfo then
exit else
inc(p);
end;
end;
result := nil;
end;
function TServiceContainer.Info(const aGUID: TGUID): TServiceFactory;
var i: PtrInt;
p: PServiceContainerInterface;
begin
if self<>nil then begin
p := pointer(fInterface);
for i := 1 to length(fInterface) do begin
result := p^.Service;
if IsEqualGUID(@result.fInterface.fInterfaceIID,@aGUID) then
exit else
inc(p);
end;
end;
result := nil;
end;
procedure TServiceContainer.SetGUIDs(out Services: TGUIDDynArray);
var i,n: PtrInt;
begin
if self=nil then
exit;
n := length(fInterface);
SetLength(Services,n);
for i := 0 to n-1 do
Services[i] := fInterface[i].Service.fInterface.fInterfaceIID;
end;
procedure TServiceContainer.SetInterfaceNames(out Names: TRawUTF8DynArray);
var i,n: PtrInt;
begin
if self=nil then
exit;
n := length(fInterface);
SetLength(Names,n);
for i := 0 to n-1 do
Names[i] := fInterface[i].Service.fInterface.fInterfaceURI;
end;
function TServiceContainer.AsJson: RawJSON;
var WR: TTextWriter;
i: PtrInt;
temp: TTextWriterStackBuffer;
begin
result := '';
if (self=nil) or (fInterface=nil) then
exit;
WR := TJSONSerializer.CreateOwnedStream(temp);
try
WR.Add('[');
for i := 0 to high(fInterface) do begin
WR.AddString(fInterface[i].Service.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) or (cardinal(aIndex)>cardinal(high(fInterface))) then
result := nil else
result := fInterface[aIndex].Service;
end;
function TServiceContainer.CallBackUnRegister(const Callback: IInvokable): boolean;
begin
result := false; // nothing to be done here
end;
{ TInterfacedObjectFake }
const
// 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 = REGX1;
// 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
ARGS_TO_VAR: array[TServiceMethodValueType] of TServiceMethodValueVar = (
smvvNone, smvvSelf, smvv64, smvv64, smvv64, smvv64, smvv64, smvv64, smvv64,
smvv64, smvv64,
smvvRawUTF8, smvvString, smvvRawUTF8, smvvWideString, smvv64, smvvRecord,
{$ifndef NOVARIANTS}smvvRecord,{$endif} smvvObject, smvvRawUTF8,
smvvDynArray, smvvInterface);
{$ifdef CPU32}
// always aligned to 8 bytes boundaries for 64-bit
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, 0, PTRSIZ,
// Currency, RawUTF8, String, RawByteString, WideString, Binary, Record,
{$ifndef NOVARIANTS}PTRSIZ,{$endif} // Variant
PTRSIZ, PTRSIZ, PTRSIZ, PTRSIZ);
// Object, RawJSON, DynArray, Interface
{$endif}
ARGS_RESULT_BY_REF: TServiceMethodValueTypes = [
smvRawUTF8, smvRawJSON, smvString, smvRawByteString, smvWideString, smvRecord,
{$ifndef NOVARIANTS}smvVariant,{$endif} smvDynArray];
PSEUDO_RESULT_NAME: string[6] = 'Result';
PSEUDO_SELF_NAME: string[4] = 'Self';
INTEGER_NAME: string[7] = 'Integer';
CARDINAL_NAME: string[8] = 'Cardinal';
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 will expect
DummyStack: packed array[0..9] of pointer;
{$endif}
{$ifdef CPUAARCH64}
// alf: on AARCH64, there is more on the stack than you will 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;
fServiceFactory: TServiceFactory;
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 HASINLINE}inline;{$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; aServiceFactory: TServiceFactory;
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; aServiceFactory: TServiceFactory;
aOptions: TInterfacedObjectFromFactoryOptions; aInvoke: TOnFakeInstanceInvoke;
aNotifyDestroy: TOnFakeInstanceDestroy);
begin
inherited Create(aFactory,aOptions,aInvoke,aNotifyDestroy);
fVTable := aFactory.GetMethodsVirtualTable;
fServiceFactory := aServiceFactory;
end;
function TInterfacedObjectFake.SelfFromInterface: TInterfacedObjectFake;
{$ifdef HASINLINE}
begin
result := pointer(PtrUInt(self)-PtrUInt(@TInterfacedObjectFake(nil).fVTable));
end;
{$else}
asm
sub eax,TInterfacedObjectFake.fVTable
end;
{$endif HASINLINE}
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); {$ifdef HASINLINE}inline;{$endif}
begin
if P<>nil then begin
while (P^<=' ') and (P^<>#0) do inc(P);
if P^=',' then inc(P);
end;
end;
function TInterfacedObjectFake.FakeCall(var aCall: TFakeCallStack): Int64;
var method: PServiceMethod;
resultType: TServiceMethodValueType; // type of value stored into result
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;
procedure InternalProcess;
var Params: TJSONSerializer;
Error, ResArray, ParamsJSON: RawUTF8;
arg, ValLen: integer;
V: PPointer;
R, Val: PUTF8Char;
resultAsJSONObject: boolean;
opt: TTextWriterWriteObjectOptions;
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;
temp: TTextWriterStackBuffer;
begin
Params := TJSONSerializer.CreateOwnedStream(temp);
try
// create the parameters
if ifoJsonAsExtended in fOptions then
include(Params.fCustomOptions,twoForceJSONExtended) else
include(Params.fCustomOptions,twoForceJSONStandard); // e.g. for AJAX
if ifoDontStoreVoidJSON in fOptions then begin
opt := DEFAULT_WRITEOPTIONS[true];
include(Params.fCustomOptions,twoIgnoreDefaultInRecord);
end else
opt := DEFAULT_WRITEOPTIONS[false];
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 := @aCall.FPRegs[FPREG_FIRST+FPRegisterIdent-1]
else
if RegisterIdent>0 then
V := @aCall.ParamRegs[PARAMREG_FIRST+RegisterIdent-1]
else
{$endif}
V := nil;
if RegisterIdent=PARAMREG_FIRST then
RaiseError('unexpected self',[]);
{$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)^;
if ValueType=smvDynArray then
DynArrays[IndexVar].InitFrom(DynArrayWrapper,V^);
Value[arg] := V;
if ValueDirection in [smdConst,smdVar] then
case ValueType of
smvInterface:
InterfaceWrite(Params,method^,method^.Args[arg],V^);
smvDynArray: begin
if vIsObjArray in ValueKindAsm then
Params.AddObjArrayJSON(V^,opt) else
Params.AddDynArrayJSON(DynArrays[IndexVar]);
Params.Add(',');
end;
else AddJSON(Params,V,opt);
end;
end;
Params.CancelLastComma;
Params.SetText(ParamsJSON); // without [ ]
finally
Params.Free;
end;
// 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]);
// 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,@ValLen);
if Val=nil then
break; // end of JSON object
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];
FromJSON(method^.InterfaceDotMethodName,R,V,nil
{$ifndef NOVARIANTS},fFactory.DocVariantOptions{$endif});
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;
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] := unaligned(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) and
(fClient.fClient.fSessionUser<>nil) then
opt := [ifoJsonAsExtended,ifoDontStoreVoidJSON] else
opt := [];
inherited Create(aClient.fInterface,aClient,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]);
inherited Destroy;
end;
constructor TInterfacedObjectFakeServer.Create(aRequest: TSQLRestServerURIContext;
aFactory: TInterfaceFactory; aFakeID: Integer);
var opt: TInterfacedObjectFromFactoryOptions;
begin
if aRequest.ClientKind=ckFramework then
opt := [ifoJsonAsExtended,ifoDontStoreVoidJSON] else
opt := [];
fServer := aRequest.Server;
fService := aRequest.Service;
fLowLevelConnectionID := aRequest.Call^.LowLevelConnectionID;
fClientDrivenID := aFakeID;
inherited Create(aFactory,nil,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]);
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 support callbacks for I%',
[fServer,fServer.Model.Root,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
FormatUTF8('%.CallbackInvoke(I%): instance has been released on client side',
[self,aMethod.InterfaceDotMethodName],aErrorMsg^);
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 parser: PJSONCustomParser;
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)) or (P=TypeInfo(TDateTimeMS)) then
result := smvDateTime else
case P^.FloatType of
ftCurr: result := smvCurrency;
ftDoub: result := smvDouble;
end;
{$ifdef FPC}tkLStringOld,{$endif} tkLString:
if P=TypeInfo(RawJSON) then
result := smvRawJSON else
if (P=TypeInfo(RawByteString)) or (P=TypeInfo(TSQLRawBlob)) 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 // = oPersistent or oCustomPropName
(JSONObjectFromClass(ClassType,parser) in // serialized w/o RTTI ?
[{$ifndef LVCL}oCollection,{$endif}oObjectList,oUtfs,oStrings,
oException,oCustomReaderWriter]) then
result := smvObject; // JSONToObject/ObjectToJSON types
{$ifdef FPC}tkObject,{$endif} tkRecord:
// JSON or 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: TSynObjectListLocked;
procedure EnterInterfaceFactoryCache;
begin
if InterfaceFactoryCache=nil then
GarbageCollectorFreeAndNil(InterfaceFactoryCache,TSynObjectListLocked.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 := pointer(InterfaceFactoryCache.List);
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{$ifdef CPU32},c,d{$endif}: PtrInt; end;
PGUID32 = ^TGUID32; // brute force search optimization
var i,ga: PtrInt;
F: ^TInterfaceFactory;
GUID32: TGUID32 absolute aGUID;
begin
if InterfaceFactoryCache<>nil then begin
InterfaceFactoryCache.Safe.Lock;
F := pointer(InterfaceFactoryCache.List);
ga := GUID32.a;
for i := 1 to InterfaceFactoryCache.Count do
with PGUID32(@F^.fInterfaceIID)^ do
if (a=ga) and (b=GUID32.b) {$ifdef CPU32}and (c=GUID32.c) and (d=GUID32.d){$endif} then begin
result := F^;
InterfaceFactoryCache.Safe.UnLock;
exit;
end else
inc(F);
InterfaceFactoryCache.Safe.UnLock;
end;
result := nil;
end;
function ToText({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF}
aGUID: TGUID): TGUIDShortString;
var fact: TInterfaceFactory;
begin
fact := TInterfaceFactory.Get(aGUID);
if fact=nil then
GUIDToShort(aGUID,result) else
result := fact.fInterfaceTypeInfo^.Name;
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
result := nil;
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;
F: ^TInterfaceFactory;
begin
result := nil;
L := length(aInterfaceName);
if (InterfaceFactoryCache<>nil) and (L<>0) then begin
InterfaceFactoryCache.Safe.Lock;
try
F := pointer(InterfaceFactoryCache.List);
for i := 1 to InterfaceFactoryCache.Count do
if IdemPropName(F^.fInterfaceTypeInfo^.Name,pointer(aInterfaceName),L) then begin
result := F^;
exit; // retrieved from cache
end else
inc(F);
finally
InterfaceFactoryCache.Safe.UnLock;
end;
end;
end;
class function TInterfaceFactory.GetUsedInterfaces: TSynObjectListLocked;
begin
result := InterfaceFactoryCache;
end;
var
GlobalUnsafeSPIType: array of PTypeInfo;
class procedure TInterfaceFactory.RegisterUnsafeSPIType(const Types: array of pointer);
var a: integer;
begin
for a := 0 to high(Types) do
if Types[a]<>nil then
PtrArrayAddOnce(GlobalUnsafeSPIType,Types[a])
end;
constructor TInterfaceFactory.Create(aInterface: PTypeInfo);
var m,a,reg: integer;
WR: TTextWriter;
C: TClass;
ErrorMsg: RawUTF8;
dummy: pointer;
{$ifdef HAS_FPREG}
ValueIsInFPR: boolean;
{$endif HAS_FPREG}
{$ifdef CPUX86}
offs: integer;
{$else}
{$ifdef Linux} // not used for Win64
fpreg: integer;
{$endif Linux}
{$endif CPUX86}
procedure RaiseError(const Args: array of const);
begin
raise EInterfaceFactoryException.CreateUTF8(
'%.Create: %.% [%] parameter has unexpected type %%',Args);
end;
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 NOVARIANTS}
fInterfaceTypeInfo := aInterface;
fInterfaceIID := aInterface^.InterfaceGUID^;
if IsNullGUID(fInterfaceIID) then
raise EInterfaceFactoryException.CreateUTF8(
'%.Create: % has no GUID',[self,aInterface^.Name]);
fInterfaceName := ToUTF8(fInterfaceTypeInfo^.Name);
fInterfaceURI := fInterfaceName;
if fInterfaceURI[1] in ['i','I'] then
delete(fInterfaceURI,1,1); // as in TServiceFactory.Create
// 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 - should inherit from IInvokable',[self,fInterfaceName]);
if fMethodsCount>MAX_METHOD_COUNT then
raise EInterfaceFactoryException.CreateUTF8(
'%.Create(%): interface has too many methods (%), so breaks the '+
'Interface Segregation Principle',[self,fInterfaceName,fMethodsCount]);
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 := fInterfaceURI+'.'+URI;
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;
RaiseError([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';
RaiseError([self,aInterface^.Name,URI,ParamName^,ArgTypeInfo^.Name,ErrorMsg]);
end;
smvInterface:
if ValueDirection in [smdVar,smdOut,smdResult] then begin
ErrorMsg := ' - interface not allowed as output: use a const parameter';
RaiseError([self,aInterface^.Name,URI,ParamName^,ArgTypeInfo^.Name,ErrorMsg]);
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;
if PtrArrayFind(GlobalUnsafeSPIType,ArgTypeInfo)>=0 then begin
include(ValueKindAsm,vIsSPI);
include(HasSPIParams,ValueDirection);
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;
if ArgsResultIndex>=0 then
with Args[ArgsResultIndex] do
case ValueType of
smvNone, smvObject, smvInterface:
raise EInterfaceFactoryException.CreateUTF8('%.Create: I% unexpected result type %',
[self,InterfaceDotMethodName,ArgTypeName^]);
smvRecord:
if ArgTypeInfo=System.TypeInfo(TServiceCustomAnswer) then begin
for a := ArgsOutFirst to ArgsOutLast do
if Args[a].ValueDirection in [smdVar,smdOut] then
raise EInterfaceFactoryException.CreateUTF8('%.Create: I% '+
'var/out parameter [%] not allowed with TServiceCustomAnswer result',
[self,InterfaceDotMethodName,Args[a].ParamName^]);
ArgsResultIsServiceCustomAnswer := true;
end;
end;
if (ArgsInputValuesCount=1) and (Args[1].ValueType=smvRawByteString) then
ArgsInputIsOctetStream := true;
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 HAS_FPREG}
ValueVar := ARGS_TO_VAR[ValueType];
IndexVar := ArgsUsedCount[ValueVar];
inc(ArgsUsedCount[ValueVar]);
include(ArgsUsed,ValueType);
if (ValueType in [smvRecord{$ifndef NOVARIANTS},smvVariant{$endif}]) or
(ValueDirection in [smdVar,smdOut]) or
((ValueDirection=smdResult) and (ValueType in ARGS_RESULT_BY_REF)) then
Include(ValueKindAsm,vPassedByReference);
case ValueType of
smvInteger, smvCardinal, smvInt64:
if TJSONCustomParserRTTI.TypeNameToSimpleBinary(
ShortStringToUTF8(ArgTypeName^),SizeInBinary,SizeInStorage) then begin
ValueType := smvBinary; // transmitted as hexa string
Include(ValueKindAsm,vIsString);
end else if ArgTypeInfo^.IsQWord then
Include(ValueKindAsm,vIsQword);
smvDouble,smvDateTime: begin
{$ifdef HAS_FPREG}
ValueIsInFPR := not (vPassedByReference in ValueKindAsm);
{$endif HAS_FPREG}
if ValueType=smvDateTime then begin
include(ValueKindAsm,vIsString);
if ArgTypeInfo=System.TypeInfo(TDateTimeMS) then
include(ValueKindAsm,vIsDateTimeMS);
end;
end;
smvRawUTF8..smvWideString:
Include(ValueKindAsm,vIsString);
smvDynArray: begin
if ObjArraySerializers.Find(ArgTypeInfo)<>nil then
Include(ValueKindAsm,vIsObjArray) else
if (ArgTypeInfo^.DynArraySQLFieldType in STRING_FIELDS) or
DynArrayItemTypeIsSimpleBinary(ShortStringToUTF8(ArgTypeName^)) then
Include(ValueKindAsm,vIsDynArrayString);
DynArrayWrapper.Init(ArgTypeInfo,dummy);
DynArrayWrapper.IsObjArray := vIsObjArray in ValueKindAsm;
DynArrayWrapper.HasCustomJSONParser; // set DynArrayWrapper.fParser
end;
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 invalid SizeInStorage=% in %.% method % parameter',
[self,ArgTypeName^,SizeInStorage,fInterfaceTypeInfo^.Name,URI,ParamName^]);
end;
smvBinary: ; // already set SizeInStorage
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 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 will add an additional by-ref parameter
end;
{$ifdef CPU32}
if ValueDirection=smdConst then
if ValueType=smvBinary then
SizeInStack := SizeInBinary else
SizeInStack := ARGS_IN_STACK_SIZE[ValueType] else
{$endif CPU32}
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: XMMs overlap regular registers
{$endif Linux}
{$endif CPUX86}
{$ifdef FPC}or ((ValueType in [smvRecord]) and
// trunk i386/x86_64\cpupara.pas: DynArray const is passed as register
not (vPassedByReference in ValueKindAsm)){$endif} then begin
// this parameter will go on the stack
InStackOffset := ArgsSizeInStack;
inc(ArgsSizeInStack,SizeInStack);
end else begin
// this parameter will go in a register
InStackOffset := STACKOFFSET_NONE;
{$ifndef CPUX86}
if (ArgsResultIndex>=0) and (reg=PARAMREG_RESULT) and
(Args[ArgsResultIndex].ValueType in ARGS_RESULT_BY_REF) then begin
inc(reg); // this register is reserved for method result pointer
end;
{$endif CPUX86}
{$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 HAS_FPREG} 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);
{.$define SOA_DEBUG} // write the low-level interface info as json
{$ifdef SOA_DEBUG}
JSONReformatToFile(fContract,TFileName(fInterfaceName+
'-'+COMP_TEXT+OS_TEXT+CPU_ARCH_TEXT+'.json'));
{$endif SOA_DEBUG}
finally
WR.Free;
end;
end;
function TInterfaceFactory.FindMethodIndex(const aMethodName: RawUTF8): integer;
begin
if (self=nil) or (aMethodName='') then
result := -1 else begin
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;
end;
function TInterfaceFactory.FindMethod(const aMethodName: RawUTF8): PServiceMethod;
var i: integer;
begin
i := FindMethodIndex(aMethodName);
if i < 0 then
result := nil else
result := @fMethods[i];
end;
function TInterfaceFactory.FindFullMethodIndex(const aFullMethodName: RawUTF8;
alsoSearchExactMethodName: boolean): integer;
begin
if PosExChar('.',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}
{$ifdef ASMORIG}
procedure TInterfacedObjectFake.ArmFakeStub;
var // warning: exact local variables order should match TFakeCallStack
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;
{$else}
procedure TInterfacedObjectFake.ArmFakeStub;nostackframe;assembler;
asm
// get method index
str r12,[r13, #-52]
// create stack space
mov r12,r13
stmfd r13!,{r11,r12,r14,r15}
sub r11,r12,#4
sub r13,r13,#128
// store registers
vstr d0,[r11, #-112]
vstr d1,[r11, #-104]
vstr d2,[r11, #-96]
vstr d3,[r11, #-88]
vstr d4,[r11, #-80]
vstr d5,[r11, #-72]
vstr d6,[r11, #-64]
vstr d7,[r11, #-56]
str r0,[r11, #-128]
str r1,[r11, #-124]
str r2,[r11, #-120]
str r3,[r11, #-116]
// set stack address
add r1,r13, #12
// branch to the FakeCall function
bl FakeCall
// store result
vstr d0,[r11, #-112]
ldmea r11,{r11,r13,r15}
end;
{$endif ASMORIG}
{$endif}
{$ifdef CPUAARCH64}
procedure TInterfacedObjectFake.AArch64FakeStub;
var // warning: exact local variables order should match TFakeCallStack
sx0, sx1, sx2, sx3, sx4, sx5, sx6, sx7: pointer;
sd0, sd1, sd2, sd3, sd4, sd5, sd6, sd7: double;
smetndx:pointer;
asm
// get method index from IP0 [x16/r16]
str x16,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}
procedure x64FakeStub;
var // warning: exact local variables order should match TFakeCallStack
smetndx,
{$ifdef Linux}
sxmm7, sxmm6, sxmm5, sxmm4,
{$endif}
sxmm3, sxmm2, sxmm1, sxmm0: double;
{$ifdef Linux}
sr9, sr8, srcx, srdx, srsi, srdi: pointer;
{$endif}
asm // caller = 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
mov smetndx, rax
movlpd sxmm0, xmm0 // movlpd to ignore upper 64-bit of 128-bit xmm reg
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
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, qword ptr sxmm0 // movsd for zero extension
end;
{$endif CPUX64}
const
STUB_SIZE = 65536; // 16*4 KB (4 KB = memory granularity)
{$ifdef FPC} // alf: multi platforms support
{$ifndef MSWINDOWS}
var
StubCallAllocMemLastStart: PtrUInt; // avoid unneeded fpmmap() calls
function StubCallAllocMem(const Size, flProtect: DWORD): pointer;
{$ifdef CPUARM}
const
STUB_RELJMP = {$ifdef CPUARM}$7fffff{$else}$7fffffff{$endif}; // relative jmp
STUB_INTERV = STUB_RELJMP+1; // try to reserve in closed stub interval
STUB_ALIGN = QWord($ffffffffffff0000); // align to STUB_SIZE
var start,stop,stub,dist: PtrUInt;
begin
stub := PtrUInt(@TInterfacedObjectFake.ArmFakeStub);
if StubCallAllocMemLastStart<>0 then
start := StubCallAllocMemLastStart else begin
start := stub-STUB_INTERV;
if start>stub then
start := 0; // avoid range overflow
start := start and STUB_ALIGN;
end;
stop := stub+STUB_INTERV;
if stop<stub then
stop := high(PtrUInt);
stop := stop and STUB_ALIGN;
while start<stop do begin // try whole -STUB_INTERV..+STUB_INTERV range
inc(start,STUB_SIZE);
result := fpmmap(pointer(start),STUB_SIZE,flProtect,MAP_PRIVATE or MAP_ANONYMOUS,-1,0);
if result<>MAP_FAILED then begin // close enough for a 24/32-bit relative jump?
dist := abs(stub-PtrUInt(result));
if dist<STUB_RELJMP then begin
StubCallAllocMemLastStart := start;
exit;
end else
fpmunmap(result,STUB_SIZE);
end;
end;
result := MAP_FAILED; // error
end;
{$else} // other platforms (Intel+Arm64) use absolute call
begin
result := fpmmap(nil,STUB_SIZE,flProtect,MAP_PRIVATE OR MAP_ANONYMOUS,-1,0);
end;
{$endif CPUARM}
{$endif MSWINDOWS}
{$endif FPC}
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;
{$ifdef UNIX}
MemoryProtection: boolean = false;
{$endif UNIX}
constructor TFakeStubBuffer.Create;
begin
{$ifdef MSWINDOWS}
fStub := VirtualAlloc(nil,STUB_SIZE,MEM_COMMIT,PAGE_EXECUTE_READWRITE);
if fStub=nil then
{$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}
if not MemoryProtection then
fStub := StubCallAllocMem(STUB_SIZE,PROT_READ or PROT_WRITE or PROT_EXEC);
if (fStub=MAP_FAILED) or MemoryProtection then begin
// i.e. on OpenBSD, we can have w^x protection
fStub := StubCallAllocMem(STUB_SIZE,PROT_READ OR PROT_WRITE);
if fStub<>MAP_FAILED then
MemoryProtection := True;
end;
{$endif KYLIX3}
if fStub=MAP_FAILED then
{$endif MSWINDOWS}
raise EServiceException.CreateUTF8('%.Create: OS memory allocation failed',[self]);
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;
{$ifdef UNIX}
PageAlignedFakeStub: pointer;
{$endif UNIX}
{$ifdef CPUAARCH64}stub: PtrUInt;{$endif}
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*16{$endif}
{$ifdef CPUARM}fMethodsCount*12{$endif}
{$ifdef CPUAARCH64}($120 shr 2)+fMethodsCount*28{$endif};
fFakeStub := TFakeStubBuffer.Reserve(tmp);
P := pointer(fFakeStub);
{$ifdef CPUAARCH64}
PtrUInt(P) := PtrUInt(P)+$120;
{$endif};
{$ifdef UNIX}
if MemoryProtection then begin
// Disable execution permission of memory to be able to write into memory
PageAlignedFakeStub := Pointer((PtrUInt(P) DIV SystemInfo.dwPageSize) * SystemInfo.dwPageSize);
if SynMProtect(PageAlignedFakeStub , (SystemInfo.dwPageSize shl 1), PROT_READ or PROT_WRITE)<0 then
raise EServiceException.CreateUTF8('%.Create: SynMProtect write failure.',[self]);
end;
{$endif UNIX}
for i := 0 to fMethodsCount-1 do begin
fFakeVTable[i+RESERVED_VTABLE_SLOTS] := P;
{$ifdef CPUX64}
PWord(P)^ := $b848; inc(PWord(P)); // mov rax,offset x64FakeStub
PPtrUInt(P)^ := PtrUInt(@x64FakeStub); inc(PPtrUInt(P));
PByte(P)^ := $50; inc(PByte(P)); // push rax
P^ := $b866+(i shl 16); inc(P); // mov (r)ax,{MethodIndex}
PByte(P)^ := $c3; inc(PByte(P)); // ret
{$endif CPUX64}
{$ifdef CPUARM}
{$ifdef ASMORIG}
P^ := ($e3a040 shl 8)+i; inc(P); // mov r4 (v1),{MethodIndex} : store method index in register
{$else}
P^ := ($e3a0c0 shl 8)+i; inc(P); // mov r12 (ip),{MethodIndex} : store method index in register
{$endif}
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 r16 [IP0]
// $10 = r16 ... loop to $1F -> number shifted * $20
P^ := ($d280 shl 16)+(i shl 5)+$10; inc(P); // mov r16 ,{MethodIndex}
// we are using a register branch here
// fill register x10 with address
stub := PtrUInt(@TInterfacedObjectFake.AArch64FakeStub);
tmp := (stub shr 0) and $ffff;
P^ := ($d280 shl 16)+(tmp shl 5)+$0a; inc(P);
tmp := (stub shr 16) and $ffff;
P^ := ($f2a0 shl 16)+(tmp shl 5)+$0a; inc(P);
tmp := (stub shr 32) and $ffff;
P^ := ($f2c0 shl 16)+(tmp shl 5)+$0a; inc(P);
tmp := (stub 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
{$ifdef DARWIN}
P^ := $900000; // ret; nop
{$else}
P^ := fMethods[i].ArgsSizeInStack or $900000; // ret {StackSize}; nop
{$endif DARWIN}
inc(PByte(P),3);
{$endif CPUX86}
end;
{$ifdef UNIX}
if MemoryProtection then
// Enable execution permission of memory
if SynMProtect(PageAlignedFakeStub , (SystemInfo.dwPageSize shl 1), PROT_READ OR PROT_EXEC)<0 then
raise EServiceException.CreateUTF8('%.Create: SynMProtect exec failure.',[self]);
{$endif UNIX}
end;
finally
InterfaceFactoryCache.Safe.UnLock;
end;
end;
result := pointer(fFakeVTable);
end;
{$ifdef HASINTERFACERTTI} // see http://bugs.freepascal.org/view.php?id=26774
{ TInterfaceFactoryRTTI }
type
TMethodKind = (mkProcedure, mkFunction, mkConstructor, mkDestructor,
mkClassProcedure, mkClassFunction, mkClassConstructor, mkClassDestructor,
mkOperatorOverload{$ifndef FPC},{ Obsolete } mkSafeProcedure, mkSafeFunction{$endif});
{$ifndef FPC}
TIntfMethodEntryTail =
{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}packed{$endif} record
{$ifdef FPC_NEWRTTI}
ResultType: PPTypeInfo;
CC: TCallingConvention;
Kind: TMethodKind;
ParamCount: Word;
StackSize: SizeInt;
Name: PShortString;
{$else}
Kind: TMethodKind;
CC: TCallingConvention;
ParamCount: Byte;
{Params: array[0..ParamCount - 1] of TVmtMethodParam;}
{$endif FPC_NEWRTTI}
end;
{$endif FPC}
procedure TInterfaceFactoryRTTI.AddMethodsFromTypeInfo(aInterface: PTypeInfo);
const
{$ifdef FPC}
{$if defined(CPUI386) or defined(CPUI8086) or defined(CPUX86_64) or defined(CPUM68K)}
DEFCC = ccRegister;
{$else}
DEFCC = ccStdCall;
{$ifend}
{$else}
DEFCC = ccRegister;
{$endif FPC}
var P: Pointer;
{$ifdef FPC}
PI: PFPCInterfaceData; // low-level types redirected from SynFPCTypInfo
VMP: PFPCVmtMethodParam;
methtable: PFPCIntfMethodTable;
PME: PFPCIntfMethodEntry;
PW: PWord;
aResultType: PTypeInfo;
argsindex: word;
{$else}
PI: PInterfaceTypeData absolute P;
PB: PByte absolute P;
PS: PShortString absolute P;
PME: ^TIntfMethodEntryTail absolute P;
PF: ^TParamFlags absolute P;
PP: ^PPTypeInfo absolute P;
PW: PWord absolute P;
{$endif FPC}
Ancestor: PTypeInfo;
Kind: TMethodKind;
f: TParamFlags;
m: integer;
paramcounter: word;
sm: PServiceMethod;
n,na: 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 := GetTypeDataClean(aInterface^);
{$ifdef FPC}
PI := P;
if PI^.Parent<>nil then
Ancestor := Deref(pointer(PI^.Parent)) else
{$else}
if PI^.IntfParent<>nil then
Ancestor := Deref(PI^.IntfParent) else
{$endif FPC}
Ancestor := nil;
if Ancestor<>nil then begin
AddMethodsFromTypeInfo(Ancestor);
inc(fAddMethodsLevel);
end;
{$ifdef FPC}
if PI^.UnitName='System' then
exit;
methtable := PI^.MethodTable;
n := methtable^.Count;
PW := @methtable^.RttiCount;
if (PW^=$ffff) or (n=0) then
exit; // no RTTI or no method at this level of interface
{$else}
P := @PI^.IntfUnit[ord(PI^.IntfUnit[0])+1];
n := PW^;
inc(PW);
if (PW^=$ffff) or (n=0) then
exit; // no RTTI or no method at this level of interface
inc(PW);
{$endif FPC}
for m := 0 to n-1 do begin
// retrieve method name, and add to the methods list (with hashing)
{$ifdef FPC}
PME := methtable^.Method[m];
ShortStringToAnsi7String(PME^.Name,aURI);
{$else}
ShortStringToAnsi7String(PS^,aURI);
{$endif FPC}
sm := fMethod.AddUniqueName(aURI,'%.% method: duplicated name for %',
[fInterfaceTypeInfo^.Name,aURI,self]);
sm^.HierarchyLevel := fAddMethodsLevel;
{$ifndef FPC}
PS := @PS^[ord(PS^[0])+1]; // skip method name in Delphi
{$endif FPC}
Kind := TMethodKind(PME^.Kind);
if TCallingConvention(PME^.CC)<>DEFCC then
RaiseError('unhandled calling convention %',[SynCommons.GetEnumName(
TypeInfo(TCallingConvention),ord(PME^.CC))^]);
// retrieve method call arguments from RTTI
n := PME^.ParamCount;
{$ifndef FPC}
inc(PME); // PF now points to parameter flags for Delphi
{$endif FPC}
na := n;
if Kind=mkFunction then
inc(na); // function result is an additional output parameter
if na>MAX_METHOD_ARGS then
RaiseError('method has too many parameters: %>%',[na,MAX_METHOD_ARGS]);
SetLength(sm^.Args,na);
{$ifdef FPC}
aResultType := Deref(pointer(PME^.ResultType));
if aResultType<>nil then
with sm^.Args[n] do begin
ParamName := @PSEUDO_RESULT_NAME;
ValueDirection := smdResult;
ArgTypeInfo := aResultType;
if ArgTypeInfo=TypeInfo(Integer) then // under FPC integer->'longint'
ArgTypeName := @INTEGER_NAME else
ArgTypeName := @ArgTypeInfo^.Name;
end;
argsindex := 0;
{$endif FPC}
paramcounter := 0;
while paramcounter<n do
{$ifdef FPC} begin // FPC has its own RTTI layout
VMP := PME^.Param[paramcounter];
f := mORMot.TParamFlags(VMP^.Flags);
with sm^.Args[argsindex] do begin
if pfVar in f then
ValueDirection := smdVar else
if pfOut in f then
ValueDirection := smdOut;
sm^.ArgsNotResultLast := argsindex;
if ValueDirection<>smdConst then
sm^.ArgsOutNotResultLast := argsindex;
ArgTypeInfo := pointer(Deref(pointer(VMP^.ParamType)));
ArgTypeName := @ArgTypeInfo^.Name;
if paramcounter>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 pfSelf in f then
ParamName := @PSEUDO_SELF_NAME else
if pfResult in f then begin
if (paramcounter<>n-1) or (High(sm^.Args)<>paramcounter+1) then begin
// at least on ARM, function (result) is on paramcounter different position than on x86
// so, cleanup and re-use array for next param entry
FillCharFast(sm^.Args[argsindex],SizeOf(TServiceMethodArgument),0);
// needed for re-use due to following Inc(argsindex) ... see below
dec(argsindex);
end;
sm^.Args[n-1] := sm^.Args[n];
SetLength(sm^.Args,n);
end else
{ since https://svn.freepascal.org/cgi-bin/viewvc.cgi?view=revision&revision=39684
TVmtMethodParam.Name is a local stack copy -> direct NamePtr use }
ParamName := {$ifdef VER3_1}@VMP^.Name{$else}VMP^.NamePtr{$endif};
end;
inc(paramcounter);
inc(argsindex);
end;
{$else FPC} // Delphi code:
with sm^.Args[paramcounter] do begin
f := PF^;
inc(PF);
if pfVar in f then
ValueDirection := smdVar else
if pfOut in f then
ValueDirection := smdOut;
sm^.ArgsNotResultLast := paramcounter;
if ValueDirection<>smdConst then
sm^.ArgsOutNotResultLast := paramcounter;
ParamName := PS;
PS := @PS^[ord(PS^[0])+1];
SetFromRTTI(PB);
{$ifdef ISDELPHIXE}
inc(PB,PW^); // skip custom attributes
{$endif ISDELPHIXE}
if paramcounter>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;
inc(paramcounter);
end;
// add a pseudo argument after all arguments for functions
if Kind=mkFunction then
with sm^.Args[n] do begin
ParamName := @PSEUDO_RESULT_NAME;
ValueDirection := smdResult;
SetFromRTTI(PB);
end;
{$ifdef ISDELPHIXE}
inc(PB,PW^); // skip custom attributes
{$endif ISDELPHIXE}
{$endif FPC}
end; // go to next method
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 := @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/Cardinal)=TypeInfo(LongInt/LongWord)
if arg^.ArgTypeInfo=TypeInfo(Integer) then
arg^.ArgTypeName := @INTEGER_NAME else
if arg^.ArgTypeInfo=TypeInfo(Cardinal) then
arg^.ArgTypeName := @CARDINAL_NAME else
{$endif FPC}
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;
{ TInterfacedObjectFakeCallback }
type
TInterfacedObjectFakeCallback = class(TInterfacedObjectFake)
protected
fRest: TSQLRest;
fName: RawUTF8;
function FakeInvoke(const aMethod: TServiceMethod; const aParams: RawUTF8;
aResult, aErrorMsg: PRawUTF8; aClientDrivenID: PCardinal;
aServiceCustomAnswer: PServiceCustomAnswer): boolean; virtual;
end;
function TInterfacedObjectFakeCallback.FakeInvoke(const aMethod: TServiceMethod;
const aParams: RawUTF8; aResult, aErrorMsg: PRawUTF8;
aClientDrivenID: PCardinal; aServiceCustomAnswer: PServiceCustomAnswer): boolean;
begin
fRest.InternalLog('%.FakeInvoke %(%)',[ClassType,aMethod.InterfaceDotMethodName,aParams]);
if aMethod.ArgsOutputValuesCount>0 then begin
if aErrorMsg<>nil then
FormatUTF8('%.FakeInvoke [%]: % has out parameters',
[self,fName,aMethod.InterfaceDotMethodName], aErrorMsg^);
result := false;
end else
result := true;
end;
{ TInterfacedObjectAsynch }
type
TInterfacedObjectAsynch = class(TInterfacedObjectFakeCallback)
protected
fTimer: TSQLRestBackgroundTimer;
fDest: IInvokable;
fOnResult: TOnAsynchRedirectResult;
function FakeInvoke(const aMethod: TServiceMethod; const aParams: RawUTF8;
aResult, aErrorMsg: PRawUTF8; aClientDrivenID: PCardinal;
aServiceCustomAnswer: PServiceCustomAnswer): boolean; override;
public
constructor Create(aTimer: TSQLRestBackgroundTimer; aFactory: TInterfaceFactory;
const aDestinationInterface: IInvokable; out aCallbackInterface;
const aOnResult: TOnAsynchRedirectResult);
end;
TInterfacedObjectAsynchCall = packed record
Method: PServiceMethod;
Instance: pointer; // weak IInvokable reference
Params: RawUTF8;
OnOutputParamsCopy: RawUTF8;
OnOutput: TOnAsynchRedirectResult;
end;
constructor TInterfacedObjectAsynch.Create(aTimer: TSQLRestBackgroundTimer;
aFactory: TInterfaceFactory; const aDestinationInterface: IInvokable;
out aCallbackInterface; const aOnResult: TOnAsynchRedirectResult);
begin
fTimer := aTimer;
fRest := fTimer.fRest;
fName := fTimer.fThreadName;
fDest := aDestinationInterface;
fOnResult := aOnResult;
inherited Create(aFactory,nil,[ifoJsonAsExtended,ifoDontStoreVoidJSON],FakeInvoke,nil);
Get(aCallbackInterface);
end;
function TInterfacedObjectAsynch.FakeInvoke(const aMethod: TServiceMethod;
const aParams: RawUTF8; aResult, aErrorMsg: PRawUTF8;
aClientDrivenID: PCardinal; aServiceCustomAnswer: PServiceCustomAnswer): boolean;
var msg: RawUTF8;
call: TInterfacedObjectAsynchCall;
begin
result := inherited FakeInvoke(aMethod,aParams,aResult,aErrorMsg,
aClientDrivenID,aServiceCustomAnswer);
if not result then
exit;
call.Method := @aMethod;
call.Instance := pointer(fDest);
call.Params := aParams;
if Assigned(fOnResult) then begin
FastSetString(call.OnOutputParamsCopy,pointer(aParams),length(aParams));
call.OnOutput := fOnResult;
end else
call.OnOutput := nil;
msg := RecordSave(call,TypeInfo(TInterfacedObjectAsynchCall));
result := fTimer.EnQueue(fTimer.AsynchBackgroundExecute,msg,true);
end;
{ TSQLRestBackgroundTimer }
constructor TSQLRestBackgroundTimer.Create(aRest: TSQLRest;
const aThreadName: RawUTF8; aStats: TSynMonitorClass);
var aName: RawUTF8;
begin
if aRest=nil then
raise EORMException.CreateUTF8('%.Create(aRest=nil,"%")',[self,aThreadName]);
fRest := aRest;
if aThreadName<>'' then
aName := aThreadName else
FormatUTF8('% %',[fRest.Model.Root, ClassType],aName);
inherited Create(aName,fRest.BeginCurrentThread,fRest.EndCurrentThread,aStats);
end;
destructor TSQLRestBackgroundTimer.Destroy;
begin
AsynchBatchStop(nil);
inherited Destroy;
end;
function TSQLRestBackgroundTimer.AsynchBatchIndex(aTable: TSQLRecordClass): integer;
begin
if (self=nil) or (fBackgroundBatch=nil) then
result := -1 else begin
result := fRest.Model.GetTableIndexExisting(aTable);
if (result>=length(fBackgroundBatch)) or (fBackgroundBatch[result]=nil) then
result := -1;
end;
end;
function TSQLRestBackgroundTimer.AsynchBatchLocked(aTable: TSQLRecordClass;
out aBatch: TSQLRestBatchLocked): boolean;
var b: integer;
begin
b := AsynchBatchIndex(aTable);
if b>=0 then begin
aBatch := fBackgroundBatch[b];
aBatch.Safe.Lock;
result := true;
end else
result := false;
end;
procedure TSQLRestBackgroundTimer.AsynchBatchUnLock(aBatch: TSQLRestBatchLocked);
begin
try
if aBatch.Count>=aBatch.Threshold then
ExecuteNow(AsynchBatchExecute);
finally
aBatch.Safe.UnLock;
end;
end;
procedure TSQLRestBackgroundTimer.AsynchBatchExecute(Sender: TSynBackgroundTimer;
Event: TWaitResult; const Msg: RawUTF8);
var data, tablename: RawUTF8;
table: TSQLRecordClass;
batch: TSQLRestBatchLocked;
b, count, status: integer;
res: TIDDynArray;
{$ifdef WITHLOG}
log: ISynLog; // for Enter auto-leave to work with FPC
{$endif}
begin
try
// send any pending data
for b := 0 to high(fBackgroundBatch) do begin
batch := fBackgroundBatch[b];
if batch.Count=0 then
continue;
data := '';
batch.Safe.Lock;
try
table := batch.Table;
count := batch.Count;
if count>0 then
try
{$ifdef WITHLOG}
if log=nil then
log := fRest.LogClass.Enter('AsynchBatchExecute % count=%',
[table,count],self);
{$endif}
batch.PrepareForSending(data);
finally
batch.Reset;
end;
finally
batch.Safe.UnLock;
end;
// inlined TSQLRest.BatchSend for lower contention
if data<>'' then
try
status := fRest.EngineBatchSend(table,data,res,count); // may take a while
fRest.InternalLog('AsynchBatchExecute % EngineBatchSend=%',[table,status]);
except
on E: Exception do
fRest.InternalLog('% during AsynchBatchExecute %',[E.ClassType,table],sllWarning);
end;
end;
finally
if IdemPChar(pointer(Msg),'FREE@') then begin // from AsynchBatchStop()
fRest.InternalLog('AsynchBatchExecute %',[Msg]);
tablename := copy(Msg,6,127);
if tablename='' then
// AsynchBatchStop(nil)
ObjArrayClear(fBackgroundBatch,true) else begin
// AsynchBatchStop(table)
b := fRest.Model.GetTableIndex(tablename);
if b<length(fBackgroundBatch) then
FreeAndNil(fBackgroundBatch[b]);
end;
end;
end;
end;
function TSQLRestBackgroundTimer.AsynchBatchStart(Table: TSQLRecordClass;
SendSeconds, PendingRowThreshold, AutomaticTransactionPerRow: integer;
Options: TSQLRestBatchOptions): boolean;
var b: Integer;
begin
result := false;
if (self=nil) or (SendSeconds<=0) then
exit;
b := fRest.Model.GetTableIndexExisting(Table);
if (fBackgroundBatch<>nil) and (fBackgroundBatch[b]<>nil) then
exit; // already defined for this Table
fRest.InternalLog('AsynchBatchStart(%,%,%)',[Table,SendSeconds,PendingRowThreshold],sllDebug);
Enable(AsynchBatchExecute,SendSeconds);
if fBackgroundBatch=nil then
SetLength(fBackgroundBatch,fRest.Model.TablesMax+1);
fBackgroundBatch[b] := TSQLRestBatchLocked.Create(
fRest,Table,AutomaticTransactionPerRow,Options);
fBackgroundBatch[b].Threshold := PendingRowThreshold;
result := true;
end;
function TSQLRestBackgroundTimer.AsynchBatchStop(Table: TSQLRecordClass): boolean;
var b: integer;
timeout: Int64;
{$ifdef WITHLOG}
log: ISynLog; // for Enter auto-leave to work with FPC
{$endif}
begin
result := false;
if (self=nil) or (fBackgroundBatch=nil) then
exit;
{$ifdef WITHLOG}
log := fRest.LogClass.Enter('AsynchBatchStop(%)',[Table],self);
{$endif}
timeout := SynCommons.GetTickCount64+5000;
if Table=nil then begin // e.g. from TSQLRest.Destroy
if not EnQueue(AsynchBatchExecute,'free@',true) then
exit;
repeat
SleepHiRes(1); // wait for all batchs to be released
until (fBackgroundBatch=nil) or (SynCommons.GetTickCount64>timeout);
result := Disable(AsynchBatchExecute);
end else begin
b := AsynchBatchIndex(Table);
if (b<0) or not EnQueue(AsynchBatchExecute,'free@'+Table.SQLTableName,true) then
exit;
repeat
SleepHiRes(1); // wait for all pending rows to be sent
until (fBackgroundBatch[b]=nil) or (SynCommons.GetTickCount64>timeout);
if ObjArrayCount(fBackgroundBatch)>0 then
result := true else begin
result := Disable(AsynchBatchExecute);
if result then
ObjArrayClear(fBackgroundBatch,true);
end;
end;
end;
function TSQLRestBackgroundTimer.AsynchBatchAdd(Value: TSQLRecord; SendData,ForceID: boolean;
const CustomFields: TSQLFieldBits; DoNotAutoComputeFields: boolean): integer;
var b: TSQLRestBatchLocked;
begin
result := -1;
if (self=nil) or (fBackgroundBatch=nil) or (Value=nil) then
exit;
fRest.InternalLog('AsynchBatchAdd %',[Value],sllDebug);
if AsynchBatchLocked(Value.RecordClass,b) then
try
result := b.Add(Value,SendData,ForceID,CustomFields,DoNotAutoComputeFields);
finally
AsynchBatchUnLock(b);
end;
end;
function TSQLRestBackgroundTimer.AsynchBatchRawAdd(Table: TSQLRecordClass;
const SentData: RawUTF8): integer;
var b: TSQLRestBatchLocked;
begin
result := -1;
if (self=nil) or (fBackgroundBatch=nil) or (Table=nil) then
exit;
fRest.InternalLog('AsynchBatchRawAdd % %',[Table,SentData],sllDebug);
if AsynchBatchLocked(Table,b) then
try
result := b.RawAdd(SentData);
finally
AsynchBatchUnLock(b);
end;
end;
procedure TSQLRestBackgroundTimer.AsynchBatchRawAppend(Table: TSQLRecordClass;
SentData: TTextWriter);
var b: TSQLRestBatchLocked;
begin
if (self=nil) or (fBackgroundBatch=nil) or (Table=nil) or (SentData=nil) then
exit;
fRest.InternalLog('AsynchBatchRawAppend %',[Table],sllDebug);
if AsynchBatchLocked(Table,b) then
try
b.RawAppend.AddNoJSONEscape(SentData);
finally
AsynchBatchUnLock(b);
end;
end;
function TSQLRestBackgroundTimer.AsynchBatchUpdate(Value: TSQLRecord;
const CustomFields: TSQLFieldBits; DoNotAutoComputeFields: boolean): integer;
var b: TSQLRestBatchLocked;
begin
result := -1;
if (self=nil) or (fBackgroundBatch=nil) or (Value=nil) then
exit;
fRest.InternalLog('AsynchBatchUpdate %',[Value],sllDebug);
if AsynchBatchLocked(Value.RecordClass,b) then
try
result := b.Update(Value,CustomFields,DoNotAutoComputeFields);
finally
AsynchBatchUnLock(b);
end;
end;
function TSQLRestBackgroundTimer.AsynchBatchDelete(Table: TSQLRecordClass; ID: TID): integer;
var b: TSQLRestBatchLocked;
begin
result := -1;
if (self=nil) or (fBackgroundBatch=nil) then
exit;
fRest.InternalLog('AsynchBatchDelete % %',[Table,ID],sllDebug);
if AsynchBatchLocked(Table,b) then
try
result := b.Delete(Table,ID);
finally
AsynchBatchUnLock(b);
end;
end;
procedure TSQLRestBackgroundTimer.AsynchBackgroundExecute(Sender: TSynBackgroundTimer;
Event: TWaitResult; const Msg: RawUTF8);
var exec: TServiceMethodExecute;
call: TInterfacedObjectAsynchCall;
o: PRawUTF8;
output: RawUTF8;
{$ifdef WITHLOG}
log: ISynLog; // for Enter auto-leave to work with FPC
{$endif}
begin
if not RecordLoad(call,Msg,TypeInfo(TInterfacedObjectAsynchCall)) then
exit; // invalid message (e.g. periodic execution)
{$ifdef WITHLOG}
log := fRest.LogClass.Enter('AsynchBackgroundExecute % %',
[call.Method^.InterfaceDotMethodName,call.Params],self);
{$endif}
exec := TServiceMethodExecute.Create(call.Method);
try
if Assigned(call.OnOutput) then
o := @output else
o := nil;
if not exec.ExecuteJsonCallback(call.Instance,call.Params, o) then
fRest.InternalLog('%.AsynchBackgroundExecute %: ExecuteJsonCallback failed',
[ClassType,call.Method^.InterfaceDotMethodName],sllWarning) else
if o<>nil then
call.OnOutput(call.Method^,IInvokable(call.Instance),
call.OnOutputParamsCopy,output);
finally
exec.Free;
end;
end;
procedure TSQLRestBackgroundTimer.AsynchRedirect(const aGUID: TGUID;
const aDestinationInterface: IInvokable; out aCallbackInterface;
const aOnResult: TOnAsynchRedirectResult);
var factory: TInterfaceFactory;
begin
factory := TInterfaceFactory.Get(aGUID);
if factory=nil then
raise EInterfaceFactoryException.CreateUTF8('%.AsynchRedirect: unknown %',
[self,GUIDToShort(aGUID)]);
if aDestinationInterface=nil then
raise EInterfaceFactoryException.CreateUTF8('%.AsynchRedirect(nil)',[self]);
fRest.InternalLog('AsynchRedirect % to % using %',[factory.InterfaceName,
ObjectFromInterface(aDestinationInterface),self]);
Enable(AsynchBackgroundExecute,3600);
TInterfacedObjectAsynch.Create(self,factory,aDestinationInterface,aCallbackInterface,aOnResult);
end;
procedure TSQLRestBackgroundTimer.AsynchRedirect(const aGUID: TGUID;
const aDestinationInstance: TInterfacedObject; out aCallbackInterface;
const aOnResult: TOnAsynchRedirectResult);
var dest: IInvokable;
begin
if aDestinationInstance=nil then
raise EInterfaceFactoryException.CreateUTF8('%.AsynchRedirect(nil)',[self]);
if not aDestinationInstance.GetInterface(aGUID,dest) then
raise EInterfaceFactoryException.CreateUTF8('%.AsynchRedirect [%]: % is not a %',
[self,fThreadName,aDestinationInstance,GUIDToShort(aGUID)]);
AsynchRedirect(aGUID,dest,aCallbackInterface,aOnResult);
end;
procedure TSQLRestBackgroundTimer.AsynchBackgroundInterning(
Sender: TSynBackgroundTimer; Event: TWaitResult; const Msg: RawUTF8);
var i, claimed, total: integer;
timer: TPrecisionTimer;
begin
timer.Start;
claimed := 0;
for i := 0 to high(fBackgroundInterning) do
inc(claimed,fBackgroundInterning[i].Clean(fBackgroundInterningMaxRefCount));
if claimed=0 then
exit; // nothing to collect
total := claimed;
for i := 0 to high(fBackgroundInterning) do
inc(total,fBackgroundInterning[i].Count);
fRest.InternalLog('%.AsynchInterning: Clean(%) claimed %/% strings from % pools in %',
[ClassType,fBackgroundInterningMaxRefCount,claimed,total,
length(fBackgroundInterning),timer.Stop],sllDebug);
end;
procedure TSQLRestBackgroundTimer.AsynchInterning(Interning: TRawUTF8Interning;
InterningMaxRefCount, PeriodMinutes: integer);
begin
if (self=nil) or (Interning=nil) then
exit;
fTaskLock.Lock;
try
if (InterningMaxRefCount<=0) or (PeriodMinutes<=0) then
ObjArrayDelete(fBackgroundInterning,Interning) else begin
fBackgroundInterningMaxRefCount := InterningMaxRefCount;
ObjArrayAddOnce(fBackgroundInterning,Interning);
Enable(AsynchBackgroundInterning,PeriodMinutes*60);
end;
finally
fTaskLock.UnLock;
end;
end;
{ TInterfacedObjectMulti / TInterfacedObjectMultiList }
type
TInterfacedObjectMultiDest = record
instance: IInvokable;
methods: TInterfaceFactoryMethodBits;
end;
TInterfacedObjectMultiDestDynArray = array of TInterfacedObjectMultiDest;
TInterfacedObjectMulti = class;
TInterfacedObjectMultiList = class(TInterfacedObjectLocked, IMultiCallbackRedirect)
protected
fDest: TInterfacedObjectMultiDestDynArray;
fDestCount: integer;
fDests: TDynArray;
fFakeCallback: TInterfacedObjectMulti;
procedure Redirect(const aCallback: IInvokable;
const aMethodsNames: array of RawUTF8; aSubscribe: boolean); overload;
procedure Redirect(const aCallback: TInterfacedObject;
const aMethodsNames: array of RawUTF8; aSubscribe: boolean); overload;
procedure CallBackUnRegister;
function GetInstances(aMethod: integer; var aInstances: TPointerDynArray): integer;
constructor Create; override;
destructor Destroy; override;
end;
TInterfacedObjectMulti = class(TInterfacedObjectFakeCallback)
protected
fList: TInterfacedObjectMultiList;
fCallBackUnRegisterNeeded: boolean;
function FakeInvoke(const aMethod: TServiceMethod; const aParams: RawUTF8;
aResult, aErrorMsg: PRawUTF8; aClientDrivenID: PCardinal;
aServiceCustomAnswer: PServiceCustomAnswer): boolean; override;
public
constructor Create(aRest: TSQLRest; aFactory: TInterfaceFactory;
aCallBackUnRegisterNeeded: boolean; out aCallbackInterface);
destructor Destroy; override;
procedure CallBackUnRegister;
end;
constructor TInterfacedObjectMultiList.Create;
begin
inherited Create;
fDests.InitSpecific(TypeInfo(TInterfacedObjectMultiDestDynArray),
fDest,djInterface,@fDestCount);
end;
procedure TInterfacedObjectMultiList.Redirect(const aCallback: IInvokable;
const aMethodsNames: array of RawUTF8; aSubscribe: boolean);
var ndx: integer;
new: TInterfacedObjectMultiDest;
const NAM: array[boolean] of string[11] = ('Unsubscribe','Subscribe');
begin
if (self=nil) or (fFakeCallback=nil) then
exit;
fFakeCallback.fRest.InternalLog('%.Redirect: % % using %',[ClassType,NAM[aSubscribe],
fFakeCallback.fFactory.fInterfaceName,ObjectFromInterface(aCallback)],sllDebug);
fFakeCallback.fFactory.CheckMethodIndexes(aMethodsNames,true,new.methods);
new.instance := aCallback;
fSafe.Lock;
try
ndx := fDests.Find(aCallback);
if aSubscribe then
if ndx<0 then
fDests.Add(new) else
fDest[ndx] := new else
fDests.Delete(ndx);
finally
fSafe.UnLock;
end;
end;
procedure TInterfacedObjectMultiList.Redirect(const aCallback: TInterfacedObject;
const aMethodsNames: array of RawUTF8; aSubscribe: boolean);
var dest: IInvokable;
begin
if (self=nil) or (fFakeCallback=nil) then
exit;
if aCallback=nil then
raise EInterfaceFactoryException.CreateUTF8('%.Redirect(nil)',[self]);
if not aCallback.GetInterface(fFakeCallback.fFactory.fInterfaceIID,dest) then
raise EInterfaceFactoryException.CreateUTF8('%.Redirect [%]: % is not a %',
[self,fFakeCallback.fName,aCallback,fFakeCallback.fFactory.fInterfaceName]);
Redirect(dest,aMethodsNames,aSubscribe);
end;
procedure TInterfacedObjectMultiList.CallBackUnRegister;
begin
fSafe.Lock;
try
fDests.ClearSafe;
finally
fSafe.UnLock;
end;
if fFakeCallback<>nil then begin
fFakeCallback.CallBackUnRegister;
fFakeCallback := nil; // disable any further Redirect()
end;
end;
destructor TInterfacedObjectMultiList.Destroy;
begin
CallBackUnRegister;
inherited Destroy;
end;
function TInterfacedObjectMultiList.GetInstances(aMethod: integer;
var aInstances: TPointerDynArray): integer;
var i: integer;
dest: ^TInterfacedObjectMultiDest;
begin
result := 0;
dec(aMethod,RESERVED_VTABLE_SLOTS);
if aMethod<0 then
exit;
SetLength(aInstances,fDestCount);
dest := pointer(fDest);
for i := 1 to fDestCount do begin
if aMethod in dest^.methods then begin
aInstances[result] := pointer(dest^.instance);
inc(result);
end;
inc(dest);
end;
if result<>fDestCount then
SetLength(aInstances,result);
end;
procedure TInterfacedObjectMulti.CallBackUnRegister;
begin
if fCallBackUnRegisterNeeded then begin
fRest.InternalLog('%.Destroy -> Services.CallbackUnRegister(%)',
[fList.ClassType,fFactory.fInterfaceTypeInfo.Name],sllDebug);
fRest.Services.CallBackUnRegister(IInvokable(pointer(@fVTable)));
end;
end;
constructor TInterfacedObjectMulti.Create(aRest: TSQLRest; aFactory: TInterfaceFactory;
aCallBackUnRegisterNeeded: boolean; out aCallbackInterface);
begin
if aRest=nil then
raise EServiceException.CreateUTF8('%.Create(aRest=nil)',[self]);
fRest := aRest;
fName := fRest.Model.Root;
fCallBackUnRegisterNeeded := aCallBackUnRegisterNeeded;
fList := TInterfacedObjectMultiList.Create;
fList.fFakeCallback := self;
inherited Create(aFactory,nil,[ifoJsonAsExtended,ifoDontStoreVoidJSON],FakeInvoke,nil);
Get(aCallbackInterface);
end;
destructor TInterfacedObjectMulti.Destroy;
begin
fList.CallBackUnRegister;
inherited Destroy;
end;
function TInterfacedObjectMulti.FakeInvoke(const aMethod: TServiceMethod;
const aParams: RawUTF8; aResult, aErrorMsg: PRawUTF8;
aClientDrivenID: PCardinal; aServiceCustomAnswer: PServiceCustomAnswer): boolean;
var i: integer;
exec: TServiceMethodExecute;
instances: TPointerDynArray;
begin
result := inherited FakeInvoke(aMethod,aParams,aResult,aErrorMsg,
aClientDrivenID,aServiceCustomAnswer);
if not result or (fList.fDestCount=0) then
exit;
fList.fSafe.Lock;
try
if fList.GetInstances(aMethod.ExecutionMethodIndex,instances)=0 then
exit;
exec := TServiceMethodExecute.Create(@aMethod);
try
exec.Options := [optIgnoreException]; // use exec.ExecutedInstancesFailed
result := exec.ExecuteJson(instances,pointer('['+aParams+']'),nil);
if exec.ExecutedInstancesFailed<>nil then
for i := high(exec.ExecutedInstancesFailed) downto 0 do
if exec.ExecutedInstancesFailed[i]<>'' then
try
fRest.InternalLog('%.FakeInvoke % failed due to % -> unsubscribe',
[ClassType,aMethod.InterfaceDotMethodName,exec.ExecutedInstancesFailed[i]],sllDebug);
fList.fDests.FindAndDelete(instances[i]);
except // ignore any exception when releasing the (unstable?) callback
end;
finally
exec.Free;
end;
finally
fList.fSafe.UnLock;
end;
end;
function TSQLRest.MultiRedirect(const aGUID: TGUID; out aCallbackInterface;
aCallBackUnRegisterNeeded: boolean): IMultiCallbackRedirect;
var factory: TInterfaceFactory;
begin
factory := TInterfaceFactory.Get(aGUID);
if factory=nil then
raise EInterfaceFactoryException.CreateUTF8('%.MultiRedirect: unknown %',
[self,GUIDToShort(aGUID)]);
result := TInterfacedObjectMulti.Create(self,factory,aCallBackUnRegisterNeeded,
aCallbackInterface).fList;
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 := ToText(Sender.ClassType)+' 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;
{ EInterfaceStub }
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;
{ TInterfaceStubLog }
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;
{ TOnInterfaceStubExecuteParamsAbstract }
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;
{ TOnInterfaceStubExecuteParamsJSON }
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}
{ TOnInterfaceStubExecuteParamsVariant }
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;
function TOnInterfaceStubExecuteParamsVariant.GetInUTF8(const ParamName: RawUTF8): RawUTF8;
var wasString: boolean;
begin
result := '';
VariantToUTF8(GetInNamed(ParamName),result,wasString);
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;
temp: TTextWriterStackBuffer;
begin
fResult := '';
if fOutput=nil then
exit;
W := TJSONSerializer.CreateOwnedStream(temp);
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;
{$ifdef WITHLOG}
procedure TOnInterfaceStubExecuteParamsVariant.AddLog(aLog: TSynLogClass;
aOutput: boolean; aLevel: TSynLogInfo);
var val: variant;
begin
if aLog=nil then
exit;
with aLog.Family do
if aLevel in Level then begin
if aOutput then
val := OutputAsDocVariant(pdvObjectFixed) else
val := InputAsDocVariant(pdvObjectFixed);
SynLog.Log(aLevel,'%(%)',[fMethod^.InterfaceDotMethodName,
_Safe(val)^.ToTextPairs('=',',',twJSONEscape)],self);
end;
end;
{$endif}
{$endif NOVARIANTS}
{ TInterfaceStub }
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,nil,[ifoJsonAsExtended,ifoDontStoreVoidJSON],
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);
var ok: boolean;
begin
case aOperator of
qoEqualTo: ok := aComputed=aCount;
qoNotEqualTo: ok := aComputed<>aCount;
qoLessThan: ok := aComputed<aCount;
qoLessThanOrEqualTo: ok := aComputed<=aCount;
qoGreaterThan: ok := aComputed>aCount;
qoGreaterThanOrEqualTo: ok := aComputed>=aCount;
else raise EInterfaceStub.CreateUTF8('%.IntCheckCount(): Unexpected % operator',
[self,Ord(aOperator)]);
end;
InternalCheck(ok,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;
FormatUTF8('No stubbing rule defined for %.%',
[fInterface.fInterfaceName,aMethod.URI],log.CustomResults);
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() by caller
if log.CustomResults='' then
FastSetString(aResult^,pointer(aMethod.DefaultResult),length(aMethod.DefaultResult)) else
FastSetString(aResult^,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;
temp: TTextWriterStackBuffer;
log: ^TInterfaceStubLog;
begin
if fLogCount=0 then
result := '' else begin
WR := TTextWriter.CreateOwnedStream(temp);
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) or (fImplementation.ItemClass=nil) then
result := '' else
result := string(fImplementation.ItemClass.ClassName);
end;
function TInterfaceResolverForSingleInterface.GetOneInstance(out Obj): boolean;
begin
if (self=nil) or (fImplementation.ItemClass=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 fImplementation.ItemClass=nil then
result := false else
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
result := true;
if fInterfaceTypeInfo=aInterface then
exit; // found exact interface
for i := 0 to length(fInterfaceAncestors)-1 do
if fInterfaceAncestors[i]=aInterface then
exit; // found any parent/ancestor interface
result := false;
end;
{ TInterfaceResolverInjected }
var
GlobalInterfaceResolutionLock: TRTLCriticalSection;
GlobalInterfaceResolution: array of record
TypeInfo: PTypeInfo;
ImplementationClass: TClassInstance;
InterfaceEntry: PInterfaceEntry;
Instance: IInterface;
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]);
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: TInterfacedObjectClass);
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.Init(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
if not GetInterfaceFromEntry(aImplementation,aInterfaceEntry,Instance) then
raise EInterfaceResolverException.CreateUTF8('Unexcepted %.RegisterGlobal(%,%)',
[self,aInterface^.Name,aImplementation]);
TypeInfo := aInterface;
InterfaceEntry := aInterfaceEntry;
end;
finally
LeaveCriticalSection(GlobalInterfaceResolutionLock);
end;
end;
class procedure TInterfaceResolverInjected.RegisterGlobalDelete(aInterface: PTypeInfo);
var i,n: integer;
begin
if (aInterface=nil) or (aInterface^.Kind<>tkInterface) then
raise EInterfaceResolverException.CreateUTF8('%.RegisterGlobalDelete(?)',[self]);
EnterCriticalSection(GlobalInterfaceResolutionLock);
try
n := length(GlobalInterfaceResolution)-1;
for i := 0 to n do
with GlobalInterfaceResolution[i] do
if TypeInfo=aInterface then begin
if Instance=nil then
raise EInterfaceResolverException.CreateUTF8(
'%.RegisterGlobalDelete(%) does not match an instance, but a class',
[self,aInterface^.Name]);
Instance := nil; // avoid GPF
if n>i then
MoveFast(GlobalInterfaceResolution[i+1],GlobalInterfaceResolution[i],
(n-i)*SizeOf(GlobalInterfaceResolution[i]));
SetLength(GlobalInterfaceResolution,n);
exit;
end;
finally
LeaveCriticalSection(GlobalInterfaceResolutionLock);
end;
end;
procedure FinalizeGlobalInterfaceResolution;
begin
GlobalInterfaceResolution := nil; // also cleanup Instance fields
DeleteCriticalSection(GlobalInterfaceResolutionLock);
DeleteCriticalSection(vmtAutoTableLock);
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 Instance<>nil then begin
IInterface(Obj) := Instance;
exit;
end else
if GetInterfaceFromEntry(ImplementationClass.CreateNew,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 := GetClassParent(CT);
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;
{ TInjectableObjectRest }
constructor TInjectableObjectRest.CreateWithResolverAndRest(
aResolver: TInterfaceResolver; aFactory: TServiceFactoryServer;
aServer: TSQLRestServer; aRaiseEServiceExceptionIfNotFound: boolean);
begin
fFactory := aFactory; // may be needed by overriden Create
fServer := aServer;
CreateWithResolver(aResolver,aRaiseEServiceExceptionIfNotFound);
end;
{ TServiceFactory }
constructor TServiceFactory.Create(aRest: TSQLRest;
aInterface: PTypeInfo; aInstanceCreation: TServiceInstanceImplementation;
const aContractExpected: RawUTF8);
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: I% routing name is '+
'already used by a % SQL table name',[self,fInterfaceURI,fInterfaceURI]);
SetLength(fExecution,fInterface.fMethodsCount);
// compute interface signature (aka "contract"), serialized as a JSON object
FormatUTF8('{"contract":"%","implementation":"%","methods":%}',
[InterfaceURI,LowerCase(TrimLeftLowerCaseShort(ToText(InstanceCreation))),
fInterface.fContract],fContract);
fContractHash := '"'+CardinalToHex(Hash32(fContract))+
CardinalToHex(CRC32string(fContract))+'"'; // 2 hashes to avoid collision
if aContractExpected<>'' then // override default contract
if aContractExpected[1]<>'"' then // stored as JSON string
fContractExpected := '"'+aContractExpected+'"' else
fContractExpected := aContractExpected else
fContractExpected := fContractHash; // for security
end;
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;
procedure TServiceFactory.ExecutionAction(const aMethod: array of RawUTF8;
aOptions: TServiceMethodOptions; aAction: TServiceMethodOptionsAction);
procedure SetAction(var exec: TServiceFactoryExecution);
begin
case aAction of
moaReplace:
exec.Options := aOptions;
moaInclude:
exec.Options := exec.Options + aOptions;
moaExclude:
exec.Options := exec.Options - aOptions;
end;
end;
var i,m: integer;
begin
if high(aMethod)<0 then
for i := 0 to fInterface.fMethodsCount-1 do
SetAction(fExecution[i]) else
for m := 0 to high(aMethod) do
SetAction(fExecution[fInterface.CheckMethodIndex(aMethod[m])]);
fAnyOptions := [];
for i := 0 to fInterface.fMethodsCount-1 do
fAnyOptions := fAnyOptions+fExecution[i].Options;
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: PtrInt;
UID: array of PGUID;
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);
// check all interfaces available in aSharedImplementation/aImplementationClass
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],{$ifdef FPC}IID{$else}@IID{$endif}) then begin
UID[j] := nil; // mark TGUID found
break;
end;
C := GetClassParent(C);
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,
fSessionTimeout,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,j: Integer;
P: ^TServiceFactoryServerInstance;
fact: TServiceFactoryServer;
inst: TServiceFactoryServerInstance;
begin
for i := 0 to high(fInterface) do begin
fact := TServiceFactoryServer(fInterface[i].Service);
if fact.fInstanceCount>0 then
case fact.InstanceCreation of
sicPerSession: begin
inst.InstanceID := aSessionID;
fact.InternalInstanceRetrieve(inst,ord(imFree),aSessionID);
end;
sicClientDriven: begin // release ASAP if was not notified by client
EnterCriticalSection(fact.fInstanceLock);
try
P := pointer(fact.fInstances);
for j := 1 to fact.fInstanceCapacity do begin
if P^.Session=aSessionID then
P^.SafeFreeInstance(fact);
inc(P);
end;
finally
LeaveCriticalSection(fact.fInstanceLock);
end;
end;
end;
end;
end;
constructor TServiceContainerServer.Create(aRest: TSQLRest);
begin
inherited Create(aRest);
fSessionTimeout := 30*60; // 30 minutes by default
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 := TSynObjectListLocked.Create(false);
fFakeCallbacks.Add(aFakeInstance);
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,Values[0].NameLen);
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.ServiceMethod := @fake.fService.fInterface.fMethods[Ctxt.ServiceMethodIndex];
Ctxt.ServiceExecution := @fake.fService.fExecution[Ctxt.ServiceMethodIndex];
Ctxt.ServiceExecutionOptions := Ctxt.ServiceExecution.Options;
Ctxt.Service := fake.fService;
inc(Ctxt.ServiceMethodIndex,SERVICE_PSEUDO_METHOD_COUNT);
fake._AddRef; // IInvokable=pointer in Ctxt.ExecuteCallback
Ctxt.ServiceParameters := pointer(FormatUTF8('[%,"%"]',
[PtrInt(PtrUInt(fake.fFakeInterface)),Values[0].Name]));
fake.fService.ExecuteMethod(Ctxt);
if withLog then
fRest.InternalLog('I%() returned %',[PServiceMethod(Ctxt.ServiceMethod)^.
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; callbacktext: PShortString): boolean;
procedure Append(var dest: shortstring; const source: shortstring);
var d,s: integer;
begin
d := ord(dest[0]);
s := ord(source[0]);
if d+s<254 then begin
dest[d+1] := ' ';
MoveFast(source[1],dest[d+2],s);
inc(dest[0],s+1);
end;
end;
var instance: TObject;
begin
instance := ObjectFromInterface(callback);
if instance=nil then
result := false else begin
if callbacktext<>nil then
Append(callbacktext^,ClassNameShort(instance)^);
result := (instance.ClassType=TInterfacedObjectFakeServer) and
TInterfacedObjectFakeServer(instance).fReleasedOnClientSide;
end;
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 := length(fInterfaceMethod);
i := 0;
while i<n do begin
fact := fInterfaceMethod[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,fInterfaceMethod[i].InterfaceMethodIndex-SERVICE_PSEUDO_METHOD_COUNT);
somemethods := true;
end;
inc(i);
until (i>=n) or (fInterfaceMethod[i].InterfaceService<>fact);
if (aExcludedMethodNamesCSV='') or somemethods then
TServiceFactoryServer(fact).SetServiceLogByIndex(methods,aLogRest,aLogClass);
end;
end;
{ TServiceFactoryServer }
type
PCallMethodArgs = ^TCallMethodArgs;
{$ifdef FPC}
{$push}
{$PACKRECORDS 16}
{$endif}
TCallMethodArgs = record
StackSize: PtrInt;
StackAddr, method: PtrInt;
ParamRegs: array[PARAMREG_FIRST..PARAMREG_LAST] of PtrInt;
{$ifdef HAS_FPREG}
FPRegs: array[FPREG_FIRST..FPREG_LAST] of Double;
{$endif}
res64: Int64Rec;
resKind: TServiceMethodValueType;
end;
{$ifdef FPC}
{$pop}
{$endif}
// ARM/AARCH64 code below provided by ALF, greatly inspired by pascalscript
{$ifdef CPUARM}
procedure CallMethod(var Args: TCallMethodArgs); 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
// sometimes, the entry-point is not exact ... give some room for errors
nop
nop
// 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]
{$ifdef CPUARM_HAS_BLX}
blx v1
{$else}
mov lr, pc
{$ifdef CPUARM_HAS_BX}
bx v1
{$else}
mov pc, v1
{$endif}
{$endif}
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}
procedure CallMethod(var Args: TCallMethodArgs); assembler; nostackframe;
label stack_loop,load_regs,asmcall_end,float_result;
asm
// inspired by pascal script
// fp x29
// lr x30
// sp sp
// sometimes, the entry-point is not exact ... give some room for errors
nop
nop
// prolog
stp x29, x30, [sp, #-16]!
mov x29, sp
stp x19, x19, [sp, #-16]!
// make space on stack
sub sp, sp, #MAX_EXECSTACK
//and sp, sp, #-16 // Always align sp.
mov x19, Args
// 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
ldr x15, [x19,#TCallMethodArgs.method]
blr x15
// store normal result
str x0, [x19, #TCallMethodArgs.res64]
ldr x15, [x19, #TCallMethodArgs.resKind]
cmp x15, smvDouble
b.eq float_result
cmp x15, smvDateTime
b.eq float_result
cmp x15, smvCurrency
b.ne asmcall_end
// store double result in res64
float_result:
str d0, [x19,#TCallMethodArgs.res64]
asmcall_end:
add sp, sp, #MAX_EXECSTACK
ldr x19,[sp], #16
ldp x29,x30,[sp], #16
ret
end;
{$endif CPUAARCH64}
{$ifdef CPUX64}
procedure CallMethod(var Args: TCallMethodArgs); 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 to 16 bytes
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 rcx, [r12].TCallMethodArgs.StackSize
mov rdx, [r12].TCallMethodArgs.StackAddr
jmp @checkstack
@addstack:
dec ecx
push qword ptr[rdx]
sub rdx, 8
@checkstack:
test 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
// movlpd to ignore upper 64-bit of 128-bit xmm0 reg
@e: {$ifdef FPC}
mov rsp, rbp
pop r12
pop rbp
{$endif}
end;
{$endif CPUX64}
{$ifdef CPUX86}
procedure CallMethod(var Args: TCallMethodArgs);
{$ifdef FPC}nostackframe; assembler;{$endif}
asm
push esi
push ebp
push eax // keep stack aligned on 16 bytes - required on DARWIN
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
// before a call instruction, esp should be divisible by 16:
// mandatory on Darwin, and also on Linux i386 as stated by Florian in
// https://www.mail-archive.com/fpc-devel@lists.freepascal.org/msg38885.html
@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 eax
pop ebp
pop esi
end;
{$endif CPUX86}
{$ifdef ISDELPHI7ANDUP}{$WARN COMPARING_SIGNED_UNSIGNED ON}{$endif}
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
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]);
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,@fInstanceCapacity); // 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
if fInstanceCount>0 then
Rest.InternalLog('%.Destroy for I% %: fInstanceCount=%',[ClassType,fInterfaceURI,
ToText(InstanceCreation)^,fInstanceCount],sllDebug);
try
EnterCriticalSection(fInstanceLock);
try // release any internal instance (should have been done by client)
try
for i := 0 to fInstanceCapacity-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
LeaveCriticalSection(fInstanceLock);
end;
DeleteCriticalSection(fInstanceLock);
ObjArrayClear(fStats,true);
inherited Destroy;
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 (InternalInstanceRetrieve(Inst,SERVICE_PSEUDO_METHOD_COUNT,0)>=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;
function TServiceFactoryServer.RenewSession(aSession: cardinal): integer;
var tix: Int64;
i: integer;
P: ^TServiceFactoryServerInstance;
begin
result := 0;
if (self=nil) or (fInstanceCount=0) or (aSession<=CONST_AUTHENTICATION_NOT_USED) or
not(fInstanceCreation in [sicClientDriven,sicPerSession]) then
exit;
tix := GetTickCount64;
EnterCriticalSection(fInstanceLock);
try
P := pointer(fInstances);
for i := 1 to fInstanceCapacity do begin
if P^.Session=aSession then begin
P^.LastAccess64 := tix;
inc(result);
end;
inc(P);
end;
finally
LeaveCriticalSection(fInstanceLock);
end;
end;
function TServiceFactoryServer.RunOnAllInstances(const aEvent: TOnServiceFactoryServerOne;
var aOpaque): integer;
var i: integer;
P: ^TServiceFactoryServerInstance;
begin
result := 0;
if (self = nil) or not Assigned(aEvent) or (fInstanceCount=0) then
exit;
EnterCriticalSection(fInstanceLock);
try
P := pointer(fInstances);
for i := 1 to fInstanceCapacity do begin
if (P^.InstanceID<>0) and (P^.Instance<>nil) then
inc(result,aEvent(self,P^,aOpaque));
inc(P);
end;
finally
LeaveCriticalSection(fInstanceLock);
end;
end;
procedure TServiceFactoryServerInstance.SafeFreeInstance(Factory: TServiceFactoryServer);
var Obj: TInterfacedObject;
begin
if Instance=nil then
exit; // nothing to release
dec(Factory.fInstanceCount);
InstanceID := 0;
Session := 0;
Obj := Instance;
Instance := nil;
try
{$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;
except
on E: Exception do
Factory.fRest.Internallog('SafeFreeInstance: Ignored % exception '+
'during %._Release',[E.ClassType,Factory.InterfaceURI],sllDebug);
end;
end;
function TServiceFactoryServer.InternalInstanceRetrieve(
var Inst: TServiceFactoryServerInstance; aMethodIndex,aSession: integer): integer;
procedure AddNew;
var i: integer;
P: ^TServiceFactoryServerInstance;
begin
Inst.Session := aSession;
Inst.Instance := CreateInstance(true);
if Inst.Instance=nil then
exit;
result := aMethodIndex; // notify caller
inc(fInstanceCount);
fRest.InternalLog('%.InternalInstanceRetrieve: Adding %(%) instance (id=%) count=%',
[ClassType,fInterfaceURI,pointer(Inst.Instance),Inst.InstanceID,fInstanceCount],sllDebug);
P := pointer(fInstances);
for i := 1 to fInstanceCapacity 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;
P: ^TServiceFactoryServerInstance;
begin
result := -1;
EnterCriticalSection(fInstanceLock);
try
Inst.LastAccess64 := GetTickCount64;
// first release any deprecated instances
if (fInstanceTimeout<>0) and (fInstanceCount>0) then begin
P := pointer(fInstances);
for i := 1 to fInstanceCapacity do begin
if (P^.InstanceID<>0) and
(Inst.LastAccess64>P^.LastAccess64+fInstanceTimeOut) then begin
fRest.InternalLog('%.InternalInstanceRetrieve: Delete %(%) instance '+
'(id=%) after % minutes timeout (max % minutes)',[ClassType,fInterfaceURI,
pointer(Inst.Instance),P^.InstanceID,(Inst.LastAccess64-P^.LastAccess64)div 60000,
fInstanceTimeOut div 60000],sllInfo);
P^.SafeFreeInstance(self);
end;
inc(P);
end;
end;
if Inst.InstanceID=0 then begin
// initialize a new sicClientDriven instance
if (InstanceCreation<>sicClientDriven) or
((cardinal(aMethodIndex-SERVICE_PSEUDO_METHOD_COUNT)>=fInterface.fMethodsCount) and
(aMethodIndex<>ord(imInstance))) then
exit;
inc(fInstanceCurrentID);
Inst.InstanceID := fInstanceCurrentID;
AddNew;
end else begin
// search the instance corresponding to Inst.InstanceID
if fInstanceCount>0 then begin
P := pointer(fInstances);
for i := 1 to fInstanceCapacity do
if P^.InstanceID=Inst.InstanceID then begin
result := aMethodIndex; // notify caller
if aMethodIndex=ord(imFree) then begin
P^.SafeFreeInstance(self); // {"method":"_free_", "params":[], "id":1234}
exit;
end;
P^.LastAccess64 := Inst.LastAccess64;
Inst.Instance := P^.Instance;
exit;
end else
inc(P);
end;
// add any new session/user/group/thread instance if necessary
if (InstanceCreation<>sicClientDriven) and
(cardinal(aMethodIndex-SERVICE_PSEUDO_METHOD_COUNT)<fInterface.fMethodsCount) then
AddNew;
end;
finally
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:
result := TInjectableObjectClass(fImplementationClass).
CreateWithResolver(Rest.Services,true);
ickInjectableRest:
result := TInjectableObjectRestClass(fImplementationClass).
CreateWithResolverAndRest(Rest.Services,self,RestServer,true);
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)));
dec(TInterfacedObjectHooked(result).FRefCount); // RefCount=1 after TryResolveInternal()
end;
else
result := fImplementationClass.Create;
end;
inc(TInterfacedObjectHooked(result).FRefCount); // >0 to call Support() in event
if Assigned(TSQLRestServer(Rest).OnServiceCreateInstance) then
TSQLRestServer(Rest).OnServiceCreateInstance(self,result);
if not AndIncreaseRefCount then
dec(TInterfacedObjectHooked(result).FRefCount);
end;
procedure TServiceFactoryServer.OnLogRestExecuteMethod(Sender: TServiceMethodExecute;
Step: TServiceMethodExecuteEventStep);
var W: TTextWriter;
a, len: 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 not (optNoLogInput in Sender.fOptions) then begin
for a := ArgsInFirst to ArgsInLast do
with Args[a] do
if (ValueDirection<>smdOut) and (ValueType<>smvInterface) and
not IsDefault(Sender.Values[a]) then begin
W.AddShort(ParamName^); // in JSON_OPTIONS_FAST_EXTENDED format
W.Add(':');
if vIsSPI in ValueKindAsm then
W.AddShort('"****",') else
AddJSON(W,Sender.Values[a],SERVICELOG_WRITEOPTIONS);
end;
W.CancelLastComma;
end;
end;
smsAfter: begin
W.AddShort('},Output:{');
if not (optNoLogOutput in Sender.fOptions) then
if ArgsResultIsServiceCustomAnswer then
with PServiceCustomAnswer(Sender.Values[ArgsResultIndex])^ do begin
len := length(Content);
W.AddShort('len:');
W.AddU(len);
if (Status<>0) and (Status<>HTTP_SUCCESS) then begin
W.AddShort(',status:');
W.AddU(Status);
end;
if not fExcludeServiceLogCustomAnswer and (len>0) and (len<=1024) then begin
W.AddShort(',result:"');
W.WrBase64(pointer(content),len,false); // up to 1KB of base-64
W.Add('"');
end;
end else begin
for a := ArgsOutFirst to ArgsOutLast do
with Args[a] do
if (ValueDirection in [smdVar,smdOut,smdResult]) and
not IsDefault(Sender.Values[a]) then begin
W.AddShort(ParamName^);
W.Add(':');
if vIsSPI in ValueKindAsm then
W.AddShort('"****",') else
AddJSON(W,Sender.Values[a],SERVICELOG_WRITEOPTIONS);
end;
W.CancelLastComma;
end;
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; // weak IInvokable reference
dolock, execres: boolean;
opt: TServiceMethodOptions;
exec: TServiceMethodExecute;
timeStart,timeEnd: Int64;
stats: TSynMonitorInputOutput;
m: integer;
err: shortstring;
temp: TTextWriterStackBuffer;
function GetFullMethodName: RawUTF8;
begin
if Ctxt.ServiceMethod<>nil then
result := PServiceMethod(Ctxt.ServiceMethod)^.InterfaceDotMethodName else
result := fInterface.fInterfaceName;
end;
procedure Error(const Msg: RawUTF8; Status: integer);
begin
Ctxt.Error('% % for %',[ToText(InstanceCreation)^,Msg,GetFullMethodName],Status);
end;
function StatsCreate: TSynMonitorInputOutput;
begin
result := TSynMonitorInputOutput.Create(GetFullMethodName);
end;
procedure FinalizeLogRest;
var W: TTextWriter;
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]);
if Ctxt.RemoteIPIsLocalHost then
W.Add('}',',') else
W.Add(',IP:"%"},',[Ctxt.fRemoteIP]);
with Ctxt.ServiceExecution^ do
LogRest.AsynchBatchRawAppend(LogClass,W);
end;
begin
if mlInterfaces in TSQLRestServer(Rest).StatLevels then
{$ifdef LINUX}QueryPerformanceMicroSeconds{$else}QueryPerformanceCounter{$endif}(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',HTTP_UNAUTHORIZED);
exit;
end;
end;
case InternalInstanceRetrieve(Inst,Ctxt.ServiceMethodIndex,Ctxt.Session) of
ord(imFree): begin
Ctxt.Success; // {"method":"_free_", "params":[], "id":1234}
exit;
end;
ord(imInstance): begin // from TServiceFactoryClient.CreateFakeInstance
Ctxt.Results([Inst.InstanceID],HTTP_SUCCESS);
exit;
end;
end;
end;
end;
if Inst.Instance=nil then begin
Error('instance not found or deprecated',HTTP_UNAUTHORIZED);
exit;
end;
Ctxt.ServiceInstanceID := Inst.InstanceID;
// 2. call method implementation
if (Ctxt.ServiceExecution=nil) or (Ctxt.ServiceMethod=nil) then begin
Error('ServiceExecution=nil',HTTP_SERVERERROR);
exit;
end;
stats := nil;
if (mlInterfaces in TSQLRestServer(Rest).StatLevels) then begin
m := Ctxt.ServiceMethodIndex-SERVICE_PSEUDO_METHOD_COUNT;
if m>=0 then begin
stats := fStats[m];
if stats=nil then begin
EnterCriticalSection(fInstanceLock);
try
stats := fStats[m];
if stats=nil then begin
stats := StatsCreate;
fStats[m] := stats;
end;
finally
LeaveCriticalSection(fInstanceLock);
end;
end;
stats.Processing := true;
end;
end;
err := '';
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;
opt := Ctxt.ServiceExecution^.Options;
if optExecInPerInterfaceThread in opt then
if fBackgroundThread=nil then
fBackgroundThread := Rest.NewBackgroundThreadMethod(
'% %',[self,fInterface.fInterfaceName]);
WR := TJSONSerializer.CreateOwnedStream(temp);
try
Ctxt.fThreadServer^.Factory := self;
if not(optForceStandardJSON in opt) and
((Ctxt.Call.InHead='') or (Ctxt.ClientKind=ckFramework)) then
include(WR.fCustomOptions,twoForceJSONExtended) else
include(WR.fCustomOptions,twoForceJSONStandard); // AJAX
if optDontStoreVoidJSON in opt then
include(WR.fCustomOptions,twoIgnoreDefaultInRecord);
// root/calculator {"method":"add","params":[1,2]} -> {"result":[3],"id":0}
Ctxt.ServiceResultStart(WR);
dolock := optExecLockedPerInterface in opt;
if dolock then
EnterCriticalSection(fInstanceLock);
exec := TServiceMethodExecute.Create(Ctxt.ServiceMethod);
try
exec.fOptions := opt;
{$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 (fImplementationClassKind=ickFake) and
((Ctxt.ServiceParameters=nil) or (Ctxt.ServiceParameters^='[')) and
{$ifndef LVCL}not ((optExecInMainThread in exec.fOptions) or
(optExecInPerInterfaceThread in exec.fOptions)) and {$endif}
(exec.fMethod^.ArgsOutputValuesCount=0) then // bypass JSON marshalling
execres := exec.ExecuteJsonFake(Inst.Instance,Ctxt.ServiceParameters) else
execres := exec.ExecuteJson([instancePtr],Ctxt.ServiceParameters,WR,
@err,Ctxt.ForceServiceResultAsJSONObject);
if not execres then begin
if err<>'' then
Ctxt.Error('%',[err],HTTP_NOTACCEPTABLE) else
Error('execution failed (probably due to bad input parameters: ' +
'e.g. did you initialize your input record(s)?)',HTTP_NOTACCEPTABLE);
exit; // wrong request
end;
Ctxt.Call.OutHead := exec.ServiceCustomAnswerHead;
Ctxt.Call.OutStatus := exec.ServiceCustomAnswerStatus;
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 := HTTP_SUCCESS;
end;
WR.SetText(Ctxt.Call.OutBody);
finally
Ctxt.fThreadServer^.Factory := nil;
WR.Free;
end;
finally
try
if InstanceCreation=sicSingle then
Inst.SafeFreeInstance(self); // always release single shot instance
if stats<>nil then begin
{$ifdef LINUX}QueryPerformanceMicroSeconds{$else}QueryPerformanceCounter{$endif}(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.fSession<>nil) then begin
if Ctxt.fSession.fInterfaces=nil then begin
EnterCriticalSection(fInstanceLock);
try
if Ctxt.fSession.fInterfaces=nil then
SetLength(Ctxt.fSession.fInterfaces,length(Rest.Services.fInterfaceMethod));
finally
LeaveCriticalSection(fInstanceLock);
end;
end;
m := Ctxt.fServiceListInterfaceMethodIndex;
if m<0 then
m := Rest.Services.fInterfaceMethods.FindHashed(
PServiceMethod(Ctxt.ServiceMethod)^.InterfaceDotMethodName);
if m>=0 then
with Ctxt.fSession do begin
stats := fInterfaces[m];
if stats=nil then begin
EnterCriticalSection(fInstanceLock);
try
stats := fInterfaces[m];
if stats=nil then begin
stats := StatsCreate;
fInterfaces[m] := stats;
end;
finally
LeaveCriticalSection(fInstanceLock);
end;
end;
Ctxt.StatsFromContext(stats,timeEnd,true);
// mlSessions stats are not yet tracked per Client
end;
end;
end else
timeEnd := 0;
finally
if exec<>nil then begin
if Ctxt.ServiceExecution^.LogRest<>nil then
FinalizeLogRest;
exec.Free;
end;
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; aAction: TServiceMethodOptionsAction): TServiceFactoryServer;
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}
ExecutionAction(aMethod,aOptions,aAction);
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);
var m: integer;
begin
if aLogRest=nil then
aLogClass := nil else begin
if aLogClass=nil then
aLogClass := TSQLRecordServiceLog;
aLogRest.Model.GetTableIndexExisting(aLogClass);
end;
for m := 0 to fInterface.fMethodsCount-1 do
if m in aMethods then
with fExecution[m] do begin
LogRest := aLogRest;
LogClass := aLogClass;
end;
if aLogRest<>nil then // write every second or after 500 rows in background
aLogRest.AsynchBatchStart(aLogClass,1,500,1000); // do nothing if already set
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;
P := @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
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
ARGTYPETOJSON: array[TServiceMethodValueType] of string[8] = (
'??','self','boolean', '', '','integer','cardinal','int64',
'double','datetime','currency','utf8','utf8','utf8','utf8','utf8','',
{$ifndef NOVARIANTS}'variant',{$endif}'','json','','');
begin
WR.AddShort('{"argument":"');
WR.AddShort(ParamName^);
WR.AddShort('","direction":"');
WR.AddShort(ARGDIRTOJSON[ValueDirection]);
WR.AddShort('","type":"');
if ARGTYPETOJSON[ValueType]='' then
WR.AddShort(ArgTypeInfo^.Name) else
WR.AddShort(ARGTYPETOJSON[ValueType]);
{$ifdef SOA_DEBUG}
WR.Add('"',',');
WR.AddPropJSONInt64('index',IndexVar);
WR.AddPropJSONString('var',GetEnumNameTrimed(TypeInfo(TServiceMethodValueVar),ValueVar));
WR.AddPropJSONInt64('stackoffset',InStackOffset);
WR.AddPropJSONInt64('reg',RegisterIdent);
WR.AddPropJSONInt64('fpreg',FPRegisterIdent);
WR.AddPropJSONInt64('stacksize',SizeInStack);
WR.AddPropJSONInt64('storsize',SizeInStorage);
if ValueType=smvBinary then
WR.AddPropJSONInt64('binsize',SizeInBinary);
WR.AddPropName('asm');
WR.AddString(GetSetNameCSV(TypeInfo(TServiceMethodValueAsm),ValueKindAsm));
WR.AddShort('},');
{$else}
WR.AddShort('"},');
{$endif SOA_DEBUG}
end;
function TServiceMethodArgument.IsDefault(V: pointer): boolean;
begin
result := false;
case ValueType of
smvBoolean..smvCurrency:
case SizeInStorage of
1: result := PByte(V)^=0;
2: result := PWord(V)^=0;
4: result := PInteger(V)^=0;
8: result := PInt64(V)^=0;
end;
smvRawUTF8..smvWideString, smvObject..smvInterface:
result := PPointer(V)^=nil;
smvBinary, smvRecord:
result := IsZeroSmall(V,SizeInStorage);
{$ifndef NOVARIANTS}
smvVariant: result := PVarData(V)^.vtype<=varNull;
{$endif}
end;
end;
function TServiceMethodArgument.FromJSON(const MethodName: RawUTF8; var R: PUTF8Char;
V: pointer; Error: PShortString{$ifndef NOVARIANTS}; DVO: TDocVariantOptions{$endif}): boolean;
procedure RaiseError(const msg: RawUTF8);
var tmp: shortstring;
begin
FormatShort('I% failed on %:% [%]',[MethodName,ParamName^,ArgTypeName^,msg],tmp);
if Error=nil then
raise EInterfaceFactoryException.CreateUTF8('%',[tmp]);
result := false;
Error^ := tmp;
end;
var parser: TJSONToObject; // inlined JSONToObject()
Val: PUTF8Char;
ValLen: integer;
wasString: boolean;
wrapper: TDynArray;
label doint;
begin
result := true;
case ValueType of
smvObject: begin
if PInteger(R)^=NULL_LOW then
inc(R,4) else begin // null from TInterfacedStub -> stay untouched
parser.From := R; // inlined JSONToObject()
parser.Options := JSONTOOBJECT_TOLERANTOPTIONS;
parser.TObjectListItemClass := nil;
parser.Value := PObject(V)^;
parser.Parse;
if parser.Valid then
R := parser.Dest else
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;
smvDateTime: begin
Val := GetJSONField(R,R,@wasString,nil,@ValLen);
if (Val=nil) or (ValLen=0) then
PInt64(V)^ := 0 else
if wasString then
Iso8601ToDateTimePUTF8CharVar(Val,ValLen,PDateTime(V)^) else
unaligned(PDouble(V)^) := GetExtended(Val); // allow JSON number decoding
end;
smvBoolean..smvDouble, smvCurrency..smvWideString: begin
Val := GetJSONField(R,R,@wasString,nil,@ValLen);
if (Val=nil) or (wasString<>(vIsString in ValueKindAsm)) then begin
RaiseError('missing or invalid value');
exit;
end;
if (ValueType=smvBoolean) and (PInteger(Val)^=TRUE_LOW) then
Val := pointer(SmallUInt32UTF8[1]); // normalize 'true' to '1'
case ValueType of
smvBoolean, smvEnum, smvSet, smvCardinal:
doint:case SizeInStorage of
1: PByte(V)^ := GetCardinal(Val);
2: PWord(V)^ := GetCardinal(Val);
4: PCardinal(V)^ := GetCardinal(Val);
8: SetQWord(Val,PQWord(V)^);
end;
smvInteger:
PInteger(V)^ := GetInteger(Val);
smvInt64:
if vIsQword in ValueKindAsm then
SetQWord(Val,PQWord(V)^) else
SetInt64(Val,PInt64(V)^);
smvDouble:
unaligned(PDouble(V)^) := GetExtended(Val);
smvCurrency:
PInt64(V)^ := StrToCurr64(Val);
smvRawUTF8:
FastSetString(PRawUTF8(V)^,Val,ValLen);
smvString:
UTF8DecodeToString(Val,ValLen,PString(V)^);
smvRawByteString:
Base64ToBin(PAnsiChar(Val),ValLen,PRawByteString(V)^);
smvWideString:
UTF8ToWideString(Val,ValLen,PWideString(V)^);
else RaiseError('ValueType?');
end;
end;
smvBinary: begin
Val := GetJSONField(R,R,@wasString,nil,@ValLen);
if Val=nil then begin
RaiseError('missing or invalid binary value');
exit;
end;
if wasString then begin // decode hexadecimal string
if ValLen=SizeInStorage*2 then
HexDisplayToBin(PAnsiChar(Val),PByte(V),SizeInStorage);
end else // allow fallback to read plain numbers (e.g. on API upgrade)
goto doint;
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,@DVO);
if R=nil then
RaiseError('returned variant');
end;
{$endif}
smvDynArray: begin
if vIsObjArray in ValueKindAsm then
ObjArrayClear(V^);
wrapper.InitFrom(DynArrayWrapper,V^);
R := wrapper.LoadFromJSON(R);
if R=nil then
RaiseError('returned array');
IgnoreComma(R);
end;
end;
end;
procedure TServiceMethodArgument.AddJSON(WR: TTextWriter; V: pointer;
ObjectOptions: TTextWriterWriteObjectOptions);
var wrapper: TDynArray; // faster than WR.AddDynArrayJSON(ArgTypeInfo,V^)
begin
if vIsString in ValueKindAsm then
WR.Add('"');
case ValueType of
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: if vIsQword in ValueKindAsm then
WR.AddQ(PQWord(V)^) else
WR.Add(PInt64(V)^);
end;
smvBoolean: WR.Add(PBoolean(V)^);
smvDouble: WR.AddDouble(unaligned(PDouble(V)^));
smvDateTime: WR.AddDateTime(PDateTime(V)^,vIsDateTimeMS in ValueKindAsm);
smvCurrency: WR.AddCurr64(PInt64(V)^);
smvRawUTF8: WR.AddJSONEscape(PPointer(V)^);
smvRawJSON: WR.AddRawJSON(PRawJSON(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)^);
smvBinary: if not IsZeroSmall(V,SizeInStorage) then // leave "" for zero
WR.AddBinToHexDisplayLower(V,SizeInStorage);
smvObject: WR.WriteObject(PPointer(V)^,ObjectOptions);
smvInterface: WR.AddShort('null'); // or written by InterfaceWrite()
smvRecord: WR.AddRecordJSON(V^,ArgTypeInfo);
smvDynArray: if vIsObjArray in ValueKindAsm then
WR.AddObjArrayJSON(V^,ObjectOptions) else begin
wrapper.InitFrom(DynArrayWrapper,V^);
WR.AddDynArrayJSON(wrapper);
end;
{$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;
temp: TTextWriterStackBuffer;
begin
case ValueType of // some direct conversion of simple types
smvBoolean:
DestValue := BOOL_UTF8[PBoolean(V)^];
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: if vIsQword in ValueKindAsm then
UInt64ToUtf8(PQword(V)^,DestValue) else
Int64ToUtf8(PInt64(V)^,DestValue);
end;
smvDouble:
DoubleToStr(unaligned(PDouble(V)^),DestValue);
smvCurrency:
Curr64ToStr(PInt64(V)^,DestValue);
smvRawJSON:
DestValue := PRawUTF8(V)^;
else begin // use generic AddJSON() method for complex "..." content
W := TJSONSerializer.CreateOwnedStream(temp);
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));
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: if vIsQword in ValueKindAsm then
DestValue := PQWord(V)^ else
DestValue := PInt64(V)^;
end;
smvDouble, smvDateTime:
DestValue := unaligned(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 dvoIsArray in Dest.Options 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.InitFrom(DynArrayWrapper,arr);
try
VariantSaveJSON(Value,twJSONEscape,json);
dyn.LoadFromJSON(pointer(json));
json := dyn.SaveToJSON(true);
_Json(json,Value,JSON_OPTIONS_FAST);
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);
_Json(json,Value,JSON_OPTIONS_FAST);
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: TCardinalDynArray;
InterfacesOffset: TCardinalDynArray;
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;
tkInterface:
if P^.GetterIsField then
AddInteger(TIntegerDynArray(InterfacesOffset),PtrUInt(P^.GetterAddr(nil)));
end;
P := P^.Next;
end;
aClass := GetClassParent(aClass);
until aClass=TObject;
end;
function SetAutoCreateFields(PVMT: pointer; c: TClass): TAutoCreateFields;
begin
EnterCriticalSection(vmtAutoTableLock); // protect from concurrent access
try
result := PPointer(PVMT)^;
if result=nil then begin
// first time access: compute RTTI cache
result := TAutoCreateFields.Create(c);
// store the RTTI cache into the AutoTable VMT entry of this class
PatchCodePtrUInt(pointer(PVMT),PtrUInt(result),true);
GarbageCollectorFreeAndNil(PVMT^,result);
end;
finally
LeaveCriticalSection(vmtAutoTableLock);
end;
end;
procedure AutoCreateFields(self: TObject);
var fields: TAutoCreateFields;
PVMT: PPointer;
i: integer;
begin
PVMT := pointer(PPtrInt(self)^+vmtAutoTable);
fields := PVMT^;
if fields=nil then
fields := SetAutoCreateFields(PVMT,PClass(self)^) 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;
function AutoDestroyFields(self: TObject): TAutoCreateFields;
{$ifdef HASINLINENOTX86}inline;{$endif}
var i: integer;
begin
result := PPointer(PPtrInt(self)^+vmtAutoTable)^;
if result=nil then
exit; // may happen in a weird finalization code
// auto-release published persistent class instances
for i := 0 to result.ClassesCount-1 do
FreeAndNil(PObject(PtrUInt(self)+result.Classes[i].Offset)^);
// auto-release published T*ObjArray instances
for i := 0 to result.ObjArraysCount-1 do
ObjArrayClear(pointer(PtrUInt(self)+result.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;
procedure TSynAutoCreateFields.AfterLoad;
begin
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;
{ TSynJsonFileSettings }
function TSynJsonFileSettings.LoadFromJson(var aJson: RawUTF8): boolean;
begin
result := JSONSettingsToObject(aJson, self);
end;
function TSynJsonFileSettings.LoadFromFile(const aFileName: TFileName): boolean;
begin
fFileName := aFileName;
fInitialJsonContent := StringFromFile(aFileName);
result := LoadFromJson(fInitialJsonContent);
end;
procedure TSynJsonFileSettings.SaveIfNeeded;
var
saved: RawUTF8;
begin
if (self = nil) or (fFileName = '') then
exit;
saved := ObjectToJSON(self, SETTINGS_WRITEOPTIONS);
if saved = fInitialJsonContent then
exit;
FileFromString(saved, fFileName);
fInitialJsonContent := saved;
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([fObjectsOwned,fNoDuplicate,fCaseSensitive]);
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;
fPurgeForceList := TRawUTF8List.Create([fCaseSensitive]);
end;
destructor TRawUTF8ObjectCacheList.Destroy;
begin
inherited Destroy;
fPurgeForceList.Free;
end;
procedure TRawUTF8ObjectCacheList.Log(const TextFmt: RawUTF8; const TextArgs: array of const;
Level: TSynLogInfo);
begin
{$ifdef WITHLOG}
if (self=nil) or (fLog=nil) then
exit;
if Level=sllNone then
Level := fLogEvent;
fLog.SynLog.Log(Level, TextFmt, TextArgs, self);
{$endif}
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)) or
(fPurgeForceList.Count > 0) then
DoPurge;
finally
fSafe.UnLock;
end;
end;
procedure TRawUTF8ObjectCacheList.AddToPurge(const Key: RawUTF8);
var i: PtrInt;
begin
fSafe.Lock;
try
i := IndexOf(Key);
if i>=0 then
fPurgeForceList.Add(Key);
finally
fSafe.UnLock;
end;
end;
procedure TRawUTF8ObjectCacheList.ForceCacheClear;
var i: integer;
cache: TRawUTF8ObjectCache;
{$ifdef WITHLOG}
log: ISynLog; // for Enter auto-leave to work with FPC
{$endif}
begin
fSafe.Lock;
try
{$ifdef WITHLOG}
log := fLog.SynLog.Enter('ForceCacheClear of % entries',[fCount],self);
{$endif}
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,n: integer;
purged: RawUTF8;
cache: TRawUTF8ObjectCache;
{$ifdef WITHLOG}
log: ISynLog; // for Enter auto-leave to work with FPC
{$endif}
procedure InternalPurge(nochecktimeout: boolean);
begin // test again the timeout after acquiring the TRawUTF8ObjectCache lock
try
cache.Safe.Lock;
if nochecktimeout or ((cache.fTimeoutTix > 0) and (tix > cache.fTimeoutTix)) then begin
{$ifdef WITHLOG}
if log = nil then
log := fLog.SynLog.Enter('DoPurge(%)', [fClass], self);
{$endif}
cache.CacheClear;
purged := purged + ' ' + cache.fKey;
end;
finally
cache.Safe.UnLock;
end;
end;
begin // called within fSafe.Lock
tix := GetTickCount64;
try
n := fPurgeForceList.Count;
if n > 0 then begin
for i := 0 to n - 1 do begin
cache := GetObjectFrom(fPurgeForceList.Strings[i]);
InternalPurge(true);
end;
fPurgeForceList.Clear;
end;
for i := 0 to fCount - 1 do begin
cache := TRawUTF8ObjectCache(fObjects[i]);
if (cache.fTimeoutTix > 0) and (tix > cache.fTimeoutTix) then
InternalPurge({checktimeout=}true);
end;
{$ifdef WITHLOG}
if log <> nil then
log.Log(fLogEvent, '%.ReleaseServices:% - count=%', [fClass, purged, fCount], self);
{$endif}
finally
fNextPurgeTix := tix + fSettings.PurgePeriodMS;
end;
end;
function TRawUTF8ObjectCacheList.GetLocked(const Key: RawUTF8;
out cache: TRawUTF8ObjectCache; onlyexisting: boolean): boolean;
begin
result := false;
if Key = '' then
exit;
fSafe.Lock;
try
if ((fNextPurgeTix <> 0) and (GetTickCount64 > fNextPurgeTix)) or
(fPurgeForceList.Count > 0) then
DoPurge; // inline TryPurge within the locked list
cache := GetObjectFrom(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;
AddObjectUnique(Key,@cache);
Log('GetLocked: Added %[%] - count=%', [fClass, Key, fCount])
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;
{ TAlgoDeflate }
type // implements the AlgoDeflate global variable
TAlgoDeflate = class(TAlgoCompressWithNoDestLen)
protected
fDeflateLevel: integer;
function RawProcess(src,dst: pointer; srcLen,dstLen,dstMax: integer;
process: TAlgoCompressWithNoDestLenProcess): integer; override;
public
constructor Create; override;
function AlgoID: byte; override;
function AlgoCompressDestLen(PlainLen: integer): integer; override;
end;
constructor TAlgoDeflate.Create;
begin
inherited Create;
fDeflateLevel := 6;
end;
function TAlgoDeflate.AlgoID: byte;
begin
result := 2;
end;
function TAlgoDeflate.RawProcess(src,dst: pointer; srcLen,dstLen,dstMax: integer;
process: TAlgoCompressWithNoDestLenProcess): integer;
begin
case process of
doCompress:
result := SynZip.CompressMem(src,dst,srcLen,dstLen,fDeflateLevel);
doUnCompress, doUncompressPartial:
result := SynZip.UnCompressMem(src,dst,srcLen,dstLen);
else
result := 0;
end;
end;
function TAlgoDeflate.AlgoCompressDestLen(PlainLen: integer): integer;
begin
result := PlainLen+256+PlainLen shr 3;
end;
{ TAlgoDeflateFast }
type // implements the AlgoDeflateFast global variable
TAlgoDeflateFast = class(TAlgoDeflate)
public
constructor Create; override;
function AlgoID: byte; override;
end;
function TAlgoDeflateFast.AlgoID: byte;
begin
result := 3;
end;
constructor TAlgoDeflateFast.Create;
begin
inherited Create;
fDeflateLevel := 1;
end;
{ TServiceMethod }
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;
temp: TTextWriterStackBuffer;
begin
W := TTextWriter.CreateOwnedStream(temp);
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.ArgsCommandLineToObject(P: PUTF8Char;
Input, RaiseExceptionOnUnknownParam: boolean): RawUTF8;
var i: integer;
W: TTextWriter;
B: PUTF8Char;
arginfo: PServiceMethodArgument;
arg, value: RawUTF8;
ok: boolean;
temp: TTextWriterStackBuffer;
begin
W := TTextWriter.CreateOwnedStream(temp);
try
W.Add('{');
while (P<>nil) and GetNextFieldProp(P,arg) and (P<>nil) and (arg<>'') do begin
ok := true;
i := ArgIndex(pointer(arg),length(arg),Input);
if i<0 then
if RaiseExceptionOnUnknownParam then
raise EServiceException.CreateUTF8('Unexpected [%] parameter for %',
[arg,InterfaceDotMethodName]) else
ok := false;
arginfo := @Args[i];
if ok then
W.AddPropName(arginfo^.ParamName^);
if not (P^ in [':','=']) then
raise EServiceException.CreateUTF8('"%" parameter has no = for %',
[arg,InterfaceDotMethodName]);
P := GotoNextNotSpace(P+1);
if P^ in ['"','[','{'] then begin // name='"value"' or name='{somejson}'
B := P;
P := GotoEndJSONItem(P);
if P = nil then
raise EServiceException.CreateUTF8('%= parameter has invalid content for %',
[arg,InterfaceDotMethodName]);
if not ok then
continue;
W.AddNoJSONEscape(B,P-B);
end else begin // name=value
GetNextItem(P,' ',value);
if not ok then
continue;
if arginfo^.ValueType=smvDynArray then // write [value] or ["value"]
W.Add('[');
if arginfo^.ValueKindAsm*[vIsString,vIsDynArrayString]<>[] then
W.AddJSONString(value) else
W.AddNoJSONEscape(pointer(value),length(value));
if arginfo^.ValueType=smvDynArray then
W.Add(']');
end;
W.Add(',');
end;
W.CancelLastComma;
W.Add('}');
W.SetText(result);
finally
W.Free;
end;
end;
function TServiceMethod.ArgsNames(Input: Boolean): TRawUTF8DynArray;
var a,n: integer;
begin
result := nil;
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
Dest.InitFast(ArgsInputValuesCount,dvObject);
for a := ArgsInFirst to ArgsInLast do
if Args[a].ValueDirection in [smdConst,smdVar] then
Args[a].AddAsVariant(Dest,Values[a]);
end else begin
Dest.InitFast(ArgsOutputValuesCount,dvObject);
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
Wrapper.InitFrom(DynArrayWrapper,Value);
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;
Value: PPointer;
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);
end;
Value := @fValues[1];
for a := 1 to high(Args) do
with Args[a] do begin
case ValueVar of
smvv64:
Value^ := @fInt64s[IndexVar];
smvvRawUTF8:
Value^ := @fRawUTF8s[IndexVar];
smvvString:
Value^ := @fStrings[IndexVar];
smvvWideString:
Value^ := @fWideStrings[IndexVar];
smvvObject: begin
Value^ := @fObjects[IndexVar];
PPointer(Value^)^ := ArgTypeInfo^.ClassCreate;
end;
smvvInterface:
Value^ := @fInterfaces[IndexVar];
smvvRecord: begin
Value^ := pointer(fRecords[IndexVar]);
if fAlreadyExecuted then
FillCharFast(Value^^,ArgTypeInfo^.RecordType^.Size,0);
end;
smvvDynArray:
Value^ := @fDynArrays[IndexVar].Value;
else raise EInterfaceFactoryException.CreateUTF8('I%.%:% ValueType=%',
[InterfaceDotMethodName,ParamName^,ArgTypeName^,ord(ValueType)]);
end;
inc(Value);
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;
{$ifndef MSWINDOWS} // ensure always aligned by 16 bytes on POSIX
while call.StackSize and 15<>0 do
inc(call.StackSize,PTRSIZ); // needed for Darwin and Linux i386
{$endif MSWINDOWS}
{$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]);
{$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);
{$else}
call.StackSize := ArgsSizeInStack shr 2;
{$endif CPUAARCH64}
{$endif CPUINTEL}
{$endif CPUX86}
for a := 1 to length(Args)-1 do
with Args[a] do begin
Value := fValues[a];
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] := unaligned(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
//Pass the self (also named $this)
call.ParamRegs[PARAMREG_FIRST] := PtrInt(Instances[i]);
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
fCurrentStep := smsError;
if fOnExecute<>nil then begin
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;
if (InstancesLast=0) and not (optIgnoreException in Options) then
raise; // single caller expects exception to be propagated
if fExecutedInstancesFailed=nil then // multiple Instances[] execution
SetLength(fExecutedInstancesFailed,InstancesLast+1);
fExecutedInstancesFailed[i] := ObjectToJSONDebug(Exc);
end;
end;
end;
end;
end;
function TServiceMethodExecute.TempTextWriter: TJSONSerializer;
begin
if fTempTextWriter=nil then begin
fTempTextWriter := TJSONSerializer.CreateOwnedStream;
fTempTextWriter.fCustomOptions := fTempTextWriter.fCustomOptions +
[twoForceJSONExtended,twoIgnoreDefaultInRecord]; // 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, and set Value^=nil
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.ExecuteJsonCallback(Instance: pointer;
const params: RawUTF8; output: PRawUTF8): boolean;
var tmp: TSynTempBuffer;
fake: TInterfacedObjectFake;
WR: TTextWriter;
n: integer;
begin
result := false;
if Instance=nil then
exit;
if (PCardinal(PPointer(PPointer(Instance)^)^)^=
PCardinal(@TInterfacedObjectFake.FakeQueryInterface)^) then begin
fake := TInterfacedObjectFake(Instance).SelfFromInterface;
if Assigned(fake.fInvoke) then begin
// call SOA/fake interface? -> bypass all JSON marshalling
if (output=nil) and (fMethod^.ArgsOutputValuesCount>0) then
exit; // ensure a function has a TOnAsynchRedirectResult callback
result := fake.fInvoke(fMethod^,params,output,nil,nil,nil);
exit;
end;
end;
n := length(params);
tmp.Init(n+2);
try
PAnsiChar(tmp.buf)[0] := '[';
MoveFast(pointer(params)^,PAnsiChar(tmp.buf)[1],n);
PWord(PAnsiChar(tmp.buf)+n+1)^ := ord(']'); // ']'#0
if output<>nil then begin
WR := TempTextWriter;
WR.CancelAll;
end else
if fMethod^.ArgsOutputValuesCount>0 then
exit else // ensure a function has a TOnAsynchRedirectResult callback
WR := nil;
result := ExecuteJson([Instance],tmp.buf,WR);
if WR<>nil then
WR.SetText(output^);
finally
tmp.Done;
end;
end;
function TServiceMethodExecute.ExecuteJsonFake(Instance: pointer; params: PUTF8Char): boolean;
var tmp: RawUTF8;
len: integer;
begin
result := false;
if not Assigned(TInterfacedObjectFake(Instance).fInvoke) then
exit;
if params<>nil then begin
if params^<>'[' then
exit;
inc(params);
len := StrLen(params);
if params[len-1]=']' then
dec(len);
FastSetString(tmp,params,len);
end;
result := TInterfacedObjectFake(Instance).fInvoke(fMethod^,tmp,nil,nil,nil,nil);
end;
function TServiceMethodExecute.ExecuteJson(const Instances: array of pointer;
Par: PUTF8Char; Res: TTextWriter; Error: PShortString; ResAsJSONObject: boolean): boolean;
var a,a1: integer;
Val, Name: PUTF8Char;
NameLen: integer;
EndOfObject: AnsiChar;
opt: array[{smdVar=}boolean] of TTextWriterWriteObjectOptions;
ParObjValuesUsed: boolean;
ParObjValues: array[0..MAX_METHOD_ARGS-1] of PUTF8Char;
begin
result := false;
BeforeExecute;
with fMethod^ do
try
// validate input parameters
ParObjValuesUsed := false;
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
repeat inc(Par) until not(Par^ in [#1..' ']);
if Par^<>'}' then begin
ParObjValuesUsed := true;
FillCharFast(ParObjValues,(ArgsInLast+1)*SizeOf(pointer),0); // := nil
a1 := ArgsInFirst;
repeat
Name := GetJSONPropName(Par,@NameLen);
if Name=nil then
exit; // invalid JSON object in input
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='}');
end;
Par := nil;
end;
else if PInteger(Par)^=NULL_LOW then
Par := nil else
exit; // only support JSON array or JSON object as input
end;
end;
// decode input parameters (if any) in f*[]
if (Par=nil) and not ParObjValuesUsed 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 ParObjValuesUsed then
if ParObjValues[a]=nil then // missing parameter in input JSON
if optErrorOnMissingParam in Options then
exit else
continue else // ignore and leave void value by default
Par := ParObjValues[a] else // value to be retrieved from JSON object
if Par=nil then
break; // premature end of ..] (ParObjValuesUsed=false)
case ValueType of
smvInterface:
if Assigned(OnCallback) then
OnCallback(Par,ArgTypeInfo,fInterfaces[IndexVar]) else
raise EInterfaceFactoryException.CreateUTF8('OnCallback=nil for %(%: %)',
[InterfaceDotMethodName,ParamName^,ArgTypeName^]);
smvDynArray: begin
Par := fDynArrays[IndexVar].Wrapper.LoadFromJSON(Par);
if Par=nil then
exit;
IgnoreComma(Par);
end;
else
if not FromJSON(InterfaceDotMethodName,Par,fValues[a],Error
{$ifndef NOVARIANTS},JSON_OPTIONS[optVariantCopiedByReference in Options]{$endif}) then
exit;
end;
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 := HTTP_SUCCESS else
fServiceCustomAnswerStatus := Status;
Result := true;
exit;
end;
// write the '{"result":[...' array or object
opt[{smdVar=}false] := DEFAULT_WRITEOPTIONS[optDontStoreVoidJSON in Options];
opt[{smdVar=}true] := []; // let var params override void/default values
for a := ArgsOutFirst to ArgsOutLast do
with Args[a] do
if ValueDirection in [smdVar,smdOut,smdResult] then begin
if ResAsJSONObject then
Res.AddPropName(ParamName^);
case ValueType of
smvDynArray: begin
if vIsObjArray in ValueKindAsm then
Res.AddObjArrayJSON(fValues[a]^,opt[ValueDirection=smdVar]) else
Res.AddDynArrayJSON(fDynArrays[IndexVar].Wrapper);
Res.Add(',');
end;
else AddJSON(Res,fValues[a],opt[ValueDirection=smdVar]);
end;
end;
Res.CancelLastComma;
end;
Result := true;
finally
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;
{ 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
SleepHiRes(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;
id: RawUTF8;
begin
if fInstanceCreation=sicClientDriven then
notify := NotifyInstanceDestroyed else
notify := nil;
result := TInterfacedObjectFakeClient.Create(self,Invoke,notify);
if not fDelayedInstance and (fInstanceCreation=sicClientDriven) and
InternalInvoke(SERVICE_PSEUDO_METHOD[imInstance],'',@id) then
// thread-safe initialization of the fClientDrivenID
TInterfacedObjectFakeClient(result).fClientDrivenID := GetCardinal(pointer(id));
end;
type
TServiceFactoryClientNotificationThread = class(TSQLRestThread)
protected
fClient: TServiceFactoryClient;
fRemote: TSQLRestClientURI;
fRetryPeriodSeconds: 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;
inherited Create(fClient.fClient,false,false);
end;
function TServiceFactoryClientNotificationThread.GetPendingCountFromDB: Int64;
begin
if not fClient.fSendNotificationsRest.OneFieldValue(
fClient.fSendNotificationsLogClass,'count(*)','Sent is null',[],[],result) then
result := 0;
end;
procedure TServiceFactoryClientNotificationThread.ProcessPendingNotification;
var pending: TSQLRecordServiceNotifications;
params,error: RawUTF8;
client: cardinal;
pendings,count: integer;
timer: TPrecisionTimer;
begin // one at a time, since InternalInvoke() is the bottleneck
pending := fClient.fSendNotificationsLogClass.Create(
fClient.fSendNotificationsRest,'Sent is null order by id limit 1');
try
if pending.IDValue=0 then begin
pendings := GetPendingCountFromDB;
fSafe.LockedInt64[0] := pendings;
if pendings=0 then
exit else
raise EServiceException.CreateUTF8(
'%.ProcessPendingNotification pending=% with no DB row',[self,pendings]);
end;
pendings := fSafe.LockedInt64[0];
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,pendings,fRemote,error]);
end;
fClient.fClient.InternalLog('ProcessPendingNotification %(%) in % [ID=%,pending=%]',
[pending.Method,params,timer.Stop,pending.IDValue,pendings]);
pending.Sent := TimeLogNowUTC;
pending.MicroSec := timer.LastTimeInMicroSec;
fClient.fSendNotificationsRest.Update(pending,'MicroSec,Sent',true);
fSafe.LockedInt64Increment(0,-1);
finally
pending.Free;
end;
end;
procedure TServiceFactoryClientNotificationThread.InternalExecute;
var delay: integer;
begin
fSafe.LockedInt64[0] := GetPendingCountFromDB;
delay := 50;
while not Terminated do begin
while fSafe.LockedInt64[0]>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) and (aClientDrivenID^<>0) then begin
pending.Session := aClientDrivenID^;
fSendNotificationsRest.Add(pending,'Method,Input,Session');
end else
fSendNotificationsRest.Add(pending,'Method,Input');
finally
pending.Free;
end;
end;
begin
if (fSendNotificationsRest<>nil) and (aMethod.ArgsOutputValuesCount=0) then begin
SendNotificationsLog;
if fSendNotificationsThread<>nil then
TServiceFactoryClientNotificationThread(fSendNotificationsThread).
Safe.LockedInt64Increment(0,1);
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
HTTP_UNAVAILABLE: result := 'Check the communication parameters and network config';
HTTP_NOTIMPLEMENTED: result := 'Server not reachable or broken connection';
HTTP_NOTALLOWED: result := 'Method forbidden for this User group';
HTTP_UNAUTHORIZED: result := 'No active session';
HTTP_FORBIDDEN: result := 'Security error';
HTTP_NOTACCEPTABLE: result := 'Invalid input parameters';
HTTP_NOTFOUND: result := 'Network problem or request timeout';
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 baseuri,uri,sent,resp,clientDrivenID,head,error,ct: RawUTF8;
Values: array[0..1] of TValuePUTF8Char;
status,m: integer;
service: PServiceMethod;
ctxt: TSQLRestServerURIContextClientInvoke;
withinput: boolean;
{$ifdef WITHLOG}
log: ISynLog; // for Enter auto-leave to work with FPC
p: RawUTF8;
{$endif}
procedure DoClientCall;
begin
uri := baseuri;
fRest.ServicesRouting.ClientSideInvoke(uri,ctxt,aMethod,aParams,clientDrivenID,sent,head);
if service<>nil then begin // ParamsAsJSONObject won't apply to _signature_ e.g.
if fParamsAsJSONObject and (clientDrivenID='') then
sent := service^.ArgsArrayToObject(Pointer(sent),true);
if fNonBlockWithoutAnswer and (head='') and (Service^.ArgsOutputValuesCount=0) then
aClient.CallbackNonBlockingSetHeader(head);
end;
status := aClient.URI(uri,'POST',@resp,@head,@sent).Lo;
end;
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);
if m<0 then
service := nil else
service := @fInterface.Methods[m];
withinput := ((service=nil) or ([smdConst,smdVar]*service^.HasSPIParams=[])) and
not(optNoLogInput in fExecution[m].Options);
{$ifdef WITHLOG}
if withinput then
p := aParams; // include non-sensitive input in log
log := fRest.LogClass.Enter('InternalInvoke I%.%(%) %',
[fInterfaceURI,aMethod,p,clientDrivenID],self);
{$endif}
// call remote server according to current routing scheme
if fForcedURI<>'' then
baseuri := fForcedURI else
if fRest.Services.ExpectMangledURI then
baseuri := aClient.Model.Root+'/'+fInterfaceMangledURI else
baseuri := aClient.Model.Root+'/'+fInterfaceURI;
ctxt := [];
if (service<>nil) and not ParamsAsJSONObject and service^.ArgsInputIsOctetStream then
include(ctxt,csiAsOctetStream);
DoClientCall;
if (status=HTTP_UNAUTHORIZED) and (clientDrivenID<>'') and
(fInstanceCreation=sicClientDriven) and (aClientDrivenID<>nil) then begin
{$ifdef WITHLOG}
if log<>nil then
log.Log(sllClient,'% -> try to recreate ClientDrivenID',[resp],self);
{$endif}
clientDrivenID := '';
aClientDrivenID^ := 0;
DoClientCall;
end;
// 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
StatusCodeToErrorMessage(status,resp);
error := GetErrorMessage(status);
if error<>'' then
error := ' - '+error;
if not withinput then
sent := ''; // exclude sensitive input in error text
aErrorMsg^ := FormatUTF8('URI % % returned status ''%'' (%%)',
[uri,sent,resp,status,error]);
end else
aErrorMsg^ := resp;
end;
exit; // leave result=false
end;
// decode JSON object
{$ifdef WITHLOG}
if (log<>nil) and (resp<>'') and not(optNoLogOutput in fExecution[m].Options) and
((service=nil) or ([smdConst,smdVar]*service^.HasSPIParams=[])) then
with fRest.fLogFamily do
if sllServiceReturn in Level then
log.Log(sllServiceReturn,resp,self,MAX_SIZE_RESPONSE_LOG);
{$endif WITHLOG}
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
if (JSONDecode(pointer(resp),['result','id'],@Values,true)=nil) or
(Values[0].Value=nil) then begin // no "result":... layout
if aErrorMsg<>nil then begin
UniqueRawUTF8ZeroToTilde(resp,1 shl 10);
aErrorMsg^ := 'Invalid returned JSON content: expects {result:...}, got '+resp;
end;
exit; // leave result=false
end;
if aResult<>nil then
Values[0].ToUTF8(aResult^);
if (aClientDrivenID<>nil) and (Values[1].Value<>nil) then // keep ID if no "id":...
aClientDrivenID^ := Values[1].ToCardinal;
end;
end else begin
// custom answer returned in TServiceCustomAnswer
{$ifdef WITHLOG}
if (log<>nil) and (resp<>'') then
with fRest.fLogFamily do
if sllServiceReturn in Level then begin
FindNameValue(head,HEADER_CONTENT_TYPE_UPPER,ct);
if (resp[1] in ['[','{','"']) and IdemPChar(pointer(ct), JSON_CONTENT_TYPE_UPPER) then
log.Log(sllServiceReturn,resp,self,MAX_SIZE_RESPONSE_LOG) else
log.Log(sllServiceReturn,'TServiceCustomAnswer=% % len=% %',
[status,ct,length(resp),EscapeToShort(resp)],self);
end;
{$endif WITHLOG}
aServiceCustomAnswer^.Status := status;
aServiceCustomAnswer^.Header := head;
aServiceCustomAnswer^.Content := resp;
// no "id" field returned, but aClientDrivenID^ should not change
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]);
if fClient=nil then
fClient := TSQLRestClientURI(aRest);
inherited Create(aRest,aInterface,aInstanceCreation,aContractExpected);
// initialize a shared instance (if needed)
case fInstanceCreation of
sicShared,sicPerSession,sicPerUser,sicPerGroup,sicPerThread: begin
// the instance shall remain active during the whole client session
fSharedInstance := CreateFakeInstance;
TInterfacedObjectFake(fSharedInstance)._AddRef; // force stay alive
end;
end;
// check if this interface is supported on the server
if PosEx(SERVICE_CONTRACT_NONE_EXPECTED,ContractExpected)=0 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 % - you may need to '+
'upgrade your % client to match % server expectations',
[self,fInterfaceURI,ContractExpected,RemoteContract,
ExeVersion.Version.DetailedOrVoid,fClient.fSessionVersion]);
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]);
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;
{$ifdef WITHLOG}
log: ISynLog; // for Enter auto-leave to work with FPC
{$endif}
begin
if SendNotificationsPending=0 then
exit;
{$ifdef WITHLOG}
log := fClient.LogClass.Enter;
{$endif}
timeOut := GetTickCount64+aTimeOutSeconds*1000;
repeat
SleepHiRes(5);
if SendNotificationsPending=0 then
exit;
until GetTickCount64>timeOut;
end;
procedure TServiceFactoryClient.SetOptions(const aMethod: array of RawUTF8;
aOptions: TServiceMethodOptions; aAction: TServiceMethodOptionsAction);
var o: TServiceMethodOption;
begin
for o := low(o) to high(o) do
if (o in aOptions) and not (o in [optNoLogInput..optErrorOnMissingParam]) then
raise EServiceException.CreateUTF8('%.SetOptions(%) not supported',
[self,GetEnumName(TypeInfo(TServiceMethodOption),ord(o))^]);
ExecutionAction(aMethod,aOptions,aAction);
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(PtrUInt(aClass))+vmtAutoTable);
if PVMT^=nil then begin
EnterCriticalSection(vmtAutoTableLock); // protect from concurrent access
try
if PVMT^=nil then begin
PatchCodePtrUInt(pointer(PVMT),PtrUInt(self),true); // LeaveUnprotected=true
GarbageCollectorFreeAndNil(PVMT^,self); // set to nil at finalization
end;
finally
LeaveCriticalSection(vmtAutoTableLock);
end;
end;
if (PVMT^<>nil) and (PVMT^<>self) then
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(PtrUInt(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 HASINLINENOTX86}inline;{$endif}
begin
result := PPointer(PPtrInt(aObject)^+vmtAutoTable)^;
if (result<>nil) and (TClass(PPointer(result)^)=TSQLRecordProperties) then
result := TSetWeakZeroClass(TSQLRecordProperties(pointer(result)).fWeakZeroClass);
if result<>nil then
EnterCriticalSection(result.fLock) else
if CreateIfNonExisting then
result := TSetWeakZeroClass.Create(PPointer(aObject)^);
end;
type
TSimpleMethodCall = procedure(self: TObject);
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;
r: PSQLRecord;
begin
r := pointer(a);
for i := 1 to length(a) do begin
result := r^;
if result.fID=aID then
exit;
inc(r);
end;
result := nil;
end;
procedure ObjArrayRecordIDs(const aSQLRecordObjArray; out result: TInt64DynArray);
var
i, n: PtrInt;
a: TSQLRecordObjArray absolute aSQLRecordObjArray;
begin
n := length(a);
SetLength(result,n);
for i := 0 to n-1 do
result[i] := a[i].fID;
end;
procedure ObjArrayCopy(const aSourceObjArray; var aDestObjArray;
aDestObjArrayClear: boolean);
var s: TObjectDynArray absolute aSourceObjArray;
d: TObjectDynArray absolute aDestObjArray;
slen,dlen: integer;
i: PtrInt;
dinst: TClassInstance;
o: TObject;
begin
if aDestObjArrayClear and (d<>nil) then
ObjArrayClear(d);
slen := length(s);
if slen=0 then
exit;
dlen := length(d);
SetLength(d,dlen+slen);
DInst.ItemClass := nil;
for i := 0 to slen-1 do
if s[i]<>nil then begin // inlined CopyObject()
if DInst.ItemClass<>PClass(s[i])^ then
DInst.Init(PClass(s[i])^); // very unlikely to change
o := DInst.CreateNew;
CopyObject(s[i],o);
d[dlen+i] := o;
end;
end;
procedure InterfaceArrayDeleteAfterException(var aInterfaceArray;
const aItemIndex: integer; aLog: TSynLogFamily; const aLogMsg: RawUTF8;
aInstance: TObject);
begin
try
{$ifdef WITHLOG}
aLog.SynLog.Log(sllWarning,'InterfaceArrayDeleteAfterException % (index=%)',
[aLogMsg,aItemIndex],aInstance);
{$endif}
InterfaceArrayDelete(aInterfaceArray,aItemIndex);
except
on E: Exception do
aLog.SynLog.Log(sllDebug,'Callback % unstability at deletion: %',
[aLogMsg,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 NOVARIANTS}
{$ifndef USENORMTOUPPER}
pointer(@SQLFieldTypeComp[sftUTF8Text]) := @AnsiIComp;
{$endif}
{$ifdef MSWINDOWS} // don't change the main process name under Linux
SetThreadNameDefault(GetCurrentThreadID,'Main Thread');
{$endif}
SetThreadNameInternal := SetThreadNameWithLog;
StatusCodeToErrorMessage := StatusCodeToErrorMsgBasic;
GarbageCollectorFreeAndNil(JSONCustomParsers,TSynDictionary.Create(
TypeInfo(TClassDynArray),TypeInfo(TJSONCustomParsers)));
DefaultTextWriterSerializer := TJSONSerializer;
TJSONSerializer.RegisterObjArrayForJSON(
[TypeInfo(TSQLModelRecordPropertiesObjArray),TSQLModelRecordProperties]);
TJSONSerializer.RegisterCustomJSONSerializerFromText(
[TypeInfo(TServicesPublishedInterfaces),_TServicesPublishedInterfaces,
TypeInfo(TSQLRestServerURI),_TSQLRestServerURI]);
SynCommons.DynArrayIsObjArray := InternalIsObjArray;
InitializeCriticalSection(GlobalInterfaceResolutionLock);
InitializeCriticalSection(vmtAutoTableLock);
TInterfaceResolverInjected.RegisterGlobal(TypeInfo(IAutoLocker),TAutoLocker);
TInterfaceResolverInjected.RegisterGlobal(TypeInfo(ILockedDocVariant),TLockedDocVariant);
assert(SizeOf(TServiceMethod)and 3=0,'wrong padding');
AlgoDeflate := TAlgoDeflate.Create;
AlgoDeflateFast := TAlgoDeflateFast.Create;
TSQLRestServerFullMemory.RegisterClassNameForDefinition;
{$ifdef MSWINDOWS}
TSQLRestClientURINamedPipe.RegisterClassNameForDefinition;
TSQLRestClientURIMessage.RegisterClassNameForDefinition;
{$endif}
{$ifdef GSSAPIAUTH}
LoadGSSAPI;
{$endif}
finalization
FinalizeGlobalInterfaceResolution;
end.
Reference in New Issue View Git Blame Copy Permalink