Skip to content
Permalink
master
Switch branches/tags
Go to file
 
 
Cannot retrieve contributors at this time
/// filter/database/cache/buffer/security/search/multithread/OS features
// - as a complement to SynCommons, which tended to increase too much
// - licensed under a MPL/GPL/LGPL tri-license; version 1.18
unit SynTable;
(*
This file is part of Synopse framework.
Synopse framework. Copyright (C) 2021 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) 2021
the Initial Developer. All Rights Reserved.
Contributor(s):
Alternatively, the contents of this file may be used under the terms of
either the GNU General Public License Version 2 or later (the "GPL"), or
the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
in which case the provisions of the GPL or the LGPL are applicable instead
of those above. If you wish to allow use of your version of this file only
under the terms of either the GPL or the LGPL, and not to allow others to
use your version of this file under the terms of the MPL, indicate your
decision by deleting the provisions above and replace them with the notice
and other provisions required by the GPL or the LGPL. If you do not delete
the provisions above, a recipient may use your version of this file under
the terms of any one of the MPL, the GPL or the LGPL.
***** END LICENSE BLOCK *****
A lot of code has moved from SynCommons.pas and mORMot.pas, to reduce the
number of source code lines of those units, and circumvent Delphi 5/6/7
limitations (e.g. internal error PRO-3006)
*)
interface
{$I Synopse.inc} // define HASINLINE CPU32 CPU64
uses
{$ifdef MSWINDOWS}
Windows,
Messages,
{$else}
{$ifdef KYLIX3}
Types,
LibC,
SynKylix,
{$endif KYLIX3}
{$ifdef FPC}
BaseUnix,
Unix,
{$endif FPC}
{$endif MSWINDOWS}
SysUtils,
Classes,
{$ifndef LVCL}
SyncObjs, // for TEvent and TCriticalSection
Contnrs, // for TObjectList
{$endif}
{$ifndef NOVARIANTS}
Variants,
{$endif}
SynCommons;
{ ************ text search and functions ****************** }
type
PMatch = ^TMatch;
TMatchSearchFunction = function(aMatch: PMatch; aText: PUTF8Char; aTextLen: PtrInt): boolean;
/// low-level structure used by IsMatch() for actual glob search
// - you can use this object to prepare a given pattern, e.g. in a loop
// - implemented as a fast brute-force state-machine without any heap allocation
// - some common patterns ('exactmatch', 'startwith*', '*endwith', '*contained*')
// are handled with dedicated code, optionally with case-insensitive search
// - consider using TMatchs (or SetMatchs/TMatchDynArray) if you expect to
// search for several patterns, or even TExprParserMatch for expression search
{$ifdef USERECORDWITHMETHODS}TMatch = record
{$else}TMatch = object{$endif}
private
Pattern, Text: PUTF8Char;
P, T, PMax, TMax: PtrInt;
Upper: PNormTable;
State: (sNONE, sABORT, sEND, sLITERAL, sPATTERN, sRANGE, sVALID);
procedure MatchAfterStar;
procedure MatchMain;
public
/// published for proper inlining
Search: TMatchSearchFunction;
/// initialize the internal fields for a given glob search pattern
// - note that the aPattern instance should remain in memory, since it will
// be pointed to by the Pattern private field of this object
procedure Prepare(const aPattern: RawUTF8; aCaseInsensitive, aReuse: boolean); overload;
/// initialize the internal fields for a given glob search pattern
// - note that the aPattern buffer should remain in memory, since it will
// be pointed to by the Pattern private field of this object
procedure Prepare(aPattern: PUTF8Char; aPatternLen: integer;
aCaseInsensitive, aReuse: boolean); overload;
/// initialize low-level internal fields for'*aPattern*' search
// - this method is faster than a regular Prepare('*' + aPattern + '*')
// - warning: the supplied aPattern variable may be modified in-place to be
// filled with some lookup buffer, for length(aPattern) in [2..31] range
procedure PrepareContains(var aPattern: RawUTF8; aCaseInsensitive: boolean); overload;
/// initialize low-level internal fields for a custom search algorithm
procedure PrepareRaw(aPattern: PUTF8Char; aPatternLen: integer;
aSearch: TMatchSearchFunction);
/// returns TRUE if the supplied content matches the prepared glob pattern
// - this method is not thread-safe
function Match(const aText: RawUTF8): boolean; overload;
{$ifdef FPC}inline;{$endif}
/// returns TRUE if the supplied content matches the prepared glob pattern
// - this method is not thread-safe
function Match(aText: PUTF8Char; aTextLen: PtrInt): boolean; overload;
{$ifdef HASINLINE}inline;{$endif}
/// returns TRUE if the supplied content matches the prepared glob pattern
// - this method IS thread-safe, and won't lock
function MatchThreadSafe(const aText: RawUTF8): boolean;
/// returns TRUE if the supplied VCL/LCL content matches the prepared glob pattern
// - this method IS thread-safe, will use stack to UTF-8 temporary conversion
// if possible, and won't lock
function MatchString(const aText: string): boolean;
/// returns TRUE if this search pattern matches another
function Equals(const aAnother{$ifndef DELPHI5OROLDER}: TMatch{$endif}): boolean;
{$ifdef HASINLINE}inline;{$endif}
/// access to the pattern length as stored in PMax + 1
function PatternLength: integer; {$ifdef HASINLINE}inline;{$endif}
/// access to the pattern text as stored in Pattern
function PatternText: PUTF8Char; {$ifdef HASINLINE}inline;{$endif}
end;
/// use SetMatchs() to initialize such an array from a CSV pattern text
TMatchDynArray = array of TMatch;
/// TMatch descendant owning a copy of the Pattern string to avoid GPF issues
TMatchStore = record
/// access to the research criteria
// - defined as a nested record (and not an object) to circumvent Delphi bug
Pattern: TMatch;
/// Pattern.Pattern PUTF8Char will point to this instance
PatternInstance: RawUTF8;
end;
TMatchStoreDynArray = array of TMatchStore;
/// stores several TMatch instances, from a set of glob patterns
TMatchs = class(TSynPersistent)
protected
fMatch: TMatchStoreDynArray;
fMatchCount: integer;
public
/// add once some glob patterns to the internal TMach list
// - aPatterns[] follows the IsMatch() syntax
constructor Create(const aPatterns: TRawUTF8DynArray; CaseInsensitive: Boolean); reintroduce; overload;
/// add once some glob patterns to the internal TMach list
// - aPatterns[] follows the IsMatch() syntax
procedure Subscribe(const aPatterns: TRawUTF8DynArray; CaseInsensitive: Boolean); overload; virtual;
/// add once some glob patterns to the internal TMach list
// - each CSV item in aPatterns follows the IsMatch() syntax
procedure Subscribe(const aPatternsCSV: RawUTF8; CaseInsensitive: Boolean); overload;
/// search patterns in the supplied UTF-8 text
// - returns -1 if no filter has been subscribed
// - returns -2 if there is no match on any previous pattern subscription
// - returns fMatch[] index, i.e. >= 0 number on first matching pattern
// - this method is thread-safe
function Match(const aText: RawUTF8): integer; overload; {$ifdef HASINLINE}inline;{$endif}
/// search patterns in the supplied UTF-8 text buffer
function Match(aText: PUTF8Char; aLen: integer): integer; overload;
/// search patterns in the supplied VCL/LCL text
// - could be used on a TFileName for instance
// - will avoid any memory allocation if aText is small enough
function MatchString(const aText: string): integer;
end;
/// fill the Match[] dynamic array with all glob patterns supplied as CSV
// - returns how many patterns have been set in Match[|]
// - note that the CSVPattern instance should remain in memory, since it will
// be pointed to by the Match[].Pattern private field
function SetMatchs(const CSVPattern: RawUTF8; CaseInsensitive: boolean;
out Match: TMatchDynArray): integer; overload;
/// fill the Match[0..MatchMax] static array with all glob patterns supplied as CSV
// - note that the CSVPattern instance should remain in memory, since it will
// be pointed to by the Match[].Pattern private field
function SetMatchs(CSVPattern: PUTF8Char; CaseInsensitive: boolean;
Match: PMatch; MatchMax: integer): integer; overload;
/// search if one TMach is already registered in the Several[] dynamic array
function MatchExists(const One: TMatch; const Several: TMatchDynArray): boolean;
/// add one TMach if not already registered in the Several[] dynamic array
function MatchAdd(const One: TMatch; var Several: TMatchDynArray): boolean;
/// returns TRUE if Match=nil or if any Match[].Match(Text) is TRUE
function MatchAny(const Match: TMatchDynArray; const Text: RawUTF8): boolean;
/// apply the CSV-supplied glob patterns to an array of RawUTF8
// - any text not maching the pattern will be deleted from the array
procedure FilterMatchs(const CSVPattern: RawUTF8; CaseInsensitive: boolean;
var Values: TRawUTF8DynArray);
/// return TRUE if the supplied content matchs a glob pattern
// - ? Matches any single characer
// - * Matches any contiguous characters
// - [abc] Matches a or b or c at that position
// - [^abc] Matches anything but a or b or c at that position
// - [!abc] Matches anything but a or b or c at that position
// - [a-e] Matches a through e at that position
// - [abcx-z] Matches a or b or c or x or y or or z, as does [a-cx-z]
// - 'ma?ch.*' would match match.exe, mavch.dat, march.on, etc..
// - 'this [e-n]s a [!zy]est' would match 'this is a test', but would not
// match 'this as a test' nor 'this is a zest'
// - consider using TMatch or TMatchs if you expect to reuse the pattern
function IsMatch(const Pattern, Text: RawUTF8; CaseInsensitive: boolean=false): boolean;
/// return TRUE if the supplied content matchs a glob pattern, using VCL strings
// - is a wrapper around IsMatch() with fast UTF-8 conversion
function IsMatchString(const Pattern, Text: string; CaseInsensitive: boolean=false): boolean;
type
/// available pronunciations for our fast Soundex implementation
TSynSoundExPronunciation =
(sndxEnglish, sndxFrench, sndxSpanish, sndxNone);
TSoundExValues = array[0..ord('Z')-ord('B')] of byte;
PSoundExValues = ^TSoundExValues;
PSynSoundEx = ^TSynSoundEx;
/// fast search of a text value, using the Soundex approximation mechanism
// - Soundex is a phonetic algorithm for indexing names by sound,
// as pronounced in a given language. The goal is for homophones to be
// encoded to the same representation so that they can be matched despite
// minor differences in spelling
// - this implementation is very fast and can be used e.g. to parse and search
// in a huge text buffer
// - this version also handles french and spanish pronunciations on request,
// which differs from default Soundex, i.e. English
TSynSoundEx = object
protected
Search, FirstChar: cardinal;
fValues: PSoundExValues;
public
/// prepare for a Soundex search
// - you can specify another language pronunciation than default english
function Prepare(UpperValue: PAnsiChar;
Lang: TSynSoundExPronunciation=sndxEnglish): boolean; overload;
/// prepare for a custom Soundex search
// - you can specify any language pronunciation from raw TSoundExValues array
function Prepare(UpperValue: PAnsiChar; Lang: PSoundExValues): boolean; overload;
/// return true if prepared value is contained in a text buffer
// (UTF-8 encoded), by using the SoundEx comparison algorithm
// - search prepared value at every word beginning in U^
function UTF8(U: PUTF8Char): boolean;
/// return true if prepared value is contained in a ANSI text buffer
// by using the SoundEx comparison algorithm
// - search prepared value at every word beginning in A^
function Ansi(A: PAnsiChar): boolean;
end;
/// Retrieve the Soundex value of a text word, from Ansi buffer
// - Return the soundex value as an easy to use cardinal value, 0 if the
// incoming string contains no valid word
// - if next is defined, its value is set to the end of the encoded word
// (so that you can call again this function to encode a full sentence)
function SoundExAnsi(A: PAnsiChar; next: PPAnsiChar=nil;
Lang: TSynSoundExPronunciation=sndxEnglish): cardinal; overload;
/// Retrieve the Soundex value of a text word, from Ansi buffer
// - Return the soundex value as an easy to use cardinal value, 0 if the
// incoming string contains no valid word
// - if next is defined, its value is set to the end of the encoded word
// (so that you can call again this function to encode a full sentence)
function SoundExAnsi(A: PAnsiChar; next: PPAnsiChar; Lang: PSoundExValues): cardinal; overload;
/// Retrieve the Soundex value of a text word, from UTF-8 buffer
// - Return the soundex value as an easy to use cardinal value, 0 if the
// incoming string contains no valid word
// - if next is defined, its value is set to the end of the encoded word
// (so that you can call again this function to encode a full sentence)
// - very fast: all UTF-8 decoding is handled on the fly
function SoundExUTF8(U: PUTF8Char; next: PPUTF8Char=nil;
Lang: TSynSoundExPronunciation=sndxEnglish): cardinal;
const
/// number of bits to use for each interresting soundex char
// - default is to use 8 bits, i.e. 4 soundex chars, which is the
// standard approach
// - for a more detailled soundex, use 4 bits resolution, which will
// compute up to 7 soundex chars in a cardinal (that's our choice)
SOUNDEX_BITS = 4;
var
DoIsValidUTF8: function(source: PUTF8Char): Boolean;
DoIsValidUTF8Len: function(source: PUTF8Char; sourcelen: PtrInt): Boolean;
/// returns TRUE if the supplied buffer has valid UTF-8 encoding
// - will stop when the buffer contains #0
// - on Haswell AVX2 Intel/AMD CPUs, will use very efficient ASM
function IsValidUTF8(source: PUTF8Char): Boolean; overload; {$ifdef HASINLINE}inline;{$endif}
/// returns TRUE if the supplied buffer has valid UTF-8 encoding
// - will also refuse #0 characters within the buffer
// - on Haswell AVX2 Intel/AMD CPUs, will use very efficient ASM
function IsValidUTF8(source: PUTF8Char; sourcelen: PtrInt): Boolean; overload; {$ifdef HASINLINE}inline;{$endif}
/// returns TRUE if the supplied buffer has valid UTF-8 encoding
// - will also refuse #0 characters within the buffer
// - on Haswell AVX2 Intel/AMD CPUs, will use very efficient ASM
function IsValidUTF8(const source: RawUTF8): Boolean; overload;
{ ************ filtering and validation classes and functions ************** }
/// convert an IPv4 'x.x.x.x' text into its 32-bit value
// - returns TRUE if the text was a valid IPv4 text, unserialized as 32-bit aValue
// - returns FALSE on parsing error, also setting aValue=0
// - '' or '127.0.0.1' will also return false
function IPToCardinal(P: PUTF8Char; out aValue: cardinal): boolean; overload;
/// convert an IPv4 'x.x.x.x' text into its 32-bit value
// - returns TRUE if the text was a valid IPv4 text, unserialized as 32-bit aValue
// - returns FALSE on parsing error, also setting aValue=0
// - '' or '127.0.0.1' will also return false
function IPToCardinal(const aIP: RawUTF8; out aValue: cardinal): boolean; overload;
{$ifdef HASINLINE}inline;{$endif}
/// convert an IPv4 'x.x.x.x' text into its 32-bit value, 0 or localhost
// - returns <> 0 value if the text was a valid IPv4 text, 0 on parsing error
// - '' or '127.0.0.1' will also return 0
function IPToCardinal(const aIP: RawUTF8): cardinal; overload;
{$ifdef HASINLINE}inline;{$endif}
/// return TRUE if the supplied content is a valid email address
// - follows RFC 822, to validate local-part@domain email format
function IsValidEmail(P: PUTF8Char): boolean;
/// return TRUE if the supplied content is a valid IP v4 address
function IsValidIP4Address(P: PUTF8Char): boolean;
type
TSynFilterOrValidate = class;
TSynFilterOrValidateObjArray = array of TSynFilterOrValidate;
TSynFilterOrValidateObjArrayArray = array of TSynFilterOrValidateObjArray;
/// will define a filter (transformation) or a validation process to be
// applied to a database Record content (typicaly a TSQLRecord)
// - the optional associated parameters are to be supplied JSON-encoded
TSynFilterOrValidate = class
protected
fParameters: RawUTF8;
/// children must override this method in order to parse the JSON-encoded
// parameters, and store it in protected field values
procedure SetParameters(const Value: RawUTF8); virtual;
public
/// add the filter or validation process to a list, checking if not present
// - if an instance with the same class type and parameters is already
// registered, will call aInstance.Free and return the exising instance
// - if there is no similar instance, will add it to the list and return it
function AddOnce(var aObjArray: TSynFilterOrValidateObjArray;
aFreeIfAlreadyThere: boolean=true): TSynFilterOrValidate;
public
/// initialize the filter (transformation) or validation instance
// - most of the time, optional parameters may be specified as JSON,
// possibly with the extended MongoDB syntax
constructor Create(const aParameters: RawUTF8=''); overload; virtual;
/// initialize the filter or validation instance
/// - this overloaded constructor will allow to easily set the parameters
constructor CreateUTF8(const Format: RawUTF8; const Args, Params: array of const); overload;
/// the optional associated parameters, supplied as JSON-encoded
property Parameters: RawUTF8 read fParameters write SetParameters;
end;
/// will define a validation to be applied to a Record (typicaly a TSQLRecord)
// field content
// - a typical usage is to validate an email or IP adress e.g.
// - the optional associated parameters are to be supplied JSON-encoded
TSynValidate = class(TSynFilterOrValidate)
public
/// perform the validation action to the specified value
// - the value is expected by be UTF-8 text, as generated by
// TPropInfo.GetValue e.g.
// - if the validation failed, must return FALSE and put some message in
// ErrorMsg (translated into the current language: you could e.g. use
// a resourcestring and a SysUtils.Format() call for automatic translation
// via the mORMoti18n unit - you can leave ErrorMsg='' to trigger a
// generic error message from clas name ('"Validate email" rule failed'
// for TSynValidateEmail class e.g.)
// - if the validation passed, will return TRUE
function Process(FieldIndex: integer; const Value: RawUTF8; var ErrorMsg: string): boolean;
virtual; abstract;
end;
/// points to a TSynValidate variable
// - used e.g. as optional parameter to TSQLRecord.Validate/FilterAndValidate
PSynValidate = ^TSynValidate;
/// IP v4 address validation to be applied to a Record field content
// (typicaly a TSQLRecord)
// - this versions expect no parameter
TSynValidateIPAddress = class(TSynValidate)
protected
public
/// perform the IP Address validation action to the specified value
function Process(aFieldIndex: integer; const Value: RawUTF8;
var ErrorMsg: string): boolean; override;
end;
/// IP address validation to be applied to a Record field content
// (typicaly a TSQLRecord)
// - optional JSON encoded parameters are "AllowedTLD" or "ForbiddenTLD",
// expecting a CSV lis of Top-Level-Domain (TLD) names, e.g.
// $ '{"AllowedTLD":"com,org,net","ForbiddenTLD":"fr"}'
// $ '{AnyTLD:true,ForbiddenDomains:"mailinator.com,yopmail.com"}'
// - this will process a validation according to RFC 822 (calling the
// IsValidEmail() function) then will check for the TLD to be in one of
// the Top-Level domains ('.com' and such) or a two-char country, and
// then will check the TLD according to AllowedTLD and ForbiddenTLD
TSynValidateEmail = class(TSynValidate)
private
fAllowedTLD: RawUTF8;
fForbiddenTLD: RawUTF8;
fForbiddenDomains: RawUTF8;
fAnyTLD: boolean;
protected
/// decode all published properties from their JSON representation
procedure SetParameters(const Value: RawUTF8); override;
public
/// perform the Email Address validation action to the specified value
// - call IsValidEmail() function and check for the supplied TLD
function Process(aFieldIndex: integer; const Value: RawUTF8; var ErrorMsg: string): boolean; override;
/// allow any TLD to be allowed, even if not a generic TLD (.com,.net ...)
// - this may be mandatory since already over 1,300 new gTLD names or
// "strings" could become available in the next few years: there is a
// growing list of new gTLDs available at
// @http://newgtlds.icann.org/en/program-status/delegated-strings
// - the only restriction is that it should be ascii characters
property AnyTLD: boolean read fAnyTLD write fAnyTLD;
/// a CSV list of allowed TLD
// - if accessed directly, should be set as lower case values
// - e.g. 'com,org,net'
property AllowedTLD: RawUTF8 read fAllowedTLD write fAllowedTLD;
/// a CSV list of forbidden TLD
// - if accessed directly, should be set as lower case values
// - e.g. 'fr'
property ForbiddenTLD: RawUTF8 read fForbiddenTLD write fForbiddenTLD;
/// a CSV list of forbidden domain names
// - if accessed directly, should be set as lower case values
// - not only the TLD, but whole domains like 'cracks.ru,hotmail.com' or such
property ForbiddenDomains: RawUTF8 read fForbiddenDomains write fForbiddenDomains;
end;
/// glob case-sensitive pattern validation of a Record field content
// - parameter is NOT JSON encoded, but is some basic TMatch glob pattern
// - ? Matches any single characer
// - * Matches any contiguous characters
// - [abc] Matches a or b or c at that position
// - [^abc] Matches anything but a or b or c at that position
// - [!abc] Matches anything but a or b or c at that position
// - [a-e] Matches a through e at that position
// - [abcx-z] Matches a or b or c or x or y or or z, as does [a-cx-z]
// - 'ma?ch.*' would match match.exe, mavch.dat, march.on, etc..
// - 'this [e-n]s a [!zy]est' would match 'this is a test', but would not
// match 'this as a test' nor 'this is a zest'
// - pattern check IS case sensitive (TSynValidatePatternI is not)
// - this class is not as complete as PCRE regex for example,
// but code overhead is very small, and speed good enough in practice
TSynValidatePattern = class(TSynValidate)
protected
fMatch: TMatch;
procedure SetParameters(const Value: RawUTF8); override;
public
/// perform the pattern validation to the specified value
// - pattern can be e.g. '[0-9][0-9]:[0-9][0-9]:[0-9][0-9]'
// - this method will implement both TSynValidatePattern and
// TSynValidatePatternI, checking the current class
function Process(aFieldIndex: integer; const Value: RawUTF8;
var ErrorMsg: string): boolean; override;
end;
/// glob case-insensitive pattern validation of a text field content
// (typicaly a TSQLRecord)
// - parameter is NOT JSON encoded, but is some basic TMatch glob pattern
// - same as TSynValidatePattern, but is NOT case sensitive
TSynValidatePatternI = class(TSynValidatePattern);
/// text validation to ensure that to any text field would not be ''
TSynValidateNonVoidText = class(TSynValidate)
public
/// perform the non void text validation action to the specified value
function Process(aFieldIndex: integer; const Value: RawUTF8;
var ErrorMsg: string): boolean; override;
end;
TSynValidateTextProps = array[0..15] of cardinal;
{$M+} // to have existing RTTI for published properties
/// text validation to be applied to any Record field content
// - default MinLength value is 1, MaxLength is maxInt: so a blank
// TSynValidateText.Create('') is the same as TSynValidateNonVoidText
// - MinAlphaCount, MinDigitCount, MinPunctCount, MinLowerCount and
// MinUpperCount allow you to specify the minimal count of respectively
// alphabetical [a-zA-Z], digit [0-9], punctuation [_!;.,/:?%$="#@(){}+-*],
// lower case or upper case characters
// - expects optional JSON parameters of the allowed text length range as
// $ '{"MinLength":5,"MaxLength":10,"MinAlphaCount":1,"MinDigitCount":1,
// $ "MinPunctCount":1,"MinLowerCount":1,"MinUpperCount":1}
TSynValidateText = class(TSynValidate)
private
/// used to store all associated validation properties by index
fProps: TSynValidateTextProps;
fUTF8Length: boolean;
protected
/// use sInvalidTextChar resourcestring to create a translated error message
procedure SetErrorMsg(fPropsIndex, InvalidTextIndex, MainIndex: integer;
var result: string);
/// decode "MinLength", "MaxLength", and other parameters into fProps[]
procedure SetParameters(const Value: RawUTF8); override;
public
/// perform the text length validation action to the specified value
function Process(aFieldIndex: integer; const Value: RawUTF8;
var ErrorMsg: string): boolean; override;
published
/// Minimal length value allowed for the text content
// - the length is calculated with UTF-16 Unicode codepoints, unless
// UTF8Length has been set to TRUE so that the UTF-8 byte count is checked
// - default is 1, i.e. a void text will not pass the validation
property MinLength: cardinal read fProps[0] write fProps[0];
/// Maximal length value allowed for the text content
// - the length is calculated with UTF-16 Unicode codepoints, unless
// UTF8Length has been set to TRUE so that the UTF-8 byte count is checked
// - default is maxInt, i.e. no maximum length is set
property MaxLength: cardinal read fProps[1] write fProps[1];
/// Minimal alphabetical character [a-zA-Z] count
// - default is 0, i.e. no minimum set
property MinAlphaCount: cardinal read fProps[2] write fProps[2];
/// Maximal alphabetical character [a-zA-Z] count
// - default is maxInt, i.e. no Maximum set
property MaxAlphaCount: cardinal read fProps[10] write fProps[10];
/// Minimal digit character [0-9] count
// - default is 0, i.e. no minimum set
property MinDigitCount: cardinal read fProps[3] write fProps[3];
/// Maximal digit character [0-9] count
// - default is maxInt, i.e. no Maximum set
property MaxDigitCount: cardinal read fProps[11] write fProps[11];
/// Minimal punctuation sign [_!;.,/:?%$="#@(){}+-*] count
// - default is 0, i.e. no minimum set
property MinPunctCount: cardinal read fProps[4] write fProps[4];
/// Maximal punctuation sign [_!;.,/:?%$="#@(){}+-*] count
// - default is maxInt, i.e. no Maximum set
property MaxPunctCount: cardinal read fProps[12] write fProps[12];
/// Minimal alphabetical lower case character [a-z] count
// - default is 0, i.e. no minimum set
property MinLowerCount: cardinal read fProps[5] write fProps[5];
/// Maximal alphabetical lower case character [a-z] count
// - default is maxInt, i.e. no Maximum set
property MaxLowerCount: cardinal read fProps[13] write fProps[13];
/// Minimal alphabetical upper case character [A-Z] count
// - default is 0, i.e. no minimum set
property MinUpperCount: cardinal read fProps[6] write fProps[6];
/// Maximal alphabetical upper case character [A-Z] count
// - default is maxInt, i.e. no Maximum set
property MaxUpperCount: cardinal read fProps[14] write fProps[14];
/// Minimal space count inside the value text
// - default is 0, i.e. any space number allowed
property MinSpaceCount: cardinal read fProps[7] write fProps[7];
/// Maximal space count inside the value text
// - default is maxInt, i.e. any space number allowed
property MaxSpaceCount: cardinal read fProps[15] write fProps[15];
/// Maximal space count allowed on the Left side
// - default is maxInt, i.e. any Left space allowed
property MaxLeftTrimCount: cardinal read fProps[8] write fProps[8];
/// Maximal space count allowed on the Right side
// - default is maxInt, i.e. any Right space allowed
property MaxRightTrimCount: cardinal read fProps[9] write fProps[9];
/// defines if lengths parameters expects UTF-8 or UTF-16 codepoints number
// - with default FALSE, the length is calculated with UTF-16 Unicode
// codepoints - MaxLength may not match the UCS4 glyphs number, in case of
// UTF-16 surrogates
// - you can set this property to TRUE so that the UTF-8 byte count would
// be used for truncation againts the MaxLength parameter
property UTF8Length: boolean read fUTF8Length write fUTF8Length;
end;
{$M-}
/// strong password validation for a Record field content (typicaly a TSQLRecord)
// - the following parameters are set by default to
// $ '{"MinLength":5,"MaxLength":20,"MinAlphaCount":1,"MinDigitCount":1,
// $ "MinPunctCount":1,"MinLowerCount":1,"MinUpperCount":1,"MaxSpaceCount":0}'
// - you can specify some JSON encoded parameters to change this default
// values, which will validate the text field only if it contains from 5 to 10
// characters, with at least one digit, one upper case letter, one lower case
// letter, and one ponctuation sign, with no space allowed inside
TSynValidatePassWord = class(TSynValidateText)
protected
/// set password specific parameters
procedure SetParameters(const Value: RawUTF8); override;
end;
{ C++Builder doesn't support array elements as properties (RSP-12595).
For now, simply exclude the relevant classes from C++Builder. }
{$NODEFINE TSynValidateTextProps}
{$NODEFINE TSynValidateText }
{$NODEFINE TSynValidatePassWord }
/// will define a transformation to be applied to a Record field content
// (typicaly a TSQLRecord)
// - here "filter" means that content would be transformed according to a
// set of defined rules
// - a typical usage is to convert to lower or upper case, or
// trim any time or date value in a TDateTime field
// - the optional associated parameters are to be supplied JSON-encoded
TSynFilter = class(TSynFilterOrValidate)
protected
public
/// perform the transformation to the specified value
// - the value is converted into UTF-8 text, as expected by
// TPropInfo.GetValue / TPropInfo.SetValue e.g.
procedure Process(aFieldIndex: integer; var Value: RawUTF8); virtual; abstract;
end;
/// class-refrence type (metaclass) for a TSynFilter or a TSynValidate
TSynFilterOrValidateClass = class of TSynFilterOrValidate;
/// class-reference type (metaclass) of a record filter (transformation)
TSynFilterClass = class of TSynFilter;
/// convert the value into ASCII Upper Case characters
// - UpperCase conversion is made for ASCII-7 only, i.e. 'a'..'z' characters
// - this version expects no parameter
TSynFilterUpperCase = class(TSynFilter)
public
/// perform the case conversion to the specified value
procedure Process(aFieldIndex: integer; var Value: RawUTF8); override;
end;
/// convert the value into WinAnsi Upper Case characters
// - UpperCase conversion is made for all latin characters in the WinAnsi
// code page only, e.g. 'e' acute will be converted to 'E'
// - this version expects no parameter
TSynFilterUpperCaseU = class(TSynFilter)
public
/// perform the case conversion to the specified value
procedure Process(aFieldIndex: integer; var Value: RawUTF8); override;
end;
/// convert the value into ASCII Lower Case characters
// - LowerCase conversion is made for ASCII-7 only, i.e. 'A'..'Z' characters
// - this version expects no parameter
TSynFilterLowerCase = class(TSynFilter)
public
/// perform the case conversion to the specified value
procedure Process(aFieldIndex: integer; var Value: RawUTF8); override;
end;
/// convert the value into WinAnsi Lower Case characters
// - LowerCase conversion is made for all latin characters in the WinAnsi
// code page only, e.g. 'E' acute will be converted to 'e'
// - this version expects no parameter
TSynFilterLowerCaseU = class(TSynFilter)
public
/// perform the case conversion to the specified value
procedure Process(aFieldIndex: integer; var Value: RawUTF8); override;
end;
/// trim any space character left or right to the value
// - this versions expect no parameter
TSynFilterTrim = class(TSynFilter)
public
/// perform the space triming conversion to the specified value
procedure Process(aFieldIndex: integer; var Value: RawUTF8); override;
end;
/// truncate a text above a given maximum length
// - expects optional JSON parameters of the allowed text length range as
// $ '{MaxLength":10}
TSynFilterTruncate = class(TSynFilter)
protected
fMaxLength: cardinal;
fUTF8Length: boolean;
/// decode the MaxLength: and UTF8Length: parameters
procedure SetParameters(const Value: RawUTF8); override;
public
/// perform the length truncation of the specified value
procedure Process(aFieldIndex: integer; var Value: RawUTF8); override;
/// Maximal length value allowed for the text content
// - the length is calculated with UTF-16 Unicode codepoints, unless
// UTF8Length has been set to TRUE so that the UTF-8 byte count is checked
// - default is 0, i.e. no maximum length is forced
property MaxLength: cardinal read fMaxLength write fMaxLength;
/// defines if MaxLength is stored as UTF-8 or UTF-16 codepoints number
// - with default FALSE, the length is calculated with UTF-16 Unicode
// codepoints - MaxLength may not match the UCS4 glyphs number, in case of
// UTF-16 surrogates
// - you can set this property to TRUE so that the UTF-8 byte count would
// be used for truncation againts the MaxLength parameter
property UTF8Length: boolean read fUTF8Length write fUTF8Length;
end;
resourcestring
sInvalidIPAddress = '"%s" is an invalid IP v4 address';
sInvalidEmailAddress = '"%s" is an invalid email address';
sInvalidPattern = '"%s" does not match the expected pattern';
sCharacter01n = 'character,character,characters';
sInvalidTextLengthMin = 'Expect at least %d %s';
sInvalidTextLengthMax = 'Expect up to %d %s';
sInvalidTextChar = 'Expect at least %d %s %s,Expect up to %d %s %s,'+
'alphabetical,digital,punctuation,lowercase,uppercase,space,'+
'Too much spaces on the left,Too much spaces on the right';
sValidationFailed = '"%s" rule failed';
sValidationFieldVoid = 'An unique key field must not be void';
sValidationFieldDuplicate = 'Value already used for this unique key field';
{ ************ Database types and classes ************************** }
type
/// handled field/parameter/column types for abstract database access
// - this will map JSON-compatible low-level database-level access types, not
// high-level Delphi types as TSQLFieldType defined in mORMot.pas
// - it does not map either all potential types as defined in DB.pas (which
// are there for compatibility with old RDBMS, and are not abstract enough)
// - those types can be mapped to standard SQLite3 generic types, i.e.
// NULL, INTEGER, REAL, TEXT, BLOB (with the addition of a ftCurrency and
// ftDate type, for better support of most DB engines)
// see @http://www.sqlite.org/datatype3.html
// - the only string type handled here uses UTF-8 encoding (implemented
// using our RawUTF8 type), for cross-Delphi true Unicode process
TSQLDBFieldType =
(ftUnknown, ftNull, ftInt64, ftDouble, ftCurrency, ftDate, ftUTF8, ftBlob);
/// set of field/parameter/column types for abstract database access
TSQLDBFieldTypes = set of TSQLDBFieldType;
/// array of field/parameter/column types for abstract database access
TSQLDBFieldTypeDynArray = array of TSQLDBFieldType;
/// array of field/parameter/column types for abstract database access
// - this array as a fixed size, ready to handle up to MAX_SQLFIELDS items
TSQLDBFieldTypeArray = array[0..MAX_SQLFIELDS-1] of TSQLDBFieldType;
PSQLDBFieldTypeArray = ^TSQLDBFieldTypeArray;
/// how TSQLVar may be processed
// - by default, ftDate will use seconds resolution unless svoDateWithMS is set
TSQLVarOption = (svoDateWithMS);
/// defines how TSQLVar may be processed
TSQLVarOptions = set of TSQLVarOption;
/// memory structure used for database values by reference storage
// - used mainly by SynDB, mORMot, mORMotDB and mORMotSQLite3 units
// - defines only TSQLDBFieldType data types (similar to those handled by
// SQLite3, with the addition of ftCurrency and ftDate)
// - cleaner/lighter dedicated type than TValue or variant/TVarData, strong
// enough to be marshalled as JSON content
// - variable-length data (e.g. UTF-8 text or binary BLOB) are never stored
// within this record, but VText/VBlob will point to an external (temporary)
// memory buffer
// - date/time is stored as ISO-8601 text (with milliseconds if svoDateWithMS
// option is set and the database supports it), and currency as double or BCD
// in most databases
TSQLVar = record
/// how this value should be processed
Options: TSQLVarOptions;
/// the type of the value stored
case VType: TSQLDBFieldType of
ftInt64: (
VInt64: Int64);
ftDouble: (
VDouble: double);
ftDate: (
VDateTime: TDateTime);
ftCurrency: (
VCurrency: Currency);
ftUTF8: (
VText: PUTF8Char);
ftBlob: (
VBlob: pointer;
VBlobLen: Integer)
end;
/// dynamic array of database values by reference storage
TSQLVarDynArray = array of TSQLVar;
/// used to store bit set for all available fields in a Table
// - with current MAX_SQLFIELDS value, 64 bits uses 8 bytes of memory
// - see also IsZero() and IsEqual() functions
// - you can also use ALL_FIELDS as defined in mORMot.pas
TSQLFieldBits = set of 0..MAX_SQLFIELDS-1;
/// used to store a field index in a Table
// - note that -1 is commonly used for the ID/RowID field so the values should
// be signed
// - even if ShortInt (-128..127) may have been enough, we define a 16 bit
// safe unsigned integer to let the source compile with Delphi 5
TSQLFieldIndex = SmallInt; // -32768..32767
/// used to store field indexes in a Table
// - same as TSQLFieldBits, but allowing to store the proper order
TSQLFieldIndexDynArray = array of TSQLFieldIndex;
/// points to a bit set used for all available fields in a Table
PSQLFieldBits = ^TSQLFieldBits;
/// generic parameter types, as recognized by SQLParamContent() and
// ExtractInlineParameters() functions
TSQLParamType = (sptUnknown, sptInteger, sptFloat, sptText, sptBlob, sptDateTime);
/// array of parameter types, as recognized by SQLParamContent() and
// ExtractInlineParameters() functions
TSQLParamTypeDynArray = array of TSQLParamType;
/// simple writer to a Stream, specialized for the JSON format and SQL export
// - i.e. define some property/method helpers to export SQL resultset as JSON
// - see mORMot.pas for proper class serialization via TJSONSerializer.WriteObject
TJSONWriter = class(TTextWriterWithEcho)
protected
/// used to store output format
fExpand: boolean;
/// used to store output format for TSQLRecord.GetJSONValues()
fWithID: boolean;
/// used to store field for TSQLRecord.GetJSONValues()
fFields: TSQLFieldIndexDynArray;
/// if not Expanded format, contains the Stream position of the first
// useful Row of data; i.e. ',val11' position in:
// & { "fieldCount":1,"values":["col1","col2",val11,"val12",val21,..] }
fStartDataPosition: integer;
public
/// used internally to store column names and count for AddColumns
ColNames: TRawUTF8DynArray;
/// the data will be written to the specified Stream
// - if no Stream is supplied, a temporary memory stream will be created
// (it's faster to supply one, e.g. any TSQLRest.TempMemoryStream)
constructor Create(aStream: TStream; Expand, withID: boolean;
const Fields: TSQLFieldBits; aBufSize: integer=8192); overload;
/// the data will be written to the specified Stream
// - if no Stream is supplied, a temporary memory stream will be created
// (it's faster to supply one, e.g. any TSQLRest.TempMemoryStream)
constructor Create(aStream: TStream; Expand, withID: boolean;
const Fields: TSQLFieldIndexDynArray=nil; aBufSize: integer=8192;
aStackBuffer: PTextWriterStackBuffer=nil); overload;
/// rewind the Stream position and write void JSON object
procedure CancelAllVoid;
/// write or init field names for appropriate JSON Expand later use
// - ColNames[] must have been initialized before calling this procedure
// - if aKnownRowsCount is not null, a "rowCount":... item will be added
// to the generated JSON stream (for faster unserialization of huge content)
procedure AddColumns(aKnownRowsCount: integer=0);
/// allow to change on the fly an expanded format column layout
// - by definition, a non expanded format will raise a ESynException
// - caller should then set ColNames[] and run AddColumns()
procedure ChangeExpandedFields(aWithID: boolean; const aFields: TSQLFieldIndexDynArray); overload;
/// end the serialized JSON object
// - cancel last ','
// - close the JSON object ']' or ']}'
// - write non expanded postlog (,"rowcount":...), if needed
// - flush the internal buffer content if aFlushFinal=true
procedure EndJSONObject(aKnownRowsCount,aRowsCount: integer; aFlushFinal: boolean=true);
{$ifdef HASINLINE}inline;{$endif}
/// the first data row is erased from the content
// - only works if the associated storage stream is TMemoryStream
// - expect not Expanded format
procedure TrimFirstRow;
/// is set to TRUE in case of Expanded format
property Expand: boolean read fExpand write fExpand;
/// is set to TRUE if the ID field must be appended to the resulting JSON
// - this field is used only by TSQLRecord.GetJSONValues
// - this field is ignored by TSQLTable.GetJSONValues
property WithID: boolean read fWithID;
/// Read-Only access to the field bits set for each column to be stored
property Fields: TSQLFieldIndexDynArray read fFields;
/// if not Expanded format, contains the Stream position of the first
// useful Row of data; i.e. ',val11' position in:
// & { "fieldCount":1,"values":["col1","col2",val11,"val12",val21,..] }
property StartDataPosition: integer read fStartDataPosition;
end;
/// returns TRUE if no bit inside this TSQLFieldBits is set
// - is optimized for 64, 128, 192 and 256 max bits count (i.e. MAX_SQLFIELDS)
// - will work also with any other value
function IsZero(const Fields: TSQLFieldBits): boolean; overload;
{$ifdef HASINLINE}inline;{$endif}
/// fast comparison of two TSQLFieldBits values
// - is optimized for 64, 128, 192 and 256 max bits count (i.e. MAX_SQLFIELDS)
// - will work also with any other value
function IsEqual(const A,B: TSQLFieldBits): boolean; overload;
{$ifdef HASINLINE}inline;{$endif}
/// fast initialize a TSQLFieldBits with 0
// - is optimized for 64, 128, 192 and 256 max bits count (i.e. MAX_SQLFIELDS)
// - will work also with any other value
procedure FillZero(var Fields: TSQLFieldBits); overload;
{$ifdef HASINLINE}inline;{$endif}
/// convert a TSQLFieldBits set of bits into an array of integers
procedure FieldBitsToIndex(const Fields: TSQLFieldBits;
var Index: TSQLFieldIndexDynArray; MaxLength: integer=MAX_SQLFIELDS;
IndexStart: integer=0); overload;
/// convert a TSQLFieldBits set of bits into an array of integers
function FieldBitsToIndex(const Fields: TSQLFieldBits;
MaxLength: integer=MAX_SQLFIELDS): TSQLFieldIndexDynArray; overload;
{$ifdef HASINLINE}inline;{$endif}
/// add a field index to an array of field indexes
// - returns the index in Indexes[] of the newly appended Field value
function AddFieldIndex(var Indexes: TSQLFieldIndexDynArray; Field: integer): integer;
/// convert an array of field indexes into a TSQLFieldBits set of bits
procedure FieldIndexToBits(const Index: TSQLFieldIndexDynArray; var Fields: TSQLFieldBits); overload;
// search a field index in an array of field indexes
// - returns the index in Indexes[] of the given Field value, -1 if not found
function SearchFieldIndex(var Indexes: TSQLFieldIndexDynArray; Field: integer): integer;
/// convert an array of field indexes into a TSQLFieldBits set of bits
function FieldIndexToBits(const Index: TSQLFieldIndexDynArray): TSQLFieldBits; overload;
{$ifdef HASINLINE}inline;{$endif}
/// returns the stored size of a TSQLVar database value
// - only returns VBlobLen / StrLen(VText) size, 0 otherwise
function SQLVarLength(const Value: TSQLVar): integer;
{$ifndef NOVARIANTS}
/// convert any Variant into a database value
// - ftBlob kind won't be handled by this function
// - complex variant types would be converted into ftUTF8 JSON object/array
procedure VariantToSQLVar(const Input: variant; var temp: RawByteString;
var Output: TSQLVar);
/// guess the correct TSQLDBFieldType from a variant type
function VariantVTypeToSQLDBFieldType(VType: cardinal): TSQLDBFieldType;
/// guess the correct TSQLDBFieldType from a variant value
function VariantTypeToSQLDBFieldType(const V: Variant): TSQLDBFieldType;
{$ifdef HASINLINE}inline;{$endif}
/// guess the correct TSQLDBFieldType from the UTF-8 representation of a value
function TextToSQLDBFieldType(json: PUTF8Char): TSQLDBFieldType;
type
/// define a variant published property as a nullable integer
// - either a varNull or a varInt64 value will be stored in the variant
// - either a NULL or an INTEGER value will be stored in the database
// - the property should be defined as such:
// ! property Int: TNullableInteger read fInt write fInt;
TNullableInteger = type variant;
/// define a variant published property as a nullable boolean
// - either a varNull or a varBoolean value will be stored in the variant
// - either a NULL or a 0/1 INTEGER value will be stored in the database
// - the property should be defined as such:
// ! property Bool: TNullableBoolean read fBool write fBool;
TNullableBoolean = type variant;
/// define a variant published property as a nullable floating point value
// - either a varNull or a varDouble value will be stored in the variant
// - either a NULL or a FLOAT value will be stored in the database
// - the property should be defined as such:
// ! property Flt: TNullableFloat read fFlt write fFlt;
TNullableFloat = type variant;
/// define a variant published property as a nullable decimal value
// - either a varNull or a varCurrency value will be stored in the variant
// - either a NULL or a FLOAT value will be stored in the database
// - the property should be defined as such:
// ! property Cur: TNullableCurrency read fCur write fCur;
TNullableCurrency = type variant;
/// define a variant published property as a nullable date/time value
// - either a varNull or a varDate value will be stored in the variant
// - either a NULL or a ISO-8601 TEXT value will be stored in the database
// - the property should be defined as such:
// ! property Dat: TNullableDateTime read fDat write fDat;
TNullableDateTime = type variant;
/// define a variant published property as a nullable timestamp value
// - either a varNull or a varInt64 value will be stored in the variant
// - either a NULL or a TTimeLog INTEGER value will be stored in the database
// - the property should be defined as such:
// ! property Tim: TNullableTimrency read fTim write fTim;
TNullableTimeLog = type variant;
/// define a variant published property as a nullable UTF-8 encoded text
// - either a varNull or varString (RawUTF8) will be stored in the variant
// - either a NULL or a TEXT value will be stored in the database
// - the property should be defined as such:
// ! property Txt: TNullableUTF8Text read fTxt write fTxt;
// or for a fixed-width VARCHAR (in external databases), here of 32 max chars:
// ! property Txt: TNullableUTF8Text index 32 read fTxt write fTxt;
// - warning: prior to Delphi 2009, since the variant will be stored as
// RawUTF8 internally, you should not use directly the field value as a
// VCL string=AnsiString like string(aField) but use VariantToString(aField)
TNullableUTF8Text = type variant;
var
/// a nullable integer value containing null
NullableIntegerNull: TNullableInteger absolute NullVarData;
/// a nullable boolean value containing null
NullableBooleanNull: TNullableBoolean absolute NullVarData;
/// a nullable float value containing null
NullableFloatNull: TNullableFloat absolute NullVarData;
/// a nullable currency value containing null
NullableCurrencyNull: TNullableCurrency absolute NullVarData;
/// a nullable TDateTime value containing null
NullableDateTimeNull: TNullableDateTime absolute NullVarData;
/// a nullable TTimeLog value containing null
NullableTimeLogNull: TNullableTimeLog absolute NullVarData;
/// a nullable UTF-8 encoded text value containing null
NullableUTF8TextNull: TNullableUTF8Text absolute NullVarData;
/// creates a nullable integer value from a supplied constant
// - FPC does not allow direct assignment to a TNullableInteger = type variant
// variable: use this function to circumvent it
function NullableInteger(const Value: Int64): TNullableInteger;
{$ifdef HASINLINE}inline;{$endif}
/// same as VarIsEmpty(V) or VarIsEmpty(V), but faster
// - FPC VarIsNull() seems buggy with varByRef variants, and does not allow
// direct transtyping from a TNullableInteger = type variant variable: use this
// function to circumvent those limitations
function NullableIntegerIsEmptyOrNull(const V: TNullableInteger): Boolean;
{$ifdef HASINLINE}inline;{$endif}
/// check if a TNullableInteger is null, or return its value
// - returns FALSE if V is null or empty, or TRUE and set the Integer value
function NullableIntegerToValue(const V: TNullableInteger; out Value: Int64): Boolean;
overload; {$ifdef HASINLINE}inline;{$endif}
/// check if a TNullableInteger is null, or return its value
// - returns 0 if V is null or empty, or the stored Integer value
function NullableIntegerToValue(const V: TNullableInteger): Int64;
overload; {$ifdef HASINLINE}inline;{$endif}
/// creates a nullable Boolean value from a supplied constant
// - FPC does not allow direct assignment to a TNullableBoolean = type variant
// variable: use this function to circumvent it
function NullableBoolean(Value: boolean): TNullableBoolean;
{$ifdef HASINLINE}inline;{$endif}
/// same as VarIsEmpty(V) or VarIsEmpty(V), but faster
// - FPC VarIsNull() seems buggy with varByRef variants, and does not allow
// direct transtyping from a TNullableBoolean = type variant variant: use this
// function to circumvent those limitations
function NullableBooleanIsEmptyOrNull(const V: TNullableBoolean): Boolean;
{$ifdef HASINLINE}inline;{$endif}
/// check if a TNullableBoolean is null, or return its value
// - returns FALSE if V is null or empty, or TRUE and set the Boolean value
function NullableBooleanToValue(const V: TNullableBoolean; out Value: Boolean): Boolean;
overload; {$ifdef HASINLINE}inline;{$endif}
/// check if a TNullableBoolean is null, or return its value
// - returns false if V is null or empty, or the stored Boolean value
function NullableBooleanToValue(const V: TNullableBoolean): Boolean;
overload; {$ifdef HASINLINE}inline;{$endif}
/// creates a nullable floating-point value from a supplied constant
// - FPC does not allow direct assignment to a TNullableFloat = type variant
// variable: use this function to circumvent it
function NullableFloat(const Value: double): TNullableFloat;
{$ifdef HASINLINE}inline;{$endif}
/// same as VarIsEmpty(V) or VarIsEmpty(V), but faster
// - FPC VarIsNull() seems buggy with varByRef variants, and does not allow
// direct transtyping from a TNullableFloat = type variant variable: use this
// function to circumvent those limitations
function NullableFloatIsEmptyOrNull(const V: TNullableFloat): Boolean;
{$ifdef HASINLINE}inline;{$endif}
/// check if a TNullableFloat is null, or return its value
// - returns FALSE if V is null or empty, or TRUE and set the Float value
function NullableFloatToValue(const V: TNullableFloat; out Value: double): boolean;
overload; {$ifdef HASINLINE}inline;{$endif}
/// check if a TNullableFloat is null, or return its value
// - returns 0 if V is null or empty, or the stored Float value
function NullableFloatToValue(const V: TNullableFloat): double;
overload; {$ifdef HASINLINE}inline;{$endif}
/// creates a nullable Currency value from a supplied constant
// - FPC does not allow direct assignment to a TNullableCurrency = type variant
// variable: use this function to circumvent it
function NullableCurrency(const Value: currency): TNullableCurrency;
{$ifdef HASINLINE}inline;{$endif}
/// same as VarIsEmpty(V) or VarIsEmpty(V), but faster
// - FPC VarIsNull() seems buggy with varByRef variants, and does not allow
// direct transtyping from a TNullableCurrency = type variant variable: use this
// function to circumvent those limitations
function NullableCurrencyIsEmptyOrNull(const V: TNullableCurrency): Boolean;
{$ifdef HASINLINE}inline;{$endif}
/// check if a TNullableCurrency is null, or return its value
// - returns FALSE if V is null or empty, or TRUE and set the Currency value
function NullableCurrencyToValue(const V: TNullableCurrency; out Value: currency): boolean;
overload; {$ifdef HASINLINE}inline;{$endif}
/// check if a TNullableCurrency is null, or return its value
// - returns 0 if V is null or empty, or the stored Currency value
function NullableCurrencyToValue(const V: TNullableCurrency): currency;
overload; {$ifdef HASINLINE}inline;{$endif}
/// creates a nullable TDateTime value from a supplied constant
// - FPC does not allow direct assignment to a TNullableDateTime = type variant
// variable: use this function to circumvent it
function NullableDateTime(const Value: TDateTime): TNullableDateTime;
{$ifdef HASINLINE}inline;{$endif}
/// same as VarIsEmpty(V) or VarIsEmpty(V), but faster
// - FPC VarIsNull() seems buggy with varByRef variants, and does not allow
// direct transtyping from a TNullableDateTime = type variant variable: use this
// function to circumvent those limitations
function NullableDateTimeIsEmptyOrNull(const V: TNullableDateTime): Boolean;
{$ifdef HASINLINE}inline;{$endif}
/// check if a TNullableDateTime is null, or return its value
// - returns FALSE if V is null or empty, or TRUE and set the DateTime value
function NullableDateTimeToValue(const V: TNullableDateTime; out Value: TDateTime): boolean;
overload; {$ifdef HASINLINE}inline;{$endif}
/// check if a TNullableDateTime is null, or return its value
// - returns 0 if V is null or empty, or the stored DateTime value
function NullableDateTimeToValue(const V: TNullableDateTime): TDateTime;
overload; {$ifdef HASINLINE}inline;{$endif}
/// creates a nullable TTimeLog value from a supplied constant
// - FPC does not allow direct assignment to a TNullableTimeLog = type variant
// variable: use this function to circumvent it
function NullableTimeLog(const Value: TTimeLog): TNullableTimeLog;
{$ifdef HASINLINE}inline;{$endif}
/// same as VarIsEmpty(V) or VarIsEmpty(V), but faster
// - FPC VarIsNull() seems buggy with varByRef variants, and does not allow
// direct transtyping from a TNullableTimeLog = type variant variable: use this
// function to circumvent those limitations
function NullableTimeLogIsEmptyOrNull(const V: TNullableTimeLog): Boolean;
{$ifdef HASINLINE}inline;{$endif}
/// check if a TNullableTimeLog is null, or return its value
// - returns FALSE if V is null or empty, or TRUE and set the TimeLog value
function NullableTimeLogToValue(const V: TNullableTimeLog; out Value: TTimeLog): boolean;
overload; {$ifdef HASINLINE}inline;{$endif}
/// check if a TNullableTimeLog is null, or return its value
// - returns 0 if V is null or empty, or the stored TimeLog value
function NullableTimeLogToValue(const V: TNullableTimeLog): TTimeLog;
overload; {$ifdef HASINLINE}inline;{$endif}
/// creates a nullable UTF-8 encoded text value from a supplied constant
// - FPC does not allow direct assignment to a TNullableUTF8 = type variant
// variable: use this function to circumvent it
function NullableUTF8Text(const Value: RawUTF8): TNullableUTF8Text;
{$ifdef HASINLINE}inline;{$endif}
/// same as VarIsEmpty(V) or VarIsEmpty(V), but faster
// - FPC VarIsNull() seems buggy with varByRef variants, and does not allow
// direct transtyping from a TNullableUTF8Text = type variant variable: use this
// function to circumvent those limitations
function NullableUTF8TextIsEmptyOrNull(const V: TNullableUTF8Text): Boolean;
{$ifdef HASINLINE}inline;{$endif}
/// check if a TNullableUTF8Text is null, or return its value
// - returns FALSE if V is null or empty, or TRUE and set the UTF8Text value
function NullableUTF8TextToValue(const V: TNullableUTF8Text; out Value: RawUTF8): boolean;
overload; {$ifdef HASINLINE}inline;{$endif}
/// check if a TNullableUTF8Text is null, or return its value
// - returns '' if V is null or empty, or the stored UTF8-encoded text value
function NullableUTF8TextToValue(const V: TNullableUTF8Text): RawUTF8;
overload; {$ifdef HASINLINE}inline;{$endif}
{$endif NOVARIANTS}
/// convert a date to a ISO-8601 string format for SQL '?' inlined parameters
// - will return the date encoded as '\uFFF1YYYY-MM-DD' - therefore
// ':("\uFFF12012-05-04"):' pattern will be recognized as a sftDateTime
// inline parameter in SQLParamContent() / ExtractInlineParameters() functions
// (JSON_SQLDATE_MAGIC will be used as prefix to create '\uFFF1...' pattern)
// - to be used e.g. as in:
// ! aRec.CreateAndFillPrepare(Client,'Datum=?',[DateToSQL(EncodeDate(2012,5,4))]);
function DateToSQL(Date: TDateTime): RawUTF8; overload;
/// convert a date to a ISO-8601 string format for SQL '?' inlined parameters
// - will return the date encoded as '\uFFF1YYYY-MM-DD' - therefore
// ':("\uFFF12012-05-04"):' pattern will be recognized as a sftDateTime
// inline parameter in SQLParamContent() / ExtractInlineParameters() functions
// (JSON_SQLDATE_MAGIC will be used as prefix to create '\uFFF1...' pattern)
// - to be used e.g. as in:
// ! aRec.CreateAndFillPrepare(Client,'Datum=?',[DateToSQL(2012,5,4)]);
function DateToSQL(Year,Month,Day: cardinal): RawUTF8; overload;
/// convert a date/time to a ISO-8601 string format for SQL '?' inlined parameters
// - if DT=0, returns ''
// - if DT contains only a date, returns the date encoded as '\uFFF1YYYY-MM-DD'
// - if DT contains only a time, returns the time encoded as '\uFFF1Thh:mm:ss'
// - otherwise, returns the ISO-8601 date and time encoded as '\uFFF1YYYY-MM-DDThh:mm:ss'
// (JSON_SQLDATE_MAGIC will be used as prefix to create '\uFFF1...' pattern)
// - if WithMS is TRUE, will append '.sss' for milliseconds resolution
// - to be used e.g. as in:
// ! aRec.CreateAndFillPrepare(Client,'Datum<=?',[DateTimeToSQL(Now)]);
// - see TimeLogToSQL() if you are using TTimeLog/TModTime/TCreateTime values
function DateTimeToSQL(DT: TDateTime; WithMS: boolean=false): RawUTF8;
/// decode a SQL '?' inlined parameter (i.e. with JSON_SQLDATE_MAGIC prefix)
// - as generated by DateToSQL/DateTimeToSQL/TimeLogToSQL functions
function SQLToDateTime(const ParamValueWithMagic: RawUTF8): TDateTime;
/// convert a TTimeLog value into a ISO-8601 string format for SQL '?' inlined
// parameters
// - handle TTimeLog bit-encoded Int64 format
// - follows the same pattern as DateToSQL or DateTimeToSQL functions, i.e.
// will return the date or time encoded as '\uFFF1YYYY-MM-DDThh:mm:ss' -
// therefore ':("\uFFF12012-05-04T20:12:13"):' pattern will be recognized as a
// sftDateTime inline parameter in SQLParamContent() / ExtractInlineParameters()
// (JSON_SQLDATE_MAGIC will be used as prefix to create '\uFFF1...' pattern)
// - to be used e.g. as in:
// ! aRec.CreateAndFillPrepare(Client,'Datum<=?',[TimeLogToSQL(TimeLogNow)]);
function TimeLogToSQL(const Timestamp: TTimeLog): RawUTF8;
/// convert a Iso8601 encoded string into a ISO-8601 string format for SQL
// '?' inlined parameters
// - follows the same pattern as DateToSQL or DateTimeToSQL functions, i.e.
// will return the date or time encoded as '\uFFF1YYYY-MM-DDThh:mm:ss' -
// therefore ':("\uFFF12012-05-04T20:12:13"):' pattern will be recognized as a
// sftDateTime inline parameter in SQLParamContent() / ExtractInlineParameters()
// (JSON_SQLDATE_MAGIC will be used as prefix to create '\uFFF1...' pattern)
// - in practice, just append the JSON_SQLDATE_MAGIC prefix to the supplied text
function Iso8601ToSQL(const S: RawByteString): RawUTF8;
/// guess the content type of an UTF-8 SQL value, in :(....): format
// - will be used e.g. by ExtractInlineParameters() to un-inline a SQL statement
// - sftInteger is returned for an INTEGER value, e.g. :(1234):
// - sftFloat is returned for any floating point value (i.e. some digits
// separated by a '.' character), e.g. :(12.34): or :(12E-34):
// - sftUTF8Text is returned for :("text"): or :('text'):, with double quoting
// inside the value
// - sftBlob will be recognized from the ':("\uFFF0base64encodedbinary"):'
// pattern, and return raw binary (for direct blob parameter assignment)
// - sftDateTime will be recognized from ':(\uFFF1"2012-05-04"):' pattern,
// i.e. JSON_SQLDATE_MAGIC-prefixed string as returned by DateToSQL() or
// DateTimeToSQL() functions
// - sftUnknown is returned on invalid content, or if wasNull is set to TRUE
// - if ParamValue is not nil, the pointing RawUTF8 string is set with the
// value inside :(...): without double quoting in case of sftUTF8Text
// - wasNull is set to TRUE if P was ':(null):' and ParamType is sftUnknwown
function SQLParamContent(P: PUTF8Char; out ParamType: TSQLParamType; out ParamValue: RawUTF8;
out wasNull: boolean): PUTF8Char;
/// this function will extract inlined :(1234): parameters into Types[]/Values[]
// - will return the generic SQL statement with ? place holders for inlined
// parameters and setting Values with SQLParamContent() decoded content
// - will set maxParam=0 in case of no inlined parameters
// - recognized types are sptInteger, sptFloat, sptDateTime ('\uFFF1...'),
// sptUTF8Text and sptBlob ('\uFFF0...')
// - sptUnknown is returned on invalid content
function ExtractInlineParameters(const SQL: RawUTF8;
var Types: TSQLParamTypeDynArray; var Values: TRawUTF8DynArray;
var maxParam: integer; var Nulls: TSQLFieldBits): RawUTF8;
/// returns a 64-bit value as inlined ':(1234):' text
function InlineParameter(ID: Int64): shortstring; overload;
/// returns a string value as inlined ':("value"):' text
function InlineParameter(const value: RawUTF8): RawUTF8; overload;
type
/// SQL Query comparison operators
// - used e.g. by CompareOperator() functions in SynTable.pas or vt_BestIndex()
// in mORMotSQLite3.pas
TCompareOperator = (
soEqualTo,
soNotEqualTo,
soLessThan,
soLessThanOrEqualTo,
soGreaterThan,
soGreaterThanOrEqualTo,
soBeginWith,
soContains,
soSoundsLikeEnglish,
soSoundsLikeFrench,
soSoundsLikeSpanish);
const
/// convert identified field types into high-level ORM types
// - as will be implemented in unit mORMot.pas
SQLDBFIELDTYPE_TO_DELPHITYPE: array[TSQLDBFieldType] of RawUTF8 = (
'???','???', 'Int64', 'Double', 'Currency', 'TDateTime', 'RawUTF8', 'TSQLRawBlob');
{ ************ low-level buffer processing functions ************************* }
type
/// safe decoding of a TFileBufferWriter content
// - similar to TFileBufferReader, but faster and only for in-memory buffer
// - is also safer, since will check for reaching end of buffer
// - raise a EFastReader exception on decoding error (e.g. if a buffer
// overflow may occur) or call OnErrorOverflow/OnErrorData event handlers
{$ifdef USERECORDWITHMETHODS}TFastReader = record
{$else}TFastReader = object{$endif}
public
/// the current position in the memory
P: PAnsiChar;
/// the last position in the buffer
Last: PAnsiChar;
/// use this event to customize the ErrorOverflow process
OnErrorOverflow: procedure of object;
/// use this event to customize the ErrorData process
OnErrorData: procedure(const fmt: RawUTF8; const args: array of const) of object;
/// some opaque value, which may be a version number to define the binary layout
Tag: PtrInt;
/// initialize the reader from a memory block
procedure Init(Buffer: pointer; Len: integer); overload;
/// initialize the reader from a RawByteString content
procedure Init(const Buffer: RawByteString); overload;
/// raise a EFastReader with an "overflow" error message
procedure ErrorOverflow;
/// raise a EFastReader with an "incorrect data" error message
procedure ErrorData(const fmt: RawUTF8; const args: array of const);
/// read the next 32-bit signed value from the buffer
function VarInt32: integer; {$ifdef HASINLINE}inline;{$endif}
/// read the next 32-bit unsigned value from the buffer
function VarUInt32: cardinal;
/// try to read the next 32-bit signed value from the buffer
// - don't change the current position
function PeekVarInt32(out value: PtrInt): boolean; {$ifdef HASINLINE}inline;{$endif}
/// try to read the next 32-bit unsigned value from the buffer
// - don't change the current position
function PeekVarUInt32(out value: PtrUInt): boolean;
/// read the next 32-bit unsigned value from the buffer
// - this version won't call ErrorOverflow, but return false on error
// - returns true on read success
function VarUInt32Safe(out Value: cardinal): boolean;
/// read the next 64-bit signed value from the buffer
function VarInt64: Int64; {$ifdef HASINLINE}inline;{$endif}
/// read the next 64-bit unsigned value from the buffer
function VarUInt64: QWord;
/// read the next RawUTF8 value from the buffer
function VarUTF8: RawUTF8; overload;
/// read the next RawUTF8 value from the buffer
procedure VarUTF8(out result: RawUTF8); overload;
/// read the next RawUTF8 value from the buffer
// - this version won't call ErrorOverflow, but return false on error
// - returns true on read success
function VarUTF8Safe(out Value: RawUTF8): boolean;
/// read the next RawByteString value from the buffer
function VarString: RawByteString; {$ifdef HASINLINE}inline;{$endif}
/// read the next pointer and length value from the buffer
procedure VarBlob(out result: TValueResult); overload; {$ifdef HASINLINE}inline;{$endif}
/// read the next pointer and length value from the buffer
function VarBlob: TValueResult; overload; {$ifdef HASINLINE}inline;{$endif}
/// read the next ShortString value from the buffer
function VarShortString: shortstring; {$ifdef HASINLINE}inline;{$endif}
/// fast ignore the next VarUInt32/VarInt32/VarUInt64/VarInt64 value
// - don't raise any exception, so caller could check explicitly for any EOF
procedure VarNextInt; overload; {$ifdef HASINLINE}inline;{$endif}
/// fast ignore the next count VarUInt32/VarInt32/VarUInt64/VarInt64 values
// - don't raise any exception, so caller could check explicitly for any EOF
procedure VarNextInt(count: integer); overload;
/// read the next byte from the buffer
function NextByte: byte; {$ifdef HASINLINE}inline;{$endif}
/// read the next byte from the buffer, checking
function NextByteSafe(dest: pointer): boolean; {$ifdef HASINLINE}inline;{$endif}
/// read the next 4 bytes from the buffer as a 32-bit unsigned value
function Next4: cardinal; {$ifdef HASINLINE}inline;{$endif}
/// read the next 8 bytes from the buffer as a 64-bit unsigned value
function Next8: Qword; {$ifdef HASINLINE}inline;{$endif}
/// consumes the next byte from the buffer, if matches a given value
function NextByteEquals(Value: byte): boolean; {$ifdef HASINLINE}inline;{$endif}
/// returns the current position, and move ahead the specified bytes
function Next(DataLen: PtrInt): pointer; {$ifdef HASINLINE}inline;{$endif}
/// returns the current position, and move ahead the specified bytes
function NextSafe(out Data: Pointer; DataLen: PtrInt): boolean; {$ifdef HASINLINE}inline;{$endif}
{$ifndef NOVARIANTS}
/// read the next variant from the buffer
// - is a wrapper around VariantLoad()
procedure NextVariant(var Value: variant; CustomVariantOptions: PDocVariantOptions);
/// read the JSON-serialized TDocVariant from the buffer
// - matches TFileBufferWriter.WriteDocVariantData format
procedure NextDocVariantData(out Value: variant; CustomVariantOptions: PDocVariantOptions);
{$endif NOVARIANTS}
/// copy data from the current position, and move ahead the specified bytes
procedure Copy(out Dest; DataLen: PtrInt); {$ifdef HASINLINE}inline;{$endif}
/// copy data from the current position, and move ahead the specified bytes
// - this version won't call ErrorOverflow, but return false on error
// - returns true on read success
function CopySafe(out Dest; DataLen: PtrInt): boolean;
/// apply TDynArray.LoadFrom on the buffer
// - will unserialize a previously appended dynamic array, e.g. as
// ! aWriter.WriteDynArray(DA);
procedure Read(var DA: TDynArray; NoCheckHash: boolean=false);
/// retrieved cardinal values encoded with TFileBufferWriter.WriteVarUInt32Array
// - only supports wkUInt32, wkVarInt32, wkVarUInt32 kind of encoding
function ReadVarUInt32Array(var Values: TIntegerDynArray): PtrInt;
/// retrieve some TAlgoCompress buffer, appended via Write()
// - BufferOffset could be set to reserve some bytes before the uncompressed buffer
function ReadCompressed(Load: TAlgoCompressLoad=aclNormal; BufferOffset: integer=0): RawByteString;
/// returns TRUE if the current position is the end of the input stream
function EOF: boolean; {$ifdef HASINLINE}inline;{$endif}
/// returns remaining length (difference between Last and P)
function RemainingLength: PtrUInt; {$ifdef HASINLINE}inline;{$endif}
end;
/// implements a stack-based writable storage of binary content
// - memory allocation is performed via a TSynTempBuffer
TSynTempWriter = object
public
/// the current writable position in tmp.buf
pos: PAnsiChar;
/// initialize a new temporary buffer of a given number of bytes
// - if maxsize is left to its 0 default value, the default stack-allocated
// memory size is used, i.e. 4 KB
procedure Init(maxsize: integer=0);
/// finalize the temporary storage
procedure Done;
/// append some binary to the internal buffer
// - will raise an ESynException in case of potential overflow
procedure wr(const val; len: PtrInt);
/// append some shortstring as binary to the internal buffer
procedure wrss(const str: shortstring); {$ifdef HASINLINE}inline;{$endif}
/// append some string as binary to the internal buffer
procedure wrs(const str: RawByteString); {$ifdef HASINLINE}inline;{$endif}
/// append some 8-bit value as binary to the internal buffer
procedure wrb(b: byte); {$ifdef HASINLINE}inline;{$endif}
/// append some 16-bit value as binary to the internal buffer
procedure wrw(w: word); {$ifdef HASINLINE}inline;{$endif}
/// append some 32-bit value as binary to the internal buffer
procedure wrint(int: integer); {$ifdef HASINLINE}inline;{$endif}
/// append some 32-bit/64-bit pointer value as binary to the internal buffer
procedure wrptr(ptr: pointer); {$ifdef HASINLINE}inline;{$endif}
/// append some 32-bit/64-bit integer as binary to the internal buffer
procedure wrptrint(int: PtrInt); {$ifdef HASINLINE}inline;{$endif}
/// append some fixed-value bytes as binary to the internal buffer
// - returns a pointer to the first byte of the added memory chunk
function wrfillchar(count: integer; value: byte): PAnsiChar;
/// returns the current offset position in the internal buffer
function Position: PtrInt; {$ifdef HASINLINE}inline;{$endif}
/// returns the buffer as a RawByteString instance
function AsBinary: RawByteString;
/// returns the buffer as a RawUTF8 instance
procedure AsUTF8(var result: RawUTF8);
protected
tmp: TSynTempBuffer;
end;
/// available kind of integer array storage, corresponding to the data layout
// - wkUInt32 will write the content as "plain" 4 bytes binary (this is the
// prefered way if the integers can be negative)
// - wkVarUInt32 will write the content using our 32-bit variable-length integer
// encoding
// - wkVarInt32 will write the content using our 32-bit variable-length integer
// encoding and the by-two complement (0=0,1=1,2=-1,3=2,4=-2...)
// - wkSorted will write an increasing array of integers, handling the special
// case of a difference of similar value (e.g. 1) between two values - note
// that this encoding is efficient only if the difference is main < 253
// - wkOffsetU and wkOffsetI will write the difference between two successive
// values, handling constant difference (Unsigned or Integer) in an optimized manner
// - wkFakeMarker won't be used by WriteVarUInt32Array, but to notify a
// custom encoding
TFileBufferWriterKind = (wkUInt32, wkVarUInt32, wkVarInt32, wkSorted,
wkOffsetU, wkOffsetI, wkFakeMarker);
/// this class can be used to speed up writing to a file
// - big speed up if data is written in small blocks
// - also handle optimized storage of any dynamic array of Integer/Int64/RawUTF8
// - use TFileBufferReader or TFastReader for decoding of the stored binary
TFileBufferWriter = class
private
fPos: PtrInt;
fBufLen: PtrInt;
fStream: TStream;
fTotalWritten: Int64;
fInternalStream: boolean;
fTag: PtrInt;
fBuffer: PByteArray;
fBufInternal: RawByteString;
procedure InternalFlush;
public
/// initialize the buffer, and specify a file handle to use for writing
// - use an internal buffer of the specified size
constructor Create(aFile: THandle; BufLen: integer=65536); overload;
/// initialize the buffer, and specify a TStream to use for writing
// - use an internal buffer of the specified size
constructor Create(aStream: TStream; BufLen: integer=65536); overload;
/// initialize the buffer, and specify a file to use for writing
// - use an internal buffer of the specified size
// - would replace any existing file by default, unless Append is TRUE
constructor Create(const aFileName: TFileName; BufLen: integer=65536;
Append: boolean=false); overload;
/// initialize the buffer, using an internal TStream instance
// - parameter could be e.g. THeapMemoryStream or TRawByteStringStream
// - use Flush then TMemoryStream(Stream) to retrieve its content, or
// TRawByteStringStream(Stream).DataString
constructor Create(aClass: TStreamClass; BufLen: integer=4096); overload;
/// initialize with a specified buffer and TStream class
// - use a specified external buffer (which may be allocated on stack),
// to avoid a memory allocation
constructor Create(aStream: TStream; aTempBuf: pointer; aTempLen: integer); overload;
/// initialize with a specified buffer
// - use a specified external buffer (which may be allocated on stack),
// to avoid a memory allocation
// - aStream parameter could be e.g. THeapMemoryStream or TRawByteStringStream
constructor Create(aClass: TStreamClass; aTempBuf: pointer; aTempLen: integer); overload;
/// release internal TStream (after AssignToHandle call)
// - warning: an explicit call to Flush is needed to write the data pending
// in internal buffer
destructor Destroy; override;
/// append some data at the current position
procedure Write(Data: pointer; DataLen: PtrInt); overload;
/// append 1 byte of data at the current position
procedure Write1(Data: Byte); {$ifdef HASINLINE}inline;{$endif}
/// append 2 bytes of data at the current position
procedure Write2(Data: Word); {$ifdef HASINLINE}inline;{$endif}
/// append 4 bytes of data at the current position
procedure Write4(Data: integer); {$ifdef HASINLINE}inline;{$endif}
/// append 4 bytes of data, encoded as BigEndian, at the current position
procedure Write4BigEndian(Data: integer); {$ifdef HASINLINE}inline;{$endif}
/// append 8 bytes of data at the current position
procedure Write8(const Data8Bytes); {$ifdef HASINLINE}inline;{$endif}
/// append the same byte a given number of occurences at the current position
procedure WriteN(Data: Byte; Count: integer);
/// append some UTF-8 encoded text at the current position
// - will write the string length (as VarUInt32), then the string content, as expected
// by the FromVarString() function
procedure Write(const Text: RawByteString); overload; {$ifdef HASINLINE}inline;{$endif}
/// append some UTF-8 encoded text at the current position
// - will write the string length (as VarUInt32), then the string content
procedure WriteShort(const Text: ShortString);
/// append some content at the current position
// - will write the binary data, without any length prefix
procedure WriteBinary(const Data: RawByteString);
{$ifndef NOVARIANTS}
/// append some variant value at the current position
// - matches FromVarVariant() and VariantSave/VariantLoad format
procedure Write(const Value: variant); overload;
/// append some TDocVariant value at the current position, as JSON string
// - matches TFastReader.NextDocVariantData format
procedure WriteDocVariantData(const Value: variant);
{$endif}
/// append some record at the current position, with binary serialization
// - will use the binary serialization as for:
// ! aWriter.WriteBinary(RecordSave(Rec,RecTypeInfo));
// but writing directly into the buffer, if possible
procedure WriteRecord(const Rec; RecTypeInfo: pointer);
/// append some dynamic array at the current position
// - will use the binary serialization as for:
// ! aWriter.WriteBinary(DA.SaveTo);
// but writing directly into the buffer, if possible
procedure WriteDynArray(const DA: TDynArray);
/// append "New[0..Len-1] xor Old[0..Len-1]" bytes
// - as used e.g. by ZeroCompressXor/TSynBloomFilterDiff.SaveTo
procedure WriteXor(New,Old: PAnsiChar; Len: PtrInt; crc: PCardinal=nil);
/// append a cardinal value using 32-bit variable-length integer encoding
procedure WriteVarUInt32(Value: PtrUInt);
/// append an integer value using 32-bit variable-length integer encoding of
// the by-two complement of the given value
procedure WriteVarInt32(Value: PtrInt);
/// append an integer value using 64-bit variable-length integer encoding of
// the by-two complement of the given value
procedure WriteVarInt64(Value: Int64);
/// append an unsigned integer value using 64-bit variable-length encoding
procedure WriteVarUInt64(Value: QWord);
/// append cardinal values (NONE must be negative!) using 32-bit
// variable-length integer encoding or other specialized algorithm,
// depending on the data layout
procedure WriteVarUInt32Array(const Values: TIntegerDynArray; ValuesCount: integer;
DataLayout: TFileBufferWriterKind);
/// append cardinal values (NONE must be negative!) using 32-bit
// variable-length integer encoding or other specialized algorithm,
// depending on the data layout
procedure WriteVarUInt32Values(Values: PIntegerArray; ValuesCount: integer;
DataLayout: TFileBufferWriterKind);
/// append UInt64 values using 64-bit variable length integer encoding
// - if Offset is TRUE, then it will store the difference between
// two values using 64-bit variable-length integer encoding (in this case,
// a fixed-sized record storage is also handled separately)
// - could be decoded later on via TFileBufferReader.ReadVarUInt64Array
procedure WriteVarUInt64DynArray(const Values: TInt64DynArray;
ValuesCount: integer; Offset: Boolean);
/// append the RawUTF8 dynamic array
// - handled the fixed size strings array case in a very efficient way
procedure WriteRawUTF8DynArray(const Values: TRawUTF8DynArray; ValuesCount: integer);
/// append a RawUTF8 array of values, from its low-level memory pointer
// - handled the fixed size strings array case in a very efficient way
procedure WriteRawUTF8Array(Values: PPtrUIntArray; ValuesCount: integer);
/// append the RawUTF8List content
// - if StoreObjectsAsVarUInt32 is TRUE, all Objects[] properties will be
// stored as VarUInt32
procedure WriteRawUTF8List(List: TRawUTF8List; StoreObjectsAsVarUInt32: Boolean=false);
/// append a TStream content
// - is StreamSize is left as -1, the Stream.Size is used
// - the size of the content is stored in the resulting stream
procedure WriteStream(aStream: TCustomMemoryStream; aStreamSize: Integer=-1);
/// allows to write directly to a memory buffer
// - caller should specify the maximum possible number of bytes to be written
// - then write the data to the returned pointer, and call DirectWriteFlush
function DirectWritePrepare(len: PtrInt; out tmp: RawByteString): PAnsiChar;
/// finalize a direct write to a memory buffer
// - by specifying the number of bytes written to the buffer
procedure DirectWriteFlush(len: PtrInt; const tmp: RawByteString);
/// write any pending data in the internal buffer to the file
// - after a Flush, it's possible to call FileSeek64(aFile,....)
// - returns the number of bytes written between two FLush method calls
function Flush: Int64;
/// write any pending data, then call algo.Compress() on the buffer
// - expect the instance to have been created via
// ! TFileBufferWriter.Create(TRawByteStringStream)
// - if algo is left to its default nil, will use global AlgoSynLZ
// - features direct compression from internal buffer, if stream was not used
// - BufferOffset could be set to reserve some bytes before the compressed buffer
function FlushAndCompress(nocompression: boolean=false; algo: TAlgoCompress=nil;
BufferOffset: integer=0): RawByteString;
/// rewind the Stream to the position when Create() was called
// - note that this does not clear the Stream content itself, just
// move back its writing position to its initial place
procedure CancelAll; virtual;
/// the associated writing stream
property Stream: TStream read fStream;
/// get the byte count written since last Flush
property TotalWritten: Int64 read fTotalWritten;
/// simple property used to store some integer content
property Tag: PtrInt read fTag write fTag;
end;
PFileBufferReader = ^TFileBufferReader;
/// this structure can be used to speed up reading from a file
// - use internaly memory mapped files for a file up to 2 GB (Windows has
// problems with memory mapped files bigger than this size limit - at least
// with 32-bit executables) - but sometimes, Windows fails to allocate
// more than 512 MB for a memory map, because it does lack of contiguous
// memory space: in this case, we fall back on direct file reading
// - maximum handled file size has no limit (but will use slower direct
// file reading)
// - can handle sophisticated storage layout of TFileBufferWriter for
// dynamic arrays of Integer/Int64/RawUTF8
// - is defined as an object or as a record, due to a bug
// in Delphi 2009/2010 compiler (at least): this structure is not initialized
// if defined as an object on the stack, but will be as a record :(
TFileBufferReader = object
protected
fCurrentPos: PtrUInt;
fMap: TMemoryMap;
/// get Isize + buffer from current memory map or fBufTemp into (P,PEnd)
procedure ReadChunk(out P, PEnd: PByte; var BufTemp: RawByteString);
public
/// initialize the buffer, and specify a file to use for reading
// - will try to map the whole file content in memory
// - if memory mapping failed, or aFileNotMapped is true, methods
// will use default slower file API
procedure Open(aFile: THandle; aFileNotMapped: boolean=false);
/// initialize the buffer from an already existing memory block
// - may be e.g. a resource or a TMemoryStream
procedure OpenFrom(aBuffer: pointer; aBufferSize: PtrUInt); overload;
/// initialize the buffer from an already existing memory block
procedure OpenFrom(const aBuffer: RawByteString); overload;
/// initialize the buffer from an already existing Stream
// - accept either TFileStream or TCustomMemoryStream kind of stream
function OpenFrom(Stream: TStream): boolean; overload;
/// close all internal mapped files
// - call Open() again to use the Read() methods
procedure Close;
{$ifndef CPU64}
/// change the current reading position, from the beginning of the file
// - returns TRUE if success, or FALSE if Offset is out of range
function Seek(Offset: Int64): boolean; overload;
{$endif}
/// change the current reading position, from the beginning of the file
// - returns TRUE if success, or FALSE if Offset is out of range
function Seek(Offset: PtrInt): boolean; overload;
/// raise an exception in case of invalid content
procedure ErrorInvalidContent;
/// read some bytes from the given reading position
// - returns the number of bytes which was read
// - if Data is nil, it won't read content but will forward reading position
function Read(Data: pointer; DataLen: PtrInt): integer; overload;
/// read some UTF-8 encoded text at the current position
// - returns the resulting text length, in bytes
function Read(out Text: RawUTF8): integer; overload;
/// read some buffer texgt at the current position
// - returns the resulting text length, in bytes
function Read(out Text: RawByteString): integer; overload;
/// read some UTF-8 encoded text at the current position
// - returns the resulting text
function ReadRawUTF8: RawUTF8; {$ifdef HASINLINE}inline;{$endif}
/// read one byte
// - if reached end of file, don't raise any error, but returns 0
function ReadByte: PtrUInt; {$ifdef HASINLINE}inline;{$endif}
/// read one cardinal, which was written as fixed length
// - if reached end of file, don't raise any error, but returns 0
function ReadCardinal: cardinal;
/// read one cardinal value encoded using our 32-bit variable-length integer
function ReadVarUInt32: PtrUInt;
/// read one integer value encoded using our 32-bit variable-length integer,
// and the by-two complement
function ReadVarInt32: PtrInt;
/// read one UInt64 value encoded using our 64-bit variable-length integer
function ReadVarUInt64: QWord;
/// read one Int64 value encoded using our 64-bit variable-length integer
function ReadVarInt64: Int64;
/// retrieved cardinal values encoded with TFileBufferWriter.WriteVarUInt32Array
// - returns the number of items read into Values[] (may differ from
// length(Values), which will be resized, so could be void before calling)
// - if the returned integer is negative, it is -Count, and testifies from
// wkFakeMarker and the content should be retrieved by the caller
function ReadVarUInt32Array(var Values: TIntegerDynArray): PtrInt;
/// retrieved Int64 values encoded with TFileBufferWriter.WriteVarUInt64DynArray
// - returns the number of items read into Values[] (may differ from length(Values))
function ReadVarUInt64Array(var Values: TInt64DynArray): PtrInt;
/// retrieved RawUTF8 values encoded with TFileBufferWriter.WriteRawUTF8DynArray
// - returns the number of items read into Values[] (may differ from length(Values))
function ReadVarRawUTF8DynArray(var Values: TRawUTF8DynArray): PtrInt;
/// retrieve the RawUTF8List content encoded with TFileBufferWriter.WriteRawUTF8List
// - if StoreObjectsAsVarUInt32 was TRUE, all Objects[] properties will be
// retrieved as VarUInt32
function ReadRawUTF8List(List: TRawUTF8List): boolean;
/// retrieve a pointer to the current position, for a given data length
// - if the data is available in the current memory mapped file, it
// will just return a pointer to it
// - otherwise (i.e. if the data is split between to 1GB memory map buffers),
// data will be copied into the temporary aTempData buffer before retrieval
function ReadPointer(DataLen: PtrUInt; var aTempData: RawByteString): pointer;
/// create a TMemoryStream instance from the current position
// - the content size is either specified by DataLen>=0, either available at
// the current position, as saved by TFileBufferWriter.WriteStream method
// - if this content fit in the current 1GB memory map buffer, a
// TSynMemoryStream instance is returned, with no data copy (faster)
// - if this content is not already mapped in memory, a separate memory map
// will be created (the returned instance is a TSynMemoryStreamMapped)
function ReadStream(DataLen: PtrInt=-1): TCustomMemoryStream;
/// retrieve the current in-memory pointer
// - if file was not memory-mapped, returns nil
// - if DataLen>0, will increment the current in-memory position
function CurrentMemory(DataLen: PtrUInt=0; PEnd: PPAnsiChar=nil): pointer;
/// retrieve the current in-memory position
// - if file was not memory-mapped, returns -1
function CurrentPosition: integer; {$ifdef HASINLINE}inline;{$endif}
/// read-only access to the global file size
function FileSize: Int64; {$ifdef HASINLINE}inline;{$endif}
/// read-only access to the global mapped buffer binary
function MappedBuffer: PAnsiChar; {$ifdef HASINLINE}inline;{$endif}
end;
/// implements a thread-safe Bloom Filter storage
// - a "Bloom Filter" is a space-efficient probabilistic data structure,
// that is used to test whether an element is a member of a set. False positive
// matches are possible, but false negatives are not. Elements can be added to
// the set, but not removed. Typical use cases are to avoid unecessary
// slow disk or network access if possible, when a lot of items are involved.
// - memory use is very low, when compared to storage of all values: fewer
// than 10 bits per element are required for a 1% false positive probability,
// independent of the size or number of elements in the set - for instance,
// storing 10,000,000 items presence with 1% of false positive ratio
// would consume only 11.5 MB of memory, using 7 hash functions
// - use Insert() methods to add an item to the internal bits array, and
// Reset() to clear all bits array, if needed
// - MayExist() function would check if the supplied item was probably set
// - SaveTo() and LoadFrom() methods allow transmission of the bits array,
// for a disk/database storage or transmission over a network
// - internally, several (hardware-accelerated) crc32c hash functions will be
// used, with some random seed values, to simulate several hashing functions
// - Insert/MayExist/Reset methods are thread-safe
TSynBloomFilter = class(TSynPersistentLock)
private
fSize: cardinal;
fFalsePositivePercent: double;
fBits: cardinal;
fHashFunctions: cardinal;
fInserted: cardinal;
fStore: RawByteString;
function GetInserted: cardinal;
public
/// initialize the internal bits storage for a given number of items
// - by default, internal bits array size will be guess from a 1 % false
// positive rate - but you may specify another value, to reduce memory use
// - this constructor would compute and initialize Bits and HashFunctions
// corresponding to the expected false positive ratio
constructor Create(aSize: integer; aFalsePositivePercent: double = 1); reintroduce; overload;
/// initialize the internal bits storage from a SaveTo() binary buffer
// - this constructor will initialize the internal bits array calling LoadFrom()
constructor Create(const aSaved: RawByteString; aMagic: cardinal=$B1003F11); reintroduce; overload;
/// add an item in the internal bits array storage
// - this method is thread-safe
procedure Insert(const aValue: RawByteString); overload;
/// add an item in the internal bits array storage
// - this method is thread-safe
procedure Insert(aValue: pointer; aValueLen: integer); overload; virtual;
/// clear the internal bits array storage
// - you may call this method after some time, if some items may have
// been removed, to reduce false positives
// - this method is thread-safe
procedure Reset; virtual;
/// returns TRUE if the supplied items was probably set via Insert()
// - some false positive may occur, but not much than FalsePositivePercent
// - this method is thread-safe
function MayExist(const aValue: RawByteString): boolean; overload;
/// returns TRUE if the supplied items was probably set via Insert()
// - some false positive may occur, but not much than FalsePositivePercent
// - this method is thread-safe
function MayExist(aValue: pointer; aValueLen: integer): boolean; overload;
/// store the internal bits array into a binary buffer
// - may be used to transmit or store the state of a dataset, avoiding
// to recompute all Insert() at program startup, or to synchronize
// networks nodes information and reduce the number of remote requests
function SaveTo(aMagic: cardinal=$B1003F11): RawByteString; overload;
/// store the internal bits array into a binary buffer
// - may be used to transmit or store the state of a dataset, avoiding
// to recompute all Insert() at program startup, or to synchronize
// networks nodes information and reduce the number of remote requests
procedure SaveTo(aDest: TFileBufferWriter; aMagic: cardinal=$B1003F11); overload;
/// read the internal bits array from a binary buffer
// - as previously serialized by the SaveTo method
// - may be used to transmit or store the state of a dataset
function LoadFrom(const aSaved: RawByteString; aMagic: cardinal=$B1003F11): boolean; overload;
/// read the internal bits array from a binary buffer
// - as previously serialized by the SaveTo method
// - may be used to transmit or store the state of a dataset
function LoadFrom(P: PByte; PLen: integer; aMagic: cardinal=$B1003F11): boolean; overload; virtual;
published
/// maximum number of items which are expected to be inserted
property Size: cardinal read fSize;
/// expected percentage (1..100) of false positive results for MayExists()
property FalsePositivePercent: double read fFalsePositivePercent;
/// number of bits stored in the internal bits array
property Bits: cardinal read fBits;
/// how many hash functions would be applied for each Insert()
property HashFunctions: cardinal read fHashFunctions;
/// how many times the Insert() method has been called
property Inserted: cardinal read GetInserted;
end;
/// implements a thread-safe differential Bloom Filter storage
// - this inherited class is able to compute incremental serialization of
// its internal bits array, to reduce network use
// - an obfuscated revision counter is used to identify storage history
TSynBloomFilterDiff = class(TSynBloomFilter)
protected
fRevision: Int64;
fSnapShotAfterMinutes: cardinal;
fSnapshotAfterInsertCount: cardinal;
fSnapshotTimestamp: Int64;
fSnapshotInsertCount: cardinal;
fKnownRevision: Int64;
fKnownStore: RawByteString;
public
/// add an item in the internal bits array storage
// - this overloaded thread-safe method would compute fRevision
procedure Insert(aValue: pointer; aValueLen: integer); override;
/// clear the internal bits array storage
// - this overloaded thread-safe method would reset fRevision
procedure Reset; override;
/// store the internal bits array into an incremental binary buffer
// - here the difference from a previous SaveToDiff revision will be computed
// - if aKnownRevision is outdated (e.g. if equals 0), the whole bits array
// would be returned, and around 10 bits per item would be transmitted
// (for 1% false positive ratio)
// - incremental retrieval would then return around 10 bytes per newly added
// item since the last snapshot reference state (with 1% ratio, i.e. 7 hash
// functions)
function SaveToDiff(const aKnownRevision: Int64): RawByteString;
/// use the current internal bits array state as known revision
// - is done the first time SaveToDiff() is called, then after 1/32th of
// the filter size has been inserted (see SnapshotAfterInsertCount property),
// or after SnapShotAfterMinutes property timeout period
procedure DiffSnapshot;
/// retrieve the revision number from an incremental binary buffer
// - returns 0 if the supplied binary buffer does not match this bloom filter
function DiffKnownRevision(const aDiff: RawByteString): Int64;
/// read the internal bits array from an incremental binary buffer
// - as previously serialized by the SaveToDiff() method
// - may be used to transmit or store the state of a dataset
// - returns false if the supplied content is incorrect, e.g. if the known
// revision is deprecated
function LoadFromDiff(const aDiff: RawByteString): boolean;
/// the opaque revision number of this internal storage
// - is in fact the Unix timestamp shifted by 31 bits, and an incremental
// counter: this pattern will allow consistent IDs over several ServPanels
property Revision: Int64 read fRevision;
/// after how many Insert() the internal bits array storage should be
// promoted as known revision
// - equals Size div 32 by default
property SnapshotAfterInsertCount: cardinal read fSnapshotAfterInsertCount
write fSnapshotAfterInsertCount;
/// after how many time the internal bits array storage should be
// promoted as known revision
// - equals 30 minutes by default
property SnapShotAfterMinutes: cardinal read fSnapShotAfterMinutes
write fSnapShotAfterMinutes;
end;
/// RLE compression of a memory buffer containing mostly zeros
// - will store the number of consecutive zeros instead of plain zero bytes
// - used for spare bit sets, e.g. TSynBloomFilter serialization
// - will also compute the crc32c of the supplied content
// - use ZeroDecompress() to expand the compressed result
// - resulting content would be at most 14 bytes bigger than the input
// - you may use this function before SynLZ compression
procedure ZeroCompress(P: PAnsiChar; Len: integer; Dest: TFileBufferWriter);
/// RLE uncompression of a memory buffer containing mostly zeros
// - returns Dest='' if P^ is not a valid ZeroCompress() function result
// - used for spare bit sets, e.g. TSynBloomFilter serialization
// - will also check the crc32c of the supplied content
procedure ZeroDecompress(P: PByte; Len: integer; {$ifdef FPC}var{$else}out{$endif} Dest: RawByteString);
/// RLE compression of XORed memory buffers resulting in mostly zeros
// - will perform ZeroCompress(Dest^ := New^ xor Old^) without any temporary
// memory allocation
// - is used e.g. by TSynBloomFilterDiff.SaveToDiff() in incremental mode
// - will also compute the crc32c of the supplied content
procedure ZeroCompressXor(New,Old: PAnsiChar; Len: cardinal; Dest: TFileBufferWriter);
/// RLE uncompression and ORing of a memory buffer containing mostly zeros
// - will perform Dest^ := Dest^ or ZeroDecompress(P^) without any temporary
// memory allocation
// - is used e.g. by TSynBloomFilterDiff.LoadFromDiff() in incremental mode
// - returns false if P^ is not a valid ZeroCompress/ZeroCompressXor() result
// - will also check the crc32c of the supplied content
function ZeroDecompressOr(P,Dest: PAnsiChar; Len,DestLen: integer): boolean;
const
/// normal pattern search depth for DeltaCompress()
// - gives good results on most content
DELTA_LEVEL_FAST = 100;
/// brutal pattern search depth for DeltaCompress()
// - may become very slow, with minor benefit, on huge content
DELTA_LEVEL_BEST = 500;
/// 2MB as internal chunks/window default size for DeltaCompress()
// - will use up to 9 MB of RAM during DeltaCompress() - none in DeltaExtract()
DELTA_BUF_DEFAULT = 2 shl 20;
/// compute difference of two binary buffers
// - returns '=' for equal buffers, or an optimized binary delta
// - DeltaExtract() could be used later on to compute New from Old + Delta
function DeltaCompress(const New, Old: RawByteString;
Level: integer=DELTA_LEVEL_FAST; BufSize: integer=DELTA_BUF_DEFAULT): RawByteString; overload;
/// compute difference of two binary buffers
// - returns '=' for equal buffers, or an optimized binary delta
// - DeltaExtract() could be used later on to compute New from Old
function DeltaCompress(New, Old: PAnsiChar; NewSize, OldSize: integer;
Level: integer=DELTA_LEVEL_FAST; BufSize: integer=DELTA_BUF_DEFAULT): RawByteString; overload;
/// compute difference of two binary buffers
// - returns '=' for equal buffers, or an optimized binary delta
// - DeltaExtract() could be used later on to compute New from Old + Delta
// - caller should call Freemem(Delta) once finished with the output buffer
function DeltaCompress(New, Old: PAnsiChar; NewSize, OldSize: integer;
out Delta: PAnsiChar; Level: integer=DELTA_LEVEL_FAST; BufSize: integer=DELTA_BUF_DEFAULT): integer; overload;
type
/// result of function DeltaExtract()
TDeltaError = (
dsSuccess, dsCrcCopy, dsCrcComp, dsCrcBegin, dsCrcEnd, dsCrcExtract, dsFlag, dsLen);
/// returns how many bytes a DeltaCompress() result will expand to
function DeltaExtractSize(const Delta: RawByteString): integer; overload;
/// returns how many bytes a DeltaCompress() result will expand to
function DeltaExtractSize(Delta: PAnsiChar): integer; overload;
/// apply the delta binary as computed by DeltaCompress()
// - decompression don't use any RAM, will perform crc32c check, and is very fast
// - return dsSuccess if was uncompressed to aOutUpd as expected
function DeltaExtract(const Delta,Old: RawByteString; out New: RawByteString): TDeltaError; overload;
/// low-level apply the delta binary as computed by DeltaCompress()
// - New should already be allocated with DeltaExtractSize(Delta) bytes
// - as such, expect Delta, Old and New to be <> nil, and Delta <> '='
// - return dsSuccess if was uncompressed to aOutUpd as expected
function DeltaExtract(Delta,Old,New: PAnsiChar): TDeltaError; overload;
function ToText(err: TDeltaError): PShortString; overload;
{ ************ high-level storage classes ************************* }
type
/// implement a cache of some key/value pairs, e.g. to improve reading speed
// - used e.g. by TSQLDataBase for caching the SELECT statements results in an
// internal JSON format (which is faster than a query to the SQLite3 engine)
// - internally make use of an efficient hashing algorithm for fast response
// (i.e. TSynNameValue will use the TDynArrayHashed wrapper mechanism)
// - this class is thread-safe if you use properly the associated Safe lock
TSynCache = class(TSynPersistentLock)
protected
fFindLastKey: RawUTF8;
fNameValue: TSynNameValue;
fRamUsed: cardinal;
fMaxRamUsed: cardinal;
fTimeoutSeconds: cardinal;
fTimeoutTix: cardinal;
procedure ResetIfNeeded;
public
/// initialize the internal storage
// - aMaxCacheRamUsed can set the maximum RAM to be used for values, in bytes
// (default is 16 MB), after which the cache is flushed
// - by default, key search is done case-insensitively, but you can specify
// another option here
// - by default, there is no timeout period, but you may specify a number of
// seconds of inactivity (i.e. no Add call) after which the cache is flushed
constructor Create(aMaxCacheRamUsed: cardinal=16 shl 20;
aCaseSensitive: boolean=false; aTimeoutSeconds: cardinal=0); reintroduce;
/// find a Key in the cache entries
// - return '' if nothing found: you may call Add() just after to insert
// the expected value in the cache
// - return the associated Value otherwise, and the associated integer tag
// if aResultTag address is supplied
// - this method is not thread-safe, unless you call Safe.Lock before
// calling Find(), and Safe.Unlock after calling Add()
function Find(const aKey: RawUTF8; aResultTag: PPtrInt=nil): RawUTF8;
/// add a Key and its associated value (and tag) to the cache entries
// - you MUST always call Find() with the associated Key first
// - this method is not thread-safe, unless you call Safe.Lock before
// calling Find(), and Safe.Unlock after calling Add()
procedure Add(const aValue: RawUTF8; aTag: PtrInt);
/// add a Key/Value pair in the cache entries
// - returns true if aKey was not existing yet, and aValue has been stored
// - returns false if aKey did already exist in the internal cache, and
// its entry has been updated with the supplied aValue/aTag
// - this method is thread-safe, using the Safe locker of this instance
function AddOrUpdate(const aKey, aValue: RawUTF8; aTag: PtrInt): boolean;
/// called after a write access to the database to flush the cache
// - set Count to 0
// - release all cache memory
// - returns TRUE if was flushed, i.e. if there was something in cache
// - this method is thread-safe, using the Safe locker of this instance
function Reset: boolean;
/// number of entries in the cache
function Count: integer;
/// access to the internal locker, for thread-safe process
// - Find/Add methods calls should be protected as such:
// ! cache.Safe.Lock;
// ! try
// ! ... cache.Find/cache.Add ...
// ! finally
// ! cache.Safe.Unlock;
// ! end;
property Safe: PSynLocker read fSafe;
/// the current global size of Values in RAM cache, in bytes
property RamUsed: cardinal read fRamUsed;
/// the maximum RAM to be used for values, in bytes
// - the cache is flushed when ValueSize reaches this limit
// - default is 16 MB (16 shl 20)
property MaxRamUsed: cardinal read fMaxRamUsed;
/// after how many seconds betwen Add() calls the cache should be flushed
// - equals 0 by default, meaning no time out
property TimeoutSeconds: cardinal read fTimeoutSeconds;
end;
/// thread-safe FIFO (First-In-First-Out) in-order queue of records
// - uses internally a dynamic array storage, with a sliding algorithm
// (more efficient than the FPC or Delphi TQueue)
TSynQueue = class(TSynPersistentLock)
protected
fValues: TDynArray;
fValueVar: pointer;
fCount, fFirst, fLast: integer;
fWaitPopFlags: set of (wpfDestroying);
fWaitPopCounter: integer;
procedure InternalGrow;
function InternalDestroying(incPopCounter: integer): boolean;
function InternalWaitDone(endtix: Int64; const idle: TThreadMethod): boolean;
public
/// initialize the queue storage
// - aTypeInfo should be a dynamic array TypeInfo() RTTI pointer, which
// would store the values within this TSynQueue instance
constructor Create(aTypeInfo: pointer); reintroduce; virtual;
/// finalize the storage
// - would release all internal stored values, and call WaitPopFinalize
destructor Destroy; override;
/// store one item into the queue
// - this method is thread-safe, since it will lock the instance
procedure Push(const aValue);
/// extract one item from the queue, as FIFO (First-In-First-Out)
// - returns true if aValue has been filled with a pending item, which
// is removed from the queue (use Peek if you don't want to remove it)
// - returns false if the queue is empty
// - this method is thread-safe, since it will lock the instance
function Pop(out aValue): boolean;
/// extract one matching item from the queue, as FIFO (First-In-First-Out)
// - the current pending item is compared with aAnother value
function PopEquals(aAnother: pointer; aCompare: TDynArraySortCompare; out aValue): boolean;
/// lookup one item from the queue, as FIFO (First-In-First-Out)
// - returns true if aValue has been filled with a pending item, without
// removing it from the queue (as Pop method does)
// - returns false if the queue is empty
// - this method is thread-safe, since it will lock the instance
function Peek(out aValue): boolean;
/// waiting extract of one item from the queue, as FIFO (First-In-First-Out)
// - returns true if aValue has been filled with a pending item within the
// specified aTimeoutMS time
// - returns false if nothing was pushed into the queue in time, or if
// WaitPopFinalize has been called
// - aWhenIdle could be assigned e.g. to VCL/LCL Application.ProcessMessages
// - you can optionally compare the pending item before returning it (could
// be used e.g. when several threads are putting items into the queue)
// - this method is thread-safe, but will lock the instance only if needed
function WaitPop(aTimeoutMS: integer; const aWhenIdle: TThreadMethod; out aValue;
aCompared: pointer=nil; aCompare: TDynArraySortCompare=nil): boolean;
/// waiting lookup of one item from the queue, as FIFO (First-In-First-Out)
// - returns a pointer to a pending item within the specified aTimeoutMS
// time - the Safe.Lock is still there, so that caller could check its content,
// then call Pop() if it is the expected one, and eventually always call Safe.Unlock
// - returns nil if nothing was pushed into the queue in time
// - this method is thread-safe, but will lock the instance only if needed
function WaitPeekLocked(aTimeoutMS: integer; const aWhenIdle: TThreadMethod): pointer;
/// ensure any pending or future WaitPop() returns immediately as false
// - is always called by Destroy destructor
// - could be also called e.g. from an UI OnClose event to avoid any lock
// - this method is thread-safe, but will lock the instance only if needed
procedure WaitPopFinalize(aTimeoutMS: integer=100);
/// delete all items currently stored in this queue, and void its capacity
// - this method is thread-safe, since it will lock the instance
procedure Clear;
/// initialize a dynamic array with the stored queue items
// - aDynArrayValues should be a variable defined as aTypeInfo from Create
// - you can retrieve an optional TDynArray wrapper, e.g. for binary or JSON
// persistence
// - this method is thread-safe, and will make a copy of the queue data
procedure Save(out aDynArrayValues; aDynArray: PDynArray=nil);
/// returns how many items are currently stored in this queue
// - this method is thread-safe
function Count: Integer;
/// returns how much slots is currently reserved in memory
// - the queue has an optimized auto-sizing algorithm, you can use this
// method to return its current capacity
// - this method is thread-safe
function Capacity: integer;
/// returns true if there are some items currently pending in the queue
// - slightly faster than checking Count=0, and much faster than Pop or Peek
function Pending: boolean;
end;
/// maintain a thread-safe sorted list of TSynPersistentLock objects
// - will use fast O(log(n)) binary search for efficient search - it is
// a lighter alternative to TObjectListHashedAbstract/TObjectListPropertyHashed
// if hashing has a performance cost (e.g. if there are a few items, or
// deletion occurs regularly)
// - in practice, insertion becomes slower after around 100,000 items stored
// - expect to store only TSynPersistentLock inherited items, so that
// the process is explicitly thread-safe
// - inherited classes should override the Compare and NewItem abstract methods
TObjectListSorted = class(TSynPersistentLock)
protected
fCount: integer;
fObjArray: TSynPersistentLockDynArray;
function FastLocate(const Value; out Index: Integer): boolean;
procedure InsertNew(Item: TSynPersistentLock; Index: integer);
// override those methods for actual implementation
function Compare(Item: TSynPersistentLock; const Value): integer; virtual; abstract;
function NewItem(const Value): TSynPersistentLock; virtual; abstract;
public
/// finalize the list
destructor Destroy; override;
/// search a given TSynPersistentLock instance from a value
// - if returns not nil, caller should make result.Safe.UnLock once finished
// - will use the TObjectListSortedCompare function for the search
function FindLocked(const Value): pointer;
/// search or add a given TSynPersistentLock instance from a value
// - if returns not nil, caller should make result.Safe.UnLock once finished
// - added is TRUE if a new void item has just been created
// - will use the TObjectListSortedCompare function for the search
function FindOrAddLocked(const Value; out added: boolean): pointer;
/// remove a given TSynPersistentLock instance from a value
function Delete(const Value): boolean;
/// how many items are actually stored
property Count: Integer read fCount;
/// low-level access to the stored items
// - warning: use should be protected by Lock.Enter/Lock.Leave
property ObjArray: TSynPersistentLockDynArray read fObjArray;
end;
/// abstract high-level handling of (SynLZ-)compressed persisted storage
// - LoadFromReader/SaveToWriter abstract methods should be overriden
// with proper binary persistence implementation
TSynPersistentStore = class(TSynPersistentLock)
protected
fName: RawUTF8;
fReader: TFastReader;
fReaderTemp: PRawByteString;
fLoadFromLastUncompressed, fSaveToLastUncompressed: integer;
fLoadFromLastAlgo: TAlgoCompress;
/// low-level virtual methods implementing the persistence
procedure LoadFromReader; virtual;
procedure SaveToWriter(aWriter: TFileBufferWriter); virtual;
public
/// initialize a void storage with the supplied name
constructor Create(const aName: RawUTF8); reintroduce; overload; virtual;
/// initialize a storage from a SaveTo persisted buffer
// - raise a EFastReader exception on decoding error
constructor CreateFrom(const aBuffer: RawByteString;
aLoad: TAlgoCompressLoad = aclNormal);
/// initialize a storage from a SaveTo persisted buffer
// - raise a EFastReader exception on decoding error
constructor CreateFromBuffer(aBuffer: pointer; aBufferLen: integer;
aLoad: TAlgoCompressLoad = aclNormal);
/// initialize a storage from a SaveTo persisted buffer
// - raise a EFastReader exception on decoding error
constructor CreateFromFile(const aFileName: TFileName;
aLoad: TAlgoCompressLoad = aclNormal);
/// fill the storage from a SaveTo persisted buffer
// - actually call the LoadFromReader() virtual method for persistence
// - raise a EFastReader exception on decoding error
procedure LoadFrom(const aBuffer: RawByteString;
aLoad: TAlgoCompressLoad = aclNormal); overload;
/// initialize the storage from a SaveTo persisted buffer
// - actually call the LoadFromReader() virtual method for persistence
// - raise a EFastReader exception on decoding error
procedure LoadFrom(aBuffer: pointer; aBufferLen: integer;
aLoad: TAlgoCompressLoad = aclNormal); overload; virtual;
/// initialize the storage from a SaveToFile content
// - actually call the LoadFromReader() virtual method for persistence
// - returns false if the file is not found, true if the file was loaded
// without any problem, or raise a EFastReader exception on decoding error
function LoadFromFile(const aFileName: TFileName;
aLoad: TAlgoCompressLoad = aclNormal): boolean;
/// persist the content as a SynLZ-compressed binary blob
// - to be retrieved later on via LoadFrom method
// - actually call the SaveToWriter() protected virtual method for persistence
// - you can specify ForcedAlgo if you want to override the default AlgoSynLZ
// - BufferOffset could be set to reserve some bytes before the compressed buffer
procedure SaveTo(out aBuffer: RawByteString; nocompression: boolean=false;
BufLen: integer=65536; ForcedAlgo: TAlgoCompress=nil; BufferOffset: integer=0); overload; virtual;
/// persist the content as a SynLZ-compressed binary blob
// - just an overloaded wrapper
function SaveTo(nocompression: boolean=false; BufLen: integer=65536;
ForcedAlgo: TAlgoCompress=nil; BufferOffset: integer=0): RawByteString; overload;
{$ifdef HASINLINE}inline;{$endif}
/// persist the content as a SynLZ-compressed binary file
// - to be retrieved later on via LoadFromFile method
// - returns the number of bytes of the resulting file
// - actually call the SaveTo method for persistence
function SaveToFile(const aFileName: TFileName; nocompression: boolean=false;
BufLen: integer=65536; ForcedAlgo: TAlgoCompress=nil): PtrUInt;
/// one optional text associated with this storage
// - you can define this field as published to serialize its value in log/JSON
property Name: RawUTF8 read fName;
/// after a LoadFrom(), contains the uncompressed data size read
property LoadFromLastUncompressed: integer read fLoadFromLastUncompressed;
/// after a SaveTo(), contains the uncompressed data size written
property SaveToLastUncompressed: integer read fSaveToLastUncompressed;
end;
/// implement binary persistence and JSON serialization (not deserialization)
TSynPersistentStoreJson = class(TSynPersistentStore)
protected
// append "name" -> inherited should add properties to the JSON object
procedure AddJSON(W: TTextWriter); virtual;
public
/// serialize this instance as a JSON object
function SaveToJSON(reformat: TTextWriterJSONFormat = jsonCompact): RawUTF8;
end;
type
/// item as stored in a TRawByteStringGroup instance
TRawByteStringGroupValue = record
Position: integer;
Value: RawByteString;
end;
PRawByteStringGroupValue = ^TRawByteStringGroupValue;
/// items as stored in a TRawByteStringGroup instance
TRawByteStringGroupValueDynArray = array of TRawByteStringGroupValue;
/// store several RawByteString content with optional concatenation
{$ifdef USERECORDWITHMETHODS}TRawByteStringGroup = record
{$else}TRawByteStringGroup = object{$endif}
public
/// actual list storing the data
Values: TRawByteStringGroupValueDynArray;
/// how many items are currently stored in Values[]
Count: integer;
/// the current size of data stored in Values[]
Position: integer;
/// naive but efficient cache for Find()
LastFind: integer;
/// add a new item to Values[]
procedure Add(const aItem: RawByteString); overload;
/// add a new item to Values[]
procedure Add(aItem: pointer; aItemLen: integer); overload;
{$ifndef DELPHI5OROLDER}
/// add another TRawByteStringGroup to Values[]
procedure Add(const aAnother: TRawByteStringGroup); overload;
/// low-level method to abort the latest Add() call
// - warning: will work only once, if an Add() has actually been just called:
// otherwise, the behavior is unexpected, and may wrongly truncate data
procedure RemoveLastAdd;
/// compare two TRawByteStringGroup instance stored text
function Equals(const aAnother: TRawByteStringGroup): boolean;
{$endif DELPHI5OROLDER}
/// clear any stored information
procedure Clear;
/// append stored information into another RawByteString, and clear content
procedure AppendTextAndClear(var aDest: RawByteString);
// compact the Values[] array into a single item
// - is also used by AsText to compute a single RawByteString
procedure Compact;
/// return all content as a single RawByteString
// - will also compact the Values[] array into a single item (which is returned)
function AsText: RawByteString;
/// return all content as a single TByteDynArray
function AsBytes: TByteDynArray;
/// save all content into a TTextWriter instance
procedure Write(W: TTextWriter; Escape: TTextWriterKind=twJSONEscape); overload;
/// save all content into a TFileBufferWriter instance
procedure WriteBinary(W: TFileBufferWriter); overload;
/// save all content as a string into a TFileBufferWriter instance
// - storing the length as WriteVarUInt32() prefix
procedure WriteString(W: TFileBufferWriter);
/// add another TRawByteStringGroup previously serialized via WriteString()
procedure AddFromReader(var aReader: TFastReader);
/// returns a pointer to Values[] containing a given position
// - returns nil if not found
function Find(aPosition: integer): PRawByteStringGroupValue; overload;
/// returns a pointer to Values[].Value containing a given position and length
// - returns nil if not found
function Find(aPosition, aLength: integer): pointer; overload;
/// returns the text at a given position in Values[]
// - text should be in a single Values[] entry
procedure FindAsText(aPosition, aLength: integer; out aText: RawByteString); overload;
{$ifdef HASINLINE}inline;{$endif}
/// returns the text at a given position in Values[]
// - text should be in a single Values[] entry
function FindAsText(aPosition, aLength: integer): RawByteString; overload;
{$ifdef HASINLINE}inline;{$endif}
{$ifndef NOVARIANTS}
/// returns the text at a given position in Values[]
// - text should be in a single Values[] entry
// - explicitly returns null if the supplied text was not found
procedure FindAsVariant(aPosition, aLength: integer; out aDest: variant);
{$ifdef HASINLINE}inline;{$endif}
{$endif}
/// append the text at a given position in Values[], JSON escaped by default
// - text should be in a single Values[] entry
procedure FindWrite(aPosition, aLength: integer; W: TTextWriter;
Escape: TTextWriterKind=twJSONEscape; TrailingCharsToIgnore: integer=0);
{$ifdef HASINLINE}inline;{$endif}
/// append the blob at a given position in Values[], base-64 encoded
// - text should be in a single Values[] entry
procedure FindWriteBase64(aPosition, aLength: integer; W: TTextWriter;
withMagic: boolean); {$ifdef HASINLINE}inline;{$endif}
/// copy the text at a given position in Values[]
// - text should be in a single Values[] entry
procedure FindMove(aPosition, aLength: integer; aDest: pointer);
end;
/// pointer reference to a TRawByteStringGroup
PRawByteStringGroup = ^TRawByteStringGroup;
/// simple stack-allocated type for handling a non-void type names list
// - Delphi "object" is buggy on stack -> also defined as record with methods
{$ifdef USERECORDWITHMETHODS}TPropNameList = record
{$else}TPropNameList = object{$endif}
public
/// the actual names storage
Values: TRawUTF8DynArray;
/// how many items are currently in Values[]
Count: Integer;
/// initialize the list
// - set Count := 0
procedure Init; {$ifdef HASINLINE}inline;{$endif}
/// search for a Value within Values[0..Count-1] using IdemPropNameU()
function FindPropName(const Value: RawUTF8): Integer; {$ifdef HASINLINE}inline;{$endif}
/// if Value is in Values[0..Count-1] using IdemPropNameU() returns FALSE
// - otherwise, returns TRUE and add Value to Values[]
// - any Value='' is rejected
function AddPropName(const Value: RawUTF8): Boolean;
end;
{ ************ Security and Identifier classes ************************** }
type
/// 64-bit integer unique identifier, as computed by TSynUniqueIdentifierGenerator
// - they are increasing over time (so are much easier to store/shard/balance
// than UUID/GUID), and contain generation time and a 16-bit process ID
// - mapped by TSynUniqueIdentifierBits memory structure
// - may be used on client side for something similar to a MongoDB ObjectID,
// but compatible with TSQLRecord.ID: TID properties
TSynUniqueIdentifier = type Int64;
/// 16-bit unique process identifier, used to compute TSynUniqueIdentifier
// - each TSynUniqueIdentifierGenerator instance is expected to have
// its own unique process identifier, stored as a 16 bit integer 1..65535 value
TSynUniqueIdentifierProcess = type word;
{$A-}
/// map 64-bit integer unique identifier internal memory structure
// - as stored in TSynUniqueIdentifier = Int64 values, and computed by
// TSynUniqueIdentifierGenerator
// - bits 0..14 map a 15-bit increasing counter (collision-free)
// - bits 15..30 map a 16-bit process identifier
// - bits 31..63 map a 33-bit UTC time, encoded as seconds since Unix epoch
{$ifdef USERECORDWITHMETHODS}TSynUniqueIdentifierBits = record
{$else}TSynUniqueIdentifierBits = object{$endif}
public
/// the actual 64-bit storage value
// - in practice, only first 63 bits are used
Value: TSynUniqueIdentifier;
/// 15-bit counter (0..32767), starting with a random value
function Counter: word;
{$ifdef HASINLINE}inline;{$endif}
/// 16-bit unique process identifier
// - as specified to TSynUniqueIdentifierGenerator constructor
function ProcessID: TSynUniqueIdentifierProcess;
{$ifdef HASINLINE}inline;{$endif}
/// low-endian 4-byte value representing the seconds since the Unix epoch
// - time is expressed in Coordinated Universal Time (UTC), not local time
// - it uses in fact a 33-bit resolution, so is "Year 2038" bug-free
function CreateTimeUnix: TUnixTime;
{$ifdef HASINLINE}inline;{$endif}
/// fill this unique identifier structure from its TSynUniqueIdentifier value
// - is just a wrapper around PInt64(@self)^
procedure From(const AID: TSynUniqueIdentifier);
{$ifdef HASINLINE}inline;{$endif}
{$ifndef NOVARIANTS}
/// convert this identifier as an explicit TDocVariant JSON object
// - returns e.g.
// ! {"Created":"2016-04-19T15:27:58","Identifier":1,"Counter":1,
// ! "Value":3137644716930138113,"Hex":"2B8B273F00008001"}
function AsVariant: variant; {$ifdef HASINLINE}inline;{$endif}
/// convert this identifier to an explicit TDocVariant JSON object
// - returns e.g.
// ! {"Created":"2016-04-19T15:27:58","Identifier":1,"Counter":1,
// ! "Value":3137644716930138113,"Hex":"2B8B273F00008001"}
procedure ToVariant(out result: variant);
{$endif NOVARIANTS}
/// extract the UTC generation timestamp from the identifier as TDateTime
// - time is expressed in Coordinated Universal Time (UTC), not local time
function CreateDateTime: TDateTime;
{$ifdef HASINLINE}inline;{$endif}
/// extract the UTC generation timestamp from the identifier
// - time is expressed in Coordinated Universal Time (UTC), not local time
function CreateTimeLog: TTimeLog;
{$ifndef DELPHI5OROLDER}
/// compare two Identifiers
function Equal(const Another: TSynUniqueIdentifierBits): boolean;
{$ifdef HASINLINE}inline;{$endif}
{$endif DELPHI5OROLDER}
/// convert the identifier into a 16 chars hexadecimal string
function ToHexa: RawUTF8;
{$ifdef HASINLINE}inline;{$endif}
/// fill this unique identifier back from a 16 chars hexadecimal string
// - returns TRUE if the supplied hexadecimal is on the expected format
// - returns FALSE if the supplied text is invalid
function FromHexa(const hexa: RawUTF8): boolean;
/// fill this unique identifier with a fake value corresponding to a given
// timestamp
// - may be used e.g. to limit database queries on a particular time range
// - bits 0..30 would be 0, i.e. would set Counter = 0 and ProcessID = 0
procedure FromDateTime(const aDateTime: TDateTime);
/// fill this unique identifier with a fake value corresponding to a given
// timestamp
// - may be used e.g. to limit database queries on a particular time range
// - bits 0..30 would be 0, i.e. would set Counter = 0 and ProcessID = 0
procedure FromUnixTime(const aUnixTime: TUnixTime);
end;
{$A+}
/// points to a 64-bit integer identifier, as computed by TSynUniqueIdentifierGenerator
// - may be used to access the identifier internals, from its stored
// Int64 or TSynUniqueIdentifier value
PSynUniqueIdentifierBits = ^TSynUniqueIdentifierBits;
/// a 24 chars cyphered hexadecimal string, mapping a TSynUniqueIdentifier
// - has handled by TSynUniqueIdentifierGenerator.ToObfuscated/FromObfuscated
TSynUniqueIdentifierObfuscated = type RawUTF8;
/// thread-safe 64-bit integer unique identifier computation
// - may be used on client side for something similar to a MongoDB ObjectID,
// but compatible with TSQLRecord.ID: TID properties, since it will contain
// a 63-bit unsigned integer, following our ORM expectations
// - each identifier would contain a 16-bit process identifier, which is
// supplied by the application, and should be unique for this process at a
// given time
// - identifiers may be obfuscated as hexadecimal text, using both encryption
// and digital signature
TSynUniqueIdentifierGenerator = class(TSynPersistent)
protected
fUnixCreateTime: cardinal;
fLatestCounterOverflowUnixCreateTime: cardinal;
fIdentifier: TSynUniqueIdentifierProcess;
fIdentifierShifted: cardinal;
fLastCounter: cardinal;
fCrypto: array[0..7] of cardinal; // only fCrypto[6..7] are used in practice
fCryptoCRC: cardinal;
fSafe: TSynLocker;
function GetComputedCount: Int64;
public
/// initialize the generator for the given 16-bit process identifier
// - you can supply an obfuscation key, which should be shared for the
// whole system, so that you may use FromObfuscated/ToObfuscated methods
constructor Create(aIdentifier: TSynUniqueIdentifierProcess;
const aSharedObfuscationKey: RawUTF8=''); reintroduce;
/// finalize the generator structure
destructor Destroy; override;
/// return a new unique ID
// - this method is very optimized, and would use very little CPU
procedure ComputeNew(out result: TSynUniqueIdentifierBits); overload;
/// return a new unique ID, type-casted to an Int64
function ComputeNew: Int64; overload;
{$ifdef HASINLINE}inline;{$endif}
/// return an unique ID matching this generator pattern, at a given timestamp
// - may be used e.g. to limit database queries on a particular time range
procedure ComputeFromDateTime(const aDateTime: TDateTime; out result: TSynUniqueIdentifierBits);
/// return an unique ID matching this generator pattern, at a given timestamp
// - may be used e.g. to limit database queries on a particular time range
procedure ComputeFromUnixTime(const aUnixTime: TUnixTime; out result: TSynUniqueIdentifierBits);
/// map a TSynUniqueIdentifier as 24 chars cyphered hexadecimal text
// - cyphering includes simple key-based encryption and a CRC-32 digital signature
function ToObfuscated(const aIdentifier: TSynUniqueIdentifier): TSynUniqueIdentifierObfuscated;
/// retrieve a TSynUniqueIdentifier from 24 chars cyphered hexadecimal text
// - any file extension (e.g. '.jpeg') would be first deleted from the
// supplied obfuscated text
// - returns true if the supplied obfuscated text has the expected layout
// and a valid digital signature
// - returns false if the supplied obfuscated text is invalid
function FromObfuscated(const aObfuscated: TSynUniqueIdentifierObfuscated;
out aIdentifier: TSynUniqueIdentifier): boolean;
/// some 32-bit value, derivated from aSharedObfuscationKey as supplied
// to the class constructor
// - FromObfuscated and ToObfuscated methods will validate their hexadecimal
// content with this value to secure the associated CRC
// - may be used e.g. as system-depending salt
property CryptoCRC: cardinal read fCryptoCRC;
/// direct access to the associated mutex
property Safe: TSynLocker read fSafe;
published
/// the process identifier, associated with this generator
property Identifier: TSynUniqueIdentifierProcess read fIdentifier;
/// how many times ComputeNew method has been called
property ComputedCount: Int64 read GetComputedCount;
end;
type
/// abstract TSynPersistent class allowing safe storage of a password
// - the associated Password, e.g. for storage or transmission encryption
// will be persisted encrypted with a private key (which can be customized)
// - if default simple symmetric encryption is not enough, you may define
// a custom TSynPersistentWithPasswordUserCrypt callback, e.g. to
// SynCrypto's CryptDataForCurrentUser, for hardened password storage
// - a published property should be defined as such in inherited class:
// ! property PasswordPropertyName: RawUTF8 read fPassword write fPassword;
// - use the PassWordPlain property to access to its uncyphered value
TSynPersistentWithPassword = class(TSynPersistent)
protected
fPassWord: RawUTF8;
fKey: cardinal;
function GetKey: cardinal; {$ifdef HASINLINE}inline;{$endif}
function GetPassWordPlain: RawUTF8;
function GetPassWordPlainInternal(AppSecret: RawUTF8): RawUTF8;
procedure SetPassWordPlain(const Value: RawUTF8);
public
/// finalize the instance
destructor Destroy; override;
/// this class method could be used to compute the encrypted password,
// ready to be stored as JSON, according to a given private key
class function ComputePassword(const PlainPassword: RawUTF8;
CustomKey: cardinal=0): RawUTF8; overload;
/// this class method could be used to compute the encrypted password from
// a binary digest, ready to be stored as JSON, according to a given private key
// - just a wrapper around ComputePassword(BinToBase64URI())
class function ComputePassword(PlainPassword: pointer; PlainPasswordLen: integer;
CustomKey: cardinal=0): RawUTF8; overload;
/// this class method could be used to decrypt a password, stored as JSON,
// according to a given private key
// - may trigger a ESynException if the password was stored using a custom
// TSynPersistentWithPasswordUserCrypt callback, and the current user
// doesn't match the expected user stored in the field
class function ComputePlainPassword(const CypheredPassword: RawUTF8;
CustomKey: cardinal=0; const AppSecret: RawUTF8=''): RawUTF8;
/// low-level function used to identify if a given field is a Password
// - this method is used e.g. by TJSONSerializer.WriteObject to identify the
// password field, since its published name is set by the inherited classes
function GetPasswordFieldAddress: pointer; {$ifdef HASINLINE}inline;{$endif}
/// the private key used to cypher the password storage on serialization
// - application can override the default 0 value at runtime
property Key: cardinal read GetKey write fKey;
/// access to the associated unencrypted Password value
// - read may trigger a ESynException if the password was stored using a
// custom TSynPersistentWithPasswordUserCrypt callback, and the current user
// doesn't match the expected user stored in the field
property PasswordPlain: RawUTF8 read GetPassWordPlain write SetPassWordPlain;
end;
var
/// function prototype to customize TSynPersistent class password storage
// - is called when 'user1:base64pass1,user2:base64pass2' layout is found,
// and the current user logged on the system is user1 or user2
// - you should not call this low-level method, but assign e.g. from SynCrypto:
// $ TSynPersistentWithPasswordUserCrypt := CryptDataForCurrentUser;
TSynPersistentWithPasswordUserCrypt:
function(const Data,AppServer: RawByteString; Encrypt: boolean): RawByteString;
type
/// could be used to store a credential pair, as user name and password
// - password will be stored with TSynPersistentWithPassword encryption
TSynUserPassword = class(TSynPersistentWithPassword)
protected
fUserName: RawUTF8;
published
/// the associated user name
property UserName: RawUTF8 read FUserName write FUserName;
/// the associated encrypted password
// - use the PasswordPlain public property to access to the uncrypted password
property Password: RawUTF8 read FPassword write FPassword;
end;
/// handle safe storage of any connection properties
// - would be used by SynDB.pas to serialize TSQLDBConnectionProperties, or
// by mORMot.pas to serialize TSQLRest instances
// - the password will be stored as Base64, after a simple encryption as
// defined by TSynPersistentWithPassword
// - typical content could be:
// $ {
// $ "Kind": "TSQLDBSQLite3ConnectionProperties",
// $ "ServerName": "server",
// $ "DatabaseName": "",
// $ "User": "",
// $ "Password": "PtvlPA=="
// $ }
// - the "Kind" value will be used to let the corresponding TSQLRest or
// TSQLDBConnectionProperties NewInstance*() class methods create the
// actual instance, from its class name
TSynConnectionDefinition = class(TSynPersistentWithPassword)
protected
fKind: string;
fServerName: RawUTF8;
fDatabaseName: RawUTF8;
fUser: RawUTF8;
public
/// unserialize the database definition from JSON
// - as previously serialized with the SaveToJSON method
// - you can specify a custom Key used for password encryption, if the
// default value is not safe enough for you
// - this method won't use JSONToObject() so avoid any dependency to mORMot.pas
constructor CreateFromJSON(const JSON: RawUTF8; Key: cardinal=0); virtual;
/// serialize the database definition as JSON
// - this method won't use ObjectToJSON() so avoid any dependency to mORMot.pas
function SaveToJSON: RawUTF8; virtual;
published
/// the class name implementing the connection or TSQLRest instance
// - will be used to instantiate the expected class type
property Kind: string read fKind write fKind;
/// the associated server name (or file, for SQLite3) to be connected to
property ServerName: RawUTF8 read fServerName write fServerName;
/// the associated database name (if any), or additional options
property DatabaseName: RawUTF8 read fDatabaseName write fDatabaseName;
/// the associated User Identifier (if any)
property User: RawUTF8 read fUser write fUser;
/// the associated Password, e.g. for storage or transmission encryption
// - will be persisted encrypted with a private key
// - use the PassWordPlain property to access to its uncyphered value
property Password: RawUTF8 read fPassword write fPassword;
end;
type
/// class-reference type (metaclass) of an authentication class
TSynAuthenticationClass = class of TSynAuthenticationAbstract;
/// abstract authentication class, implementing safe token/challenge security
// and a list of active sessions
// - do not use this class, but plain TSynAuthentication
TSynAuthenticationAbstract = class
protected
fSessions: TIntegerDynArray;
fSessionsCount: Integer;
fSessionGenerator: integer;
fTokenSeed: Int64;
fSafe: TSynLocker;
function ComputeCredential(previous: boolean; const UserName,PassWord: RawUTF8): cardinal; virtual;
function GetPassword(const UserName: RawUTF8; out Password: RawUTF8): boolean; virtual; abstract;
function GetUsersCount: integer; virtual; abstract;
// check the given Hash challenge, against stored credentials
function CheckCredentials(const UserName: RaWUTF8; Hash: cardinal): boolean; virtual;
public
/// initialize the authentication scheme
constructor Create;
/// finalize the authentation
destructor Destroy; override;
/// register one credential for a given user
// - this abstract method will raise an exception: inherited classes should
// implement them as expected
procedure AuthenticateUser(const aName, aPassword: RawUTF8); virtual;
/// unregister one credential for a given user
// - this abstract method will raise an exception: inherited classes should
// implement them as expected
procedure DisauthenticateUser(const aName: RawUTF8); virtual;
/// create a new session
// - should return 0 on authentication error, or an integer session ID
// - this method will check the User name and password, and create a new session
function CreateSession(const User: RawUTF8; Hash: cardinal): integer; virtual;
/// check if the session exists in the internal list
function SessionExists(aID: integer): boolean;
/// delete a session
procedure RemoveSession(aID: integer);
/// returns the current identification token
// - to be sent to the client for its authentication challenge
function CurrentToken: Int64;
/// the number of current opened sessions
property SessionsCount: integer read fSessionsCount;
/// the number of registered users
property UsersCount: integer read GetUsersCount;
/// to be used to compute a Hash on the client sude, for a given Token
// - the token should have been retrieved from the server, and the client
// should compute and return this hash value, to perform the authentication
// challenge and create the session
// - internal algorithm is not cryptographic secure, but fast and safe
class function ComputeHash(Token: Int64; const UserName,PassWord: RawUTF8): cardinal; virtual;
end;
/// simple authentication class, implementing safe token/challenge security
// - maintain a list of user / name credential pairs, and a list of sessions
// - is not meant to handle authorization, just plain user access validation
// - used e.g. by TSQLDBConnection.RemoteProcessMessage (on server side) and
// TSQLDBProxyConnectionPropertiesAbstract (on client side) in SynDB.pas
TSynAuthentication = class(TSynAuthenticationAbstract)
protected
fCredentials: TSynNameValue; // store user/password pairs
function GetPassword(const UserName: RawUTF8; out Password: RawUTF8): boolean; override;
function GetUsersCount: integer; override;
public
/// initialize the authentication scheme
// - you can optionally register one user credential
constructor Create(const aUserName: RawUTF8=''; const aPassword: RawUTF8=''); reintroduce;
/// register one credential for a given user
procedure AuthenticateUser(const aName, aPassword: RawUTF8); override;
/// unregister one credential for a given user
procedure DisauthenticateUser(const aName: RawUTF8); override;
end;
type
/// optimized thread-safe storage of a list of IP v4 adresses
// - can be used e.g. as white-list or black-list of clients
// - will maintain internally a sorted list of 32-bit integers for fast lookup
// - with optional binary persistence
TIPBan = class(TSynPersistentStore)
protected
fIP4: TIntegerDynArray;
fCount: integer;
procedure LoadFromReader; override;
procedure SaveToWriter(aWriter: TFileBufferWriter); override;
public
/// register one IP to the list
function Add(const aIP: RawUTF8): boolean;
/// unregister one IP to the list
function Delete(const aIP: RawUTF8): boolean;
/// returns true if the IP is in the list
function Exists(const aIP: RawUTF8): boolean;
/// creates a TDynArray wrapper around the stored list of values
// - could be used e.g. for binary persistence
// - warning: caller should make Safe.Unlock when finished
function DynArrayLocked: TDynArray;
/// low-level access to the internal IPv4 list
// - 32-bit unsigned values are sorted, for fast O(log(n)) binary search
property IP4: TIntegerDynArray read fIP4;
published
/// how many IPs are currently banned
property Count: integer read fCount;
end;
{ ************ Expression Search Engine ************************** }
type
/// exception type used by TExprParser
EExprParser = class(ESynException);
/// identify an expression search engine node type, as used by TExprParser
TExprNodeType = (entWord, entNot, entOr, entAnd);
/// results returned by TExprParserAbstract.Parse method
TExprParserResult = (
eprSuccess, eprNoExpression,
eprMissingParenthesis, eprTooManyParenthesis, eprMissingFinalWord,
eprInvalidExpression, eprUnknownVariable, eprUnsupportedOperator,
eprInvalidConstantOrVariable);
TParserAbstract = class;
/// stores an expression search engine node, as used by TExprParser
TExprNode = class(TSynPersistent)
protected
fNext: TExprNode;
fNodeType: TExprNodeType;
function Append(node: TExprNode): boolean;
public
/// initialize a node for the search engine
constructor Create(nodeType: TExprNodeType); reintroduce;
/// recursively destroys the linked list of nodes (i.e. Next)
destructor Destroy; override;
/// browse all nodes until Next = nil
function Last: TExprNode;
/// points to the next node in the parsed tree
property Next: TExprNode read fNext;
/// what is actually stored in this node
property NodeType: TExprNodeType read fNodeType;
end;
/// abstract class to handle word search, as used by TExprParser
TExprNodeWordAbstract = class(TExprNode)
protected
fOwner: TParserAbstract;
fWord: RawUTF8;
/// should be set from actual data before TExprParser.Found is called
fFound: boolean;
function ParseWord: TExprParserResult; virtual; abstract;
public
/// you should override this virtual constructor for proper initialization
constructor Create(aOwner: TParserAbstract; const aWord: RawUTF8); reintroduce; virtual;
end;
/// class-reference type (metaclass) for a TExprNode
// - allow to customize the actual searching process for entWord
TExprNodeWordClass = class of TExprNodeWordAbstract;
/// parent class of TExprParserAbstract
TParserAbstract = class(TSynPers