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

1057 lines
40 KiB
ObjectPascal
Raw Permalink Blame History

/// experimental Firebird 2.5+ direct access classes to be used with our SynDB architecture
// - not finished, nor working yet: we urge you to use SynDBZeos (or SynDBODBC) instead
// - this unit is a part of the freeware Synopse mORMot framework,
// licensed under a MPL/GPL/LGPL tri-license; version 1.18
unit SynDBFirebird;
{
This file is part of Synopse mORMot framework.
Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez
Synopse Informatique - https://synopse.info
*** BEGIN LICENSE BLOCK *****
Version: MPL 1.1/GPL 2.0/LGPL 2.1
The contents of this file are subject to the Mozilla Public License Version
1.1 (the "License"); you may not use this file except in compliance with
the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
for the specific language governing rights and limitations under the License.
The Original Code is Synopse mORMot framework.
The Initial Developer of the Original Code is Arnaud Bouchez.
Portions created by the Initial Developer are Copyright (C) 2022
the Initial Developer. All Rights Reserved.
Contributor(s):
Alternatively, the contents of this file may be used under the terms of
either the GNU General Public License Version 2 or later (the "GPL"), or
the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
in which case the provisions of the GPL or the LGPL are applicable instead
of those above. If you wish to allow use of your version of this file only
under the terms of either the GPL or the LGPL, and not to allow others to
use your version of this file under the terms of the MPL, indicate your
decision by deleting the provisions above and replace them with the notice
and other provisions required by the GPL or the LGPL. If you do not delete
the provisions above, a recipient may use your version of this file under
the terms of any one of the MPL, the GPL or the LGPL.
***** END LICENSE BLOCK *****
WARNING: This unit is NOT FINISHED and doesn't work as expected!
PLEASE USE SynDBZeos instead!
TODO:
- share a global database connection for embedded mode, instead of
setting ForceOnlyOneSharedConnection=true
}
{$I Synopse.inc} // define HASINLINE CPU32 CPU64 OWNNORMTOUPPER
interface
uses
{$ifdef MSWINDOWS}
Windows,
{$endif MSWINDOWS}
SysUtils,
{$ifndef DELPHI5OROLDER}
Variants,
{$endif}
Classes,
Contnrs,
SynCommons,
SynTable,
SynLog,
SynDB;
{ -------------- TSQLDBFirebird* classes and types implementing a Firebird connection }
type
/// generic Exception type, generated for Firebird connection
EFirebirdException = class(ESQLDBException);
/// implements properties shared by the Firebird library
// - will first search for a "Firebird Embedded Server" library in the
// executable folder or its 'Firebird\' sub-folder
// - if not found, the Firebird client library will be searched in the path,
// or, in default, from the Windows registry settings
// - use TSQLDBFirebirdEmbeddedConnectionProperties or
// TSQLDBFirebirdConnectionClientProperties to force either of the two modes
// - we focus on Firebird 2.5.0 and up (released on October 2010), since it
// was the first multi-thread-capable and thread-safe client implementation
// - not finished, nor working yet: we urge you to use SynDBZeos (or SynDBODBC) instead
TSQLDBFirebirdConnectionProperties = class(TSQLDBConnectionPropertiesThreadSafe)
protected
fDefaultPageSize: Integer;
/// opaque protected reference to the corresponding TFirebirdLib instance
fFirebirdInstance: TObject;
// this overridden method will force dFirebird kind of DBMS
procedure SetInternalProperties; override;
public
/// initialize the connection properties
// - will raise an exception if no Firebird library is available
constructor Create(const aServerName, aDatabaseName, aUserID, aPassWord: RawUTF8); override;
/// create a new connection
// - call this method if the shared MainConnection is not enough (e.g. for
// multi-thread access)
// - the caller is responsible of freeing this instance
// - this overridden method will create an TSQLDBFirebirdConnection instance
function NewConnection: TSQLDBConnection; override;
/// the page size on disk to be used when creating a new database file
// - only used in embedded mode, if no database file exists
// - default value is 4096, but you may set 8192 or 16384 for better performance
property DefaultPageSize: Integer read fDefaultPageSize write fDefaultPageSize;
end;
/// implements properties shared by the Firebird embedded engine
// - will search for a "Firebird Embedded Server" library in the executable
// folder or its 'Firebird\' sub-folder
// - if not found, will raise an EFirebirdException
TSQLDBFirebirdEmbeddedConnectionProperties = class(TSQLDBFirebirdConnectionProperties)
public
/// initialize the embedded connection properties
// - will raise an exception if no embedded Firebird library is available
constructor Create(const aServerName, aDatabaseName, aUserID, aPassWord: RawUTF8); override;
end;
/// implements a direct connection to the Firebird client library
// - the Firebird client libray will be searched in the path, or, in default,
// from the Windows registry settings
// - if not found, will raise an EFirebirdException
TSQLDBFirebirdConnectionClientProperties = class(TSQLDBFirebirdConnectionProperties)
public
/// initialize the embedded connection properties
// - will raise an exception if no embedded Firebird library is available
constructor Create(const aServerName, aDatabaseName, aUserID, aPassWord: RawUTF8); override;
end;
TSQLDBFirebirdStatus = array[0..19] of PtrInt;
/// implements a direct connection to the Firebird library
TSQLDBFirebirdConnection = class(TSQLDBConnectionThreadSafe)
protected
fFirebirdProperties: TSQLDBFirebirdConnectionProperties;
fEmbedded: boolean;
fBuf: PByteArray;
fBufLen: integer;
fStatus: TSQLDBFirebirdStatus;
fDatabase: pointer;
fTransaction: pointer;
// increased on each StartTransaction call
fTransactionID: cardinal;
/// opaque protected reference to the corresponding TFirebirdLib instance
fFirebirdInstance: TObject;
procedure BufAddStr(dpb: byte; const Value: RawUTF8; DoNotStoreIfBlank: boolean=true);
procedure BufAddI8(dpb: byte; Value: byte=0);
procedure BufAddI32(dpb: byte; Value: cardinal);
procedure BufClear;
public
/// connect to a specified Firebird database
constructor Create(aProperties: TSQLDBConnectionProperties); override;
/// release memory and connection
destructor Destroy; override;
/// connect to the Firebird library, i.e. create the DB instance
// - should raise an Exception on error
procedure Connect; override;
/// stop connection to the Firebird library, i.e. release the DB instance
// - should raise an Exception on error
procedure Disconnect; override;
/// return TRUE if Connect has been already successfully called
function IsConnected: boolean; override;
/// initialize a new SQL query statement for the given connection
// - the caller should free the instance after use
function NewStatement: TSQLDBStatement; override;
/// begin a Transaction for this connection
// - current implementation do not support nested transaction with those
// methods: exception will be raised in such case
procedure StartTransaction; override;
/// commit changes of a Transaction for this connection
// - StartTransaction method must have been called before
procedure Commit; override;
/// discard changes of a Transaction for this connection
// - StartTransaction method must have been called before
procedure Rollback; override;
published
/// TRUE if the Embedded Firebird Library is used for this connection
property Embedded: boolean read fEmbedded;
end;
TSQLDBFirebirdInternalStatement = record
Transaction: pointer;
TransactionID: cardinal;
Statement: pointer;
end;
/// implements a statement using a Firebird connection
TSQLDBFirebirdStatement = class(TSQLDBStatementWithParamsAndColumns)
protected
fMain: TSQLDBFirebirdInternalStatement;
fAutoCommit: TSQLDBFirebirdInternalStatement;
fCurrent: ^TSQLDBFirebirdInternalStatement;
fInput: TByteDynArray;
fOutput: TByteDynArray;
fStatus: TSQLDBFirebirdStatus;
function ReleaseMainStatementIfAny: boolean;
public
{{ create a Firebird statement instance, from an existing Firebird connection
- the Execute method can be called once per TSQLDBFirebirdStatement instance,
but you can use the Prepare once followed by several ExecutePrepared methods
- if the supplied connection is not of TOleDBConnection type, will raise
an exception }
constructor Create(aConnection: TSQLDBConnection); override;
{{ release all associated memory and Firebird handles }
destructor Destroy; override;
{{ Prepare an UTF-8 encoded SQL statement
- parameters marked as ? will be bound later, before ExecutePrepared call
- if ExpectResults is TRUE, then Step() and Column*() methods are available
to retrieve the data rows
- raise an EFirebirdException or ESQLDBException on any error }
procedure Prepare(const aSQL: RawUTF8; ExpectResults: Boolean=false); overload; override;
{{ Execute a prepared SQL statement
- parameters marked as ? should have been already bound with Bind*() functions
- raise an EFirebirdException or ESQLDBException on any error }
procedure ExecutePrepared; override;
{/ Reset the previous prepared statement
- this overridden implementation will reset all bindings and the cursor state
- raise an EFirebirdException on any error }
procedure Reset; override;
{/ After a statement has been prepared via Prepare() + ExecutePrepared() or
Execute(), this method must be called one or more times to evaluate it
- you shall call this method before calling any Column*() methods
- return TRUE on success, with data ready to be retrieved by Column*()
- return FALSE if no more row is available (e.g. if the SQL statement
is not a SELECT but an UPDATE or INSERT command)
- access the first or next row of data from the SQL Statement result:
if SeekFirst is TRUE, will put the cursor on the first row of results,
otherwise, it will fetch one row of data, to be called within a loop
- raise an EFirebirdException or ESQLDBException exception on any error }
function Step(SeekFirst: boolean=false): boolean; override;
{{ returns TRUE if the column contains NULL }
function ColumnNull(Col: integer): boolean; override;
{{ return a Column integer value of the current Row, first Col is 0 }
function ColumnInt(Col: integer): Int64; override;
{{ return a Column floating point value of the current Row, first Col is 0 }
function ColumnDouble(Col: integer): double; override;
{{ return a Column floating point value of the current Row, first Col is 0 }
function ColumnDateTime(Col: integer): TDateTime; override;
{{ return a Column currency value of the current Row, first Col is 0
- should retrieve directly the 64 bit Currency content, to avoid
any rounding/conversion error from floating-point types }
function ColumnCurrency(Col: integer): currency; override;
{{ return a Column UTF-8 encoded text value of the current Row, first Col is 0 }
function ColumnUTF8(Col: integer): RawUTF8; override;
{{ return a Column as a blob value of the current Row, first Col is 0
- ColumnBlob() will return the binary content of the field is was not ftBlob,
e.g. a 8 bytes RawByteString for a vtInt64/vtDouble/vtDate/vtCurrency,
or a direct mapping of the RawUnicode }
function ColumnBlob(Col: integer): RawByteString; override;
{{ append all columns values of the current Row to a JSON stream
- will use WR.Expand to guess the expected output format
- fast overridden implementation with no temporary variable
- BLOB field value is saved as Base64, in the '"\uFFF0base64encodedbinary"
format and contains true BLOB data }
procedure ColumnsToJSON(WR: TJSONWriter); override;
/// returns the number of rows updated by the execution of this statement
function UpdateCount: integer; override;
end;
const
FBLIBNAME: array[boolean] of TFileName =
{$ifdef MSWINDOWS}
('gds32.dll','fbembed.dll');
{$endif}
{$ifdef LINUX}
('libfbclient.so','libfbembed.so');
{$endif}
/// check from the file beginning if sounds like a valid Firebird database file
// - no official signature is available, so it will be a "best-guess"
function IsFirebirdFile(const FileName: TFileName): boolean;
implementation
function IsFirebirdFile(const FileName: TFileName): boolean;
var F: THandle;
Header: packed record
pag_type, pag_flags: byte;
pag_checksum: word;
pag_generation, pag_scn, reserved: cardinal;
hdr_page_size, hdr_ods_version: word;
end; // cf. http://www.firebirdsql.org/manual/fbint-standard-header.html
begin
F := FileOpen(FileName,fmOpenRead or fmShareDenyNone);
if F<=0 then
result := false else begin
result := (FileRead(F,Header,sizeof(Header))=SizeOf(Header)) and
(Header.pag_type=1) and (Header.pag_checksum=12345) and
(Header.hdr_page_size and $3ff=0) and (Header.hdr_ods_version and $8000<>0);
FileClose(F);
end;
end;
{ -------------- Firebird library interfaces, constants and types }
const
METADATALENGTH = 68;
MAX_DPB_SIZE = 1024;
{ supports SQL delimited identifier, SQLDATE/DATE, TIME,
TIMESTAMP, CURRENT_DATE, CURRENT_TIME, CURRENT_TIMESTAMP, and
64-bit exact numeric type }
SQL_DIALECT = 3;
// fits XSQLDA/XSQLVAR layout
SQLDA_CURRENT_VERSION = 1;
DSQL_close = 1;
DSQL_drop = 2;
type
PIscTrHandle = PPointer;
ISCStatus = PtrInt;
PISCStatus = ^ISCStatus;
PPISCStatus = ^PISCStatus;
PGDSQuad = ^GDS_Quad;
PISCQuad = ^GDS_Quad;
GDS_QUAD = record
gds_quad_high: integer;
gds_quad_low: cardinal;
end;
PXSQLVar = ^XSQLVar;
XSQLVAR = object
// datatype of field
sqltype: Smallint;
// scale factor
sqlscale: Smallint;
// datatype subtype
sqlsubtype: Smallint;
// length of data area
sqllen: Smallint;
// address of data
sqldata: PAnsiChar;
// address of indicator variable
sqlind: PSmallintArray;
// length of sqlname field
sqlname_length: Smallint;
// name of field, name length + space for #0
sqlname: array[0..METADATALENGTH-1] of AnsiChar;
// length of relation name
relname_length: Smallint;
// field's relation name + space for #0
relname: array[0..METADATALENGTH-1] of AnsiChar;
// length of owner name
ownname_length: Smallint;
// relation's owner name + space for #0
ownname: array[0..METADATALENGTH-1] of AnsiChar;
// length of alias name
aliasname_length: Smallint;
// relation's alias name + space for #0
aliasname: array[0..METADATALENGTH-1] of AnsiChar;
// wrapper to return the column name from sqlname[] content
function ColumnName: RawUTF8;
end;
PXSQLDA = ^XSQLDA;
XSQLDA = record
// version of this XSQLDA = SQLDA_CURRENT_VERSION = 1
version: Smallint;
// XSQLDA name field -> RESERVED
sqldaid: array[0..7] of AnsiChar;
// length in bytes of SQLDA -> RESERVED
sqldabc: Integer;
// number of fields allocated
sqln: Smallint;
// actual number of fields
sqld: Smallint;
// fields content
sqlvar: array[0..0] of XSQLVar;
end;
// used by isc_start_multiple()
PISCTEB = ^TISCTEB;
TISCTEB = record
Handle: pointer;
Len: Integer;
Address: PAnsiChar;
end;
// Database parameter block stuff
TFirebirdDatabaseParameterBlock = (dpb_cdd_pathname=1,
dpb_allocation, dpb_journal, dpb_page_size, dpb_num_buffers,
dpb_buffer_length, dpb_debug, dpb_garbage_collect, dpb_verify, dpb_sweep,
dpb_enable_journal, dpb_disable_journal, dpb_dbkey_scope, dpb_number_of_users,
dpb_trace, dpb_no_garbage_collect, dpb_damaged, dpb_license, dpb_sys_user_name,
dpb_encrypt_key, dpb_activate_shadow, dpb_sweep_interval, dpb_delete_shadow,
dpb_force_write, dpb_begin_log, dpb_quit_log, dpb_no_reserve, dpb_user_name,
dpb_password, dpb_password_enc, dpb_sys_user_name_enc, dpb_interp, dpb_online_dump,
dpb_old_file_size, dpb_old_num_files, dpb_old_file, dpb_old_start_page,
dpb_old_start_seqno, dpb_old_start_file, dpb_drop_walfile, dpb_old_dump_id,
dpb_wal_backup_dir, dpb_wal_chkptlen, dpb_wal_numbufs, dpb_wal_bufsize,
dpb_wal_grp_cmt_wait, dpb_lc_messages, dpb_lc_ctype, dpb_cache_manager,
dpb_shutdown, dpb_online, dpb_shutdown_delay, dpb_reserved,
dpb_overwrite, dpb_sec_attach, dpb_disable_wal, dpb_connect_timeout,
dpb_dummy_packet_interval, dpb_gbak_attach, dpb_sql_role_name,
dpb_set_page_buffers, dpb_working_directory, dpb_sql_dialect,
dpb_set_db_readonly, dpb_set_db_sql_dialect, dpb_gfix_attach, dpb_gstat_attach);
/// direct access to the Firebird library
TFirebirdLib = class(TSQLDBLib)
protected
fEmbedded: boolean;
public
isc_attach_database: function(var user_status: TSQLDBFirebirdStatus; file_length: Smallint;
file_name: PAnsiChar; var handle: pointer; dpb_length: Smallint; dpb: PByteArray): ISCStatus;
{$ifdef MSWINDOWS} stdcall {$else} cdecl {$endif};
isc_detach_database: function(var user_status: TSQLDBFirebirdStatus; var handle: pointer): ISCStatus;
{$ifdef MSWINDOWS} stdcall {$else} cdecl {$endif};
isc_create_database: function(var user_status: TSQLDBFirebirdStatus; file_length: Smallint;
file_name: PAnsiChar; var handle: pointer; dpb_length: Smallint; dpb: PAnsiChar;
db_type: Smallint): ISCStatus;
{$ifdef MSWINDOWS} stdcall {$else} cdecl {$endif};
isc_sqlcode: function (var user_status: TSQLDBFirebirdStatus): integer;
{$ifdef MSWINDOWS} stdcall {$else} cdecl {$endif};
isc_sql_interprete: procedure(sqlcode: SmallInt; buf: PAnsiChar; buflen: SmallInt);
{$ifdef MSWINDOWS} stdcall {$else} cdecl {$endif};
fb_interpret: function(buf: PAnsiChar; bufsize: integer; status_vector: PPISCStatus): ISCStatus;
{$ifdef MSWINDOWS} stdcall {$else} cdecl {$endif};
isc_dsql_execute_immediate: function(var user_status: TSQLDBFirebirdStatus; var db_handle: pointer;
tra_handle: PIscTrHandle; buflen: Word; buf: PAnsiChar; dialect: Word=SQL_DIALECT;
sqlda: PXSQLDA=nil): ISCStatus;
{$ifdef MSWINDOWS} stdcall {$else} cdecl {$endif};
isc_start_multiple: function(var user_status: TSQLDBFirebirdStatus; var tra_handle: pointer;
count: Smallint; vector: PISCTEB): ISCStatus;
{$ifdef MSWINDOWS} stdcall {$else} cdecl {$endif};
isc_rollback_transaction: function(var user_status: TSQLDBFirebirdStatus; var tra_handle: pointer): ISCStatus;
{$ifdef MSWINDOWS} stdcall {$else} cdecl {$endif};
isc_commit_transaction: function(var user_status: TSQLDBFirebirdStatus; var tra_handle: pointer): ISCStatus;
{$ifdef MSWINDOWS} stdcall {$else} cdecl {$endif};
isc_commit_retaining: function(var user_status: TSQLDBFirebirdStatus; var tra_handle: pointer): ISCStatus;
{$ifdef MSWINDOWS} stdcall {$else} cdecl {$endif};
isc_dsql_allocate_statement: function(var user_status: TSQLDBFirebirdStatus; var db_handle: pointer;
var stmt_handle: pointer): ISCStatus;
{$ifdef MSWINDOWS} stdcall {$else} cdecl {$endif};
isc_dsql_free_statement: function(var user_status: TSQLDBFirebirdStatus; var stmt_handle: pointer;
option: Word): ISCStatus;
{$ifdef MSWINDOWS} stdcall {$else} cdecl {$endif};
isc_dsql_execute: function(var user_status: TSQLDBFirebirdStatus; var tra_handle: pointer;
var stmt_handle: pointer; dialect: Word; sqlda: PXSQLDA): ISCStatus;
{$ifdef MSWINDOWS} stdcall {$else} cdecl {$endif};
isc_dsql_describe: function(var user_status: TSQLDBFirebirdStatus; var stmt_handle: pointer;
dialect: Word; sqlda: PXSQLDA): ISCStatus;
{$ifdef MSWINDOWS} stdcall {$else} cdecl {$endif};
isc_dsql_prepare: function(var user_status: TSQLDBFirebirdStatus; var tra_handle: pointer;
var stmt_handle: pointer; buflen: Word; buf: PAnsiChar; dialect: Word;
sqlda: PXSQLDA): ISCStatus;
{$ifdef MSWINDOWS} stdcall {$else} cdecl {$endif};
isc_dsql_sql_info: function(var user_status: TSQLDBFirebirdStatus; var stmt_handle: pointer;
itemlsength: Smallint; items: PAnsiChar; buflen: Smallint; buf: PAnsiChar): ISCStatus;
{$ifdef MSWINDOWS} stdcall {$else} cdecl {$endif};
isc_create_blob2: function(var user_status: TSQLDBFirebirdStatus; var db_handle: pointer;
var tra_handle: pointer; var blob_handle: pointer; blob_id: PISCQuad;
bpb_length: Smallint; bpb: PAnsiChar): ISCStatus;
{$ifdef MSWINDOWS} stdcall {$else} cdecl {$endif};
isc_put_segment: function(var user_status: TSQLDBFirebirdStatus; var blob_handle: pointer;
buffer_length: Word; buffer: PAnsiChar): ISCStatus;
{$ifdef MSWINDOWS} stdcall {$else} cdecl {$endif};
isc_close_blob: function(var user_status: TSQLDBFirebirdStatus; var blob_handle: pointer): ISCStatus;
{$ifdef MSWINDOWS} stdcall {$else} cdecl {$endif};
isc_dsql_set_cursor_name: function(var user_status: TSQLDBFirebirdStatus; var stmt_handle: pointer;
cursorname: PAnsiChar; type_: Word=0): ISCStatus;
{$ifdef MSWINDOWS} stdcall {$else} cdecl {$endif};
public
/// load the Firebird library
// - and retrieve all SQL*() addresses for FIREBIRD_ENTRIES[] items
constructor Create(aEmbedded: boolean);
/// raise an EFirebirdException on error
procedure Check(Status: ISCStatus; var PrivateStatus: TSQLDBFirebirdStatus);
/// wrapper around isc_start_multiple() function
procedure StartTransaction(var PrivateStatus: TSQLDBFirebirdStatus;
var Database, Transaction: pointer);
/// if the library is the "Firebird Embedded Server" version
property Embedded: boolean read fEmbedded;
end;
const
isc_dpb_version1 = 1;
FIREBIRD_ENTRIES: array[0..20] of PChar =
('isc_attach_database','isc_detach_database','isc_create_database',
'isc_sqlcode','isc_sql_interprete','fb_interpret',
'isc_dsql_execute_immediate',
'isc_start_multiple','isc_rollback_transaction','isc_commit_transaction',
'isc_commit_retaining',
'isc_dsql_allocate_statement','isc_dsql_free_statement',
'isc_dsql_execute','isc_dsql_describe','isc_dsql_prepare',
'isc_dsql_sql_info','isc_create_blob2','isc_put_segment','isc_close_blob',
'isc_dsql_set_cursor_name');
{ TSQLDBFirebirdConnection }
procedure TSQLDBFirebirdConnection.Connect;
var Log: ISynLog;
ServerName, SQL: RawByteString;
begin
Log := SynDBLog.Enter;
Disconnect;
if fProperties.ServerName='' then
raise EFirebirdException.Create('ServerName missing');
ServerName := CurrentAnsiConvert.UTF8ToAnsi(fProperties.ServerName);
with TFirebirdLib(fFirebirdInstance) do begin
if fEmbedded and not FileExists(
{$ifdef UNICODE}UTF8ToString(fProperties.ServerName){$else}ServerName{$endif}) then begin
SQL := fProperties.SQLCreateDatabase(fProperties.ServerName,
TSQLDBFirebirdConnectionProperties(fProperties).DefaultPageSize);
Log.Log(sllDB,'No DB file found -> % using %', [SQL,LibraryPath],fProperties);
Check(isc_dsql_execute_immediate(fStatus,fDatabase,nil,0,pointer(SQL)),fStatus);
exit;
end;
Log.Log(sllDB,'Connect to "%" as "%" using %',
[fProperties.ServerName,fProperties.UserID,LibraryPath],fProperties);
BufClear;
BufAddStr(ord(dpb_user_name),fProperties.UserID);
BufAddStr(ord(dpb_password),fProperties.PassWord);
Check(isc_attach_database(fStatus,length(ServerName),pointer(ServerName),
fDatabase,fBufLen,fBuf),fStatus);
inherited Connect; // notify any re-connection
end;
end;
constructor TSQLDBFirebirdConnection.Create(aProperties: TSQLDBConnectionProperties);
begin
if not aProperties.InheritsFrom(TSQLDBFirebirdConnectionProperties) then
raise EFirebirdException.Create('Invalid TSQLDBFirebirdConnection.Create');
fFirebirdProperties := TSQLDBFirebirdConnectionProperties(aProperties);
fFirebirdInstance := fFirebirdProperties.fFirebirdInstance;
fEmbedded := TFirebirdLib(fFirebirdProperties.fFirebirdInstance).Embedded;
GetMem(fBuf,MAX_DPB_SIZE);
inherited;
end;
destructor TSQLDBFirebirdConnection.Destroy;
begin
inherited Destroy;
FreeMem(fBuf);
end;
procedure TSQLDBFirebirdConnection.Disconnect;
begin
try
inherited Disconnect; // flush any cached statement
finally
if fFirebirdInstance=nil then
raise EFirebirdException.Create('No lib');
if fDatabase<>nil then
with TFirebirdLib(fFirebirdInstance) do begin
if TransactionCount>0 then
Rollback;
Check(isc_detach_database(fStatus,fDatabase),fStatus);
end;
end;
end;
function TSQLDBFirebirdConnection.IsConnected: boolean;
begin
result := fDatabase<>nil;
end;
function TSQLDBFirebirdConnection.NewStatement: TSQLDBStatement;
begin
result := TSQLDBFirebirdStatement.Create(self);
end;
procedure TSQLDBFirebirdConnection.Commit;
begin
inherited Commit;
if fTransaction=nil then
raise EFirebirdException.Create('Commit');
with TFirebirdLib(fFirebirdInstance) do
try
Check(isc_commit_transaction(fStatus,fTransaction),fStatus);
except
inc(fTransactionCount); // the transaction is still active
raise;
end;
end;
procedure TSQLDBFirebirdConnection.Rollback;
begin
inherited RollBack;
if fTransaction=nil then
raise EFirebirdException.Create('Rollback');
with TFirebirdLib(fFirebirdInstance) do
Check(isc_rollback_transaction(fStatus,fTransaction),fStatus);
end;
procedure TSQLDBFirebirdConnection.StartTransaction;
begin
if TransactionCount>0 then
raise EFirebirdException.Create('TSQLDBFirebirdConnection do not provide nested transactions');
inherited StartTransaction;
if fTransaction<>nil then
raise EFirebirdException.Create('StartTransaction');
inc(fTransactionID);
TFirebirdLib(fFirebirdInstance).StartTransaction(fStatus,fDatabase,fTransaction);
end;
procedure TSQLDBFirebirdConnection.BufClear;
begin
fBuf[0] := isc_dpb_version1;
fBufLen := 1;
end;
procedure TSQLDBFirebirdConnection.BufAddStr(dpb: byte; const Value: RawUTF8;
DoNotStoreIfBlank: boolean);
var L: integer;
begin
L := length(Value);
if (L=0) and DoNotStoreIfBlank then
exit;
if L>255 then
raise EFirebirdException.Create('BufAddStr size>255');
if fBufLen+L>=MAX_DPB_SIZE-5 then
raise EFirebirdException.Create('BufAdd overflow');
fBuf[fBufLen] := dpb;
inc(fBufLen);
fBuf[fBufLen] := L;
inc(fBufLen);
move(pointer(Value)^,fBuf[fBufLen],L);
inc(fBufLen,L);
end;
procedure TSQLDBFirebirdConnection.BufAddI32(dpb: byte; Value: cardinal);
begin
fBuf[fBufLen] := dpb;
inc(fBufLen);
case Value of
0..255: begin
fBuf[fBufLen] := 1;
inc(fBufLen);
fBuf[fBufLen] := Value;
inc(fBufLen);
end;
256..65535: begin
fBuf[fBufLen] := 2;
inc(fBufLen);
PWord(@fBuf[fBufLen])^ := Value;
inc(fBufLen,2);
end;
else begin
fBuf[fBufLen] := 4;
inc(fBufLen);
PCardinal(@fBuf[fBufLen])^ := Value;
inc(fBufLen,4);
end;
end;
end;
procedure TSQLDBFirebirdConnection.BufAddI8(dpb, Value: byte);
begin
fBuf[fBufLen] := dpb;
inc(fBufLen);
fBuf[fBufLen] := Value;
inc(fBufLen);
end;
{ TSQLDBFirebirdStatement }
function TSQLDBFirebirdStatement.ColumnBlob(Col: integer): RawByteString;
begin
end;
function TSQLDBFirebirdStatement.ColumnUTF8(Col: integer): RawUTF8;
begin
end;
function TSQLDBFirebirdStatement.ColumnCurrency(Col: integer): currency;
begin
end;
function TSQLDBFirebirdStatement.ColumnDateTime(Col: integer): TDateTime;
begin
end;
function TSQLDBFirebirdStatement.ColumnDouble(Col: integer): double;
begin
end;
function TSQLDBFirebirdStatement.ColumnInt(Col: integer): Int64;
begin
end;
function TSQLDBFirebirdStatement.ColumnNull(Col: integer): boolean;
begin
end;
procedure TSQLDBFirebirdStatement.ColumnsToJSON(WR: TJSONWriter);
var col, METHODTOBEWRITTEN: integer;
begin
if (CurrentRow<=0) then
raise EFirebirdException.Create('TSQLDBFirebirdStatement.ColumnsToJSON() with no prior Step');
if WR.Expand then
WR.Add('{');
for col := 0 to fColumnCount-1 do // fast direct conversion from OleDB buffer
with fColumns[col] do begin
if WR.Expand then
WR.AddFieldName(ColumnName); // add '"ColumnName":'
// ....
WR.Add(',');
end;
WR.CancelLastComma; // cancel last ','
if WR.Expand then
WR.Add('}');
end;
constructor TSQLDBFirebirdStatement.Create(aConnection: TSQLDBConnection);
begin
if not aConnection.InheritsFrom(TSQLDBFirebirdConnection) then
raise EFirebirdException.CreateFmt('%s.Create expects a TSQLDBFirebirdConnection',[ClassName]);
inherited Create(aConnection);
end;
destructor TSQLDBFirebirdStatement.Destroy;
begin
try
with TFirebirdLib(TSQLDBFirebirdConnection(fConnection).fFirebirdInstance) do begin
if fMain.Statement<>nil then
Check(isc_dsql_free_statement(fStatus,fMain.Statement,DSQL_drop),fStatus);
if fAutoCommit.Statement<>nil then
Check(isc_dsql_free_statement(fStatus,fAutoCommit.Statement,DSQL_drop),fStatus);
if fAutoCommit.Transaction<>nil then
Check(isc_rollback_transaction(fStatus,fAutoCommit.Transaction),fStatus);
end;
finally
inherited Destroy;
end;
end;
function TSQLDBFirebirdStatement.UpdateCount: integer;
begin
end;
procedure TSQLDBFirebirdStatement.Prepare(const aSQL: RawUTF8; ExpectResults: Boolean);
var Log: ISynLog;
Conn: TSQLDBFirebirdConnection;
begin
Log := SynDBLog.Enter(self, 'Prepare');
if (fColumnCount>0) or (fAutoCommit.Statement<>nil) or (fCurrent<>nil) then
raise EFirebirdException.CreateFmt('%s.Prepare should be called only once',[ClassName]);
// 1. process SQL
inherited Prepare(aSQL,ExpectResults); // set fSQL + Connect if necessary
// 2. prepare statement and bind result columns (if any)
Conn := TSQLDBFirebirdConnection(fConnection);
with TFirebirdLib(Conn.fFirebirdInstance) do
try
// always prepare auto-commit transaction and associated statement
StartTransaction(fStatus,Conn.fDatabase,fAutoCommit.Transaction);
Check(isc_dsql_allocate_statement(fStatus,Conn.fDatabase,fAutoCommit.Statement),fStatus);
Check(isc_dsql_prepare(fStatus,fAutoCommit.Transaction,fAutoCommit.Statement,length(fSQL),
pointer(fSQL),SQL_DIALECT,nil),fStatus);
// execution within a main transaction will be prepared on purpose
except
on E: Exception do begin
Log.Log(sllError,E);
raise;
end;
end;
end;
function TSQLDBFirebirdStatement.ReleaseMainStatementIfAny: boolean;
var MainConn: TSQLDBFirebirdConnection;
begin
if (fAutoCommit.Statement=nil) or (fAutoCommit.Transaction=nil) then
raise EFirebirdException.Create('Prepare should be called before ExecutePrepared/Reset');
MainConn := TSQLDBFirebirdConnection(fConnection);
with TFirebirdLib(MainConn.fFirebirdInstance) do
if (fMain.Transaction<>nil) and (MainConn.fTransactionID<>fMain.TransactionID) then
try
Check(isc_dsql_free_statement(fStatus,fMain.Statement,DSQL_drop),fStatus);
Check(isc_rollback_transaction(fStatus,fMain.Transaction),fStatus);
result := true;
finally // force nil: connection may be lost
fMain.Statement := nil;
fMain.Transaction := nil;
end else
result := false;
end;
// allocate a TByteDynArray to contain
function XSQLDAAllocate(var Buf: TByteDynArray; number: integer): PXSQLDA;
begin
SetLength(Buf,sizeof(XSQLDA)+(number-1)*sizeof(XSQLVar));
result := pointer(Buf);
result.version := SQLDA_CURRENT_VERSION;
result.sqln := number;
result.sqld := number;
end;
procedure TSQLDBFirebirdStatement.ExecutePrepared;
var MainConn: TSQLDBFirebirdConnection;
i: integer;
begin
inherited ExecutePrepared; // set fConnection.fLastAccessTicks
MainConn := TSQLDBFirebirdConnection(fConnection);
with TFirebirdLib(MainConn.fFirebirdInstance) do begin
// 1. release any deprecated main transaction/statement
ReleaseMainStatementIfAny;
// 2. decide which transaction/statement is to be used
if MainConn.fTransaction<>nil then begin
// main transaction is active -> prepare a statement for it (if needed)
if fMain.Transaction=nil then begin
fMain.Transaction := MainConn.fTransaction;
fMain.TransactionID := MainConn.fTransactionID;
assert(fMain.Statement=nil);
Check(isc_dsql_allocate_statement(fStatus,MainConn.fDatabase,fMain.Statement),fStatus);
Check(isc_dsql_prepare(fStatus,fMain.Transaction,fMain.Statement,length(fSQL),
pointer(fSQL),SQL_DIALECT,nil),fStatus);
end;
fCurrent := @fMain;
end else
// we are in auto-commit mode
fCurrent := @fAutoCommit;
// 3. bind parameters
// 4. execute the statement
if fExpectResults then
// (re)open result cursor for queries
Check(isc_dsql_set_cursor_name(fStatus,fCurrent.Statement,'SynDB'),fStatus);
Check(isc_dsql_execute(fStatus,fCurrent.Transaction,fCurrent.Statement,SQL_DIALECT,pointer(fInput)),fStatus);
if (fCurrent=@fAutoCommit) and not fExpectResults then
// emulate AUTOCOMMIT mode
Check(isc_commit_retaining(fStatus,fAutoCommit.Transaction),fStatus);
// 5. prepare results
if fOutput=nil then begin // allocate fOutput buffer (reuse the same)
Check(isc_dsql_describe(fStatus,fCurrent.Statement,SQL_DIALECT,XSQLDAAllocate(fOutput,32)),fStatus);
with PXSQLDA(fOutput)^ do
if sqld>sqln then
Check(isc_dsql_describe(fStatus,fCurrent.Statement,SQL_DIALECT,XSQLDAAllocate(fOutput,sqld)),fStatus);
with PXSQLDA(fOutput)^ do begin
for i := 0 to sqld-1 do
with PSQLDBColumnProperty(fColumn.AddAndMakeUniqueName(sqlvar[i].ColumnName))^ do begin
ColumnValueDBType := sqlvar[i].sqltype;
end;
end;
end;
end;
end;
function TSQLDBFirebirdStatement.Step(SeekFirst: boolean): boolean;
begin
result := false;
end;
procedure TSQLDBFirebirdStatement.Reset;
begin
ReleaseMainStatementIfAny; // global transaction context may have changed
with TFirebirdLib(TSQLDBFirebirdConnection(fConnection).fFirebirdInstance) do
if fExpectResults and (fCurrent<>nil) then
// release opened cursor for queries
Check(isc_dsql_free_statement(fStatus,fCurrent.Statement,DSQL_close),fStatus);
inherited Reset;
end;
{ TFirebirdLib }
procedure TFirebirdLib.Check(Status: ISCStatus; var PrivateStatus: TSQLDBFirebirdStatus);
procedure RaiseEFirebirdException;
var Code: integer;
sql,tmp: array[byte] of AnsiChar;
Vec: pointer;
msg: string;
begin
Code := isc_sqlcode(PrivateStatus);
isc_sql_interprete(Code,sql,sizeof(sql));
Vec := @PrivateStatus;
while fb_interpret(tmp,sizeof(tmp),@Vec)>0 do begin
msg := msg+' '+SysUtils.Trim(string(tmp));
if msg[length(msg)]<>'.' then
msg := msg+'.';
end;
raise EFirebirdException.CreateFmt('Firebird Error %x:%s [ SQLCODE=%d (%s) ]',
[Status,msg,Code,sql]);
end;
const
CLASS_MASK = $F0000000; // Defines the code as warning, error, info, or other
CLASS_ERROR = 0; // Code represents an error
CLASS_WARNING = 1; // Code represents a warning
CLASS_INFO = 2; // Code represents an information msg
begin
if (Status<>0) and ((Status and CLASS_MASK) shr 30=CLASS_ERROR) then
RaiseEFirebirdException;
end;
constructor TFirebirdLib.Create(aEmbedded: boolean);
var P: PPointer;
i: integer;
{$ifdef MSWINDOWS}
Key: HKEY;
Size: Cardinal;
HR: Integer;
{$endif}
l1, l2: TFileName;
begin
fEmbedded := aEmbedded;
if aEmbedded then begin
l1 := ExeVersion.ProgramFilePath;
if FileExists(l1+FBLIBNAME[true]) then
l1 := l1+FBLIBNAME[true] else
l1 := l1+'Firebird\'+FBLIBNAME[true];
end else begin
l1 := FBLIBNAME[false];
{$ifdef MSWINDOWS} // also search from registry
HR := RegOpenKeyEx(HKEY_LOCAL_MACHINE,
'SOFTWARE\Firebird Project\Firebird Server\Instances',0,KEY_READ,Key);
if HR=ERROR_SUCCESS then begin
HR := RegQueryValueEx(Key,'DefaultInstance',nil,nil,nil,@Size);
if HR=ERROR_SUCCESS then begin
SetLength(l2,Size div SizeOf(Char));
HR := RegQueryValueEx(Key,'DefaultInstance',nil,nil,pointer(l2),@Size);
if HR=ERROR_SUCCESS then begin
l2 := IncludeTrailingPathDelimiter(SysUtils.Trim(l2));
if FileExists(l2+FBLIBNAME[false]) then
l2 := l2+FBLIBNAME[false] else
l2 := l2+('bin\'+FBLIBNAME[false]);
end;
end;
RegCloseKey(Key);
end;
{$endif}
end;
TryLoadLibrary([l1, l2],EFirebirdException);
SynDBLog.Add.Log(sllDebug,'Loading %',StringToUTF8(LibraryPath));
P := @@isc_attach_database;
for i := 0 to High(FIREBIRD_ENTRIES) do begin
P^ := GetProcAddress(fHandle,FIREBIRD_ENTRIES[i]);
if P^=nil then begin
FreeLibrary(fHandle);
fHandle := 0;
raise EFirebirdException.CreateFmt('Invalid %s: missing %s',
[LibraryPath,Firebird_ENTRIES[i]]);
end;
inc(P);
end;
end;
procedure TFirebirdLib.StartTransaction(var PrivateStatus: TSQLDBFirebirdStatus;
var Database, Transaction: pointer);
var Vector: TISCTEB;
begin
Vector.Handle := @Database;
Vector.Len := 0;
Vector.Address := nil;
Check(isc_start_multiple(PrivateStatus,Transaction,1,@Vector),PrivateStatus);
end;
{ TSQLDBFirebirdConnectionProperties }
var
// define two GlobalFirebird[Embedded] libraries instances
GlobalFirebird: array[boolean] of TFirebirdLib;
function Firebird(Embedded: boolean): TFirebirdLib;
begin
if GlobalFirebird[Embedded]=nil then
try
result := TFirebirdLib.Create(Embedded);
GarbageCollector.Add(result);
GlobalFirebird[Embedded] := result;
except
on E: EFirebirdException do begin
GlobalFirebird[Embedded] := pointer(-1);
result := nil;
end;
end else
if GlobalFirebird[Embedded]=pointer(-1) then
result := nil else
result := GlobalFirebird[Embedded];
end;
constructor TSQLDBFirebirdConnectionProperties.Create(const aServerName,
aDatabaseName, aUserID, aPassWord: RawUTF8);
begin
fDefaultPageSize := 4096;
if fFirebirdInstance=nil then
fFirebirdInstance := Firebird(true); // first check embedded
if fFirebirdInstance=nil then
fFirebirdInstance := Firebird(false); // then client
if fFirebirdInstance=nil then
raise EFirebirdException.CreateFmt('%s.Create: no library',[ClassName]);
inherited;
end;
function TSQLDBFirebirdConnectionProperties.NewConnection: TSQLDBConnection;
begin
result := TSQLDBFirebirdConnection.Create(self);
end;
procedure TSQLDBFirebirdConnectionProperties.SetInternalProperties;
begin
if TFirebirdLib(fFirebirdInstance).Embedded then
// disable multi-thread if embedded (avoid stability/performance issues)
ThreadingMode := tmMainConnection;
fDBMS := dFirebird;
end;
{ TSQLDBFirebirdEmbeddedConnectionProperties }
constructor TSQLDBFirebirdEmbeddedConnectionProperties.Create(
const aServerName, aDatabaseName, aUserID, aPassWord: RawUTF8);
begin
if fFirebirdInstance=nil then
fFirebirdInstance := Firebird(true);
if fFirebirdInstance=nil then
raise EFirebirdException.CreateFmt('%s.Create: no embedded library',[ClassName]);
inherited;
end;
{ TSQLDBFirebirdConnectionClientProperties }
constructor TSQLDBFirebirdConnectionClientProperties.Create(
const aServerName, aDatabaseName, aUserID, aPassWord: RawUTF8);
begin
if fFirebirdInstance=nil then
fFirebirdInstance := Firebird(false);
if fFirebirdInstance=nil then
raise EFirebirdException.CreateFmt('%s.Create: no client library',[ClassName]);
inherited;
end;
{ XSQLVAR }
function XSQLVAR.ColumnName: RawUTF8;
begin
SetString(result,sqlname,sqlname_length);
end;
initialization
assert(ord(dpb_gstat_attach)=67);
TSQLDBFirebirdConnectionProperties.RegisterClassNameForDefinition;
end.
Reference in New Issue View Git Blame Copy Permalink