Skip to content
Permalink
Branch: master
Find file Copy path
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
13299 lines (12319 sloc) 462 KB
/// implement TSynTable/TSynTableStatement and TSynFilter/TSynValidate process
// - licensed under a MPL/GPL/LGPL tri-license; version 1.18
unit SynTable;
(*
This file is part of Synopse framework.
Synopse framework. Copyright (C) 2019 Arnaud Bouchez
Synopse Informatique - https://synopse.info
*** BEGIN LICENSE BLOCK *****
Version: MPL 1.1/GPL 2.0/LGPL 2.1
The contents of this file are subject to the Mozilla Public License Version
1.1 (the "License"); you may not use this file except in compliance with
the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
for the specific language governing rights and limitations under the License.
The Original Code is Synopse framework.
The Initial Developer of the Original Code is Arnaud Bouchez.
Portions created by the Initial Developer are Copyright (C) 2019
the Initial Developer. All Rights Reserved.
Contributor(s):
Alternatively, the contents of this file may be used under the terms of
either the GNU General Public License Version 2 or later (the "GPL"), or
the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
in which case the provisions of the GPL or the LGPL are applicable instead
of those above. If you wish to allow use of your version of this file only
under the terms of either the GPL or the LGPL, and not to allow others to
use your version of this file under the terms of the MPL, indicate your
decision by deleting the provisions above and replace them with the notice
and other provisions required by the GPL or the LGPL. If you do not delete
the provisions above, a recipient may use your version of this file under
the terms of any one of the MPL, the GPL or the LGPL.
***** END LICENSE BLOCK *****
Version 1.18
- initial release
- removed from SynCommons.pas, for better code clarity, and to reduce the
number of source code lines of the unit, and circumvent the Delphi 5/6/7
limitation of 65535 lines (internal error PRO-3006)
*)
interface
{$I Synopse.inc} // define HASINLINE USETYPEINFO CPU32 CPU64
uses
{$ifdef MSWINDOWS}
Windows,
{$else}
{$ifdef KYLIX3}
Types,
LibC,
SynKylix,
{$endif KYLIX3}
{$ifdef FPC}
Unix,
{$endif FPC}
{$endif MSWINDOWS}
SysUtils,
Classes,
{$ifndef LVCL}
SyncObjs, // for TEvent and TCriticalSection
Contnrs, // for TObjectList
{$endif}
{$ifndef NOVARIANTS}
Variants,
{$endif}
SynCommons;
{ ************ filtering and validation classes and functions ************** }
/// return TRUE if the supplied content is a valid email address
// - follows RFC 822, to validate local-part@domain email format
function IsValidEmail(P: PUTF8Char): boolean;
/// return TRUE if the supplied content is a valid IP v4 address
function IsValidIP4Address(P: PUTF8Char): boolean;
/// return TRUE if the supplied content matchs a glob pattern
// - ? Matches any single characer
// - * Matches any contiguous characters
// - [abc] Matches a or b or c at that position
// - [^abc] Matches anything but a or b or c at that position
// - [!abc] Matches anything but a or b or c at that position
// - [a-e] Matches a through e at that position
// - [abcx-z] Matches a or b or c or x or y or or z, as does [a-cx-z]
// - 'ma?ch.*' would match match.exe, mavch.dat, march.on, etc..
// - 'this [e-n]s a [!zy]est' would match 'this is a test', but would not
// match 'this as a test' nor 'this is a zest'
// - consider using TMatch or TMatchs if you expect to reuse the pattern
function IsMatch(const Pattern, Text: RawUTF8; CaseInsensitive: boolean=false): boolean;
/// return TRUE if the supplied content matchs a glob pattern, using VCL strings
// - is a wrapper around IsMatch() with fast UTF-8 conversion
function IsMatchString(const Pattern, Text: string; CaseInsensitive: boolean=false): boolean;
type
PMatch = ^TMatch;
TMatchSearchFunction = function(aMatch: PMatch; aText: PUTF8Char; aTextLen: PtrInt): boolean;
/// low-level structure used by IsMatch() for actual glob search
// - you can use this object to prepare a given pattern, e.g. in a loop
// - implemented as a fast brute-force state-machine without any heap allocation
// - some common patterns ('exactmatch', 'startwith*', '*endwith', '*contained*')
// are handled with dedicated code, optionally with case-insensitive search
// - consider using TMatchs (or SetMatchs/TMatchDynArray) if you expect to
// search for several patterns, or even TExprParserMatch for expression search
{$ifdef UNICODE}TMatch = record{$else}TMatch = object{$endif}
private
Pattern, Text: PUTF8Char;
P, T, PMax, TMax: PtrInt;
Upper: PNormTable;
State: (sNONE, sABORT, sEND, sLITERAL, sPATTERN, sRANGE, sVALID);
procedure MatchAfterStar;
procedure MatchMain;
public
/// published for proper inlining
Search: TMatchSearchFunction;
/// initialize the internal fields for a given glob search pattern
// - note that the aPattern instance should remain in memory, since it will
// be pointed to by the Pattern private field of this object
procedure Prepare(const aPattern: RawUTF8; aCaseInsensitive, aReuse: boolean); overload;
/// initialize the internal fields for a given glob search pattern
// - note that the aPattern buffer should remain in memory, since it will
// be pointed to by the Pattern private field of this object
procedure Prepare(aPattern: PUTF8Char; aPatternLen: integer;
aCaseInsensitive, aReuse: boolean); overload;
/// initialize low-level internal fields for'*aPattern*' search
// - this method is faster than a regular Prepare('*' + aPattern + '*')
// - warning: the supplied aPattern variable may be modified in-place to be
// filled with some lookup buffer, for length(aPattern) in [2..31] range
procedure PrepareContains(var aPattern: RawUTF8; aCaseInsensitive: boolean); overload;
/// initialize low-level internal fields for a custom search algorithm
procedure PrepareRaw(aPattern: PUTF8Char; aPatternLen: integer;
aSearch: TMatchSearchFunction);
/// returns TRUE if the supplied content matches the prepared glob pattern
// - this method is not thread-safe
function Match(const aText: RawUTF8): boolean; overload;
{$ifdef FPC}inline;{$endif}
/// returns TRUE if the supplied content matches the prepared glob pattern
// - this method is not thread-safe
function Match(aText: PUTF8Char; aTextLen: PtrInt): boolean; overload;
{$ifdef HASINLINE}inline;{$endif}
/// returns TRUE if the supplied content matches the prepared glob pattern
// - this method IS thread-safe, and won't lock
function MatchThreadSafe(const aText: RawUTF8): boolean;
/// returns TRUE if the supplied VCL/LCL content matches the prepared glob pattern
// - this method IS thread-safe, will use stack to UTF-8 temporary conversion
// if possible, and won't lock
function MatchString(const aText: string): boolean;
/// returns TRUE if this search pattern matches another
function Equals(const aAnother{$ifndef DELPHI5OROLDER}: TMatch{$endif}): boolean;
{$ifdef HASINLINE}inline;{$endif}
/// access to the pattern length as stored in PMax + 1
function PatternLength: integer; {$ifdef HASINLINE}inline;{$endif}
/// access to the pattern text as stored in Pattern
function PatternText: PUTF8Char; {$ifdef HASINLINE}inline;{$endif}
end;
/// use SetMatchs() to initialize such an array from a CSV pattern text
TMatchDynArray = array of TMatch;
/// TMatch descendant owning a copy of the Pattern string to avoid GPF issues
TMatchStore = record
/// access to the research criteria
// - defined as a nested record (and not an object) to circumvent Delphi bug
Pattern: TMatch;
/// Pattern.Pattern PUTF8Char will point to this instance
PatternInstance: RawUTF8;
end;
TMatchStoreDynArray = array of TMatchStore;
/// stores several TMatch instances, from a set of glob patterns
TMatchs = class(TSynPersistent)
protected
fMatch: TMatchStoreDynArray;
fMatchCount: integer;
public
/// add once some glob patterns to the internal TMach list
// - aPatterns[] follows the IsMatch() syntax
constructor Create(const aPatterns: TRawUTF8DynArray; CaseInsensitive: Boolean); reintroduce; overload;
/// add once some glob patterns to the internal TMach list
// - aPatterns[] follows the IsMatch() syntax
procedure Subscribe(const aPatterns: TRawUTF8DynArray; CaseInsensitive: Boolean); overload; virtual;
/// add once some glob patterns to the internal TMach list
// - each CSV item in aPatterns follows the IsMatch() syntax
procedure Subscribe(const aPatternsCSV: RawUTF8; CaseInsensitive: Boolean); overload;
/// search patterns in the supplied UTF-8 text
// - returns -1 if no filter has been subscribed
// - returns -2 if there is no match on any previous pattern subscription
// - returns fMatch[] index, i.e. >= 0 number on first matching pattern
// - this method is thread-safe
function Match(const aText: RawUTF8): integer; overload; {$ifdef HASINLINE}inline;{$endif}
/// search patterns in the supplied UTF-8 text buffer
function Match(aText: PUTF8Char; aLen: integer): integer; overload;
/// search patterns in the supplied VCL/LCL text
// - could be used on a TFileName for instance
// - will avoid any memory allocation if aText is small enough
function MatchString(const aText: string): integer;
end;
/// fill the Match[] dynamic array with all glob patterns supplied as CSV
// - returns how many patterns have been set in Match[|]
// - note that the CSVPattern instance should remain in memory, since it will
// be pointed to by the Match[].Pattern private field
function SetMatchs(const CSVPattern: RawUTF8; CaseInsensitive: boolean;
out Match: TMatchDynArray): integer; overload;
/// fill the Match[0..MatchMax] static array with all glob patterns supplied as CSV
// - note that the CSVPattern instance should remain in memory, since it will
// be pointed to by the Match[].Pattern private field
function SetMatchs(CSVPattern: PUTF8Char; CaseInsensitive: boolean;
Match: PMatch; MatchMax: integer): integer; overload;
/// search if one TMach is already registered in the Several[] dynamic array
function MatchExists(const One: TMatch; const Several: TMatchDynArray): boolean;
/// add one TMach if not already registered in the Several[] dynamic array
function MatchAdd(const One: TMatch; var Several: TMatchDynArray): boolean;
/// returns TRUE if Match=nil or if any Match[].Match(Text) is TRUE
function MatchAny(const Match: TMatchDynArray; const Text: RawUTF8): boolean;
/// apply the CSV-supplied glob patterns to an array of RawUTF8
// - any text not maching the pattern will be deleted from the array
procedure FilterMatchs(const CSVPattern: RawUTF8; CaseInsensitive: boolean;
var Values: TRawUTF8DynArray);
type
TSynFilterOrValidate = class;
TSynFilterOrValidateObjArray = array of TSynFilterOrValidate;
TSynFilterOrValidateObjArrayArray = array of TSynFilterOrValidateObjArray;
/// will define a filter (transformation) or a validation process to be
// applied to a database Record content (typicaly a TSQLRecord)
// - the optional associated parameters are to be supplied JSON-encoded
TSynFilterOrValidate = class
protected
fParameters: RawUTF8;
/// children must override this method in order to parse the JSON-encoded
// parameters, and store it in protected field values
procedure SetParameters(const Value: RawUTF8); virtual;
public
/// add the filter or validation process to a list, checking if not present
// - if an instance with the same class type and parameters is already
// registered, will call aInstance.Free and return the exising instance
// - if there is no similar instance, will add it to the list and return it
function AddOnce(var aObjArray: TSynFilterOrValidateObjArray;
aFreeIfAlreadyThere: boolean=true): TSynFilterOrValidate;
public
/// initialize the filter (transformation) or validation instance
// - most of the time, optional parameters may be specified as JSON,
// possibly with the extended MongoDB syntax
constructor Create(const aParameters: RawUTF8=''); overload; virtual;
/// initialize the filter or validation instance
/// - this overloaded constructor will allow to easily set the parameters
constructor CreateUTF8(const Format: RawUTF8; const Args, Params: array of const); overload;
/// the optional associated parameters, supplied as JSON-encoded
property Parameters: RawUTF8 read fParameters write SetParameters;
end;
/// will define a validation to be applied to a Record (typicaly a TSQLRecord)
// field content
// - a typical usage is to validate an email or IP adress e.g.
// - the optional associated parameters are to be supplied JSON-encoded
TSynValidate = class(TSynFilterOrValidate)
public
/// perform the validation action to the specified value
// - the value is expected by be UTF-8 text, as generated by
// TPropInfo.GetValue e.g.
// - if the validation failed, must return FALSE and put some message in
// ErrorMsg (translated into the current language: you could e.g. use
// a resourcestring and a SysUtils.Format() call for automatic translation
// via the mORMoti18n unit - you can leave ErrorMsg='' to trigger a
// generic error message from clas name ('"Validate email" rule failed'
// for TSynValidateEmail class e.g.)
// - if the validation passed, will return TRUE
function Process(FieldIndex: integer; const Value: RawUTF8; var ErrorMsg: string): boolean;
virtual; abstract;
end;
/// points to a TSynValidate variable
// - used e.g. as optional parameter to TSQLRecord.Validate/FilterAndValidate
PSynValidate = ^TSynValidate;
/// IP v4 address validation to be applied to a Record field content
// (typicaly a TSQLRecord)
// - this versions expect no parameter
TSynValidateIPAddress = class(TSynValidate)
protected
public
/// perform the IP Address validation action to the specified value
function Process(aFieldIndex: integer; const Value: RawUTF8;
var ErrorMsg: string): boolean; override;
end;
/// IP address validation to be applied to a Record field content
// (typicaly a TSQLRecord)
// - optional JSON encoded parameters are "AllowedTLD" or "ForbiddenTLD",
// expecting a CSV lis of Top-Level-Domain (TLD) names, e.g.
// $ '{"AllowedTLD":"com,org,net","ForbiddenTLD":"fr"}'
// $ '{AnyTLD:true,ForbiddenDomains:"mailinator.com,yopmail.com"}'
// - this will process a validation according to RFC 822 (calling the
// IsValidEmail() function) then will check for the TLD to be in one of
// the Top-Level domains ('.com' and such) or a two-char country, and
// then will check the TLD according to AllowedTLD and ForbiddenTLD
TSynValidateEmail = class(TSynValidate)
private
fAllowedTLD: RawUTF8;
fForbiddenTLD: RawUTF8;
fForbiddenDomains: RawUTF8;
fAnyTLD: boolean;
protected
/// decode all published properties from their JSON representation
procedure SetParameters(const Value: RawUTF8); override;
public
/// perform the Email Address validation action to the specified value
// - call IsValidEmail() function and check for the supplied TLD
function Process(aFieldIndex: integer; const Value: RawUTF8; var ErrorMsg: string): boolean; override;
/// allow any TLD to be allowed, even if not a generic TLD (.com,.net ...)
// - this may be mandatory since already over 1,300 new gTLD names or
// "strings" could become available in the next few years: there is a
// growing list of new gTLDs available at
// @http://newgtlds.icann.org/en/program-status/delegated-strings
// - the only restriction is that it should be ascii characters
property AnyTLD: boolean read fAnyTLD write fAnyTLD;
/// a CSV list of allowed TLD
// - if accessed directly, should be set as lower case values
// - e.g. 'com,org,net'
property AllowedTLD: RawUTF8 read fAllowedTLD write fAllowedTLD;
/// a CSV list of forbidden TLD
// - if accessed directly, should be set as lower case values
// - e.g. 'fr'
property ForbiddenTLD: RawUTF8 read fForbiddenTLD write fForbiddenTLD;
/// a CSV list of forbidden domain names
// - if accessed directly, should be set as lower case values
// - not only the TLD, but whole domains like 'cracks.ru,hotmail.com' or such
property ForbiddenDomains: RawUTF8 read fForbiddenDomains write fForbiddenDomains;
end;
/// glob case-sensitive pattern validation of a Record field content
// - parameter is NOT JSON encoded, but is some basic TMatch glob pattern
// - ? Matches any single characer
// - * Matches any contiguous characters
// - [abc] Matches a or b or c at that position
// - [^abc] Matches anything but a or b or c at that position
// - [!abc] Matches anything but a or b or c at that position
// - [a-e] Matches a through e at that position
// - [abcx-z] Matches a or b or c or x or y or or z, as does [a-cx-z]
// - 'ma?ch.*' would match match.exe, mavch.dat, march.on, etc..
// - 'this [e-n]s a [!zy]est' would match 'this is a test', but would not
// match 'this as a test' nor 'this is a zest'
// - pattern check IS case sensitive (TSynValidatePatternI is not)
// - this class is not as complete as PCRE regex for example,
// but code overhead is very small, and speed good enough in practice
TSynValidatePattern = class(TSynValidate)
protected
fMatch: TMatch;
procedure SetParameters(const Value: RawUTF8); override;
public
/// perform the pattern validation to the specified value
// - pattern can be e.g. '[0-9][0-9]:[0-9][0-9]:[0-9][0-9]'
// - this method will implement both TSynValidatePattern and
// TSynValidatePatternI, checking the current class
function Process(aFieldIndex: integer; const Value: RawUTF8;
var ErrorMsg: string): boolean; override;
end;
/// glob case-insensitive pattern validation of a text field content
// (typicaly a TSQLRecord)
// - parameter is NOT JSON encoded, but is some basic TMatch glob pattern
// - same as TSynValidatePattern, but is NOT case sensitive
TSynValidatePatternI = class(TSynValidatePattern);
/// text validation to ensure that to any text field would not be ''
TSynValidateNonVoidText = class(TSynValidate)
public
/// perform the non void text validation action to the specified value
function Process(aFieldIndex: integer; const Value: RawUTF8;
var ErrorMsg: string): boolean; override;
end;
TSynValidateTextProps = array[0..15] of cardinal;
{$M+} // to have existing RTTI for published properties
/// text validation to be applied to any Record field content
// - default MinLength value is 1, MaxLength is maxInt: so a blank
// TSynValidateText.Create('') is the same as TSynValidateNonVoidText
// - MinAlphaCount, MinDigitCount, MinPunctCount, MinLowerCount and
// MinUpperCount allow you to specify the minimal count of respectively
// alphabetical [a-zA-Z], digit [0-9], punctuation [_!;.,/:?%$="#@(){}+-*],
// lower case or upper case characters
// - expects optional JSON parameters of the allowed text length range as
// $ '{"MinLength":5,"MaxLength":10,"MinAlphaCount":1,"MinDigitCount":1,
// $ "MinPunctCount":1,"MinLowerCount":1,"MinUpperCount":1}
TSynValidateText = class(TSynValidate)
private
/// used to store all associated validation properties by index
fProps: TSynValidateTextProps;
fUTF8Length: boolean;
protected
/// use sInvalidTextChar resourcestring to create a translated error message
procedure SetErrorMsg(fPropsIndex, InvalidTextIndex, MainIndex: integer;
var result: string);
/// decode "MinLength", "MaxLength", and other parameters into fProps[]
procedure SetParameters(const Value: RawUTF8); override;
public
/// perform the text length validation action to the specified value
function Process(aFieldIndex: integer; const Value: RawUTF8;
var ErrorMsg: string): boolean; override;
published
/// Minimal length value allowed for the text content
// - the length is calculated with UTF-16 Unicode codepoints, unless
// UTF8Length has been set to TRUE so that the UTF-8 byte count is checked
// - default is 1, i.e. a void text will not pass the validation
property MinLength: cardinal read fProps[0] write fProps[0];
/// Maximal length value allowed for the text content
// - the length is calculated with UTF-16 Unicode codepoints, unless
// UTF8Length has been set to TRUE so that the UTF-8 byte count is checked
// - default is maxInt, i.e. no maximum length is set
property MaxLength: cardinal read fProps[1] write fProps[1];
/// Minimal alphabetical character [a-zA-Z] count
// - default is 0, i.e. no minimum set
property MinAlphaCount: cardinal read fProps[2] write fProps[2];
/// Maximal alphabetical character [a-zA-Z] count
// - default is maxInt, i.e. no Maximum set
property MaxAlphaCount: cardinal read fProps[10] write fProps[10];
/// Minimal digit character [0-9] count
// - default is 0, i.e. no minimum set
property MinDigitCount: cardinal read fProps[3] write fProps[3];
/// Maximal digit character [0-9] count
// - default is maxInt, i.e. no Maximum set
property MaxDigitCount: cardinal read fProps[11] write fProps[11];
/// Minimal punctuation sign [_!;.,/:?%$="#@(){}+-*] count
// - default is 0, i.e. no minimum set
property MinPunctCount: cardinal read fProps[4] write fProps[4];
/// Maximal punctuation sign [_!;.,/:?%$="#@(){}+-*] count
// - default is maxInt, i.e. no Maximum set
property MaxPunctCount: cardinal read fProps[12] write fProps[12];
/// Minimal alphabetical lower case character [a-z] count
// - default is 0, i.e. no minimum set
property MinLowerCount: cardinal read fProps[5] write fProps[5];
/// Maximal alphabetical lower case character [a-z] count
// - default is maxInt, i.e. no Maximum set
property MaxLowerCount: cardinal read fProps[13] write fProps[13];
/// Minimal alphabetical upper case character [A-Z] count
// - default is 0, i.e. no minimum set
property MinUpperCount: cardinal read fProps[6] write fProps[6];
/// Maximal alphabetical upper case character [A-Z] count
// - default is maxInt, i.e. no Maximum set
property MaxUpperCount: cardinal read fProps[14] write fProps[14];
/// Minimal space count inside the value text
// - default is 0, i.e. any space number allowed
property MinSpaceCount: cardinal read fProps[7] write fProps[7];
/// Maximal space count inside the value text
// - default is maxInt, i.e. any space number allowed
property MaxSpaceCount: cardinal read fProps[15] write fProps[15];
/// Maximal space count allowed on the Left side
// - default is maxInt, i.e. any Left space allowed
property MaxLeftTrimCount: cardinal read fProps[8] write fProps[8];
/// Maximal space count allowed on the Right side
// - default is maxInt, i.e. any Right space allowed
property MaxRightTrimCount: cardinal read fProps[9] write fProps[9];
/// defines if lengths parameters expects UTF-8 or UTF-16 codepoints number
// - with default FALSE, the length is calculated with UTF-16 Unicode
// codepoints - MaxLength may not match the UCS4 glyphs number, in case of
// UTF-16 surrogates
// - you can set this property to TRUE so that the UTF-8 byte count would
// be used for truncation againts the MaxLength parameter
property UTF8Length: boolean read fUTF8Length write fUTF8Length;
end;
{$M-}
/// strong password validation for a Record field content (typicaly a TSQLRecord)
// - the following parameters are set by default to
// $ '{"MinLength":5,"MaxLength":20,"MinAlphaCount":1,"MinDigitCount":1,
// $ "MinPunctCount":1,"MinLowerCount":1,"MinUpperCount":1,"MaxSpaceCount":0}'
// - you can specify some JSON encoded parameters to change this default
// values, which will validate the text field only if it contains from 5 to 10
// characters, with at least one digit, one upper case letter, one lower case
// letter, and one ponctuation sign, with no space allowed inside
TSynValidatePassWord = class(TSynValidateText)
protected
/// set password specific parameters
procedure SetParameters(const Value: RawUTF8); override;
end;
{ C++Builder doesn't support array elements as properties (RSP-12595).
For now, simply exclude the relevant classes from C++Builder. }
{$NODEFINE TSynValidateTextProps}
{$NODEFINE TSynValidateText }
{$NODEFINE TSynValidatePassWord }
/// will define a transformation to be applied to a Record field content
// (typicaly a TSQLRecord)
// - here "filter" means that content would be transformed according to a
// set of defined rules
// - a typical usage is to convert to lower or upper case, or
// trim any time or date value in a TDateTime field
// - the optional associated parameters are to be supplied JSON-encoded
TSynFilter = class(TSynFilterOrValidate)
protected
public
/// perform the transformation to the specified value
// - the value is converted into UTF-8 text, as expected by
// TPropInfo.GetValue / TPropInfo.SetValue e.g.
procedure Process(aFieldIndex: integer; var Value: RawUTF8); virtual; abstract;
end;
/// class-refrence type (metaclass) for a TSynFilter or a TSynValidate
TSynFilterOrValidateClass = class of TSynFilterOrValidate;
/// class-reference type (metaclass) of a record filter (transformation)
TSynFilterClass = class of TSynFilter;
/// convert the value into ASCII Upper Case characters
// - UpperCase conversion is made for ASCII-7 only, i.e. 'a'..'z' characters
// - this version expects no parameter
TSynFilterUpperCase = class(TSynFilter)
public
/// perform the case conversion to the specified value
procedure Process(aFieldIndex: integer; var Value: RawUTF8); override;
end;
/// convert the value into WinAnsi Upper Case characters
// - UpperCase conversion is made for all latin characters in the WinAnsi
// code page only, e.g. 'e' acute will be converted to 'E'
// - this version expects no parameter
TSynFilterUpperCaseU = class(TSynFilter)
public
/// perform the case conversion to the specified value
procedure Process(aFieldIndex: integer; var Value: RawUTF8); override;
end;
/// convert the value into ASCII Lower Case characters
// - LowerCase conversion is made for ASCII-7 only, i.e. 'A'..'Z' characters
// - this version expects no parameter
TSynFilterLowerCase = class(TSynFilter)
public
/// perform the case conversion to the specified value
procedure Process(aFieldIndex: integer; var Value: RawUTF8); override;
end;
/// convert the value into WinAnsi Lower Case characters
// - LowerCase conversion is made for all latin characters in the WinAnsi
// code page only, e.g. 'E' acute will be converted to 'e'
// - this version expects no parameter
TSynFilterLowerCaseU = class(TSynFilter)
public
/// perform the case conversion to the specified value
procedure Process(aFieldIndex: integer; var Value: RawUTF8); override;
end;
/// trim any space character left or right to the value
// - this versions expect no parameter
TSynFilterTrim = class(TSynFilter)
public
/// perform the space triming conversion to the specified value
procedure Process(aFieldIndex: integer; var Value: RawUTF8); override;
end;
/// truncate a text above a given maximum length
// - expects optional JSON parameters of the allowed text length range as
// $ '{MaxLength":10}
TSynFilterTruncate = class(TSynFilter)
protected
fMaxLength: cardinal;
fUTF8Length: boolean;
/// decode the MaxLength: and UTF8Length: parameters
procedure SetParameters(const Value: RawUTF8); override;
public
/// perform the length truncation of the specified value
procedure Process(aFieldIndex: integer; var Value: RawUTF8); override;
/// Maximal length value allowed for the text content
// - the length is calculated with UTF-16 Unicode codepoints, unless
// UTF8Length has been set to TRUE so that the UTF-8 byte count is checked
// - default is 0, i.e. no maximum length is forced
property MaxLength: cardinal read fMaxLength write fMaxLength;
/// defines if MaxLength is stored as UTF-8 or UTF-16 codepoints number
// - with default FALSE, the length is calculated with UTF-16 Unicode
// codepoints - MaxLength may not match the UCS4 glyphs number, in case of
// UTF-16 surrogates
// - you can set this property to TRUE so that the UTF-8 byte count would
// be used for truncation againts the MaxLength parameter
property UTF8Length: boolean read fUTF8Length write fUTF8Length;
end;
{ ************ Database types and classes ************************** }
type
/// handled field/parameter/column types for abstract database access
// - this will map JSON-compatible low-level database-level access types, not
// high-level Delphi types as TSQLFieldType defined in mORMot.pas
// - it does not map either all potential types as defined in DB.pas (which
// are there for compatibility with old RDBMS, and are not abstract enough)
// - those types can be mapped to standard SQLite3 generic types, i.e.
// NULL, INTEGER, REAL, TEXT, BLOB (with the addition of a ftCurrency and
// ftDate type, for better support of most DB engines)
// see @http://www.sqlite.org/datatype3.html
// - the only string type handled here uses UTF-8 encoding (implemented
// using our RawUTF8 type), for cross-Delphi true Unicode process
TSQLDBFieldType =
(ftUnknown, ftNull, ftInt64, ftDouble, ftCurrency, ftDate, ftUTF8, ftBlob);
/// set of field/parameter/column types for abstract database access
TSQLDBFieldTypes = set of TSQLDBFieldType;
/// array of field/parameter/column types for abstract database access
TSQLDBFieldTypeDynArray = array of TSQLDBFieldType;
/// array of field/parameter/column types for abstract database access
// - this array as a fixed size, ready to handle up to MAX_SQLFIELDS items
TSQLDBFieldTypeArray = array[0..MAX_SQLFIELDS-1] of TSQLDBFieldType;
/// how TSQLVar may be processed
// - by default, ftDate will use seconds resolution unless svoDateWithMS is set
TSQLVarOption = (svoDateWithMS);
/// defines how TSQLVar may be processed
TSQLVarOptions = set of TSQLVarOption;
/// memory structure used for database values by reference storage
// - used mainly by SynDB, mORMot, mORMotDB and mORMotSQLite3 units
// - defines only TSQLDBFieldType data types (similar to those handled by
// SQLite3, with the addition of ftCurrency and ftDate)
// - cleaner/lighter dedicated type than TValue or variant/TVarData, strong
// enough to be marshalled as JSON content
// - variable-length data (e.g. UTF-8 text or binary BLOB) are never stored
// within this record, but VText/VBlob will point to an external (temporary)
// memory buffer
// - date/time is stored as ISO-8601 text (with milliseconds if svoDateWithMS
// option is set and the database supports it), and currency as double or BCD
// in most databases
TSQLVar = record
/// how this value should be processed
Options: TSQLVarOptions;
/// the type of the value stored
case VType: TSQLDBFieldType of
ftInt64: (
VInt64: Int64);
ftDouble: (
VDouble: double);
ftDate: (
VDateTime: TDateTime);
ftCurrency: (
VCurrency: Currency);
ftUTF8: (
VText: PUTF8Char);
ftBlob: (
VBlob: pointer;
VBlobLen: Integer)
end;
/// dynamic array of database values by reference storage
TSQLVarDynArray = array of TSQLVar;
/// used to store bit set for all available fields in a Table
// - with current MAX_SQLFIELDS value, 64 bits uses 8 bytes of memory
// - see also IsZero() and IsEqual() functions
// - you can also use ALL_FIELDS as defined in mORMot.pas
TSQLFieldBits = set of 0..MAX_SQLFIELDS-1;
/// used to store a field index in a Table
// - note that -1 is commonly used for the ID/RowID field so the values should
// be signed
// - even if ShortInt (-128..127) may have been enough, we define a 16 bit
// safe unsigned integer to let the source compile with Delphi 5
TSQLFieldIndex = SmallInt; // -32768..32767
/// used to store field indexes in a Table
// - same as TSQLFieldBits, but allowing to store the proper order
TSQLFieldIndexDynArray = array of TSQLFieldIndex;
/// points to a bit set used for all available fields in a Table
PSQLFieldBits = ^TSQLFieldBits;
/// generic parameter types, as recognized by SQLParamContent() and
// ExtractInlineParameters() functions
TSQLParamType = (sptUnknown, sptInteger, sptFloat, sptText, sptBlob, sptDateTime);
/// array of parameter types, as recognized by SQLParamContent() and
// ExtractInlineParameters() functions
TSQLParamTypeDynArray = array of TSQLParamType;
/// simple writer to a Stream, specialized for the JSON format and SQL export
// - use an internal buffer, faster than string+string
TJSONWriter = class(TTextWriter)
protected
/// used to store output format
fExpand: boolean;
/// used to store output format for TSQLRecord.GetJSONValues()
fWithID: boolean;
/// used to store field for TSQLRecord.GetJSONValues()
fFields: TSQLFieldIndexDynArray;
/// if not Expanded format, contains the Stream position of the first
// useful Row of data; i.e. ',val11' position in:
// & { "fieldCount":1,"values":["col1","col2",val11,"val12",val21,..] }
fStartDataPosition: integer;
public
/// used internally to store column names and count for AddColumns
ColNames: TRawUTF8DynArray;
/// the data will be written to the specified Stream
// - if no Stream is supplied, a temporary memory stream will be created
// (it's faster to supply one, e.g. any TSQLRest.TempMemoryStream)
constructor Create(aStream: TStream; Expand, withID: boolean;
const Fields: TSQLFieldBits; aBufSize: integer=8192); overload;
/// the data will be written to the specified Stream
// - if no Stream is supplied, a temporary memory stream will be created
// (it's faster to supply one, e.g. any TSQLRest.TempMemoryStream)
constructor Create(aStream: TStream; Expand, withID: boolean;
const Fields: TSQLFieldIndexDynArray=nil; aBufSize: integer=8192); overload;
/// rewind the Stream position and write void JSON object
procedure CancelAllVoid;
/// write or init field names for appropriate JSON Expand later use
// - ColNames[] must have been initialized before calling this procedure
// - if aKnownRowsCount is not null, a "rowCount":... item will be added
// to the generated JSON stream (for faster unserialization of huge content)
procedure AddColumns(aKnownRowsCount: integer=0);
/// allow to change on the fly an expanded format column layout
// - by definition, a non expanded format will raise a ESynException
// - caller should then set ColNames[] and run AddColumns()
procedure ChangeExpandedFields(aWithID: boolean; const aFields: TSQLFieldIndexDynArray); overload;
/// end the serialized JSON object
// - cancel last ','
// - close the JSON object ']' or ']}'
// - write non expanded postlog (,"rowcount":...), if needed
// - flush the internal buffer content if aFlushFinal=true
procedure EndJSONObject(aKnownRowsCount,aRowsCount: integer; aFlushFinal: boolean=true);
{$ifdef HASINLINE}inline;{$endif}
/// the first data row is erased from the content
// - only works if the associated storage stream is TMemoryStream
// - expect not Expanded format
procedure TrimFirstRow;
/// is set to TRUE in case of Expanded format
property Expand: boolean read fExpand write fExpand;
/// is set to TRUE if the ID field must be appended to the resulting JSON
// - this field is used only by TSQLRecord.GetJSONValues
// - this field is ignored by TSQLTable.GetJSONValues
property WithID: boolean read fWithID;
/// Read-Only access to the field bits set for each column to be stored
property Fields: TSQLFieldIndexDynArray read fFields;
/// if not Expanded format, contains the Stream position of the first
// useful Row of data; i.e. ',val11' position in:
// & { "fieldCount":1,"values":["col1","col2",val11,"val12",val21,..] }
property StartDataPosition: integer read fStartDataPosition;
end;
/// returns TRUE if no bit inside this TSQLFieldBits is set
// - is optimized for 64, 128, 192 and 256 max bits count (i.e. MAX_SQLFIELDS)
// - will work also with any other value
function IsZero(const Fields: TSQLFieldBits): boolean; overload;
{$ifdef HASINLINE}inline;{$endif}
/// fast comparison of two TSQLFieldBits values
// - is optimized for 64, 128, 192 and 256 max bits count (i.e. MAX_SQLFIELDS)
// - will work also with any other value
function IsEqual(const A,B: TSQLFieldBits): boolean; overload;
{$ifdef HASINLINE}inline;{$endif}
/// fast initialize a TSQLFieldBits with 0
// - is optimized for 64, 128, 192 and 256 max bits count (i.e. MAX_SQLFIELDS)
// - will work also with any other value
procedure FillZero(var Fields: TSQLFieldBits); overload;
{$ifdef HASINLINE}inline;{$endif}
/// convert a TSQLFieldBits set of bits into an array of integers
procedure FieldBitsToIndex(const Fields: TSQLFieldBits;
var Index: TSQLFieldIndexDynArray; MaxLength: integer=MAX_SQLFIELDS;
IndexStart: integer=0); overload;
/// convert a TSQLFieldBits set of bits into an array of integers
function FieldBitsToIndex(const Fields: TSQLFieldBits;
MaxLength: integer=MAX_SQLFIELDS): TSQLFieldIndexDynArray; overload;
{$ifdef HASINLINE}inline;{$endif}
/// add a field index to an array of field indexes
// - returns the index in Indexes[] of the newly appended Field value
function AddFieldIndex(var Indexes: TSQLFieldIndexDynArray; Field: integer): integer;
/// convert an array of field indexes into a TSQLFieldBits set of bits
procedure FieldIndexToBits(const Index: TSQLFieldIndexDynArray; var Fields: TSQLFieldBits); overload;
// search a field index in an array of field indexes
// - returns the index in Indexes[] of the given Field value, -1 if not found
function SearchFieldIndex(var Indexes: TSQLFieldIndexDynArray; Field: integer): integer;
/// convert an array of field indexes into a TSQLFieldBits set of bits
function FieldIndexToBits(const Index: TSQLFieldIndexDynArray): TSQLFieldBits; overload;
{$ifdef HASINLINE}inline;{$endif}
/// returns the stored size of a TSQLVar database value
// - only returns VBlobLen / StrLen(VText) size, 0 otherwise
function SQLVarLength(const Value: TSQLVar): integer;
{$ifndef NOVARIANTS}
/// convert any Variant into a database value
// - ftBlob kind won't be handled by this function
// - complex variant types would be converted into ftUTF8 JSON object/array
procedure VariantToSQLVar(const Input: variant; var temp: RawByteString;
var Output: TSQLVar);
/// guess the correct TSQLDBFieldType from a variant type
function VariantVTypeToSQLDBFieldType(VType: word): TSQLDBFieldType;
/// guess the correct TSQLDBFieldType from a variant value
function VariantTypeToSQLDBFieldType(const V: Variant): TSQLDBFieldType;
{$ifdef HASINLINE}inline;{$endif}
/// guess the correct TSQLDBFieldType from the UTF-8 representation of a value
function TextToSQLDBFieldType(json: PUTF8Char): TSQLDBFieldType;
{$endif NOVARIANTS}
/// convert a date to a ISO-8601 string format for SQL '?' inlined parameters
// - will return the date encoded as '\uFFF1YYYY-MM-DD' - therefore
// ':("\uFFF12012-05-04"):' pattern will be recognized as a sftDateTime
// inline parameter in SQLParamContent() / ExtractInlineParameters() functions
// (JSON_SQLDATE_MAGIC will be used as prefix to create '\uFFF1...' pattern)
// - to be used e.g. as in:
// ! aRec.CreateAndFillPrepare(Client,'Datum=?',[DateToSQL(EncodeDate(2012,5,4))]);
function DateToSQL(Date: TDateTime): RawUTF8; overload;
/// convert a date to a ISO-8601 string format for SQL '?' inlined parameters
// - will return the date encoded as '\uFFF1YYYY-MM-DD' - therefore
// ':("\uFFF12012-05-04"):' pattern will be recognized as a sftDateTime
// inline parameter in SQLParamContent() / ExtractInlineParameters() functions
// (JSON_SQLDATE_MAGIC will be used as prefix to create '\uFFF1...' pattern)
// - to be used e.g. as in:
// ! aRec.CreateAndFillPrepare(Client,'Datum=?',[DateToSQL(2012,5,4)]);
function DateToSQL(Year,Month,Day: cardinal): RawUTF8; overload;
/// convert a date/time to a ISO-8601 string format for SQL '?' inlined parameters
// - if DT=0, returns ''
// - if DT contains only a date, returns the date encoded as '\uFFF1YYYY-MM-DD'
// - if DT contains only a time, returns the time encoded as '\uFFF1Thh:mm:ss'
// - otherwise, returns the ISO-8601 date and time encoded as '\uFFF1YYYY-MM-DDThh:mm:ss'
// (JSON_SQLDATE_MAGIC will be used as prefix to create '\uFFF1...' pattern)
// - if WithMS is TRUE, will append '.sss' for milliseconds resolution
// - to be used e.g. as in:
// ! aRec.CreateAndFillPrepare(Client,'Datum<=?',[DateTimeToSQL(Now)]);
// - see TimeLogToSQL() if you are using TTimeLog/TModTime/TCreateTime values
function DateTimeToSQL(DT: TDateTime; WithMS: boolean=false): RawUTF8;
/// decode a SQL '?' inlined parameter (i.e. with JSON_SQLDATE_MAGIC prefix)
// - as generated by DateToSQL/DateTimeToSQL/TimeLogToSQL functions
function SQLToDateTime(const ParamValueWithMagic: RawUTF8): TDateTime;
/// convert a TTimeLog value into a ISO-8601 string format for SQL '?' inlined
// parameters
// - handle TTimeLog bit-encoded Int64 format
// - follows the same pattern as DateToSQL or DateTimeToSQL functions, i.e.
// will return the date or time encoded as '\uFFF1YYYY-MM-DDThh:mm:ss' -
// therefore ':("\uFFF12012-05-04T20:12:13"):' pattern will be recognized as a
// sftDateTime inline parameter in SQLParamContent() / ExtractInlineParameters()
// (JSON_SQLDATE_MAGIC will be used as prefix to create '\uFFF1...' pattern)
// - to be used e.g. as in:
// ! aRec.CreateAndFillPrepare(Client,'Datum<=?',[TimeLogToSQL(TimeLogNow)]);
function TimeLogToSQL(const Timestamp: TTimeLog): RawUTF8;
/// convert a Iso8601 encoded string into a ISO-8601 string format for SQL
// '?' inlined parameters
// - follows the same pattern as DateToSQL or DateTimeToSQL functions, i.e.
// will return the date or time encoded as '\uFFF1YYYY-MM-DDThh:mm:ss' -
// therefore ':("\uFFF12012-05-04T20:12:13"):' pattern will be recognized as a
// sftDateTime inline parameter in SQLParamContent() / ExtractInlineParameters()
// (JSON_SQLDATE_MAGIC will be used as prefix to create '\uFFF1...' pattern)
// - in practice, just append the JSON_SQLDATE_MAGIC prefix to the supplied text
function Iso8601ToSQL(const S: RawByteString): RawUTF8;
/// guess the content type of an UTF-8 SQL value, in :(....): format
// - will be used e.g. by ExtractInlineParameters() to un-inline a SQL statement
// - sftInteger is returned for an INTEGER value, e.g. :(1234):
// - sftFloat is returned for any floating point value (i.e. some digits
// separated by a '.' character), e.g. :(12.34): or :(12E-34):
// - sftUTF8Text is returned for :("text"): or :('text'):, with double quoting
// inside the value
// - sftBlob will be recognized from the ':("\uFFF0base64encodedbinary"):'
// pattern, and return raw binary (for direct blob parameter assignment)
// - sftDateTime will be recognized from ':(\uFFF1"2012-05-04"):' pattern,
// i.e. JSON_SQLDATE_MAGIC-prefixed string as returned by DateToSQL() or
// DateTimeToSQL() functions
// - sftUnknown is returned on invalid content, or if wasNull is set to TRUE
// - if ParamValue is not nil, the pointing RawUTF8 string is set with the
// value inside :(...): without double quoting in case of sftUTF8Text
// - wasNull is set to TRUE if P was ':(null):' and ParamType is sftUnknwown
function SQLParamContent(P: PUTF8Char; out ParamType: TSQLParamType; out ParamValue: RawUTF8;
out wasNull: boolean): PUTF8Char;
/// this function will extract inlined :(1234): parameters into Types[]/Values[]
// - will return the generic SQL statement with ? place holders for inlined
// parameters and setting Values with SQLParamContent() decoded content
// - will set maxParam=0 in case of no inlined parameters
// - recognized types are sptInteger, sptFloat, sptDateTime ('\uFFF1...'),
// sptUTF8Text and sptBlob ('\uFFF0...')
// - sptUnknown is returned on invalid content
function ExtractInlineParameters(const SQL: RawUTF8;
var Types: TSQLParamTypeDynArray; var Values: TRawUTF8DynArray;
var maxParam: integer; var Nulls: TSQLFieldBits): RawUTF8;
/// returns a 64-bit value as inlined ':(1234):' text
function InlineParameter(ID: Int64): shortstring; overload;
/// returns a string value as inlined ':("value"):' text
function InlineParameter(const value: RawUTF8): RawUTF8; overload;
type
/// SQL Query comparison operators
// - used e.g. by CompareOperator() functions in SynTable.pas or vt_BestIndex()
// in mORMotSQLite3.pas
TCompareOperator = (
soEqualTo,
soNotEqualTo,
soLessThan,
soLessThanOrEqualTo,
soGreaterThan,
soGreaterThanOrEqualTo,
soBeginWith,
soContains,
soSoundsLikeEnglish,
soSoundsLikeFrench,
soSoundsLikeSpanish);
const
/// convert identified field types into high-level ORM types
// - as will be implemented in unit mORMot.pas
SQLDBFIELDTYPE_TO_DELPHITYPE: array[TSQLDBFieldType] of RawUTF8 = (
'???','???', 'Int64', 'Double', 'Currency', 'TDateTime', 'RawUTF8', 'TSQLRawBlob');
{ ************ TSynTable types and classes ************************** }
{$define SORTCOMPAREMETHOD}
{ if defined, the field content comparison will use a method instead of fixed
functions - could be mandatory for tftArray field kind }
type
/// exception raised by all TSynTable related code
ETableDataException = class(ESynException);
/// the available types for any TSynTable field property
// - this is used in our so-called SBF compact binary format
// (similar to BSON or Protocol Buffers)
// - those types are used for both storage and JSON conversion
// - basic types are similar to SQLite3, i.e. Int64/Double/UTF-8/Blob
// - storage can be of fixed size, or of variable length
// - you can specify to use WinAnsi encoding instead of UTF-8 for string storage
// (it can use less space on disk than UTF-8 encoding)
// - BLOB fields can be either internal (i.e. handled by TSynTable like a
// RawByteString text storage), either external (i.e. must be stored in a dedicated
// storage structure - e.g. another TSynBigTable instance)
TSynTableFieldType =
(// unknown or not defined field type
tftUnknown,
// some fixed-size field value
tftBoolean, tftUInt8, tftUInt16, tftUInt24, tftInt32, tftInt64,
tftCurrency, tftDouble,
// some variable-size field value
tftVarUInt32, tftVarInt32, tftVarUInt64,
// text storage
tftWinAnsi, tftUTF8,
// BLOB fields
tftBlobInternal, tftBlobExternal,
// other variable-size field value
tftVarInt64);
/// set of available field types for TSynTable
TSynTableFieldTypes = set of TSynTableFieldType;
/// available option types for a field property
// - tfoIndex is set if an index must be created for this field
// - tfoUnique is set if field values must be unique (if set, the tfoIndex
// will be always forced)
// - tfoCaseInsensitive can be set to make no difference between 'a' and 'A'
// (by default, comparison is case-sensitive) - this option has an effect
// not only if tfoIndex or tfoUnique is set, but also for iterating search
TSynTableFieldOption = (
tfoIndex, tfoUnique, tfoCaseInsensitive);
/// set of option types for a field
TSynTableFieldOptions = set of TSynTableFieldOption;
/// used to store bit set for all available fiels in a Table
// - with current format, maximum field count is 64
TSynTableFieldBits = set of 0..63;
/// an custom RawByteString type used to store internaly a data in
// our SBF compact binary format
TSBFString = type RawByteString;
/// function prototype used to retrieve the index of a specified property name
// - 'ID' is handled separately: here must be available only the custom fields
TSynTableFieldIndex = function(const PropName: RawUTF8): integer of object;
/// the recognized operators for a TSynTableStatement where clause
TSynTableStatementOperator = (
opEqualTo,
opNotEqualTo,
opLessThan,
opLessThanOrEqualTo,
opGreaterThan,
opGreaterThanOrEqualTo,
opIn,
opIsNull,
opIsNotNull,
opLike,
opContains,
opFunction);
TSynTableFieldProperties = class;
/// one recognized SELECT expression for TSynTableStatement
TSynTableStatementSelect = record
/// the column SELECTed for the SQL statement, in the expected order
// - contains 0 for ID/RowID, or the RTTI field index + 1
Field: integer;
/// an optional integer to be added
// - recognized from .. +123 .. -123 patterns in the select
ToBeAdded: integer;
/// the optional column alias, e.g. 'MaxID' for 'max(id) as MaxID'
Alias: RawUTF8;
/// the optional function applied to the SELECTed column
// - e.g. Max(RowID) would store 'Max' and SelectField[0]=0
// - but Count(*) would store 'Count' and SelectField[0]=0, and
// set FunctionIsCountStart = TRUE
FunctionName: RawUTF8;
/// if the function needs a special process
// - e.g. funcCountStar for the special Count(*) expression or
// funcDistinct, funcMax for distinct(...)/max(...) aggregation
FunctionKnown: (funcNone, funcCountStar, funcDistinct, funcMax);
end;
/// the recognized SELECT expressions for TSynTableStatement
TSynTableStatementSelectDynArray = array of TSynTableStatementSelect;
/// one recognized WHERE expression for TSynTableStatement
TSynTableStatementWhere = record
/// any '(' before the actual expression
ParenthesisBefore: RawUTF8;
/// any ')' after the actual expression
ParenthesisAfter: RawUTF8;
/// expressions are evaluated as AND unless this field is set to TRUE
JoinedOR: boolean;
/// if this expression is preceded by a NOT modifier
NotClause: boolean;
/// the index of the field used for the WHERE expression
// - WhereField=0 for ID, 1 for field # 0, 2 for field #1,
// and so on... (i.e. WhereField = RTTI field index +1)
Field: integer;
/// the operator of the WHERE expression
Operator: TSynTableStatementOperator;
/// the SQL function name associated to a Field and Value
// - e.g. 'INTEGERDYNARRAYCONTAINS' and Field=0 for
// IntegerDynArrayContains(RowID,10) and ValueInteger=10
// - Value does not contain anything
FunctionName: RawUTF8;
/// the value used for the WHERE expression
Value: RawUTF8;
/// the raw value SQL buffer used for the WHERE expression
ValueSQL: PUTF8Char;
/// the raw value SQL buffer length used for the WHERE expression
ValueSQLLen: integer;
/// an integer representation of WhereValue (used for ID check e.g.)
ValueInteger: integer;
/// used to fast compare with SBF binary compact formatted data
ValueSBF: TSBFString;
{$ifndef NOVARIANTS}
/// the value used for the WHERE expression, encoded as Variant
// - may be a TDocVariant for the IN operator
ValueVariant: variant;
{$endif}
end;
/// the recognized WHERE expressions for TSynTableStatement
TSynTableStatementWhereDynArray = array of TSynTableStatementWhere;
/// used to parse a SELECT SQL statement, following the SQlite3 syntax
// - handle basic REST commands, i.e. a SELECT over a single table (no JOIN)
// with its WHERE clause, and result column aliases
// - handle also aggregate functions like "SELECT Count(*) FROM TableName"
// - will also parse any LIMIT, OFFSET, ORDER BY, GROUP BY statement clause
TSynTableStatement = class
protected
fSQLStatement: RawUTF8;
fSelect: TSynTableStatementSelectDynArray;
fSelectFunctionCount: integer;
fTableName: RawUTF8;
fWhere: TSynTableStatementWhereDynArray;
fOrderByField: TSQLFieldIndexDynArray;
fGroupByField: TSQLFieldIndexDynArray;
fWhereHasParenthesis: boolean;
fOrderByDesc: boolean;
fLimit: integer;
fOffset: integer;
fWriter: TJSONWriter;
public
/// parse the given SELECT SQL statement and retrieve the corresponding
// parameters into this class read-only properties
// - the supplied GetFieldIndex() method is used to populate the
// SelectedFields and Where[].Field properties
// - SimpleFieldsBits is used for '*' field names
// - SQLStatement is left '' if the SQL statement is not correct
// - if SQLStatement is set, the caller must check for TableName to match
// the expected value, then use the Where[] to retrieve the content
// - if FieldProp is set, then the Where[].ValueSBF property is initialized
// with the SBF equivalence of the Where[].Value
constructor Create(const SQL: RawUTF8; GetFieldIndex: TSynTableFieldIndex;
SimpleFieldsBits: TSQLFieldBits=[0..MAX_SQLFIELDS-1];
FieldProp: TSynTableFieldProperties=nil);
/// compute the SELECT column bits from the SelectFields array
procedure SelectFieldBits(var Fields: TSQLFieldBits; var withID: boolean);
/// the SELECT SQL statement parsed
// - equals '' if the parsing failed
property SQLStatement: RawUTF8 read fSQLStatement;
/// the column SELECTed for the SQL statement, in the expected order
property Select: TSynTableStatementSelectDynArray read fSelect;
/// if the SELECTed expression of this SQL statement have any function defined
property SelectFunctionCount: integer read fSelectFunctionCount;
/// the retrieved table name
property TableName: RawUTF8 read fTableName;
/// the WHERE clause of this SQL statement
property Where: TSynTableStatementWhereDynArray read fWhere;
/// if the WHERE clause contains any ( ) parenthesis expression
property WhereHasParenthesis: boolean read fWhereHasParenthesis;
/// recognize an GROUP BY clause with one or several fields
// - here 0 = ID, otherwise RTTI field index +1
property GroupByField: TSQLFieldIndexDynArray read fGroupByField;
/// recognize an ORDER BY clause with one or several fields
// - here 0 = ID, otherwise RTTI field index +1
property OrderByField: TSQLFieldIndexDynArray read fOrderByField;
/// false for default ASC order, true for DESC attribute
property OrderByDesc: boolean read fOrderByDesc;
/// the number specified by the optional LIMIT ... clause
// - set to 0 by default (meaning no LIMIT clause)
property Limit: integer read fLimit;
/// the number specified by the optional OFFSET ... clause
// - set to 0 by default (meaning no OFFSET clause)
property Offset: integer read fOffset;
/// optional associated writer
property Writer: TJSONWriter read fWriter write fWriter;
end;
/// function prototype used to retrieve the RECORD data of a specified Index
// - the index is not the per-ID index, but the "physical" index, i.e. the
// index value used to retrieve data from low-level (and faster) method
// - should return nil if Index is out of range
// - caller must provide a temporary storage buffer to be used optionally
TSynTableGetRecordData = function(
Index: integer; var aTempData: RawByteString): pointer of object;
TSynTable = class;
{$ifdef SORTCOMPAREMETHOD}
/// internal value used by TSynTableFieldProperties.SortCompare() method to
// avoid stack allocation
TSortCompareTmp = record
PB1, PB2: PByte;
L1,L2: integer;
end;
{$endif}
/// store the type properties of a given field / database column
TSynTableFieldProperties = class
protected
/// used during OrderedIndexSort to prevent stack usage
SortPivot: pointer;
{$ifdef SORTCOMPAREMETHOD}
/// internal value used by SortCompare() method to avoid stack allocation
SortCompareTmp: TSortCompareTmp;
{$endif}
/// these two temporary buffers are used to call TSynTableGetRecordData
DataTemp1, DataTemp2: RawByteString;
/// the associated table which own this field property
Owner: TSynTable;
/// the global size of a default field value, as encoded
// in our SBF compact binary format
fDefaultFieldLength: integer;
/// a default field data, as encoded in our SBF compact binary format
fDefaultFieldData: TSBFString;
/// last >=0 value returned by the last OrderedIndexFindAdd() call
fOrderedIndexFindAdd: integer;
/// used for internal QuickSort of OrderedIndex[]
// - call SortCompare() for sorting the items
procedure OrderedIndexSort(L,R: PtrInt);
/// retrieve an index from OrderedIndex[] of the given value
// - call SortCompare() to compare to the reference value
function OrderedIndexFind(Value: pointer): PtrInt;
/// retrieve an index where a Value must be added into OrderedIndex[]
// - call SortCompare() to compare to the reference value
// - returns -1 if Value is there, or the index where to insert
// - the returned value (if >= 0) will be stored in fOrderedIndexFindAdd
function OrderedIndexFindAdd(Value: pointer): PtrInt;
/// set OrderedIndexReverse[OrderedIndex[aOrderedIndex]] := aOrderedIndex;
procedure OrderedIndexReverseSet(aOrderedIndex: integer);
public
/// the field name
Name: RawUTF8;
/// kind of field (defines both value type and storage to be used)
FieldType: TSynTableFieldType;
/// the fixed-length size, or -1 for a varInt, -2 for a variable string
FieldSize: integer;
/// options of this field
Options: TSynTableFieldOptions;
/// contains the offset of this field, in case of fixed-length field
// - normally, fixed-length fields are stored in the beginning of the record
// storage: in this case, a value >= 0 will point to the position of the
// field value of this field
// - if the value is < 0, its absolute will be the field number to be counted
// after TSynTable.fFieldVariableOffset (-1 for first item)
Offset: integer;
/// number of the field in the table (starting at 0)
FieldNumber: integer;
/// if allocated, contains the storage indexes of every item, in sorted order
// - only available if tfoIndex is in Options
// - the index is not the per-ID index, but the "physical" index, i.e. the
// index value used to retrieve data from low-level (and faster) method
OrderedIndex: TIntegerDynArray;
/// if allocated, contains the reverse storage index of OrderedIndex
// - i.e. OrderedIndexReverse[OrderedIndex[i]] := i;
// - used to speed up the record update procedure with huge number of
// records
OrderedIndexReverse: TIntegerDynArray;
/// number of items in OrderedIndex[]
// - is set to 0 when the content has been modified (mark force recreate)
OrderedIndexCount: integer;
/// if set to TRUE after an OrderedIndex[] refresh but with not sorting
// - OrderedIndexSort(0,OrderedIndexCount-1) must be called before using
// the OrderedIndex[] array
// - you should call OrderedIndexRefresh method to ensure it is sorted
OrderedIndexNotSorted: boolean;
/// all TSynValidate instances registered per each field
Filters: TObjectList;
/// all TSynValidate instances registered per each field
Validates: TObjectList;
/// low-level binary comparison used by IDSort and TSynTable.IterateJSONValues
// - P1 and P2 must point to the values encoded in our SBF compact binary format
{$ifdef SORTCOMPAREMETHOD}
function SortCompare(P1,P2: PUTF8Char): PtrInt;
{$else}
SortCompare: TUTF8Compare;
{$endif}
/// read entry from a specified file reader
constructor CreateFrom(var RD: TFileBufferReader);
/// release associated memory and objects
destructor Destroy; override;
/// save entry to a specified file writer
procedure SaveTo(WR: TFileBufferWriter);
/// decode the value from our SBF compact binary format into UTF-8 JSON
// - returns the next FieldBuffer value
function GetJSON(FieldBuffer: pointer; W: TTextWriter): pointer;
/// decode the value from our SBF compact binary format into UTF-8 text
// - this method does not check for FieldBuffer to be not nil -> caller
// should check this explicitely
function GetValue(FieldBuffer: pointer): RawUTF8;
/// decode the value from a record buffer into an Boolean
// - will call Owner.GetData to retrieve then decode the field SBF content
function GetBoolean(RecordBuffer: pointer): Boolean;
{$ifdef HASINLINE}inline;{$endif}
/// decode the value from a record buffer into an integer
// - will call Owner.GetData to retrieve then decode the field SBF content
function GetInteger(RecordBuffer: pointer): Integer;
/// decode the value from a record buffer into an Int64
// - will call Owner.GetData to retrieve then decode the field SBF content
function GetInt64(RecordBuffer: pointer): Int64;
/// decode the value from a record buffer into an floating-point value
// - will call Owner.GetData to retrieve then decode the field SBF content
function GetDouble(RecordBuffer: pointer): Double;
/// decode the value from a record buffer into an currency value
// - will call Owner.GetData to retrieve then decode the field SBF content
function GetCurrency(RecordBuffer: pointer): Currency;
/// decode the value from a record buffer into a RawUTF8 string
// - will call Owner.GetData to retrieve then decode the field SBF content
function GetRawUTF8(RecordBuffer: pointer): RawUTF8;
{$ifndef NOVARIANTS}
/// decode the value from our SBF compact binary format into a Variant
function GetVariant(FieldBuffer: pointer): Variant; overload;
{$ifdef HASINLINE}inline;{$endif}
/// decode the value from our SBF compact binary format into a Variant
procedure GetVariant(FieldBuffer: pointer; var result: Variant); overload;
{$endif}
/// retrieve the binary length (in bytes) of some SBF compact binary format
function GetLength(FieldBuffer: pointer): Integer;
{$ifdef HASINLINE}inline;{$endif}
/// create some SBF compact binary format from a Delphi binary value
// - will return '' if the field type doesn't match a boolean
function SBF(const Value: Boolean): TSBFString; overload;
/// create some SBF compact binary format from a Delphi binary value
// - will encode any byte, word, integer, cardinal, Int64 value
// - will return '' if the field type doesn't match an integer
function SBF(const Value: Int64): TSBFString; overload;
/// create some SBF compact binary format from a Delphi binary value
// - will encode any byte, word, integer, cardinal value
// - will return '' if the field type doesn't match an integer
function SBF(const Value: Integer): TSBFString; overload;
/// create some SBF compact binary format from a Delphi binary value
// - will return '' if the field type doesn't match a currency
// - we can't use SBF() method name because of Currency/Double ambiguity
function SBFCurr(const Value: Currency): TSBFString;
/// create some SBF compact binary format from a Delphi binary value
// - will return '' if the field type doesn't match a floating-point
// - we can't use SBF() method name because of Currency/Double ambiguity
function SBFFloat(const Value: Double): TSBFString;
/// create some SBF compact binary format from a Delphi binary value
// - expect a RawUTF8 string: will be converted to WinAnsiString
// before storage, for tftWinAnsi
// - will return '' if the field type doesn't match a string
function SBF(const Value: RawUTF8): TSBFString; overload;
/// create some SBF compact binary format from a BLOB memory buffer
// - will return '' if the field type doesn't match tftBlobInternal
function SBF(Value: pointer; ValueLen: integer): TSBFString; overload;
/// convert any UTF-8 encoded value into our SBF compact binary format
// - can be used e.g. from a WHERE clause, for fast comparison in
// TSynTableStatement.WhereValue content using OrderedIndex[]
// - is the reverse of GetValue/GetRawUTF8 methods above
function SBFFromRawUTF8(const aValue: RawUTF8): TSBFString;
{$ifndef NOVARIANTS}
/// create some SBF compact binary format from a Variant value
function SBF(const Value: Variant): TSBFString; overload;
{$endif}
/// will update then sort the array of indexes used for the field index
// - the OrderedIndex[] array is first refreshed according to the
// aOldIndex, aNewIndex parameters: aOldIndex=-1 for Add, aNewIndex=-1 for
// Delete, or both >= 0 for update
// - call with both indexes = -1 will sort the existing OrderedIndex[] array
// - GetData property must have been set with a method returning a pointer
// to the field data for a given index (this index is not the per-ID index,
// but the "physical" index, i.e. the index value used to retrieve data
// from low-level (and fast) GetData method)
// - aOldRecordData and aNewRecordData can be specified in order to guess
// if the field data has really been modified (speed up the update a lot
// to only sort indexed fields if its content has been really modified)
// - returns FALSE if any parameter is invalid
function OrderedIndexUpdate(aOldIndex, aNewIndex: integer;
aOldRecordData, aNewRecordData: pointer): boolean;
/// retrieve one or more "physical" indexes matching a WHERE Statement
// - is faster than O(1) GetIteraring(), because will use O(log(n)) binary
// search using the OrderedIndex[] array
// - returns the resulting indexes as a a sorted list in MatchIndex/MatchIndexCount
// - if the indexes are already present in the list, won't duplicate them
// - WhereSBFValue must be a valid SBF formated field buffer content
// - the Limit parameter is similar to the SQL LIMIT clause: if greater than 0,
// an upper bound on the number of rows returned is placed (e.g. set Limit=1
// to only retrieve the first match)
// - GetData property must have been set with a method returning a pointer
// to the field data for a given index (this index is not the per-ID index,
// but the "physical" index, i.e. the index value used to retrieve data
// from low-level (and fast) GetData method)
// - in this method, indexes are not the per-ID indexes, but the "physical"
// indexes, i.e. each index value used to retrieve data from low-level
// (and fast) GetData method
function OrderedIndexMatch(WhereSBFValue: pointer;
var MatchIndex: TIntegerDynArray; var MatchIndexCount: integer;
Limit: Integer=0): Boolean;
/// will force refresh the OrderedIndex[] array
// - to be called e.g. if OrderedIndexNotSorted = TRUE, if you want to
// access to the OrderedIndex[] array
procedure OrderedIndexRefresh;
/// register a custom filter or validation rule to the class for this field
// - this will be used by Filter() and Validate() methods
// - will return the specified associated TSynFilterOrValidate instance
// - a TSynValidateTableUniqueField is always added by
// TSynTable.AfterFieldModif if tfoUnique is set in Options
function AddFilterOrValidate(aFilter: TSynFilterOrValidate): TSynFilterOrValidate;
/// check the registered constraints
// - returns '' on success
// - returns an error message e.g. if a tftUnique constraint failed
// - RecordIndex=-1 in case of adding, or the physical index of the updated record
function Validate(RecordBuffer: pointer; RecordIndex: integer): string;
/// some default SBF compact binary format content
property SBFDefault: TSBFString read fDefaultFieldData;
end;
{$ifndef DELPHI5OROLDER}
/// a pointer to structure used to store a TSynTable record
PSynTableData = ^TSynTableData;
{$A-} { packet object not allowed since Delphi 2009 :( }
/// used to store a TSynTable record using our SBF compact binary format
// - this object can be created on the stack
// - it is mapped into a variant TVarData, to be retrieved by the
// TSynTable.Data method - but direct allocation of a TSynTableData on the
// stack is faster (due to the Variant overhead)
// - is defined either as an object either as a record, due to a bug
// in Delphi 2009/2010 compiler (at least): this structure is not initialized
// if defined as an object on the stack, but will be as a record :(
{$ifdef UNICODE}TSynTableData = record{$else}TSynTableData = object{$endif UNICODE}
{$ifdef UNICODE}private{$else}protected{$endif UNICODE}
VType: TVarType;
Filler: array[1..SizeOf(TVarData)-SizeOf(TVarType)-SizeOf(pointer)*2-4] of byte;
VID: integer;
VTable: TSynTable;
VValue: TSBFString;
{$ifndef NOVARIANTS}
function GetFieldValue(const FieldName: RawUTF8): Variant; overload;
procedure GetFieldVariant(const FieldName: RawUTF8; var result: Variant);
procedure SetFieldValue(const FieldName: RawUTF8; const Value: Variant); overload;
{$endif}
/// raise an exception if VTable=nil
procedure CheckVTableInitialized;
{$ifdef HASINLINE}inline;{$endif}
public
/// initialize a record data content for a specified table
// - a void content is set
procedure Init(aTable: TSynTable; aID: Integer=0); overload; {$ifdef HASINLINE}inline;{$endif}
/// initialize a record data content for a specified table
// - the specified SBF content is store inside this TSynTableData
procedure Init(aTable: TSynTable; aID: Integer; RecordBuffer: pointer;
RecordBufferLen: integer); overload;
/// the associated record ID
property ID: integer read VID write VID;
/// the associated TSynTable instance
property Table: TSynTable read VTable write VTable;
/// the record content, SBF compact binary format encoded
property SBF: TSBFString read VValue;
{$ifndef NOVARIANTS}
/// set or retrieve a field value from a variant data
property Field[const FieldName: RawUTF8]: Variant read GetFieldValue write SetFieldValue;
/// get a field value for a specified field
// - this method is faster than Field[], because it won't look for the field name
function GetFieldValue(aField: TSynTableFieldProperties): Variant; overload;
/// set a field value for a specified field
// - this method is faster than Field[], because it won't look for the field name
procedure SetFieldValue(aField: TSynTableFieldProperties; const Value: Variant); overload;
{$ifdef HASINLINE}inline;{$endif}
{$endif}
/// set a field value for a specified field, from SBF-encoded data
// - this method is faster than the other, because it won't look for the field
// name nor make any variant conversion
procedure SetFieldSBFValue(aField: TSynTableFieldProperties; const Value: TSBFString);
/// get a field value for a specified field, into SBF-encoded data
// - this method is faster than the other, because it won't look for the field
// name nor make any variant conversion
function GetFieldSBFValue(aField: TSynTableFieldProperties): TSBFString;
/// filter the SBF buffer record content with all registered filters
// - all field values are filtered in-place, following our SBF compact
// binary format encoding for this record
procedure FilterSBFValue; {$ifdef HASINLINE}inline;{$endif}
/// check the registered constraints according to a record SBF buffer
// - returns '' on success
// - returns an error message e.g. if a tftUnique constraint failed
// - RecordIndex=-1 in case of adding, or the physical index of the updated record
function ValidateSBFValue(RecordIndex: integer): string;
end;
{$A+} { packet object not allowed since Delphi 2009 :( }
{$endif DELPHI5OROLDER}
PUpdateFieldEvent = ^TUpdateFieldEvent;
/// an opaque structure used for TSynTable.UpdateFieldEvent method
TUpdateFieldEvent = record
/// the number of record added
Count: integer;
/// the list of IDs added
// - this list is already in increasing order, because GetIterating was
// called with the ioID order
IDs: TIntegerDynArray;
/// the offset of every record added
// - follows the IDs[] order
Offsets64: TInt64DynArray;
/// previous indexes: NewIndexs[oldIndex] := newIndex
NewIndexs: TIntegerDynArray;
/// the list of existing field in the previous data
AvailableFields: TSQLFieldBits;
/// where to write the updated data
WR: TFileBufferWriter;
end;
/// will define a validation to be applied to a TSynTableFieldProperties field
// - a typical usage is to validate a value to be unique in the table
// (implemented in the TSynValidateTableUniqueField class)
// - the optional associated parameters are to be supplied JSON-encoded
// - ProcessField and ProcessRecordIndex properties will be filled before
// Process method call by TSynTableFieldProperties.Validate()
TSynValidateTable = class(TSynValidate)
protected
fProcessField: TSynTableFieldProperties;
fProcessRecordIndex: integer;
public
/// the associated TSQLRest instance
// - this value is filled by TSynTableFieldProperties.Validate with its
// self value to be used for the validation
// - it can be used in the overridden Process method
property ProcessField: TSynTableFieldProperties read fProcessField write fProcessField;
/// the associated record index (in case of update)
// - is set to -1 in case of adding, or the physical index of the updated record
// - this value is filled by TSynTableFieldProperties.Validate
// - it can be used in the overridden Process method
property ProcessRecordIndex: integer read fProcessRecordIndex write fProcessRecordIndex;
end;
/// will define a validation for a TSynTableFieldProperties Unique field
// - implement constraints check e.g. if tfoUnique is set in Options
// - it will check that the field value is not void
// - it will check that the field value is not a duplicate
TSynValidateTableUniqueField = class(TSynValidateTable)
public
/// perform the unique field validation action to the specified value
// - duplication value check will use the ProcessField and
// ProcessRecordIndex properties, which will be filled before call by
// TSynTableFieldProperties.Validate()
// - aFieldIndex parameter is not used here, since we have already the
// ProcessField property set
// - here the Value is expected to be UTF-8 text, as converted from our SBF
// compact binary format via e.g. TSynTableFieldProperties.GetValue /
// GetRawUTF8: this is mandatory to have the validation rule fit with other
// TSynValidateTable classes
function Process(aFieldIndex: integer; const Value: RawUTF8; var ErrorMsg: string): boolean; override;
end;
/// store the description of a table with records, to implement a Database
// - can be used with several storage engines, for instance TSynBigTableRecord
// - each record can have up to 64 fields
// - a mandatory ID field must be handled by the storage engine itself
// - will handle the storage of records into our SBF compact binary format, in
// which fixed-length fields are stored leftmost side, then variable-length
// fields follow
TSynTable = class
protected
fTableName: RawUTF8;
/// list of TSynTableFieldProperties instances
fField: TObjectList;
/// offset of the first variable length value field
fFieldVariableOffset: PtrUInt;
/// index of the first variable length value field
// - equals -1 if no variable length field exists
fFieldVariableIndex: integer;
/// bit is set for a tftWinAnsi, tftUTF8 or tftBlobInternal kind of field
// - these kind of field are encoded as a VarInt length, then the data
fFieldIsVarString: TSynTableFieldBits;
/// bit is set for a tftBlobExternal kind of field e.g.
fFieldIsExternal: TSynTableFieldBits;
/// event used for proper data retrieval of a given record buffer
fGetRecordData: TSynTableGetRecordData;
/// the global size of a default value, as encoded in our SBF compact binary format
fDefaultRecordLength: integer;
/// a default record data, as encoded in our SBF compact binary format
fDefaultRecordData: TSBFString;
/// list of TSynTableFieldProperties added via all AddField() call
fAddedField: TList;
/// true if any field has a tfoUnique option set
fFieldHasUniqueIndexes: boolean;
function GetFieldType(Index: integer): TSynTableFieldProperties;
function GetFieldCount: integer;
function GetFieldFromName(const aName: RawUTF8): TSynTableFieldProperties;
function GetFieldIndexFromName(const aName: RawUTF8): integer;
/// this method matchs the TSynTableFieldIndex event type
function GetFieldIndexFromShortName(const aName: ShortString): integer;
/// refresh Offset,FieldNumber,FieldSize and fFieldVariableIndex,fFieldVariableOffset
procedure AfterFieldModif;
public
/// create a table definition instance
constructor Create(const aTableName: RawUTF8);
/// create a table definition instance from a specified file reader
procedure LoadFrom(var RD: TFileBufferReader);
/// release used memory
destructor Destroy; override;
/// save field properties to a specified file writer
procedure SaveTo(WR: TFileBufferWriter);
/// retrieve to the corresponding data address of a given field
function GetData(RecordBuffer: PUTF8Char; Field: TSynTableFieldProperties): pointer;
/// add a field description to the table
// - warning: the class responsible of the storage itself must process the
// data already stored when a field is created, e.g. in
// TSynBigTableRecord.AddFieldUpdate method
// - physical order does not necessary follow the AddField() call order:
// for better performance, it will try to store fixed-sized record first,
// multiple of 4 bytes first (access is faster if dat is 4 byte aligned),
// then variable-length after fixed-sized fields; in all case, a field
// indexed will be put first
function AddField(const aName: RawUTF8; aType: TSynTableFieldType;
aOptions: TSynTableFieldOptions=[]): TSynTableFieldProperties;
/// update a record content
// - return the updated record data, in our SBF compact binary format
// - if NewFieldData is not specified, a default 0 or '' value is appended
// - if NewFieldData is set, it must match the field value kind
// - warning: this method will update result in-place, so RecordBuffer MUST
// be <> pointer(result) or data corruption may occur
procedure UpdateFieldData(RecordBuffer: PUTF8Char; RecordBufferLen,
FieldIndex: integer; var result: TSBFString; const NewFieldData: TSBFString='');
/// update a record content after any AddfieldUpdate, to refresh the data
// - AvailableFields must contain the list of existing fields in the previous data
function UpdateFieldRecord(RecordBuffer: PUTF8Char; var AvailableFields: TSQLFieldBits): TSBFString;
/// this Event is to be called for all data records (via a GetIterating method)
// after any AddfieldUpdate, to refresh the data
// - Opaque is in fact a pointer to a TUpdateFieldEvent record, and will contain
// all parameters set by TSynBigTableRecord.AddFieldUpdate, including a
// TFileBufferWriter instance to use to write the recreated data
// - it will work with either any newly added field, handly also field data
// order change in SBF record (e.g. when a fixed-sized field has been added
// on a record containing variable-length fields)
function UpdateFieldEvent(Sender: TObject; Opaque: pointer; ID, Index: integer;
Data: pointer; DataLen: integer): boolean;
/// event which must be called by the storage engine when some values are modified
// - if aOldIndex and aNewIndex are both >= 0, the corresponding aOldIndex
// will be replaced by aNewIndex value (i.e. called in case of a data Update)
// - if aOldIndex is -1 and aNewIndex is >= 0, aNewIndex refers to a just
// created item (i.e. called in case of a data Add)
// - if aOldIndex is >= 0 and aNewIndex is -1, aNewIndex refers to a just
// deleted item (i.e. called in case of a data Delete)
// - will update then sort all existing TSynTableFieldProperties.OrderedIndex
// values
// - the GetDataBuffer protected virtual method must have been overridden to
// properly return the record data for a given "physical/stored" index
// - aOldRecordData and aNewRecordData can be specified in order to guess
// if the field data has really been modified (speed up the update a lot
// to only sort indexed fields if its content has been really modified)
procedure FieldIndexModify(aOldIndex, aNewIndex: integer;
aOldRecordData, aNewRecordData: pointer);
/// return the total length of the given record buffer, encoded in our SBF
// compact binary format
function DataLength(RecordBuffer: pointer): integer;
{$ifndef NOVARIANTS}
/// create a Variant able to access any field content via late binding
// - i.e. you can use Var.Name to access the 'Name' field of record Var
// - if you leave ID and RecordBuffer void, a void record is created
function Data(aID: integer=0; RecordBuffer: pointer=nil;
RecordBufferLen: Integer=0): Variant; overload;
{$endif NOVARIANTS}
/// return a default content for ALL record fields
// - uses our SBF compact binary format
property DefaultRecordData: TSBFString read fDefaultRecordData;
/// list of TSynTableFieldProperties added via all AddField() call
// - this list will allow TSynBigTableRecord.AddFieldUpdate to refresh
// the data on disk according to the new field configuration
property AddedField: TList read fAddedField write fAddedField;
/// offset of the first variable length value field
property FieldVariableOffset: PtrUInt read fFieldVariableOffset;
public
{$ifndef DELPHI5OROLDER}
/// create a TJSONWriter, ready to be filled with GetJSONValues(W) below
// - will initialize all TJSONWriter.ColNames[] values according to the
// specified Fields index list, and initialize the JSON content
function CreateJSONWriter(JSON: TStream; Expand, withID: boolean;
const Fields: TSQLFieldIndexDynArray): TJSONWriter; overload;
/// create a TJSONWriter, ready to be filled with GetJSONValues(W) below
// - will initialize all TJSONWriter.ColNames[] values according to the
// specified Fields bit set, and initialize the JSON content
function CreateJSONWriter(JSON: TStream; Expand, withID: boolean;
const Fields: TSQLFieldBits): TJSONWriter; overload;
(** return the UTF-8 encoded JSON objects for the values contained
in the specified RecordBuffer encoded in our SBF compact binary format,
according to the Expand/WithID/Fields parameters of W
- if W.Expand is true, JSON data is an object, for direct use with any Ajax or .NET client:
! {"col1":val11,"col2":"val12"}
- if W.Expand is false, JSON data is serialized (as used in TSQLTableJSON)
! { "fieldCount":1,"values":["col1","col2",val11,"val12",val21,..] }
- only fields with a bit set in W.Fields will be appended
- if W.WithID is true, then the first ID field value is included *)
procedure GetJSONValues(aID: integer; RecordBuffer: PUTF8Char; W: TJSONWriter);
/// can be used to retrieve all values matching a preparated TSynTableStatement
// - this method matchs the TSynBigTableIterateEvent callback definition
// - Sender will be the TSynBigTable instance, and Opaque will point to a
// TSynTableStatement instance (with all fields initialized, including Writer)
function IterateJSONValues(Sender: TObject; Opaque: pointer; ID: integer;
Data: pointer; DataLen: integer): boolean;
{$endif DELPHI5OROLDER}
/// check the registered constraints according to a record SBF buffer
// - returns '' on success
// - returns an error message e.g. if a tftUnique constraint failed
// - RecordIndex=-1 in case of adding, or the physical index of the updated record
function Validate(RecordBuffer: pointer; RecordIndex: integer): string;
/// filter the SBF buffer record content with all registered filters
// - all field values are filtered in-place, following our SBF compact
// binary format encoding for this record
procedure Filter(var RecordBuffer: TSBFString);
/// event used for proper data retrieval of a given record buffer, according
// to the physical/storage index value (not per-ID index)
// - if not set, field indexes won't work
// - will be mapped e.g. to TSynBigTable.GetPointerFromPhysicalIndex
property GetRecordData: TSynTableGetRecordData read fGetRecordData write fGetRecordData;
public
/// the internal Table name used to identify it (e.g. from JSON or SQL)
// - similar to the SQL Table name
property TableName: RawUTF8 read fTableName write fTableName;
/// number of fields in this table
property FieldCount: integer read GetFieldCount;
/// retrieve the properties of a given field
// - returns nil if the specified Index is out of range
property Field[Index: integer]: TSynTableFieldProperties read GetFieldType;
/// retrieve the properties of a given field
// - returns nil if the specified Index is out of range
property FieldFromName[const aName: RawUTF8]: TSynTableFieldProperties read GetFieldFromName; default;
/// retrieve the index of a given field
// - returns -1 if the specified Index is out of range
property FieldIndexFromName[const aName: RawUTF8]: integer read GetFieldIndexFromName;
/// read-only access to the Field list
property FieldList: TObjectList read fField;
/// true if any field has a tfoUnique option set
property HasUniqueIndexes: boolean read fFieldHasUniqueIndexes;
end;
{$ifndef NOVARIANTS}
/// a custom variant type used to have direct access to a record content
// - use TSynTable.Data method to retrieve such a Variant
// - this variant will store internaly a SBF compact binary format
// representation of the record content
// - uses internally a TSynTableData object
TSynTableVariantType = class(TSynInvokeableVariantType)
protected
procedure IntGet(var Dest: TVarData; const V: TVarData; Name: PAnsiChar); override;
procedure IntSet(const V, Value: TVarData; Name: PAnsiChar); override;
public
/// retrieve the SBF compact binary format representation of a record content
class function ToSBF(const V: Variant): TSBFString;
/// retrieve the ID value associated to a record content
class function ToID(const V: Variant): integer;
/// retrieve the TSynTable instance associated to a record content
class function ToTable(const V: Variant): TSynTable;
/// clear the content
procedure Clear(var V: TVarData); override;
/// copy two record content
procedure Copy(var Dest: TVarData; const Source: TVarData;
const Indirect: Boolean); override;
end;
{$endif NOVARIANTS}
const
/// used by TSynTableStatement.WhereField for "SELECT .. FROM TableName WHERE ID=?"
SYNTABLESTATEMENTWHEREID = 0;
/// low-level integer comparison according to a specified operator
// - SBF must point to the values encoded in our SBF compact binary format
// - Value must contain the plain integer value
// - Value can be a Currency accessed via a PInt64
// - will work only for tftBoolean, tftUInt8, tftUInt16, tftUInt24,
// tftInt32, tftInt64 and tftCurrency field types
// - will handle only soEqualTo...soGreaterThanOrEqualTo operators
// - if SBFEnd is not nil, it will test for all values until SBF>=SBFEnd
// (can be used for tftArray)
// - returns true if both values match, or false otherwise
function CompareOperator(FieldType: TSynTableFieldType; SBF, SBFEnd: PUTF8Char;
Value: Int64; Oper: TCompareOperator): boolean; overload;
/// low-level floating-point comparison according to a specified operator
// - SBF must point to the values encoded in our SBF compact binary format
// - Value must contain the plain floating-point value
// - will work only for tftDouble field type
// - will handle only soEqualTo...soGreaterThanOrEqualTo operators
// - if SBFEnd is not nil, it will test for all values until SBF>=SBFEnd
// (can be used for tftArray)
// - returns true if both values match, or false otherwise
function CompareOperator(SBF, SBFEnd: PUTF8Char;
Value: double; Oper: TCompareOperator): boolean; overload;
/// low-level text comparison according to a specified operator
// - SBF must point to the values encoded in our SBF compact binary format
// - Value must contain the plain text value, in the same encoding (either
// WinAnsi either UTF-8, as FieldType defined for the SBF value)
// - will work only for tftWinAnsi and tftUTF8 field types
// - will handle all kind of operators (including soBeginWith, soContains and
// soSoundsLike*) but soSoundsLike* won't make use of the CaseSensitive parameter
// - for soSoundsLikeEnglish, soSoundsLikeFrench and soSoundsLikeSpanish
// operators, Value is not a real PUTF8Char but a prepared PSynSoundEx
// - if SBFEnd is not nil, it will test for all values until SBF>=SBFEnd
// (can be used for tftArray)
// - returns true if both values match, or false otherwise
function CompareOperator(FieldType: TSynTableFieldType; SBF, SBFEnd: PUTF8Char;
Value: PUTF8Char; ValueLen: integer; Oper: TCompareOperator;
CaseSensitive: boolean): boolean; overload;
/// convert any AnsiString content into our SBF compact binary format storage
procedure ToSBFStr(const Value: RawByteString; out Result: TSBFString);
{ ************ low-level buffer processing functions ************************* }
type
/// implements a thread-safe Bloom Filter storage
// - a "Bloom Filter" is a space-efficient probabilistic data structure,
// that is used to test whether an element is a member of a set. False positive
// matches are possible, but false negatives are not. Elements can be added to
// the set, but not removed. Typical use cases are to avoid unecessary
// slow disk or network access if possible, when a lot of items are involved.
// - memory use is very low, when compared to storage of all values: fewer
// than 10 bits per element are required for a 1% false positive probability,
// independent of the size or number of elements in the set - for instance,
// storing 10,000,000 items presence with 1% of false positive ratio
// would consume only 11.5 MB of memory, using 7 hash functions
// - use Insert() methods to add an item to the internal bits array, and
// Reset() to clear all bits array, if needed
// - MayExist() function would check if the supplied item was probably set
// - SaveTo() and LoadFrom() methods allow transmission of the bits array,
// for a disk/database storage or transmission over a network
// - internally, several (hardware-accelerated) crc32c hash functions will be
// used, with some random seed values, to simulate several hashing functions
// - Insert/MayExist/Reset methods are thread-safe
TSynBloomFilter = class(TSynPersistentLock)
private
fSize: cardinal;
fFalsePositivePercent: double;
fBits: cardinal;
fHashFunctions: cardinal;
fInserted: cardinal;
fStore: RawByteString;
function GetInserted: cardinal;
public
/// initialize the internal bits storage for a given number of items
// - by default, internal bits array size will be guess from a 1 % false
// positive rate - but you may specify another value, to reduce memory use
// - this constructor would compute and initialize Bits and HashFunctions
// corresponding to the expected false positive ratio
constructor Create(aSize: integer; aFalsePositivePercent: double = 1); reintroduce; overload;
/// initialize the internal bits storage from a SaveTo() binary buffer
// - this constructor will initialize the internal bits array calling LoadFrom()
constructor Create(const aSaved: RawByteString; aMagic: cardinal=$B1003F11); reintroduce; overload;
/// add an item in the internal bits array storage
// - this method is thread-safe
procedure Insert(const aValue: RawByteString); overload;
/// add an item in the internal bits array storage
// - this method is thread-safe
procedure Insert(aValue: pointer; aValueLen: integer); overload; virtual;
/// clear the internal bits array storage
// - you may call this method after some time, if some items may have
// been removed, to reduce false positives
// - this method is thread-safe
procedure Reset; virtual;
/// returns TRUE if the supplied items was probably set via Insert()
// - some false positive may occur, but not much than FalsePositivePercent
// - this method is thread-safe
function MayExist(const aValue: RawByteString): boolean; overload;
/// returns TRUE if the supplied items was probably set via Insert()
// - some false positive may occur, but not much than FalsePositivePercent
// - this method is thread-safe
function MayExist(aValue: pointer; aValueLen: integer): boolean; overload;
/// store the internal bits array into a binary buffer
// - may be used to transmit or store the state of a dataset, avoiding
// to recompute all Insert() at program startup, or to synchronize
// networks nodes information and reduce the number of remote requests
function SaveTo(aMagic: cardinal=$B1003F11): RawByteString; overload;
/// store the internal bits array into a binary buffer
// - may be used to transmit or store the state of a dataset, avoiding
// to recompute all Insert() at program startup, or to synchronize
// networks nodes information and reduce the number of remote requests
procedure SaveTo(aDest: TFileBufferWriter; aMagic: cardinal=$B1003F11); overload;
/// read the internal bits array from a binary buffer
// - as previously serialized by the SaveTo method
// - may be used to transmit or store the state of a dataset
function LoadFrom(const aSaved: RawByteString; aMagic: cardinal=$B1003F11): boolean; overload;
/// read the internal bits array from a binary buffer
// - as previously serialized by the SaveTo method
// - may be used to transmit or store the state of a dataset
function LoadFrom(P: PByte; PLen: integer; aMagic: cardinal=$B1003F11): boolean; overload; virtual;
published
/// maximum number of items which are expected to be inserted
property Size: cardinal read fSize;
/// expected percentage (1..100) of false positive results for MayExists()
property FalsePositivePercent: double read fFalsePositivePercent;
/// number of bits stored in the internal bits array
property Bits: cardinal read fBits;
/// how many hash functions would be applied for each Insert()
property HashFunctions: cardinal read fHashFunctions;
/// how many times the Insert() method has been called
property Inserted: cardinal read GetInserted;
end;
/// implements a thread-safe differential Bloom Filter storage
// - this inherited class is able to compute incremental serialization of
// its internal bits array, to reduce network use
// - an obfuscated revision counter is used to identify storage history
TSynBloomFilterDiff = class(TSynBloomFilter)
protected
fRevision: Int64;
fSnapShotAfterMinutes: cardinal;
fSnapshotAfterInsertCount: cardinal;
fSnapshotTimestamp: Int64;
fSnapshotInsertCount: cardinal;
fKnownRevision: Int64;
fKnownStore: RawByteString;
public
/// add an item in the internal bits array storage
// - this overloaded thread-safe method would compute fRevision
procedure Insert(aValue: pointer; aValueLen: integer); override;
/// clear the internal bits array storage
// - this overloaded thread-safe method would reset fRevision
procedure Reset; override;
/// store the internal bits array into an incremental binary buffer
// - here the difference from a previous SaveToDiff revision will be computed
// - if aKnownRevision is outdated (e.g. if equals 0), the whole bits array
// would be returned, and around 10 bits per item would be transmitted
// (for 1% false positive ratio)
// - incremental retrieval would then return around 10 bytes per newly added
// item since the last snapshot reference state (with 1% ratio, i.e. 7 hash
// functions)
function SaveToDiff(const aKnownRevision: Int64): RawByteString;
/// use the current internal bits array state as known revision
// - is done the first time SaveToDiff() is called, then after 1/32th of
// the filter size has been inserted (see SnapshotAfterInsertCount property),
// or after SnapShotAfterMinutes property timeout period
procedure DiffSnapshot;
/// retrieve the revision number from an incremental binary buffer
// - returns 0 if the supplied binary buffer does not match this bloom filter
function DiffKnownRevision(const aDiff: RawByteString): Int64;
/// read the internal bits array from an incremental binary buffer
// - as previously serialized by the SaveToDiff() method
// - may be used to transmit or store the state of a dataset
// - returns false if the supplied content is incorrect, e.g. if the known
// revision is deprecated
function LoadFromDiff(const aDiff: RawByteString): boolean;
/// the opaque revision number of this internal storage
// - is in fact the Unix timestamp shifted by 31 bits, and an incremental
// counter: this pattern will allow consistent IDs over several ServPanels
property Revision: Int64 read fRevision;
/// after how many Insert() the internal bits array storage should be
// promoted as known revision
// - equals Size div 32 by default
property SnapshotAfterInsertCount: cardinal read fSnapshotAfterInsertCount
write fSnapshotAfterInsertCount;
/// after how many time the internal bits array storage should be
// promoted as known revision
// - equals 30 minutes by default
property SnapShotAfterMinutes: cardinal read fSnapShotAfterMinutes
write fSnapShotAfterMinutes;
end;
/// RLE compression of a memory buffer containing mostly zeros
// - will store the number of consecutive zeros instead of plain zero bytes
// - used for spare bit sets, e.g. TSynBloomFilter serialization
// - will also compute the crc32c of the supplied content
// - use ZeroDecompress() to expand the compressed result
// - resulting content would be at most 14 bytes bigger than the input
// - you may use this function before SynLZ compression
procedure ZeroCompress(P: PAnsiChar; Len: integer; Dest: TFileBufferWriter);
/// RLE uncompression of a memory buffer containing mostly zeros
// - returns Dest='' if P^ is not a valid ZeroCompress() function result
// - used for spare bit sets, e.g. TSynBloomFilter serialization
// - will also check the crc32c of the supplied content
procedure ZeroDecompress(P: PByte; Len: integer; {$ifdef FPC}var{$else}out{$endif} Dest: RawByteString);
/// RLE compression of XORed memory buffers resulting in mostly zeros
// - will perform ZeroCompress(Dest^ := New^ xor Old^) without any temporary
// memory allocation
// - is used e.g. by TSynBloomFilterDiff.SaveToDiff() in incremental mode
// - will also compute the crc32c of the supplied content
procedure ZeroCompressXor(New,Old: PAnsiChar; Len: cardinal; Dest: TFileBufferWriter);
/// RLE uncompression and ORing of a memory buffer containing mostly zeros
// - will perform Dest^ := Dest^ or ZeroDecompress(P^) without any temporary
// memory allocation
// - is used e.g. by TSynBloomFilterDiff.LoadFromDiff() in incremental mode
// - returns false if P^ is not a valid ZeroCompress/ZeroCompressXor() result
// - will also check the crc32c of the supplied content
function ZeroDecompressOr(P,Dest: PAnsiChar; Len,DestLen: integer): boolean;
const
/// normal pattern search depth for DeltaCompress()
// - gives good results on most content
DELTA_LEVEL_FAST = 100;
/// brutal pattern search depth for DeltaCompress()
// - may become very slow, with minor benefit, on huge content
DELTA_LEVEL_BEST = 500;
/// 2MB as internal chunks/window default size for DeltaCompress()
// - will use up to 9 MB of RAM during DeltaCompress() - none in DeltaExtract()
DELTA_BUF_DEFAULT = 2 shl 20;
/// compute difference of two binary buffers
// - returns '=' for equal buffers, or an optimized binary delta
// - DeltaExtract() could be used later on to compute New from Old + Delta
function DeltaCompress(const New, Old: RawByteString;
Level: integer=DELTA_LEVEL_FAST; BufSize: integer=DELTA_BUF_DEFAULT): RawByteString; overload;
/// compute difference of two binary buffers
// - returns '=' for equal buffers, or an optimized binary delta
// - DeltaExtract() could be used later on to compute New from Old
function DeltaCompress(New, Old: PAnsiChar; NewSize, OldSize: integer;
Level: integer=DELTA_LEVEL_FAST; BufSize: integer=DELTA_BUF_DEFAULT): RawByteString; overload;
/// compute difference of two binary buffers
// - returns '=' for equal buffers, or an optimized binary delta
// - DeltaExtract() could be used later on to compute New from Old + Delta
// - caller should call Freemem(Delta) once finished with the output buffer
function DeltaCompress(New, Old: PAnsiChar; NewSize, OldSize: integer;
out Delta: PAnsiChar; Level: integer=DELTA_LEVEL_FAST; BufSize: integer=DELTA_BUF_DEFAULT): integer; overload;
type
/// result of function DeltaExtract()
TDeltaError = (
dsSuccess, dsCrcCopy, dsCrcComp, dsCrcBegin, dsCrcEnd, dsCrcExtract, dsFlag, dsLen);
/// returns how many bytes a DeltaCompress() result will expand to
function DeltaExtractSize(const Delta: RawByteString): integer; overload;
/// returns how many bytes a DeltaCompress() result will expand to
function DeltaExtractSize(Delta: PAnsiChar): integer; overload;
/// apply the delta binary as computed by DeltaCompress()
// - decompression don't use any RAM, will perform crc32c check, and is very fast
// - return dsSuccess if was uncompressed to aOutUpd as expected
function DeltaExtract(const Delta,Old: RawByteString; out New: RawByteString): TDeltaError; overload;
/// low-level apply the delta binary as computed by DeltaCompress()
// - New should already be allocated with DeltaExtractSize(Delta) bytes
// - as such, expect Delta, Old and New to be <> nil, and Delta <> '='
// - return dsSuccess if was uncompressed to aOutUpd as expected
function DeltaExtract(Delta,Old,New: PAnsiChar): TDeltaError; overload;
function ToText(err: TDeltaError): PShortString; overload;
type
/// safe decoding of a TFileBufferWriter content
// - similar to TFileBufferReader, but faster and only for in-memory buffer
// - is also safer, since will check for reaching end of buffer
// - raise a EFastReader exception on decoding error (e.g. if a buffer
// overflow may occur) or call OnErrorOverflow/OnErrorData event handlers
{$ifdef FPC_OR_UNICODE}TFastReader = record{$else}TFastReader = object{$endif}
public
/// the current position in the memory
P: PAnsiChar;
/// the last position in the buffer
Last: PAnsiChar;
/// use this event to customize the ErrorOverflow process
OnErrorOverflow: procedure of object;
/// use this event to customize the ErrorData process
OnErrorData: procedure(const fmt: RawUTF8; const args: array of const) of object;
/// some opaque value, which may be a version number to define the binary layout
Tag: PtrInt;
/// initialize the reader from a memory block
procedure Init(Buffer: pointer; Len: integer); overload;
/// initialize the reader from a RawByteString content
procedure Init(const Buffer: RawByteString); overload;
/// raise a EFastReader with an "overflow" error message
procedure ErrorOverflow;
/// raise a EFastReader with an "incorrect data" error message
procedure ErrorData(const fmt: RawUTF8; const args: array of const);
/// read the next 32-bit signed value from the buffer
function VarInt32: integer; {$ifdef HASINLINE}inline;{$endif}
/// read the next 32-bit unsigned value from the buffer
function VarUInt32: cardinal;
/// try to read the next 32-bit signed value from the buffer
// - don't change the current position
function PeekVarInt32(out value: PtrInt): boolean; {$ifdef HASINLINE}inline;{$endif}
/// try to read the next 32-bit unsigned value from the buffer
// - don't change the current position
function PeekVarUInt32(out value: PtrUInt): boolean;
/// read the next 32-bit unsigned value from the buffer
// - this version won't call ErrorOverflow, but return false on error
// - returns true on read success
function VarUInt32Safe(out Value: cardinal): boolean;
/// read the next 64-bit signed value from the buffer
function VarInt64: Int64; {$ifdef HASINLINE}inline;{$endif}
/// read the next 64-bit unsigned value from the buffer
function VarUInt64: QWord;
/// read the next RawUTF8 value from the buffer
function VarUTF8: RawUTF8; overload;
/// read the next RawUTF8 value from the buffer
procedure VarUTF8(out result: RawUTF8); overload;
/// read the next RawUTF8 value from the buffer
// - this version won't call ErrorOverflow, but return false on error
// - returns true on read success
function VarUTF8Safe(out Value: RawUTF8): boolean;
/// read the next RawByteString value from the buffer
function VarString: RawByteString; {$ifdef HASINLINE}inline;{$endif}
/// read the next pointer and length value from the buffer
procedure VarBlob(out result: TValueResult); overload; {$ifdef HASINLINE}inline;{$endif}
/// read the next pointer and length value from the buffer
function VarBlob: TValueResult; overload; {$ifdef HASINLINE}inline;{$endif}
/// read the next ShortString value from the buffer
function VarShortString: shortstring; {$ifdef HASINLINE}inline;{$endif}
/// fast ignore the next VarUInt32/VarInt32/VarUInt64/VarInt64 value
// - don't raise any exception, so caller could check explicitly for any EOF
procedure VarNextInt; overload; {$ifdef HASINLINE}inline;{$endif}
/// fast ignore the next count VarUInt32/VarInt32/VarUInt64/VarInt64 values
// - don't raise any exception, so caller could check explicitly for any EOF
procedure VarNextInt(count: integer); overload;
/// read the next byte from the buffer
function NextByte: byte; {$ifdef HASINLINE}inline;{$endif}
/// read the next byte from the buffer, checking
function NextByteSafe(dest: pointer): boolean; {$ifdef HASINLINE}inline;{$endif}
/// read the next 4 bytes from the buffer as a 32-bit unsigned value
function Next4: cardinal; {$ifdef HASINLINE}inline;{$endif}
/// read the next 8 bytes from the buffer as a 64-bit unsigned value
function Next8: Qword; {$ifdef HASINLINE}inline;{$endif}
/// consumes the next byte from the buffer, if matches a given value
function NextByteEquals(Value: byte): boolean; {$ifdef HASINLINE}inline;{$endif}
/// returns the current position, and move ahead the specified bytes
function Next(DataLen: PtrInt): pointer; {$ifdef HASINLINE}inline;{$endif}
/// returns the current position, and move ahead the specified bytes
function NextSafe(out Data: Pointer; DataLen: PtrInt): boolean; {$ifdef HASINLINE}inline;{$endif}
{$ifndef NOVARIANTS}
/// read the next variant from the buffer
// - is a wrapper around VariantLoad(), so may suffer from buffer overflow
procedure NextVariant(var Value: variant; CustomVariantOptions: pointer);
/// read the JSON-serialized TDocVariant from the buffer
// - matches TFileBufferWriter.WriteDocVariantData format
procedure NextDocVariantData(out Value: variant; CustomVariantOptions: pointer);
{$endif NOVARIANTS}
/// copy data from the current position, and move ahead the specified bytes
procedure Copy(out Dest; DataLen: PtrInt); {$ifdef HASINLINE}inline;{$endif}
/// copy data from the current position, and move ahead the specified bytes
// - this version won't call ErrorOverflow, but return false on error
// - returns true on read success
function CopySafe(out Dest; DataLen: PtrInt): boolean;
/// apply TDynArray.LoadFrom on the buffer
// - will unserialize a previously appended dynamic array, e.g. as
// ! aWriter.WriteDynArray(DA);
procedure Read(var DA: TDynArray; NoCheckHash: boolean=false);
/// retrieved cardinal values encoded with TFileBufferWriter.WriteVarUInt32Array
// - only supports wkUInt32, wkVarInt32, wkVarUInt32 kind of encoding
function ReadVarUInt32Array(var Values: TIntegerDynArray): PtrInt;
/// retrieve some TAlgoCompress buffer, appended via Write()
// - BufferOffset could be set to reserve some bytes before the uncompressed buffer
function ReadCompressed(Load: TAlgoCompressLoad=aclNormal; BufferOffset: integer=0): RawByteString;
/// returns TRUE if the current position is the end of the input stream
function EOF: boolean; {$ifdef HASINLINE}inline;{$endif}
/// returns remaining length (difference between Last and P)
function RemainingLength: PtrUInt; {$ifdef HASINLINE}inline;{$endif}
end;
/// abstract high-level handling of (SynLZ-)compressed persisted storage
// - LoadFromReader/SaveToWriter abstract methods should be overriden
// with proper binary persistence implementation
TSynPersistentStore = class(TSynPersistentLock)
protected
fName: RawUTF8;
fReader: TFastReader;
fReaderTemp: PRawByteString;
fLoadFromLastUncompressed, fSaveToLastUncompressed: integer;
fLoadFromLastAlgo: TAlgoCompress;
/// low-level virtual methods implementing the persistence reading
procedure LoadFromReader; virtual;
procedure SaveToWriter(aWriter: TFileBufferWriter); virtual;
public
/// initialize a void storage with the supplied name
constructor Create(const aName: RawUTF8); reintroduce; overload; virtual;
/// initialize a storage from a SaveTo persisted buffer
// - raise a EFastReader exception on decoding error
constructor CreateFrom(const aBuffer: RawByteString;
aLoad: TAlgoCompressLoad = aclNormal);
/// initialize a storage from a SaveTo persisted buffer
// - raise a EFastReader exception on decoding error
constructor CreateFromBuffer(aBuffer: pointer; aBufferLen: integer;
aLoad: TAlgoCompressLoad = aclNormal);
/// initialize a storage from a SaveTo persisted buffer
// - raise a EFastReader exception on decoding error
constructor CreateFromFile(const aFileName: TFileName;
aLoad: TAlgoCompressLoad = aclNormal);
/// fill the storage from a SaveTo persisted buffer
// - actually call the LoadFromReader() virtual method for persistence
// - raise a EFastReader exception on decoding error
procedure LoadFrom(const aBuffer: RawByteString;
aLoad: TAlgoCompressLoad = aclNormal); overload;
/// initialize the storage from a SaveTo persisted buffer
// - actually call the LoadFromReader() virtual method for persistence
// - raise a EFastReader exception on decoding error
procedure LoadFrom(aBuffer: pointer; aBufferLen: integer;
aLoad: TAlgoCompressLoad = aclNormal); overload; virtual;
/// initialize the storage from a SaveToFile content
// - actually call the LoadFromReader() virtual method for persistence
// - returns false if the file is not found, true if the file was loaded
// without any problem, or raise a EFastReader exception on decoding error
function LoadFromFile(const aFileName: TFileName;
aLoad: TAlgoCompressLoad = aclNormal): boolean;
/// persist the content as a SynLZ-compressed binary blob
// - to be retrieved later on via LoadFrom method
// - actually call the SaveToWriter() protected virtual method for persistence
// - you can specify ForcedAlgo if you want to override the default AlgoSynLZ
// - BufferOffset could be set to reserve some bytes before the compressed buffer
procedure SaveTo(out aBuffer: RawByteString; nocompression: boolean=false;
BufLen: integer=65536; ForcedAlgo: TAlgoCompress=nil; BufferOffset: integer=0); overload; virtual;
/// persist the content as a SynLZ-compressed binary blob
// - just an overloaded wrapper
function SaveTo(nocompression: boolean=false; BufLen: integer=65536;
ForcedAlgo: TAlgoCompress=nil; BufferOffset: integer=0): RawByteString; overload;
{$ifdef HASINLINE}inline;{$endif}
/// persist the content as a SynLZ-compressed binary file
// - to be retrieved later on via LoadFromFile method
// - returns the number of bytes of the resulting file
// - actually call the SaveTo method for persistence
function SaveToFile(const aFileName: TFileName; nocompression: boolean=false;
BufLen: integer=65536; ForcedAlgo: TAlgoCompress=nil): PtrUInt;
/// one optional text associated with this storage
// - you can define this field as published to serialize its value in log/JSON
property Name: RawUTF8 read fName;
/// after a LoadFrom(), contains the uncompressed data size read
property LoadFromLastUncompressed: integer read fLoadFromLastUncompressed;
/// after a SaveTo(), contains the uncompressed data size written
property SaveToLastUncompressed: integer read fSaveToLastUncompressed;
end;
/// implement binary persistence and JSON serialization (not deserialization)
TSynPersistentStoreJson = class(TSynPersistentStore)
protected
// append "name" -> inherited should add properties to the JSON object
procedure AddJSON(W: TTextWriter); virtual;
public
/// serialize this instance as a JSON object
function SaveToJSON(reformat: TTextWriterJSONFormat = jsonCompact): RawUTF8;
end;
type
/// item as stored in a TRawByteStringGroup instance
TRawByteStringGroupValue = record
Position: integer;
Value: RawByteString;
end;
PRawByteStringGroupValue = ^TRawByteStringGroupValue;
/// items as stored in a TRawByteStringGroup instance
TRawByteStringGroupValueDynArray = array of TRawByteStringGroupValue;
/// store several RawByteString content with optional concatenation
{$ifdef UNICODE}TRawByteStringGroup = record{$else}TRawByteStringGroup = object{$endif}
public
/// actual list storing the data
Values: TRawByteStringGroupValueDynArray;
/// how many items are currently stored in Values[]
Count: integer;
/// the current size of data stored in Values[]
Position: integer;
/// naive but efficient cache for Find()
LastFind: integer;
/// add a new item to Values[]
procedure Add(const aItem: RawByteString); overload;
/// add a new item to Values[]
procedure Add(aItem: pointer; aItemLen: integer); overload;
{$ifndef DELPHI5OROLDER}
/// add another TRawByteStringGroup to Values[]
procedure Add(const aAnother: TRawByteStringGroup); overload;
/// low-level method to abort the latest Add() call
// - warning: will work only once, if an Add() has actually been just called:
// otherwise, the behavior is unexpected, and may wrongly truncate data
procedure RemoveLastAdd;
/// compare two TRawByteStringGroup instance stored text
function Equals(const aAnother: TRawByteStringGroup): boolean;
{$endif DELPHI5OROLDER}
/// clear any stored information
procedure Clear;
/// append stored information into another RawByteString, and clear content
procedure AppendTextAndClear(var aDest: RawByteString);
// compact the Values[] array into a single item
// - is also used by AsText to compute a single RawByteString
procedure Compact;
/// return all content as a single RawByteString
// - will also compact the Values[] array into a single item (which is returned)
function AsText: RawByteString;
/// return all content as a single TByteDynArray
function AsBytes: TByteDynArray;
/// save all content into a TTextWriter instance
procedure Write(W: TTextWriter; Escape: TTextWriterKind=twJSONEscape); overload;
/// save all content into a TFileBufferWriter instance
procedure WriteBinary(W: TFileBufferWriter); overload;
/// save all content as a string into a TFileBufferWriter instance
// - storing the length as WriteVarUInt32() prefix
procedure WriteString(W: TFileBufferWriter);
/// add another TRawByteStringGroup previously serialized via WriteString()
procedure AddFromReader(var aReader: TFastReader);
/// returns a pointer to Values[] containing a given position
// - returns nil if not found
function Find(aPosition: integer): PRawByteStringGroupValue; overload;
/// returns a pointer to Values[].Value containing a given position and length
// - returns nil if not found
function Find(aPosition, aLength: integer): pointer; overload;
/// returns the text at a given position in Values[]
// - text should be in a single Values[] entry
procedure FindAsText(aPosition, aLength: integer; out aText: RawByteString); overload;
{$ifdef HASINLINE}inline;{$endif}
/// returns the text at a given position in Values[]
// - text should be in a single Values[] entry
function FindAsText(aPosition, aLength: integer): RawByteString; overload;
{$ifdef HASINLINE}inline;{$endif}
{$ifndef NOVARIANTS}
/// returns the text at a given position in Values[]
// - text should be in a single Values[] entry
// - explicitly returns null if the supplied text was not found
procedure FindAsVariant(aPosition, aLength: integer; out aDest: variant);
{$ifdef HASINLINE}inline;{$endif}
{$endif}
/// append the text at a given position in Values[], JSON escaped by default
// - text should be in a single Values[] entry
procedure FindWrite(aPosition, aLength: integer; W: TTextWriter;
Escape: TTextWriterKind=twJSONEscape; TrailingCharsToIgnore: integer=0);
{$ifdef HASINLINE}inline;{$endif}
/// append the blob at a given position in Values[], base-64 encoded
// - text should be in a single Values[] entry
procedure FindWriteBase64(aPosition, aLength: integer; W: TTextWriter;
withMagic: boolean);
{$ifdef HASINLINE}inline;{$endif}
/// copy the text at a given position in Values[]
// - text should be in a single Values[] entry
procedure FindMove(aPosition, aLength: integer; aDest: pointer);
end;
/// pointer reference to a TRawByteStringGroup
PRawByteStringGroup = ^TRawByteStringGroup;
{ ************ Security and Identifier classes ************************** }
type
/// 64-bit integer unique identifier, as computed by TSynUniqueIdentifierGenerator
// - they are increasing over time (so are much easier to store/shard/balance
// than UUID/GUID), and contain generation time and a 16-bit process ID
// - mapped by TSynUniqueIdentifierBits memory structure
// - may be used on client side for something similar to a MongoDB ObjectID,
// but compatible with TSQLRecord.ID: TID properties
TSynUniqueIdentifier = type Int64;
/// 16-bit unique process identifier, used to compute TSynUniqueIdentifier
// - each TSynUniqueIdentifierGenerator instance is expected to have
// its own unique process identifier, stored as a 16 bit integer 1..65535 value
TSynUniqueIdentifierProcess = type word;
{$A-}
/// map 64-bit integer unique identifier internal memory structure
// - as stored in TSynUniqueIdentifier = Int64 values, and computed by
// TSynUniqueIdentifierGenerator
// - bits 0..14 map a 15-bit increasing counter (collision-free)
// - bits 15..30 map a 16-bit process identifier
// - bits 31..63 map a 33-bit UTC time, encoded as seconds since Unix epoch
{$ifdef FPC_OR_UNICODE}TSynUniqueIdentifierBits = record{$else}TSynUniqueIdentifierBits = object{$endif}
public
/// the actual 64-bit storage value
// - in practice, only first 63 bits are used
Value: TSynUniqueIdentifier;
/// 15-bit counter (0..32767), starting with a random value
function Counter: word;
{$ifdef HASINLINE}inline;{$endif}
/// 16-bit unique process identifier
// - as specified to TSynUniqueIdentifierGenerator constructor
function ProcessID: TSynUniqueIdentifierProcess;
{$ifdef HASINLINE}inline;{$endif}
/// low-endian 4-byte value representing the seconds since the Unix epoch
// - time is expressed in Coordinated Universal Time (UTC), not local time
// - it uses in fact a 33-bit resolution, so is "Year 2038" bug-free
function CreateTimeUnix: TUnixTime;
{$ifdef HASINLINE}inline;{$endif}
/// fill this unique identifier structure from its TSynUniqueIdentifier value
// - is just a wrapper around PInt64(@self)^
procedure From(const AID: TSynUniqueIdentifier);
{$ifdef HASINLINE}inline;{$endif}
{$ifndef NOVARIANTS}
/// convert this identifier as an explicit TDocVariant JSON object
// - returns e.g.
// ! {"Created":"2016-04-19T15:27:58","Identifier":1,"Counter":1,
// ! "Value":3137644716930138113,"Hex":"2B8B273F00008001"}
function AsVariant: variant; {$ifdef HASINLINE}inline;{$endif}
/// convert this identifier to an explicit TDocVariant JSON object
// - returns e.g.
// ! {"Created":"2016-04-19T15:27:58","Identifier":1,"Counter":1,
// ! "Value":3137644716930138113,"Hex":"2B8B273F00008001"}
procedure ToVariant(out result: variant);
{$endif NOVARIANTS}
/// extract the UTC generation timestamp from the identifier as TDateTime
// - time is expressed in Coordinated Universal Time (UTC), not local time
function CreateDateTime: TDateTime;
{$ifdef HASINLINE}inline;{$endif}
/// extract the UTC generation timestamp from the identifier
// - time is expressed in Coordinated Universal Time (UTC), not local time
function CreateTimeLog: TTimeLog;
{$ifndef DELPHI5OROLDER}
/// compare two Identifiers
function Equal(const Another: TSynUniqueIdentifierBits): boolean;
{$ifdef HASINLINE}inline;{$endif}
{$endif DELPHI5OROLDER}
/// convert the identifier into a 16 chars hexadecimal string
function ToHexa: RawUTF8;
{$ifdef HASINLINE}inline;{$endif}
/// fill this unique identifier back from a 16 chars hexadecimal string
// - returns TRUE if the supplied hexadecimal is on the expected format
// - returns FALSE if the supplied text is invalid
function FromHexa(const hexa: RawUTF8): boolean;
/// fill this unique identifier with a fake value corresponding to a given
// timestamp
// - may be used e.g. to limit database queries on a particular time range
// - bits 0..30 would be 0, i.e. would set Counter = 0 and ProcessID = 0
procedure FromDateTime(const aDateTime: TDateTime);
/// fill this unique identifier with a fake value corresponding to a given
// timestamp
// - may be used e.g. to limit database queries on a particular time range
// - bits 0..30 would be 0, i.e. would set Counter = 0 and ProcessID = 0
procedure FromUnixTime(const aUnixTime: TUnixTime);
end;
{$A+}
/// points to a 64-bit integer identifier, as computed by TSynUniqueIdentifierGenerator
// - may be used to access the identifier internals, from its stored
// Int64 or TSynUniqueIdentifier value
PSynUniqueIdentifierBits = ^TSynUniqueIdentifierBits;
/// a 24 chars cyphered hexadecimal string, mapping a TSynUniqueIdentifier
// - has handled by TSynUniqueIdentifierGenerator.ToObfuscated/FromObfuscated
TSynUniqueIdentifierObfuscated = type RawUTF8;
/// thread-safe 64-bit integer unique identifier computation
// - may be used on client side for something similar to a MongoDB ObjectID,
// but compatible with TSQLRecord.ID: TID properties, since it will contain
// a 63-bit unsigned integer, following our ORM expectations
// - each identifier would contain a 16-bit process identifier, which is
// supplied by the application, and should be unique for this process at a
// given time
// - identifiers may be obfuscated as hexadecimal text, using both encryption
// and digital signature
TSynUniqueIdentifierGenerator = class(TSynPersistent)
protected
fUnixCreateTime: cardinal;
fLatestCounterOverflowUnixCreateTime: cardinal;
fIdentifier: TSynUniqueIdentifierProcess;
fIdentifierShifted: cardinal;
fLastCounter: cardinal;
fCrypto: array[0..7] of cardinal; // only fCrypto[6..7] are used in practice
fCryptoCRC: cardinal;
fSafe: TSynLocker;
function GetComputedCount: Int64;
public
/// initialize the generator for the given 16-bit process identifier
// - you can supply an obfuscation key, which should be shared for the
// whole system, so that you may use FromObfuscated/ToObfuscated methods
constructor Create(aIdentifier: TSynUniqueIdentifierProcess;
const aSharedObfuscationKey: RawUTF8=''); reintroduce;
/// finalize the generator structure
destructor Destroy; override;
/// return a new unique ID
// - this method is very optimized, and would use very little CPU
procedure ComputeNew(out result: TSynUniqueIdentifierBits); overload;
/// return a new unique ID, type-casted to an Int64
function ComputeNew: Int64; overload;
{$ifdef HASINLINE}inline;{$endif}
/// return an unique ID matching this generator pattern, at a given timestamp
// - may be used e.g. to limit database queries on a particular time range
procedure ComputeFromDateTime(const aDateTime: TDateTime; out result: TSynUniqueIdentifierBits);
/// return an unique ID matching this generator pattern, at a given timestamp
// - may be used e.g. to limit database queries on a particular time range
procedure ComputeFromUnixTime(const aUnixTime: TUnixTime; out result: TSynUniqueIdentifierBits);
/// map a TSynUniqueIdentifier as 24 chars cyphered hexadecimal text
// - cyphering includes simple key-based encryption and a CRC-32 digital signature
function ToObfuscated(const aIdentifier: TSynUniqueIdentifier): TSynUniqueIdentifierObfuscated;
/// retrieve a TSynUniqueIdentifier from 24 chars cyphered hexadecimal text
// - any file extension (e.g. '.jpeg') would be first deleted from the
// supplied obfuscated text
// - returns true if the supplied obfuscated text has the expected layout
// and a valid digital signature
// - returns false if the supplied obfuscated text is invalid
function FromObfuscated(const aObfuscated: TSynUniqueIdentifierObfuscated;
out aIdentifier: TSynUniqueIdentifier): boolean;
/// some 32-bit value, derivated from aSharedObfuscationKey as supplied
// to the class constructor
// - FromObfuscated and ToObfuscated methods will validate their hexadecimal
// content with this value to secure the associated CRC
// - may be used e.g. as system-depending salt
property CryptoCRC: cardinal read fCryptoCRC;
/// direct access to the associated mutex
property Safe: TSynLocker read fSafe;
published
/// the process identifier, associated with this generator
property Identifier: TSynUniqueIdentifierProcess read fIdentifier;
/// how many times ComputeNew method has been called
property ComputedCount: Int64 read GetComputedCount;
end;
type
/// abstract TSynPersistent class allowing safe storage of a password
// - the associated Password, e.g. for storage or transmission encryption
// will be persisted encrypted with a private key (which can be customized)
// - if default simple symmetric encryption is not enough, you may define
// a custom TSynPersistentWithPasswordUserCrypt callback, e.g. to
// SynCrypto's CryptDataForCurrentUser, for hardened password storage
// - a published property should be defined as such in inherited class:
// ! property PasswordPropertyName: RawUTF8 read fPassword write fPassword;
// - use the PassWordPlain property to access to its uncyphered value
TSynPersistentWithPassword = class(TSynPersistent)
protected
fPassWord: RawUTF8;
fKey: cardinal;
function GetKey: cardinal;
{$ifdef HASINLINE}inline;{$endif}
function GetPassWordPlain: RawUTF8;
function GetPassWordPlainInternal(AppSecret: RawUTF8): RawUTF8;
procedure SetPassWordPlain(const Value: RawUTF8);
public
/// finalize the instance
destructor Destroy; override;
/// this class method could be used to compute the encrypted password,
// ready to be stored as JSON, according to a given private key
class function ComputePassword(const PlainPassword: RawUTF8;
CustomKey: cardinal=0): RawUTF8; overload;
/// this class method could be used to compute the encrypted password from
// a binary digest, ready to be stored as JSON, according to a given private key
// - just a wrapper around ComputePassword(BinToBase64URI())
class function ComputePassword(PlainPassword: pointer; PlainPasswordLen: integer;
CustomKey: cardinal=0): RawUTF8; overload;
/// this class method could be used to decrypt a password, stored as JSON,
// according to a given private key
// - may trigger a ESynException if the password was stored using a custom
// TSynPersistentWithPasswordUserCrypt callback, and the current user
// doesn't match the expected user stored in the field
class function ComputePlainPassword(const CypheredPassword: RawUTF8;
CustomKey: cardinal=0; const AppSecret: RawUTF8=''): RawUTF8;
/// low-level function used to identify if a given field is a Password
// - this method is used e.g. by TJSONSerializer.WriteObject to identify the
// password field, since its published name is set by the inherited classes
function GetPasswordFieldAddress: pointer;
{$ifdef HASINLINE}inline;{$endif}
/// the private key used to cypher the password storage on serialization
// - application can override the default 0 value at runtime
property Key: cardinal read GetKey write fKey;
/// access to the associated unencrypted Password value
// - read may trigger a ESynException if the password was stored using a
// custom TSynPersistentWithPasswordUserCrypt callback, and the current user
// doesn't match the expected user stored in the field
property PasswordPlain: RawUTF8 read GetPassWordPlain write SetPassWordPlain;
end;
var
/// function prototype to customize TSynPersistent class password storage
// - is called when 'user1:base64pass1,user2:base64pass2' layout is found,
// and the current user logged on the system is user1 or user2
// - you should not call this low-level method, but assign e.g. from SynCrypto:
// $ TSynPersistentWithPasswordUserCrypt := CryptDataForCurrentUser;
TSynPersistentWithPasswordUserCrypt:
function(const Data,AppServer: RawByteString; Encrypt: boolean): RawByteString;
type
/// could be used to store a credential pair, as user name and password
// - password will be stored with TSynPersistentWithPassword encryption
TSynUserPassword = class(TSynPersistentWithPassword)
protected
fUserName: RawUTF8;
published
/// the associated user name
property UserName: RawUTF8 read FUserName write FUserName;
/// the associated encrypted password
// - use the PasswordPlain public property to access to the uncrypted password
property Password: RawUTF8 read FPassword write FPassword;
end;
/// handle safe storage of any connection properties
// - would be used by SynDB.pas to serialize TSQLDBConnectionProperties, or
// by mORMot.pas to serialize TSQLRest instances
// - the password will be stored as Base64, after a simple encryption as
// defined by TSynPersistentWithPassword
// - typical content could be:
// $ {
// $ "Kind": "TSQLDBSQLite3ConnectionProperties",
// $ "ServerName": "server",
// $ "DatabaseName": "",
// $ "User": "",
// $ "Password": "PtvlPA=="
// $ }
// - the "Kind" value will be used to let the corresponding TSQLRest or
// TSQLDBConnectionProperties NewInstance*() class methods create the
// actual instance, from its class name
TSynConnectionDefinition = class(TSynPersistentWithPassword)
protected
fKind: string;
fServerName: RawUTF8;
fDatabaseName: RawUTF8;
fUser: RawUTF8;
public
/// unserialize the database definition from JSON
// - as previously serialized with the SaveToJSON method
// - you can specify a custom Key used for password encryption, if the
// default value is not safe enough for you
// - this method won't use JSONToObject() so avoid any dependency to mORMot.pas
constructor CreateFromJSON(const JSON: RawUTF8; Key: cardinal=0); virtual;
/// serialize the database definition as JSON
// - this method won't use ObjectToJSON() so avoid any dependency to mORMot.pas
function SaveToJSON: RawUTF8; virtual;
published
/// the class name implementing the connection or TSQLRest instance
// - will be used to instantiate the expected class type
property Kind: string read fKind write fKind;
/// the associated server name (or file, for SQLite3) to be connected to
property ServerName: RawUTF8 read fServerName write fServerName;
/// the associated database name (if any), or additional options
property DatabaseName: RawUTF8 read fDatabaseName write fDatabaseName;
/// the associated User Identifier (if any)
property User: RawUTF8 read fUser write fUser;
/// the associated Password, e.g. for storage or transmission encryption
// - will be persisted encrypted with a private key
// - use the PassWordPlain property to access to its uncyphered value
property Password: RawUTF8 read fPassword write fPassword;
end;
type
/// class-reference type (metaclass) of an authentication class
TSynAuthenticationClass = class of TSynAuthenticationAbstract;
/// abstract authentication class, implementing safe token/challenge security
// and a list of active sessions
// - do not use this class, but plain TSynAuthentication
TSynAuthenticationAbstract = class
protected
fSessions: TIntegerDynArray;
fSessionsCount: Integer;
fSessionGenerator: integer;
fTokenSeed: Int64;
fSafe: TSynLocker;
function ComputeCredential(previous: boolean; const UserName,PassWord: RawUTF8): cardinal; virtual;
function GetPassword(const UserName: RawUTF8; out Password: RawUTF8): boolean; virtual; abstract;
function GetUsersCount: integer; virtual; abstract;
public
/// initialize the authentication scheme
constructor Create;
/// finalize the authentation
destructor Destroy; override;
/// register one credential for a given user
// - this abstract method will raise an exception: inherited classes should
// implement them as expected
procedure AuthenticateUser(const aName, aPassword: RawUTF8); virtual;
/// unregister one credential for a given user
// - this abstract method will raise an exception: inherited classes should
// implement them as expected
procedure DisauthenticateUser(const aName: RawUTF8); virtual;
/// create a new session
// - should return 0 on authentication error, or an integer session ID
// - this method will check the User name and password, and create a new session
function CreateSession(const User: RawUTF8; Hash: cardinal): integer; virtual;
/// check if the session exists in the internal list
function SessionExists(aID: integer): boolean;
/// delete a session
procedure RemoveSession(aID: integer);
/// returns the current identification token
// - to be sent to the client for its authentication challenge
function CurrentToken: Int64;
/// the number of current opened sessions
property SessionsCount: integer read fSessionsCount;
/// the number of registered users
property UsersCount: integer read GetUsersCount;
/// to be used to compute a Hash on the client sude, for a given Token
// - the token should have been retrieved from the server, and the client
// should compute and return this hash value, to perform the authentication
// challenge and create the session
// - internal algorithm is not cryptographic secure, but fast and safe
class function ComputeHash(Token: Int64; const UserName,PassWord: RawUTF8): cardinal; virtual;
end;
/// simple authentication class, implementing safe token/challenge security
// - maintain a list of user / name credential pairs, and a list of sessions
// - is not meant to handle authorization, just plain user access validation
// - used e.g. by TSQLDBConnection.RemoteProcessMessage (on server side) and
// TSQLDBProxyConnectionPropertiesAbstract (on client side) in SynDB.pas
TSynAuthentication = class(TSynAuthenticationAbstract)
protected
fCredentials: TSynNameValue; // store user/password pairs
function GetPassword(const UserName: RawUTF8; out Password: RawUTF8): boolean; override;
function GetUsersCount: integer; override;
public
/// initialize the authentication scheme
// - you can optionally register one user credential
constructor Create(const aUserName: RawUTF8=''; const aPassword: RawUTF8=''); reintroduce;
/// register one credential for a given user
procedure AuthenticateUser(const aName, aPassword: RawUTF8); override;
/// unregister one credential for a given user
procedure DisauthenticateUser(const aName: RawUTF8); override;
end;
{ ************ Expression Search Engine ************************** }
type
/// exception type used by TExprParser
EExprParser = class(ESynException);
/// identify an expression search engine node type, as used by TExprParser
TExprNodeType = (entWord, entNot, entOr, entAnd);
/// results returned by TExprParserAbstract.Parse method
TExprParserResult = (
eprSuccess, eprNoExpression,
eprMissingParenthesis, eprTooManyParenthesis, eprMissingFinalWord,
eprInvalidExpression, eprUnknownVariable, eprUnsupportedOperator,
eprInvalidConstantOrVariable);
TParserAbstract = class;
/// stores an expression search engine node, as used by TExprParser
TExprNode = class(TSynPersistent)
protected
fNext: TExprNode;
fNodeType: TExprNodeType;
function Append(node: TExprNode): boolean;
public
/// initialize a node for the search engine
constructor Create(nodeType: TExprNodeType); reintroduce;
/// recursively destroys the linked list of nodes (i.e. Next)
destructor Destroy; override;
/// browse all nodes until Next = nil
function Last: TExprNode;
/// points to the next node in the parsed tree
property Next: TExprNode read fNext;
/// what is actually stored in this node
property NodeType: TExprNodeType read fNodeType;
end;
/// abstract class to handle word search, as used by TExprParser
TExprNodeWordAbstract = class(TExprNode)
protected
fOwner: TParserAbstract;
fWord: RawUTF8;
/// should be set from actual data before TExprParser.Found is called
fFound: boolean;
function ParseWord: TExprParserResult; virtual; abstract;
public
/// you should override this virtual constructor for proper initialization
constructor Create(aOwner: TParserAbstract; const aWord: RawUTF8); reintroduce; virtual;
end;
/// class-reference type (metaclass) for a TExprNode
// - allow to customize the actual searching process for entWord
TExprNodeWordClass = class of TExprNodeWordAbstract;
/// parent class of TExprParserAbstract
TParserAbstract = class(TSynPersistent)
protected
fExpression, fCurrentWord, fAndWord, fOrWord, fNotWord: RawUTF8;
fCurrent: PUTF8Char;
fCurrentError: TExprParserResult;
fFirstNode: TExprNode;
fWordClass: TExprNodeWordClass;
fWords: array of TExprNodeWordAbstract;
fWordCount: integer;
fNoWordIsAnd: boolean;
fFoundStack: array[byte] of boolean; // simple stack-based virtual machine
procedure ParseNextCurrentWord; virtual; abstract;
function ParseExpr: TExprNode;
function ParseFactor: TExprNode;
function ParseTerm: TExprNode;
procedure Clear; virtual;
// override this method to initialize fWordClass and fAnd/Or/NotWord
procedure Initialize; virtual; abstract;
/// perform the expression search over TExprNodeWord.fFound flags
// - warning: caller should check that fFirstNode<>nil (e.g. WordCount>0)
function Execute: boolean; {$ifdef HASINLINE}inline;{$endif}
public
/// initialize an expression parser
constructor Create; override;
/// finalize the expression parser
destructor Destroy; override;
/// initialize the parser from a given text expression
function Parse(const aExpression: RawUTF8): TExprParserResult;
/// try this parser class on a given text expression
// - returns '' on success, or an explicit error message (e.g.
// 'Missing parenthesis')
class function ParseError(const aExpression: RawUTF8): RawUTF8;
/// the associated text expression used to define the search
property Expression: RawUTF8 read fExpression;
/// how many words did appear in the search expression
property WordCount: integer read fWordCount;
end;
/// abstract class to parse a text expression into nodes
// - you should inherit this class to provide actual text search
// - searched expressions can use parenthesis and &=AND -=WITHOUT +=OR operators,
// e.g. '((w1 & w2) - w3) + w4' means ((w1 and w2) without w3) or w4
// - no operator is handled like a AND, e.g. 'w1 w2' = 'w1 & w2'
TExprParserAbstract = class(TParserAbstract)
protected
procedure ParseNextCurrentWord; override;
// may be overriden to provide custom words escaping (e.g. handle quotes)
procedure ParseNextWord; virtual;
procedure Initialize; override;
end;
/// search expression engine using TMatch for the actual word searches
TExprParserMatch = class(TExprParserAbstract)
protected
fCaseSensitive: boolean;
fMatchedLastSet: integer;
procedure Initialize; override;
public
/// initialize the search engine
constructor Create(aCaseSensitive: boolean = true); reintroduce;
/// returns TRUE if the expression is within the text buffer
function Search(aText: PUTF8Char; aTextLen: PtrInt): boolean; overload;
/// returns TRUE if the expression is within the text buffer
function Search(const aText: RawUTF8): boolean; overload; {$ifdef HASINLINE}inline;{$endif}
end;
const
/// may be used when overriding TExprParserAbstract.ParseNextWord method
PARSER_STOPCHAR = ['&', '+', '-', '(', ')'];
function ToText(r: TExprParserResult): PShortString; overload;
function ToUTF8(r: TExprParserResult): RawUTF8; overload;
{ ************ Multi-Threading classes ************************** }
type
/// internal item definition, used by TPendingTaskList storage
TPendingTaskListItem = packed record
/// the task should be executed when TPendingTaskList.GetTimestamp reaches
// this value
Timestamp: Int64;
/// the associated task, stored by representation as raw binary
Task: RawByteString;
end;
/// internal list definition, used by TPendingTaskList storage
TPendingTaskListItemDynArray = array of TPendingTaskListItem;
/// handle a list of tasks, stored as RawByteString, with a time stamp
// - internal time stamps would be GetTickCount64 by default, so have a
// resolution of about 16 ms under Windows
// - you can add tasks to the internal list, to be executed after a given
// delay, using a post/peek like algorithm
// - execution delays are not expected to be accurate, but are best guess,
// according to NextTask call
// - this implementation is thread-safe, thanks to the Safe internal locker
TPendingTaskList = class(TSynPersistentLock)
protected
fCount: Integer;
fTask: TPendingTaskListItemDynArray;
fTasks: TDynArray;
function GetCount: integer;
function GetTimestamp: Int64; virtual;
public
/// initialize the list memory and resources
constructor Create; override;
/// append a task, specifying a delay in milliseconds from current time
procedure AddTask(aMilliSecondsDelayFromNow: integer; const aTask: RawByteString); virtual;
/// append several tasks, specifying a delay in milliseconds between tasks
// - first supplied delay would be computed from the current time, then
// it would specify how much time to wait between the next supplied task
procedure AddTasks(const aMilliSecondsDelays: array of integer;
const aTasks: array of RawByteString);
/// retrieve the next pending task
// - returns '' if there is no scheduled task available at the current time
// - returns the next stack as defined corresponding to its specified delay
function NextPendingTask: RawByteString; virtual;
/// flush all pending tasks
procedure Clear; virtual;
/// access to the locking methods of this instance
// - use Safe.Lock/TryLock with a try ... finally Safe.Unlock block
property Safe: PSynlocker read fSafe;
/// access to the internal TPendingTaskListItem.Timestamp stored value
// - corresponding to the current time
// - default implementation is to return GetTickCount64, with a 16 ms
// typical resolution under Windows
property Timestamp: Int64 read GetTimestamp;
/// how many pending tasks are currently defined
property Count: integer read GetCount;
/// direct low-level access to the internal task list
// - warning: this dynamic array length is the list capacity: use Count
// property to retrieve the exact number of stored items
// - use Safe.Lock/TryLock with a try ... finally Safe.Unlock block for
// thread-safe access to this array
// - items are stored in increasing Timestamp, i.e. the first item is
// the next one which would be returned by the NextPendingTask method
property Task: TPendingTaskListItemDynArray read fTask;
end;
{$ifndef LVCL} // LVCL does not implement TEvent
type
{$M+}
TSynBackgroundThreadAbstract = class;
TSynBackgroundThreadEvent = class;
{$M-}
/// idle method called by TSynBackgroundThreadAbstract in the caller thread
// during remote blocking process in a background thread
// - typical use is to run Application.ProcessMessages, e.g. for
// TSQLRestClientURI.URI() to provide a responsive UI even in case of slow
// blocking remote access
// - provide the time elapsed (in milliseconds) from the request start (can be
// used e.g. to popup a temporary message to wait)
// - is call once with ElapsedMS=0 at request start
// - is call once with ElapsedMS=-1 at request ending
// - see TLoginForm.OnIdleProcess and OnIdleProcessForm in mORMotUILogin.pas
TOnIdleSynBackgroundThread = procedure(Sender: TSynBackgroundThreadAbstract;
ElapsedMS: Integer) of object;
/// event prototype used e.g. by TSynBackgroundThreadAbstract callbacks
// - a similar signature is defined in SynCrtSock and LVCL.Classes
TNotifyThreadEvent = procedure(Sender: TThread) of object;
/// abstract TThread with its own execution content
// - you should not use this class directly, but use either
// TSynBackgroundThreadMethodAbstract / TSynBackgroundThreadEvent /
// TSynBackgroundThreadMethod and provide a much more convenient callback
TSynBackgroundThreadAbstract = class(TThread)
protected
fProcessEvent: TEvent;
fOnBeforeExecute: TNotifyThreadEvent;
fOnAfterExecute: TNotifyThreadEvent;
fThreadName: RawUTF8;
fExecute: (exCreated,exRun,exFinished);
fExecuteLoopPause: boolean;
procedure SetExecuteLoopPause(dopause: boolean);
/// where the main process takes place
procedure Execute; override;
procedure ExecuteLoop; virtual; abstract;
public
/// initialize the thread
// - you could define some callbacks to nest the thread execution, e.g.
// assigned to TSQLRestServer.BeginCurrentThread/EndCurrentThread, or
// at least set OnAfterExecute to TSynLogFamily.OnThreadEnded
constructor Create(const aThreadName: RawUTF8; OnBeforeExecute: TNotifyThreadEvent=nil;
OnAfterExecute: TNotifyThreadEvent=nil; CreateSuspended: boolean=false); reintroduce;
/// release used resources
destructor Destroy; override;
{$ifndef HASTTHREADSTART}
/// method to be called to start the thread
// - Resume is deprecated in the newest RTL, since some OS - e.g. Linux -
// do not implement this pause/resume feature; we define here this method
// for older versions of Delphi
procedure Start;
{$endif}
{$ifdef HASTTHREADTERMINATESET}
/// properly terminate the thread
// - called by TThread.Terminate
procedure TerminatedSet; override;
{$else}
/// properly terminate the thread
// - called by reintroduced Terminate
procedure TerminatedSet; virtual;
/// reintroduced to call TeminatedSet
procedure Terminate; reintroduce;
{$endif}
/// wait for Execute/ExecuteLoop to be ended (i.e. fExecute<>exRun)
procedure WaitForNotExecuting(maxMS: integer=500);
/// temporary stop the execution of ExecuteLoop, until set back to false
// - may be used e.g. by TSynBackgroundTimer to delay the process of
// background tasks
property Pause: boolean read fExecuteLoopPause write SetExecuteLoopPause;
/// access to the low-level associated event used to notify task execution
// to the background thread
// - you may call ProcessEvent.SetEvent to trigger the internal process loop
property ProcessEvent: TEvent read fProcessEvent;
/// defined as public since may be used to terminate the processing methods
property Terminated;
end;
/// state machine status of the TSynBackgroundThreadAbstract process
TSynBackgroundThreadProcessStep = (
flagIdle, flagStarted, flagFinished, flagDestroying);
/// state machine statuses of the TSynBackgroundThreadAbstract process
TSynBackgroundThreadProcessSteps = set of TSynBackgroundThreadProcessStep;
/// abstract TThread able to run a method in its own execution content
// - typical use is a background thread for processing data or remote access,
// while the UI will be still responsive by running OnIdle event in loop: see
// e.g. how TSQLRestClientURI.OnIdle handle this in mORMot.pas unit
// - you should not use this class directly, but inherit from it and override
// the Process method, or use either TSynBackgroundThreadEvent /
// TSynBackgroundThreadMethod and provide a much more convenient callback
TSynBackgroundThreadMethodAbstract = class(TSynBackgroundThreadAbstract)
protected
fCallerEvent: TEvent;
fParam: pointer;
fCallerThreadID: TThreadID;
fBackgroundException: Exception;
fOnIdle: TOnIdleSynBackgroundThread;
fOnBeforeProcess: TNotifyThreadEvent;
fOnAfterProcess: TNotifyThreadEvent;
fPendingProcessFlag: TSynBackgroundThreadProcessStep;
fPendingProcessLock: TSynLocker;
procedure ExecuteLoop; override;
function OnIdleProcessNotify(start: Int64): integer;
function GetOnIdleBackgroundThreadActive: boolean;
function GetPendingProcess: TSynBackgroundThreadProcessStep;
procedure SetPendingProcess(State: TSynBackgroundThreadProcessStep);
// returns flagIdle if acquired, flagDestroying if terminated
function AcquireThread: TSynBackgroundThreadProcessStep;
procedure WaitForFinished(start: Int64; const onmainthreadidle: TNotifyEvent);
/// called by Execute method when fProcessParams<>nil and fEvent is notified
procedure Process; virtual; abstract;
public
/// initialize the thread
// - if aOnIdle is not set (i.e. equals nil), it will simply wait for
// the background process to finish until RunAndWait() will return
// - you could define some callbacks to nest the thread execution, e.g.
// assigned to TSQLRestServer.BeginCurrentThread/EndCurrentThread
constructor Create(aOnIdle: TOnIdleSynBackgroundThread;
const aThreadName: RawUTF8; OnBeforeExecute: TNotifyThreadEvent=nil;
OnAfterExecute: TNotifyThreadEvent=nil); reintroduce;
/// finalize the thread
destructor Destroy; override;
/// launch Process abstract method asynchronously in the background thread
// - wait until process is finished, calling OnIdle() callback in
// the meanwhile
// - any exception raised in background thread will be translated in the
// caller thread
// - returns false if self is not set, or if called from the same thread
// as it is currently processing (to avoid race condition from OnIdle()
// callback)
// - returns true when the background process is finished
// - OpaqueParam will be used to specify a thread-safe content for the
// background process
// - this method is thread-safe, that is it will wait for any started process
// already launch by another thread: you may call this method from any
// thread, even if its main purpose is to be called from the main UI thread
function RunAndWait(OpaqueParam: pointer): boolean;
/// set a callback event to be executed in loop during remote blocking
// process, e.g. to refresh the UI during a somewhat long request
// - you can assign a callback to this property, calling for instance
// Application.ProcessMessages, to execute the remote request in a
// background thread, but let the UI still be reactive: the
// TLoginForm.OnIdleProcess and OnIdleProcessForm methods of
// mORMotUILogin.pas will match this property expectations
// - if OnIdle is not set (i.e. equals nil), it will simply wait for
// the background process to finish until RunAndWait() will return
property OnIdle: TOnIdleSynBackgroundThread read fOnIdle write fOnIdle;
/// TRUE if the background thread is active, and OnIdle event is called
// during process
// - to be used e.g. to ensure no re-entrance from User Interface messages
property OnIdleBackgroundThreadActive: Boolean read GetOnIdleBackgroundThreadActive;
/// optional callback event triggered in Execute before each Process
property OnBeforeProcess: TNotifyThreadEvent read fOnBeforeProcess write fOnBeforeProcess;
/// optional callback event triggered in Execute after each Process
property OnAfterProcess: TNotifyThreadEvent read fOnAfterProcess write fOnAfterProcess;
end;
/// background process method called by TSynBackgroundThreadEvent
// - will supply the OpaqueParam parameter as provided to RunAndWait()
// method when the Process virtual method will be executed
TOnProcessSynBackgroundThread = procedure(Sender: TSynBackgroundThreadEvent;
ProcessOpaqueParam: pointer) of object;
/// allow background thread process of a method callback
TSynBackgroundThreadEvent = class(TSynBackgroundThreadMethodAbstract)
protected
fOnProcess: TOnProcessSynBackgroundThread;
/// just call the OnProcess handler
procedure Process; override;
public
/// initialize the thread
// - if aOnIdle is not set (i.e. equals nil), it will simply wait for
// the background process to finish until RunAndWait() will return
constructor Create(aOnProcess: TOnProcessSynBackgroundThread;
aOnIdle: TOnIdleSynBackgroundThread; const aThreadName: RawUTF8); reintroduce;
/// provide a method handler to be execute in the background thread
// - triggered by RunAndWait() method - which will wait until finished
// - the OpaqueParam as specified to RunAndWait() will be supplied here
property OnProcess: TOnProcessSynBackgroundThread read fOnProcess write fOnProcess;
end;
/// allow background thread process of a variable TThreadMethod callback
TSynBackgroundThreadMethod = class(TSynBackgroundThreadMethodAbstract)
protected
/// just call the TThreadMethod, as supplied to RunAndWait()
procedure Process; override;
public
/// run once the supplied TThreadMethod callback
// - use this method, and not the inherited RunAndWait()
procedure RunAndWait(Method: TThreadMethod); reintroduce;
end;
/// background process procedure called by TSynBackgroundThreadProcedure
// - will supply the OpaqueParam parameter as provided to RunAndWait()
// method when the Process virtual method will be executed
TOnProcessSynBackgroundThreadProc = procedure(ProcessOpaqueParam: pointer);
/// allow background thread process of a procedure callback
TSynBackgroundThreadProcedure = class(TSynBackgroundThreadMethodAbstract)
protected
fOnProcess: TOnProcessSynBackgroundThreadProc;
/// just call the OnProcess handler
procedure Process; override;
public
/// initialize the thread
// - if aOnIdle is not set (i.e. equals nil), it will simply wait for
// the background process to finish until RunAndWait() will return
constructor Create(aOnProcess: TOnProcessSynBackgroundThreadProc;
aOnIdle: TOnIdleSynBackgroundThread; const aThreadName: RawUTF8); reintroduce;
/// provide a procedure handler to be execute in the background thread
// - triggered by RunAndWait() method - which will wait until finished
// - the OpaqueParam as specified to RunAndWait() will be supplied here
property OnProcess: TOnProcessSynBackgroundThreadProc read fOnProcess write fOnProcess;
end;
/// an exception which would be raised by TSynParallelProcess
ESynParallelProcess = class(ESynException);
/// callback implementing some parallelized process for TSynParallelProcess
// - if 0<=IndexStart<=IndexStop, it should execute some process
TSynParallelProcessMethod = procedure(IndexStart, IndexStop: integer) of object;
/// thread executing process for TSynParallelProcess
TSynParallelProcessThread = class(TSynBackgroundThreadMethodAbstract)
protected
fMethod: TSynParallelProcessMethod;
fIndexStart, fIndexStop: integer;
procedure Start(Method: TSynParallelProcessMethod; IndexStart,IndexStop: integer);
/// executes fMethod(fIndexStart,fIndexStop)
procedure Process; override;
public
end;
/// allow parallel execution of an index-based process in a thread pool
// - will create its own thread pool, then execute any method by spliting the
// work into each thread
TSynParallelProcess = class(TSynPersistentLock)
protected
fThreadName: RawUTF8;
fPool: array of TSynParallelProcessThread;
fThreadPoolCount: integer;
fParallelRunCount: integer;
public
/// initialize the thread pool
// - you could define some callbacks to nest the thread execution, e.g.
// assigned to TSQLRestServer.BeginCurrentThread/EndCurrentThread
// - up to MaxThreadPoolCount=32 threads could be setup (you may allow a
// bigger value, but interrest of this thread pool is to have its process
// saturating each CPU core)
// - if ThreadPoolCount is 0, no thread would be created, and process
// would take place in the current thread
constructor Create(ThreadPoolCount: integer; const ThreadName: RawUTF8;
OnBeforeExecute: TNotifyThreadEvent=nil; OnAfterExecute: TNotifyThreadEvent=nil;
MaxThreadPoolCount: integer = 32); reintroduce; virtual;
/// finalize the thread pool
destructor Destroy; override;
/// run a method in parallel, and wait for the execution to finish
// - will split Method[0..MethodCount-1] execution over the threads
// - in case of any exception during process, an ESynParallelProcess
// exception would be raised by this method
// - if OnMainThreadIdle is set, the current thread (which is expected to be
// e.g. the main UI thread) won't process anything, but call this event
// during waiting for the background threads
procedure ParallelRunAndWait(const Method: TSynParallelProcessMethod;
MethodCount: integer; const OnMainThreadIdle: TNotifyEvent = nil);
published
/// how many threads have been activated
property ParallelRunCount: integer read fParallelRunCount;
/// how many threads are currently in this instance thread pool
property ThreadPoolCount: integer read fThreadPoolCount;
/// some text identifier, used to distinguish each owned thread
property ThreadName: RawUTF8 read fThreadName;
end;
TSynBackgroundThreadProcess = class;
/// event callback executed periodically by TSynBackgroundThreadProcess
// - Event is wrTimeout after the OnProcessMS waiting period
// - Event is wrSignaled if ProcessEvent.SetEvent has been called
TOnSynBackgroundThreadProcess = procedure(Sender: TSynBackgroundThreadProcess;
Event: TWaitResult) of object;
/// TThread able to run a method at a given periodic pace
TSynBackgroundThreadProcess = class(TSynBackgroundThreadAbstract)
protected
fOnProcess: TOnSynBackgroundThreadProcess;
fOnException: TNotifyEvent;
fOnProcessMS: cardinal;
fStats: TSynMonitor;
procedure ExecuteLoop; override;
public
/// initialize the thread for a periodic task processing
// - aOnProcess would be called when ProcessEvent.SetEvent is called or
// aOnProcessMS milliseconds period was elapse since last process
// - if aOnProcessMS is 0, will wait until ProcessEvent.SetEvent is called
// - you could define some callbacks to nest the thread execution, e.g.
// assigned to TSQLRestServer.BeginCurrentThread/EndCurrentThread
constructor Create(const aThreadName: RawUTF8;
aOnProcess: TOnSynBackgroundThreadProcess; aOnProcessMS: cardinal;
aOnBeforeExecute: TNotifyThreadEvent=nil;
aOnAfterExecute: TNotifyThreadEvent=nil;
aStats: TSynMonitorClass=nil; CreateSuspended: boolean=false); reintroduce; virtual;
/// finalize the thread
destructor Destroy; override;
/// access to the implementation event of the periodic task
property OnProcess: TOnSynBackgroundThreadProcess read fOnProcess;
/// event callback executed when OnProcess did raise an exception
// - supplied Sender parameter is the raised Exception instance
property OnException: TNotifyEvent read fOnException write fOnException;
published
/// access to the delay, in milliseconds, of the periodic task processing
property OnProcessMS: cardinal read fOnProcessMS write fOnProcessMS;
/// processing statistics
// - may be nil if aStats was nil in the class constructor
property Stats: TSynMonitor read fStats;
end;
TSynBackgroundTimer = class;
/// event callback executed periodically by TSynBackgroundThreadProcess
// - Event is wrTimeout after the OnProcessMS waiting period
// - Event is wrSignaled if ProcessEvent.SetEvent has been called
// - Msg is '' if there is no pending message in this task FIFO
// - Msg is set for each pending message in this task FIFO
TOnSynBackgroundTimerProcess = procedure(Sender: TSynBackgroundTimer;
Event: TWaitResult; const Msg: RawUTF8) of object;
/// used by TSynBackgroundTimer internal registration list
TSynBackgroundTimerTask = record
OnProcess: TOnSynBackgroundTimerProcess;
Secs: cardinal;
NextTix: Int64;
FIFO: TRawUTF8DynArray;
end;
/// stores TSynBackgroundTimer internal registration list
TSynBackgroundTimerTaskDynArray = array of TSynBackgroundTimerTask;
/// TThread able to run one or several tasks at a periodic pace in a
// background thread
// - as used e.g. by TSQLRest.TimerEnable/TimerDisable methods, via the
// inherited TSQLRestBackgroundTimer
// - each process can have its own FIFO of text messages
// - if you expect to update some GUI, you should rather use a TTimer
// component (with a period of e.g. 200ms), since TSynBackgroundTimer will
// use its own separated thread
TSynBackgroundTimer = class(TSynBackgroundThreadProcess)
protected
fTask: TSynBackgroundTimerTaskDynArray;
fTasks: TDynArray;
fTaskLock: TSynLocker;
procedure EverySecond(Sender: TSynBackgroundThreadProcess; Event: TWaitResult);
function Find(const aProcess: TMethod): integer;
function Add(aOnProcess: TOnSynBackgroundTimerProcess;
const aMsg: RawUTF8; aExecuteNow: boolean): boolean;
public
/// initialize the thread for a periodic task processing
// - you could define some callbacks to nest the thread execution, e.g.
// assigned to TSQLRestServer.BeginCurrentThread/EndCurrentThread, as
// made by TSQLRestBackgroundTimer.Create
constructor Create(const aThreadName: RawUTF8;
aOnBeforeExecute: TNotifyThreadEvent=nil; aOnAfterExecute: TNotifyThreadEvent=nil;
aStats: TSynMonitorClass=nil); reintroduce; virtual;
/// finalize the thread
destructor Destroy; override;
/// define a process method for a task running on a periodic number of seconds
// - for background process on a mORMot service, consider using TSQLRest
// TimerEnable/TimerDisable methods, and its associated BackgroundTimer thread
procedure Enable(aOnProcess: TOnSynBackgroundTimerProcess; aOnProcessSecs: cardinal);
/// undefine a task running on a periodic number of seconds
// - aOnProcess should have been registered by a previous call to Enable() method
// - returns true on success, false if the supplied task was not registered
// - for background process on a mORMot service, consider using TSQLRestServer
// TimerEnable/TimerDisable methods, and their TSynBackgroundTimer thread
function Disable(aOnProcess: TOnSynBackgroundTimerProcess): boolean;
/// add a message to be processed during the next execution of a task
// - supplied message will be added to the internal FIFO list associated
// with aOnProcess, then supplied to as aMsg parameter for each call
// - if aExecuteNow is true, won't wait for the next aOnProcessSecs occurence
// - aOnProcess should have been registered by a previous call to Enable() method
// - returns true on success, false if the supplied task was not registered
function EnQueue(aOnProcess: TOnSynBackgroundTimerProcess;
const aMsg: RawUTF8; aExecuteNow: boolean=false): boolean; overload;
/// add a message to be processed during the next execution of a task
// - supplied message will be added to the internal FIFO list associated
// with aOnProcess, then supplied to as aMsg parameter for each call
// - if aExecuteNow is true, won't wait for the next aOnProcessSecs occurence
// - aOnProcess should have been registered by a previous call to Enable() method
// - returns true on success, false if the supplied task was not registered
function EnQueue(aOnProcess: TOnSynBackgroundTimerProcess;
const aMsgFmt: RawUTF8; const Args: array of const; aExecuteNow: boolean=false): boolean; overload;
/// remove a message from the processing list
// - supplied message will be searched in the internal FIFO list associated
// with aOnProcess, then removed from the list if found
// - aOnProcess should have been registered by a previous call to Enable() method
// - returns true on success, false if the supplied message was not registered
function DeQueue(aOnProcess: TOnSynBackgroundTimerProcess; const aMsg: RawUTF8): boolean;
/// execute a task without waiting for the next aOnProcessSecs occurence
// - aOnProcess should have been registered by a previous call to Enable() method
// - returns true on success, false if the supplied task was not registered
function ExecuteNow(aOnProcess: TOnSynBackgroundTimerProcess): boolean;
/// returns true if there is currenly one task processed
function Processing: boolean;
/// wait until no background task is processed
procedure WaitUntilNotProcessing(timeoutsecs: integer=10);
/// low-level access to the internal task list
property Task: TSynBackgroundTimerTaskDynArray read fTask;
/// low-level access to the internal task mutex
property TaskLock: TSynLocker read fTaskLock;
end;
/// the current state of a TBlockingProcess instance
TBlockingEvent = (evNone,evWaiting,evTimeOut,evRaised);
{$M+}
/// a semaphore used to wait for some process to be finished
// - used e.g. by TBlockingCallback in mORMot.pas
// - once created, process would block via a WaitFor call, which would be
// released when NotifyFinished is called by the process background thread
TBlockingProcess = class(TEvent)
protected
fTimeOutMs: integer;
fEvent: TBlockingEvent;
fSafe: PSynLocker;
fOwnedSafe: boolean;
procedure ResetInternal; virtual; // override to reset associated params
public
/// initialize the semaphore instance
// - specify a time out millliseconds period after which blocking execution
// should be handled as failure (if 0 is set, default 3000 would be used)
// - an associated mutex shall be supplied
constructor Create(aTimeOutMs: integer; aSafe: PSynLocker); reintroduce; overload; virtual;
/// initialize the semaphore instance
// - specify a time out millliseconds period after which blocking execution
// should be handled as failure (if 0 is set, default 3000 would be used)
// - an associated mutex would be created and owned by this instance
constructor Create(aTimeOutMs: integer); reintroduce; overload; virtual;
/// finalize the instance
destructor Destroy; override;
/// called to wait for NotifyFinished() to be called, or trigger timeout
// - returns the final state of the process, i.e. evRaised or evTimeOut
function WaitFor: TBlockingEvent; reintroduce; overload; virtual;
/// called to wait for NotifyFinished() to be called, or trigger timeout
// - returns the final state of the process, i.e. evRaised or evTimeOut
function WaitFor(TimeOutMS: integer): TBlockingEvent; reintroduce; overload;
/// should be called by the background process when it is finished
// - the caller would then let its WaitFor method return
// - returns TRUE on success (i.e. status was not evRaised or evTimeout)
// - if the instance is already locked (e.g. when retrieved from
// TBlockingProcessPool.FromCallLocked), you may set alreadyLocked=TRUE
function NotifyFinished(alreadyLocked: boolean=false): boolean; virtual;
/// just a wrapper to reset the internal Event state to evNone
// - may be used to re-use the same TBlockingProcess instance, after
// a successfull WaitFor/NotifyFinished process
// - returns TRUE on success (i.e. status was not evWaiting), setting
// the current state to evNone, and the Call property to 0
// - if there is a WaitFor currently in progress, returns FALSE
function Reset: boolean; virtual;
/// just a wrapper around fSafe^.Lock
procedure Lock;
/// just a wrapper around fSafe^.Unlock
procedure Unlock;
published
/// the current state of process
// - use Reset method to re-use this instance after a WaitFor process
property Event: TBlockingEvent read fEvent;
/// the time out period, in ms, as defined at constructor level
property TimeOutMs: integer read fTimeOutMS;
end;
{$M-}
/// used to identify each TBlockingProcessPool call
// - allow to match a given TBlockingProcessPoolItem semaphore
TBlockingProcessPoolCall = type integer;
/// a semaphore used in the TBlockingProcessPool
// - such semaphore have a Call field to identify each execution
TBlockingProcessPoolItem = class(TBlockingProcess)
protected
fCall: TBlockingProcessPoolCall;
procedure ResetInternal; override;
published
/// an unique identifier, when owned by a TBlockingProcessPool
// - Reset would restore this field to its 0 default value
property Call: TBlockingProcessPoolCall read fCall;
end;
/// class-reference type (metaclass) of a TBlockingProcess
TBlockingProcessPoolItemClass = class of TBlockingProcessPoolItem;
/// manage a pool of TBlockingProcessPoolItem instances
// - each call will be identified via a TBlockingProcessPoolCall unique value
// - to be used to emulate e.g. blocking execution from an asynchronous
// event-driven DDD process
// - it would also allow to re-use TEvent system resources
TBlockingProcessPool = class(TSynPersistent)
protected
fClass: TBlockingProcessPoolItemClass;
fPool: TObjectListLocked;
fCallCounter: TBlockingProcessPoolCall; // set TBlockingProcessPoolItem.Call
public
/// initialize the pool, for a given implementation class
constructor Create(aClass: TBlockingProcessPoolItemClass=nil); reintroduce;
/// finalize the pool
// - would also force all pending WaitFor to trigger a evTimeOut
destructor Destroy; override;
/// book a TBlockingProcess from the internal pool
// - returns nil on error (e.g. the instance is destroying)
// - or returns the blocking process instance corresponding to this call;
// its Call property would identify the call for the asynchronous callback,
// then after WaitFor, the Reset method should be run to release the mutex
// for the pool
function NewProcess(aTimeOutMs: integer): TBlockingProcessPoolItem; virtual;
/// retrieve a TBlockingProcess from its call identifier
// - may be used e.g. from the callback of the asynchronous process
// to set some additional parameters to the inherited TBlockingProcess,
// then call NotifyFinished to release the caller WaitFor
// - if leavelocked is TRUE, the returned instance would be locked: caller
// should execute result.Unlock or NotifyFinished(true) after use
function FromCall(call: TBlockingProcessPoolCall;
locked: boolean=false): TBlockingProcessPoolItem; virtual;
end;
/// allow to fix TEvent.WaitFor() method for Kylix
// - under Windows or with FPC, will call original TEvent.WaitFor() method
function FixedWaitFor(Event: TEvent; Timeout: LongWord): TWaitResult;
/// allow to fix TEvent.WaitFor(Event,INFINITE) method for Kylix
// - under Windows or with FPC, will call original TEvent.WaitFor() method
procedure FixedWaitForever(Event: TEvent);
{$endif LVCL} // LVCL does not implement TEvent
{ ************ System Analysis types and classes ************************** }
type
/// store CPU and RAM usage for a given process
// - as used by TSystemUse class
TSystemUseData = packed record
/// when the data has been sampled
Timestamp: TDateTime;
/// percent of current Kernel-space CPU usage for this process
Kernel: single;
/// percent of current User-space CPU usage for this process
User: single;
/// how many KB of working memory are used by this process
WorkKB: cardinal;
/// how many KB of virtual memory are used by this process
VirtualKB: cardinal;
end;
/// store CPU and RAM usage history for a given process
// - as returned by TSystemUse.History
TSystemUseDataDynArray = array of TSystemUseData;
/// low-level structure used to compute process memory and CPU usage
{$ifdef FPC_OR_UNICODE}TProcessInfo = record private
{$else}TProcessInfo = object protected{$endif}
{$ifdef MSWINDOWS}
fSysPrevIdle, fSysPrevKernel, fSysPrevUser,
fDiffIdle, fDiffKernel, fDiffUser, fDiffTotal: Int64;
{$endif}
public
/// initialize the system/process resource tracking
function Init: boolean;
/// to be called before PerSystem() or PerProcess() iteration
function Start: boolean;
/// percent of current Idle/Kernel/User CPU usage for all processes
function PerSystem(out Idle,Kernel,User: currency): boolean;
/// retrieve CPU and RAM usage for a given process
function PerProcess(PID: cardinal; Now: PDateTime; out Data: TSystemUseData;
var PrevKernel, PrevUser: Int64): boolean;
end;
/// event handler which may be executed by TSystemUse.BackgroundExecute
// - called just after the measurement of each process CPU and RAM consumption
// - run from the background thread, so should not directly make VCL calls,
// unless BackgroundExecute is run from a VCL timer
TOnSystemUseMeasured = procedure(ProcessID: integer; const Data: TSystemUseData) of object;
/// internal storage of CPU and RAM usage for one process
TSystemUseProcess = record
ID: integer;
Data: TSystemUseDataDynArray;
PrevKernel: Int64;
PrevUser: Int64;
end;
/// internal storage of CPU and RAM usage for a set of processes
TSystemUseProcessDynArray = array of TSystemUseProcess;
/// monitor CPU and RAM usage of one or several processes
// - you should execute BackgroundExecute on a regular pace (e.g. every second)
// to gather low-level CPU and RAM information for the given set of processes
// - is able to keep an history of latest sample values
// - use Current class function to access a process-wide instance
TSystemUse = class(TSynPersistentLock)
protected
fProcess: TSystemUseProcessDynArray;
fProcesses: TDynArray;
fDataIndex: integer;
fProcessInfo: TProcessInfo;
fHistoryDepth: integer;
fOnMeasured: TOnSystemUseMeasured;
fTimer: TSynBackgroundTimer;
fUnsubscribeProcessOnAccessError: boolean;
function ProcessIndex(aProcessID: integer): integer;
public
/// a TSynBackgroundThreadProcess compatible event
// - matches TOnSynBackgroundTimerProcess callback signature
// - to be supplied e.g. to a TSynBackgroundTimer.Enable method so that it
// will run every few seconds and retrieve the CPU and RAM use
procedure BackgroundExecute(Sender: TSynBackgroundTimer;
Event: TWaitResult; const Msg: RawUTF8);
/// a VCL's TTimer.OnTimer compatible event
// - to be run every few seconds and retrieve the CPU and RAM use:
// ! tmrSystemUse.Interval := 10000; // every 10 seconds
// ! tmrSystemUse.OnTimer := TSystemUse.Current.OnTimerExecute;
procedure OnTimerExecute(Sender: TObject);
/// track the CPU and RAM usage of the supplied set of Process ID
// - any aProcessID[]=0 will be replaced by the current process ID
// - you can specify the number of sample values for the History() method
// - you should then execute the BackgroundExecute method of this instance
// in a VCL timer or from a TSynBackgroundTimer.Enable() registration
constructor Create(const aProcessID: array of integer;
aHistoryDepth: integer=60); reintroduce; overload; virtual;
/// track the CPU and RAM usage of the current process
// - you can specify the number of sample values for the History() method
// - you should then execute the BackgroundExecute method of this instance
// in a VCL timer or from a TSynBackgroundTimer.Enable() registration
constructor Create(aHistoryDepth: integer=60); reintroduce; overload; virtual;
/// add a Process ID to the internal tracking list
procedure Subscribe(aProcessID: integer);
/// remove a Process ID from the internal tracking list
function Unsubscribe(aProcessID: integer): boolean;
/// returns the total (Kernel+User) CPU usage percent of the supplied process
// - aProcessID=0 will return information from the current process
// - returns -1 if the Process ID was not registered via Create/Subscribe
function Percent(aProcessID: integer=0): single; overload;
/// returns the Kernel-space CPU usage percent of the supplied process
// - aProcessID=0 will return information from the current process
// - returns -1 if the Process ID was not registered via Create/Subscribe
function PercentKernel(aProcessID: integer=0): single; overload;
/// returns the User-space CPU usage percent of the supplied process
// - aProcessID=0 will return information from the current process
// - returns -1 if the Process ID was not registered via Create/Subscribe
function PercentUser(aProcessID: integer=0): single; overload;
/// returns the total (Work+Paged) RAM use of the supplied process, in KB
// - aProcessID=0 will return information from the current process
// - returns 0 if the Process ID was not registered via Create/Subscribe
function KB(aProcessID: integer=0): cardinal; overload;
/// percent of current Idle/Kernel/User CPU usage for all processes
function PercentSystem(out Idle,Kernel,User: currency): boolean;
/// returns the detailed CPU and RAM usage percent of the supplied process
// - aProcessID=0 will return information from the current process
// - returns -1 if the Process ID was not registered via Create/Subscribe
function Data(out aData: TSystemUseData; aProcessID: integer=0): boolean; overload;
/// returns the detailed CPU and RAM usage percent of the supplied process
// - aProcessID=0 will return information from the current process