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

2561 lines
95 KiB
ObjectPascal
Raw Permalink Blame History

/// SQLite3 embedded Database engine used as the mORMot SQL kernel
// - this unit is a part of the freeware Synopse mORMot framework,
// licensed under a MPL/GPL/LGPL tri-license; version 1.18
unit mORMotSQLite3;
{
This file is part of Synopse mORMot framework.
Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez
Synopse Informatique - https://synopse.info
*** BEGIN LICENSE BLOCK *****
Version: MPL 1.1/GPL 2.0/LGPL 2.1
The contents of this file are subject to the Mozilla Public License Version
1.1 (the "License"); you may not use this file except in compliance with
the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
for the specific language governing rights and limitations under the License.
The Original Code is Synopse mORMot framework.
The Initial Developer of the Original Code is Arnaud Bouchez.
Portions created by the Initial Developer are Copyright (C) 2022
the Initial Developer. All Rights Reserved.
Contributor(s):
- Ondrej
- Mario Moretti
Alternatively, the contents of this file may be used under the terms of
either the GNU General Public License Version 2 or later (the "GPL"), or
the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
in which case the provisions of the GPL or the LGPL are applicable instead
of those above. If you wish to allow use of your version of this file only
under the terms of either the GPL or the LGPL, and not to allow others to
use your version of this file under the terms of the MPL, indicate your
decision by deleting the provisions above and replace them with the notice
and other provisions required by the GPL or the LGPL. If you do not delete
the provisions above, a recipient may use your version of this file under
the terms of any one of the MPL, the GPL or the LGPL.
***** END LICENSE BLOCK *****
}
interface
{$I Synopse.inc} // define HASINLINE CPU32 CPU64 WITHLOG
uses
{$ifdef MSWINDOWS}
Windows,
{$else}
{$ifdef FPC}
SynFPCLinux,
BaseUnix,
{$endif}
{$ifdef KYLIX3}
Types,
LibC,
SynKylix,
{$endif}
{$endif}
SysUtils,
Classes,
{$ifndef LVCL}
SyncObjs, // for TCriticalSection inlining
Contnrs,
{$endif}
SynZip,
SynCommons,
SynLog,
SynSQLite3,
SynTable,
mORMot;
{.$define WITHUNSAFEBACKUP}
{ define this if you really need the old blocking TSQLRestServerDB backup methods
- those methods are deprecated - you should use DB.BackupBackground() instead }
{ ****************** SQLite3 database used as kernel of our mORMot framework }
type
/// Execute a SQL statement in the local SQLite3 database engine, and get
// result in memory
// - all DATA (even the BLOB fields) is converted into UTF-8 TEXT
// - uses a TSQLTableJSON internaly: faster than sqlite3_get_table()
// (less memory allocation/fragmentation) and allows efficient caching
TSQLTableDB = class(TSQLTableJSON)
private
public
/// Execute a SQL statement, and init TSQLTable fields
// - FieldCount=0 if no result is returned
// - the BLOB data is converted into TEXT: you have to retrieve it with
// a special request explicitely (note that JSON format returns BLOB data)
// - uses a TSQLTableJSON internaly: all currency is transformed to its floating
// point TEXT representation, and allows efficient caching
// - if the SQL statement is in the DB cache, it's retrieved from its cached
// value: our JSON parsing is a lot faster than SQLite3 engine itself,
// and uses less memory
// - will raise an ESQLException on any error
constructor Create(aDB: TSQLDatabase; const Tables: array of TSQLRecordClass;
const aSQL: RawUTF8; Expand: boolean); reintroduce;
end;
/// class-reference type (metaclass) of a REST server using SQLite3 as main engine
TSQLRestServerDBClass = class of TSQLRestServerDB;
TSQLVirtualTableModuleServerDB = class;
/// REST server with direct access to a SQLite3 database
// - caching is handled at TSQLDatabase level
// - SQL statements for record retrieval from ID are prepared for speed
TSQLRestServerDB = class(TSQLRestServer)
private
/// access to the associated SQLite3 database engine
fDB: TSQLDataBase;
/// initialized by Create(aModel,aDBFileName)
fOwnedDB: TSQLDataBase;
/// prepared statements with parameters for faster SQLite3 execution
// - used for SQL code with :(%): internal parameters
fStatementCache: TSQLStatementCached;
/// used during GetAndPrepareStatement() execution (run in global lock)
fStatement: PSQLRequest;
fStaticStatement: TSQLRequest;
fStatementTimer: PPrecisionTimer;
fStatementMonitor: TSynMonitor;
fStaticStatementTimer: TPrecisionTimer;
fStatementSQL: RawUTF8;
fStatementGenericSQL: RawUTF8;
fStatementMaxParam: integer;
fStatementLastException: RawUTF8;
fStatementTruncateSQLLogLen: integer;
fStatementPreparedSelectQueryPlan: boolean;
/// check if a VACUUM statement is possible
// - VACUUM in fact DISCONNECT all virtual modules (sounds like a SQLite3
// design problem), so calling it during process could break the engine
// - if you can safely run VACUUM, returns TRUE and release all active
// SQL statements (otherwise VACUUM will fail)
// - if there are some static virtual tables, returns FALSE and do nothing:
// in this case, VACUUM will be a no-op
function PrepareVacuum(const aSQL: RawUTF8): boolean;
protected
fBatchMethod: TSQLURIMethod;
fBatchOptions: TSQLRestBatchOptions;
fBatchTableIndex: integer;
fBatchID: TIDDynArray;
fBatchIDCount: integer;
fBatchIDMax: TID;
fBatchValues: TRawUTF8DynArray;
fBatchValuesCount: integer;
constructor RegisteredClassCreateFrom(aModel: TSQLModel;
aServerHandleAuthentication: boolean; aDefinition: TSynConnectionDefinition); override;
/// retrieve a TSQLRequest instance in fStatement
// - will set @fStaticStatement if no :(%): internal parameters appear:
// in this case, the TSQLRequest.Close method must be called
// - will set a @fStatementCache[].Statement, after having bounded the
// :(%): parameter values; in this case, TSQLRequest.Close must not be called
// - expect sftBlob, sftBlobDynArray and sftBlobRecord properties
// to be encoded as ':("\uFFF0base64encodedbinary"):'
procedure GetAndPrepareStatement(const SQL: RawUTF8; ForceCacheStatement: boolean);
/// free a static prepared statement on success or from except on E: Exception block
procedure GetAndPrepareStatementRelease(E: Exception=nil; const Msg: ShortString='';
ForceBindReset: boolean=false);
/// create or retrieve from the cache a TSQLRequest instance in fStatement
// - called e.g. by GetAndPrepareStatement()
procedure PrepareStatement(Cached: boolean);
/// reset the cache if necessary
procedure SetNoAJAXJSON(const Value: boolean); override;
{$ifdef WITHLOG}
/// overriden method which will also set the DB.LogClass
procedure SetLogClass(aClass: TSynLogClass); override;
{$endif}
/// overridden methods for direct sqlite3 database engine call:
function MainEngineList(const SQL: RawUTF8; ForceAJAX: Boolean; ReturnedRowCount: PPtrInt): RawUTF8; override;
function MainEngineRetrieve(TableModelIndex: integer; ID: TID): RawUTF8; override;
function MainEngineAdd(TableModelIndex: integer; const SentData: RawUTF8): TID; override;
function MainEngineUpdate(TableModelIndex: integer; ID: TID; const SentData: RawUTF8): boolean; override;
function MainEngineDelete(TableModelIndex: integer; ID: TID): boolean; override;
function MainEngineDeleteWhere(TableModelIndex: Integer; const SQLWhere: RawUTF8;
const IDs: TIDDynArray): boolean; override;
function MainEngineRetrieveBlob(TableModelIndex: integer; aID: TID;
BlobField: PPropInfo; out BlobData: TSQLRawBlob): boolean; override;
function MainEngineUpdateBlob(TableModelIndex: integer; aID: TID;
BlobField: PPropInfo; const BlobData: TSQLRawBlob): boolean; override;
function MainEngineUpdateField(TableModelIndex: integer;
const SetFieldName, SetValue, WhereFieldName, WhereValue: RawUTF8): boolean; override;
function MainEngineUpdateFieldIncrement(TableModelIndex: integer; ID: TID;
const FieldName: RawUTF8; Increment: Int64): boolean; override;
function EngineExecute(const aSQL: RawUTF8): boolean; override;
procedure InternalStat(Ctxt: TSQLRestServerURIContext; W: TTextWriter); override;
procedure InternalInfo(var info: TDocVariantData); override;
/// execute one SQL statement
// - intercept any DB exception and return false on error, true on success
// - optional LastInsertedID can be set (if ValueInt/ValueUTF8 are nil) to
// retrieve the proper ID when aSQL is an INSERT statement (thread safe)
// - optional LastChangeCount can be set (if ValueInt/ValueUTF8 are nil) to
// retrieve the modified row count when aSQL is an UPDATE statement (thread safe)
function InternalExecute(const aSQL: RawUTF8; ForceCacheStatement: boolean;
ValueInt: PInt64=nil; ValueUTF8: PRawUTF8=nil; ValueInts: PInt64DynArray=nil;
LastInsertedID: PInt64=nil; LastChangeCount: PInteger=nil): boolean;
// overridden method returning TRUE for next calls to EngineAdd
// will properly handle operations until InternalBatchStop is called
function InternalBatchStart(Method: TSQLURIMethod;
BatchOptions: TSQLRestBatchOptions): boolean; override;
// internal method called by TSQLRestServer.RunBatch() to process fast
// multi-INSERT statements to the SQLite3 engine
procedure InternalBatchStop; override;
public
/// begin a transaction (implements REST BEGIN Member)
// - to be used to speed up some SQL statements like Insert/Update/Delete
// - must be ended with Commit on success
// - must be aborted with Rollback if any SQL statement failed
// - return true if no transaction is active, false otherwise
function TransactionBegin(aTable: TSQLRecordClass; SessionID: cardinal=1): boolean; override;
/// end a transaction (implements REST END Member)
// - write all pending SQL statements to the disk
procedure Commit(SessionID: cardinal=1; RaiseException: boolean=false); override;
/// abort a transaction (implements REST ABORT Member)
// - restore the previous state of the database, before the call to TransactionBegin
procedure RollBack(SessionID: cardinal=1); override;
/// overridden method for direct SQLite3 database engine call
// - it will update all BLOB fields at once, in one SQL statement
function UpdateBlobFields(Value: TSQLRecord): boolean; override;
/// overridden method for direct SQLite3 database engine call
// - it will retrieve all BLOB fields at once, in one SQL statement
function RetrieveBlobFields(Value: TSQLRecord): boolean; override;
{$ifndef KYLIX3}
/// backup of the opened Database into an external stream (e.g. a file,
// compressed or not)
// - DEPRECATED: use DB.BackupBackground() instead
// - this method doesn't use the SQLite Online Backup API, but low-level
// database file copy which may lock the database process if the data
// is consistent - consider using DB.BackupBackground() method instead
// - database is closed, VACCUUMed, copied, then reopened
function Backup(Dest: TStream): boolean; deprecated;
/// backup of the opened Database into a .gz compressed file
// - DEPRECATED: use DB.BackupBackground() instead
// - this method doesn't use the SQLite Online Backup API, but low-level
// database file copy which may lock the database process if the data
// is consistent - consider using DB.BackupBackground() method instead
// - database is closed, VACCUUMed, compressed into .gz file, then reopened
// - default compression level is 2, which is very fast, and good enough for
// a database file content: you may change it into the default 6 level
function BackupGZ(const DestFileName: TFileName;
CompressionLevel: integer=2): boolean; deprecated;
{$endif}
/// restore a database content on the fly
// - database is closed, source DB file is replaced by the supplied content,
// then reopened
// - there are cases where this method will fail and return FALSE: consider
// shuting down the server, replace the file, then relaunch the server instead
function Restore(const ContentToRestore: RawByteString): boolean;
/// restore a database content on the fly, from a .gz compressed file
// - database is closed, source DB file is replaced by the supplied content,
// then reopened
// - there are cases where this method will fail and return FALSE: consider
// shuting down the server, replace the file, then relaunch the server instead
function RestoreGZ(const BackupFileName: TFileName): boolean;
/// used e.g. by IAdministratedDaemon to implement "pseudo-SQL" commands
procedure AdministrationExecute(const DatabaseName,SQL: RawUTF8;
var result: TServiceCustomAnswer); override;
/// retrieves the per-statement detailed timing, as a TDocVariantData
procedure ComputeDBStats(out result: variant); overload;
/// retrieves the per-statement detailed timing, as a TDocVariantData
function ComputeDBStats: variant; overload;
/// initialize the associated DB connection
// - called by Create and on Backup/Restore just after DB.DBOpen
// - will register all *_in() functions for available TSQLRecordRTree
// - will register all modules for available TSQLRecordVirtualTable*ID
// with already registered modules via RegisterVirtualTableModule()
// - you can override this method to call e.g. DB.RegisterSQLFunction()
procedure InitializeEngine; virtual;
/// call this method when the internal DB content is known to be invalid
// - by default, all REST/CRUD requests and direct SQL statements are
// scanned and identified as potentially able to change the internal SQL/JSON
// cache used at SQLite3 database level; but some virtual tables (e.g.
// TSQLRestStorageExternal classes defined in SQLite3DB) could flush
// the database content without proper notification
// - this overridden implementation will call TSQLDataBase.CacheFlush method
procedure FlushInternalDBCache; override;
/// call this method to flush the internal SQL prepared statements cache
// - you should not have to flush the cache, only e.g. before a DROP TABLE
// - in all cases, running this method would never harm, nor be slow
procedure FlushStatementCache;
/// execute one SQL statement, and apply an Event to every record
// - lock the database during the run
// - call a fast "stored procedure"-like method for each row of the request;
// this method must use low-level DB access in any attempt to modify the
// database (e.g. a prepared TSQLRequest with Reset+Bind+Step), and not
// the TSQLRestServerDB.Engine*() methods which include a Lock(): this Lock()
// is performed by the main loop in EngineExecute() and any attempt to
// such high-level call will fail into an endless loop
// - caller may use a transaction in order to speed up StoredProc() writing
// - intercept any DB exception and return false on error, true on success
function StoredProcExecute(const aSQL: RawUTF8; StoredProc: TOnSQLStoredProc): boolean;
public
/// initialize a REST server with a SQLite3 database
// - any needed TSQLVirtualTable class should have been already registered
// via the RegisterVirtualTableModule() method
constructor Create(aModel: TSQLModel; aDB: TSQLDataBase;
aHandleUserAuthentication: boolean=false; aOwnDB: boolean=false); reintroduce; overload; virtual;
/// initialize a REST server with a database, by specifying its filename
// - TSQLRestServerDB will initialize a owned TSQLDataBase, and free it on Destroy
// - if specified, the password will be used to cypher this file on disk
// (the main SQLite3 database file is encrypted, not the wal file during run)
// - it will then call the other overloaded constructor to initialize the server
constructor Create(aModel: TSQLModel; const aDBFileName: TFileName;
aHandleUserAuthentication: boolean=false; const aPassword: RawUTF8='';
aDefaultCacheSize: integer=10000; aDefaultPageSize: integer=4096); reintroduce; overload;
/// initialize a REST server with a database, and a temporary Database Model
// - a Model will be created with supplied tables, and owned by the server
// - if you instantiate a TSQLRestServerFullMemory or TSQLRestServerDB
// with this constructor, an in-memory engine will be created, with
// enough abilities to run regression tests, for instance
constructor CreateWithOwnModel(const aTables: array of TSQLRecordClass;
const aDBFileName: TFileName; aHandleUserAuthentication: boolean=false;
const aRoot: RawUTF8='root'; const aPassword: RawUTF8='';
aDefaultCacheSize: integer=10000; aDefaultPageSize: integer=4096); overload;
/// initialize a REST server with an in-memory SQLite3 database
// - could be used for test purposes
constructor Create(aModel: TSQLModel; aHandleUserAuthentication: boolean=false); overload; override;
/// initialize a REST server with an in-memory SQLite3 database and a
// temporary Database Model
// - could be used for test purposes
constructor CreateWithOwnModel(const aTables: array of TSQLRecordClass;
aHandleUserAuthentication: boolean=false); overload;
/// close database and free used memory
destructor Destroy; override;
/// save the TSQLRestServerDB properties into a persistent storage object
// - RegisteredClassCreateFrom() will expect Definition.DatabaseName to store
// the DBFileName, and optionally encrypt the file using Definition.Password
procedure DefinitionTo(Definition: TSynConnectionDefinition); override;
/// Missing tables are created if they don't exist yet for every TSQLRecord
// class of the Database Model
// - you must call explicitely this before having called StaticDataCreate()
// - all table description (even Unique feature) is retrieved from the Model
// - this method also create additional fields, if the TSQLRecord definition
// has been modified; only field adding is available, field renaming or
// field deleting are not allowed in the FrameWork (in such cases, you must
// create a new TSQLRecord type)
procedure CreateMissingTables(user_version: cardinal=0;
Options: TSQLInitializeTableOptions=[]); override;
/// search for the last inserted ID in a table
// - will execute not default select max(rowid) from Table, but faster
// $ select rowid from Table order by rowid desc limit 1
function TableMaxID(Table: TSQLRecordClass): TID; override;
/// after how many bytes a sllSQL statement log entry should be truncated
// - default is 0, meaning no truncation
// - typical value is 2048 (2KB), which will avoid any heap allocation
property StatementTruncateSQLLogLen: integer read fStatementTruncateSQLLogLen
write fStatementTruncateSQLLogLen;
/// executes (therefore log) the QUERY PLAN for each prepared statement
property StatementPreparedSelectQueryPlan: boolean
read fStatementPreparedSelectQueryPlan write fStatementPreparedSelectQueryPlan;
published
/// associated database
property DB: TSQLDataBase read fDB;
/// contains some textual information about the latest Exception raised
// during SQL statement execution
property StatementLastException: RawUTF8 read fStatementLastException;
end;
/// REST client with direct access to a SQLite3 database
// - a hidden TSQLRestServerDB server is created and called internaly
TSQLRestClientDB = class(TSQLRestClientURI)
private
// use internaly a TSQLRestServerDB to access data in the proper JSON format
fServer: TSQLRestServerDB;
fOwnedServer: TSQLRestServerDB;
fOwnedDB: TSQLDataBase;
fInternalHeader: RawUTF8;
function getDB: TSQLDataBase;
protected
/// method calling the RESTful server fServer
procedure InternalURI(var Call: TSQLRestURIParams); override;
/// overridden protected method do nothing (direct DB access has no connection)
function InternalCheckOpen: boolean; override;
/// overridden protected method do nothing (direct DB access has no connection)
procedure InternalClose; override;
public
/// initializes the class, and creates an internal TSQLRestServerDB to
// internaly answer to the REST queries
// - aServerClass could be TSQLRestServerDB by default
constructor Create(aClientModel, aServerModel: TSQLModel; aDB: TSQLDataBase;
aServerClass: TSQLRestServerDBClass;
aHandleUserAuthentication: boolean=false); reintroduce; overload;
/// same as above, from a SQLite3 filename specified
// - an internal TSQLDataBase will be created internaly and freed on Destroy
// - aServerClass could be TSQLRestServerDB by default
// - if specified, the password will be used to cypher this file on disk
// (the main SQLite3 database file is encrypted, not the wal file during run)
constructor Create(aClientModel, aServerModel: TSQLModel; const aDBFileName: TFileName;
aServerClass: TSQLRestServerDBClass; aHandleUserAuthentication: boolean=false;
const aPassword: RawUTF8=''; aDefaultCacheSize: integer=10000); reintroduce; overload;
/// initialize the class, for an existing TSQLRestServerDB
// - the client TSQLModel will be cloned from the server's one
// - the TSQLRestServerDB and TSQLDatabase instances won't be managed by the
// client, but will access directly to the server
constructor Create(aRunningServer: TSQLRestServerDB); reintroduce; overload;
/// release the server
destructor Destroy; override;
/// retrieve a list of members as a TSQLTable (implements REST GET Collection)
// - this overridden method call directly the database to get its result,
// without any URI() call, but with use of DB JSON cache if available
// - other TSQLRestClientDB methods use URI() function and JSON conversion
// of only one record properties values, which is very fast
function List(const Tables: array of TSQLRecordClass; const SQLSelect: RawUTF8='ID';
const SQLWhere: RawUTF8=''): TSQLTableJSON; override;
/// associated Server
property Server: TSQLRestServerDB read fServer;
/// associated database
property DB: TSQLDataBase read getDB;
end;
/// define a Virtual Table module for a stand-alone SQLite3 engine
// - it's not needed to free this instance: it will be destroyed by the SQLite3
// engine together with the DB connection
TSQLVirtualTableModuleSQLite3 = class(TSQLVirtualTableModule)
protected
fDB: TSQLDataBase;
/// used internaly to register the module to the SQLite3 engine
fModule: TSQLite3Module;
public
/// initialize the module for a given DB connection
// - internally set fModule and call sqlite3_create_module_v2(fModule)
// - will raise EBusinessLayerException if aDB is incorrect, or SetDB() has
// already been called for this module
// - will call sqlite3_check() to raise the corresponding ESQLite3Exception
// - in case of success (no exception), the SQLite3 engine will release the
// module by itself; but in case of error (an exception is raised), it is
// up to the caller to intercept it via a try..except and free the
// TSQLVirtualTableModuleSQLite3 instance
procedure Attach(aDB: TSQLDataBase);
/// retrieve the file name to be used for a specific Virtual Table
// - overridden method returning a file located in the DB file folder, and
// '' if the main DB was created as SQLITE_MEMORY_DATABASE_NAME (i.e.
// ':memory:' so that no file should be written)
// - of course, if a custom FilePath property value is specified, it will be
// used, even if the DB is created as SQLITE_MEMORY_DATABASE_NAME
function FileName(const aTableName: RawUTF8): TFileName; override;
/// the associated SQLite3 database connection
property DB: TSQLDataBase read fDB;
end;
/// define a Virtual Table module for a TSQLRestServerDB SQLite3 engine
TSQLVirtualTableModuleServerDB = class(TSQLVirtualTableModuleSQLite3)
public
/// register the Virtual Table to the database connection of a TSQLRestServerDB server
// - in case of an error, an excepton will be raised
constructor Create(aClass: TSQLVirtualTableClass; aServer: TSQLRestServer); override;
end;
/// REST storage sharded over several SQlite3 instances
// - numerotated '*0000.dbs' SQLite3 files would contain the sharded data
// - here *.dbs is used as extension, to avoid any confusion with regular
// SQLite3 database files (*.db or *.db3)
// - when the server is off (e.g. on periodic version upgrade), you may safely
// delete/archive some oldest *.dbs files, for easy and immediate purge of
// your database content: such process would be much faster and cleaner than
// regular "DELETE FROM TABLE WHERE ID < ?" + "VACUUM" commands
TSQLRestStorageShardDB = class(TSQLRestStorageShard)
protected
fShardRootFileName: TFileName;
fSynchronous: TSQLSynchronousMode;
fInitShardsIsLast: boolean;
fCacheSizePrevious, fCacheSizeLast: integer;
procedure InitShards; override;
function InitNewShard: TSQLRest; override;
function DBFileName(ShardIndex: Integer): TFileName; virtual;
public
/// initialize the table storage redirection for sharding over SQLite3 DB
// - if no aShardRootFileName is set, the executable folder and stored class
// table name would be used
// - typical use may be:
// ! Server.StaticDataAdd(TSQLRestStorageShardDB.Create(TSQLRecordSharded,Server,500000))
// - you may define some low-level tuning of SQLite3 process via aSynchronous
// / aCacheSizePrevious / aCacheSizeLast / aMaxShardCount parameters, if
// the default smOff / 1MB / 2MB / 100 values are not enough
constructor Create(aClass: TSQLRecordClass; aServer: TSQLRestServer;
aShardRange: TID; aOptions: TSQLRestStorageShardOptions=[];
const aShardRootFileName: TFileName=''; aMaxShardCount: integer=100;
aSynchronous: TSQLSynchronousMode=smOff;
aCacheSizePrevious: integer=250; aCacheSizeLast: integer=500); reintroduce; virtual;
published
/// associated file name for the SQLite3 database files
// - contains the folder, and root file name for the storage
// - each shard would end with its 4 digits index: actual file name would
// append '0000.dbs' to this ShardRootFileName
property ShardRootFileName: TFileName read fShardRootFileName;
end;
/// initialize a Virtual Table Module for a specified database
// - to be used for low-level access to a virtual module, e.g. with
// TSQLVirtualTableLog
// - when using our ORM, you should call TSQLModel.VirtualTableRegister()
// instead to associate a TSQLRecordVirtual class to a module
// - returns the created TSQLVirtualTableModule instance (which will be a
// TSQLVirtualTableModuleSQLite3 instance in fact)
// - will raise an exception of failure
function RegisterVirtualTableModule(aModule: TSQLVirtualTableClass;
aDatabase: TSQLDataBase): TSQLVirtualTableModule;
implementation
{$ifdef SQLVIRTUALLOGS}
uses
mORMotDB;
{$endif SQLVIRTUALLOGS}
{ TSQLTableDB }
constructor TSQLTableDB.Create(aDB: TSQLDataBase; const Tables: array of TSQLRecordClass;
const aSQL: RawUTF8; Expand: boolean);
var JSONCached: RawUTF8;
R: TSQLRequest;
n: PtrInt;
begin
if aDB=nil then
exit;
JSONCached := aDB.LockJSON(aSQL,@n);
if JSONCached='' then // not retrieved from cache -> call SQLite3 engine
try // faster than sqlite3_get_table(): memory is allocated as a whole
n := 0;
JSONCached := R.ExecuteJSON(aDB.DB,aSQL,Expand,@n); // Expand=true for AJAX
inherited CreateFromTables(Tables,aSQL,JSONCached);
Assert(n=fRowCount);
finally
aDB.UnLockJSON(JSONCached,n);
end
else begin
inherited CreateFromTables(Tables,aSQL,JSONCached);
Assert(n=fRowCount);
end;
end;
{ TSQLRestServerDB }
procedure TSQLRestServerDB.PrepareStatement(Cached: boolean);
var wasPrepared: boolean;
timer: PPPrecisionTimer;
begin
fStaticStatementTimer.Start;
if not Cached then begin
fStaticStatement.Prepare(DB.DB,fStatementGenericSQL);
fStatementGenericSQL := '';
fStatement := @fStaticStatement;
fStatementTimer := @fStaticStatementTimer;
fStatementMonitor := nil;
exit;
end;
if mlSQLite3 in StatLevels then
timer := @fStatementTimer else
timer := nil;
fStatement := fStatementCache.Prepare(fStatementGenericSQL,@wasPrepared,timer,@fStatementMonitor);
if wasPrepared then begin
InternalLog('prepared % % %', [fStaticStatementTimer.Stop,
DB.FileNameWithoutPath,fStatementGenericSQL],sllDB);
if fStatementPreparedSelectQueryPlan then
DB.ExecuteJSON('explain query plan '+
StringReplaceChars(fStatementGenericSQL,'?','1'), {expand=}true);
end;
if timer=nil then begin
fStaticStatementTimer.Start;
fStatementTimer := @fStaticStatementTimer;
fStatementMonitor := nil;
end;
end;
procedure TSQLRestServerDB.GetAndPrepareStatement(const SQL: RawUTF8;
ForceCacheStatement: boolean);
var i, sqlite3param: integer;
Types: TSQLParamTypeDynArray;
Nulls: TSQLFieldBits;
Values: TRawUTF8DynArray;
begin
// prepare statement
fStatementSQL := SQL;
fStatementGenericSQL := ExtractInlineParameters(SQL,Types,Values,fStatementMaxParam,Nulls);
PrepareStatement(ForceCacheStatement or (fStatementMaxParam<>0));
// bind parameters
if fStatementMaxParam=0 then
exit; // no valid :(...): inlined parameter found -> manual bind
sqlite3param := sqlite3.bind_parameter_count(fStatement^.Request);
if sqlite3param<>fStatementMaxParam then
raise EORMException.CreateUTF8(
'%.GetAndPrepareStatement(%) recognized % params, and % for SQLite3',
[self,fStatementGenericSQL,fStatementMaxParam,sqlite3param]);
for i := 0 to fStatementMaxParam-1 do
if i in Nulls then
fStatement^.BindNull(i+1) else
case Types[i] of
sptDateTime, // date/time are stored as ISO-8601 TEXT in SQLite3
sptText: fStatement^.Bind(i+1,Values[i]);
sptBlob: fStatement^.BindBlob(i+1,Values[i]);
sptInteger: fStatement^.Bind(i+1,GetInt64(pointer(Values[i])));
sptFloat: fStatement^.Bind(i+1,GetExtended(pointer(Values[i])));
end;
end;
procedure TSQLRestServerDB.GetAndPrepareStatementRelease(E: Exception;
const Msg: ShortString; ForceBindReset: boolean);
var
tmp: TSynTempBuffer;
P: PAnsiChar;
begin
try
if fStatementTimer<>nil then begin
if fStatementMonitor<>nil then
fStatementMonitor.ProcessEnd else
fStatementTimer^.Pause;
if E=nil then
if (fStatementTruncateSQLLogLen > 0) and
(length(fStatementSQL) > fStatementTruncateSQLLogLen) then begin
tmp.Init(pointer(fStatementSQL),fStatementTruncateSQLLogLen);
P := tmp.buf;
PCardinal(P+fStatementTruncateSQLLogLen-3)^ := ord('.')+ord('.')shl 8+ord('.')shl 16;
InternalLog('% % % len=%',[fStatementTimer^.LastTime,Msg,P,length(fStatementSQL)],sllSQL);
tmp.Done;
end else
InternalLog('% % %',[fStatementTimer^.LastTime,Msg,fStatementSQL],sllSQL) else
InternalLog('% for % // %',[E,fStatementSQL,fStatementGenericSQL],sllError);
fStatementTimer := nil;
end;
fStatementMonitor := nil;
finally
if fStatement<>nil then begin
if fStatement=@fStaticStatement then
fStaticStatement.Close else
if (fStatementMaxParam<>0) or ForceBindReset then
fStatement^.BindReset; // release bound RawUTF8 ASAP
fStatement := nil;
end;
fStatementSQL := '';
fStatementGenericSQL := '';
fStatementMaxParam := 0;
if E<>nil then
FormatUTF8('% %',[E,ObjectToJSONDebug(E)],fStatementLastException);
end;
end;
procedure TSQLRestServerDB.FlushStatementCache;
begin
DB.Lock;
try
fStatementCache.ReleaseAllDBStatements;
finally
DB.Unlock;
end;
end;
function TSQLRestServerDB.TableMaxID(Table: TSQLRecordClass): TID;
var SQL: RawUTF8;
begin
if StaticTable[Table]<>nil then
result := inherited TableMaxID(Table) else begin
SQL := 'select rowid from '+Table.SQLTableName+' order by rowid desc limit 1';
if not InternalExecute(SQL,true,PInt64(@result)) then
result := 0;
end;
end;
function TSQLRestServerDB.MainEngineAdd(TableModelIndex: integer;
const SentData: RawUTF8): TID;
var Props: TSQLRecordProperties;
SQL: RawUTF8;
Decoder: TJSONObjectDecoder;
begin
result := 0;
if TableModelIndex<0 then
exit;
Props := fModel.TableProps[TableModelIndex].Props;
SQL := Props.SQLTableName;
if fBatchMethod<>mNone then begin
result := 0; // indicates error
if SentData='' then
InternalLog('BATCH with MainEngineAdd(%,SentData="") -> '+
'DEFAULT VALUES not implemented',[SQL],sllError) else
if (fBatchMethod=mPOST) and (fBatchIDMax>=0) and
((fBatchTableIndex<0) or (fBatchTableIndex=TableModelIndex)) then begin
fBatchTableIndex := TableModelIndex;
if JSONGetID(pointer(SentData),result) then begin
if result>fBatchIDMax then
fBatchIDMax := result;
end else begin
if fBatchIDMax=0 then begin
fBatchIDMax := TableMaxID(Props.Table);
if fBatchIDMax<0 then
exit; // will force error for whole BATCH block
end;
inc(fBatchIDMax);
result := fBatchIDMax;
end;
AddID(fBatchID,fBatchIDCount,result);
AddRawUTF8(fBatchValues,fBatchValuesCount,SentData);
end;
exit;
end;
SQL := 'INSERT INTO '+SQL;
if trim(SentData)='' then
SQL := SQL+' DEFAULT VALUES;' else begin
JSONGetID(pointer(SentData),result);
Decoder.Decode(SentData,nil,pInlined,result,false);
if Props.RecordVersionField<>nil then
InternalRecordVersionHandle(
soInsert,TableModelIndex,decoder,Props.RecordVersionField);
SQL := SQL+Decoder.EncodeAsSQL(false)+';';
end;
if InternalExecute(SQL,true,nil,nil,nil,PInt64(@result)) then
InternalUpdateEvent(seAdd,TableModelIndex,result,SentData,nil);
end;
procedure InternalRTreeIn(Context: TSQLite3FunctionContext;
argc: integer; var argv: TSQLite3ValueArray); cdecl;
var aRTree: TSQLRecordRTreeClass;
BlobA, BlobB: pointer;
begin
if argc<>2 then begin
ErrorWrongNumberOfArgs(Context);
exit;
end;
aRTree := sqlite3.user_data(Context);
BlobA := sqlite3.value_blob(argv[0]);
BlobB := sqlite3.value_blob(argv[1]);
if (aRTree=nil) or (BlobA=nil) or (BlobB=nil) then
sqlite3.result_error(Context,'invalid call') else
sqlite3.result_int64(Context,byte(aRTree.ContainedIn(BlobA^,BlobB^)));
end;
constructor TSQLRestServerDB.Create(aModel: TSQLModel;
aHandleUserAuthentication: boolean);
begin
Create(aModel,SQLITE_MEMORY_DATABASE_NAME,aHandleUserAuthentication);
end;
constructor TSQLRestServerDB.Create(aModel: TSQLModel; aDB: TSQLDataBase;
aHandleUserAuthentication, aOwnDB: boolean);
begin
fStatementCache.Init(aDB.DB);
aDB.UseCache := true; // we better use caching in this JSON oriented use
fDB := aDB;
if aOwnDB then
fOwnedDB := fDB;
if fDB.InternalState=nil then begin // should be done once
InternalState := 1;
fDB.InternalState := @InternalState; // to update TSQLRestServerDB.InternalState
end;
inherited Create(aModel,aHandleUserAuthentication);
InitializeEngine;
end;
{$ifdef WITHLOG}
procedure TSQLRestServerDB.SetLogClass(aClass: TSynLogClass);
begin
inherited;
if DB<>nil then
DB.Log := aClass; // ensure low-level SQLite3 engine will share the same log
end;
{$endif}
procedure TSQLRestServerDB.InitializeEngine;
var i: integer;
module: TSQLVirtualTableClass;
registered: array of TSQLVirtualTableClass;
begin
for i := 0 to high(Model.TableProps) do
case Model.TableProps[i].Kind of
rRTree, rRTreeInteger: // register all *_in() SQL functions
sqlite3_check(DB.DB,sqlite3.create_function_v2(DB.DB,
pointer(TSQLRecordRTreeClass(Model.Tables[i]).RTreeSQLFunctionName),
2,SQLITE_ANY,Model.Tables[i],InternalRTreeIn,nil,nil,nil));
rCustomForcedID, rCustomAutoID: begin
module := Model.VirtualTableModule(Model.Tables[i]);
if (module<>nil) and (PtrArrayFind(registered,module)<0) then begin
TSQLVirtualTableModuleServerDB.Create(module,self);
PtrArrayAdd(registered,module); // register it once for this DB
end;
end;
end;
end;
constructor TSQLRestServerDB.Create(aModel: TSQLModel; const aDBFileName: TFileName;
aHandleUserAuthentication: boolean; const aPassword: RawUTF8;
aDefaultCacheSize, aDefaultPageSize: integer);
begin
fOwnedDB := TSQLDataBase.Create(aDBFileName,aPassword,0,aDefaultCacheSize,aDefaultPageSize);
// fOwnedDB.Free done in Destroy
Create(aModel,fOwnedDB,aHandleUserAuthentication);
end;
constructor TSQLRestServerDB.CreateWithOwnModel(const aTables: array of TSQLRecordClass;
const aDBFileName: TFileName; aHandleUserAuthentication: boolean;
const aRoot, aPassword: RawUTF8; aDefaultCacheSize, aDefaultPageSize: integer);
begin
Create(TSQLModel.Create(aTables,aRoot),aDBFileName,aHandleUserAuthentication,
aPassword,aDefaultCacheSize,aDefaultPageSize);
fModel.Owner := self;
end;
constructor TSQLRestServerDB.CreateWithOwnModel(const aTables: array of TSQLRecordClass;
aHandleUserAuthentication: boolean);
begin
Create(TSQLModel.Create(aTables),aHandleUserAuthentication);
fModel.Owner := self;
end;
procedure TSQLRestServerDB.CreateMissingTables(user_version: cardinal;
Options: TSQLInitializeTableOptions);
var t,f,nt,nf: integer;
TableNamesAtCreation, aFields: TRawUTF8DynArray;
TableJustCreated: TSQLFieldTables;
aSQL: RawUTF8;
begin
if DB.TransactionActive then
raise EBusinessLayerException.Create('CreateMissingTables in transaction');
fDB.GetTableNames(TableNamesAtCreation);
nt := length(TableNamesAtCreation);
QuickSortRawUTF8(TableNamesAtCreation,nt,nil,@StrIComp);
{$ifdef WITHLOG}
fLogFamily.SynLog.Log(sllDB,'CreateMissingTables on %',[fDB],self);
fLogFamily.SynLog.Log(sllDB,'GetTables',TypeInfo(TRawUTF8DynArray),TableNamesAtCreation,self);
{$endif}
FillcharFast(TableJustCreated,sizeof(TSQLFieldTables),0);
try
// create not static and not existing tables
for t := 0 to high(Model.Tables) do
if ((fStaticData=nil) or (fStaticData[t]=nil)) then
// this table is not static -> check if already existing, create if necessary
with Model.TableProps[t], Props do
if not NoCreateMissingTable then
if FastFindPUTF8CharSorted(pointer(TableNamesAtCreation),nt-1,pointer(SQLTableName),@StrIComp)<0 then begin
if not DB.TransactionActive then
DB.TransactionBegin; // make initialization faster by using transaction
DB.Execute(Model.GetSQLCreate(t)); // don't catch exception in constructor
include(TableJustCreated,t); // mark to be initialized below
end else
if not(itoNoCreateMissingField in Options) then begin
// this table is existing: check that all fields exist -> create if necessary
DB.GetFieldNames(aFields,SQLTableName);
nf := length(aFields);
QuickSortRawUTF8(aFields,nf,nil,@StrIComp);
for f := 0 to Fields.Count-1 do
with Fields.List[f] do
if SQLFieldType in COPIABLE_FIELDS then
/// real database columns exist for Simple + Blob fields (not Many)
if FastFindPUTF8CharSorted(pointer(aFields),nf-1,pointer(Name),@StrIComp)<0 then begin
aSQL := Model.GetSQLAddField(t,f);
if aSQL<>'' then begin // need a true field with data
if not DB.TransactionActive then
DB.TransactionBegin; // make initialization faster by using transaction
DB.Execute(aSQL);
end;
Model.Tables[t].InitializeTable(self,Name,Options);
end;
end;
if not DB.TransactionActive then
exit;
// database schema was modified -> update user version in SQLite3 file
if user_version<>0 then
DB.user_version := user_version;
// initialize new tables AFTER creation of ALL tables
if not IsZero(@TableJustCreated,sizeof(TSQLFieldTables)) then
for t := 0 to high(Model.Tables) do
if t in TableJustCreated then
if not(Model.TableProps[t].Kind in IS_CUSTOM_VIRTUAL) or
not TableHasRows(Model.Tables[t]) then // check is really void
Model.Tables[t].InitializeTable(self,'',Options); // '' for table creation
DB.Commit;
except
on E: Exception do begin
DB.RollBack; // will close any active Transaction
raise; // caller must handle exception
end;
end;
end;
function TSQLRestServerDB.MainEngineDelete(TableModelIndex: integer; ID: TID): boolean;
begin
if (TableModelIndex<0) or (ID<=0) then
result := false else begin
// notify BEFORE deletion
InternalUpdateEvent(seDelete,TableModelIndex,ID,'',nil);
result := ExecuteFmt('DELETE FROM % WHERE RowID=:(%):;',
[fModel.TableProps[TableModelIndex].Props.SQLTableName,ID]);
end;
end;
function TSQLRestServerDB.MainEngineDeleteWhere(TableModelIndex: Integer;
const SQLWhere: RawUTF8; const IDs: TIDDynArray): boolean;
var i: integer;
aSQLWhere: RawUTF8;
begin
if (TableModelIndex<0) or (IDs=nil) then
result := false else begin
// notify BEFORE deletion
for i := 0 to high(IDs) do
InternalUpdateEvent(seDelete,TableModelIndex,IDs[i],'',nil);
if IdemPChar(pointer(SQLWhere),'LIMIT ') or
IdemPChar(pointer(SQLWhere),'ORDER BY ') then
// LIMIT is not handled by SQLite3 when built from amalgamation
// see http://www.sqlite.org/compile.html#enable_update_delete_limit
aSQLWhere := Int64DynArrayToCSV(pointer(IDs),length(IDs),'RowID IN (',')') else
aSQLWhere := SQLWhere;
result := ExecuteFmt('DELETE FROM %%',
[fModel.TableProps[TableModelIndex].Props.SQLTableName,SQLFromWhere(aSQLWhere)]);
end;
end;
destructor TSQLRestServerDB.Destroy;
begin
{$ifdef WITHLOG}
with fLogClass.Enter('Destroy %', [fModel.SafeRoot], self) do
{$endif}
try
if (fDB<>nil) and (fDB.InternalState=@InternalState) then
fDB.InternalState := nil; // avoid memory modification on free block
inherited Destroy;
finally
try
fStatementCache.ReleaseAllDBStatements;
finally
fOwnedDB.Free; // do nothing if DB<>fOwnedDB
end;
end;
end;
procedure TSQLRestServerDB.DefinitionTo(Definition: TSynConnectionDefinition);
begin
if Definition=nil then
exit;
inherited; // set Kind
if fDB<>nil then begin
Definition.ServerName := StringToUTF8(fDB.FileName);
Definition.PasswordPlain := fDB.Password;
end;
end;
constructor TSQLRestServerDB.RegisteredClassCreateFrom(aModel: TSQLModel;
aServerHandleAuthentication: boolean; aDefinition: TSynConnectionDefinition);
begin
Create(aModel,UTF8ToString(aDefinition.ServerName),aServerHandleAuthentication,
aDefinition.PasswordPlain);
end;
function TSQLRestServerDB.PrepareVacuum(const aSQL: RawUTF8): boolean;
begin
result := not IdemPChar(Pointer(aSQL),'VACUUM');
if result then
exit;
result := (fStaticVirtualTable=nil) or
IsZero(fStaticVirtualTable,length(fStaticVirtualTable)*sizeof(pointer));
if result then
// VACUUM will fail if there are one or more active SQL statements
fStatementCache.ReleaseAllDBStatements;
end;
function TSQLRestServerDB.InternalExecute(const aSQL: RawUTF8;
ForceCacheStatement: boolean; ValueInt: PInt64; ValueUTF8: PRawUTF8;
ValueInts: PInt64DynArray; LastInsertedID: PInt64; LastChangeCount: PInteger): boolean;
var ValueIntsCount, Res: Integer;
msg: shortstring;
begin
msg := '';
if (self<>nil) and (DB<>nil) then
try
DB.Lock(aSQL);
try
result := true;
if not PrepareVacuum(aSQL) then
exit; // no-op if there are some static virtual tables around
try
GetAndPrepareStatement(aSQL,ForceCacheStatement);
if ValueInts<>nil then begin
ValueIntsCount := 0;
repeat
res := fStatement^.Step;
if res=SQLITE_ROW then
AddInt64(ValueInts^,ValueIntsCount,fStatement^.FieldInt(0));
until res=SQLITE_DONE;
SetLength(ValueInts^,ValueIntsCount);
FormatShort('returned Int64 len=%',[ValueIntsCount],msg);
end else
if (ValueInt=nil) and (ValueUTF8=nil) then begin
// default execution: loop through all rows
repeat until fStatement^.Step<>SQLITE_ROW;
if LastInsertedID<>nil then begin
LastInsertedID^ := DB.LastInsertRowID;
FormatShort(' lastInsertedID=%',[LastInsertedID^],msg);
end;
if LastChangeCount<>nil then begin
LastChangeCount^ := DB.LastChangeCount;
FormatShort(' lastChangeCount=%',[LastChangeCount^],msg);
end;
end else
// get one row, and retrieve value
if fStatement^.Step<>SQLITE_ROW then
result := false else
if ValueInt<>nil then begin
ValueInt^ := fStatement^.FieldInt(0);
FormatShort('returned=%',[ValueInt^],msg);
end else begin
ValueUTF8^ := fStatement^.FieldUTF8(0);
FormatShort('returned="%"',[ValueUTF8^],msg);
end;
GetAndPrepareStatementRelease(nil,msg);
except
on E: Exception do begin
GetAndPrepareStatementRelease(E);
result := false;
end;
end;
finally
DB.UnLock;
end;
except
on E: ESQLite3Exception do begin
{$ifdef WITHLOG}
InternalLog('% for % // %',[E,aSQL,fStatementGenericSQL],sllError);
{$else}
LogToTextFile('TSQLRestServerDB.InternalExecute '+RawUTF8(E.Message)+#13#10+aSQL);
{$endif}
result := false;
end;
end else
result := false;
end;
function TSQLRestServerDB.StoredProcExecute(const aSQL: RawUTF8;
StoredProc: TOnSQLStoredProc): boolean;
var R: TSQLRequest; // we don't use fStatementCache[] here
Res: integer;
begin
result := false;
if (self<>nil) and (DB<>nil) and (aSQL<>'') and Assigned(StoredProc) then
try
{$ifdef WITHLOG}
fLogFamily.SynLog.Enter('StoredProcExecute(%)', [aSQL], self);
{$endif}
DB.LockAndFlushCache; // even if aSQL is SELECT, StoredProc may update data
try
try
R.Prepare(DB.DB,aSQL);
if R.FieldCount>0 then
repeat
res := R.Step;
if res=SQLITE_ROW then
StoredProc(R); // apply the stored procedure to all rows
until res=SQLITE_DONE;
result := true;
finally
R.Close; // always release statement
end;
finally
DB.UnLock;
end;
except
on E: ESQLite3Exception do begin
{$ifdef WITHLOG}
fLogFamily.SynLog.Log(sllError,'% for %',[E,aSQL],self);
{$else}
LogToTextFile(ClassName+'.StoredProcExecute Error: '+RawUTF8(E.Message)+#13#10+aSQL);
{$endif}
result := false;
end;
end;
end;
function TSQLRestServerDB.EngineExecute(const aSQL: RawUTF8): boolean;
begin
result := InternalExecute(aSQL,{forcecache=}false);
end;
procedure TSQLRestServerDB.InternalInfo(var info: TDocVariantData);
begin
inherited InternalInfo(info);
info.AddValue('db', FormatString('% %', [ExtractFileName(DB.FileName), KB(DB.FileSize)]));
end;
procedure TSQLRestServerDB.InternalStat(Ctxt: TSQLRestServerURIContext; W: TTextWriter);
var i: integer;
ndx: TIntegerDynArray;
begin
inherited InternalStat(Ctxt,W);
if Ctxt.InputExists['withall'] or Ctxt.InputExists['withsqlite3'] then begin
W.CancelLastChar('}');
W.AddShort(',"sqlite3":[');
DB.Lock;
try
fStatementCache.SortCacheByTotalTime(ndx);
with fStatementCache do
for i := 0 to Count-1 do
with Cache[ndx[i]] do begin
W.AddJSONEscape([StatementSQL,Timer]);
W.Add(',');
end;
finally
DB.UnLock;
end;
W.CancelLastComma;
W.Add(']','}');
end;
end;
procedure TSQLRestServerDB.ComputeDBStats(out result: variant);
var i: integer;
ndx: TIntegerDynArray;
doc: TDocVariantData absolute result;
begin
if self=nil then
exit;
doc.Init(JSON_OPTIONS_FAST_EXTENDED,dvObject);
DB.Lock;
try
fStatementCache.SortCacheByTotalTime(ndx);
with fStatementCache do
for i := 0 to Count-1 do
with Cache[ndx[i]] do
doc.AddValue(StatementSQL,Timer.ComputeDetails);
finally
DB.UnLock;
end;
end;
function TSQLRestServerDB.ComputeDBStats: variant;
begin
ComputeDBStats(result);
end;
function TSQLRestServerDB.MainEngineList(const SQL: RawUTF8; ForceAJAX: Boolean;
ReturnedRowCount: PPtrInt): RawUTF8;
var MS: TRawByteStringStream;
RowCount: integer;
begin
result := '';
RowCount := 0;
if (self<>nil) and (DB<>nil) and (SQL<>'') then begin
// need a SQL request for R.Execute() to prepare a statement
result := DB.LockJSON(SQL,ReturnedRowCount); // lock and try from cache
if result<>'' then
exit;
try // Execute request if was not got from cache
try
GetAndPrepareStatement(SQL,{forcecache=}false);
MS := TRawByteStringStream.Create;
try
RowCount := fStatement^.Execute(0,'',MS,ForceAJAX or not NoAJAXJSON);
result := MS.DataString;
finally
MS.Free;
end;
GetAndPrepareStatementRelease(nil, FormatToShort('returned % as %',
[Plural('row',RowCount),KB(result)]));
except
on E: ESQLite3Exception do
GetAndPrepareStatementRelease(E);
end;
finally
DB.UnLockJSON(result,RowCount);
end;
end;
if ReturnedRowCount<>nil then
ReturnedRowCount^ := RowCount;
end;
function TSQLRestServerDB.MainEngineRetrieve(TableModelIndex: integer; ID: TID): RawUTF8;
var aSQL: RawUTF8;
begin
result := '';
if (ID<0) or (TableModelIndex<0) then
exit;
with Model.TableProps[TableModelIndex] do
FormatUTF8('SELECT % FROM % WHERE RowID=:(%):;',
[SQL.TableSimpleFields[true,false],Props.SQLTableName,ID],aSQL);
result := EngineList(aSQL,true); // ForceAJAX=true -> '[{...}]'#10
if result<>'' then
if IsNotAjaxJSON(pointer(result)) then
// '{"fieldCount":2,"values":["ID","FirstName"]}'#$A -> ID not found
result := '' else
// list '[{...}]'#10 -> object '{...}'
result := copy(result,2,length(result)-3);
end;
function TSQLRestServerDB.MainEngineRetrieveBlob(TableModelIndex: integer; aID: TID;
BlobField: PPropInfo; out BlobData: TSQLRawBlob): boolean;
var SQL: RawUTF8;
begin
result := false;
if (aID<0) or (TableModelIndex<0) or not BlobField^.IsBlob then
exit;
// retrieve the BLOB using SQL
try
SQL := FormatUTF8('SELECT % FROM % WHERE RowID=?',
[BlobField^.Name,Model.TableProps[TableModelIndex].Props.SQLTableName],[aID]);
DB.Lock(SQL); // UPDATE for a blob field -> no JSON cache flush, but UI refresh
try
GetAndPrepareStatement(SQL,true);
try
if (fStatement^.FieldCount=1) and (fStatement^.Step=SQLITE_ROW) then begin
BlobData := fStatement^.FieldBlob(0);
result := true;
end;
GetAndPrepareStatementRelease(nil,KB(BlobData));
except
on E: Exception do
GetAndPrepareStatementRelease(E);
end;
finally
DB.UnLock;
end;
except
on ESQLite3Exception do
result := false;
end;
end;
function TSQLRestServerDB.RetrieveBlobFields(Value: TSQLRecord): boolean;
var Static: TSQLRest;
SQL: RawUTF8;
f: PtrInt;
size: Int64;
data: TSQLVar;
begin
result := false;
if Value=nil then
exit;
Static := GetStaticTable(PSQLRecordClass(Value)^);
if Static<>nil then
result := Static.RetrieveBlobFields(Value) else
if (DB<>nil) and (Value.ID>0) and (PSQLRecordClass(Value)^<>nil) then
with Value.RecordProps do
if BlobFields<>nil then begin
SQL := FormatUTF8('SELECT % FROM % WHERE ROWID=?',
[SQLTableRetrieveBlobFields,SQLTableName],[Value.ID]);
DB.Lock(SQL);
try
GetAndPrepareStatement(SQL,true);
try
if fStatement^.Step<>SQLITE_ROW then
exit;
size := 0;
for f := 0 to high(BlobFields) do begin
SQlite3ValueToSQLVar(fStatement^.FieldValue(f),data);
BlobFields[f].SetFieldSQLVar(Value,data); // OK for all blobs
inc(size,SQLVarLength(data));
end;
GetAndPrepareStatementRelease(nil,KB(size));
result := true;
except
on E: Exception do
GetAndPrepareStatementRelease(E);
end;
finally
DB.UnLock;
end;
end;
end;
procedure TSQLRestServerDB.SetNoAJAXJSON(const Value: boolean);
begin
inherited;
if Value=NoAJAXJSON then
exit;
fDB.Cache.Reset; // we changed the JSON format -> cache must be updated
end;
function TSQLRestServerDB.MainEngineUpdate(TableModelIndex: integer; ID: TID;
const SentData: RawUTF8): boolean;
var Props: TSQLRecordProperties;
Decoder: TJSONObjectDecoder;
SQL: RawUTF8;
begin
if (TableModelIndex<0) or (ID<=0) then
result := false else
if SentData='' then // update with no simple field -> valid no-op
result := true else begin
// this SQL statement use :(inlined params): for all values
Props := fModel.TableProps[TableModelIndex].Props;
Decoder.Decode(SentData,nil,pInlined,ID,false);
if Props.RecordVersionField<>nil then
InternalRecordVersionHandle(
soUpdate,TableModelIndex,decoder,Props.RecordVersionField);
SQL := Decoder.EncodeAsSQL(true);
result := ExecuteFmt('UPDATE % SET % WHERE RowID=:(%):',
[Props.SQLTableName,SQL,ID]);
InternalUpdateEvent(seUpdate,TableModelIndex,ID,SentData,nil);
end;
end;
function TSQLRestServerDB.MainEngineUpdateBlob(TableModelIndex: integer; aID: TID;
BlobField: PPropInfo; const BlobData: TSQLRawBlob): boolean;
var SQL: RawUTF8;
AffectedField: TSQLFieldBits;
Props: TSQLRecordProperties;
begin
result := false;
if (aID<0) or (TableModelIndex<0) or not BlobField^.IsBlob then
exit;
Props := Model.TableProps[TableModelIndex].Props;
try
FormatUTF8('UPDATE % SET %=? WHERE RowID=?',[Props.SQLTableName,BlobField^.Name],SQL);
DB.Lock(SQL); // UPDATE for a blob field -> no JSON cache flush, but UI refresh
try
GetAndPrepareStatement(SQL,true);
try
if BlobData='' then
fStatement^.BindNull(1) else
fStatement^.BindBlob(1,BlobData);
fStatement^.Bind(2,aID);
repeat until fStatement^.Step<>SQLITE_ROW; // Execute
GetAndPrepareStatementRelease(nil,FormatToShort('stored % in ID=%',
[KB(BlobData),aID]),true);
result := true;
except
on E: Exception do
GetAndPrepareStatementRelease(E);
end;
finally
DB.UnLock;
end;
Props.FieldBitsFromBlobField(BlobField,AffectedField);
InternalUpdateEvent(seUpdateBlob,TableModelIndex,aID,'',@AffectedField);
except
on ESQLite3Exception do
result := false;
end;
end;
function TSQLRestServerDB.MainEngineUpdateFieldIncrement(TableModelIndex: integer;
ID: TID; const FieldName: RawUTF8; Increment: Int64): boolean;
var Props: TSQLRecordProperties;
Value: Int64;
begin
result := false;
if (TableModelIndex<0) or (FieldName='') then
exit;
Props := Model.TableProps[TableModelIndex].Props;
if Props.Fields.IndexByName(FieldName)<0 then
Exit;
if InternalUpdateEventNeeded(TableModelIndex) or
(Props.RecordVersionField<>nil) then
result := OneFieldValue(Props.Table,FieldName,'ID=?',[],[ID],Value) and
UpdateField(Props.Table,ID,FieldName,[Value+Increment]) else
result := RecordCanBeUpdated(Props.Table,ID,seUpdate) and
ExecuteFmt('UPDATE % SET %=%+:(%): WHERE ID=:(%):',
[Props.SQLTableName,FieldName,FieldName,Increment,ID]);
end;
function TSQLRestServerDB.MainEngineUpdateField(TableModelIndex: integer;
const SetFieldName, SetValue, WhereFieldName, WhereValue: RawUTF8): boolean;
var Props: TSQLRecordProperties;
WhereID,RecordVersion: TID;
i: integer;
JSON,IDs: RawUTF8;
ID: TIDDynArray;
begin
result := false;
if (TableModelIndex<0) or (SetFieldName='') then
exit;
Props := Model.TableProps[TableModelIndex].Props;
if Props.Fields.IndexByName(SetFieldName)<0 then
Exit;
if IsRowID(pointer(WhereFieldName)) then begin
WhereID := GetInt64(Pointer(WhereValue));
if WhereID<=0 then
exit;
end else
if Props.Fields.IndexByName(WhereFieldName)<0 then
exit else
WhereID := 0;
if InternalUpdateEventNeeded(TableModelIndex) or
(Props.RecordVersionField<>nil) then begin
if WhereID>0 then begin
SetLength(ID,1);
ID[0] := WhereID;
end else
if not InternalExecute(FormatUTF8('select RowID from % where %=:(%):',
[Props.SQLTableName,WhereFieldName,WhereValue]),true,nil,nil,@ID) then
exit else
if ID=nil then begin
result := true; // nothing to update, but return success
exit;
end;
for i := 0 to high(ID) do
if not RecordCanBeUpdated(Props.Table,ID[i],seUpdate) then
exit;
if Length(ID)=1 then
if Props.RecordVersionField=nil then
result := ExecuteFmt('UPDATE % SET %=:(%): WHERE RowID=:(%):',
[Props.SQLTableName,SetFieldName,SetValue,ID[0]]) else
result := ExecuteFmt('UPDATE % SET %=:(%):,%=:(%): WHERE RowID=:(%):',
[Props.SQLTableName,SetFieldName,SetValue,
Props.RecordVersionField.Name,RecordVersionCompute,ID[0]]) else begin
IDs := Int64DynArrayToCSV(pointer(ID),length(ID));
if Props.RecordVersionField=nil then
result := ExecuteFmt('UPDATE % SET %=% WHERE RowID IN (%)',
[Props.SQLTableName,SetFieldName,SetValue,IDs]) else begin
RecordVersion := RecordVersionCompute;
result := ExecuteFmt('UPDATE % SET %=%,%=% WHERE RowID IN (%)',
[Props.SQLTableName,SetFieldName,SetValue,
Props.RecordVersionField.Name,RecordVersion,IDs]);
end;
end;
if not result then
exit;
JSONEncodeNameSQLValue(SetFieldName,SetValue,JSON);
for i := 0 to high(ID) do
InternalUpdateEvent(seUpdate,TableModelIndex,ID[i],JSON,nil);
end else
if (WhereID>0) and not RecordCanBeUpdated(Props.Table,WhereID,seUpdate) then
exit else // limitation: will only check for update when RowID is provided
result := ExecuteFmt('UPDATE % SET %=:(%): WHERE %=:(%):',
[Props.SQLTableName,SetFieldName,SetValue,WhereFieldName,WhereValue]);
end;
function TSQLRestServerDB.UpdateBlobFields(Value: TSQLRecord): boolean;
var Static: TSQLRest;
SQL: RawUTF8;
TableModelIndex,f: integer;
data: TSQLVar;
size: Int64;
temp: RawByteString;
begin
result := false;
if Value=nil then
exit;
TableModelIndex := Model.GetTableIndexExisting(PSQLRecordClass(Value)^);
Static := GetStaticTableIndex(TableModelIndex);
if Static<>nil then
result := Static.UpdateBlobFields(Value) else
if (DB<>nil) and (Value.ID>0) and (PSQLRecordClass(Value)^<>nil) then
with Model.TableProps[TableModelIndex].Props do
if BlobFields<>nil then begin
FormatUTF8('UPDATE % SET % WHERE ROWID=?',[SQLTableName,SQLTableUpdateBlobFields],SQL);
DB.Lock(SQL); // UPDATE for all blob fields -> no cache flush, but UI refresh
try
GetAndPrepareStatement(SQL,true);
try
size := 0;
for f := 1 to length(BlobFields) do begin
BlobFields[f-1].GetFieldSQLVar(Value,data,temp); // OK for all blobs
if data.VType=ftBlob then begin
fStatement^.Bind(f,data.VBlob,data.VBlobLen);
inc(size,data.VBlobLen);
end else
fStatement^.BindNull(f); // e.g. Value was ''
end;
fStatement^.Bind(length(BlobFields)+1,Value.ID);
repeat until fStatement^.Step<>SQLITE_ROW; // Execute
GetAndPrepareStatementRelease(nil,FormatToShort('stored % in ID=%',
[KB(size),Value.ID]),true);
result := true;
except
on E: Exception do
GetAndPrepareStatementRelease(E);
end;
finally
DB.UnLock;
end;
InternalUpdateEvent(seUpdateBlob,TableModelIndex,Value.ID,'',@FieldBits[sftBlob]);
end else
result := true; // as TSQLRest.UpdateblobFields()
end;
procedure TSQLRestServerDB.Commit(SessionID: cardinal; RaiseException: boolean);
begin
inherited Commit(SessionID,RaiseException);
// reset fTransactionActive + write all TSQLVirtualTableJSON
try
DB.Commit; // will call DB.Lock
except
on Exception do
if RaiseException then
raise; // default RaiseException=false will just ignore the exception
end;
end;
procedure TSQLRestServerDB.RollBack(SessionID: cardinal);
begin
inherited RollBack(SessionID); // reset TSQLRestServerDB.fTransactionActive flag
try
DB.RollBack; // will call DB.Lock
except
on ESQLite3Exception do
; // just catch exception
end;
end;
function TSQLRestServerDB.TransactionBegin(aTable: TSQLRecordClass; SessionID: cardinal): boolean;
begin
result := not DB.TransactionActive and inherited TransactionBegin(aTable,SessionID);
if not result then
exit; // fTransactionActive flag was already set
try
DB.TransactionBegin; // will call DB.Lock
except
on ESQLite3Exception do
result := false;
end;
end;
{$ifndef KYLIX3}
function TSQLRestServerDB.Backup(Dest: TStream): boolean;
{$ifndef WITHUNSAFEBACKUP} // deprecated - use DB.BackupBackground() instead
begin
result := false;
end;
{$else}
var Source: TFileStream;
Closed: boolean;
user_version: cardinal;
begin
result := false;
if (Self=nil) or (DB=nil) then
exit;
user_version := DB.user_version;
DB.LockAndFlushCache;
try
try
fStatementCache.ReleaseAllDBStatements;
// perform a VACCUM to recreate the database content
EngineExecute('VACUUM');
Closed := false;
try
Closed := DB.DBClose=SQLITE_OK;
// compress the database content file
Source := FileStreamSequentialRead(DB.FileName);
try
Dest.CopyFrom(Source,0); // Count=0 for whole stream copy
result := true;
finally
Source.Free;
end;
finally
if Closed then begin
// reopen the database if was previously closed
DB.DBOpen;
// register functions and modules
InitializeEngine;
// register virtual tables
CreateMissingTables(user_version,fCreateMissingTablesOptions);
end;
end;
finally
DB.UnLock;
end;
except
on E: Exception do
result := false;
end;
end;
{$endif}
function TSQLRestServerDB.BackupGZ(const DestFileName: TFileName;
CompressionLevel: integer): boolean;
{$ifndef WITHUNSAFEBACKUP} // deprecated - use DB.BackupBackground() instead
begin
result := false;
end;
{$else}
var D,Z: TStream;
begin
try
D := TFileStream.Create(DestFileName,fmCreate);
try
Z := TSynZipCompressor.Create(D,CompressionLevel,szcfGZ);
try
{$WARN SYMBOL_DEPRECATED OFF} // BackupGZ() itself is marked deprecated
result := Backup(Z);
{$WARN SYMBOL_DEPRECATED ON}
finally
Z.Free;
end;
finally
D.Free;
end;
except
result := false;
end;
end;
{$endif}
{$endif KYLIX3}
function TSQLRestServerDB.RestoreGZ(const BackupFileName: TFileName): boolean;
{$ifndef WITHUNSAFEBACKUP} // deprecated - use DB.BackupBackground() instead
begin
result := false;
end;
{$else}
begin
try
with TSynMemoryStreamMapped.Create(BackupFileName) do
try
result := Restore(GZRead(Memory,Size));
finally
Free;
end;
except
on Exception do
result := false;
end;
end;
{$endif}
function TSQLRestServerDB.Restore(const ContentToRestore: RawByteString): boolean;
{$ifndef WITHUNSAFEBACKUP} // deprecated - use DB.BackupBackground() instead
begin
result := false;
end;
{$else}
var BackupFileName: TFileName;
user_version: cardinal;
begin
result := false;
if (Self=nil) or (DB=nil) or
not IdemPChar(pointer(ContentToRestore),'SQLITE FORMAT 3') then
exit; // invalid restore content
user_version := DB.user_version;
DB.LockAndFlushCache;
try
try
fStatementCache.ReleaseAllDBStatements;
if DB.DBClose<>SQLITE_OK then
exit; // impossible to close DB.FileName (some statement may be opened)
BackupFileName := ChangeFileExt(DB.FileName,'.bak');
DeleteFile(BackupFileName);
try
{$ifdef MSWINDOWS}
if MoveFile(pointer(DB.FileName),pointer(BackupFileName)) then
{$else}
if RenameFile(DB.FileName,BackupFileName) then
{$endif}
if FileFromString(ContentToRestore,DB.FileName,true) and
(StringFromFile(DB.FileName)=ContentToRestore) then
result := (DB.DBOpen=SQLITE_OK);
finally
if result then
DeleteFile(BackupFileName) else begin
// on error, restore previous db file
DeleteFile(DB.FileName);
{$ifdef MSWINDOWS}
MoveFile(pointer(BackupFileName),pointer(DB.FileName));
{$else}
RenameFile(BackupFileName,DB.FileName);
{$endif}
DB.DBOpen; // always reopen the database
end;
// register functions and modules
InitializeEngine;
// register virtual tables
CreateMissingTables(user_version,fCreateMissingTablesOptions);
end;
finally
DB.UnLock;
end;
except
on E: Exception do
result := false;
end;
end;
{$endif}
procedure TSQLRestServerDB.AdministrationExecute(const DatabaseName,SQL: RawUTF8;
var result: TServiceCustomAnswer);
var new,cmd,fn: RawUTF8;
bfn: TFileName;
compress: boolean;
i: integer;
begin
inherited AdministrationExecute(DatabaseName,SQL,result);
if (SQL<>'') and (SQL[1]='#') then begin
case IdemPCharArray(@SQL[2],['VERSION','HELP','DB','BACKUP']) of
0: new := FormatUTF8('"sqlite3":?}',[],[sqlite3.Version],true);
1: begin
result.Content[length(result.Content)] := '|';
result.Content := result.Content+'#db [*/filename]|#backup [filename]"';
end;
2: begin
split(SQL,' ',cmd,fn);
if fn='' then begin
result.Content := ObjectToJSON(DB,[woFullExpand]);
if fStaticData<>nil then begin
for i := 0 to high(fStaticData) do
if fStaticData[i]<>nil then
new := new+ObjectToJSON(fStaticData[i],[woFullExpand])+',';
if new<>'' then begin
new[length(new)] := ']';
new := '"StaticTables":['+new+'}';
end;
end;
end else
AdministrationExecuteGetFiles(ExtractFilePath(DB.FileName),
'*.db;*.db3;*.dbs',fn,result); // *.dbs includes *.dbsynlz
end;
3: begin
split(SQL,' ',cmd,fn);
if fn='' then
FormatUTF8('% %',[NowToString(false),ChangeFileExt(DB.FileNameWithoutPath,'.dbsynlz')],fn);
if (fn<>' ') and (PosEx('..',fn)=0) then begin
bfn := UTF8ToString(fn);
if ExtractFilePath(bfn)='' then // put in local data folder if not set
bfn := ExtractFilePath(DB.FileName)+bfn;
compress := GetFileNameExtIndex(bfn,'dbsynlz')=0;
if DB.BackupBackground(bfn,4*1024,1,nil,compress) then // 4*1024*4096=16MB step
result.Content := JsonEncode(['started',bfn,'compress',compress]) else
result.Content := '"Backup failed to start"';
end;
end;
else exit;
end;
if new<>'' then begin
if result.Content='' then
result.Content := '{' else
result.Content[length(result.Content)] := ',';
result.Content := result.Content+new;
end;
end;
end;
procedure TSQLRestServerDB.FlushInternalDBCache;
begin
inherited;
if DB=nil then
exit;
DB.Lock;
try
DB.CacheFlush;
finally
DB.UnLock;
end;
end;
function TSQLRestServerDB.InternalBatchStart(
Method: TSQLURIMethod; BatchOptions: TSQLRestBatchOptions): boolean;
begin
result := false; // means BATCH mode not supported
if method=mPOST then begin // POST=ADD=INSERT -> MainEngineAdd() to fBatchValues[]
if (fBatchMethod<>mNone) or (fBatchValuesCount<>0) or (fBatchIDCount<>0) then
raise EORMBatchException.CreateUTF8('%.InternalBatchStop should have been called',[self]);
fBatchMethod := method;
fBatchOptions := BatchOptions;
fBatchTableIndex := -1;
fBatchIDMax := 0; // MainEngineAdd() will search for max(id)
result := true; // means BATCH mode is supported
end;
end;
procedure TSQLRestServerDB.InternalBatchStop;
const MAX_PARAMS = 500; // pragmatic value (theoritical limit is 999)
var ndx,f,r,prop,fieldCount,valuesCount,
rowCount,valuesFirstRow: integer;
P: PUTF8Char;
DecodeSaved,UpdateEventNeeded: boolean;
Fields, Values: TRawUTF8DynArray;
ValuesNull: TByteDynArray;
Types: TSQLDBFieldTypeDynArray;
SQL: RawUTF8;
Props: TSQLRecordProperties;
Decode: TJSONObjectDecoder;
tmp: TSynTempBuffer;
begin
if (fBatchValuesCount=0) or (fBatchTableIndex<0) then
exit; // nothing to add
if fBatchMethod<>mPOST then
raise EORMBatchException.CreateUTF8('%.InternalBatchStop: BatchMethod=%',
[self,ToText(fBatchMethod)^]);
try
if fBatchValuesCount<>fBatchIDCount then
raise EORMBatchException.CreateUTF8('%.InternalBatchStop(*Count?)',[self]);
UpdateEventNeeded := InternalUpdateEventNeeded(fBatchTableIndex);
Props := fModel.Tables[fBatchTableIndex].RecordProps;
if fBatchValuesCount=1 then begin // handle single record insert
Decode.Decode(fBatchValues[0],nil,pInlined,fBatchID[0]);
if Props.RecordVersionField<>nil then
InternalRecordVersionHandle(
soInsert,fBatchTableIndex,Decode,Props.RecordVersionField);
SQL := 'INSERT INTO '+Props.SQLTableName+Decode.EncodeAsSQL(False)+';';
if not InternalExecute(SQL,true) then // just like ESQLite3Exception below
raise EORMBatchException.CreateUTF8('%.InternalBatchStop failed on %', [self, SQL]);
if UpdateEventNeeded then
InternalUpdateEvent(seAdd,fBatchTableIndex,fBatchID[0],fBatchValues[0],nil);
exit;
end;
DecodeSaved := true;
valuesCount := 0;
rowCount := 0;
valuesFirstRow := 0;
SetLength(ValuesNull,(MAX_PARAMS shr 3)+1);
SetLength(Values,32);
Fields := nil; // makes compiler happy
fieldCount := 0;
ndx := 0;
repeat
repeat
// decode a row
if DecodeSaved then
try
if UpdateEventNeeded then begin
tmp.Init(fBatchValues[ndx]);
P := tmp.buf;
end else
P := pointer(fBatchValues[ndx]);
if P=nil then
raise EORMBatchException.CreateUTF8(
'%.InternalBatchStop: fBatchValues[%]=""',[self,ndx]);
while P^ in [#1..' ','{','['] do inc(P);
Decode.Decode(P,nil,pNonQuoted,fBatchID[ndx]);
if Props.RecordVersionField<>nil then
InternalRecordVersionHandle(
soInsert,fBatchTableIndex,Decode,Props.RecordVersionField);
inc(ndx);
DecodeSaved := false;
finally
if UpdateEventNeeded then
tmp.Done;
end;
if Fields=nil then begin
Decode.AssignFieldNamesTo(Fields);
fieldCount := Decode.FieldCount;
SQL := Decode.EncodeAsSQLPrepared(Props.SQLTableName,soInsert,'',fBatchOptions);
SetLength(Types,fieldCount);
for f := 0 to fieldCount-1 do begin
prop := Props.Fields.IndexByNameOrExcept(Decode.FieldNames[f]);
if prop<0 then // RowID
Types[f] := ftInt64 else
Types[f] := Props.Fields.List[prop].SQLDBFieldType;
end;
end else
if not Decode.SameFieldNames(Fields) then
break else // this item would break the SQL statement
if valuesCount+fieldCount>MAX_PARAMS then
break; // this item would bound too many params
// if we reached here, we can add this row to Values[]
if valuesCount+fieldCount>length(Values) then
SetLength(Values,MAX_PARAMS);
for f := 0 to fieldCount-1 do
if Decode.FieldTypeApproximation[f]=ftaNull then
SetBitPtr(pointer(ValuesNull),valuesCount+f) else
Values[valuesCount+f] := Decode.FieldValues[f];
inc(ValuesCount,fieldCount);
inc(rowCount);
DecodeSaved := true;
until ndx=fBatchValuesCount;
// INSERT Values[] into the DB
DB.LockAndFlushCache;
try
try
FormatUTF8('% multi %',[rowCount,SQL],fStatementSQL);
if rowCount>1 then
SQL := SQL+','+CSVOfValue('('+CSVOfValue('?',fieldCount)+')',rowCount-1);
fStatementGenericSQL := SQL; // full log on error
PrepareStatement((rowCount<5) or (valuesCount+fieldCount>MAX_PARAMS));
prop := 0;
for f := 0 to valuesCount-1 do begin
if GetBitPtr(pointer(ValuesNull),f) then
fStatement^.BindNull(f+1) else
case Types[prop] of
ftInt64:
fStatement^.Bind(f+1,GetInt64(pointer(Values[f])));
ftDouble, ftCurrency:
fStatement^.Bind(f+1,GetExtended(pointer(Values[f])));
ftDate, ftUTF8:
fStatement^.Bind(f+1,Values[f]);
ftBlob:
fStatement^.BindBlob(f+1,Values[f]);
end;
inc(prop);
if prop=fieldCount then
prop := 0;
end;
repeat until fStatement^.Step<>SQLITE_ROW; // ESQLite3Exception on error
if UpdateEventNeeded then
for r := valuesFirstRow to valuesFirstRow+rowCount-1 do
InternalUpdateEvent(seAdd,fBatchTableIndex,fBatchID[r],fBatchValues[r],nil);
inc(valuesFirstRow,rowCount);
GetAndPrepareStatementRelease;
except
on E: Exception do begin
GetAndPrepareStatementRelease(E);
raise;
end;
end;
finally
DB.UnLock;
end;
FillcharFast(ValuesNull[0],(ValuesCount shr 3)+1,0);
ValuesCount := 0;
rowCount := 0;
Fields := nil; // force new SQL statement and Values[]
until DecodeSaved and (ndx=fBatchValuesCount);
if valuesFirstRow<>fBatchValuesCount then
raise EORMBatchException.CreateUTF8('%.InternalBatchStop(valuesFirstRow)',[self]);
finally
fBatchMethod := mNone;
fBatchValuesCount := 0;
fBatchValues := nil;
fBatchIDCount := 0;
fBatchID := nil;
end;
end;
{ TSQLRestClientDB }
constructor TSQLRestClientDB.Create(aClientModel, aServerModel: TSQLModel; aDB: TSQLDataBase;
aServerClass: TSQLRestServerDBClass; aHandleUserAuthentication: boolean);
begin
aDB.UseCache := true; // we better use caching in this JSON oriented use
inherited Create(aClientModel);
if aServerModel=nil then
aServerModel := TSQLModel.Create(aClientModel); // clone from client
// next line will create aModel tables if necessary
fOwnedServer := aServerClass.Create(aServerModel,aDB,aHandleUserAuthentication);
fServer := fOwnedServer;
fServer.NoAJAXJSON := true; // use smaller JSON size in this local use (never AJAX)
end;
constructor TSQLRestClientDB.Create(aClientModel, aServerModel: TSQLModel;
const aDBFileName: TFileName; aServerClass: TSQLRestServerDBClass;
aHandleUserAuthentication: boolean; const aPassword: RawUTF8;
aDefaultCacheSize: integer);
begin
fOwnedDB := TSQLDataBase.Create(aDBFileName,aPassword,0,aDefaultCacheSize);
Create(aClientModel,aServerModel,fOwnedDB,aServerClass,aHandleUserAuthentication);
end;
constructor TSQLRestClientDB.Create(aRunningServer: TSQLRestServerDB);
var ClientModel: TSQLModel;
begin
if aRunningServer=nil then
raise EORMException.Create('TSQLRestClientDB.Create(nil)');
ClientModel := TSQLModel.Create(aRunningServer.Model);
ClientModel.Owner := Self; // auto-free ClientModel in TSQLRest.Destroy
inherited Create(ClientModel);
fServer := aRunningServer; // leave fOwnedServer=nil
end;
destructor TSQLRestClientDB.Destroy;
var M: TSQLModel;
begin
try
inherited Destroy; // UnLock records + SessionClose
finally
if fOwnedServer<>nil then begin
if fServer=nil then
M := nil else
M := fServer.Model;
if (M<>nil) and (M.Owner<>nil) then
M := nil; // free associated model only if it's owned by nobody
try
FreeAndNil(fOwnedServer);
fServer := nil;
finally
M.Free;
fOwnedDB.Free;
end;
end;
end;
end;
function TSQLRestClientDB.getDB: TSQLDataBase;
begin
result := fServer.DB;
end;
function TSQLRestClientDB.List(const Tables: array of TSQLRecordClass;
const SQLSelect, SQLWhere: RawUTF8): TSQLTableJSON;
var aSQL: RawUTF8;
n: integer;
begin
result := nil;
n := length(Tables);
if (self<>nil) and (n>0) then
try // will use JSON cache if available:
aSQL := Model.SQLFromSelectWhere(Tables,SQLSelect,SQLWhere);
if n=1 then
// InternalListJSON will handle both static and DB tables
result := fServer.ExecuteList(Tables,aSQL) else
// we access localy the DB -> TSQLTableDB handle Tables parameter
result := TSQLTableDB.Create(fServer.DB,Tables,aSQL,not fServer.NoAJAXJSON);
if fServer.DB.InternalState<>nil then
result.InternalState := fServer.DB.InternalState^;
except
on ESQLite3Exception do
result := nil;
end;
end;
procedure TSQLRestClientDB.InternalURI(var call: TSQLRestURIParams);
begin
if fInternalHeader='' then
fInternalHeader := 'RemoteIP: 127.0.0.1'#13#10'ConnectionID: '+PointerToHex(self);
AddToCSV(fInternalHeader,call.InHead,#13#10);
call.RestAccessRights := @FULL_ACCESS_RIGHTS;
fServer.URI(call);
if (call.OutInternalState=0) and (fServer.DB.InternalState<>nil) then
call.OutInternalState := fServer.DB.InternalState^; // manual update if necessary
end;
function TSQLRestClientDB.InternalCheckOpen: boolean;
begin
result := true;
end;
procedure TSQLRestClientDB.InternalClose;
begin
end;
{ TSQLVirtualTableModuleSQLite3 }
procedure Notify(const Format: RawUTF8; const Args: array of const);
begin
{$ifdef WITHLOG}
SynSQLite3Log.DebuggerNotify(sllWarning,Format,Args);
{$endif}
end;
function TSQLVirtualTableModuleSQLite3.FileName(const aTableName: RawUTF8): TFileName;
begin
if FilePath<>'' then
// if a file path is specified (e.g. by SynDBExplorer) -> always use this
result := inherited FileName(aTableName) else
if SameText(DB.FileName,SQLITE_MEMORY_DATABASE_NAME) then
// in-memory databases virtual tables should remain in memory
result := '' else
// change file path to current DB folder
result := ExtractFilePath(DB.FileName)+ExtractFileName(inherited FileName(aTableName));
end;
function vt_Create(DB: TSQLite3DB; pAux: Pointer;
argc: Integer; const argv: PPUTF8CharArray;
var ppVTab: PSQLite3VTab; var pzErr: PUTF8Char): Integer; cdecl;
var Module: TSQLVirtualTableModuleSQLite3 absolute pAux;
Table: TSQLVirtualTable;
Structure: RawUTF8;
ModuleName: RawUTF8;
begin
if Module<>nil then
ModuleName := Module.ModuleName;
if (Module=nil) or (Module.DB.DB<>DB) or
(StrIComp(pointer(ModuleName),argv[0])<>0) then begin
Notify('vt_Create(%<>%)',[argv[0],ModuleName]);
result := SQLITE_ERROR;
exit;
end;
ppVTab := sqlite3.malloc(sizeof(TSQLite3VTab));
if ppVTab=nil then begin
result := SQLITE_NOMEM;
exit;
end;
FillcharFast(ppVTab^,sizeof(ppVTab^),0);
try
Table := Module.TableClass.Create(Module,RawUTF8(argv[2]),argc-3,@argv[3]);
except
on E: Exception do begin
ExceptionToSqlite3Err(E,pzErr);
sqlite3.free_(ppVTab);
result := SQLITE_ERROR;
exit;
end;
end;
Structure := Table.Structure;
result := sqlite3.declare_vtab(DB,pointer(Structure));
if result<>SQLITE_OK then begin
Notify('vt_Create(%) declare_vtab(%)',[ModuleName,Structure]);
Table.Free;
sqlite3.free_(ppVTab);
result := SQLITE_ERROR;
end else
ppVTab^.pInstance := Table;
end;
function vt_Disconnect(pVTab: PSQLite3VTab): Integer; cdecl;
begin
TSQLVirtualTable(pvTab^.pInstance).Free;
sqlite3.free_(pVTab);
result := SQLITE_OK;
end;
function vt_Destroy(pVTab: PSQLite3VTab): Integer; cdecl;
begin
if TSQLVirtualTable(pvTab^.pInstance).Drop then
result := SQLITE_OK else begin
Notify('vt_Destroy',[]);
result := SQLITE_ERROR;
end;
vt_Disconnect(pVTab); // release memory
end;
function vt_BestIndex(var pVTab: TSQLite3VTab; var pInfo: TSQLite3IndexInfo): Integer;
cdecl;
const COST: array[TSQLVirtualTablePreparedCost] of double = (1E10,1E8,10,1);
// costFullScan, costScanWhere, costSecondaryIndex, costPrimaryIndex
var Prepared: PSQLVirtualTablePrepared;
Table: TSQLVirtualTable;
i, n: Integer;
begin
result := SQLITE_ERROR;
Table := TSQLVirtualTable(pvTab.pInstance);
if (cardinal(pInfo.nOrderBy)>MAX_SQLFIELDS) or
(cardinal(pInfo.nConstraint)>MAX_SQLFIELDS) then begin
Notify('nOrderBy=% nConstraint=%',[pInfo.nOrderBy,pInfo.nConstraint]);
exit; // avoid buffer overflow
end;
Prepared := sqlite3.malloc(sizeof(TSQLVirtualTablePrepared));
try
// encode the incoming parameters into Prepared^ record
Prepared^.WhereCount := pInfo.nConstraint;
Prepared^.EstimatedCost := costFullScan;
for i := 0 to pInfo.nConstraint-1 do
with Prepared^.Where[i], pInfo.aConstraint^[i] do begin
OmitCheck := False;
Value.VType := ftUnknown;
if usable then begin
Column := iColumn;
case op of
SQLITE_INDEX_CONSTRAINT_EQ: Operation := soEqualTo;
SQLITE_INDEX_CONSTRAINT_GT: Operation := soGreaterThan;
SQLITE_INDEX_CONSTRAINT_LE: Operation := soLessThanOrEqualTo;
SQLITE_INDEX_CONSTRAINT_LT: Operation := soLessThan;
SQLITE_INDEX_CONSTRAINT_GE: Operation := soGreaterThanOrEqualTo;
SQLITE_INDEX_CONSTRAINT_MATCH: Operation := soBeginWith;
else Column := VIRTUAL_TABLE_IGNORE_COLUMN; // unhandled operator
end;
end else
Column := VIRTUAL_TABLE_IGNORE_COLUMN;
end;
Prepared^.OmitOrderBy := false;
if pInfo.nOrderBy>0 then begin
assert(sizeof(TSQLVirtualTablePreparedOrderBy)=sizeof(TSQLite3IndexOrderBy));
Prepared^.OrderByCount := pInfo.nOrderBy;
MoveFast(pInfo.aOrderBy^[0],Prepared^.OrderBy[0],pInfo.nOrderBy*sizeof(Prepared^.OrderBy[0]));
end else
Prepared^.OrderByCount := 0;
// perform the index query
if not Table.Prepare(Prepared^) then
exit;
// update pInfo and store Prepared into pInfo.idxStr for vt_Filter()
n := 0;
for i := 0 to pInfo.nConstraint-1 do
if Prepared^.Where[i].Value.VType<>ftUnknown then begin
if i<>n then // expression needed for Search() method to be moved at [n]
MoveFast(Prepared^.Where[i],Prepared^.Where[n],sizeof(Prepared^.Where[i]));
inc(n);
pInfo.aConstraintUsage[i].argvIndex := n;
pInfo.aConstraintUsage[i].omit := Prepared^.Where[i].OmitCheck;
end;
Prepared^.WhereCount := n; // will match argc in vt_Filter()
if Prepared^.OmitOrderBy then
pInfo.orderByConsumed := 1 else
pInfo.orderByConsumed := 0;
pInfo.estimatedCost := COST[Prepared^.EstimatedCost];
if sqlite3.VersionNumber>=3008002000 then // starting with SQLite 3.8.2
case Prepared^.EstimatedCost of
costFullScan:
pInfo.estimatedRows := Prepared^.EstimatedRows;
costScanWhere: // estimate a WHERE clause is a slight performance gain
pInfo.estimatedRows := Prepared^.EstimatedRows shr 1;
costSecondaryIndex:
pInfo.estimatedRows := 10;
costPrimaryIndex:
pInfo.estimatedRows := 1;
else raise EORMException.Create('vt_BestIndex: unexpected EstimatedCost');
end;
pInfo.idxStr := pointer(Prepared);
pInfo.needToFreeIdxStr := 1; // will do sqlite3.free(idxStr) when needed
result := SQLITE_OK;
{$ifdef SQLVIRTUALLOGS}
if Table.Static is TSQLRestStorageExternal then
TSQLRestStorageExternal(Table.Static).ComputeSQL(prepared^);
SQLite3Log.Add.Log(sllDebug,'vt_BestIndex(%) plan=% -> cost=% rows=%',
[sqlite3.VersionNumber,ord(Prepared^.EstimatedCost),pInfo.estimatedCost,pInfo.estimatedRows]);
{$endif SQLVIRTUALLOGS}
finally
if result<>SQLITE_OK then
sqlite3.free_(Prepared); // avoid memory leak on error
end;
end;
function vt_Filter(var pVtabCursor: TSQLite3VTabCursor; idxNum: Integer; const idxStr: PAnsiChar;
argc: Integer; var argv: TSQLite3ValueArray): Integer;
cdecl;
var Prepared: PSQLVirtualTablePrepared absolute idxStr; // idxNum is not used
i: integer;
begin
result := SQLITE_ERROR;
if Prepared^.WhereCount<>argc then begin
Notify('vt_Filter WhereCount=% argc=%',[Prepared^.WhereCount,argc]);
exit; // invalid prepared array (should not happen)
end;
for i := 0 to argc-1 do
SQlite3ValueToSQLVar(argv[i],Prepared^.Where[i].Value);
if TSQLVirtualTableCursor(pVtabCursor.pInstance).Search(Prepared^) then
result := SQLITE_OK else
Notify('vt_Filter Search()',[]);
end;
function vt_Open(var pVTab: TSQLite3VTab; var ppCursor: PSQLite3VTabCursor): Integer;
cdecl;
var Table: TSQLVirtualTable;
begin
ppCursor := sqlite3.malloc(sizeof(TSQLite3VTabCursor));
if ppCursor=nil then begin
result := SQLITE_NOMEM;
exit;
end;
Table := TSQLVirtualTable(pvTab.pInstance);
if (Table=nil) or (Table.Module=nil) or (Table.Module.CursorClass=nil) then begin
Notify('vt_Open',[]);
sqlite3.free_(ppCursor);
result := SQLITE_ERROR;
exit;
end;
ppCursor.pInstance := Table.Module.CursorClass.Create(Table);
result := SQLITE_OK;
end;
function vt_Close(pVtabCursor: PSQLite3VTabCursor): Integer;
cdecl;
begin
TSQLVirtualTableCursor(pVtabCursor^.pInstance).Free;
sqlite3.free_(pVtabCursor);
result := SQLITE_OK;
end;
function vt_next(var pVtabCursor: TSQLite3VTabCursor): Integer;
cdecl;
begin
if TSQLVirtualTableCursor(pVtabCursor.pInstance).Next then
result := SQLITE_OK else
result := SQLITE_ERROR;
end;
function vt_Eof(var pVtabCursor: TSQLite3VTabCursor): Integer;
cdecl;
begin
if TSQLVirtualTableCursor(pVtabCursor.pInstance).HasData then
result := 0 else
result := 1; // reached actual EOF
end;
function vt_Column(var pVtabCursor: TSQLite3VTabCursor; sContext: TSQLite3FunctionContext;
N: Integer): Integer; cdecl;
var Res: TSQLVar;
begin
Res.VType := ftUnknown;
if (N>=0) and TSQLVirtualTableCursor(pVtabCursor.pInstance).Column(N,Res) and
SQLVarToSQlite3Context(Res,sContext) then
result := SQLITE_OK else begin
Notify('vt_Column(%) Res=%',[N,ord(Res.VType)]);
result := SQLITE_ERROR;
end;
end;
function vt_Rowid(var pVtabCursor: TSQLite3VTabCursor; var pRowid: Int64): Integer;
cdecl;
var Res: TSQLVar;
begin
result := SQLITE_ERROR;
with TSQLVirtualTableCursor(pVtabCursor.pInstance) do
if Column(-1,Res) then begin
case Res.VType of
ftInt64: pRowID := Res.VInt64;
ftDouble: pRowID := trunc(Res.VDouble);
ftCurrency: pRowID := trunc(Res.VCurrency);
ftUTF8: pRowID := GetInt64(Res.VText);
else begin
Notify('vt_Rowid Res=%',[ord(Res.VType)]);
exit;
end;
end;
result := SQLITE_OK;
end else
Notify('vt_Rowid Column',[]);
end;
function vt_Update(var pVTab: TSQLite3VTab;
nArg: Integer; var ppArg: TSQLite3ValueArray;
var pRowid: Int64): Integer; cdecl;
var Values: TSQLVarDynArray;
Table: TSQLVirtualTable;
RowID0, RowID1: Int64;
i: integer;
OK: boolean;
begin // call Delete/Insert/Update methods according to supplied parameters
Table := TSQLVirtualTable(pvTab.pInstance);
result := SQLITE_ERROR;
if (nArg<=0) or (nArg>1024) then
exit;
case sqlite3.value_type(ppArg[0]) of
SQLITE_INTEGER: RowID0 := sqlite3.value_int64(ppArg[0]);
SQLITE_NULL: RowID0 := 0;
else exit; // invalid call
end;
if nArg=1 then
OK := Table.Delete(RowID0) else begin
case sqlite3.value_type(ppArg[1]) of
SQLITE_INTEGER: RowID1 := sqlite3.value_int64(ppArg[1]);
SQLITE_NULL: RowID1 := 0;
else exit; // invalid call
end;
SetLength(Values,nArg-2);
for i := 0 to nArg-3 do
SQlite3ValueToSQLVar(ppArg[i+2],Values[i]);
if RowID0=0 then
OK := Table.Insert(RowID1,Values,pRowid) else
OK := Table.Update(RowID0,RowID1,Values);
end;
if OK then
result := SQLITE_OK else
Notify('vt_Update(%)',[pRowID]);
end;
function InternalTrans(pVTab: TSQLite3VTab; aState: TSQLVirtualTableTransaction;
aSavePoint: integer): integer;
begin
if TSQLVirtualTable(pvTab.pInstance).Transaction(aState,aSavePoint) then
result := SQLITE_OK else begin
Notify('Transaction(%,%)',[ToText(aState)^,aSavePoint]);
result := SQLITE_ERROR;
end;
end;
function vt_Begin(var pVTab: TSQLite3VTab): Integer; cdecl;
begin
result := InternalTrans(pVTab,vttBegin,0);
end;
function vt_Commit(var pVTab: TSQLite3VTab): Integer; cdecl;
begin
result := InternalTrans(pVTab,vttCommit,0);
end;
function vt_RollBack(var pVTab: TSQLite3VTab): Integer; cdecl;
begin
result := InternalTrans(pVTab,vttRollBack,0);
end;
function vt_Sync(var pVTab: TSQLite3VTab): Integer; cdecl;
begin
result := InternalTrans(pVTab,vttSync,0);
end;
function vt_SavePoint(var pVTab: TSQLite3VTab; iSavepoint: integer): Integer; cdecl;
begin
result := InternalTrans(pVTab,vttSavePoint,iSavePoint);
end;
function vt_Release(var pVTab: TSQLite3VTab; iSavepoint: integer): Integer; cdecl;
begin
result := InternalTrans(pVTab,vttRelease,iSavePoint);
end;
function vt_RollBackTo(var pVTab: TSQLite3VTab; iSavepoint: integer): Integer; cdecl;
begin
result := InternalTrans(pVTab,vttRollBackTo,iSavePoint);
end;
function vt_Rename(var pVTab: TSQLite3VTab; const zNew: PAnsiChar): Integer; cdecl;
begin
if TSQLVirtualTable(pvTab.pInstance).Rename(RawUTF8(zNew)) then
result := SQLITE_OK else begin
Notify('vt_Rename(%)',[zNew]);
result := SQLITE_ERROR;
end;
end;
procedure sqlite3InternalFreeModule(p: pointer); cdecl;
begin
if (p<>nil) and (TSQLVirtualTableModuleSQLite3(p).fDB<>nil) then
TSQLVirtualTableModuleSQLite3(p).Free;
end;
procedure TSQLVirtualTableModuleSQLite3.Attach(aDB: TSQLDataBase);
begin
if aDB=nil then
raise EBusinessLayerException.CreateFmt('aDB=nil at %s.SetDB()',[ClassName]);
if fDB<>nil then
raise EBusinessLayerException.CreateFmt('fDB<>nil at %s.SetDB()',[ClassName]);
FillCharFast(fModule,sizeof(fModule),0);
fModule.iVersion := 1;
fModule.xCreate := vt_Create;
fModule.xConnect := vt_Create;
fModule.xBestIndex := vt_BestIndex;
fModule.xDisconnect := vt_Disconnect;
fModule.xDestroy := vt_Destroy;
fModule.xOpen := vt_Open;
fModule.xClose := vt_Close;
fModule.xFilter := vt_Filter;
fModule.xNext := vt_Next;
fModule.xEof := vt_Eof;
fModule.xColumn := vt_Column;
fModule.xRowid := vt_Rowid;
if vtWrite in Features then begin
fModule.xUpdate := vt_Update;
if vtTransaction in Features then begin
fModule.xBegin := vt_Begin;
fModule.xSync := vt_Sync;
fModule.xCommit := vt_Commit;
fModule.xRollback := vt_RollBack;
end;
if vtSavePoint in Features then begin
fModule.iVersion := 2;
fModule.xSavePoint := vt_SavePoint;
fModule.xRelease := vt_Release;
fModule.xRollBackTo := vt_RollBackTo;
end;
fModule.xRename := vt_Rename;
end;
sqlite3_check(aDB.DB,sqlite3.create_module_v2(aDB.DB,pointer(fModuleName),fModule,
self,sqlite3InternalFreeModule)); // raise ESQLite3Exception on error
fDB := aDB; // mark successfull create_module() for sqlite3InternalFreeModule
end;
{ TSQLVirtualTableModuleServerDB }
constructor TSQLVirtualTableModuleServerDB.Create(
aClass: TSQLVirtualTableClass; aServer: TSQLRestServer);
begin
if not aServer.InheritsFrom(TSQLRestServerDB) then
raise EBusinessLayerException.CreateFmt('%.Create expects a DB Server',[ClassName]);
inherited;
Attach(TSQLRestServerDB(aServer).DB);
// any exception in Attach() will let release the instance by the RTL
end;
{ TSQLRestStorageShardDB }
constructor TSQLRestStorageShardDB.Create(aClass: TSQLRecordClass;
aServer: TSQLRestServer; aShardRange: TID; aOptions: TSQLRestStorageShardOptions;
const aShardRootFileName: TFileName; aMaxShardCount: integer;
aSynchronous: TSQLSynchronousMode; aCacheSizePrevious,aCacheSizeLast: Integer);
begin
fShardRootFileName := aShardRootFileName;
fSynchronous := aSynchronous;
fCacheSizePrevious := aCacheSizePrevious;
fCacheSizeLast := aCacheSizeLast;
inherited Create(aClass,aServer,aShardRange,aOptions,aMaxShardCount);
end;
function TSQLRestStorageShardDB.DBFileName(ShardIndex: Integer): TFileName;
begin
result := Format('%s%.4d.dbs',[fShardRootFileName,fShardOffset+ShardIndex]);
end;
function TSQLRestStorageShardDB.InitNewShard: TSQLRest;
var db: TSQLRestServerDB;
cachesize: integer;
sql: TSQLDataBase;
model: TSQLModel;
begin
inc(fShardLast);
model := TSQLModel.Create([fStoredClass],FormatUTF8('shard%',[fShardLast]));
if fInitShardsIsLast then // last/new .dbs = 2MB cache, previous 1MB only
cachesize := fCacheSizeLast else
cachesize := fCacheSizePrevious;
sql := TSQLDatabase.Create(DBFileName(fShardLast),'',0,cachesize);
sql.LockingMode := lmExclusive;
sql.Synchronous := fSynchronous;
db := TSQLRestServerDB.Create(model,sql,false,true);
model.Owner := db;
db.CreateMissingTables;
result := db;
SetLength(fShards,fShardLast+1);
fShards[fShardLast] := result;
end;
procedure TSQLRestStorageShardDB.InitShards;
var f,i,num,first: integer;
db: TFindFilesDynArray;
mask: TFileName;
begin
if fShardRootFileName='' then
fShardRootFileName := ExeVersion.ProgramFilePath+UTF8ToString(fStoredClass.SQLTableName);
mask := DBFileName(0);
i := Pos('0000',mask);
if i>0 then begin
system.Delete(mask,i,3);
mask[i] := '*';
end else
mask := fShardRootFileName+'*.dbs';
db := FindFiles(ExtractFilePath(mask),ExtractFileName(mask),'',{sorted=}true);
if db=nil then
exit; // no existing data
fShardOffset := -1;
first := length(db)-integer(fMaxShardCount);
if first<0 then
first := 0;
for f := first to high(db) do begin
i := Pos('.dbs',db[f].Name);
if (i<=4) or not TryStrToInt(Copy(db[f].Name,i-4,4),num) then begin
InternalLog('InitShards(%)?',[db[f].Name],sllWarning);
continue;
end;
if fShardOffset<0 then
fShardOffset := num;
dec(num,fShardOffset);
if not SameText(DBFileName(num),db[f].Name) then
raise EORMException.CreateUTF8('%.InitShards(%)',[self,db[f].Name]);
if f = high(db) then
fInitShardsIsLast := true;
fShardLast := num-1; // 'folder\root0005.dbs' -> fShardLast := 4
InitNewShard; // now fShardLast=5, fShards[5] contains root005.dbs
end;
if fShardOffset<0 then
fShardOffset := 0;
if Integer(fShardLast)<0 then begin
InternalLog('InitShards?',sllWarning);
exit;
end;
fInitShardsIsLast := true; // any newly appended .dbs would use 2MB of cache
fShardLastID := fShards[fShardLast].TableMaxID(fStoredClass);
if fShardLastID<0 then
fShardLastID := 0; // no data yet
end;
function RegisterVirtualTableModule(aModule: TSQLVirtualTableClass; aDatabase: TSQLDataBase): TSQLVirtualTableModule;
begin
result := TSQLVirtualTableModuleSQLite3.Create(aModule,nil);
try
TSQLVirtualTableModuleSQLite3(result).Attach(aDatabase);
except
on Exception do begin
result.Free; // should be released by hand here
raise; // e.g. EBusinessLayerException or ESQLite3Exception
end;
end;
end;
initialization
{$ifdef WITHLOG}
// all our SynSQlite3 related functions shall log to main TSQLLog
SynSQLite3Log := TSQLLog;
{$endif}
TSQLRestServerDB.RegisterClassNameForDefinition;
end.
Reference in New Issue View Git Blame Copy Permalink