// To enable debugging remove the dot. Do NOT forget to re-insert before // deploying to production since this feature will slow down this component // significantly {.$DEFINE DEBUG_ENABLED } // Enables Debug information {.$DEFINE DEBUG_VERY_LOUD} {.$DEFINE DEBUG_LOUD} // Disable this for ignoring IProvider interface (for D4) {$DEFINE IPROVIDER} // enable this if you want to link the SQLite library statically. (No need for dll) {.$DEFINE SQLite_Static} {$I asqlite_def.inc} unit ASGSQLite3; {*_* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * Author: Albert Drent Description: SQLite 3 DataSet class (encapsulates the Delphi DataSet Class) based upon the asqlite version for sqlite 2 Target: Delphi 4, 5, 6 and 7; Delphi 2005; Borland C++ 5 and 6 Creation: November 2003 Version: 2006.03.D Stable EMail: a.drent@aducom.com (www.aducom.com/sqlite, sqlite.aducom.com) Support: support@aducom.com (supportforum on www.aducom.com) Please post any questions, remarks etc. to the support forum. We useually answer questions within days. Unsollicited mail to support will be intercepted by our spamfilters and probabely never be heard of. Legal issues: Copyright (C) 2003..2006 by Aducom Software Aducom Software Eckhartstr 61 9746 BN Groningen Netherlands Open Source licence (BSD: http://www.opensource.org/licenses/bsd-license.php) Copyright (c) 2006, Aducom Software All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. Neither the name of Aducom Software nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Acknowledgement These components were written for our own needs. Since SQLite is a freeware component we like to donate this one to the community too. Parts of the code is adapted from several sources, but mainly from a sample and the vcl sources of Borland itself. And, of course, we did a lot and still are... To Do A lot... We are very busy, but will develop on our needs. If anyone can contribute, please feel welcome. Alter the source with lots of comment and mail it to me. If it works right I will add it to the official source and add your credit here below. Before you start, please put a request on the forum. It would be a shame and a waste of your time if you develop something which already is... and I need to set the spamfilter right to let you pass through. History: Nov 8, 2003 First alpha release 1.0.A Albert Drent (c) 2003 Aducom Software Nov 11, Release alpha 1.0.B Albert Drent (c) 2003 Aducom Software - added 'param' support - fixed null pointer assignment - added support for partial select (limit / offset) Nov 12, Release alpha 1.0.C Albert Drent (c) 2003 Aducom Software - fixed bug in update - support for events - added 'RowsAffected' Nov 16, Release beta 1.0.D Albert Drent (c) 2003 Aducom Software - fixed 0 resultlist after any ExecSQL usage - added Transaction support Nov 24, Release beta 1.0.E Albert Drent (c) 2003 Aducom Software - StartTransaction will open database if it is'nt already open - Changed resultset method - Added property editor for table names - Added GetTableNames function to TASQLite3Database - Added GetIndexNames function to TASQLite3Database - Added Open and Close function to TASQLite3Database - Added AutoCommit property to TDataSet descendants - Split of source in designtime and runtime package Dec 15, Release beta 1.0.F Albert Drent (c) 2003 Aducom Software - Optimized code for speed - Added support for quering databases - Added property for base directory (default dir) TDatabase - Preparations for mastersets and TUpdateSQL (not functional yet) - Solved GPF on stringfields - Solved hangup of Delphi when developing - Solved invalid pointer operation bug while developing Jan 11 2004, Release beta 1.0.G Albert Drent (c) 2003, 2004 Aducom Software - Fixed GetTableNames Bug as reported on forum - Solved some minor bugs, several code optimizations - Added 'getfieldnames' procedure to asqlitedb - Added component asqlitepragma for adjustments to sqlite behaviour - Added several property editors to smooth things up - Added component asqliteupdatesql - Added master-detail support for TASQLite3table (not fully tested yet) - Added master-detail support for TASQLite3query (not fully tested yet) - Added filter property to TASQLite3Query Jan 18, 2004, Release beta 1.0.H Albert Drent (c) 2003, 2004 Aducom Software - Added TASQLite3Log component - Support for autoincrement (index primary key) Jan 22, 2004, Release beta 1.0.I Albert Drent (c) 2003, 2004 Aducom Software - Solved bug, causing the user to open database first (where it should be opened automatically after open query or table. - datatype text is now treated as a string of max 255 chars. - added samples - added preparations for import and export component Jan 26, 2004, Release beta 1.1.A Albert Drent (c) 2003, 2004 Aducom Software - Support for master-detail - Support for TUpdateSQL Feb 05, 2004, Release beta 1.1.B Albert Drent (c) 2003, 2004 Aducom Software - Solved small bug: basequery is closed on querychanged event - Solved small bug: basequery is closed on filter change event - Solved bug in design package, by Marc Wetzel(forum) - Notification of BaseQuery removed and added to SQLiteTable Feb 24, 2004 Release alpha 1.2.A Albert Drent (c) 2003, 2004 Aducom Software - Locate implemented, working on resultset! - Some small bugfixes Feb 25, 2004 Release alpha 1.2.B Albert Drent (c) 2003, 2004 Aducom Software - Reformat of source (Marc Wetzel) - All the debug directives (Marc Wetzel) The debug stuff is added to be able to do more debugging on the components. At this stage there are still some isues which are hard to be find. - Some small bugfixes (Marc Wetzel) - Solved bug with dblookupcombobox, lookup is now shown (variant error) - Derived more classes from TDataset to solve compatibility isues with 3rd party software (DevExpress) - Start of port to lower Delphi versions (designintf vs dsgnintf) March 25, 2004 Release alpha 1.2.C Albert Drent (c) 2003, 2004 Aducom Software - Added property editor for database directory - Added property editor for sqlitedll directory - Bugix needed for release 13 of SQLite.dll (is compatible to lower dll versions) - More changes to solve compatibility problem with DevExpress (Plato of DevExpress) - Solved some compatibility isues with TDataSet - Solved some compatibility isues with the newest SQLite version (2.8.12) - Added/modified, GetFieldNames, GetPrimaryKeys - Added GetTableInfo - Added StartTransaction and Commit and RollBack to TTable and TQuery This will create a more readable source: db.starttranaction; q.somesql db.commit becomes now with q do begin starttransaction; somesql; try commit; except rollback; end; end; - Changed cleanup of components in notification (TheSneak) - Fixed potential AV (so far not reported) - Changed escape of string characters (TheSneak) (might cause incompatibility of older components if you use single quote in data) - Fixed question mark problem in data (TheSneak) April 7, 2004 - Fixed bug GetxxxxNames, moved pragma (reported by Martini) - Improved some performance isues (TheSneak) - Added GetTableIndexNames(by Martini) - Added support for 'small text blobs', it isn't the real stuff but limited to 20000 characters. - Fixed another compatibility isue with DevExpress April 8, 2004 - Fixed EnableControls (TheSneak) - Fixed memoryleak ASQLiteQuery.InternalPost (TheSneak) - Downgraded some stuff for support Delphi 4/5 - Updated Locate function (by Joel hottcha@juno.com) April 14, 2004 Release beta 1.2.C Albert Drent (c) 2003, 2004 Aducom Software - RawSQL property implemented (supresses parsing of sql data) - published csv release as 1.2.C beta April 15, 2004 Release alpha 2.0.A Albert Drent (c) 2003, 2004 Aducom Software - support for real clobs - added fieldtype numeric(x.y) - Implement RawSQL property in TASQLite3Query May 26, 2004 Release beta 2.0.B Albert Drent (c) 2003, 2004 Aducom Software - new procedure: GetGetLastInsertRow - new component: TASQLite3InlineSQL, to be used to contain all kinds of pre-stored sql statements. I.e. for creation of tables in case of an in-memory database, or a local storage for sql statements to simplify sourcecode. In this release it is bound to the ASQLiteDB component. - new component TASQLite3Output, to be used to generate csv files, xml and html documents. It is NOT bound to ASQLite components but to a datasource (containing any database connection) - implemented bound as described by minhl on the forum - implemented IsNull as described by Kazooie64 on the forum - implemented a uniform datetime implementation by jpierce May, 26, 2004 Release beta 2.0.B Albert Drent (c) 2003, 2004 Aducom Software - A few bugfixes June, 15, 2004 Release beta 2.0.C Albert Drent (c) 2003, 2004 Aducom Software - A few bugfixes, thanks to Tzvetan July 2004, Release 1.0 based upon source sqlite version 2 components Okt 11, 2004 Release beta 1.0.B Albert Drent (c) 2003, 2004 Aducom Software - Callback routine for retieving data replaced by new by sqlite prefered way. - Some bugfixes - Support for calculated fields - Support for real blobs okt 14, 2004 Release beta 1.0.C Albert Drent (c) 2003, 2004 Aducom Software - support for locate lo-partial key (thanks to Bob Mitchel) - some bugfixes (thanks to Oleg Lembievskiy marked by OL) - some other bugfixes and code cleanup okt 18, 2004 - re-introduced sqlite_version - added transactiontype property(SQLite3 feature) - added transaction procedures to db and basequery StartDeferredTransaction; StartImmediateTransaction; StartExclusiveTransaction; nov 1, 2004 - bugfix (thanx to James) for null pointer assignment on null values nov 8, 2004 - fixed introduced bug in result preventing new records to appear right in dbgrids. nov 17, 2004 - fixed small bug showing rubish on empty tables Nov 17, 2004 by Mike Dijkema - filter bug FPrepared := FPrepared + ' and ' + Filter adds ' and filterexpr' to the end of the sql statement this created errors with 'order by' 'limit' 'union' 'having' etc.. filtering changed to that it works like the ADO components and union and other statements now 'select a from b union select c from d' and 'select a from b order by c' works with a filter - filter bug 'select a_where from b' removed jan 11, 2005 Release 2005.01.A Albert Drent (c) 2003 .. 2005 Aducom Software - fixed bug causing fielddescription to be deleted incorrectly - fixed bug causing errormessage on null values in integer fields - added sqlcursor property - modifications to support Delphi 2005 - implemented all transactiontypes - changed all showmessages to raise event types - added readonly property feb 21, 2005 Release 2005.02.A Albert Drent (c) 2003 .. 2005 Aducom Software - some bugfixes, code optimization - first implementation of IProvider support (thanks to Rocco Barbaresco) - changed default SDB extension to SQB - support for multi sql statements in one string - added master-detail functionality on insert of new child record (key-data is copied) - added compatibility with SQLite3.dll version 3.1.2 feb 28, 2005 Release 2005.02.B Albert Drent (c) 2003 .. 2005 Aducom Software - bugfix for filter on master-detail. Setting filtered will not automatical open table any more. Causes error on closed tables in master-detail otherwise. mar 7, 2005 Release 2005.03.A Albert Drent (c) 2003 .. 2005 Aducom Software - bugfix for memofields causing crlf to be handled wrongly - added TableExists function ('// DI Ralf http://www.yunqa.de/delphi/) - some code optimizations ('// DI Ralf http://www.yunqa.de/delphi/) - solved decimalpoint bug ('// DI Ralf http://www.yunqa.de/delphi/) mar 10, 2005 Release 2005.03.B Albert Drent (c) 2003 .. 2005 Aducom Software - more code optimizations - removed Forms from uses list to decrease codesize of console app's - changed cursorstyle handling - changed exception handling mar 29, 2005 Release 2005.03.C Albert Drent (c) 2003 .. 2005 Aducom Software - removed default pragma's for tables - implemented another solution for tableheader duplicates (mirko) - implemented user version - solved minor bug in GetTableInfo april 5, 2005 Release 2005.04.A Albert Drent (c) 2003 .. 2005 Aducom Software - fixed bug conceirning in-memory database (Bert Verhees) - fixed precompiler settings for Delhpi 7 (Dak) mai 31, 2005 Release 2005.05.A Albert Drent (c) 2003 .. 2005 Aducom Software - UTF8 support (thanks to Bilgehan KUYUCU) - Statical linking (thanks to Gianpaolo Avallone (GPA) - Some bugfixes and enhancements by Albert, Gianpaolo and others. august 1, 2005 Release 2005.08.A - UTF8 support to be set by property, solving a 'locale' problem. - Bugfix for null strings - Fix for static linking - Solved bug in updatesql, fieldlist is now setup correctly - solved bug in updatesql, inserting null values and constants. august 2, 2005 Release 2005.08.B - first steps towards support utf16 (by Kevin Zhang) - implemented another locate routine (by jbannon) - changed treatment of datatype text. It is considered 'longtext' now. added 'shorttext' datatype which replaces the original 'text' datatype. The datatype text is now compatible with sqlite3, mysql and perhaps others. sept 1, 2005 Release 2005.09.A - code optimizations by Kevin Lu, Aducom sept 1, 2005 Release 2005.09.B - candidate fix for decimal point problem by Jordi March sept 20, 2005 Release 2005.09.C - implementation of unidirectional dataset. This improves performance on large resultsets to the optimum. However the dataset is readonly by default, using inserts/deletes and updates will result in a 'database table is locked' error. sept 21, 2005 Release 2005.09.D - bugfix for decimal point routine by Kevin Lu sept 29, 2005 Release 2005.09.E - bugfix for unidirectional dataset. - bugfix for split of prepare and execute. Data was not updated correctly nov 1, 2005 Release 2005.11.A - Code improvements - First (alpha) implementation of Lookup field (By John Lito) dec 14, 2005 Release 2005.12.A - Check for null values jan 5, 2006 Release 2006.01.A - fixed unidirectional bug (I) jan 9, 2006 Release 2006.01.B - fixed unidirectional bug (II) - automatically will close table if tablename property is changed while a table is still open. - automatically close query if sql property is changed while a table is still open. - fixes for compilation under D4 - changes for installation under Delphi 2005 and 2006 - changes of copyright notice, the components are now under open-source bsd licence. feb 22, 2006 Release 2006.02.A - Changed status to stable mar 2, 2006 Release 2006.03.A - Modifications for D4/D5 - Added order by property. Enter fieldnames separated by ',' - Added GetIndexFieldNames (thanks to zavu10n) - Database will be reopened if necessary on filter change - Fixes by Donnie - New routine for dates and floates by Donnie mar 8, 2006 Release 2006.03.B - Fixed small bug causing text treated as char 255, is now memo. mar 15, 2006 Release 2006.03.C - Added switch for compilation under D4/D5 (Art Register) - DBOpen change for utf8 by John Lito - SQLCursor fix - GetFieldValue fix by Velis mar 23, 2006 Release 2006.03.D - Compatibility fixes for D45 (Art Register) - changed D45 directive to $IFDEF ASQLITE_D6PLUS so compilation should work automatically now - changed cr cr/lf pairs for compatibilty with D4/D5 - added CompareBookmarks to support multiple selection in DBGrid (Michael S) - added support for char *nothing* datatype (was char(1) now char is allowed) *_* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * } interface uses DB, DBCommon, Dialogs, Classes, Windows, SysUtils, {$IFDEF ASQLITE_D6PLUS} Variants, {$ENDIF} ASGRout3; const SQLiteVersion = 'ASGSQLite V2006.03.D stable'; MaxBuf = 30000; // max stringbuffer for record (length) (excluding blob's) SQLITE_OK = 0; // Successful result */ SQLITE_ERROR = 1; // SQL error or missing database */ SQLITE_INTERNAL = 2; // An internal logic error in SQLite */ SQLITE_PERM = 3; // Access permission denied */ SQLITE_ABORT = 4; // Callback routine requested an abort */ SQLITE_BUSY = 5; // The database file is locked */ SQLITE_LOCKED = 6; // A table in the database is locked */ SQLITE_NOMEM = 7; // A malloc() failed */ SQLITE_READONLY = 8; // Attempt to write a readonly database */ SQLITE_INTERRUPT = 9; // Operation terminated by sqlite_interrupt() */ SQLITE_IOERR = 10; // Some kind of disk I/O error occurred */ SQLITE_CORRUPT = 11; // The database disk image is malformed */ SQLITE_NOTFOUND = 12; // (Internal Only) Table or record not found */ SQLITE_FULL = 13; // Insertion failed because database is full */ SQLITE_CANTOPEN = 14; // Unable to open the database file */ SQLITE_PROTOCOL = 15; // Database lock protocol error */ SQLITE_EMPTY = 16; // (Internal Only) Database table is empty */ SQLITE_SCHEMA = 17; // The database schema changed */ SQLITE_TOOBIG = 18; // Too much data for one row of a table */ SQLITE_CONSTRAINT = 19; // Abort due to contraint violation */ SQLITE_MISMATCH = 20; // Data type mismatch */ SQLITE_MISUSE = 21; // Library used incorrectly */ SQLITE_NOLFS = 22; // Uses OS features not supported on host */ SQLITE_AUTH = 23; // Authorization denied */ SQLITE_ROW = 100; // sqlite_step() has another row ready */ SQLITE_DONE = 101; // sqlite_step() has finished executing */ SQLITE_CREATE_INDEX = 1; // Index Name Table Name */ SQLITE_CREATE_TABLE = 2; // Table Name NULL */ SQLITE_CREATE_TEMP_INDEX = 3; // Index Name Table Name */ SQLITE_CREATE_TEMP_TABLE = 4; // Table Name NULL */ SQLITE_CREATE_TEMP_TRIGGER = 5; // Trigger Name Table Name */ SQLITE_CREATE_TEMP_VIEW = 6; // View Name NULL */ SQLITE_CREATE_TRIGGER = 7; // Trigger Name Table Name */ SQLITE_CREATE_VIEW = 8; // View Name NULL */ SQLITE_DELETE = 9; // Table Name NULL */ SQLITE_DROP_INDEX = 10; // Index Name Table Name */ SQLITE_DROP_TABLE = 11; // Table Name NULL */ SQLITE_DROP_TEMP_INDEX = 12; // Index Name Table Name */ SQLITE_DROP_TEMP_TABLE = 13; // Table Name NULL */ SQLITE_DROP_TEMP_TRIGGER = 14; // Trigger Name Table Name */ SQLITE_DROP_TEMP_VIEW = 15; // View Name NULL */ SQLITE_DROP_TRIGGER = 16; // Trigger Name Table Name */ SQLITE_DROP_VIEW = 17; // View Name NULL */ SQLITE_INSERT = 18; // Table Name NULL */ SQLITE_PRAGMA = 19; // Pragma Name 1st arg or NULL */ SQLITE_READ = 20; // Table Name Column Name */ SQLITE_SELECT = 21; // NULL NULL */ SQLITE_TRANSACTION = 22; // NULL NULL */ SQLITE_UPDATE = 23; // Table Name Column Name */ SQLITE_ATTACH = 24; // Filename NULL */ SQLITE_DETACH = 25; // Database Name NULL */ SQLITE_DENY = 1; // Abort the SQL statement with an error */ SQLITE_IGNORE = 2; // Don't allow access, but don't generate an error */ Crlf : string = #13#10; Q = ''''; type pInteger = ^integer; pPointer = ^Pointer; pSmallInt = ^smallint; pFloat = ^extended; pBoolean = ^boolean; TConvertBuffer = array[1..255] of char; TSQLite3_Callback = function(UserData: Pointer; ColumnCount: Integer; ColumnValues, ColumnNames: PPointer): Integer; cdecl; // TSQLiteExecCallback = function(Sender: TObject; Columns: integer; ColumnValues: Pointer; ColumnNames: Pointer): integer of object; cdecl; TSQLiteBusyCallback = function(Sender: TObject; ObjectName: PAnsiChar; BusyCount: integer): integer of object; cdecl; TOnData = procedure(Sender: TObject; Columns: integer; ColumnNames, ColumnValues: string) of object; TOnBusy = procedure(Sender: TObject; ObjectName: string; BusyCount: integer; var Cancel: boolean) of object; TOnQueryComplete = procedure(Sender: TObject) of object; TASQLite3NotifyEvent = procedure(Sender: TObject) of object; // structure for holding field information. It is used by GetTableInfo TASQLite3Field = class public FieldNumber: integer; FieldName: string; FieldType: string; FieldNN: integer; // 1 if notnull FieldDefault: string; FieldPK: integer; // 1 if primary key end; // object to 'play' with SQLite's default settings TASQLite3Pragma = class(TComponent) private FTempCacheSize: integer; FDefaultCacheSize: integer; FDefaultSynchronous: string; FDefaultTempStore: string; FTempStore: string; FSynchronous: string; protected function GetTempCacheSize: string; function GetDefaultCacheSize: string; function GetDefaultSynchronous: string; function GetDefaultTempStore: string; function GetTempStore: string; function GetSynchronous: string; published { Published declarations } property TempCacheSize: integer read FTempCacheSize write FTempCacheSize; property DefaultCacheSize: integer read FDefaultCacheSize write FDefaultCacheSize; property DefaultSynchronous: string read FDefaultSynchronous write FDefaultSynchronous; property DefaultTempStore: string read FDefaultTempStore write FDefaultTempStore; property TempStore: string read FTempStore write FTempStore; property Synchronous: string read FSynchronous write FSynchronous; end; // component to log messages // it's for debugging purpose and may be obsolete due // to the event implementation. not sure yet... TASQLite3Log = class(TComponent) private FLogFile: string; FLogDebugOut: boolean; FAppend: boolean; FLogSQL: boolean; FLogInt: boolean; protected public procedure Display(Msg: string); published { Published declarations } property LogFile: string read FLogFile write FLogFile; property LogDebugOut: boolean read FLogDebugOut write FLogDebugOut; // 20040225 property Append: boolean read FAppend write FAppend; property LogSQL: boolean read FLogSQL write FLogSQL; property LogInternals: boolean read FLogInt write FLogInt; end; // This component can be used to store sql outside the pascal source. // It is useful for automatically creating tables on open of a temporary database // (i.e. in-memory database) TASQLite3InlineSQL = class(TComponent) private FSQL: TStrings; procedure SetSQL(const Value: TStrings); function GetSQL: TStrings; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; published property SQL: TStrings read GetSQL write SetSQL; end; { Basic Database component } TASQLite3DB = class(TComponent) private { Private declarations } FAfterConnect: TASQLite3NotifyEvent; FBeforeConnect: TASQLite3NotifyEvent; FAfterDisconnect: TASQLite3NotifyEvent; FBeforeDisconnect: TASQLite3NotifyEvent; function FGetDefaultExt: string; function FGetDriverDLL: string; protected { Protected declarations } FInlineSQL: TASQLite3InlineSQL; FExecuteInlineSQL: boolean; FDatabase: string; FTransactionType: string; FSQLiteVersion: string; FDefaultExt: string; FDefaultDir: string; FDriverDll: string; FConnected: boolean; FMustExist: boolean; FVersion: string; FCharEnc: string; FUtf8: boolean; DBHandle: Pointer; FASQLitePragma: TASQLite3Pragma; FASQLiteLog: TASQLite3Log; FLastError: string; SQLite3_Open: function(dbname: PAnsiChar; var db: pointer): integer; cdecl; SQLite3_Close: function(db: pointer): integer; cdecl; SQLite3_Exec: function(DB: Pointer; SQLStatement: PAnsiChar; Callback: TSQLite3_Callback; UserDate: Pointer; var ErrMsg: PAnsiChar): Integer; cdecl; SQLite3_LibVersion: function(): PAnsiChar; cdecl; SQLite3_ErrorString: function(db: pointer): PAnsiChar; cdecl; SQLite3_GetTable: function(db: Pointer; SQLStatement: PAnsiChar; var ResultPtr: Pointer; var RowCount: cardinal; var ColCount: cardinal; var ErrMsg: PAnsiChar): integer; cdecl; SQLite3_FreeTable: procedure(Table: PAnsiChar); cdecl; SQLite3_FreeMem: procedure(P: PAnsiChar); cdecl; SQLite3_Complete: function(P: PAnsiChar): boolean; cdecl; SQLite3_LastInsertRow: function(db: Pointer): integer; cdecl; SQLite3_Cancel: procedure(db: Pointer); cdecl; SQLite3_BusyHandler: procedure(db: Pointer; CallbackPtr: Pointer; Sender: TObject); cdecl; SQLite3_BusyTimeout: procedure(db: Pointer; TimeOut: integer); cdecl; SQLite3_Changes: function(db: Pointer): integer; cdecl; SQLite3_Prepare: function(db: Pointer; SQLStatement: PAnsiChar; nBytes: integer; var hstatement: pointer; var Tail: PAnsiChar): integer; cdecl; SQLite3_Finalize: function(hstatement: pointer): integer; cdecl; SQLite3_Reset: function(hstatement: pointer): integer; cdecl; SQLite3_Step: function(hstatement: pointer): integer; cdecl; SQLite3_Column_blob: function(hstatement: pointer; iCol: integer): pointer; cdecl; SQLite3_Column_bytes: function(hstatement: pointer; iCol: integer): integer; cdecl; SQLite3_Column_count: function(hstatement: pointer): integer; cdecl; SQLite3_Column_decltype: function(hstatement: pointer; iCol: integer): PAnsiChar; cdecl; SQLite3_Column_double: function(hstatement: pointer; iCol: integer): double; cdecl; SQLite3_Column_int: function(hstatement: pointer; iCol: integer): integer; cdecl; SQLite3_Column_int64: function(hstatement: pointer; iCol: integer): int64; cdecl; SQLite3_Column_name: function(hstatement: pointer; iCol: integer): PAnsiChar; cdecl; SQLite3_Column_text: function(hstatement: pointer; iCol: integer): PAnsiChar; cdecl; SQLite3_Column_text16: function(hstatement: pointer; iCol: integer): PWideChar; cdecl; SQLite3_Column_type: function(hstatement: pointer; iCol: integer): integer; cdecl; SQLite3_Bind_Blob: function(hstatement: pointer; iCol: integer; buf: PAnsiChar; n: integer; DestroyPtr: Pointer): integer; cdecl; SQLite3_Bind_Text16: function(hstatement: pointer; iCol: integer; buf: pointer; n: integer; DestroyPtr: Pointer): integer; cdecl;//\\\ SQLite3_Bind_Parameter_Count: function(hstatement: pointer): integer; cdecl;//\\\ procedure Notification(AComponent: TComponent; Operation: TOperation); override; procedure DBConnect(Connected: boolean); function SQLite3_PrepareResult(DB: Pointer; TheStatement: string; FParams: TParams; Sender: TObject) : pointer; function SQLite3_GetNextResult(DB: Pointer; TheStatement: pointer; FParams: TParams; Sender: TObject) : pointer; procedure SQLite3_CloseResult(TheStatement : pointer); public DLLHandle: THandle; { Public declarations } constructor Create(AOwner: TComponent); override; destructor Destroy; override; function LoadLibs: boolean; procedure FSetDatabase(Database: string); function RowsAffected: integer; function TableExists(const ATableName: AnsiString): Boolean; procedure ExecStartTransaction(TransType: string); procedure StartTransaction; procedure StartDeferredTransaction; procedure StartImmediateTransaction; procedure StartExclusiveTransaction; procedure Open; procedure Close; procedure Commit; procedure RollBack; procedure ShowDatabases(List: TStrings); procedure GetTableNames(List: TStrings; SystemTables: boolean = false); procedure GetTableInfo(TableName: string; List: TList); procedure GetIndexNames(List: TStrings; SystemTables: boolean = false); procedure GetIndexFieldNames(IndexName: string; List: TStrings); procedure GetFieldNames(TableName: string; List: TStrings); procedure GetPrimaryKeys(TableName: string; List: TStrings); procedure GetTableIndexNames(TableName: string; List: TStrings); procedure ExecPragma; // function SQLite_XExec(db: Pointer; SQLStatement: PAnsiChar; // CallbackPtr: Pointer; Sender: TObject; var ErrMsg: PAnsiChar): integer; cdecl; function SQLite3_Execute(db: Pointer; TheStatement: string; FParams: TParams; Sender: TObject): integer; function SQLite3_ExecSQL(TheStatement: string; Blobs: TList=nil): integer; procedure ShowError; function GetUserVersion(database : string=''): integer; procedure SetUserVersion(Version : integer; Database : string=''); published { Published declarations } property CharacterEncoding: string read FCharEnc write FCharEnc; property TransactionType: string read FTransactionType write FTransactionType; property Database: string read FDatabase write FSetDatabase; property ASQLitePragma: TASQLite3Pragma read FASQLitePragma write FASQLitePragma; property ASQLiteLog: TASQLite3Log read FASQLiteLog write FASQLiteLog; property DefaultExt: string read FGetDefaultExt write FDefaultExt; property DefaultDir: string read FDefaultDir write FDefaultDir; property Version: string read FVersion write FVersion; // property CharacterEncoding: string Read FCharEncoding Write FCharEncoding; property DriverDLL: string read FGetDriverDLL write FDriverDLL; property Connected: boolean read FConnected write DBConnect; property MustExist: boolean read FMustExist write FMustExist; property ASQLiteInlineSQL: TASQLite3InlineSQL read FInlineSQL write FInlineSQL; property ExecuteInlineSQL: boolean read FExecuteInlineSQL write FExecuteInlineSQL; property AfterConnect: TASQLite3NotifyEvent read FAfterConnect write FAfterConnect; property BeforeConnect: TASQLite3NotifyEvent read FBeforeConnect write FBeforeConnect; property AfterDisconnect: TASQLite3NotifyEvent read FAfterDisconnect write FAfterDisconnect; property BeforeDisconnect: TASQLite3NotifyEvent read FBeforeDisconnect write FBeforeDisconnect; end; AsgError = class(Exception); { TRecInfo } { This structure is used to access additional information stored in each record buffer which follows the actual record data. Buffer: PAnsiChar; || \/ -------------------------------------------- | Record Data | Bookmark | Bookmark Flag | -------------------------------------------- ^-- PRecInfo = Buffer + FRecInfoOfs Keep in mind that this is just an example of how the record buffer can be used to store additional information besides the actual record data. There is no requirement that TDataSet implementations do it this way. For the purposes of this demo, the bookmark format used is just an integer value. For an actual implementation the bookmark would most likely be a native bookmark type (as with BDE), or a fabricated bookmark for data providers which do not natively support bookmarks (this might be a variant array of key values for instance). The BookmarkFlag is used to determine if the record buffer contains a valid bookmark and has special values for when the dataset is positioned on the "cracks" at BOF and EOF. } PRecInfo = ^TRecInfo; TRecInfo = packed record Bookmark : integer; BookmarkFlag : TBookmarkFlag; // Nulls : end; //============================================================================== TFResult // The TFResult class is used to maintain the resultlist in memory. This // will only be the case for 'normal' data. Blobs and Clobs will be treated // differently, but they are not supported yet. //============================================================================== TASQLite3BaseQuery = class; TFResult = class protected Data: TList; BookMark: TList; RowId: TList; FLastBookmark: integer; FBufSize: integer; FDataSet: TASQLite3BaseQuery; public constructor Create(TheDataSet: TASQLite3BaseQuery); destructor Destroy; override; procedure FreeBlobs; procedure SetBufSize(TheSize: integer); procedure Add(TheBuffer: PAnsiChar; TheRowId: integer); procedure Insert(Index: integer; TheBuffer: Pointer; TheRowId: integer); procedure Delete(Index: integer); function GetData(Index: integer): Pointer; function Count: integer; function IndexOf(TheBookMark: pointer): integer; function GetBookmark(Index: integer): integer; function GetRowId(Index: integer): integer; end; //============================================================================== TASQLite3UpdateSQL TASQLite3UpdateSQL = class(TComponent) private FInsertSQL: TStrings; FUpdateSQL: TStrings; FDeleteSQL: TStrings; procedure SetInsertSQL(const Value: TStrings); procedure SetUpdateSQL(const Value: TStrings); procedure SetDeleteSQL(const Value: TStrings); public constructor Create(AOwner: TComponent); override; destructor Destroy; override; published property InsertSQL: TStrings read FInsertSQL write SetInsertSQL; property UpdateSQL: TStrings read FUpdateSQL write SetUpdateSQL; property DeleteSQL: TStrings read FDeleteSQL write SetDeleteSQL; end; //============================================================================== TASQLite3Output TASQLite3Output = class(TComponent) private FActive: boolean; FOutputType: string; FTableClass: string; FHeaderClass: string; FCellClass: string; FOutput: TStrings; FSeparator: string; FDataSource: TDataSource; procedure SetOutput(const Value: TStrings); procedure SetFActive(Active: boolean); function GetOutput: TStrings; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Execute(MyDataSet: TDataSet); protected procedure Notification(AComponent: TComponent; Operation: TOperation); override; published property Active: boolean read FActive write SetFActive; property DataSource: TDataSource read FDataSource write FDataSource; property OutputType: string read FOutputType write FOutputType; property TableClass: string read FTableClass write FTableClass; property HeaderClass: string read FHeaderClass write FHeaderClass; property CellClass: string read FCellClass write FCellClass; property Output: TStrings read GetOutput write SetOutput; property FieldSeparator: string read FSeparator write FSeparator; end; //============================================================================== TASQLite3BaseQuery TASQLite3BaseQuery = class(TDataSet) private FParams: TParams; FTypeLess: boolean; FNoResults: boolean; // suppresses the creation of a result list FAutoCommit: boolean; FTransactionType: string; FTableDateFormat: string; FSQLiteDateFormat: boolean; FResult: TFResult; FSQL: TStrings; FSQLCursor: boolean; FPrepared: string; FRecBufSize: integer; FRecInfoOfs: integer; FCurRec: integer; FMasterFields: string; FMasterSource: TDataSource; FSaveChanges: boolean; MaxStrLen: integer; FConnection: TASQLite3DB; FReadOnly: boolean; FMaxResults: integer; FStartResult: integer; FUniDir : boolean; FStatement : pointer; CurrentRowId: integer; SQLStr: string; ResultStr: PAnsiChar; RowId : integer; RowIdCol : integer; DetailList: TList; procedure SetSQL(const Value: TStrings); function UnpackBuffer(Buffer: PAnsiChar; FieldType: TFieldType): TConvertBuffer; procedure SetDataSource(Value: TDataSource); protected function SetQueryParams(InStr: string): string; //*** procedure SetParamsList(Value: TParams); function GetParamsCount: word; procedure RegisterDetailDataset(DetailDataSet: TASQLite3BaseQuery); procedure LoadQueryData; function GetActiveBuffer(var Buffer: PAnsiChar): boolean; function GetDataSource: TDataSource; override; procedure NotifySQLiteMasterChanged; function GetFieldValue(const AField: TField; const Blobs: TList = nil): string; // added by Donnie { Overriden abstract methods (required) } function AllocRecordBuffer: PAnsiChar; override; procedure FreeRecordBuffer(var Buffer: PAnsiChar); override; procedure GetBookmarkData(Buffer: PAnsiChar; Data: Pointer); override; function GetBookmarkFlag(Buffer: PAnsiChar): TBookmarkFlag; override; function GetRecord(Buffer: PAnsiChar; GetMode: TGetMode; DoCheck: boolean): TGetResult; override; function GetRecordSize: word; override; procedure InternalAddRecord(Buffer: Pointer; Append: boolean); override; procedure InternalClose; override; procedure InternalDelete; override; procedure InternalFirst; override; procedure InternalGotoBookmark(Bookmark: Pointer); override; procedure InternalHandleException; override; procedure InternalInitFieldDefs; override; procedure InternalInitRecord(Buffer: PAnsiChar); override; procedure InternalLast; override; procedure InternalOpen; override; procedure InternalPost; override; procedure InternalSetToRecord(Buffer: PAnsiChar); override; procedure OpenCursor(InfoQuery: Boolean); override; // GPA function IsCursorOpen: boolean; override; procedure SetBookmarkFlag(Buffer: PAnsiChar; Value: TBookmarkFlag); override; procedure SetBookmarkData(Buffer: PAnsiChar; Data: Pointer); override; procedure SetFieldData(Field: TField; Buffer: Pointer); override; function GetFieldSize(FieldNo: integer): integer; overload; function GetFieldSize(Field: TField): integer; overload; function GetNativeFieldSize(FieldNo: integer): integer; function GetFieldOffset(FieldNo: integer): integer; function GetCalcFieldOffset(Field: TField): integer; function GetMasterFields: string; procedure SetMasterFields(const Value: string); { Additional overrides (optional) } function GetRecordCount: integer; override; function GetRecNo: integer; override; procedure SetRecNo(Value: integer); override; property BaseSQL: TStrings read FSQL write SetSQL; procedure SetSQLiteDateFormat(const Value: boolean); procedure SetFilterText(const Value: string); override; procedure DataConvert(Field: TField; Source, Dest: Pointer; ToNative: Boolean); override;//\\\ function CalcFieldInList(const List: string): Boolean; // John Lito {$IFDEF IPROVIDER} {***** IProviderSupport - Begin *****} //-----| These are not necessary until the moment! // procedure PSGetAttributes(List: TList); virtual; // function PSGetDefaultOrder: TIndexDef; virtual; // function PSGetIndexDefs(IndexTypes: TIndexOptions): TIndexDefs; virtual; //-----| These are necessary to support IProvider procedure PSEndTransaction(Commit: Boolean); override; procedure PSExecute; override; function PSExecuteStatement(const ASQL: string; AParams: TParams; ResultSet: Pointer = nil): Integer; override; function PSGetParams: TParams; override; function PSGetTableName: string; override; function PSGetUpdateException(E: Exception; Prev: EUpdateError): EUpdateError; override; function PSInTransaction: Boolean; override; function PSIsSQLBased: Boolean; override; function PSIsSQLSupported: Boolean; override; procedure PSReset; override; procedure PSSetCommandText(const CommandText: string); override; procedure PSSetParams(AParams: TParams); override; procedure PSStartTransaction; override; function PSUpdateRecord(UpdateKind: TUpdateKind; Delta: TDataSet): Boolean; override; function PSGetQuoteChar: string; override; function PSGetKeyFields: string; override; {***** IProviderSupport - End *****} {$ENDIF} public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure ExecSQL; procedure StartTransaction; procedure StartDeferredTransaction; procedure StartImmediateTransaction; procedure StartExclusiveTransaction; procedure Commit; procedure RollBack; procedure SetFiltered(Value: Boolean); override; procedure SQLiteMasterChanged; virtual; function GetFieldData(Field: TField; Buffer: Pointer): boolean; override; function GetFieldData(FieldNo: integer; Buffer: Pointer): boolean; override; // 20040225 function GetLastInsertRow: integer; {$IFDEF ASQLITE_D6PLUS} // function GetFieldData(Field: TField; Buffer: Pointer; NativeFormat: boolean): boolean; override; {$ENDIF} function CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Integer; override; //MS function CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; override; function Locate(const KeyFields: string; const KeyValues: variant; Options: TLocateOptions): boolean; override; function BookmarkValid(Bookmark: Pointer): boolean; override; // function LocateNearest(const KeyFields: String; const KeyValues: Variant; Options: TLocateOptions): Boolean; property Params: TParams read FParams write SetParamsList stored false; function Lookup(const KeyFields: string; const KeyValues: Variant; // John Lito const ResultFields: string): Variant; override; // John Lito published property AutoCommit: boolean read FAutoCommit write FAutoCommit default true; property TransactionType: string read FTransactionType write FTransactionType; property SQLiteDateFormat: boolean read FSQLiteDateFormat write SetSQLiteDateFormat; property TableDateFormat: string read FTableDateFormat write FTableDateFormat; property Connection: TASQLite3DB read FConnection write FConnection; property MaxResults: integer read FMaxResults write FMaxResults; property StartResult: integer read FStartResult write FStartResult; property TypeLess: boolean read FTypeLess write FTypeLess; property MasterFields: string read GetMasterFields write SetMasterFields; property MasterSource: TDataSource read GetDataSource write SetDataSource; property SQLCursor: boolean read FSQLCursor write FSQLCursor; property ReadOnly: boolean read FreadOnly write FReadOnly; property UniDirectional : boolean read FUniDir write FUniDir; property AutoCalcFields; property Filter; property Filtered; property Active; property BeforeOpen; property AfterOpen; property BeforeClose; property AfterClose; property BeforeInsert; property AfterInsert; property BeforeEdit; property AfterEdit; property BeforePost; property AfterPost; property BeforeCancel; property AfterCancel; property BeforeDelete; property AfterDelete; property BeforeScroll; property AfterScroll; {$IFDEF ASQLITE_D6PLUS} property BeforeRefresh; property AfterRefresh; {$ENDIF} property OnCalcFields; property OnDeleteError; property OnEditError; property OnNewRecord; property OnPostError; end; //============================================================================== TASQLite3Query TASQLite3Query = class(TASQLite3BaseQuery) private FUpdateSQL: TASQLite3UpdateSQL; FRawSQL: boolean; procedure SetSQL(const Value: TStrings); function GetSQL: TStrings; procedure QueryChanged(Sender: TObject); protected procedure InternalOpen; override; procedure InternalPost; override; procedure InternalDelete; override; procedure Notification(AComponent: TComponent; Operation: TOperation); override; procedure InternalClose; override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; // property Params: TParams Read FParams Write SetParamsList Stored false; procedure SQLiteMasterChanged; override; published property RawSQL: boolean read FRawSQL write FRawSQL; property SQL: TStrings read GetSQL write SetSQL; property UpdateSQL: TASQLite3UpdateSQL read FUpdateSQL write FUpdateSQL; end; //============================================================================== TASQLite3Table TASQLite3Table = class(TASQLite3BaseQuery) private FTableName: string; FOrderBy : string; FPrimaryAutoInc: boolean; protected procedure Notification(AComponent: TComponent; Operation: TOperation); override; procedure InternalOpen; override; procedure InternalPost; override; procedure InternalDelete; override; procedure SetFTableName(TableName : string); procedure SetFOrderBy(OrderBy : string); public procedure SQLiteMasterChanged; override; published property TableName: string read FTableName write SetFTableName; property PrimaryAutoInc: boolean read FPrimaryAutoInc write FPrimaryAutoInc; property OrderBy : string read FOrderBy write SetFOrderBy; end; //============================================================================== TASQLite3BlobStream TASQLite3BlobStream = class(TMemoryStream) private FField: TBlobField; FDataSet: TASQLite3BaseQuery; FMode: TBlobStreamMode; FModified: Boolean; FOpened: Boolean; procedure LoadBlobData; procedure SaveBlobData; public constructor Create(Field: TBlobField; Mode: TBlobStreamMode); destructor Destroy; override; function Read(var Buffer; Count: Longint): Longint; override; function Write(const Buffer; Count: Longint): Longint; override; end; implementation uses Math {$IFDEF ASQLITE_D6PLUS} , StrUtils {$endif} ; // GPA - Static Link Start {$IFDEF SQLite_Static} Var __HandlerPtr:Pointer; {$L 'OBJ\sqlite3.obj'} {$L 'OBJ\files.obj'} {$L 'OBJ\strlen.obj'} {$L 'OBJ\assert.obj'} {$L 'OBJ\memcmp.obj'} {$L 'OBJ\memcpy.obj'} {$L 'OBJ\memset.obj'} {$L 'OBJ\strcmp.obj'} {$L 'OBJ\strcpy.obj'} {$L 'OBJ\strcat.obj'} {$L 'OBJ\strncmp.obj'} {$L 'OBJ\strncpy.obj'} {$L 'OBJ\strncat.obj'} {$L 'OBJ\sprintf.obj'} {$L 'OBJ\fprintf.obj'} {$L 'OBJ\_ll.obj'} {$L 'OBJ\ltoupper.obj'} {$L 'OBJ\ltolower.obj'} {$L 'OBJ\atol.obj'} {$L 'OBJ\ftol.obj'} {$L 'OBJ\longtoa.obj'} {$L 'OBJ\hrdir_r.obj'} {$L 'OBJ\gmtime.obj'} {$L 'OBJ\tzdata.obj'} {$L 'OBJ\initcvt.obj'} {$L 'OBJ\streams.obj'} {$L 'OBJ\scantod.obj'} {$L 'OBJ\scanwtod.obj'} {$L 'OBJ\allocbuf.obj'} {$L 'OBJ\bigctype.obj'} {$L 'OBJ\clocale.obj'} {$L 'OBJ\clower.obj'} {$L 'OBJ\cupper.obj'} {$L 'OBJ\fflush.obj'} {$L 'OBJ\fputn.obj'} {$L 'OBJ\hrdir_s.obj'} {$L 'OBJ\mbisspc.obj'} {$L 'OBJ\mbsrchr.obj'} {$L 'OBJ\realcvt.obj'} {$L 'OBJ\realcvtw.obj'} {$L 'OBJ\timefunc.obj'} {$L 'OBJ\vprinter.obj'} {$L 'OBJ\hugeval.obj'} {$L 'OBJ\cvtfak.obj'} {$L 'OBJ\getinfo.obj'} {$L 'OBJ\qmul10.obj'} {$L 'OBJ\fuildq.obj'} {$L 'OBJ\_pow10.obj'} {$L 'OBJ\ldtrunc.obj'} {$L 'OBJ\cvtfakw.obj'} {$L 'OBJ\wis.obj'} {$L 'OBJ\xfflush.obj'} {$L 'OBJ\flushout.obj'} {$L 'OBJ\lputc.obj'} {$L 'OBJ\hrdir_b.obj'} {$L 'OBJ\realloc.obj'} {$L 'OBJ\mbctype.obj'} {$L 'OBJ\xcvt.obj'} {$L 'OBJ\xcvtw.obj'} {$L 'OBJ\wcscpy.obj'} {$L 'OBJ\errno.obj'} {$L 'OBJ\ctrl87.obj'} {$L 'OBJ\timedata.obj'} {$L 'OBJ\int64toa.obj'} {$L 'OBJ\cvtentry.obj'} {$L 'OBJ\mbyte1.obj'} {$L 'OBJ\errormsg.obj'} {$L 'OBJ\exit.obj'} {$L 'OBJ\iswctype.obj'} {$L 'OBJ\heap.obj'} {$L 'OBJ\memmove.obj'} {$L 'OBJ\fxam.obj'} {$L 'OBJ\fuistq.obj'} {$L 'OBJ\qdiv10.obj'} {$L 'OBJ\wmemset.obj'} {$L 'OBJ\wcslen.obj'} {$L 'OBJ\_tzset.obj'} {$L 'OBJ\deflt87.obj'} {$L 'OBJ\mbschr.obj'} {$L 'OBJ\mbsrchr.obj'} {$L 'OBJ\ermsghlp.obj'} {$L 'OBJ\patexit.obj'} {$L 'OBJ\initexit.obj'} {$L 'OBJ\virtmem.obj'} {$L 'OBJ\tzset.obj'} {$L 'OBJ\mbisdgt.obj'} {$L 'OBJ\mbsnbcpy.obj'} {$L 'OBJ\platform.obj'} {$L 'OBJ\getenv.obj'} {$L 'OBJ\mbisalp.obj'} {$L 'OBJ\abort.obj'} {$L 'OBJ\signal.obj'} {$L 'OBJ\clear87.obj'} {$L 'OBJ\abort.obj'} {$L 'OBJ\handles.obj'} {$L 'OBJ\_cfinfo.obj'} {$L 'OBJ\__isatty.obj'} {$L 'OBJ\perror.obj'} {$L 'OBJ\fputs.obj'} {$L 'OBJ\files2.obj'} {$L 'OBJ\ioerror.obj'} {$L 'OBJ\__write.obj'} {$L 'OBJ\_write.obj'} {$L 'OBJ\__lseek.obj'} {$L 'OBJ\ioerror.obj'} {$L 'OBJ\setenvp.obj'} {$L 'OBJ\calloc.obj'} {$L 'OBJ\mbsnbcmp.obj'} {$L 'OBJ\mbsnbicm.obj'} {$L 'OBJ\is.obj'} {$L 'OBJ\isctype.obj'} {$L 'OBJ\bigctype.obj'} {$L 'OBJ\globals.obj'} {$L 'OBJ\hrdir_mf.obj'} {$L 'OBJ\fpreset.obj'} {$L 'OBJ\ta.obj'} {$L 'OBJ\setexc.obj'} {$L 'OBJ\defhandl.obj'} function _wsprintfA:integer; external 'user32.dll' name 'wsprintfA'; procedure RtlUnwind; external 'NtDll.dll' name 'RtlUnwind'; function _sqlite3_open(dbname: PAnsiChar; var db: pointer): integer; cdecl; external; function _sqlite3_close(db: pointer): integer; cdecl; external; function _sqlite3_exec(DB: Pointer; SQLStatement: PAnsiChar; Callback: TSQLite3_Callback; UserDate: Pointer; var ErrMsg: PAnsiChar): Integer; cdecl; external; function _sqlite3_libversion: PAnsiChar; cdecl; external; function _sqlite3_errmsg(db: pointer): PAnsiChar; cdecl; external; function _sqlite3_get_table(db: Pointer; SQLStatement: PAnsiChar; var ResultPtr: Pointer; var RowCount: cardinal; var ColCount: cardinal; var ErrMsg: PAnsiChar): integer; cdecl; external; procedure _sqlite3_free_table(Table: PAnsiChar); cdecl; external; procedure _sqlite3_free(P: PAnsiChar); cdecl; external; function _sqlite3_complete(P: PAnsiChar): boolean; cdecl; external; function _sqlite3_last_insert_rowid(db: Pointer): integer; cdecl; external; procedure _sqlite3_interrupt(db: Pointer); cdecl; external; procedure _sqlite3_busy_handler(db: Pointer; CallbackPtr: Pointer; Sender: TObject); cdecl; external; procedure _sqlite3_busy_timeout(db: Pointer; TimeOut: integer); cdecl; external; function _sqlite3_changes(db: Pointer): integer; cdecl; external; function _sqlite3_prepare(db: Pointer; SQLStatement: PAnsiChar; nBytes: integer; var hstatement: pointer; var Tail: PAnsiChar): integer; cdecl; external; function _sqlite3_finalize(hstatement: pointer): integer; cdecl; external; function _sqlite3_reset(hstatement: pointer): integer; cdecl; external; function _sqlite3_step(hstatement: pointer): integer; cdecl; external; function _sqlite3_column_blob(hstatement: pointer; iCol: integer): pointer; cdecl; external; function _sqlite3_column_bytes(hstatement: pointer; iCol: integer): integer; cdecl; external; function _sqlite3_column_count(hstatement: pointer): integer; cdecl; external; function _sqlite3_column_decltype(hstatement: pointer; iCol: integer): PAnsiChar; cdecl; external; function _sqlite3_column_double(hstatement: pointer; iCol: integer): double; cdecl; external; function _sqlite3_column_int(hstatement: pointer; iCol: integer): integer; cdecl; external; function _sqlite3_column_int64(hstatement: pointer; iCol: integer): int64; cdecl; external; function _sqlite3_column_name(hstatement: pointer; iCol: integer): PAnsiChar; cdecl; external; function _sqlite3_column_text(hstatement: pointer; iCol: integer): PAnsiChar; cdecl; external; function _sqlite3_column_type(hstatement: pointer; iCol: integer): integer; cdecl; external; function _sqlite3_bind_blob(hstatement: pointer; iCol: integer; buf: PAnsiChar; n: integer; DestroyPtr: Pointer): integer; cdecl; external; {$ENDIF} // GPA - Static Link End {$IFDEF DEBUG_ENABLED} var DebugSpaces : Integer = 0; {$ENDIF} {$IFNDEF ASQLITE_D6PLUS} //Art Register - Function sign not provided in Delphi 5 function Sign(I: Integer) : Integer ; begin if (I > 0) then Result := 1 else begin if (I < 0) then Result := -1 else Result := 0; end; end; {$ENDIF} procedure Debug(const S: string); begin {$IFDEF DEBUG_ENABLED} OutputDebugString(PAnsiChar(StringOfChar(' ', DebugSpaces) + S)); {$ENDIF} end; procedure DebugEnter(const S: string); begin {$IFDEF DEBUG_ENABLED} OutputDebugString(PAnsiChar(StringOfChar(' ', DebugSpaces) + 'Enter ' + S)); inc(DebugSpaces); {$ENDIF} end; procedure DebugLeave(const S: string); begin {$IFDEF DEBUG_ENABLED} dec(DebugSpaces); OutputDebugString(PAnsiChar(StringOfChar(' ', DebugSpaces) + 'Leave ' + S)); {$ENDIF} end; //============================================================================== // SyntaxCheck. This routine is used to check if words match the sql syntax // It is called where sql statements are parsed and generated //============================================================================== function SyntaxCheck(LWord, RWord: string): boolean; begin DebugEnter('SyntaxCheck'); try if CompareText(LWord, RWord) <> 0 then begin SyntaxCheck := false; raise AsgError.Create('SQL macro syntax error on sql, expected ' + RWord) end else SyntaxCheck := true; finally DebugLeave('SyntaxCheck'); end; end; //============================================================================== // Parse the SQL fielddescription and return the Delphi Field types, length etc. //============================================================================== procedure GetFieldInfo(FieldInfo: string; var FieldType: TFieldType; var FieldLen, FieldDec: integer); var p1, p2, pn : integer; vt : string; begin DebugEnter('GetFieldInfo'); FieldType := ftString; // just a default; FieldLen := 255; FieldDec := 0; p1 := pos('(', FieldInfo); if p1 <> 0 then begin p2 := pos(')', FieldInfo); if p2 <> 0 then begin vt := LowerCase(Copy(FieldInfo, 1, p1 - 1)); if (vt = 'varchar') or (vt = 'char') or (vt = 'varchar2') then begin FieldType := ftString; FieldLen := StrToInt(Copy(FieldInfo, p1 + 1, p2 - p1 - 1)); end else if (vt = 'nvarchar') or (vt = 'nchar') or (vt = 'nvarchar2') then begin FieldType := ftWideString; FieldLen := StrToInt(Copy(FieldInfo, p1 + 1, p2 - p1 - 1)) * 2; end else if (vt = 'numeric') then begin vt := Copy(FieldInfo, p1 + 1, p2 - p1 - 1); pn := pos('.', vt); if pn = 0 then pn := pos(',', vt); FieldType := ftFloat; if pn = 0 then begin FieldLen := StrToInt(vt); FieldDec := 0; end else begin FieldLen := StrToInt(Copy(vt, 1, pn - 1)); FieldDec := StrToInt(Copy(vt, pn + 1, 2)); end; end; end else FieldLen := 256; end else begin vt := LowerCase(FieldInfo); if vt = 'date' then begin FieldType := ftDate; FieldLen := 10; end else if vt = 'datetime' then begin FieldType := ftDateTime; // fpierce original ftDate FieldLen := 24; // aducom end else if vt = 'time' then begin FieldType := ftTime; FieldLen := 12; end {$IFDEF ASQLITE_D6PLUS} else if vt = 'timestamp' then begin FieldType := ftTimeStamp; FieldLen := 12; end {$ENDIF} else if (vt = 'integer') or (vt = 'int') then begin FieldType := ftInteger; FieldLen := 12; end else if (vt = 'float') or (vt = 'real') then begin FieldType := ftFloat; FieldLen := 12; end else if (vt = 'boolean') or (vt = 'logical') then begin FieldType := ftBoolean; FieldLen := 2; end else if (vt = 'char') or (vt = 'byte') then begin FieldType := ftString; FieldLen := 1; end else if (vt = 'shorttext') or (vt = 'string') then begin FieldType := ftString; FieldLen := 255; end else if (vt = 'widetext') or (vt = 'widestring') then begin FieldType := ftWideString; FieldLen := 512; end else if (vt = 'currency') or (vt = 'financial') or (vt = 'money') then begin FieldType := ftCurrency; FieldLen := 10; end else if (vt = 'blob') then begin FieldType := ftBlob; FieldLen := SizeOf(Pointer); end else if (vt = 'graphic') then begin FieldType := ftGraphic; FieldLen := SizeOf(Pointer); end else if (vt = 'clob') or (vt = 'memo') or (vt = 'text') or (vt = 'longtext') then begin FieldType := ftMemo; FieldLen := SizeOf(Pointer); end; end; DebugLeave('GetFieldInfo: ' + vt); end; //============================================================================== // Convert TDateTime to TDateTimeRec //============================================================================== function DateTimeToNative(DataType: TFieldType; Data: TDateTime): TDateTimeRec; var TimeStamp : TTimeStamp; begin DebugEnter('DateTimeToNative'); TimeStamp := DateTimeToTimeStamp(Data); case DataType of ftDate: Result.Date := TimeStamp.Date; ftTime: Result.Time := TimeStamp.Time; else Result.DateTime := TimeStampToMSecs(TimeStamp); end; DebugLeave('DateTimeToNative'); end; procedure ApplicationHandleException(Sender: TObject); begin {$IFDEF ASQLITE_D6PLUS} if Assigned(Classes.ApplicationHandleException) then Classes.ApplicationHandleException(Sender); {$ENDIF} end; //============================================================================== TASQLite3LOG procedure TASQLite3Log.Display(Msg: string); var fn : Textfile; begin DebugEnter('TASQLite3Log.Display'); if FileExists(FLogFile) then begin if FAppend then begin AssignFile(fn, FLogFile); System.Append(fn); end else begin SysUtils.DeleteFile(FLogFile); AssignFile(fn, FLogFile); Rewrite(fn); end; end else begin AssignFile(fn, FLogFile); Rewrite(fn); end; Writeln(fn, FormatDateTime('yyyy mmm dd (hh:nn:ss) ', now) + Msg); CloseFile(fn); DebugLeave('TASQLite3Log.Display'); end; //============================================================================== TASQLite3PRAGMA function TASQLite3Pragma.GetTempCacheSize: string; begin DebugEnter('TASQLite3Pragma.GetTempCacheSize'); GetTempCacheSize := 'pragma cache_size=' + IntToStr(FTempCacheSize); DebugLeave('TASQLite3Pragma.GetTempCacheSize'); end; function TASQLite3Pragma.GetDefaultCacheSize: string; begin DebugEnter('TASQLite3Pragma.GetDefaultCacheSize'); GetDefaultCacheSize := 'pragma default_cache_size=' + IntToStr(FDefaultCacheSize); DebugLeave('TASQLite3Pragma.GetDefaultCacheSize'); end; function TASQLite3Pragma.GetDefaultSynchronous: string; begin DebugEnter('TASQLite3Pragma.GetDefaultSynchronous'); GetDefaultSynchronous := 'pragma default_synchronous=' + FDefaultSynchronous; DebugLeave('TASQLite3Pragma.GetDefaultSynchronous'); end; function TASQLite3Pragma.GetDefaultTempStore: string; begin DebugEnter('TASQLite3Pragma.GetDefaultTempStore'); GetDefaultTempStore := 'pragma default_temp_store=' + FDefaultTempStore; DebugLeave('TASQLite3Pragma.GetDefaultTempStore'); end; function TASQLite3Pragma.GetTempStore: string; begin DebugEnter('TASQLite3Pragma.GetTempStore'); GetTempStore := 'pragma temp_store=' + FTempStore; DebugLeave('TASQLite3Pragma.GetTempStore'); end; function TASQLite3Pragma.GetSynchronous: string; begin DebugEnter('TASQLite3Pragma.GetSynchronous'); GetSynchronous := 'pragma synchronous=' + FSynchronous; DebugLeave('TASQLite3Pragma.GetSynchronous'); end; //============================================================================== TFRESULT // TResult is a representation of an internal pointerlist of results. // Only 'normal' results will be stored internally within a fixed memory block // depending on calculated length internally. This is not the case // for blobs and clobs. In this case only the handle is stored in the fixed // structure and a separate memory handle is retrieved to store the blob and // clob data. This is because the blobs are stored as null terminated 'strings' // and thus have different lengths. No more memory is allocated this way than // strictly necessary. // KEEP IN MIND: ... // This resultset is NOT used for unidirectional search results. You can // however, open a dbgrid containing griddata. You cannot update your data // if you use the unidirectional the result is read-only by default and cannot // be changed. // The unidirectional dataset improves performance on large resultsets and // is to be considered for query-only components... //============================================================================== constructor TFResult.Create(TheDataSet: TASQLite3BaseQuery); begin DebugEnter('TFResult.Create'); Data := TList.Create; Bookmark := TList.Create; RowId := TList.Create; FDataSet := TheDataset; FLastBookmark := -1; // 2004-14-09 (rps) 0 -> -1 (otherwise insert in an empty table gives index out of range) DebugLeave('TFResult.Create'); end; destructor TFResult.Destroy; var ptr : Pointer; i : integer; begin DebugEnter('TFResult.Destroy'); FreeBlobs; if Assigned(Data) then begin for i := 0 to Data.Count - 1 do begin ptr := Data.Items[i]; if Assigned(ptr) then FreeMem(ptr, FBufSize); end; Data.Free; // D4 compatibility, otherwise FreeAndNil could be used Data := nil; end; if Assigned(Bookmark) then begin Bookmark.Free; Bookmark := nil; end; if Assigned(RowId) then begin RowId.Free; RowId := nil; end; DebugLeave('TFResult.Destroy'); end; procedure TFResult.FreeBlobs; var i, j : integer; offset : integer; ptr : PAnsiChar; stream : TMemoryStream; begin if not Assigned(FDataSet) then exit; if not Assigned(FDataSet.FieldList) then exit; for j := 0 to Data.Count - 1 do begin ptr := GetData(j); for i := 0 to FDataSet.FieldList.Count - 1 do begin if FDataSet.FieldList[i].DataType in [ftMemo, ftFmtMemo, ftGraphic, ftBlob] then begin Offset := FDataset.GetFieldOffset(FDataSet.FieldList[i].FieldNo); Move((ptr + Offset)^, Pointer(Stream), sizeof(Pointer)); Stream.Free; end; end; end; end; procedure TFResult.SetBufSize(TheSize: integer); begin DebugEnter('TFResult.SetBufSize'); FBufSize := TheSize; DebugLeave('TFResult.SetBufSize'); end; //============================================================================== // Adds a row of data to the resultset. //============================================================================== procedure TFResult.Add(TheBuffer: PAnsiChar; TheRowId: integer); var ptr : PAnsiChar; // i: integer; begin {$IFDEF DEBUG_VERY_LOUD} DebugEnter('TFResult.Add'); {$ENDIF} Inc(FLastBookmark); GetMem(Ptr, FBufSize); move(TheBuffer^, ptr^, FBufSize); Data.Add(Ptr); Bookmark.Add(Pointer(FLastBookMark)); if TheRowId >= 0 then RowId.Add(Pointer(TheRowId)) else RowId.Add(Pointer(RowId.Count)); {$IFDEF DEBUG_VERY_LOUD} DebugLeave('TFResult.Add'); {$ENDIF} end; //============================================================================== // Inserts a row of date into the resultset //============================================================================== procedure TFResult.Insert(Index: integer; TheBuffer: pointer; TheRowId: integer); var ptr : Pointer; begin DebugEnter('TFResult.Insert'); Inc(FLastBookmark); GetMem(Ptr, FBufSize); move(TheBuffer^, ptr^, FBufSize); if Data.Count < Index then begin Data.Add(Ptr); Bookmark.Add(Pointer(FLastBookMark)); RowId.Add(Pointer(TheRowId)); end else begin Data.Insert(Index, Ptr); Bookmark.Insert(Index, Pointer(FLastBookMark)); RowId.Insert(Index, Pointer(TheRowId)); end; DebugLeave('TFResult.Insert'); end; //============================================================================== // Deletes a row of data from the resultset //============================================================================== procedure TFResult.Delete(Index: integer); var ptr : pointer; begin DebugEnter('TFResult.Delete'); if not ((Index < 0) or (Index >= Data.Count)) then begin ptr := Data.Items[Index]; if ptr <> nil then FreeMem(ptr, FBufSize); Data.Delete(Index); Bookmark.Delete(Index); Rowid.Delete(Index); end; DebugLeave('TFResult.Delete'); end; //============================================================================== // Returns a row from the resultset //============================================================================== function TFResult.GetData(Index: integer): Pointer; begin DebugEnter('TFResult.GetData'); if (Index < 0) or (Index >= Data.Count) then GetData := nil else GetData := Data.Items[Index]; DebugLeave('TFResult.GetData'); end; function TFResult.GetBookmark(Index: integer): integer; begin DebugEnter('TFResult.GetBookmark'); if (Index < 0) or (Index >= Data.Count) then GetBookmark := -1 else GetBookmark := integer(Bookmark.Items[Index]); DebugLeave('TFResult.GetBookmark'); end; function TFResult.GetRowId(Index: integer): integer; begin DebugEnter('TFResult.GetRowId'); if (Index < 0) or (Index >= RowId.Count) then GetRowId := -1 else GetRowId := integer(RowId.Items[Index]); DebugLeave('TFResult.GetRowId'); end; function TFResult.Count: integer; begin Count := Data.Count; end; function TFResult.IndexOf(TheBookMark: pointer): integer; begin Result := BookMark.IndexOf(TheBookmark); end; //============================================================================== ASQLITEDB procedure TASQLite3DB.Notification(AComponent: TComponent; Operation: TOperation); begin {$IFDEF DEBUG_VERY_LOUD} DebugEnter('TASQLite3DB.Notification'); {$ENDIF} // Application.ProcessMessages; if Assigned(AComponent) then begin if (Operation = opRemove) then begin if (AComponent is TASQLite3Pragma) then begin if Assigned(FASQLitePragma) then begin if TASQLite3Pragma(AComponent) = FASQLitePragma then FASQLitePragma := nil; end; end else if (AComponent is TASQLite3Log) then begin if Assigned(FASQLiteLog) then begin if TASQLite3Log(AComponent) = FASQLiteLog then FASQLiteLog := nil; end; end else if (AComponent is TASQLite3InlineSQL) then begin if Assigned(FInlineSQL) then begin if TASQLite3InlineSQL(AComponent) = FInlineSQL then FInlineSQL := nil; end; end; end; end; inherited; {$IFDEF DEBUG_VERY_LOUD} DebugLeave('TASQLite3DB.Notification'); {$ENDIF} end; function TASQLite3DB.LoadLibs: boolean; begin try DebugEnter('TASQLite3DB.LoadLibs'); if not(DecimalSeparator in ['.',',']) then DecimalSeparator := '.'; Debug('loading sqlite lib'); {$IFNDEF SQLite_Static} Debug(PAnsiChar(DriverDLL)); Result := false; DLLHandle := LoadLibrary(PAnsiChar(DriverDLL)); //JohnLito if DLLHandle <> 0 then begin @SQLite3_Open := GetProcAddress(DLLHandle, 'sqlite3_open'); if not Assigned(@SQLite3_Open) then exit; @SQLite3_Close := GetProcAddress(DLLHandle, 'sqlite3_close'); if not Assigned(@SQLite3_Close) then exit; @SQLite3_Exec := GetProcAddress(DLLHandle, 'sqlite3_exec'); if not Assigned(@SQLite3_Exec) then exit; @SQLite3_LibVersion := GetProcAddress(DLLHandle, 'sqlite3_libversion'); if not Assigned(@SQLite3_LibVersion) then exit; @SQLite3_ErrorString := GetProcAddress(DLLHandle, 'sqlite3_errmsg'); if not Assigned(@SQLite3_ErrorString) then exit; @SQLite3_GetTable := GetProcAddress(DLLHandle, 'sqlite3_get_table'); if not Assigned(@SQLite3_GetTable) then exit; @SQLite3_FreeTable := GetProcAddress(DLLHandle, 'sqlite3_free_table'); if not Assigned(@SQLite3_FreeTable) then exit; @SQLite3_FreeMem := GetProcAddress(DLLHandle, 'sqlite3_free'); if not Assigned(@SQLite3_FreeMem) then exit; @SQLite3_Complete := GetProcAddress(DLLHandle, 'sqlite3_complete'); if not Assigned(@SQLite3_Complete) then exit; @SQLite3_LastInsertRow := GetProcAddress(DLLHandle, 'sqlite3_last_insert_rowid'); if not Assigned(@SQLite3_LastInsertRow) then exit; @SQLite3_Cancel := GetProcAddress(DLLHandle, 'sqlite3_interrupt'); if not Assigned(@SQLite3_Cancel) then exit; @SQLite3_BusyTimeout := GetProcAddress(DLLHandle, 'sqlite3_busy_timeout'); if not Assigned(@SQLite3_BusyTimeout) then exit; @SQLite3_BusyHandler := GetProcAddress(DLLHandle, 'sqlite3_busy_handler'); if not Assigned(@SQLite3_BusyHandler) then exit; @SQLite3_Changes := GetProcAddress(DLLHandle, 'sqlite3_changes'); if not Assigned(@SQLite3_Changes) then exit; @SQLite3_Prepare := GetProcAddress(DLLHandle, 'sqlite3_prepare'); if not Assigned(@SQLite3_Prepare) then exit; @SQLite3_Finalize := GetProcAddress(DLLHandle, 'sqlite3_finalize'); if not Assigned(@SQLite3_Finalize) then exit; @SQLite3_Reset := GetProcAddress(DLLHandle, 'sqlite3_reset'); if not Assigned(@SQLite3_Reset) then exit; @SQLite3_Step := GetProcAddress(DLLHandle, 'sqlite3_step'); if not Assigned(@SQLite3_Step) then exit; @SQLite3_Column_blob := GetProcAddress(DLLHandle, 'sqlite3_column_blob'); if not Assigned(@SQLite3_Column_blob) then exit; @SQLite3_Column_bytes := GetProcAddress(DLLHandle, 'sqlite3_column_bytes'); if not Assigned(@SQLite3_Column_bytes) then exit; @SQLite3_Column_count := GetProcAddress(DLLHandle, 'sqlite3_column_count'); if not Assigned(@SQLite3_Column_Count) then exit; @SQLite3_Column_decltype := GetProcAddress(DLLHandle, 'sqlite3_column_decltype'); if not Assigned(@SQLite3_Column_decltype) then exit; @SQLite3_Column_double := GetProcAddress(DLLHandle, 'sqlite3_column_double'); if not Assigned(@SQLite3_Column_double) then exit; @SQLite3_Column_int := GetProcAddress(DLLHandle, 'sqlite3_column_int'); if not Assigned(@SQLite3_Column_int) then exit; @SQLite3_Column_int64 := GetProcAddress(DLLHandle, 'sqlite3_column_int64'); if not Assigned(@SQLite3_Column_int64) then exit; @SQLite3_Column_name := GetProcAddress(DLLHandle, 'sqlite3_column_name'); if not Assigned(@SQLite3_Column_name) then exit; @SQLite3_Column_text := GetProcAddress(DLLHandle, 'sqlite3_column_text'); if not Assigned(@SQLite3_Column_text) then exit; @SQLite3_Column_text16 := GetProcAddress(DLLHandle, 'sqlite3_column_text16'); if not Assigned(@SQLite3_Column_text16) then exit; @SQLite3_Column_type := GetProcAddress(DLLHandle, 'sqlite3_column_type'); if not Assigned(@SQLite3_Column_type) then exit; @SQLite3_Bind_Blob := GetProcAddress(DLLHandle, 'sqlite3_bind_blob'); if not Assigned(@SQLite3_Bind_blob) then exit; @SQLite3_Bind_Text16 := GetProcAddress(DLLHandle, 'sqlite3_bind_text16'); if not Assigned(@SQLite3_Bind_Text16) then exit; @SQLite3_Bind_Parameter_Count := GetProcAddress(DLLHandle, 'sqlite3_bind_parameter_count'); if not Assigned(@SQLite3_Bind_Parameter_Count) then exit; Result := true; end; {$ELSE} DllHandle := 1; @SQLite3_Open := @_sqlite3_open; @SQLite3_Close := @_sqlite3_close; @SQLite3_Exec := @_sqlite3_exec; @SQLite3_LibVersion := @_sqlite3_libversion; @SQLite3_ErrorString := @_sqlite3_errmsg; @SQLite3_GetTable := @_sqlite3_get_table; @SQLite3_FreeTable := @_sqlite3_free_table; @SQLite3_FreeMem := @_sqlite3_free; @SQLite3_Complete := @_sqlite3_complete; @SQLite3_LastInsertRow := @_sqlite3_last_insert_rowid; @SQLite3_Cancel := @_sqlite3_interrupt; @SQLite3_BusyTimeout := @_sqlite3_busy_timeout; @SQLite3_BusyHandler := @_sqlite3_busy_handler; @SQLite3_Changes := @_sqlite3_changes; @SQLite3_Prepare := @_sqlite3_prepare; @SQLite3_Finalize := @_sqlite3_finalize; @SQLite3_Reset := @_sqlite3_reset; @SQLite3_Step := @_sqlite3_step; @SQLite3_Column_blob := @_sqlite3_column_blob; @SQLite3_Column_bytes := @_sqlite3_column_bytes; @SQLite3_Column_count := @_sqlite3_column_count; @SQLite3_Column_decltype := @_sqlite3_column_decltype; @SQLite3_Column_double := @_sqlite3_column_double; @SQLite3_Column_int := @_sqlite3_column_int; @SQLite3_Column_int64 := @_sqlite3_column_int64; @SQLite3_Column_name := @_sqlite3_column_name; @SQLite3_Column_text := @_sqlite3_column_text; @SQLite3_Column_type := @_sqlite3_column_type; @SQLite3_Bind_Blob := @_sqlite3_bind_blob; Result := true; {$ENDIF} finally DebugLeave('TASQLite3DB.LoadLibs'); end; end; procedure TASQLite3DB.ShowError; var msg : PAnsiChar; begin msg := SQLite3_ErrorString(DBHandle); raise EDatabaseError.Create(msg); end; function TASQLite3DB.SQLite3_ExecSQL(TheStatement: string; Blobs: TList=nil): integer; var PF: PAnsiChar; p: Pointer; i: Integer; b: Integer; m: TMemoryStream; begin TheStatement := StringReplace(TheStatement, #2, '?', [rfReplaceAll, rfIgnoreCase]); PF := PAnsiChar(TheStatement); repeat Result := SQLite3_Prepare(DBHandle, PF, -1, p, PF); if Result = SQLITE_OK then begin if Assigned(Blobs) then begin for i := 0 to Blobs.Count - 1 do Begin b := i+1; m := TMemoryStream(Blobs.Items[i]); SQLite3_Bind_Blob(p, b, PChar(m.Memory), m.Size, nil); End; end; repeat until SQLite3_Step(p) in [SQLITE_DONE, SQLITE_ERROR, SQLITE_MISUSE]; Result := SQLite3_Finalize(p); if Result <> SQLITE_OK then ShowError; end else ShowError; until PF^ = #0; end; function TASQLite3DB.SQLite3_PrepareResult(DB: Pointer; TheStatement: string; FParams: TParams; Sender: TObject): Pointer; var i,tmpi: Integer; t: PAnsiChar; RV: Integer; // RowIdCol: Integer; // column containing rowid // RowId: Integer; // current record row id (to be stored in resultset) colname, coltype: PChar; tmpcolname:string; FieldType: TFieldType; FieldLen: Integer; FieldDec: Integer; bFirst: Boolean; wildcard: Integer; begin if not (Sender is TASQLite3BaseQuery) then Exit; with (Sender as TASQLite3BaseQuery) do begin // if there are blob fields then we need to bind the blob variable RowId := -1; RowIdCol := -1; TheStatement := StringReplace(TheStatement, #2, '?', [rfReplaceAll, rfIgnoreCase]); bFirst := True; {$IFDEF ASQLITE_D6PLUS} if FUtf8 then RV := SQLite3_Prepare(DBHandle, PAnsiChar(AnsiToUtf8(TheStatement)), -1, result, t) else {$endif} RV := SQLite3_Prepare(DBHandle, PAnsiChar(TheStatement), -1, result, t); wildcard := 1; if Assigned(FParams) then begin for i := 0 to FParams.Count - 1 do begin if FParams[i].DataType in [ftBlob, ftGraphic] then begin SQLite3_Bind_Blob(result, wildcard, PChar(FParams[i].AsBlob), FParams[i].GetDataSize, nil); Inc(wildcard); end; end; end; if RV <> 0 then ShowError else begin if bFirst then begin // retrieve metadata on first row bFirst := False; if SQLite3_Column_count(result) > 0 then FieldDefs.Clear; for i := 0 to SQLite3_Column_count(result) - 1 do begin colname := SQLite3_Column_name(result, i); // the second field named "ID", change in "ID_1" (like InterBase) if (FieldDefs.IndexOf(colname) >= 0) then begin // Mirko tmpColName := colname; // Mirko tmpI := 0; // Mirko while (FieldDefs.IndexOf(tmpcolname) >= 0) do begin // Mirko inc(tmpI); // Mirko tmpColName := colname + '_' + inttostr(tmpI); // Mirko end; // Mirko colName := PChar(tmpColName); // Mirko end; // Mirko if CompareText(colname, 'rowid') = 0 then begin RowIdCol := i; end else begin coltype := SQLite3_Column_decltype(result, i); //SQl: select max(CurID) from Items, sqlite3_column_decltype returns null.. it's probably SQLite bug // better is to use max(CurID) as something from .... Aducom if coltype = nil then GetFieldInfo('string', FieldType, FieldLen, FieldDec) //OL else GetFieldInfo(coltype, FieldType, FieldLen, FieldDec); if TypeLess then begin FieldType := ftString; with FieldDefs.AddFieldDef do begin Name := colname; DataType := FieldType; Size := FieldLen; end; end else begin with FieldDefs.AddFieldDef do begin if FieldType <> ftString then begin Name := colname; DataType := FieldType; if FieldType = ftFloat then Precision := FieldDec; end else begin Name := colname; DataType := FieldType; Size := FieldLen; end; end; end; MaxStrLen := MaxStrLen + GetNativeFieldSize(i + 1); // compensate for terminating zero FResult.SetBufSize(MaxStrLen + 1 + SizeOf(TBookMark)); end; end; end; end; end; end; function TASQLite3DB.SQLite3_GetNextResult(DB: Pointer; TheStatement: pointer; FParams: TParams; Sender: TObject) : pointer; var i : integer; minmin : integer; RV: Integer; mv: Integer; // RowIdCol: Integer; // column containing rowid convertbuf: TConvertBuffer; pData: PAnsiChar; BlobStream: TMemoryStream; begin result := nil; with (Sender as TASQLite3BaseQuery) do begin FillChar(ResultStr^, MaxBuf, 0); RV := SQLite3_Step(theStatement); if RV = SQLITE_ROW then begin // retrieve data if (Sender is TASQLite3Query) then MinMin := 1 else MinMin := 1; // compensate for 'rowid' for i := 0 to SQLite3_Column_count(theStatement) - MinMin do begin if i = RowIdCol then begin // just save rowid RowId := SQLite3_Column_int(theStatement, i); end else begin // ok, i can find-out that the fiels is null but.... eh.... // if SQLite3_column_type(theStatement, i) = 5 then begin // end; pData := SQLite3_Column_text(theStatement, i); if pData = nil then pData := ''; // james if FTypeLess then begin mv := GetNativeFieldSize(i + 1); if StrLen(pData) < Cardinal(mv) then mv := StrLen(pData); Move(pData^, (ResultStr + GetFieldOffset(i + 1))^, mv); end else begin case FieldDefs[i].DataType of // DI ftString: // DI begin // DI mv := GetNativeFieldSize(i + 1); if pData <> nil then //OL begin if StrLen(pData) < Cardinal(mv) then mv := StrLen(pData)+1; // plus onennnnnnnnnnnnnnnn Move(pData^, (ResultStr + GetFieldOffset(i + 1))^, mv); end; end; // DI ftMemo, ftGraphic, ftFmtMemo, ftBlob: // DI begin // DI // create memory stream to save blob; pData := SQLite3_Column_blob(theStatement, i); BlobStream := TMemoryStream.Create; if pData <> nil then BlobStream.Write(pData^, SQLite3_Column_bytes(theStatement, i)) else begin pData := ''; BlobStream.Write(pData^, 0); end; Move(BlobStream, (ResultStr + GetFieldOffset(i + 1))^, SizeOf(BlobStream)); end; // DI else // DI begin // DI convertbuf := UnpackBuffer(pData, FieldDefs[i].DataType); Move(convertbuf, (ResultStr + GetFieldOffset(i + 1))^, GetFieldSize(i + 1)); end; end; end; end end; Result := ResultStr; end; if RV in [SQLITE_DONE] then result := nil; if RV in [SQLITE_ERROR, SQLITE_MISUSE] then //f.e. inserting NULL in field declared as NOT NULL ShowError; end; end; procedure TASQLite3DB.SQLite3_CloseResult(TheStatement : pointer); var RV : integer; begin if TheStatement <> nil then begin SQLite3_Reset(TheStatement); RV := SQLite3_Finalize(TheStatement); if RV <> 0 then raise AsgError.Create('SQLiteExecute error: ' + IntToStr(RV)); end; end; function TASQLite3DB.SQLite3_Execute(DB: Pointer; TheStatement: string; FParams: TParams; Sender: TObject): Integer; var p: Pointer; RowIdCol: Integer; // column containing rowid {$IFDEF ASQLITE_D6PLUS} Cursor: TDBScreenCursor; {$endif} begin SQLite3_Execute := 0; RowIdCol := -1; if not (Sender is TASQLite3BaseQuery) then Exit; try with (Sender as TASQLite3BaseQuery) do begin {$IFDEF ASQLITE_D6PLUS} if Assigned(DBScreen) and (FSQLCursor) then begin Cursor := DBScreen.Cursor; DBScreen.Cursor := dcrSQLWait; end; {$endif} RowId := -1; FStatement := Connection.SQLite3_PrepareResult(Connection.DBHandle, PAnsiChar(TheStatement),FParams, Sender); repeat p := Connection.SQLite3_GetNextResult(Connection.DBHandle, FStatement, FParams, Sender); if p <> nil then FResult.Add(ResultStr, RowId); until p = nil; Connection.SQLite3_CloseResult(FStatement); FStatement := nil; end; finally {$IFDEF ASQLITE_D6PLUS} if Assigned(DBScreen) and ((Sender as TASQLite3BaseQuery).FSQLCursor) then begin DBScreen.Cursor := Cursor; if DBScreen.Cursor = dcrSQLWait then DBScreen.Cursor := dcrDefault; end; {$endif} end; end; function TASQLite3DB.FGetDriverDLL: string; begin DebugEnter('TASQLite3DB.FGetDriverDLL'); if FDriverDLL = '' then FDriverDLL := 'SQLite3.dll'; FGetDriverDLL := FDriverDLL; DebugLeave('TASQLite3DB.FGetDriverDLL'); end; function TASQLite3DB.FGetDefaultExt: string; begin DebugEnter('TASQLite3DB.FGetDefaultExt'); if FDefaultExt = '' then FDefaultExt := '.sqb'; FGetDefaultExt := FDefaultExt; DebugLeave('TASQLite3DB.FGetDefaultExt'); end; procedure TASQLite3DB.FSetDatabase(Database: string); begin DebugEnter('TASQLite3DB.FSetDatabase ' + Database); FDatabase := Trim(Database); if ExtractFileExt(FDataBase)='' Then // GPA FDatabase:=FDataBase+FDefaultExt; // GPA DebugLeave('TASQLite3DB.FSetDatabase'); end; procedure TASQLite3DB.ShowDatabases(List: TStrings); var sr : TSearchRec; begin DebugEnter('TASQLite3DB.ShowDatabases'); if DefaultExt = '' then DefaultExt := '.sqb'; if DefaultExt[1] <> '.' then DefaultExt := '.' + DefaultExt; if DefaultDir <> '' then if DefaultDir[Length(DefaultDir)] <> '\' then DefaultDir := DefaultDir + '\'; if FindFirst(FDefaultDir + '*' + DefaultExt, faAnyFile, sr) = 0 then begin repeat List.Add(sr.Name); until FindNext(sr) <> 0; SysUtils.FindClose(sr); end; DebugLeave('TASQLite3DB.ShowDatabases'); end; procedure TASQLite3DB.GetTableNames(List: TStrings; SystemTables: boolean = false); var ResultPtr : Pointer; ResultStr : ^Pointer; RowCount : cardinal; ColCount : cardinal; ErrMsg : PAnsiChar; i : integer; begin DebugEnter('TASQLite3DB.GetTableNames'); if not FConnected then Connected := true; if FConnected then begin SQLite3_GetTable(DBHandle, PAnsiChar( 'SELECT name FROM sqlite_master WHERE type="table" ORDER BY name'), ResultPtr, RowCount, ColCount, ErrMsg); ResultStr := ResultPtr; List.Clear; Inc(ResultStr); // ignore header for i := 1 to RowCount do begin if (CompareText('name', PAnsiChar(ResultStr^)) <> 0) then List.Add(PAnsiChar(ResultStr^)); Inc(ResultStr); end; if Assigned(ResultPtr) then SQLite3_FreeTable(ResultPtr); end; DebugLeave('TASQLite3DB.GetTableNames'); end; procedure TASQLite3DB.GetIndexFieldNames(IndexName: string; List: TStrings); var ResultPtr : Pointer; ResultStr : ^Pointer; RowCount : cardinal; ColCount : cardinal; ErrMsg : PAnsiChar; i : integer; begin DebugEnter('TASQLite3DB.GetIndexFieldNames'); if not FConnected then Connected := true; if FConnected then begin SQLite3_GetTable(DBHandle, PAnsiChar( 'PRAGMA index_info("' + IndexName + '");'), ResultPtr, RowCount, ColCount, ErrMsg); ResultStr := ResultPtr; List.Clear; Inc(ResultStr, 5); for i := 1 to RowCount do begin List.Insert(0, PAnsiChar(ResultStr^)); Inc(ResultStr, 3); end; if Assigned(ResultPtr) then SQLite3_FreeTable(ResultPtr); end; DebugLeave('TASQLite3DB.GetIndexFieldNames'); end; procedure TASQLite3DB.GetIndexNames(List: TStrings; SystemTables: boolean = false); var ResultPtr : Pointer; ResultStr : ^Pointer; RowCount : cardinal; ColCount : cardinal; ErrMsg : PAnsiChar; i : integer; begin DebugEnter('TASQLite3DB.GetIndexNames'); if not FConnected then Connected := true; if FConnected then begin SQLite3_GetTable(DBHandle, PAnsiChar( 'SELECT name FROM sqlite_master WHERE type="index" ORDER BY name'), ResultPtr, RowCount, ColCount, ErrMsg); ResultStr := ResultPtr; List.Clear; Inc(ResultStr); // ignore header for i := 1 to RowCount do begin List.Add(PAnsiChar(ResultStr^)); Inc(ResultStr); end; if Assigned(ResultPtr) then SQLite3_FreeTable(ResultPtr); end; DebugLeave('TASQLite3DB.GetIndexNames'); end; procedure TASQLite3DB.GetFieldNames(TableName: string; List: TStrings); var ResultPtr : Pointer; ResultStr : ^Pointer; RowCount : cardinal; ColCount : cardinal; ErrMsg : PAnsiChar; i : integer; begin DebugEnter('TASQLite3DB.GetFieldNames ' + Tablename); if not FConnected then Connected := true; if FConnected then begin SQLite3_GetTable(DBHandle, PAnsiChar('PRAGMA table_info("' + TableName + '");'), ResultPtr, RowCount, ColCount, ErrMsg); ResultStr := ResultPtr; List.Clear; Inc(ResultStr, 6); // headers can be ignored for i := 1 to RowCount do begin Inc(ResultStr); List.Add(PAnsiChar(ResultStr^)); // the second field contains the fieldname Inc(ResultStr, 5); end; if Assigned(ResultPtr) then SQLite3_FreeTable(ResultPtr); end; DebugLeave('TASQLite3DB.GetFieldNames'); end; procedure TASQLite3DB.GetPrimaryKeys(TableName: string; List: TStrings); var ResultPtr : Pointer; ResultStr : ^Pointer; // PK: ^Pointer; RowCount : cardinal; ColCount : cardinal; ErrMsg : PAnsiChar; Temp : string; i : integer; begin DebugEnter('TASQLite3DB.GetPrimaryKeys ' + Tablename); if not FConnected then Connected := true; if FConnected then begin SQLite3_GetTable(DBHandle, PAnsiChar('PRAGMA table_info("' + TableName + '");'), ResultPtr, RowCount, ColCount, ErrMsg); ResultStr := ResultPtr; List.Clear; Inc(ResultStr, 6); // headers can be ignored for i := 1 to RowCount do begin Inc(ResultStr); Temp := PAnsiChar(ResultStr^); // the second field contains the fieldname Inc(ResultStr, 4); // the last field reveils a indicator for primary key if PAnsiChar(ResultStr^) = '1' then List.Add(Temp); Inc(ResultStr); end; if Assigned(ResultPtr) then SQLite3_FreeTable(ResultPtr); end; DebugLeave('TASQLite3DB.GetPrimaryKeys'); end; procedure TASQLite3DB.GetTableInfo(TableName: string; List: TList); var ResultPtr : Pointer; ResultStr : ^Pointer; RowCount : cardinal; ColCount : cardinal; ErrMsg : PAnsiChar; Field : TASQLite3Field; i : integer; begin DebugEnter('TASQLite3DB.GetTableInfo ' + Tablename); if not FConnected then Connected := true; if FConnected then begin SQLite3_GetTable(DBHandle, PAnsiChar('PRAGMA table_info("' + TableName + '");'), ResultPtr, RowCount, ColCount, ErrMsg); ResultStr := ResultPtr; while List.Count > 0 do begin TASQLite3Field(List[0]).Free; List.Delete(0); end; List.Clear; Inc(ResultStr,6); for i := 1 to RowCount do begin Field := TASQLite3Field.Create; with Field do begin FieldNumber := StrToIntX(PAnsiChar(ResultStr^)); Inc(ResultStr); FieldName := PAnsiChar(ResultStr^); Inc(ResultStr); FieldType := PAnsiChar(ResultStr^); Inc(ResultStr); FieldNN := StrToIntX(PAnsiChar(ResultStr^)); Inc(ResultStr); FieldDefault := PAnsiChar(ResultStr^); Inc(ResultStr); FieldPK := StrToIntX(PAnsiChar(ResultStr^)); Inc(ResultStr); end; List.Add(Field); end; if Assigned(ResultPtr) then SQLite3_FreeTable(ResultPtr); end; DebugLeave('TASQLite3DB.GetTableInfo'); end; // retrieves the user version function TASQLite3DB.GetUserVersion(database : string=''): integer; var ResultPtr : Pointer; ResultStr : ^Pointer; RowCount : cardinal; ColCount : cardinal; ErrMsg : PAnsiChar; begin DebugEnter('TASQLite3DB.GetTableIndexNames'); GetUserVersion := -1; if not FConnected then Connected := true; if FConnected then begin if database <> '' then database := database +'.'; SQLite3_GetTable(DBHandle, PAnsiChar( 'PRAGMA '+Database+'user_version'), ResultPtr, RowCount, ColCount, ErrMsg); ResultStr := ResultPtr; Inc(ResultStr); GetUserVersion := StrToIntX(PAnsiChar(ResultStr^)); end; end; // sets user version. procedure TASQLite3DB.SetUserVersion(Version : integer; Database : string=''); begin if Database <> '' then Database := Database +'.'; SQLite3_ExecSQL('PRAGMA '+Database+'user_version='+IntToStr(Version)); end; procedure TASQLite3DB.GetTableIndexNames(TableName: string; List: TStrings); var ResultPtr : Pointer; ResultStr : ^Pointer; RowCount : cardinal; ColCount : cardinal; ErrMsg : PAnsiChar; i : integer; begin DebugEnter('TASQLite3DB.GetTableIndexNames'); if not FConnected then Connected := true; if FConnected then begin SQLite3_GetTable(DBHandle, PAnsiChar( 'PRAGMA index_list("' + TableName + '");'), ResultPtr, RowCount, ColCount, ErrMsg); ResultStr := ResultPtr; List.Clear; Inc(ResultStr, 4); // Skip header + 1st col. for i := 1 to RowCount do begin List.Insert(0, PAnsiChar(ResultStr^)); Inc(ResultStr, 3); end; if Assigned(ResultPtr) then SQLite3_FreeTable(ResultPtr); end; DebugLeave('TASQLite3DB.GetTableIndexNames'); end; procedure TASQLite3DB.DBConnect(Connected: boolean); var ErrMsg : PAnsiChar; DBMS : string; rv : integer; i : integer; // GPA begin DebugEnter('TASQLite3DB.DBConnect'); // ShowMessage(FCharEnc); if (CompareText(FCharEnc,'utf8')=0) or (FCharEnc='') then FUtf8 := true else FUtf8 := false; if (Connected) and (FDatabase = '') then begin DebugLeave('TASQLite3DB.DBConnect Exit'); raise AsgError.Create('Missing database property'); SQLite3_FreeMem(ErrMsg); FConnected := false; exit; end; if not Connected then begin if FConnected then begin if DLLHandle <> 0 then begin Debug('freeing sqlite dll'); if Assigned(FBeforeDisconnect) then FBeforeDisconnect(self); // if closed then all Datasets must be closed (GPA) if Assigned(Owner) Then For I:=0 to Owner.ComponentCount-1 do if Owner.Components[I] is TASQLite3BaseQuery Then TASQLite3BaseQuery(Owner.Components[I]).Active:=False; if Assigned(@SQLite3_Close) then SQLite3_Close(DBHandle); {$IFNDEF SQLite_Static} FreeLibrary(DLLHandle); {$ENDIF} DLLHandle := 0; if Assigned(FAfterDisconnect) then FAfterDisconnect(self); end; FConnected := false; DebugLeave('TASQLite3DB.DBConnect'); exit; end end else begin if CompareText(':memory:', Database) <> 0 then begin if DefaultDir <> '' then begin if DefaultDir[Length(DefaultDir)] <> '\' then DefaultDir := DefaultDir + '\'; DBMS := DefaultDir + Database; end else begin if Pos('\', Database) = 0 then DBMS := GetCurrentDir + '\' + DataBase else DBMS := Database; end; if FMustExist then begin if not FileExists(DBMS) then begin DebugLeave('TASQLite3DB.DBConnect ' + 'Database ' + DBMS + ' does not exist'); raise EDatabaseError.Create('Database ' + DBMS + ' does not exist'); end; end; end else DBMS := Database; // in memory database if DLLHandle = 0 then begin if not LoadLibs then begin FConnected := false; DebugLeave('TASQLite3DB.DBConnect ' + 'Could Not load SQLite Library'); raise AsgError.Create('Could not load SQLite library'); end; end; FConnected := true; FVersion := SQLite3_LibVersion; DBHandle := nil; ErrMsg := nil; if Assigned(FBeforeConnect) then FBeforeConnect(self); {$IFDEF ASQLITE_D6PLUS} if Assigned(@SQLite3_Open) then if FVersion > '3.2.5' then rv := SQLite3_Open(PAnsiChar(AnsiToUTF8(DBMS)), DBHandle) else {$endif} rv := SQLite3_Open(PAnsiChar(DBMS), DBHandle); if Assigned(FAfterConnect) then FAfterConnect(self); if DBHandle = nil then FConnected := false; if Assigned(FASQLitePragma) then ExecPragma; FLastError := ErrMsg; if ErrMsg <> nil then SQLite3_FreeMem(ErrMsg); // GPA Added to execute InlineSQL in case of use Connected:=True instead of Open if ExecuteInlineSQL and Assigned(FInlineSQL) then Try // GPA ExecStartTransaction(''); // GPA SQLite3_ExecSQL(FInlineSQL.FSQL.Text); // GPA Commit; // GPA finally // GPA ExecuteInlineSQL:=False; //GPA Assure just one execution in case of reopen end; // GPA end; DebugLeave('TASQLite3DB.DBConnect'); end; function TASQLite3DB.RowsAffected: integer; begin DebugEnter('TASQLite3DB.RowsAffected'); if not FConnected then Result := -1 else Result := SQLite3_Changes(DBHandle); DebugLeave('TASQLite3DB.RowsAffected'); end; //------------------------------------------------------------------------------ // By Ralf, The Delphi Inspiration //------------------------------------------------------------------------------ function TableExistsCallback(UserData: Pointer; ColumnCount: Integer; ColumnValues, ColumnNames: PPointer): Integer; cdecl; begin if AnsiStrIComp(UserData, ColumnValues^) <> 0 then Result := 0 else Result := 1; // Abort end; //------------------------------------------------------------------------------ function TASQLite3DB.TableExists(const ATableName: AnsiString): Boolean; var ErrMsg: PAnsiChar; begin try { No WHERE clause is used in the SQL statement below. Instead, the callback function compares without case sensitivity. } Result := SQLite3_Exec(DBHandle, 'SELECT name FROM sqlite_master', TableExistsCallback,Pointer(ATableName), ErrMsg) = SQLITE_ABORT; finally if ErrMsg <> nil then begin SQLite3_FreeMem(ErrMsg); ShowError; end; end; end; //------------------------------------------------------------------------------ procedure TASQLite3DB.ExecStartTransaction(TransType: string); begin // if no transaction type available then use default from asqlitedb if (TransType = '') then TransType := FTransactionType; if ((TransType = '') or (CompareText(TransType, 'DEFAULT') = 0)) then StartTransaction else if (CompareText(TransType, 'DEFERRED') = 0) then StartDeferredTransaction else if (CompareText(TransType, 'IMMEDIATE') = 0) then StartImmediateTransaction else if (CompareText(TransType, 'EXCLUSIVE') = 0) then StartExclusiveTransaction else StartTransaction; end; procedure TASQLite3DB.StartTransaction; begin DebugEnter('TASQLite3DB.StartTransaction'); if not FConnected then // open database if necessary Connected := true; // trigger the 'dbconnect' event if FConnected then SQLite3_ExecSQL('begin transaction'); DebugLeave('TASQLite3DB.StartTransaction'); end; procedure TASQLite3DB.StartDeferredTransaction; begin if not FConnected then // open database if necessary Connected := true; // trigger the 'dbconnect' event if FConnected then SQLite3_ExecSQL('begin deferred transaction'); end; procedure TASQLite3DB.StartImmediateTransaction; begin if not FConnected then // open database if necessary Connected := true; // trigger the 'dbconnect' event if FConnected then SQLite3_ExecSQL('begin immediate transaction'); end; procedure TASQLite3DB.StartExclusiveTransaction; begin if not FConnected then // open database if necessary Connected := true; // trigger the 'dbconnect' event if FConnected then SQLite3_ExecSQL('begin exclusive transaction'); end; procedure TASQLite3DB.Open; begin DebugEnter('TASQLite3DB.Open'); Connected := true; if DLLHandle = 0 then Connected := false; DebugLeave('TASQLite3DB.Open'); end; procedure TASQLite3DB.Close; begin DebugEnter('TASQLite3DB.Close'); Connected := false; DebugLeave('TASQLite3DB.Close'); end; procedure TASQLite3DB.ExecPragma; var Cmd : string; begin DebugEnter('TASQLite3DB.ExecPragma'); if not FConnected then Connected := true; if FConnected then begin if FASQLitePragma.FTempCacheSize <> 0 then begin cmd := FASQLitePragma.GetTempCacheSize; SQLite3_ExecSQL(cmd); end; if FASQLitePragma.FDefaultCacheSize <> 0 then begin cmd := FASQLitePragma.GetDefaultCacheSize; SQLite3_ExecSQL(cmd); end; if FASQLitePragma.FDefaultSynchronous <> '' then begin cmd := FASQLitePragma.GetDefaultSynchronous; SQLite3_ExecSQL(cmd); end; if FASQLitePragma.FDefaultTempStore <> '' then begin cmd := FASQLitePragma.GetDefaultTempStore; SQLite3_ExecSQL(cmd); end; if FASQLitePragma.FTempStore <> '' then begin cmd := FASQLitePragma.GetTempStore; SQLite3_ExecSQL(cmd); end; if FASQLitePragma.FSynchronous <> '' then begin cmd := FASQLitePragma.GetSynchronous; SQLite3_ExecSQL(cmd); end; end; DebugLeave('TASQLite3DB.ExecPragma'); end; procedure TASQLite3DB.Commit; begin DebugEnter('TASQLite3DB.Commit'); if not FConnected then Connected := true; if FConnected then SQLite3_ExecSQL('commit transaction'); DebugLeave('TASQLite3DB.Commit'); end; procedure TASQLite3DB.RollBack; begin DebugEnter('TASQLite3DB.RollBack'); if not FConnected then Connected := true; if FConnected then SQLite3_ExecSQL('rollback transaction'); DebugLeave('TASQLite3DB.RollBack'); end; constructor TASQLite3DB.Create(AOwner: TComponent); //var fn : TextFile; begin DebugEnter('TASQLite3DB.Create'); Connected := false; ASQLiteLog := nil; ASQLitePragma := nil; inherited Create(AOwner); DebugLeave('TASQLite3DB.Create'); end; destructor TASQLite3DB.Destroy; //var fn : TextFile; begin DebugEnter('TASQLite3DB.Destroy'); FConnected := false; ASQLiteLog := nil; ASQLitePragma := nil; inherited Destroy; DebugLeave('TASQLite3DB.Destroy'); end; //============================================================================== TASQLite3BaseQuery function TASQLite3BaseQuery.CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Integer; //MS begin result := sign(integer(Bookmark1^)-integer(Bookmark2^)); end; // Is one or more fields a calculated field? (John Lito) function TASQLite3BaseQuery.CalcFieldInList(const List: string): Boolean; var i: Integer; Fields: TList; begin if Pos(';', List) <> 0 then begin Result := False; Fields := TList.Create; try GetFieldList(Fields, List); for i := 0 to Fields.Count - 1 do if TField(Fields[I]).FieldKind in [fkCalculated, fkLookup] then Result := True; finally Fields.Free; end; end else Result := (FieldByName(List).FieldKind in [fkCalculated, fkLookup]); end; function TASQLite3BaseQuery.Lookup(const KeyFields: string; const KeyValues: Variant; const ResultFields: string): Variant; var OldState: TDataSetState; begin Result := ''; if Locate(KeyFields, KeyValues, []) then begin if CalcFieldInList(ResultFields) then GetCalcFields(PChar(FResult.GetData(FCurRec))); OldState := SetTempState(dsFilter); try Result := FieldValues[ResultFields]; finally RestoreState(OldState); end; end; end; { support routine for UTF16 } procedure TASQlite3BaseQuery.DataConvert(Field: TField; Source, Dest: Pointer; ToNative: Boolean); const x: Word = 0; var L: Integer; begin try case Field.DataType of ftWideString: begin if ToNative then begin L := Length(PWideChar(Source^)); if (L <= 0) then Move(x,Dest^,2) else begin if (L <= Field.Size) then Move(PWideChar(Source^)^, Dest^, (L+1)*2) else begin Move(PWideChar(Source^)^, Dest^, Field.Size*2); //Move(x,(PChar(Dest)+Field.Size-(Field.Size mod 2))^,2+(Field.Size mod 2)); Move(x, (PChar(Dest)+Field.Size*2 - 2)^, 2); end; end; end else begin WideString(Dest^) := WideString(PWideChar(Source)); end; end;//ftWideString else begin inherited DataConvert(Field, Source, Dest, ToNative); end end;//case finally end; end;//DataConvert { Register detail dataset for a master-detail relationship } procedure TASQLite3BaseQuery.RegisterDetailDataset(DetailDataSet: TASQLite3BaseQuery); var i : integer; begin DebugEnter('TASQLite3BaseQuery.RegisterDetailDataset'); try for i := 0 to DetailList.Count - 1 do if DetailList[i] = DetailDataset then exit; DetailList.Add(DetailDataSet); finally DebugLeave('TASQLite3BaseQuery.RegisterDetailDataset'); end; end; { compatibility isue } procedure TASQLite3BaseQuery.SQLiteMasterChanged; begin DebugEnter('TASQLite3BaseQuery.SQLiteMasterChanged'); DebugLeave('TASQLite3BaseQuery.SQLiteMasterChanged'); end; { notify that the master has changed and a requery on the detail has to be done } procedure TASQLite3BaseQuery.NotifySQLiteMasterChanged; var i : integer; begin DebugEnter('TASQLite3BaseQuery.NotifySQLiteMasterChanged'); for i := 0 to DetailList.Count - 1 do begin TASQLite3BaseQuery(DetailList[i]).SQLiteMasterChanged; end; DebugLeave('TASQLite3BaseQuery.NotifySQLiteMasterChanged'); end; { This function returns a string representing the value of the specified field in SQLite format. Floating point values always use '.' as a decimal separator. Date values use 'yyyy-mm-dd' format, unless SQLiteDateFormat is set to false, which results in using TableDateFormat, or system dependent ShortDateFormat if TableDateFormat is not set. Same goes for DateTime and Time values, for which default formats are 'yyyy-mm-ss hh:nn:ss' and 'hh:nn:ss.zzz', respectively. Setting SQLiteDateFormat to false is discouraged. Result is quoted when necessary. } // added by Donnie function TASQLite3BaseQuery.GetFieldValue(const AField: TField; const Blobs: TList = nil): string; var MS: TMemoryStream; DateTimeFormat: string; begin if (AField.DataSet <> Self) then raise EInvalidArgument.Create('Only own fields are accepted'); case AField.DataType of ftString: {$IFDEF ASQLITE_D6PLUS} if Connection.FUtf8 then Result := QuotedStr(UTF8Encode(VarToWideStr(AField.Value))) else {$endif} Result := QuotedStr(AField.AsString); ftSmallint, ftInteger, ftWord: Result := AField.AsString; ftFloat: if DecimalSeparator <> '.' then {$IFDEF ASQLITE_D6PLUS} Result := AnsiReplaceStr(AField.AsString, DecimalSeparator, '.') {$else} Result := StringReplace(AField.AsString, DecimalSeparator, '.', [rfReplaceAll]) {$endif} else Result := AField.AsString; ftDate: begin if FSQLiteDateFormat then DateTimeFormat := 'yyyy"-"mm"-"dd' else if TableDateFormat <> '' then DateTimeFormat := TableDateFormat else DateTimeFormat := ShortDateFormat; Result := QuotedStr(FormatDateTime(DateTimeFormat, AField.AsDateTime)); end; ftDateTime: begin if FSQLiteDateFormat then DateTimeFormat := 'yyyy"-"mm"-"dd" "hh":"nn":"ss"."zzz' else if TableDateFormat <> '' then DateTimeFormat := TableDateFormat else DateTimeFormat := ShortDateFormat + '" "' + LongTimeFormat; Result := QuotedStr(FormatDateTime(DateTimeFormat, AField.AsDateTime)); end; ftTime: begin if FSQLiteDateFormat then DateTimeFormat := 'hh":"nn":"ss"."zzz' else if TableDateFormat <> '' then DateTimeFormat := TableDateFormat else DateTimeFormat := LongTimeFormat; Result := QuotedStr(FormatDateTime(DateTimeFormat, AField.AsDateTime)); end; ftBlob, ftGraphic, ftMemo, ftFmtMemo: begin if Blobs = nil then raise EInvalidArgument.Create('No place to store a blob field'); MS := TMemoryStream.Create; TBlobField(AField).SaveToStream(MS); Result := #2 + IntToStr(1 + Blobs.Add(MS)); end else Result := QuotedStr(AField.AsString); end; end; // GetFieldValue { Unpack the buffer (if necessary) and convert it to a valid representation this is necessary for sqlite since it it typeless. If typed has been defined then the fields have to be converted to the appropiate datatype } function TASQLite3BaseQuery.UnpackBuffer(Buffer: PAnsiChar; FieldType: TFieldType): TConvertBuffer; var TempInt : integer; TempDouble : double; TempBool : wordbool; TempT : TDateTimeRec; begin {$IFDEF DEBUG_VERY_LOUD} DebugEnter('TASQLite3BaseQuery.UnpackBuffer: ' + Buffer); {$ENDIF} case FieldType of ftString: begin {$IFDEF DEBUG_VERY_LOUD} DebugLeave('TASQLite3BaseQuery.UnpackBuffer'); {$ENDIF} exit; end; ftInteger, ftSmallInt: begin TempInt := StrToIntX(Buffer); Move(TempInt, result, sizeof(TempInt)); end; ftTime: begin TempT := DateTimeToNative(FieldType, StrToDateTimeX(Buffer)); Move(TempT, result, sizeof(TDateTime)); end; ftDate: begin TempT := DateTimeToNative(FieldType, StrToDateTimeX(Buffer)); Move(TempT, result, sizeof(TDateTime)); end; ftDateTime: begin if FSQLiteDateFormat then // aducom TempT := DateTimeToNative(FieldType, YYYYMMDDParser(Buffer)) // jpierce else TempT := DateTimeToNative(FieldType, StrToDateTimeX(Buffer)); Move(TempT, result, sizeof(TDateTime)); end; ftFloat, ftBCD, ftCurrency: begin TempDouble := StrToFloatX(FloatParser(Buffer)); Move(TempDouble, result, sizeof(TempDouble)); end; {$IFDEF ASQLITE_D6PLUS} ftBoolean: begin TempBool := StrToBool(Buffer); Move(TempBool, result, sizeof(TempBool)); end; {$ENDIF} ftMemo, ftGraphic, ftBlob, ftFMTMemo: // pointer to stream begin TempInt := StrToInt(Buffer); Move(TempInt, result, sizeof(TempInt)); end; end; {$IFDEF DEBUG_VERY_LOUD} DebugLeave('TASQLite3BaseQuery.UnpackBuffer'); {$ENDIF} end; { This method is called by TDataSet.Open and also when FieldDefs need to be updated (usually by the DataSet designer). Everything which is allocated or initialized in this method should also be freed or uninitialized in the InternalClose method. } constructor TASQLite3BaseQuery.Create(AOwner: TComponent); begin DebugEnter('TASQLite3BaseQuery.Create'); MaxStrLen := 0; FSQL := TStringList.Create; FParams := TParams.Create(Self); DetailList := TList.Create; FConnection := nil; FResult := nil; GetMem(ResultStr, MaxBuf); SQLCursor := true; SQLiteDateFormat := true; TypeLess := false; ReadOnly := false; inherited; DebugLeave('TASQLite3BaseQuery.Create'); end; function TASQLite3BaseQuery.CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; begin Result := TASQLite3BlobStream.Create(Field as TBlobField, Mode); end; destructor TASQLite3BaseQuery.Destroy; begin DebugEnter('TASQLite3BaseQuery.Destroy'); // Close; // inherited Destroy; if Assigned(FSQL) then begin TStringList(FSQL).OnChange := nil; FSQL.Free; end; FSQL := nil; if Assigned(FParams) then begin FParams.Free; FParams := nil; end; if Assigned(DetailList) then DetailList.Free; DetailList := nil; if Assigned(FConnection) then FConnection := nil; if Assigned(ResultStr) then FreeMem(ResultStr); ResultStr := nil; if Assigned(FResult) then FResult.Free; FResult := nil; inherited; DebugLeave('TASQLite3BaseQuery.Destroy'); end; procedure TASQLite3BaseQuery.StartTransaction; begin if Assigned(FConnection) then FConnection.ExecStartTransaction(FTransActionType); end; procedure TASQLite3BaseQuery.StartDeferredTransaction; begin if Assigned(FConnection) then FConnection.StartDeferredTransaction; end; procedure TASQLite3BaseQuery.StartImmediateTransaction; begin if Assigned(FConnection) then FConnection.StartImmediateTransaction; end; procedure TASQLite3BaseQuery.StartExclusiveTransaction; begin if Assigned(FConnection) then FConnection.StartExclusiveTransaction; end; procedure TASQLite3BaseQuery.Commit; begin if Assigned(FConnection) then FConnection.Commit; end; procedure TASQLite3BaseQuery.RollBack; begin if Assigned(FConnection) then FConnection.RollBack; end; //function TASQLite3BaseQuery.LocateNearest(const KeyFields: String; const KeyValues: Variant; Options: TLocateOptions): Boolean; //begin //end; // implementation by J Bannon, implementing partial key too. function TASQLite3BaseQuery.Locate(const KeyFields: string; const KeyValues: variant; Options: TLocateOptions): boolean; //loCaseInsensitive, loPartialKey var bOk : boolean; i, j, p : integer; Fields, SearchValue: string; //Variable SearchValue added by bobmitch FieldList : TStringList; DebugStr : string; DoEnableControls : boolean; begin DebugEnter('TASQLite3BaseQuery.Locate ' + Keyfields); DoEnableControls := not ControlsDisabled; {used to determine whether to EnableControls at end of function} DisableControls; FieldList := TStringList.Create; bOk := false; try Fields := KeyFields; p := pos(';', Fields); while p > 0 do begin FieldList.Add(Copy(Fields, 1, p - 1)); System.Delete(Fields, 1, p); p := pos(';', Fields); end; if Fields <> '' then FieldList.Add(Fields); First; for i := 1 to FResult.Data.Count do begin SetRecNo(i); bOk := true; for j := 0 to FieldList.Count - 1 do begin if loCaseInsensitive in Options then begin if FieldList.Count = 1 then begin //Lines 2303 - 2338 by bobmitch, replaces original lines 2303 - 2336 SearchValue := VarToStr(KeyValues); if (loPartialKey in Options) and (Length(SearchValue) <= Length(FieldByName(FieldList[j]).AsString)) then bOk := CompareText(Copy(FieldByName(FieldList[j]).AsString, 1, Length(SearchValue)), SearchValue) = 0 else bOk := CompareText(FieldByName(FieldList[j]).AsString, SearchValue) = 0 end {end loCaseInsensitive in Options AND FieldList.Count = 1} else begin SearchValue := VarToStr(KeyValues[j]); if (loPartialKey in Options) and (Length(SearchValue) <= Length(FieldByName(FieldList[j]).AsString)) then bOk := CompareText(Copy(FieldByName(FieldList[j]).AsString, 1, Length(SearchValue)), SearchValue) = 0 else bOk := CompareText(FieldByName(FieldList[j]).AsString, SearchValue) = 0 end {end loCaseInsensitive in Options AND FieldList.Count greater than 1} end {end loCaseInsensitive in Options} else begin {begin loCaseInsensitive NOT in Options} if FieldList.Count = 1 then begin SearchValue := VarToStr(KeyValues); if (loPartialKey in Options) and (Length(SearchValue) <= Length(FieldByName(FieldList[j]).AsString)) then bOk := Copy(FieldByName(FieldList[j]).AsString, 1, Length(SearchValue)) = SearchValue else bOk := FieldByName(FieldList[j]).AsString = SearchValue end {end loCaseInsensitive NOT in Options AND FieldList.Count = 1} else begin SearchValue := VarToStr(KeyValues[j]); if (loPartialKey in Options) and (Length(SearchValue) <= Length(FieldByName(FieldList[j]).AsString)) then bOk := Copy(FieldByName(FieldList[j]).AsString, 1, Length(SearchValue)) = SearchValue else bOk := FieldByName(FieldList[j]).AsString = SearchValue end; {end loCaseInsensitive NOT in Options AND FieldList.Count greater than 1} end; {end loCaseInsensitive NOT in Options} if bOk = false then break; end; {end for j := 0 to FieldList.Count - 1} if bOk then begin break; end; end; {end for i := 1 to FResult.Data.Count} if bOk then begin Locate := true; DebugStr := 'TASQLite3BaseQuery.Locate true'; end else begin Locate := false; DebugStr := 'TASQLite3BaseQuery.Locate false'; end; finally FieldList.Free; if DoEnableControls then {restore original state of the controls} EnableControls; DebugLeave(DebugStr); end; end; function TASQLite3BaseQuery.GetDataSource: TDataSource; begin DebugEnter('TASQLite3BaseQuery.GetDataSource'); Result := FMasterSource; DebugLeave('TASQLite3BaseQuery.GetDataSource'); end; procedure TASQLite3BaseQuery.SetSQLiteDateFormat(const Value: boolean); begin FSQLiteDateFormat := Value; end; procedure TASQLite3BaseQuery.SetDataSource(Value: TDataSource); begin DebugEnter('TASQLite3BaseQuery.SetDataSource'); if IsLinkedTo(Value) then DatabaseError('circular references are not allowed', Self); FMasterSource := Value; DebugLeave('TASQLite3BaseQuery.SetDataSource'); end; function TASQLite3BaseQuery.GetMasterFields: string; begin DebugEnter('TASQLite3BaseQuery.GetMasterFields'); Result := FMasterFields; //FMasterLink.FieldNames; DebugLeave('TASQLite3BaseQuery.GetMasterFields'); end; procedure TASQLite3BaseQuery.SetMasterFields(const Value: string); begin DebugEnter('TASQLite3BaseQuery.SetMasterFields ' + Value); FMasterFields := Value; // FMasterLink.FieldNames := Value; DebugLeave('TASQLite3BaseQuery.SetMasterFields'); end; //Checks the State and Results a defined Buffer; function TASQLite3BaseQuery.GetActiveBuffer(var Buffer: PAnsiChar): boolean; begin {$IFDEF DEBUG_VERY_LOUD} DebugEnter('TASQLite3BaseQuery.GetActiveBuffer'); {$ENDIF} case State of dsBrowse: if IsEmpty then Buffer := nil else Buffer := ActiveBuffer; dsEdit: Buffer := ActiveBuffer; dsInsert: Buffer := ActiveBuffer; dsFilter: Buffer := ActiveBuffer; //FFilterBuffer; dsCalcFields: Buffer := CalcBuffer; else Buffer := nil; end; Result := Buffer <> nil; {$IFDEF DEBUG_VERY_LOUD} DebugLeave('TASQLite3BaseQuery.GetActiveBuffer ' + PAnsiChar(Buffer)); {$ENDIF} end; function TASQLite3BaseQuery.GetNativeFieldSize(FieldNo: integer): integer; begin DebugEnter('TASQLite3BaseQuery.GetNativeFieldSize'); Result := 0; case FieldDefs.Items[FieldNo - 1].Datatype of ftString: Result := FieldDefs.Items[FieldNo - 1].Size + 1; ftWideString: Result := FieldDefs.Items[FieldNo - 1].Size + 1; ftInteger, ftSmallInt, ftDate, ftTime: Result := 12; ftDateTime: Result := 20; ftFloat, ftBCD, ftCurrency: Result := 12; ftBoolean: Result := 12; ftGraphic, ftMemo, ftBlob, ftFmtMemo: Result := 12; // space for memory handles else raise AsgError.Create('Fieldtype of Field "' + FieldDefs.Items[FieldNo - 1].Name + '" not supported!'); end; DebugLeave('TASQLite3BaseQuery.GetNativeFieldSize'); end; function TASQLite3BaseQuery.GetFieldSize(FieldNo: integer): integer; begin {$IFDEF DEBUG_VERY_LOUD} DebugEnter('TASQLite3BaseQuery.GetFieldSize'); {$ENDIF} // try Result := 0; case FieldDefs.Items[FieldNo - 1].Datatype of ftString: Result := FieldDefs.Items[FieldNo - 1].Size+ 1 ; // GPA - Warning UTF-8 length can be potentially > Ansi length ftWideString: Result := FieldDefs.Items[FieldNo - 1].Size+ 1 ; ftInteger, ftSmallInt, ftDate, ftTime: Inc(Result, sizeof(integer)); ftDateTime: Inc(Result, sizeof(TDateTime)); ftFloat, ftBCD, ftCurrency: Inc(Result, sizeof(double)); ftBoolean: Inc(Result, sizeof(wordbool)); ftGraphic, ftMemo, ftBlob, ftFmtMemo: Inc(Result, sizeof(pointer)); else raise AsgError.Create('Fieldtype of Field "' + FieldDefs.Items[FieldNo - 1].Name + '" not supported!'); end; {$IFDEF DEBUG_VERY_LOUD} DebugLeave('TASQLite3BaseQuery.GetFieldSize'); {$ENDIF} end; function TASQLite3BaseQuery.GetFieldSize(Field: TField): integer; begin {$IFDEF DEBUG_VERY_LOUD} DebugEnter('TASQLiteBaseQuery.GetFieldSize'); {$ENDIF} // try Result := 0; case Field.DataType of ftString: Result := Field.Size + 1; ftWideString: Result := Field.Size + 1; ftInteger, ftSmallInt, ftDate, ftTime: Inc(Result, sizeof(integer)); ftDateTime: Inc(Result, sizeof(TDateTime)); ftFloat, ftBCD, ftCurrency: Inc(Result, sizeof(double)); ftBoolean: Inc(Result, sizeof(wordbool)); ftGraphic, ftMemo, ftBlob, ftFmtMemo: Inc(Result, sizeof(pointer)); else raise AsgError.Create('Fieldtype of Field "' + Field.FieldName + '" not supported!'); end; {$IFDEF DEBUG_VERY_LOUD} DebugLeave('TASQLiteBaseQuery.GetFieldSize'); {$ENDIF} end; function TASQLite3BaseQuery.GetFieldOffset(FieldNo: integer): integer; var i : integer; Offset : integer; begin {$IFDEF DEBUG_VERY_LOUD} DebugEnter('TASQLite3BaseQuery.GetFieldOffset'); {$ENDIF} Offset := 0; if FieldNo > 1 then begin for i := 1 to FieldNo - 1 do OffSet := OffSet + GetFieldSize(i); end; GetFieldOffset := Offset; {$IFDEF DEBUG_VERY_LOUD} DebugLeave('TASQLite3BaseQuery.GetFieldOffset'); {$ENDIF} end; function TASQLite3BaseQuery.GetCalcFieldOffset(Field: TField): integer; var i : integer; Offset : integer; begin // calcfieldoffset is appended to record (after bookmarkinfo) {$IFDEF DEBUG_VERY_LOUD} DebugEnter('TASQLiteBaseQuery.GetCalcFieldOffset'); {$ENDIF} Offset := FRecBufSize + sizeof(TRecInfo); // startlocation of offsetbuffer for i := 0 to FieldList.Count - 1 do begin if CompareText(FieldList[i].FieldName, Field.FieldName) = 0 then begin GetCalcFieldOffset := Offset; exit; end; if FieldList[i].Calculated then OffSet := OffSet + GetFieldSize(Field); end; GetCalcFieldOffset := Offset; {$IFDEF DEBUG_VERY_LOUD} DebugLeave('TASQLiteBaseQuery.GetCalcFieldOffset'); {$ENDIF} end; procedure TASQLite3BaseQuery.SetSQL(const Value: TStrings); begin DebugEnter('TASQLite3BaseQuery.SetSQL'); Close; if Assigned(FSQL) then FSQL.Assign(Value) else FSQL := Value; DebugLeave('TASQLite3BaseQuery.SetSQL'); end; procedure TASQLite3BaseQuery.LoadQueryData; begin DebugEnter('TASQLite3BaseQuery.LoadQueryData'); if Connection.FConnected then begin Connection.SQLite3_execute(Connection.DBHandle, PAnsiChar(FPrepared), FParams, self); end; DebugLeave('TASQLite3BaseQuery.LoadQueryData'); end; procedure TASQLite3BaseQuery.InternalOpen; begin DebugEnter('TASQLite3BaseQuery.InternalOpen'); {$IFDEF ASQLITE_D6PLUS} if UniDirectional then SetUnidirectional(true) else SetUniDirectional(false); {$endif} MaxStrLen := 0; if (Connection = nil) then begin // check to see if a valid database raise AsgError.Create('no database connection'); end else begin if Connection.Connected = false then // open database if necessary Connection.Connected := true; // trigger the 'dbconnect' event if (Connection.Connected) and (Connection.DLLHandle <> 0) then if Assigned(MasterSource) then begin // notify master about existance! if (MasterSource.DataSet <> nil) then begin if CompareText(Copy(MasterSource.DataSet.ClassName, 1, 9), 'TASQLite3') = 0 then begin TASQLite3BaseQuery(MasterSource.DataSet).RegisterDetailDataset( TASQLite3BaseQuery(Self)); end else begin raise AsgError.Create('master dataset ' + MasterSource.DataSet.ClassName + ' is not of TSQLiteBaseQuery type'); DebugLeave('TASQLite3BaseQuery.InternalOpen'); exit; end; end else begin raise AsgError.Create('master dataset undefined'); DebugLeave('TASQLite3BaseQuery.InternalOpen'); exit; end; end; if not FUniDir then begin { Load the result into a resultlist } FResult := TFResult.Create(Self); LoadQueryData; end else begin FResult := TFResult.Create(Self); FStatement := Connection.SQLite3_PrepareResult(Connection.DBHandle, PAnsiChar(FPrepared),FParams, self); // ptr := Connection.SQLite3_GetNextResult(Connection.DBHandle, FStatement, FParams,self); end; { Initialize our internal position. We use -1 to indicate the "crack" before the first record. } FCurRec := -1; { Initialize an offset value to find the TRecInfo in each buffer } FRecInfoOfs := MaxStrLen; { Calculate the size of the record buffers. Note: This is NOT the same as the RecordSize property which only gets the size of the data in the record buffer } FRecBufSize := FRecInfoOfs + SizeOf(TRecInfo); { Tell TDataSet how big our Bookmarks are (REQUIRED) } BookmarkSize := SizeOf(integer); { Initialize the FieldDefs } InternalInitFieldDefs; { Create TField components when no persistent fields have been created } if DefaultFields then CreateFields; { Bind the TField components to the physical fields } BindFields(true); end; DebugLeave('TASQLite3BaseQuery.InternalOpen'); end; procedure TASQLite3BaseQuery.InternalClose; begin DebugEnter('TASQLite3BaseQuery.InternalClose'); if (FUniDir) and (FStatement <> nil) and (active) then begin Connection.SQLite3_CloseResult(FStatement); FStatement := nil; end; if Assigned(FResult) then begin FResult.Free; FResult := nil; end; { Destroy the TField components if no persistent fields } if DefaultFields then DestroyFields; { Reset these internal flags } // FLastBookmark := 0; FCurRec := -1; DebugLeave('TASQLite3BaseQuery.InternalClose'); end; { This property is used while opening the dataset. It indicates if data is available even though the current state is still dsInActive. } function TASQLite3BaseQuery.IsCursorOpen: boolean; begin Result := Assigned(FResult); end; procedure TASQLite3BaseQuery.OpenCursor(InfoQuery: Boolean); begin if InfoQuery then Begin if Assigned(FConnection) Then Begin InternalOpen; InternalClose; End; End else if State <> dsOpening then inherited OpenCursor(InfoQuery); end; procedure TASQLite3BaseQuery.InternalInitFieldDefs; begin // Just here for compatibility end; { This is the exception handler which is called if an exception is raised while the component is being stream in or streamed out. In most cases this should be implemented useing the application exception handler as follows. } procedure TASQLite3BaseQuery.InternalHandleException; begin DebugEnter('TASQLite3BaseQuery.InternalHandleException'); ApplicationHandleException(Self); DebugLeave('TASQLite3BaseQuery.InternalHandleException'); end; { Bookmarks } { ========= } { In this sample the bookmarks are stored in the Object property of the TStringList holding the data. Positioning to a bookmark just requires finding the offset of the bookmark in the TStrings.Objects and using that value as the new current record pointer. } procedure TASQLite3BaseQuery.InternalGotoBookmark(Bookmark: Pointer); var Index : integer; begin DebugEnter('TASQLite3BaseQuery.InternalGotoBookmark'); // inherited; Index := FResult.IndexOf(TObject(PInteger(Bookmark)^)); if Index <> -1 then FCurRec := Index else if not FUniDir then DatabaseError('Bookmark not found'); DebugLeave('TASQLite3BaseQuery.InternalGotoBookmark'); end; function TASQLite3BaseQuery.BookmarkValid(Bookmark: Pointer): boolean; var Index : integer; begin DebugEnter('TASQLite3BaseQuery.BookmarkValid'); Index := FResult.IndexOf(TObject(PInteger(Bookmark)^)); if Index <> -1 then BookmarkValid := true else BookmarkValid := false; DebugLeave('TASQLite3BaseQuery.BookmarkValid'); end; { This function does the same thing as InternalGotoBookmark, but it takes a record buffer as a parameter instead } procedure TASQLite3BaseQuery.InternalSetToRecord(Buffer: PAnsiChar); begin DebugEnter('TASQLite3BaseQuery.InternalSetToRecord'); InternalGotoBookmark(@PRecInfo(Buffer + FRecInfoOfs).Bookmark); // NotifySQLiteMasterChanged; DebugLeave('TASQLite3BaseQuery.InternalSetToRecord'); end; { Bookmark flags are used to indicate if a particular record is the first or last record in the dataset. This is necessary for "crack" handling. If the bookmark flag is bfBOF or bfEOF then the bookmark is not actually used; InternalFirst, or InternalLast are called instead by TDataSet. } function TASQLite3BaseQuery.GetBookmarkFlag(Buffer: PAnsiChar): TBookmarkFlag; begin DebugEnter('TASQLite3BaseQuery.GetBookmarkFlag'); Result := PRecInfo(Buffer + FRecInfoOfs).BookmarkFlag; DebugLeave('TASQLite3BaseQuery.GetBookmarkFlag'); end; procedure TASQLite3BaseQuery.SetBookmarkFlag(Buffer: PAnsiChar; Value: TBookmarkFlag); begin DebugEnter('TASQLite3BaseQuery.SetBookmarkFlag'); PRecInfo(Buffer + FRecInfoOfs).BookmarkFlag := Value; DebugLeave('TASQLite3BaseQuery.SetBookmarkFlag'); end; { These methods provide a way to read and write bookmark data into the record buffer without actually repositioning the current record } procedure TASQLite3BaseQuery.GetBookmarkData(Buffer: PAnsiChar; Data: Pointer); begin DebugEnter('TASQLite3BaseQuery.GetBookmarkData'); PInteger(Data)^ := PRecInfo(Buffer + FRecInfoOfs).Bookmark; DebugLeave('TASQLite3BaseQuery.GetBookmarkData'); end; procedure TASQLite3BaseQuery.SetBookmarkData(Buffer: PAnsiChar; Data: Pointer); begin DebugEnter('TASQLite3BaseQuery.SetBookmarkData'); PRecInfo(Buffer + FRecInfoOfs).Bookmark := PInteger(Data)^; DebugLeave('TASQLite3BaseQuery.SetBookmarkData'); end; { Record / Field Access } { ===================== } { This method returns the size of just the data in the record buffer. Do not confuse this with RecBufSize which also includes any additonal structures stored in the record buffer (such as TRecInfo). } function TASQLite3BaseQuery.GetRecordSize: word; begin DebugEnter('TASQLite3BaseQuery.GetRecordSize'); Result := MaxStrLen; DebugLeave('TASQLite3BaseQuery.GetRecordSize'); end; { TDataSet calls this method to allocate the record buffer. Here we use FRecBufSize which is equal to the size of the data plus the size of the TRecInfo structure. } function TASQLite3BaseQuery.AllocRecordBuffer: PAnsiChar; begin DebugEnter('TASQLiteBaseQuery.AllocRecordBuffer'); GetMem(Result, FRecBufSize + CalcFieldsSize + sizeof(TRecinfo) + 5); FillChar(Result^, FRecBufSize + CalcFieldsSize + sizeof(TRecinfo) + 5, 0); // FillChar(Result^, GetRecordSize+CalcFieldsSize+10, 0); DebugLeave('TASQLiteBaseQuery.AllocRecordBuffer'); end; { Again, TDataSet calls this method to free the record buffer. Note: Make sure the value of FRecBufSize does not change before all allocated buffers are freed. } procedure TASQLite3BaseQuery.FreeRecordBuffer(var Buffer: PAnsiChar); begin DebugEnter('TASQLiteBaseQuery.FreeRecordBuffer'); try FreeMem(Buffer); //, FRecBufSize+CalcFieldsSize+sizeof(TRecinfo)); except end; // Buffer := nil; DebugLeave('TASQLiteBaseQuery.FreeRecordBuffer'); end; { This multi-purpose function does 3 jobs. It retrieves data for either the current, the prior, or the next record. It must return the status (TGetResult), and raise an exception if DoCheck is True. } function TASQLite3BaseQuery.GetRecord(Buffer: PAnsiChar; GetMode: TGetMode; DoCheck: boolean): TGetResult; var ptr : pointer; begin DebugEnter('TASQLite3BaseQuery.GetRecord'); // if Active then CheckBrowseMode; if (not (FUniDir)) and (FResult.Count < 1) then Result := grEOF else begin Result := grOK; case GetMode of gmNext: if FUniDir then begin // ptr := Connection.SQLite3_GetNextResult(Connection.DBHandle, FStatement, FParams,self); // if ptr <> nil then // Move(ptr^, Buffer^, MaxStrLen) // else // Result := grEOF; end else begin if FCurRec >= RecordCount - 1 then Result := grEOF else Inc(FCurRec); end; gmPrior: begin if FUniDir then // Result := grOK raise AsgError.Create('operation PRIOR not allowed on unidirectional dataset') else begin if FCurRec <= 0 then Result := grBOF else Dec(FCurRec); end; end; gmCurrent: begin if (FCurRec < 0) or (FCurRec >= RecordCount) then Result := grError; end; end; if Result = grOK then begin if FUniDir then begin ptr := Connection.SQLite3_GetNextResult(Connection.DBHandle, FStatement, FParams,self); if ptr <> nil then begin Move(ptr^, ActiveBuffer^, MaxStrLen); end else Result := grEOF; end else begin ptr := FResult.GetData(FCurRec); if FResult.Count = 0 then InternalInitRecord(Buffer) else if ptr <> nil then Move(ptr^, Buffer^, MaxStrLen); // albert 17/11/2004 end; with PRecInfo(Buffer + FRecInfoOfs)^ do begin BookmarkFlag := bfCurrent; Bookmark := FResult.GetBookMark(FCurRec); end; if CalcFieldsSize > 0 then GetCalcFields(Buffer) end else if (Result = grError) and DoCheck then DatabaseError('No Records'); end; DebugLeave('TASQLite3BaseQuery.GetRecord: ' + Buffer); end; { This routine is called to initialize a record buffer. } procedure TASQLite3BaseQuery.InternalInitRecord(Buffer: PAnsiChar); var i : integer; TempT : TDateTimeRec; Stream : TMemoryStream; begin DebugEnter('TASQLite3BaseQuery.InternalInitRecord'); for i := 0 to FieldDefs.Count - 1 do begin if not (Fields[i].Calculated) then begin case FieldDefs.Items[i].Datatype of ftMemo, ftGraphic, ftBlob, ftFmtMemo: begin Stream := TMemoryStream.Create; Move(Pointer(Stream), (Buffer + GetFieldOffset(i + 1))^, sizeof(Pointer)); end; ftString: PAnsiChar(Buffer + GetFieldOffset(i + 1))^ := #0; ftBoolean: pBoolean(Buffer + GetFieldOffset(i + 1))^ := false; ftFloat: pFloat(Buffer + GetFieldOffset(i + 1))^ := 0; ftSmallInt: pSmallInt(Buffer + GetFieldOffset(i + 1))^ := 0; ftInteger: pInteger(Buffer + GetFieldOffset(i + 1))^ := integer(nil); ftCurrency: pFloat(Buffer + GetFieldOffset(i + 1))^ := 0; ftDate: begin TempT := DateTimeToNative(ftDate, now); Move(TempT, (Buffer + GetFieldOffset(i + 1))^, sizeof(TDateTime)); end; ftTime: begin TempT := DateTimeToNative(ftTime, now); Move(TempT, (Buffer + GetFieldOffset(i + 1))^, sizeof(TDateTime)); end; ftDateTime: begin TempT := DateTimeToNative(ftDateTime, now); Move(TempT, (Buffer + GetFieldOffset(i + 1))^, sizeof(TDateTime)); end; end; end; end; // if FMasterSource <> nil then begin // FMasterSource.DataSet.FieldByName() // end; DebugLeave('TASQLite3BaseQuery.InternalInitRecord'); end; { Here we copy the data from the record buffer into a field's buffer. This function, and SetFieldData, are more complex when supporting calculated fields, filters, and other more advanced features. See TBDEDataSet for a more complete example. } function TASQLite3BaseQuery.GetFieldData(Field: TField; Buffer: Pointer): boolean; var // SrcBuffer : PAnsiChar; MyBuf : string; SrcBuffer : PAnsiChar; // MasterField : TField; // EqualPos : Integer; /// MasterFieldName, DetailFieldName : string; begin {$IFDEF DEBUG_VERY_LOUD} DebugEnter('TASQLite3BaseQuery.GetFieldData'); {$ENDIF} if Field.FieldNo > 0 then begin // load masterfield data if there's a master-detail relationship // key-data should not be NULL!! if pos(UpperCase(Field.FieldName), UpperCase(FMasterFields)) > 0 then begin MasterSource.DataSet.GetFieldData(Field, Buffer); Result := true; exit; end; // if FMasterFields <> '' then begin // EqualPos := Pos('=',FMasterFields); // DetailFieldName := Copy(FMasterFields,1, EqualPos - 1); // MasterFieldName := Copy(FMasterFields,EqualPos + 1, Length(FMasterFields) - EqualPos -1); // if UpperCase(Field.FieldName) = UpperCase(DetailFieldName) then begin // // locate and get master field by name // MasterField := MasterSource.DataSet.FieldByName(MasterFieldName); // MasterSource.DataSet.GetFieldData(MasterField, Buffer); // Result := true; // exit; // end; // end; Result := true; // indicates NotNull if GetActiveBuffer(SrcBuffer) then begin if (Assigned(Buffer)) and (Assigned(SrcBuffer)) then begin Move((SrcBuffer + GetFieldOffset(Field.FieldNo))^, Buffer^, GetFieldSize(Field.FieldNo)); if Field.DataType = ftString then begin // GPA MyBuf := PChar(Buffer); {$IFDEF ASQLITE_D6PLUS} if Connection.FUtf8 then Move(Utf8ToAnsi(MyBuf)[1], Buffer^, Length(MyBuf)) // GPA - Warning UTF-8 length can be potentially > Ansi length else {$endif} Move(MyBuf[1], Buffer^, Length(MyBuf)); // GPA - Warning UTF-8 length can be potentially > Ansi length PAnsiChar(PAnsiChar(Buffer) + GetFieldSize(Field.FieldNo))^ := #0; // dev end; Result := true; exit; end; if Assigned(SrcBuffer) then if (Field.DataType <> ftDateTime) and ((SrcBuffer + GetFieldOffset(Field.FieldNo))^ = #0) then Result := false end else begin if assigned(Buffer) then PAnsiChar(Buffer)^ := #0; Result := false; end; end else begin {calcfields} Result := GetActiveBuffer(SrcBuffer); if Result and (State in [dsBrowse, dsEdit, dsInsert, dsCalcFields, dsBlockRead]) then begin if (Assigned(Buffer)) then Move((SrcBuffer + GetCalcFieldOffset(Field))^, Buffer^, GetFieldSize(Field)); end; end; {$IFDEF DEBUG_VERY_LOUD} DebugLeave('TASQLite3BaseQuery.GetFieldData: ' + PAnsiChar(Buffer)); {$ENDIF} end; // The next two functions are added to increase compatibility with // components that require it (like DevExpress) function TASQLite3BaseQuery.GetFieldData(FieldNo: integer; Buffer: Pointer): boolean; begin Result := GetFieldData(FieldByNumber(FieldNo), Buffer); end; {$IFDEF ASQLITE_D6PLUS} //function TASQLite3BaseQuery.GetFieldData(Field: TField; Buffer: Pointer; // NativeFormat: boolean): boolean; //begin // Result := GetFieldData(Field, Buffer); //end; {$ENDIF} { returns the field data back to callee } procedure TASQLite3BaseQuery.SetFieldData(Field: TField; Buffer: Pointer); var DestBuffer : PAnsiChar; MyBuf : string; begin DebugEnter('TASQLite3BaseQuery.SetFieldData'); GetActiveBuffer(DestBuffer); if (Field.FieldNo > 0) and (Assigned(Buffer)) and (Assigned(DestBuffer)) then begin if Field.DataType = ftString then Begin // GPA MyBuf := PChar(Buffer); {$IFDEF ASQLITE_D6PLUS} if Connection.FUtf8 then MyBuf := AnsiToUTF8(MyBuf); {$endif} if Length(MyBuf)>0 then Move(MyBuf[1], (DestBuffer + GetFieldOffset(Field.FieldNo))^, Length(MyBuf)+1) // GPA - Warning UTF-8 length can be potentially > Ansi length else begin MyBuf := #0; Move(MyBuf[1], (DestBuffer + GetFieldOffset(Field.FieldNo))^, Length(MyBuf)); // GPA - Warning UTF-8 length can be potentially > Ansi length end; End else Move(Buffer^, (DestBuffer + GetFieldOffset(Field.FieldNo))^, GetFieldSize(Field.FieldNo)); end else {fkCalculated, fkLookup} begin if (State in [dsBrowse, dsEdit, dsInsert, dsCalcFields, dsBlockRead]) then begin if (Field.FieldNo < 0) and (Assigned(Buffer)) and (Assigned(DestBuffer)) then begin Move(Buffer^, (CalcBuffer + GetCalcFieldOffset(Field))^, GetFieldSize(Field)); end; end; end; if not (State in [dsCalcFields, dsFilter, dsNewValue]) then DataEvent(deFieldChange, Longint(Field)); DebugLeave('TASQLite3BaseQuery.SetFieldData'); end; { Record Navigation / Editing } { =========================== } { This method is called by TDataSet.First. Crack behavior is required. That is we must position to a special place *before* the first record. Otherwise, we will actually end up on the second record after Resync is called. } procedure TASQLite3BaseQuery.InternalFirst; begin DebugEnter('TASQLite3BaseQuery.InternalFirst'); FCurRec := -1; DebugLeave('TASQLite3BaseQuery.InternalFirst'); end; { Again, we position to the crack *after* the last record here. } procedure TASQLite3BaseQuery.InternalLast; begin DebugEnter('TASQLite3BaseQuery.InternalLast'); FCurRec := FResult.Count; DebugLeave('TASQLite3BaseQuery.InternalLast'); end; function TASQLite3BaseQuery.GetLastInsertRow: integer; begin if Assigned(Connection) then result := Connection.SQLite3_LastInsertRow(Connection.DBHandle) else result := -1; end; { This method is called by TDataSet.Post. } procedure TASQLite3BaseQuery.InternalPost; var ptr : Pointer; begin DebugEnter('TASQLite3BaseQuery.InternalPost'); FSaveChanges := true; { For inserts, just update the data in the string list } if State = dsEdit then begin if FUniDir then Connection.SQLite3_GetNextResult(Connection.DBHandle, FStatement, FParams,self) else begin ptr := FResult.GetData(FCurrec); if ptr <> nil then move(ActiveBuffer^, ptr^, FRecBufSize); // albert 17/11/2004 end;//2006 end else begin { If inserting (or appending), increment the bookmark counter and store the data } FResult.Insert(FCurRec, ActiveBuffer, Connection.SQLite3_LastInsertRow(Connection.DBHandle)); end; DebugLeave('TASQLite3BaseQuery.InternalPost'); end; { This method is similar to InternalPost above, but the operation is always an insert or append and takes a pointer to a record buffer as well. } procedure TASQLite3BaseQuery.InternalAddRecord(Buffer: Pointer; Append: boolean); begin DebugEnter('TASQLite3BaseQuery.InternalAddRecord'); if FReadOnly then raise AsgError.Create('Cannot write to a read-only dataset'); FSaveChanges := true; if Append then InternalLast; Post; DebugLeave('TASQLite3BaseQuery.InternalAddRecord'); end; { This method is called by TDataSet.Delete to delete the current record } procedure TASQLite3BaseQuery.InternalDelete; begin DebugEnter('TASQLite3BaseQuery.InternalDelete'); FSaveChanges := true; FResult.Delete(FCurRec); if FCurRec >= FResult.Count then Dec(FCurRec); DebugLeave('TASQLite3BaseQuery.InternalDelete'); end; { Optional Methods } { ================ } { The following methods are optional. When provided they will allow the DBGrid and other data aware controls to track the current cursor postion relative to the number of records in the dataset. Because we are dealing with a small, static data store (a stringlist), these are very easy to implement. However, for many data sources (SQL servers), the concept of record numbers and record counts do not really apply. } function TASQLite3BaseQuery.GetRecordCount: longint; begin DebugEnter('TASQLite3BaseQuery.GetRecordCount'); Result := FResult.Count; DebugLeave('TASQLite3BaseQuery.GetRecordCount ' + IntToStr(Result)); end; function TASQLite3BaseQuery.GetRecNo: longint; begin DebugEnter('TASQLite3BaseQuery.GetRecNo'); UpdateCursorPos; if (FCurRec = -1) and (RecordCount > 0) then Result := 1 else Result := FCurRec + 1; NotifySQLiteMasterChanged; //20040819 DebugLeave('TASQLite3BaseQuery.GetRecNo'); end; procedure TASQLite3BaseQuery.SetRecNo(Value: integer); begin DebugEnter('TASQLite3BaseQuery.SetRecNo'); if (Value >= 0) and (Value < FResult.Count + 2) then // value < resultetc begin FCurRec := Value - 1; Resync([]); end; DebugLeave('TASQLite3BaseQuery.SetRecNo'); end; procedure TASQLite3BaseQuery.SetFiltered(Value: Boolean); begin inherited; end; procedure TASQLite3BaseQuery.SetFilterText(const Value: string); begin DebugEnter('TASQLite3BaseQuery.SetFilterText ' + Value); if Active then begin Close; inherited; Open; end else Inherited; DebugLeave('TASQLite3BaseQuery.SetFilterText'); end; function TASQLite3BaseQuery.SetQueryParams(InStr: string): string; var i : integer; TempParam : string; ThisDateFormat : string; OldDateFormat : string; begin if FSQLiteDateFormat then ThisDateFormat := 'yyyy-mm-dd hh:nn:ss.zzz' else if (FTableDateFormat <> '') then ThisDateFormat := FTableDateFormat else ThisDateFormat := ShortDateFormat; for i := 0 to FParams.Count - 1 do begin if (FParams.Items[i].DataType <> ftBlob) and (FParams.Items[i].DataType <> ftGraphic) then begin TempParam := Fparams.Items[i].AsString; if (TempParam = '') and (FParams.Items[i].bound) then begin InStr := StringReplace(Instr, '?', 'NULL', []); end else begin //Here we'll replace legitimate '?' characters with an unprintable character TempParam := StringReplace(TempParam, '?', #1, [rfReplaceAll]); //Okay, we need to check string dates and times if FParams[i].DataType = ftDate then begin end else if FParams[i].DataType = ftTime then begin end else if FParams[i].DataType = ftDateTime then begin OldDateFormat := ShortDateFormat; ShortDateFormat := ThisDateFormat; TempParam := DateToStr(FParams[i].AsDateTime); ShortDateFormat := OldDateFormat; end; InStr := StringReplace(Instr, '?', QuotedStr(TempParam), [rfIgnoreCase]); end; end else begin // BLOB !! //Here we'll replace legitimate '?' characters with an unprintable character InStr := StringReplace(Instr, '?', #2, [rfIgnoreCase]); end; end; //Here we'll restore legitimate '?' characters InStr := StringReplace(Instr, #1, '?', [rfReplaceAll]); SetQueryParams := InStr; end; // ============================================================================= TASQLite3 UPDATE SQL constructor TASQLite3UpdateSQL.Create(AOWner: TComponent); begin DebugEnter('TASQLite3UpdateSQL.Create'); inherited Create(AOwner); FInsertSQL := TStringList.Create; FUpdateSQL := TStringList.Create; FDeleteSQL := TStringList.Create; DebugLeave('TASQLite3UpdateSQL.Create'); end; destructor TASQLite3UpdateSQL.Destroy; begin DebugEnter('TASQLite3UpdateSQL.Destroy'); inherited; if Assigned(FInsertSQL) then FInsertSQL.Free; if Assigned(FUpdateSQL) then FUpdateSQL.Free; if Assigned(FDeleteSQL) then FDeleteSQL.Free; DebugLeave('TASQLite3UpdateSQL.Destroy'); end; procedure TASQLite3UpdateSQL.SetInsertSQL(const Value: TStrings); begin DebugEnter('TASQLite3UpdateSQL.SetInsertSQL'); if Assigned(FInsertSQL) then FInsertSQL.Assign(Value) else FInsertSQL := Value; DebugLeave('TASQLite3UpdateSQL.SetInsertSQL'); end; procedure TASQLite3UpdateSQL.SetUpdateSQL(const Value: TStrings); begin DebugEnter('TASQLite3UpdateSQL.SetUpdateSQL'); if Assigned(FUpdateSQL) then FUpdateSQL.Assign(Value) else FUpdateSQL := Value; DebugLeave('TASQLite3UpdateSQL.SetUpdateSQL'); end; procedure TASQLite3UpdateSQL.SetDeleteSQL(const Value: TStrings); begin DebugEnter('TASQLite3UpdateSQL.SetDeleteSQL'); if Assigned(FDeleteSQL) then FDeleteSQL.Assign(Value) else FDeleteSQL := Value; DebugLeave('TASQLite3UpdateSQL.SetDeleteSQL'); end; // ============================================================================= TASQLite3 QUERY constructor TASQLite3Query.Create(AOwner: TComponent); begin DebugEnter('TASQLite3Query.Create'); inherited Create(AOwner); // FParams := TParams.Create(Self); TStringList(FSQL).OnChange := QueryChanged; DebugLeave('TASQLite3Query.Create'); end; destructor TASQLite3Query.Destroy; begin DebugEnter('TASQLite3Query.Destroy'); if Assigned(FSQL) then TStringList(FSQL).OnChange := nil; inherited Destroy; DebugLeave('TASQLite3Query.Destroy'); end; procedure TASQLite3Query.Notification(AComponent: TComponent; Operation: TOperation); begin {$IFDEF DEBUG_VERY_LOUD} DebugEnter('TASQLite3Query.Notification'); {$ENDIF} // Application.ProcessMessages; if Assigned(AComponent) then begin if (Operation = opRemove) then begin if Assigned(FUpdateSQL) and (AComponent is TASQLite3UpdateSQL) then begin if TASQLite3UpdateSQL(AComponent) = FUpdateSQL then FUpdateSQL := nil; end else if Assigned(FConnection) then begin if (AComponent is TASQLite3DB) and (TASQLite3Db(AComponent) = FConnection) then begin Close; Connection := nil; end; end else end; end; inherited; {$IFDEF DEBUG_VERY_LOUD} DebugLeave('TASQLite3Query.Notification'); {$ENDIF} end; procedure TASQLite3Query.QueryChanged(Sender: TObject); begin DebugEnter('TASQLite3Query.QueryChanged'); FNoResults := false; Close; if not FRawSQL then begin if assigned(FParams) then FParams.Clear; // new SQLStr := FParams.ParseSQL(SQL.Text, true) end else SQLStr := SQL.Text; DebugLeave('TASQLite3Query.QueryChanged'); end; procedure TASQLite3Query.SetSQL(const Value: TStrings); begin DebugEnter('TASQLite3Query.SetSQL'); FNoResults := false; Close; if Assigned(FSQL) then FSQL.Assign(Value) else FSQL := Value; // FText := FParams.ParseSQL(SQL.Text, False); DebugLeave('TASQLite3Query.SetSQL'); end; function TASQLite3Query.GetSQL: TStrings; begin DebugEnter('TASQLite3Query.GetSQL'); GetSQL := FSQL; DebugLeave('TASQLite3Query.GetSQL'); end; procedure TASQLite3Query.InternalDelete; var MySQL : string; TempSQL : string; SQLStr : string; // added by Donnie TheWord : string; TableId : string; FieldId : string; startpos : integer; vartype : integer; p : integer; Blobs : TList; // added by Donnie label Ende; begin DebugEnter('TASQLite3Query.InternalDelete'); if FReadOnly then raise AsgError.Create('Cannot delete from a read-only dataset'); if Connection.FConnected then begin if FAutoCommit then Connection.ExecStartTransaction(FTransactionType); if not Assigned(FUpdateSQL) then begin raise AsgError.Create('Missing TASQLite3UpdateSQL component'); goto ende; end; // MyFieldList := TStringList.Create; // MyFieldValues := TStringList.Create; Blobs := TList.Create; MySQL := FUpdateSQL.FDeleteSQL.Text; startpos := 1; TheWord := GetWord(MySQL, startpos, vartype); // delete if not SyntaxCheck(TheWord, 'delete') then goto ende; TheWord := GetWord(MySQL, startpos, vartype); // from if not SyntaxCheck(TheWord, 'from') then goto ende; Tableid := GetWord(MySQL, startpos, vartype); // tablename TheWord := GetWord(MySQL, startpos, vartype); // where if not SyntaxCheck(TheWord, 'where') then goto ende; SQLStr := 'delete from ' + TableId + ' where '; TempSQL := Copy(MySQL, startpos, 999); p := pos(':', TempSQL); while p > 0 do begin SQLStr := SQLStr + Copy(TempSQL, 1, p - 1); System.Delete(TempSQL, 1, p); startpos := 1; FieldId := GetWord(TempSQL, startpos, vartype); // variable System.Delete(TempSQL, 1, startpos); // Tzvetan // SQLStr := SQLStr + QuotedStr(FieldByName(FieldId).AsString); // edited by Donnie SQLStr := SQLStr + GetFieldValue(FieldByName(FieldId), Blobs); p := pos(':', TempSQL); end; SQLStr := SQLStr + Copy(TempSQL, StartPos, 999); try Connection.SQLite3_execute(Connection.DBHandle, PAnsiChar(SQLStr), FParams, self); if FAutoCommit then Connection.Commit; except if FAutoCommit then begin Connection.RollBack; raise; end; end; if Assigned(Blobs) then begin for p := 0 to Blobs.Count - 1 do TMemoryStream(Blobs.Items[p]).Free; Blobs.Free; end; inherited InternalDelete; end; Ende: DebugLeave('TASQLite3Query.InternalDelete'); end; //============================================================================== // This is probabely the most difficult thing about these components. // To be able to have a live resultset a tupdatequery must be used to // supply the correct sql on the events. In the internalpost the insert and // update are handled. The routine will take the given sql and remodel it // to a workable sql which is executed. Keep in mind that this routine // is far more difficult then the TASQLite3Table, since the last one is depending // on a unique rownumber, available in the resultset, which might not be // available to user queries // There are several syntaxes allowed: // // insert into table * // this will generate an insert statement for each field and values // i.e. insert into table a,b,c values :a, :b, :c; // // insert into table (a, b, c) values * // this will generate an insert statement like // insert into table (a, b, c) values (:a, :b, :c); // // insert into table (a, b, c) values (:a, :b, :c); // insert into table (a, b, c) values (:a, "bvalue", :c) etc. // // update table set * where // this will generate a update for all fields like // update a=:a, b=:b, c=:c where // //============================================================================== procedure TASQLite3Query.InternalPost; var i : integer; p : integer; startpos : integer; MyFieldList : TStringList; MyFieldValues : TStringList; MySQL : string; TheWord : string; TempSQL : string; SQLStr : string; // added by Donnie TableId : string; FieldId : string; varType : integer; Blobs : TList; // added by Donnie begin DebugEnter('TASQLite3Query.InternalPost'); if FReadOnly then raise AsgError.Create('Cannot post into a read-only dataset'); MyFieldList := nil; MyFieldValues := nil; try if not Connection.FConnected then begin DebugLeave('TASQLite3Query.InternalPost'); exit; end; if FAutoCommit then Connection.ExecStartTransaction(FTransactionType); if not Assigned(FUpdateSQL) then begin DebugLeave('TASQLite3Query.InternalPost Exception'); raise AsgError.Create('Missing TASQLite3UpdateSQL component'); end; Blobs := TList.Create; if (State = dsEdit) and (FResult.Count > 0) then begin MyFieldList := TStringList.Create; MyFieldValues := TStringList.Create; MySQL := FUpdateSQL.FUpdateSQL.Text; startpos := 1; TheWord := GetWord(MySQL, startpos, vartype); // update if not SyntaxCheck(TheWord, 'update') then exit; Tableid := GetWord(MySQL, startpos, vartype); // tablename TheWord := GetWord(MySQL, startpos, vartype); // set or '*' if TheWord = '*' then begin for i := 0 to FieldList.Count - 1 do begin MyFieldList.Add(FieldList[i].FieldName); MyFieldValues.Add(':' + FieldList[i].FieldName); end; TheWord := GetWord(MySQL, startpos, vartype); // where end else begin if not SyntaxCheck(TheWord, 'set') then begin DebugLeave('TASQLite3Query.InternalPost'); exit; end; repeat TheWord := GetWord(MySQL, startpos, vartype); // fieldname MyFieldList.Add(TheWord); TheWord := GetWord(MySQL, startpos, vartype); // '=' if not SyntaxCheck(TheWord, '=') then begin DebugLeave('TASQLite3Query.InternalPost'); exit; end; TheWord := GetWord(MySQL, startpos, vartype); // 2004-14-09 (rps) ':' or 'where' ---> if vartype = vtcDelimiter then // <--- TheWord := GetWord(MySQL, startpos, vartype); // fieldvalue if TheWord = '*' then MyFieldValues.Add(':' + MyFieldList[MyFieldList.Count - 1]) else MyFieldValues.Add(':' + TheWord); TheWord := GetWord(MySQL, startpos, vartype); // , or 'where' until CompareText(TheWord, 'where') = 0; end; if not SyntaxCheck(TheWord, 'where') then exit; SQLStr := 'update ' + TableId + ' set '; // for i := 0 to FieldList.Count - 1 do // typo corrected by Donnie for i := 0 to MyFieldList.Count - 1 do begin // SQLStr := SQLStr + FieldList[i].FieldName + '='; // typo corrected by Donnie SQLStr := SQLStr + MyFieldList.Strings[i] + '='; FieldId := MyFieldValues[i]; if FieldId[1] = ':' then begin System.Delete(FieldId, 1, 1); // SQLStr := SQLStr + QuotedStr(FieldByName(FieldId).AsString) + ',' // edited by Donnie SQLStr := SQLStr + GetFieldValue(FieldByName(FieldId), Blobs) + ',' end else SQLStr := SQLStr + QuotedStr(FieldId) + ',' end; System.Delete(SQLStr, Length(SQLStr), 1); // get rid of ',' TempSQL := ' where ' + Copy(MySQL, startpos, 999); p := pos(':', TempSQL); while p > 0 do begin SQLStr := SQLStr + Copy(TempSQL, 1, p - 1); System.Delete(TempSQL, 1, p); startpos := 1; FieldId := GetWord(TempSQL, startpos, vartype); // variable System.Delete(TempSQL, 1, startpos); // Tzvetan // SQLStr := SQLStr + QuotedStr(FieldToStr(FieldByName(FieldId))); // edited by Donnie SQLStr := SQLStr + GetFieldValue(FieldByName(FieldId), Blobs); p := pos(':', TempSQL); end; SQLStr := SQLStr + Copy(TempSQL, StartPos, 999); // Connection.SQLite3_ExecSQL(SQLStr); // edited by Donnie Connection.SQLite3_ExecSQL(SQLStr, Blobs); inherited InternalPost; // rework internals end else begin { If inserting (or appending), increment the bookmark counter and store the data. Sytax should be: insert into * or insert into
(field, field) values (field, field) | * The sql is parsed and a new (valid) sql generated } MyFieldList := TStringList.Create; MyFieldValues := TStringList.Create; MySQL := FUpdateSQL.FInsertSQL.Text; startpos := 1; TheWord := GetWord(MySQL, startpos, vartype); // insert if not SyntaxCheck(TheWord, 'insert') then exit; TheWord := GetWord(MySQL, startpos, vartype); // into if not SyntaxCheck(TheWord, 'into') then exit; Tableid := GetWord(MySQL, startpos, vartype); // tablename TheWord := GetWord(MySQL, startpos, vartype); // ( or * if TheWord = '*' then begin for i := 0 to FieldList.Count - 1 do begin MyFieldList.Add(FieldList[i].FieldName); MyFieldValues.Add(':' + FieldList[i].FieldName); end; end else if TheWord = '(' then begin repeat TheWord := GetWord(MySQL, startpos, vartype); // fieldname MyFieldList.Add(TheWord); TheWord := GetWord(MySQL, startpos, vartype); // ',' or ')' until theword = ')'; TheWord := GetWord(MySQL, startpos, vartype); // values TheWord := GetWord(MySQL, startpos, vartype); // '(' or '*' if TheWord = '*' then begin for i := 0 to MyFieldList.Count - 1 do MyFieldValues.Add(':' + MyFieldList[i]); end else begin // 2004-14-09 (rps) original - does not work repeat TheWord := GetWord(MySQL, startpos, vartype); // ':' or fieldname if vartype = vtcDelimiter then begin TheWord := GetWord(MySQL, startpos, vartype); // fieldname !! MyFieldValues.Add(':' + TheWord); end else MyFieldValues.Add(TheWord); TheWord := GetWord(MySQL, startpos, vartype); // ',' or ')' until theword = ')'; end; end else begin raise AsgError.Create('SQL macro syntax error on insertsql, expected ( or *'); end; SQLStr := 'insert into ' + TableId + ' ('; for i := 0 to MyFieldList.Count - 1 do SQLStr := SQLStr + MyFieldList[i] + ','; SQLStr[Length(SQLStr)] := ')'; SQLStr := SQLStr + ' values ('; for i := 0 to MyFieldList.Count - 1 do begin FieldId := MyFieldValues[i]; if FieldId[1] = ':' then begin System.Delete(FieldId, 1, 1); // SQLStr := SQLStr + QuotedStr(FieldByName(FieldId).AsString) + ',' // edited by Donnie SQLStr := SQLStr + GetFieldValue(FieldByName(FieldId), Blobs) + ',' end else begin if CompareText(FieldId,'null')=0 then SQLStr := SQLStr + FieldId+',' else SQLStr := SQLStr + QuotedStr(FieldId) + ',' end; end; SQLStr[Length(SQLStr)] := ')'; // Connection.SQLite3_ExecSQL(SQLStr); // edited by Donnie Connection.SQLite3_ExecSQL(SQLStr, Blobs); if FResult.Count = 0 then Inc(FCurrec); inherited InternalPost; // rework internals end; if FAutoCommit then begin try Connection.Commit; except Connection.RollBack; raise; end; end; finally if Assigned(MyFieldList) then MyFieldList.Free; if Assigned(MyFieldValues) then MyFieldValues.Free; if Assigned(Blobs) then begin for i := 0 to Blobs.Count - 1 do try TMemoryStream(Blobs.Items[i]).Free; except end; Blobs.Free; end; end; DebugLeave('TASQLite3Query.InternalPost'); end; procedure TASQLite3Query.InternalClose; begin DebugEnter('TASQLite3Query.InternalClose'); FPrepared := ''; inherited; DebugLeave('TASQLite3Query.InternalClose'); end; procedure TASQLite3Query.InternalOpen; //var // p : integer; begin DebugEnter('TASQLite3Query.InternalOpen'); if Trim(FSQL.Text) = '' then begin raise AsgError.Create('no query specified'); abort; end; if (FMaxResults = 0) and (FStartResult <> 0) then FMaxResults := -1; // SQLStr contains the 'raw' interpreted SQL, with ? as parameterlist // This string has to be preserved, since it was parsed on entering the sql. // On close and open (i.e. in case of master-detail) the parsed data still // must be available // We'll prepare the SQL statement into FPrepared. This is also the var // containing the SQL statement to be executed. FPrepared := SQLStr; // FPrepared := FSql.Text; // 2004-14-09 (rps) changed SqlStr (current) -> FSql.Text (property), // to bring Close; Open; to work. (Full refresh.) // this will block parameterized queries to function right (Aducom) if (Filtered) and (Filter <> '') then begin //in order to let a filter work we use a little trick: //select * from (my select statement) FPrepared := 'select * from (' + FPrepared + ') where ' + Filter; end; if FParams.Count > 0 then FPrepared := SetQueryParams(FPrepared); if FMaxResults <> 0 then FPrepared := FPrepared + ' limit ' + IntToStr(FMaxResults); if FStartResult <> 0 then FPrepared := FPrepared + ' offset ' + IntToStr(FStartResult); inherited; DebugLeave('TASQLite3Query.InternalOpen'); end; // ============================================================================= // The master-detail is implemented through the filter object // in the future perhaps a separate filter object will be used allowing // to add your own criteria too, but for the time being.. //============================================================================== procedure TASQLite3Query.SQLiteMasterChanged; var r, s : string; m, d : string; p : integer; cAnd : string; begin DebugEnter('TASQLite3Query.SQLiteMasterChanged'); Close; cAnd := ''; r := FMasterFields; Filter := ''; Filtered := false; while r <> '' do begin // build the filter sql syntax p := pos(';', r); if p = 0 then begin if Trim(r) <> '' then s := r; r := ''; end else begin s := Trim(Copy(r, 1, p - 1)); System.Delete(r, 1, p); end; p := pos('=', s); if p = 0 then begin raise AsgError.Create('Syntax error: Masterfields not build of a=b;... pairs'); end else begin d := copy(s, 1, p - 1); m := copy(s, p + 1, 99); end; // Filter := Filter + cAnd + d + '=' + FMasterSource.DataSet.FieldByName(m).AsString; Filter := Filter + cAnd + d + '=' + QuotedStr(FMasterSource.DataSet.FieldByName(m).AsString) ; cAnd := ' and '; end; if (Filter <> '') and (Active) then begin filtered := true; Open; end; DebugLeave('TASQLite3Query.SQLiteMasterChanged'); end; //============================================================================== // execsql is used for sql statements which do not require cursors. For this // reason the fnoresults is set, to prevent building a result set //============================================================================== procedure TASQLite3BaseQuery.ExecSQL; begin DebugEnter('TASQLite3BaseQuery.ExecSQL'); FNoResults := true; Close; if FAutoCommit then begin Connection.ExecStartTransaction(FTransactionType); Open; try Connection.Commit except Connection.RollBack; raise; end; end else Open; DebugLeave('TASQLite3BaseQuery.ExecSQL'); end; procedure TASQLite3BaseQuery.SetParamsList(Value: TParams); begin DebugEnter('TASQLite3BaseQuery.SetParamsList'); FParams.AssignValues(Value); DebugLeave('TASQLite3BaseQuery.SetParamsList'); end; function TASQLite3BaseQuery.GetParamsCount: word; begin DebugEnter('TASQLite3BaseQuery.GetParamsCount'); Result := FParams.Count; DebugLeave('TASQLite3BaseQuery.GetParamsCount'); end; procedure TASQLite3Table.SetFOrderBy(OrderBy : string); begin if FOrderBy <> OrderBy then begin Close; FOrderBy := OrderBy; end; end; procedure TASQLite3Table.SetFTableName(TableName : string); begin Close; FTableName := TableName; end; procedure TASQLite3Table.Notification(AComponent: TComponent; Operation: TOperation); begin {$IFDEF DEBUG_VERY_LOUD} DebugEnter('TASQLite3Table.Notification'); {$ENDIF} // Application.ProcessMessages; if Assigned(AComponent) then begin if (Operation = opRemove) then begin if (AComponent is TASQLite3DB) and Assigned(FConnection) then begin if TASQLite3DB(AComponent) = FConnection then begin Close; FConnection := nil; end; end else end; end; inherited; {$IFDEF DEBUG_VERY_LOUD} DebugLeave('TASQLite3Table.Notification'); {$ENDIF} end; procedure TASQLite3Table.InternalOpen; begin DebugEnter('TASQLite3Table.InternalOpen'); if FTableName = '' then begin raise AsgError.Create('no table specified'); exit; end; FSQL.Clear; FSQL.Add('select *, rowid as rowid from ' + TableName); if Filtered then if Filter <> '' then FSQL.Add(' where ' + Filter); if (FMaxResults = 0) and (FStartResult <> 0) then FMaxResults := -1; if FMaxResults <> 0 then FSQL.Add(' limit ' + IntToStr(FMaxResults)); if FStartResult <> 0 then FSQL.Add(' offset ' + IntToStr(FStartResult)); if FOrderBy <> '' then FSQL.Add(' order by ('+FOrderBy+')'); SQLStr := FSQL.Text; FPrepared := SQLStr; inherited; DebugLeave('TASQLite3Table.InternalOpen'); end; procedure TASQLite3Table.SQLiteMasterChanged; var r, s : string; m, d : string; p : integer; cAnd : string; begin DebugEnter('TASQLite3Table.SQLiteMasterChanged'); Close; cAnd := ''; r := FMasterFields; Filter := ''; while r <> '' do begin p := pos(';', r); if p = 0 then begin if Trim(r) <> '' then s := r; r := ''; end else begin s := Trim(Copy(r, 1, p - 1)); System.Delete(r, 1, p); end; p := pos('=', s); if p = 0 then begin raise AsgError.Create('Syntax error: Masterfields not build of a=b;... pairs'); end else begin d := copy(s, 1, p - 1); m := copy(s, p + 1, 99); end; // Filter := Filter + cAnd + d + '=' + FMasterSource.DataSet.FieldByName(m).AsString; Filter := Filter + cAnd + d + '=' + QuotedStr(FMasterSource.DataSet.FieldByName(m).AsString) ; cAnd := ' and '; end; if Filter <> '' then filtered := true; Open; DebugLeave('TASQLite3Table.SQLiteMasterChanged'); end; procedure TASQLite3Table.InternalDelete; begin DebugEnter('TASQLite3Table.InternalDelete'); if FReadOnly then raise AsgError.Create('Cannot delete from a read-only dataset'); if not Connection.FConnected then exit; if FAutoCommit then Connection.ExecStartTransaction(FTransactionType); SQLStr := ''; CurrentRowId := FResult.GetRowId(FCurRec); FSQL.Clear; FSQL.Add('delete from ' + Tablename + ' where rowid=' + QuotedStr(IntToStr(CurrentRowId))); // SQLStr := StringReplace(FSQL.Text, crlf, #10, [rfReplaceAll, rfIgnoreCase]); // albert SQLStr := FSQL.Text; Connection.SQLite3_execute(Connection.DBHandle, PAnsiChar(SQLStr), FParams, self); inherited InternalDelete; if FAutoCommit then begin try Connection.Commit; except Connection.RollBack; raise; end; end; DebugLeave('TASQLite3Table.InternalDelete'); end; procedure TASQLite3Table.InternalPost; var i : integer; n: Integer; ThisDateFormat, tmpMasterDetail, MasterField, chDelim: string; slDetail, slValues: TStringList; lsBlobs: TList; //GPA M:TMemoryStream; //GPA // this function will return the fielvalue of an indicated fieldbyordinalnumber // if the fieldtype is tdatetime it is transfered to the right date notation as // indicated by jpierce. function GetFieldValue(const AField: TField): string; // DI begin // DI if AField.DataType = ftDateTime then // DI GetFieldValue := QuotedStr(FormatDateTime(ThisDateFormat, FieldByName(AField.FieldName).AsDateTime)) // DI else if (AField.DataType = ftBlob) or (AField.DataType = ftMemo) or (AField.DataType = ftFmtMemo) or (AField.DataType = ftGraphic) then //GPA begin //GPA M:=TMemoryStream.Create; //GPA TBlobField(FieldByName(AField.FieldName)).SaveToStream(M); GetFieldValue := #2+IntToStr(1+lsBlobs.Add(Pointer(M))) //GPA end else GetFieldValue := QuotedStr(FieldByName(AField.FieldName).AsString); // DI end; // DI var f: TField; // DI OldDecimalSeparator: ansiChar; // DI begin DebugEnter('TASQLite3Table.InternalPost'); if FReadOnly then raise AsgError.Create('Cannot post into a read-only dataset'); // determine datetime style of dataset (if any) if FSQLiteDateFormat then ThisDateFormat := 'yyyy-mm-dd hh:nn:ss.zzz' else if (FTableDateFormat <> '') then ThisDateFormat := FTableDateFormat else ThisDateFormat := ShortDateFormat; if not Connection.FConnected then Exit; if FAutoCommit then Connection.StartTransaction; lsBlobs := TList.Create; //GPA OldDecimalSeparator := DecimalSeparator; // DI try // DI DecimalSeparator := '.'; // DI: Force Delphi's DecimalSeparator to SQL style syntax. if (State = dsEdit) and (FResult.Count > 0) then begin CurrentRowId := FResult.GetRowId(FCurRec); FSQL.Clear; FSQL.Add('update ' + TableName + ' set '); SQLStr := ''; for i := 0 to FieldList.Count - 1 do begin f := FieldList[i]; // DI if not (f.Calculated or f.Lookup) then // DI SQLStr := SQLStr + f.FieldName + '=' + GetFieldValue(f) + ','; // DI end; SQLStr[Length(SQLStr)] := ' '; FSQL.Add(SQLStr); FSQL.Add(' where rowid=' + QuotedStr(IntToStr(CurrentRowId))); SQLStr := FSQL.Text; // DI // DI SQLStr := StringReplace(FSQL.Text, CRLF, #10, [rfReplaceAll, rfIgnoreCase]); Connection.SQLite3_ExecSQL(SQLStr,lsBlobs); inherited InternalPost; // rework internals end else begin { If inserting (or appending), increment the bookmark counter and store the data } FSQL.Clear; FSQL.Add('insert into ' + TableName + ' ('); SQLStr := ''; for i := 0 to FieldList.Count - 1 do begin if not (FieldList[i].Calculated or FieldList[i].Lookup) then // aducom SQLStr := SQLStr + FieldList[i].FieldName + ','; end; SQLStr[Length(SQLStr)] := ')'; SQLStr := SQLStr + ' values ('; FSQL.Add(SQLStr); SQLStr := ''; slDetail := TStringList.Create; slValues := TStringList.Create; i := 0; chDelim := ';'; if FMasterSource <> nil then begin while i < Length(FMasterFields) do begin tmpMasterDetail := GetWordByDelim(FMasterFields, i, chDelim); n := Pos('=', tmpMasterDetail); if n <> 0 then begin slDetail.Add(Copy(tmpMasterDetail, 1, n - 1)); MasterField := Copy(tmpMasterDetail, n + 1, Length(tmpMasterDetail) - n); slValues.Add(FMasterSource.DataSet.FieldByName(MasterField).AsString); end; end; end; if (FPrimaryAutoInc) and (FieldDefs[0].DataType = ftInteger) then begin SQLStr := SQLStr + 'null,'; n := 1; // aducom end else begin // aducom n := 0; // aducom end; // aducom for i := n to FieldList.Count - 1 do // aducom begin // DI f := FieldList[i]; if not (f.Calculated or f.Lookup) then // DI if slDetail.Find(f.FieldName, n) then // DI SQLStr := SQLStr + QuotedStr(slValues.Strings[n]) + ',' else SQLStr := SQLStr + GetFieldValue(f) + ','; // DI end; // DI slDetail.Free; slValues.Free; SQLStr[Length(SQLStr)] := ')'; FSQL.Add(SQLStr); SQLStr := FSQL.Text; // DI // DI SQLStr := StringReplace(FSQL.Text, CRLF, #10, [rfReplaceAll, rfIgnoreCase]); Connection.SQLite3_ExecSQL(SQLStr, lsBlobs); if FPrimaryAutoInc then if FieldDefs[0].DataType = ftInteger then FieldByName(FieldList[0].FieldName).AsInteger := Connection.SQLite3_LastInsertRow(Connection.DBHandle); if FResult.Count = 0 then Inc(FCurRec); inherited InternalPost; // rework internals end; finally // DI DecimalSeparator := OldDecimalSeparator; // DI For I:=0 to lsBlobs.Count-1 do begin // GPA M:=TMemoryStream(lsBlobs.Items[I]); // GPA M.Free; // GPA end; // GPA lsBlobs.Free; // GPA end; // DI if FAutoCommit then begin try Connection.Commit; except Connection.RollBack; raise; end; end; DebugLeave('TASQLite3Table.InternalPost'); end; // Blobfields in SQLite are in fact CLOB fields. However, since it is a large // chunk of data for all types the ftBlob is used. Keep in mind that blobs are // stored separately of TResult. Within the result structure only the memory // handle of the blob is stored. constructor TASQLite3BlobStream.Create(Field: TBlobField; Mode: TBlobStreamMode); begin // inherited Create; FField := Field; FMode := Mode; FDataSet := FField.DataSet as TASQLite3BaseQuery; if Mode <> bmWrite then LoadBlobData; end; destructor TASQLite3BlobStream.Destroy; begin DebugEnter('TASQLite3BlobStream.Destroy'); if FModified then SaveBlobData; inherited Destroy; end; function TASQLite3BlobStream.Read(var Buffer; Count: Longint): Longint; begin DebugEnter('ASQLiteBlobStream.Read'); Result := inherited Read(Buffer, Count); FOpened := True; end; function TASQLite3BlobStream.Write(const Buffer; Count: Longint): Longint; begin DebugEnter('ASQLiteBlobStream.Write'); Result := inherited Write(Buffer, Count); FModified := True; FDataSet.SetModified(true); end; procedure TASQLite3BlobStream.LoadBlobData; var Stream : TMemoryStream; Offset : Integer; RecBuffer : PAnsiChar; begin DebugEnter('ASQLiteBlobStream.LoadBlobData'); Self.Size := 0; FDataset.GetActiveBuffer(RecBuffer); // recbuffer := nil; if RecBuffer <> nil then begin Offset := FDataset.GetFieldOffset(FField.FieldNo); Move((RecBuffer + Offset)^, Pointer(Stream), sizeof(Pointer)); Self.CopyFrom(Stream, 0); end; Position := 0; end; procedure TASQLite3BlobStream.SaveBlobData; var Stream : TMemoryStream; Offset : Integer; RecBuffer : PAnsiChar; begin DebugEnter('ASQLiteBlobStream.SaveBlobData'); FDataset.GetActiveBuffer(RecBuffer); if RecBuffer <> nil then begin Offset := FDataset.GetFieldOffset(FField.FieldNo); Move((RecBuffer + Offset)^, Pointer(Stream), sizeof(Pointer)); Stream.Size := 0; Stream.CopyFrom(Self, 0); Stream.Position := 0; end; end; // Inline sql can be used to store sqlstatements outside of the pascal source. // it prevents large 'sql.add' rows. Also it can be used to generate an in-memory // database structure if needed constructor TASQLite3InlineSQL.Create; begin inherited; FSQL := TStringList.Create; end; destructor TASQLite3InlineSQL.Destroy; begin if Assigned(FSQL) then FSQL.Free; inherited; end; procedure TASQLite3InlineSQL.SetSQL(const Value: TStrings); begin if Assigned(FSQL) then FSQL.Assign(Value) else FSQL := Value; end; function TASQLite3InlineSQL.GetSQL: TStrings; begin GetSQL := FSQL; end; // save resultset as text, html or xml. Depending on type the following // will happen: // // text: all rows will be output, separated by the given separation symbol // xml: all rows will be output, tags are the fieldnames // // // fieldvalue // .... // // html: a table will be generated with the given classnames (if available) constructor TASQLite3Output.Create; begin inherited; FOutput := TStringList.Create; end; destructor TASQLite3Output.Destroy; begin if Assigned(FOutput) then FOutput.Free; inherited; end; procedure TASQLite3Output.SetFActive(Active: boolean); begin FActive := Active; if FActive = false then begin end else begin if Assigned(FDataSource) then begin if Assigned(FDataSource.DataSet) then begin Execute(FDataSource.DataSet); end else raise AsgError.Create('Missing Datasource.Dataset'); end else raise AsgError.Create('Missing Datasource'); end; end; procedure TASQLite3Output.SetOutput(const Value: TStrings); begin if Assigned(FOutput) then FOutput.Assign(Value) else FOutput := Value; end; function TASQLite3Output.GetOutput: TStrings; begin GetOutput := FOutput; end; procedure TASQLite3Output.Notification(AComponent: TComponent; Operation: TOperation); begin {$IFDEF DEBUG_VERY_LOUD} DebugEnter('TASQLite3Output.Notification'); {$ENDIF} if Assigned(AComponent) then begin if (Operation = opRemove) then begin if (AComponent is TDataSource) then begin if Assigned(FDataSource) then begin if TDataSource(AComponent) = FDataSource then FDataSource := nil; end; end end; end; inherited; {$IFDEF DEBUG_VERY_LOUD} DebugLeave('TASQLite3DB.Notification'); {$ENDIF} end; procedure TASQLite3Output.Execute(MyDataSet: TDataSet); const eXML = 0; eHTML = 1; eTXT = 2; var FType : integer; i : integer; Line : string; Sep : string; // Indent : integer; begin if Assigned(MyDataset) then begin if MyDataSet.Active = false then MyDataSet.Open; Output.Clear; FType := ETxt; Line := ''; if CompareText(FOutputType[1], 'X') = 0 then begin FType := eXML; Line := Line + '
' + #10; end else if CompareText(FOutputType[1], 'H') = 0 then begin FType := eHTML; Line := Line + '' + #10 + '' + #10 + 'Table ' + MyDataSet.Name + '' + #10 + '' + #10 + '
' + #10 + '' + #10; end else if CompareText(FOutputType[1], 'T') = 0 then begin FType := eTXT; end; Sep := ''; for i := 0 to MyDataSet.FieldDefs.Count - 1 do begin case FType of eXML: begin end; eHTML: begin Line := Line + ''; end; eTXT: begin Line := Line + Sep + MyDataSet.FieldDefs[i].Name; end; end; Sep := FSeparator; end; Output.Add(Line); Line := ''; Sep := ''; MyDataSet.First; // Indent := 0; while not MyDataSet.Eof do begin case FType of eXML: Line := Line + ' ' + #10; eHTML: Line := Line + '' + #10; end; for i := 0 to MyDataSet.FieldDefs.Count - 1 do begin case FType of eXML: begin Line := Line + ' <' + MyDataSet.FieldDefs[i].Name + '>' + MyDataSet.FieldByName(MyDataSet.FieldDefs[i].Name).AsString + '' + #10; end; eHTML: begin Line := Line + ''; end; eTXT: begin Line := Line + Sep + MyDataSet.FieldByName(MyDataSet.FieldDefs[i].Name).AsString; end; end; Sep := FSeparator; end; case FType of eXML: Line := Line + ' ' + #10; eHTML: Line := Line + '' + #10; end; Output.Add(Line); Line := ''; Sep := ''; MyDataSet.Next; end; case FType of eXML: Line := Line + '
' + MyDataSet.FieldDefs[i].Name + '
' + MyDataSet.FieldByName(MyDataSet.FieldDefs[i].Name).AsString + '
' + #10; eHTML: Line := Line + '' + #10 + '' + #10 + '' + #10; end; Output.Add(Line); end; end; {$IFDEF IPROVIDER} procedure TASQLite3BaseQuery.PSEndTransaction(Commit: Boolean); begin // qui non sono molto sicuro... if Assigned(Connection) then if Commit then Connection.Commit else Connection.RollBack; end; procedure TASQLite3BaseQuery.PSExecute; begin UniDirectional := true; ExecSQL; end; function TASQLite3BaseQuery.PSExecuteStatement(const ASQL: string; AParams: TParams; ResultSet: Pointer): Integer; var AsqlQry : TASQLite3BaseQuery; begin if Assigned(ResultSet) then begin TDataSet(ResultSet^) := TASQLite3Query.Create(nil); {$IFDEF ASQLITE_D6PLUS} TASQlite3Query(ResultSet^).SetUniDirectional(true);// := true; // just store data in provider. {$endif} with TASQLite3BaseQuery(ResultSet^) do begin Connection := self.Connection; Params.Assign(AParams); FPrepared := ASql; if FParams.Count > 0 then FPrepared := SetQueryParams(FPrepared); Open; Result := Connection.RowsAffected; end; end else begin AsqlQry := TASQLite3BaseQuery.Create(nil); try with AsqlQry do begin Connection := self.Connection; FPrepared := ASql; FParams.Assign(AParams); if FParams.Count > 0 then FPrepared := SetQueryParams(AsqlQry.FPrepared); ExecSQL; Result := Connection.RowsAffected; end; finally AsqlQry.Free; end; end; end; function TASQLite3BaseQuery.PSGetParams: TParams; begin Result := Params; end; function TASQLite3BaseQuery.PSGetQuoteChar: string; begin Result := '"'; end; function TASQLite3BaseQuery.PSGetTableName: string; begin Result := GetTableNameFromSQL(FSQL.Text); end; function TASQLite3BaseQuery.PSInTransaction: Boolean; begin Result := Assigned(Connection); end; function TASQLite3BaseQuery.PSIsSQLBased: Boolean; begin Result := True; end; function TASQLite3BaseQuery.PSIsSQLSupported: Boolean; begin Result := True; end; procedure TASQLite3BaseQuery.PSSetCommandText(const CommandText: string); begin if CommandText <> '' then begin FSQL.Text := CommandText; FPrepared := CommandText; end; end; procedure TASQLite3BaseQuery.PSSetParams(AParams: TParams); begin if AParams.Count <> 0 then Params.Assign(AParams); Close; end; procedure TASQLite3BaseQuery.PSStartTransaction; begin StartTransaction; end; procedure TASQLite3BaseQuery.PSReset; begin if Active then begin Close; Open; end; end; function TASQLite3BaseQuery.PSGetUpdateException(e: Exception; Prev: EUpdateError): EUpdateError; var PrevErr : Integer; begin // Generates an EUpdateError object based on another exception object. if e is ASGError then begin if Prev = nil then PrevErr := Prev.errorCode else PrevErr := 0; with ASGError(e) do Result := EUpdateError.Create(e.Message, '', -1, PrevErr, e); end else Result := EUpdateError.Create(e.Message, '', -1, -1, e); end; function TASQLite3BaseQuery.PSUpdateRecord(UpdateKind: TUpdateKind; Delta: TDataSet): Boolean; begin // OnUpdateRecord is not supported Result := False; end; function TASQlite3BaseQuery.PSGetKeyFields: string; var i : integer; begin Result := ''; for i := 0 to (Fields.Count - 1) do begin if pfInKey in Fields[i].ProviderFlags then begin if Result <> '' then Result := Result + ';'; Result := Result + Fields[i].FieldName; end; end; end; {$ENDIF} end.