source upload
This commit is contained in:
Razor12911
313
contrib/mORMot/SynDBDataset/SynDBBDE.pas
Normal file
313
contrib/mORMot/SynDBDataset/SynDBBDE.pas
Normal file
@@ -0,0 +1,313 @@
|
||||
/// BDE access classes for SynDB units
|
||||
// - this unit is a part of the freeware Synopse framework,
|
||||
// licensed under a MPL/GPL/LGPL tri-license; version 1.18
|
||||
unit SynDBBDE;
|
||||
|
||||
{
|
||||
This file is part of Synopse framework.
|
||||
|
||||
Synopse framework. Copyright (C) 2020 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) 2020
|
||||
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 *****
|
||||
|
||||
Todo:
|
||||
- use BDE metadata to retrieve table names and field definitions from
|
||||
any supported database (not only our SynDB.TSQLDBDefinition list)
|
||||
}
|
||||
|
||||
{$I Synopse.inc} // define HASINLINE CPU32 CPU64 OWNNORMTOUPPER
|
||||
|
||||
interface
|
||||
|
||||
|
||||
uses
|
||||
Windows, SysUtils,
|
||||
{$IFNDEF DELPHI5OROLDER}
|
||||
Variants,
|
||||
{$ENDIF}
|
||||
Classes, Contnrs,
|
||||
SynCommons,
|
||||
SynLog,
|
||||
SynDB,
|
||||
DBTables,
|
||||
SynDBDataset;
|
||||
|
||||
|
||||
{ -------------- BDE database engine connection }
|
||||
|
||||
type
|
||||
/// Exception type associated to the direct BDE connection
|
||||
ESQLDBBDE = class(ESQLDBDataset);
|
||||
|
||||
|
||||
/// implement properties shared by BDE connections
|
||||
TSQLDBBDEConnectionProperties = class(TSQLDBDatasetConnectionProperties)
|
||||
protected
|
||||
/// initialize fForeignKeys content with all foreign keys of this DB
|
||||
// - do nothing by now (BDE metadata may be used in the future)
|
||||
procedure GetForeignKeys; override;
|
||||
/// this overridden method will retrieve the kind of DBMS from the main connection
|
||||
function GetDBMS: TSQLDBDefinition; override;
|
||||
public
|
||||
/// initialize the properties to connect to the BDE engine
|
||||
// - aServerName shall contain the BDE Alias name
|
||||
// - aDatabaseName is ignored
|
||||
constructor Create(const aServerName, aDatabaseName, aUserID, aPassWord: RawUTF8); override;
|
||||
/// create a new connection
|
||||
// - caller is responsible of freeing this instance
|
||||
// - this overridden method will create an TSQLDBBDEConnection instance
|
||||
function NewConnection: TSQLDBConnection; override;
|
||||
end;
|
||||
|
||||
|
||||
/// implements a direct connection via the BDE access layer
|
||||
TSQLDBBDEConnection = class(TSQLDBConnectionThreadSafe)
|
||||
protected
|
||||
fDatabase: TDatabase;
|
||||
fSession: TSession;
|
||||
fDBMS: TSQLDBDefinition;
|
||||
fDBMSName: RawUTF8;
|
||||
public
|
||||
/// prepare a connection to a specified BDE database server
|
||||
constructor Create(aProperties: TSQLDBConnectionProperties); override;
|
||||
/// release memory and connection
|
||||
destructor Destroy; override;
|
||||
/// connect to the specified BDE server
|
||||
// - should raise an ESQLDBBDE on error
|
||||
procedure Connect; override;
|
||||
/// stop connection to the specified BDE database server
|
||||
// - should raise an ESQLDBBDE on error
|
||||
procedure Disconnect; override;
|
||||
/// return TRUE if Connect has been already successfully called
|
||||
function IsConnected: boolean; override;
|
||||
/// create a new statement instance
|
||||
function NewStatement: TSQLDBStatement; override;
|
||||
/// begin a Transaction for this connection
|
||||
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;
|
||||
/// access to the associated BDE connection instance
|
||||
property Database: TDatabase read fDatabase;
|
||||
published
|
||||
/// the remote DBMS name, as retrieved at BDE connection creation
|
||||
property DBMSName: RawUTF8 read fDBMSName;
|
||||
/// the remote DBMS type, as retrieved at BDE connection creation
|
||||
property DBMS: TSQLDBDefinition read fDBMS;
|
||||
end;
|
||||
|
||||
/// implements a statement via a BDE connection
|
||||
TSQLDBBDEStatement = class(TSQLDBDatasetStatement)
|
||||
protected
|
||||
/// initialize and set fQuery internal field as expected
|
||||
procedure DatasetCreate; override;
|
||||
/// set fQueryParams internal field as expected
|
||||
function DatasetPrepare(const aSQL: string): boolean; override;
|
||||
/// execute underlying TQuery.ExecSQL
|
||||
procedure DatasetExecSQL; override;
|
||||
public
|
||||
end;
|
||||
|
||||
|
||||
implementation
|
||||
|
||||
|
||||
{ TSQLDBBDEConnectionProperties }
|
||||
|
||||
constructor TSQLDBBDEConnectionProperties.Create(const aServerName, aDatabaseName, aUserID, aPassWord: RawUTF8);
|
||||
begin
|
||||
inherited Create(aServerName,aDatabaseName,aUserID,aPassWord);
|
||||
{$ifndef UNICODE}
|
||||
fForceInt64AsFloat := true; // BDE is old and deprecated :(
|
||||
{$endif}
|
||||
end;
|
||||
|
||||
procedure TSQLDBBDEConnectionProperties.GetForeignKeys;
|
||||
begin
|
||||
{ TODO : get FOREIGN KEYS from BDE metadata ? }
|
||||
end;
|
||||
|
||||
function TSQLDBBDEConnectionProperties.NewConnection: TSQLDBConnection;
|
||||
begin
|
||||
result := TSQLDBBDEConnection.Create(self);
|
||||
end;
|
||||
|
||||
function TSQLDBBDEConnectionProperties.GetDBMS: TSQLDBDefinition;
|
||||
begin
|
||||
if fDBMS=dUnknown then // retrieve DBMS type from alias driver name
|
||||
fDBMS := (MainConnection as TSQLDBBDEConnection).DBMS;
|
||||
result := fDBMS;
|
||||
end;
|
||||
|
||||
|
||||
{ TSQLDBBDEConnection }
|
||||
|
||||
procedure TSQLDBBDEConnection.Commit;
|
||||
begin
|
||||
inherited Commit;
|
||||
try
|
||||
fDatabase.Commit;
|
||||
except
|
||||
inc(fTransactionCount); // the transaction is still active
|
||||
raise;
|
||||
end;
|
||||
end;
|
||||
|
||||
var
|
||||
BDEConnectionCount: integer = 0;
|
||||
|
||||
constructor TSQLDBBDEConnection.Create(aProperties: TSQLDBConnectionProperties);
|
||||
const
|
||||
PCHARS: array[0..2] of PAnsiChar = (
|
||||
'ORACLE','MSSQL','MSACCESS');
|
||||
TYPES: array[-1..high(PCHARS)] of TSQLDBDefinition = (
|
||||
dDefault,dOracle,dMSSQL,dJet);
|
||||
var alias: string;
|
||||
begin
|
||||
inherited Create(aProperties);
|
||||
fDatabase := TDatabase.Create(nil);
|
||||
fSession := TSession.Create(nil);
|
||||
fSession.AutoSessionName := true;
|
||||
fDatabase.SessionName := fSession.SessionName;
|
||||
fDatabase.LoginPrompt := false;
|
||||
inc(BDEConnectionCount);
|
||||
alias := UTF8ToString(fProperties.ServerName);
|
||||
fDatabase.DatabaseName := 'SynDB'+alias+IntToStr(BDEConnectionCount);
|
||||
fDatabase.AliasName := alias;
|
||||
fDatabase.Params.Text := Format('USER NAME=%s'#13#10'PASSWORD=%s',
|
||||
[UTF8ToString(fProperties.UserID),UTF8ToString(fProperties.PassWord)]);
|
||||
fDBMSName := StringToUTF8(fSession.GetAliasDriverName(alias));
|
||||
fDBMS := TYPES[IdemPCharArray(pointer(fDBMSName),PCHARS)];
|
||||
end;
|
||||
|
||||
procedure TSQLDBBDEConnection.Connect;
|
||||
var Log: ISynLog;
|
||||
begin
|
||||
if (fSession=nil) or (fDatabase=nil) then
|
||||
raise ESQLDBBDE.CreateUTF8('%.Connect() on % failed: Database=nil',
|
||||
[self,fProperties.ServerName]);
|
||||
Log := SynDBLog.Enter('Connect to Alias=%',[fDatabase.AliasName],self);
|
||||
try
|
||||
fSession.Open;
|
||||
fDatabase.Open;
|
||||
inherited Connect; // notify any re-connection
|
||||
except
|
||||
on E: Exception do begin
|
||||
Log.Log(sllError,E);
|
||||
Disconnect; // clean up on fail
|
||||
raise;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
destructor TSQLDBBDEConnection.Destroy;
|
||||
begin
|
||||
try
|
||||
Disconnect;
|
||||
except
|
||||
on Exception do
|
||||
end;
|
||||
inherited;
|
||||
FreeAndNil(fDatabase);
|
||||
FreeAndNil(fSession);
|
||||
end;
|
||||
|
||||
procedure TSQLDBBDEConnection.Disconnect;
|
||||
begin
|
||||
try
|
||||
inherited Disconnect; // flush any cached statements
|
||||
finally
|
||||
if fDatabase<>nil then
|
||||
fDatabase.Close;
|
||||
if (fSession<>nil) and fSession.Active then
|
||||
fSession.Close;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TSQLDBBDEConnection.IsConnected: boolean;
|
||||
begin
|
||||
result := Assigned(fDatabase) and fDatabase.Connected;
|
||||
end;
|
||||
|
||||
function TSQLDBBDEConnection.NewStatement: TSQLDBStatement;
|
||||
begin
|
||||
result := TSQLDBBDEStatement.Create(self);
|
||||
end;
|
||||
|
||||
procedure TSQLDBBDEConnection.Rollback;
|
||||
begin
|
||||
inherited Rollback;
|
||||
fDatabase.Rollback;
|
||||
end;
|
||||
|
||||
procedure TSQLDBBDEConnection.StartTransaction;
|
||||
begin
|
||||
inherited StartTransaction;
|
||||
fDatabase.StartTransaction;
|
||||
end;
|
||||
|
||||
|
||||
{ TSQLDBBDEStatement }
|
||||
|
||||
procedure TSQLDBBDEStatement.DatasetCreate;
|
||||
begin
|
||||
fQuery := DBTables.TQuery.Create(nil);
|
||||
with DBTables.TQuery(fQuery) do begin
|
||||
DatabaseName := (fConnection as TSQLDBBDEConnection).Database.DatabaseName;
|
||||
SessionName := TSQLDBBDEConnection(fConnection).Database.Session.SessionName;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TSQLDBBDEStatement.DatasetPrepare(const aSQL: string): boolean;
|
||||
begin
|
||||
(fQuery as DBTables.TQuery).SQL.Text := aSQL;
|
||||
fQueryParams := DBTables.TQuery(fQuery).Params;
|
||||
result := fQueryParams<>nil;
|
||||
end;
|
||||
|
||||
procedure TSQLDBBDEStatement.DatasetExecSQL;
|
||||
begin
|
||||
(fQuery as DBTables.TQuery).ExecSQL;
|
||||
end;
|
||||
|
||||
initialization
|
||||
TSQLDBBDEConnectionProperties.RegisterClassNameForDefinition;
|
||||
end.
|
||||
678
contrib/mORMot/SynDBDataset/SynDBFireDAC.pas
Normal file
678
contrib/mORMot/SynDBDataset/SynDBFireDAC.pas
Normal file
@@ -0,0 +1,678 @@
|
||||
/// FireDAC/AnyDAC-based classes for SynDB units
|
||||
// - this unit is a part of the freeware Synopse framework,
|
||||
// licensed under a MPL/GPL/LGPL tri-license; version 1.18
|
||||
unit SynDBFireDAC;
|
||||
|
||||
{
|
||||
This file is part of Synopse framework.
|
||||
|
||||
Synopse framework. Copyright (C) 2020 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) 2020
|
||||
the Initial Developer. All Rights Reserved.
|
||||
|
||||
Contributor(s):
|
||||
- delphinium (louisyeow)
|
||||
- Oleg Tretyakov
|
||||
|
||||
|
||||
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 *****
|
||||
|
||||
}
|
||||
|
||||
{$I Synopse.inc} // define HASINLINE CPU32 CPU64 OWNNORMTOUPPER
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Windows, SysUtils,
|
||||
{$IFNDEF DELPHI5OROLDER}
|
||||
Variants,
|
||||
{$ENDIF}
|
||||
Classes, Contnrs,
|
||||
SynCommons,
|
||||
SynTable,
|
||||
SynLog,
|
||||
SynDB,
|
||||
SynDBDataset,
|
||||
{$ifdef ISDELPHIXE5}
|
||||
FireDAC.Comp.Client, FireDAC.Stan.Param;
|
||||
{$else}
|
||||
uADCompClient, uADStanParam;
|
||||
{$endif}
|
||||
|
||||
|
||||
|
||||
{ -------------- FireDAC/AnyDAC database access }
|
||||
|
||||
type
|
||||
/// Exception type associated to FireDAC/AnyDAC database access
|
||||
ESQLDBFireDAC = class(ESQLDBDataset);
|
||||
|
||||
|
||||
/// connection properties definition using FireDAC/AnyDAC database access
|
||||
TSQLDBFireDACConnectionProperties = class(TSQLDBDatasetConnectionProperties)
|
||||
protected
|
||||
fFireDACOptions: TStringList;
|
||||
/// initialize fForeignKeys content with all foreign keys of this DB
|
||||
// - do nothing by now (FireDAC metadata may be used in the future)
|
||||
procedure GetForeignKeys; override;
|
||||
public
|
||||
/// initialize the properties to connect via FireDAC/AnyDAC database access
|
||||
// - aServerName shall contain the FireDAC provider DriverID, e.g. 'Ora', and
|
||||
// some optional parameters (e.g. remote server name if needed), after a '?'
|
||||
// and separated by ';' - for instance:
|
||||
// ! Create('Ora','TNSNAME','User','Password');
|
||||
// ! Create('Ora?CharacterSet=cl8mswin1251','TNSNAME','User','Password');
|
||||
// ! Create('MSSQL?Server=127.0.0.1\SQLEXPRESS','Northwind','User','Password');
|
||||
// ! Create('MSSQL?Server=.\SQLEXPRESS;OSAuthent=Yes','','','');
|
||||
// ! Create('MSAcc','c:\data\access.mdb','','');
|
||||
// ! Create('MySQL?Server=127.0.0.1;Port=3306','MyDB','User','Password');
|
||||
// ! Create('SQLite','c:\data\myapp.db3','','');
|
||||
// ! Create('SQLite',SQLITE_MEMORY_DATABASE_NAME,'','');
|
||||
// ! Create('IB','127.0.0.1:C:\ib\ADDEMO_IB2007.IB','User','Password');
|
||||
// ! Create('IB?Server=my_host/3055','C:\ib\ADDEMO_IB2007.IB','User','Password');
|
||||
// ! Create('IB?CreateDatabase=Yes','127.0.0.1:C:\ib\ADDEMO_IB2007.IB','User','Password');
|
||||
// ! Create('DB2?Server=localhost;Port=50000','SAMPLE','db2admin','db2Password');
|
||||
// ! Create('PG?Server=localhost;Port=5432','postgres','postgres','postgresPassword');
|
||||
// ! Create('MySQL?Server=localhost;Port=3306','test','root','');
|
||||
// - aDatabaseName shall contain the database server name
|
||||
// - note that you need to link the FireDAC driver by including the
|
||||
// expected uADPhys*.pas / FireDAC.Phy.*.pas units into a uses clause
|
||||
// of your application, e.g. uADPhysOracle, uADPhysMSSQL, uADPhysMSAcc,
|
||||
// uADPhysMySQL, uADPhysSQLite, uADPhysIB or uADPhysDB2 (depending on the
|
||||
// expected provider) - or FireDAC.Phys.Oracle, FireDAC.Phys.MSAcc,
|
||||
// FireDAC.Phys.MSSQL, FireDAC.Phys.SQLite, FireDAC.Phys.IB, FireDAC.Phys.PG
|
||||
// or FireDAC.Phys.DB2 since Delphi XE5 namespace modifications
|
||||
constructor Create(const aServerName, aDatabaseName, aUserID, aPassWord: RawUTF8); override;
|
||||
/// release internal structures
|
||||
destructor Destroy; override;
|
||||
/// create a new connection
|
||||
// - caller is responsible of freeing this instance
|
||||
// - this overridden method will create an TSQLDBFireDACConnection instance
|
||||
function NewConnection: TSQLDBConnection; override;
|
||||
|
||||
/// retrieve the column/field layout of a specified table
|
||||
// - this overridden method will use FireDAC metadata to retrieve the information
|
||||
procedure GetFields(const aTableName: RawUTF8; out Fields: TSQLDBColumnDefineDynArray); override;
|
||||
/// get all table names
|
||||
// - this overridden method will use FireDAC metadata to retrieve the information
|
||||
procedure GetTableNames(out Tables: TRawUTF8DynArray); override;
|
||||
/// retrieve the advanced indexed information of a specified Table
|
||||
// - this overridden method will use FireDAC metadata to retrieve the information
|
||||
procedure GetIndexes(const aTableName: RawUTF8; out Indexes: TSQLDBIndexDefineDynArray); override;
|
||||
|
||||
/// allow to set the options specific to a FireDAC driver
|
||||
// - by default, ServerName, DatabaseName, UserID and Password are set by
|
||||
// the Create() constructor according to the underlying FireDAC driver
|
||||
// - you can add some additional options here
|
||||
property Parameters: TStringList read fFireDACOptions;
|
||||
end;
|
||||
|
||||
|
||||
/// implements a direct connection via FireDAC/AnyDAC database access
|
||||
TSQLDBFireDACConnection = class(TSQLDBConnectionThreadSafe)
|
||||
protected
|
||||
fDatabase: {$ifdef ISDELPHIXE5}TFDConnection{$else}TADConnection{$endif};
|
||||
public
|
||||
/// prepare a connection for a specified FireDAC/AnyDAC database access
|
||||
constructor Create(aProperties: TSQLDBConnectionProperties); override;
|
||||
/// release memory and connection
|
||||
destructor Destroy; override;
|
||||
/// connect to the specified database server using FireDAC
|
||||
// - should raise an ESQLDBFireDAC on error
|
||||
procedure Connect; override;
|
||||
/// stop connection to the specified database server using FireDAC
|
||||
// - should raise an ESQLDBFireDAC on error
|
||||
procedure Disconnect; override;
|
||||
/// return TRUE if Connect has been already successfully called
|
||||
function IsConnected: boolean; override;
|
||||
/// create a new statement instance
|
||||
function NewStatement: TSQLDBStatement; override;
|
||||
/// begin a Transaction for this connection
|
||||
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;
|
||||
/// access to the associated FireDAC connection instance
|
||||
property Database: {$ifdef ISDELPHIXE5}TFDConnection{$else}TADConnection{$endif} read fDatabase;
|
||||
end;
|
||||
|
||||
/// implements a statement via a FireDAC connection
|
||||
// - this specific version will handle the FireDAC specific parameter classes
|
||||
// - it will also handle Array DML commands, if possible
|
||||
TSQLDBFireDACStatement = class(TSQLDBDatasetStatementAbstract)
|
||||
protected
|
||||
fQueryParams: {$ifdef ISDELPHIXE5}TFDParams{$else}TADParams{$endif};
|
||||
fPreparedUseArrayDML: boolean;
|
||||
/// initialize and set fQuery: TUniQuery internal field as expected
|
||||
procedure DatasetCreate; override;
|
||||
/// set fQueryParams internal field as expected
|
||||
function DatasetPrepare(const aSQL: string): boolean; override;
|
||||
/// execute underlying TUniQuery.ExecSQL
|
||||
procedure DatasetExecSQL; override;
|
||||
/// bind SQLDBParam to TQuery-like param using fQueryParams: DB.TParams
|
||||
procedure DataSetBindSQLParam(const aArrayIndex, aParamIndex: integer;
|
||||
const aParam: TSQLDBParam); override;
|
||||
/// set the returned parameter after a stored proc execution
|
||||
procedure DataSetOutSQLParam(const aParamIndex: integer;
|
||||
var aParam: TSQLDBParam); override;
|
||||
public
|
||||
/// 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 ESQLDBFireDAC on any error
|
||||
procedure Prepare(const aSQL: RawUTF8; ExpectResults: boolean = false); overload; override;
|
||||
end;
|
||||
|
||||
|
||||
const
|
||||
/// FireDAC DriverID values corresponding to SynDB recognized SQL engines
|
||||
{$ifdef ISDELPHIXE5}
|
||||
FIREDAC_PROVIDER: array[dOracle..high(TSQLDBDefinition)] of RawUTF8 = (
|
||||
'Ora','MSSQL','MSAcc','MySQL','SQLite','FB','','PG','DB2','Infx');
|
||||
|
||||
{$else}
|
||||
FIREDAC_PROVIDER: array[dOracle..high(TSQLDBDefinition)] of RawUTF8 = (
|
||||
'Ora','MSSQL','MSAcc','MySQL','SQLite','IB','','PG','DB2','Infx');
|
||||
{$endif}
|
||||
implementation
|
||||
|
||||
uses
|
||||
{$ifdef ISDELPHIXE5}
|
||||
FireDAC.Phys.Intf, FireDAC.Stan.Def, FireDAC.DApt, FireDAC.Stan.Async;
|
||||
|
||||
type
|
||||
TADConnection = TFDConnection;
|
||||
TADQuery = TFDQuery;
|
||||
TADMetaInfoQuery = TFDMetaInfoQuery;
|
||||
TADParam = TFDParam;
|
||||
TADParams = TFDParams;
|
||||
TADPhysMetaInfoKind = TFDPhysMetaInfoKind;
|
||||
|
||||
{$else}
|
||||
uADPhysIntf, uADStanDef, uADDAptManager, uADStanAsync;
|
||||
{$endif}
|
||||
|
||||
|
||||
{ TSQLDBFireDACConnectionProperties }
|
||||
|
||||
constructor TSQLDBFireDACConnectionProperties.Create(const aServerName, aDatabaseName, aUserID, aPassWord: RawUTF8);
|
||||
var p: TSQLDBDefinition;
|
||||
server,options,namevalue: RawUTF8;
|
||||
opt: PUTF8Char;
|
||||
begin
|
||||
Split(aServerName,'?',server,options);
|
||||
if server<>'' then
|
||||
for p := Low(FIREDAC_PROVIDER) to high(FIREDAC_PROVIDER) do
|
||||
if SameTextU(FIREDAC_PROVIDER[p],server) then begin
|
||||
fDBMS := p;
|
||||
break;
|
||||
end;
|
||||
inherited Create(server,aDatabaseName,aUserID,aPassWord);
|
||||
fOnBatchInsert := nil; // MultipleValuesInsert is slower than FireDAC ArrayDML
|
||||
fFireDACOptions := TStringList.Create;
|
||||
if ((fDBMS<low(FIREDAC_PROVIDER)) or (fDBMS>high(FIREDAC_PROVIDER))) and
|
||||
(fDBMS<>dNexusDB) then
|
||||
if SameTextU(server,'ASA') then
|
||||
fDBMS := dMSSQL else begin
|
||||
for p := Low(FIREDAC_PROVIDER) to high(FIREDAC_PROVIDER) do
|
||||
namevalue := ' '+namevalue+FIREDAC_PROVIDER[p];
|
||||
raise ESQLDBFireDAC.CreateUTF8('%.Create: unknown provider - available:%',
|
||||
[self,namevalue]);
|
||||
end;
|
||||
if server='' then
|
||||
server := FIREDAC_PROVIDER[fDBMS];
|
||||
fFireDACOptions.Text := UTF8ToString(FormatUTF8(
|
||||
'DriverID=%'#13#10'User_Name=%'#13#10'Password=%'#13#10'Database=%',
|
||||
[server,fUserId,fPassWord,fDatabaseName]));
|
||||
opt := pointer(options);
|
||||
while opt<>nil do begin
|
||||
GetNextItem(opt,';',namevalue);
|
||||
if namevalue<>'' then
|
||||
fFireDACOptions.Add(UTF8ToString(namevalue));
|
||||
end;
|
||||
case fDBMS of
|
||||
dSQLite: begin
|
||||
if fFireDACOptions.Values['CharacterSet']='' then // force UTF-8 for SynDB
|
||||
fFireDACOptions.Values['CharacterSet'] := 'UTF8';
|
||||
{$ifdef UNICODE} // CreateUTF16 is the default value for Delphi 2009+
|
||||
if fFireDACOptions.Values['OpenMode']='' then // force UTF-8 for SynDB
|
||||
fFireDACOptions.Values['OpenMode'] := 'CreateUTF8';
|
||||
{$else}
|
||||
ForceUseWideString := true; // as expected by FireDAC when UTF-8 is enabled
|
||||
{$endif}
|
||||
fSQLCreateField[ftInt64] := ' BIGINT'; // SQLite3 INTEGER = 32bit for FireDAC
|
||||
end;
|
||||
dFirebird, dMySQL, dPostgreSQL, dDB2: begin
|
||||
if fFireDACOptions.Values['CharacterSet']='' then // force UTF-8 for SynDB
|
||||
fFireDACOptions.Values['CharacterSet'] := 'UTF8';
|
||||
{$ifndef UNICODE}
|
||||
ForceUseWideString := true; // as expected by FireDAC when UTF-8 is enabled
|
||||
{$endif}
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
destructor TSQLDBFireDACConnectionProperties.Destroy;
|
||||
begin
|
||||
fFireDACOptions.Free;
|
||||
inherited;
|
||||
end;
|
||||
|
||||
procedure TSQLDBFireDACConnectionProperties.GetTableNames(
|
||||
out Tables: TRawUTF8DynArray);
|
||||
var List: TStringList;
|
||||
begin
|
||||
List := TStringList.Create;
|
||||
try
|
||||
(MainConnection as TSQLDBFireDACConnection).fDatabase.GetTableNames(
|
||||
'','','',List,[osMy],[tkTable]);
|
||||
StringListToRawUTF8DynArray(List,Tables);
|
||||
exit;
|
||||
finally
|
||||
List.Free;
|
||||
end;
|
||||
inherited;
|
||||
end;
|
||||
|
||||
procedure TSQLDBFireDACConnectionProperties.GetFields(
|
||||
const aTableName: RawUTF8; out Fields: TSQLDBColumnDefineDynArray);
|
||||
var meta: TADMetaInfoQuery;
|
||||
n: integer;
|
||||
F: TSQLDBColumnDefine;
|
||||
FA: TDynArray;
|
||||
begin
|
||||
meta := TADMetaInfoQuery.Create(nil);
|
||||
try
|
||||
meta.Connection := (MainConnection as TSQLDBFireDACConnection).fDatabase;
|
||||
FA.Init(TypeInfo(TSQLDBColumnDefineDynArray),Fields,@n);
|
||||
FA.Compare := SortDynArrayAnsiStringI; // FA.Find() case insensitive
|
||||
FillChar(F,sizeof(F),0);
|
||||
meta.MetaInfoKind := mkTableFields;
|
||||
meta.ObjectName := UTF8ToString(UpperCase(aTableName));
|
||||
meta.Open;
|
||||
while not meta.Eof do begin
|
||||
F.ColumnName := StringToUTF8(meta.FieldByName('COLUMN_NAME').AsString);
|
||||
F.ColumnTypeNative := StringToUTF8(meta.FieldByName('COLUMN_TYPENAME').AsString);
|
||||
F.ColumnLength := meta.FieldByName('COLUMN_LENGTH').AsInteger;
|
||||
F.ColumnScale := meta.FieldByName('COLUMN_SCALE').AsInteger;
|
||||
F.ColumnPrecision := meta.FieldByName('COLUMN_PRECISION').AsInteger;
|
||||
{ TODO : retrieve ColumnType from high-level FireDAC type information }
|
||||
F.ColumnType := ColumnTypeNativeToDB(F.ColumnTypeNative,F.ColumnScale);
|
||||
FA.Add(F);
|
||||
meta.Next;
|
||||
end;
|
||||
Setlength(Fields,n);
|
||||
GetIndexesAndSetFieldsColumnIndexed(aTableName,Fields);
|
||||
finally
|
||||
meta.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TSQLDBFireDACConnectionProperties.GetIndexes(
|
||||
const aTableName: RawUTF8; out Indexes: TSQLDBIndexDefineDynArray);
|
||||
var kind: boolean;
|
||||
meta, indexs: TADMetaInfoQuery;
|
||||
TableName: string;
|
||||
ColName: RawUTF8;
|
||||
F: TSQLDBIndexDefine;
|
||||
FA: TDynArray;
|
||||
n: integer;
|
||||
const
|
||||
MASTER: array[boolean] of TADPhysMetaInfoKind = (mkPrimaryKey,mkIndexes);
|
||||
CHILD: array[boolean] of TADPhysMetaInfoKind = (mkPrimaryKeyFields,mkIndexFields);
|
||||
begin
|
||||
TableName := UTF8ToString(UpperCase(aTableName));
|
||||
FA.Init(TypeInfo(TSQLDBIndexDefineDynArray),Indexes,@n);
|
||||
fillchar(F,sizeof(F),0);
|
||||
meta := TADMetaInfoQuery.Create(nil);
|
||||
indexs := TADMetaInfoQuery.Create(nil);
|
||||
try
|
||||
meta.Connection := (MainConnection as TSQLDBFireDACConnection).fDatabase;
|
||||
indexs.Connection := meta.Connection;
|
||||
for kind := true to true do begin // primary keys may not be indexed
|
||||
meta.MetaInfoKind := MASTER[kind];
|
||||
meta.ObjectName := TableName;
|
||||
meta.Open;
|
||||
while not meta.Eof do begin
|
||||
indexs.MetaInfoKind := CHILD[kind];
|
||||
indexs.BaseObjectName := TableName;
|
||||
indexs.ObjectName := meta.FieldByName('INDEX_NAME').AsString;
|
||||
indexs.Open;
|
||||
F.IndexName := StringToUTF8(indexs.ObjectName);
|
||||
F.IsPrimaryKey := not kind;
|
||||
F.KeyColumns := '';
|
||||
while not indexs.Eof do begin
|
||||
ColName := StringToUTF8(indexs.FieldByName('COLUMN_NAME').AsString);
|
||||
if F.KeyColumns='' then
|
||||
F.KeyColumns := ColName else
|
||||
F.KeyColumns := F.KeyColumns+','+ColName;
|
||||
indexs.Next;
|
||||
end;
|
||||
FA.Add(F);
|
||||
indexs.Close;
|
||||
meta.Next;
|
||||
end;
|
||||
meta.Close;
|
||||
end;
|
||||
SetLength(Indexes,n);
|
||||
finally
|
||||
indexs.Free;
|
||||
meta.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TSQLDBFireDACConnectionProperties.GetForeignKeys;
|
||||
begin
|
||||
{ TODO : get FOREIGN KEYS from FireDAC metadata using mkForeignKeys }
|
||||
end;
|
||||
|
||||
function TSQLDBFireDACConnectionProperties.NewConnection: TSQLDBConnection;
|
||||
begin
|
||||
result := TSQLDBFireDACConnection.Create(self);
|
||||
end;
|
||||
|
||||
|
||||
{ TSQLDBFireDACConnection }
|
||||
|
||||
procedure TSQLDBFireDACConnection.Commit;
|
||||
begin
|
||||
inherited Commit;
|
||||
try
|
||||
fDatabase.Commit;
|
||||
except
|
||||
inc(fTransactionCount); // the transaction is still active
|
||||
raise;
|
||||
end;
|
||||
end;
|
||||
|
||||
constructor TSQLDBFireDACConnection.Create(aProperties: TSQLDBConnectionProperties);
|
||||
begin
|
||||
inherited Create(aProperties);
|
||||
fDatabase := TADConnection.Create(nil);
|
||||
fDatabase.ResourceOptions.SilentMode := True; // no need for wait cursor
|
||||
fDatabase.Params.Text :=
|
||||
(fProperties as TSQLDBFireDACConnectionProperties).fFireDACOptions.Text;
|
||||
end;
|
||||
|
||||
procedure TSQLDBFireDACConnection.Connect;
|
||||
var Log: ISynLog;
|
||||
begin
|
||||
if fDatabase=nil then
|
||||
raise ESQLDBFireDAC.CreateUTF8('%.Connect(%): Database=nil',
|
||||
[self,fProperties.ServerName]);
|
||||
Log := SynDBLog.Enter('Connect to DriverID=% Database=%',
|
||||
[FIREDAC_PROVIDER[fProperties.DBMS],fProperties.DatabaseName],self);
|
||||
try
|
||||
fDatabase.Open;
|
||||
inherited Connect; // notify any re-connection
|
||||
Log.Log(sllDB,'Connected to % (%)',
|
||||
[fDatabase.DriverName,fProperties.DatabaseName]);
|
||||
except
|
||||
on E: Exception do begin
|
||||
Log.Log(sllError,E);
|
||||
Disconnect; // clean up on fail
|
||||
raise;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TSQLDBFireDACConnection.Disconnect;
|
||||
begin
|
||||
try
|
||||
inherited Disconnect; // flush any cached statement
|
||||
finally
|
||||
if fDatabase<>nil then
|
||||
fDatabase.Close;
|
||||
end;
|
||||
end;
|
||||
|
||||
destructor TSQLDBFireDACConnection.Destroy;
|
||||
begin
|
||||
try
|
||||
Disconnect;
|
||||
except
|
||||
on Exception do
|
||||
end;
|
||||
inherited;
|
||||
FreeAndNil(fDatabase);
|
||||
end;
|
||||
|
||||
function TSQLDBFireDACConnection.IsConnected: boolean;
|
||||
begin
|
||||
result := Assigned(fDatabase) and fDatabase.Connected;
|
||||
end;
|
||||
|
||||
function TSQLDBFireDACConnection.NewStatement: TSQLDBStatement;
|
||||
begin
|
||||
result := TSQLDBFireDACStatement.Create(self);
|
||||
end;
|
||||
|
||||
procedure TSQLDBFireDACConnection.Rollback;
|
||||
begin
|
||||
inherited Rollback;
|
||||
fDatabase.Rollback;
|
||||
end;
|
||||
|
||||
procedure TSQLDBFireDACConnection.StartTransaction;
|
||||
begin
|
||||
inherited StartTransaction;
|
||||
fDatabase.StartTransaction;
|
||||
end;
|
||||
|
||||
|
||||
{ TSQLDBFireDACStatement }
|
||||
|
||||
procedure TSQLDBFireDACStatement.DatasetCreate;
|
||||
begin
|
||||
fQuery := TADQuery.Create(nil);
|
||||
TADQuery(fQuery).Connection := (fConnection as TSQLDBFireDACConnection).Database;
|
||||
fDatasetSupportBatchBinding := true;
|
||||
end;
|
||||
|
||||
function TSQLDBFireDACStatement.DatasetPrepare(const aSQL: string): boolean;
|
||||
begin
|
||||
(fQuery as TADQuery).SQL.Text := aSQL;
|
||||
fQueryParams := TADQuery(fQuery).Params;
|
||||
result := fQueryParams<>nil;
|
||||
end;
|
||||
|
||||
procedure TSQLDBFireDACStatement.Prepare(const aSQL: RawUTF8;
|
||||
ExpectResults: boolean);
|
||||
begin
|
||||
inherited;
|
||||
if fPreparedParamsCount<>fQueryParams.Count then
|
||||
raise ESQLDBFireDAC.CreateUTF8(
|
||||
'%.Prepare() expected % parameters in request, found % - [%]',
|
||||
[self,fPreparedParamsCount,fQueryParams.Count,aSQL]);
|
||||
end;
|
||||
|
||||
procedure TSQLDBFireDACStatement.DatasetExecSQL;
|
||||
begin
|
||||
if fPreparedUseArrayDML then
|
||||
(fQuery as TADQuery).Execute(fParamsArrayCount) else
|
||||
(fQuery as TADQuery).Execute;
|
||||
end;
|
||||
|
||||
procedure TSQLDBFireDACStatement.DataSetBindSQLParam(const aArrayIndex,
|
||||
aParamIndex: integer; const aParam: TSQLDBParam);
|
||||
var P: TADParam;
|
||||
i: integer;
|
||||
tmp: RawUTF8;
|
||||
StoreVoidStringAsNull: boolean;
|
||||
begin
|
||||
if fDatasetSupportBatchBinding then
|
||||
fPreparedUseArrayDML := (aArrayIndex<0) and (fParamsArrayCount>0) else
|
||||
fPreparedUseArrayDML := false;
|
||||
if fPreparedUseArrayDML and (fQueryParams.ArraySize<>fParamsArrayCount) then
|
||||
fQueryParams.ArraySize := fParamsArrayCount;
|
||||
with aParam do begin
|
||||
P := fQueryParams[aParamIndex];
|
||||
P.ParamType := SQLParamTypeToDBParamType(VInOut);
|
||||
if VinOut <> paramInOut then
|
||||
case VType of
|
||||
SynTable.ftNull:
|
||||
if fPreparedUseArrayDML then
|
||||
for i := 0 to fParamsArrayCount-1 do
|
||||
P.Clear(i) else
|
||||
P.Clear;
|
||||
SynTable.ftInt64: begin
|
||||
if fPreparedUseArrayDML then
|
||||
for i := 0 to fParamsArrayCount-1 do
|
||||
if VArray[i]='null' then
|
||||
P.Clear(i) else
|
||||
P.AsLargeInts[i] := GetInt64(pointer(VArray[i])) else
|
||||
if aArrayIndex>=0 then
|
||||
if VArray[aArrayIndex]='null' then
|
||||
P.Clear else
|
||||
P.AsLargeInt := GetInt64(pointer(VArray[aArrayIndex])) else
|
||||
P.AsLargeInt := VInt64;
|
||||
end;
|
||||
SynTable.ftDouble:
|
||||
if fPreparedUseArrayDML then
|
||||
for i := 0 to fParamsArrayCount-1 do
|
||||
if VArray[i]='null' then
|
||||
P.Clear(i) else
|
||||
P.AsFloats[i] := GetExtended(pointer(VArray[i])) else
|
||||
if aArrayIndex>=0 then
|
||||
if VArray[aArrayIndex]='null' then
|
||||
P.Clear else
|
||||
P.AsFloat := GetExtended(pointer(VArray[aArrayIndex])) else
|
||||
P.AsFloat := PDouble(@VInt64)^;
|
||||
SynTable.ftCurrency:
|
||||
if fPreparedUseArrayDML then
|
||||
for i := 0 to fParamsArrayCount-1 do
|
||||
if VArray[i]='null' then
|
||||
P.Clear(i) else
|
||||
P.AsCurrencys[i] := StrToCurrency(pointer(VArray[i])) else
|
||||
if aArrayIndex>=0 then
|
||||
if VArray[aArrayIndex]='null' then
|
||||
P.Clear else
|
||||
P.AsCurrency := StrToCurrency(pointer(VArray[aArrayIndex])) else
|
||||
P.AsCurrency := PCurrency(@VInt64)^;
|
||||
SynTable.ftDate:
|
||||
if fPreparedUseArrayDML then
|
||||
for i := 0 to fParamsArrayCount-1 do
|
||||
if VArray[i]='null' then
|
||||
P.Clear(i) else begin
|
||||
UnQuoteSQLStringVar(pointer(VArray[i]),tmp);
|
||||
P.AsDateTimes[i] := Iso8601ToDateTime(tmp);
|
||||
end else
|
||||
if aArrayIndex>=0 then
|
||||
if VArray[aArrayIndex]='null' then
|
||||
P.Clear else begin
|
||||
UnQuoteSQLStringVar(pointer(VArray[aArrayIndex]),tmp);
|
||||
P.AsDateTime := Iso8601ToDateTime(tmp);
|
||||
end else
|
||||
P.AsDateTime := PDateTime(@VInt64)^;
|
||||
SynTable.ftUTF8:
|
||||
if fPreparedUseArrayDML then begin
|
||||
StoreVoidStringAsNull := fConnection.Properties.StoreVoidStringAsNull;
|
||||
for i := 0 to fParamsArrayCount-1 do
|
||||
if (VArray[i]='null') or
|
||||
(StoreVoidStringAsNull and (VArray[i]=#39#39)) then
|
||||
P.Clear(i) else begin
|
||||
UnQuoteSQLStringVar(pointer(VArray[i]),tmp);
|
||||
{$ifdef UNICODE} // for FireDAC: TADWideString=UnicodeString
|
||||
P.AsWideStrings[i] := UTF8ToString(tmp);
|
||||
{$else}
|
||||
if fForceUseWideString then
|
||||
P.AsWideStrings[i] := UTF8ToWideString(tmp) else
|
||||
P.AsStrings[i] := UTF8ToString(tmp);
|
||||
{$endif}
|
||||
end
|
||||
end else
|
||||
if aArrayIndex>=0 then
|
||||
if (VArray[aArrayIndex]='null') or
|
||||
(fConnection.Properties.StoreVoidStringAsNull and
|
||||
(VArray[aArrayIndex]=#39#39)) then
|
||||
P.Clear else begin
|
||||
UnQuoteSQLStringVar(pointer(VArray[aArrayIndex]),tmp);
|
||||
{$ifdef UNICODE}
|
||||
P.AsWideString := UTF8ToString(tmp); // TADWideString=string
|
||||
{$else}
|
||||
if fForceUseWideString then
|
||||
P.AsWideString := UTF8ToWideString(tmp) else
|
||||
P.AsString := UTF8ToString(tmp);
|
||||
{$endif}
|
||||
end else
|
||||
if (VData='') and fConnection.Properties.StoreVoidStringAsNull then
|
||||
P.Clear else
|
||||
{$ifdef UNICODE}
|
||||
P.AsWideString := UTF8ToString(VData); // TADWideString=string
|
||||
{$else}
|
||||
if (not fForceUseWideString) {or IsAnsiCompatible(VData)} then
|
||||
P.AsString := UTF8ToString(VData) else
|
||||
P.AsWideString := UTF8ToWideString(VData);
|
||||
{$endif}
|
||||
SynTable.ftBlob:
|
||||
if fPreparedUseArrayDML then
|
||||
for i := 0 to fParamsArrayCount-1 do
|
||||
if VArray[i]='null' then
|
||||
P.Clear(i) else
|
||||
P.AsBlobs[i] := VArray[i] else
|
||||
if aArrayIndex>=0 then
|
||||
if VArray[aArrayIndex]='null' then
|
||||
P.Clear else
|
||||
P.AsBlob := VArray[aArrayIndex] else
|
||||
P.AsBlob := VData;
|
||||
else
|
||||
raise ESQLDBFireDAC.CreateUTF8(
|
||||
'%.DataSetBindSQLParam: invalid type % on bound parameter #%',
|
||||
[Self,ord(VType),aParamIndex+1]);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TSQLDBFireDACStatement.DataSetOutSQLParam(const aParamIndex: integer;
|
||||
var aParam: TSQLDBParam);
|
||||
var Par: TADParam;
|
||||
begin
|
||||
Par := fQueryParams[aParamIndex];
|
||||
case aParam.VType of
|
||||
SynTable.ftInt64: aParam.VInt64 := Par.AsLargeInt;
|
||||
SynTable.ftDouble: PDouble(@aParam.VInt64)^ := Par.AsFloat;
|
||||
SynTable.ftCurrency: PCurrency(@aParam.VInt64)^ := Par.AsCurrency;
|
||||
SynTable.ftDate: PDateTime(@aParam.VInt64)^ := Par.AsDateTime;
|
||||
SynTable.ftUTF8: aParam.VData := StringToUTF8(Par.AsString);
|
||||
SynTable.ftBlob: aParam.VData := Par.AsBlob;
|
||||
end;
|
||||
end;
|
||||
|
||||
initialization
|
||||
TSQLDBFireDACConnectionProperties.RegisterClassNameForDefinition;
|
||||
end.
|
||||
590
contrib/mORMot/SynDBDataset/SynDBNexusDB.pas
Normal file
590
contrib/mORMot/SynDBDataset/SynDBNexusDB.pas
Normal file
@@ -0,0 +1,590 @@
|
||||
/// NexusDB 3.x direct access classes (embedded engine only)
|
||||
// - this unit is a part of the freeware Synopse framework,
|
||||
// licensed under a MPL/GPL/LGPL tri-license; version 1.18
|
||||
unit SynDBNexusDB;
|
||||
|
||||
{
|
||||
This file is part of Synopse framework.
|
||||
|
||||
Synopse framework. Copyright (C) 2020 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) 2020
|
||||
the Initial Developer. All Rights Reserved.
|
||||
|
||||
Contributor(s):
|
||||
- Bas Schouten (initial uSGSynDBNexusDB.pas port)
|
||||
|
||||
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 *****
|
||||
|
||||
}
|
||||
|
||||
{$I Synopse.inc} // define HASINLINE CPU32 CPU64 OWNNORMTOUPPER
|
||||
|
||||
interface
|
||||
|
||||
|
||||
{.$define SYNDB_FULLNEXUSDB}
|
||||
// by default, only the NexusDB Free Embedded version is interfaced
|
||||
// - you can define this conditional in project options to use all units
|
||||
|
||||
uses
|
||||
Windows, SysUtils,
|
||||
{$IFNDEF DELPHI5OROLDER}
|
||||
Variants,
|
||||
{$ENDIF}
|
||||
Classes, Contnrs,
|
||||
{$ifdef ISDELPHIXE2}Data.DB,{$else}DB,{$endif}
|
||||
SynCommons,
|
||||
SynTable,
|
||||
SynLog,
|
||||
SynDB,
|
||||
SynDBDataset,
|
||||
nxDB,
|
||||
nxsdServerEngine,
|
||||
nxsrServerEngine,
|
||||
nxsqlEngine,
|
||||
nxlgEventLog,
|
||||
nxllTransport,
|
||||
{$ifdef SYNDB_FULLNEXUSDB}
|
||||
nxchCommandHandler,
|
||||
nxsiServerInfoPluginServer,
|
||||
nxtcCOMTransport,
|
||||
nxtmSharedMemoryTransport,
|
||||
nxtnNamedPipeTransport,
|
||||
nxtsBlowfishRC4SecuredTransport,
|
||||
nxtwWinsockTransport,
|
||||
{$endif}
|
||||
nxseAutoComponent;
|
||||
|
||||
|
||||
{ -------------- NexusDB database engine native connection }
|
||||
|
||||
type
|
||||
/// Exception type associated to the direct NexusDB connection
|
||||
ESQLDBNexusDB = class(ESQLDBDataset);
|
||||
|
||||
// available communication protocols used by NexusDB between client and server
|
||||
// - nxpFOLDER: default protocol, accessing NexusDB database in a Windows Folder
|
||||
// - nxpTCPIP: TCP/IP transport, indicated by nxtcp://
|
||||
// - nxpPIPE: Windows Named Pipe transport, indicated by nxpipe://
|
||||
// - nxpMEM: direct memory transport, indicated by nxmem://
|
||||
// - nxpBFISH: BlowFish transport, indicated by nxbfisch://
|
||||
TNXProtocol = (
|
||||
nxpUnknown,
|
||||
nxpFOLDER,
|
||||
nxpTCPIP,
|
||||
nxpPIPE,
|
||||
nxpCOM,
|
||||
nxpMEM,
|
||||
nxpBFISH);
|
||||
|
||||
// implement properties shared by native NexusDB connections
|
||||
// - note that only the embedded engine is implemented by now - feedback needed!
|
||||
TSQLDBNexusDBConnectionProperties = class(TSQLDBDatasetConnectionProperties)
|
||||
private
|
||||
fProtocol: TNXProtocol;
|
||||
protected
|
||||
/// initialize fForeignKeys content with all foreign keys of this DB
|
||||
// - used by GetForeignKey method
|
||||
procedure GetForeignKeys; override;
|
||||
public
|
||||
/// initialize the properties to connect to the NexusDB engine
|
||||
// - this overridden method will initialize the protocol to be used as stated
|
||||
// by aServerName i.e. nxpTCIP://11.23.34.43
|
||||
// - Default protocol is nxpFolder
|
||||
// - if protocol is nxpFolder then aDatabaseName will contain the path to the
|
||||
// folder to be used
|
||||
// - if protocol is other then nxpFolder than aServerName will contain the server
|
||||
// to connect to and aDatabaseName will contains the alias of the database
|
||||
// - Possible aServerName formats:
|
||||
// $ <protocol>://<servername>/<alias> (aDatabaseName will be overwritten by this alias)
|
||||
// $ <protocol>://servername (aDatabaseName will contain alias)
|
||||
// $ '' (aDatabaseName contains path to nxpFOLDER database)
|
||||
constructor Create(const aServerName, aDatabaseName, aUserID, aPassWord: RawUTF8); override;
|
||||
/// convert a textual column data type, as retrieved e.g. from SQLGetField,
|
||||
// into our internal primitive types
|
||||
function ColumnTypeNativeToDB(const aNativeType: RawUTF8; aScale: integer): TSQLDBFieldType; override;
|
||||
/// Determine if database exists
|
||||
// - just test if the corresponding folder exists
|
||||
function DatabaseExists: boolean; virtual;
|
||||
/// create the database folder (if not existing)
|
||||
function CreateDatabase: boolean; virtual;
|
||||
/// delete the database folder
|
||||
// - including all its files - so to be used carefully!
|
||||
function DeleteDatabase: boolean; virtual;
|
||||
/// create a new connection
|
||||
// - caller is responsible of freeing this instance
|
||||
// - this overridden method will create an TSQLDBNexusDBConnection instance
|
||||
function NewConnection: TSQLDBConnection; override;
|
||||
published
|
||||
/// the transport protocol used to connect to the NexusDB engine
|
||||
property Protocol: TNXProtocol read fProtocol;
|
||||
end;
|
||||
|
||||
|
||||
// implements a direct connection to the native NexusDB database
|
||||
TSQLDBNexusDBConnection = class(TSQLDBConnectionThreadSafe)
|
||||
protected
|
||||
fDatabase: TnxDatabase;
|
||||
fSession: TnxSession;
|
||||
fServerEngine: TnxBaseServerEngine;
|
||||
procedure SetServerEngine(aServerEngine: TnxBaseServerEngine);
|
||||
public
|
||||
/// prepare a connection to a specified NexusDB database server
|
||||
constructor Create(aProperties: TSQLDBConnectionProperties); override;
|
||||
/// release memory and connection
|
||||
destructor Destroy; override;
|
||||
/// connect to the specified NexusDB server
|
||||
// - should raise an ESQLDBNexusDB on error
|
||||
procedure Connect; override;
|
||||
/// stop connection to the specified NexusDB database server
|
||||
// - should raise an ESQLDBNexusDB on error
|
||||
procedure Disconnect; override;
|
||||
/// return TRUE if Connect has been already successfully called
|
||||
function IsConnected: boolean; override;
|
||||
/// create a new statement instance
|
||||
function NewStatement: TSQLDBStatement; override;
|
||||
/// begin a Transaction for this connection
|
||||
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;
|
||||
/// access to the associated NexusDB connection instance
|
||||
property Database: TnxDatabase read fDatabase;
|
||||
/// associated NexusDB server engine
|
||||
property ServerEngine: TnxBaseServerEngine read fServerEngine write SetServerEngine;
|
||||
end;
|
||||
|
||||
// implements a statement via the native NexusDB connection
|
||||
TSQLDBNexusDBStatement = class(TSQLDBDatasetStatement)
|
||||
protected
|
||||
/// initialize and set fQuery internal field as expected
|
||||
procedure DatasetCreate; override;
|
||||
/// set fQueryParams internal field as expected
|
||||
function DatasetPrepare(const aSQL: string): boolean; override;
|
||||
/// execute underlying TQuery.ExecSQL
|
||||
procedure DatasetExecSQL; override;
|
||||
public
|
||||
end;
|
||||
|
||||
|
||||
const
|
||||
/// set aServerName to this value to create an in-memory table
|
||||
// - do not use this constant, since it was not working as expected yet
|
||||
NEXUSDB_INMEMORY = '#INMEM';
|
||||
|
||||
|
||||
// determine NexusDB transport protocol (TNXProtocol) to be used, based on
|
||||
// protocol indicator in connection string
|
||||
// - if no protocol specifier is included in the connectionstring then nxpFOLDER
|
||||
// is assumed.
|
||||
// - aServerName will contain the URL to the Server if the protocol
|
||||
// is not nxpFOLDER
|
||||
function GetNXProtocol(const aConnectionString: RawUTF8; out aServerName: RawUTF8;
|
||||
out aAlias: RawUTF8): TNXProtocol;
|
||||
|
||||
/// return the internal NexusDB embedded engine
|
||||
// - initialize it, if was not already the case
|
||||
function NexusEmbeddedEngine: TnxServerEngine;
|
||||
|
||||
/// release any internal NexusDB embedded engine
|
||||
// - returns nil on success, or PtrInt(-1) if was not initialized
|
||||
function DropNexusEmbeddedEngine: TnxServerEngine;
|
||||
|
||||
|
||||
implementation
|
||||
|
||||
uses
|
||||
|
||||
{$ifdef SYNDB_FULLNEXUSDB}
|
||||
nxreRemoteServerEngine,
|
||||
uMiscellaneous,
|
||||
{$endif}
|
||||
nxsdConst,
|
||||
nxsdTypes;
|
||||
|
||||
|
||||
{ TSQLDBNexusDBConnectionProperties }
|
||||
|
||||
function TSQLDBNexusDBConnectionProperties.ColumnTypeNativeToDB(const aNativeType: RawUTF8;
|
||||
aScale: integer): TSQLDBFieldType;
|
||||
const CONV_TABLE: array[TnxFieldType] of TSQLDBFieldType = (
|
||||
SynTable.ftInt64, SynTable.ftUTF8, SynTable.ftUTF8, SynTable.ftInt64,
|
||||
SynTable.ftInt64, SynTable.ftInt64, SynTable.ftInt64, SynTable.ftInt64,
|
||||
SynTable.ftInt64, SynTable.ftInt64, SynTable.ftInt64, SynTable.ftDouble,
|
||||
SynTable.ftDouble, SynTable.ftDouble, SynTable.ftCurrency, SynTable.ftDate,
|
||||
SynTable.ftDate, SynTable.ftDate, SynTable.ftInt64, SynTable.ftBlob,
|
||||
SynTable.ftUTF8, SynTable.ftBlob, SynTable.ftBlob, SynTable.ftUTF8,
|
||||
SynTable.ftUTF8, SynTable.ftUTF8, SynTable.ftInt64, SynTable.ftUTF8,
|
||||
SynTable.ftCurrency, SynTable.ftUTF8, SynTable.ftDouble );
|
||||
begin
|
||||
result := CONV_TABLE[FieldDataTypesMapSQL(UTF8ToString(aNativeType))];
|
||||
end;
|
||||
|
||||
constructor TSQLDBNexusDBConnectionProperties.Create(const aServerName, aDatabaseName, aUserID, aPassWord: RawUTF8);
|
||||
var lServerURL, lAlias: RawUTF8;
|
||||
begin
|
||||
fDBMS := dNexusDB;
|
||||
inherited Create(aServerName,aDatabaseName,aUserID,aPassWord);
|
||||
fProtocol := GetNXProtocol(aServerName,lServerURL,lAlias);
|
||||
if fProtocol=nxpFOLDER then
|
||||
fServerName := '' else
|
||||
if fProtocol>nxpFOLDER then
|
||||
fServerName := lServerURL;
|
||||
if fProtocol>nxpUnknown then
|
||||
fDatabaseName := lAlias else
|
||||
fDatabaseName := '';
|
||||
end;
|
||||
|
||||
procedure TSQLDBNexusDBConnectionProperties.GetForeignKeys;
|
||||
begin
|
||||
with Execute('select F.FK_CONSTRAINT_TABLE_NAME||''.''||C.FK_CONSTRAINT_REFERENCING_COLUMNS_NAME col, ' +
|
||||
' F.FK_CONSTRAINT_REFERENCES_TABLE_NAME||''.''||R.FK_CONSTRAINT_REFERENCED_COLUMNS_NAME ref ' +
|
||||
' from #FOREIGNKEY_CONSTRAINTS F, ' + ' #FOREIGNKEY_CONSTRAINTS_REFERENCING_COLUMNS C, ' +
|
||||
' #FOREIGNKEY_CONSTRAINTS_REFERENCED_COLUMNS R ' + ' where ' +
|
||||
' F.FK_CONSTRAINT_TABLE_NAME = C.FK_CONSTRAINT_TABLE_NAME' +
|
||||
' and F.FK_CONSTRAINT_NAME = C.FK_CONSTRAINT_NAME' +
|
||||
' F.FK_CONSTRAINT_TABLE_NAME = R.FK_CONSTRAINT_TABLE_NAME' +
|
||||
' and F.FK_CONSTRAINT_NAME = R.FK_CONSTRAINT_NAME', []) do
|
||||
while Step do
|
||||
fForeignKeys.Add(ColumnUTF8(0),ColumnUTF8(1));
|
||||
end;
|
||||
|
||||
function TSQLDBNexusDBConnectionProperties.NewConnection: TSQLDBConnection;
|
||||
begin
|
||||
result := TSQLDBNexusDBConnection.Create(self);
|
||||
end;
|
||||
|
||||
function TSQLDBNexusDBConnectionProperties.DatabaseExists: boolean;
|
||||
begin
|
||||
if (fProtocol=nxpFOLDER) and (fDatabaseName<>NEXUSDB_INMEMORY) then
|
||||
result := DirectoryExists(UTF8ToString(fDatabaseName)) else
|
||||
result := True; // if we cannot determine directly, assume it exists
|
||||
end;
|
||||
|
||||
function TSQLDBNexusDBConnectionProperties.CreateDatabase: boolean;
|
||||
begin
|
||||
if fProtocol=nxpFOLDER then
|
||||
if fDatabaseName=NEXUSDB_INMEMORY then
|
||||
result := true else
|
||||
result := ForceDirectories(UTF8ToString(fDatabaseName)) else
|
||||
result := false;
|
||||
end;
|
||||
|
||||
function TSQLDBNexusDBConnectionProperties.DeleteDatabase: boolean;
|
||||
begin
|
||||
if fProtocol=nxpFOLDER then
|
||||
if fDatabaseName=NEXUSDB_INMEMORY then
|
||||
result := true else
|
||||
result := DirectoryDelete(UTF8ToString(fDatabaseName)) else
|
||||
result := false;
|
||||
end;
|
||||
|
||||
|
||||
{ TSQLDBNexusDBConnection }
|
||||
|
||||
procedure TSQLDBNexusDBConnection.Commit;
|
||||
begin
|
||||
inherited Commit;
|
||||
try
|
||||
fDatabase.Commit;
|
||||
except
|
||||
inc(fTransactionCount); // the transaction is still active
|
||||
raise;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TSQLDBNexusDBConnection.Connect;
|
||||
var Log: ISynLog;
|
||||
begin
|
||||
Log := SynDBLog.Enter;
|
||||
try
|
||||
ServerEngine.Active := True;
|
||||
ServerEngine.Connected := True;
|
||||
fDatabase.Name := ClassName;
|
||||
fDatabase.Connect;
|
||||
inherited Connect; // notify any re-connection
|
||||
except
|
||||
on E: Exception do begin
|
||||
Log.Log(sllError,E);
|
||||
Disconnect; // clean up on fail
|
||||
raise;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
constructor TSQLDBNexusDBConnection.Create(aProperties: TSQLDBConnectionProperties);
|
||||
var
|
||||
lProp: TSQLDBNexusDBConnectionProperties;
|
||||
var Log: ISynLog;
|
||||
begin
|
||||
Log := SynDBLog.Enter;
|
||||
inherited Create(aProperties);
|
||||
lProp := aProperties as TSQLDBNexusDBConnectionProperties; // type check to make sure
|
||||
if lProp.Protocol=nxpUnknown then
|
||||
raise ESQLDBNexusDB.CreateUTF8(
|
||||
'%.Create: Unknown NexusDB protocol in Servername=[%]',
|
||||
[self,lProp.ServerName]);
|
||||
fDatabase := TnxDatabase.Create(nil);
|
||||
fSession := TnxSession.Create(nil);
|
||||
fSession.UserName := UTF8ToString(lProp.UserID);
|
||||
fSession.Password := UTF8ToString(lProp.PassWord);
|
||||
fDatabase.Session := fSession;
|
||||
if lProp.Protocol=nxpFOLDER then begin
|
||||
SetServerEngine(NexusEmbeddedEngine);
|
||||
if not lProp.DatabaseExists then begin
|
||||
Log.Log(sllDB,'Database % does not exists -> create folder',[lProp.DatabaseName]);
|
||||
lProp.CreateDatabase;
|
||||
end;
|
||||
Database.AliasPath := lProp.DatabaseName;
|
||||
Log.Log(sllDB,'NexusDB % using database folder %',
|
||||
[fDatabase.Version,lProp.DatabaseName]);
|
||||
end else begin
|
||||
raise ESQLDBNexusDB.Create('Remote NexusDB engine not supported (yet)');
|
||||
{ SetServerEngine(TnxRemoteServerEngine.Create(nil));
|
||||
Database.AliasName := lProp.DatabaseName;
|
||||
case lProp.Protocol of
|
||||
nxpTCPIP: FTransport := TnxWinsockTransport.Create(nil);
|
||||
nxpPIPE: FTransport := TnxNamedPipeTransport.Create(nil);
|
||||
nxpCOM: FTransport := TnxRegisteredCOMTransport.Create(nil);
|
||||
nxpMEM: FTransport := TnxSharedMemoryTransport.Create(nil);
|
||||
nxpBFISH: FTransport := TnxBlowfishRC4SecuredTransport.Create(nil);
|
||||
end;
|
||||
TnxRemoteServerEngine(FServerEngine).Transport := FTransport;
|
||||
FTransport.ServerName := lProp.Servername;
|
||||
FTransport.CommandHandler := FCommandHandler;
|
||||
FTransport.EventLog := FEventLog; }
|
||||
end;
|
||||
end;
|
||||
|
||||
destructor TSQLDBNexusDBConnection.Destroy;
|
||||
begin
|
||||
Disconnect;
|
||||
inherited;
|
||||
FreeAndNil(fDatabase);
|
||||
FreeAndNil(fSession);
|
||||
end;
|
||||
|
||||
procedure TSQLDBNexusDBConnection.Disconnect;
|
||||
begin
|
||||
try
|
||||
inherited Disconnect; // flush any cached statements
|
||||
finally
|
||||
if Assigned(fDatabase) then
|
||||
fDatabase.Close;
|
||||
if Assigned(fSession) and fSession.Active then begin
|
||||
fSession.CloseInactiveTables;
|
||||
fSession.CloseInactiveFolders;
|
||||
fSession.Close;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TSQLDBNexusDBConnection.IsConnected: boolean;
|
||||
begin
|
||||
result := Assigned(fDatabase) and fDatabase.Connected;
|
||||
end;
|
||||
|
||||
function TSQLDBNexusDBConnection.NewStatement: TSQLDBStatement;
|
||||
begin
|
||||
result := TSQLDBNexusDBStatement.Create(self);
|
||||
end;
|
||||
|
||||
procedure TSQLDBNexusDBConnection.Rollback;
|
||||
begin
|
||||
inherited Rollback;
|
||||
fDatabase.Rollback;
|
||||
end;
|
||||
|
||||
procedure TSQLDBNexusDBConnection.SetServerEngine(aServerEngine: TnxBaseServerEngine);
|
||||
begin
|
||||
if FServerEngine<>aServerEngine then begin
|
||||
FServerEngine := aServerEngine;
|
||||
fSession.ServerEngine := aServerEngine;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TSQLDBNexusDBConnection.StartTransaction;
|
||||
begin
|
||||
inherited StartTransaction;
|
||||
if not fDatabase.TryStartTransaction then
|
||||
raise ESQLDBNexusDB.Create('Error occcured trying to start a transaction');
|
||||
end;
|
||||
|
||||
|
||||
{ TSQLDBNexusDBStatement }
|
||||
|
||||
function TSQLDBNexusDBStatement.DatasetPrepare(const aSQL: string): boolean;
|
||||
begin
|
||||
(fQuery as TnxQuery).SQL.Text := aSQL;
|
||||
fQueryParams := TnxQuery(fQuery).Params;
|
||||
result := fQueryParams<>nil;
|
||||
end;
|
||||
|
||||
procedure TSQLDBNexusDBStatement.DatasetExecSQL;
|
||||
begin
|
||||
(fQuery as TnxQuery).ExecSQL;
|
||||
end;
|
||||
|
||||
procedure TSQLDBNexusDBStatement.DatasetCreate;
|
||||
begin
|
||||
fQuery := TnxQuery.Create(nil);
|
||||
with TnxQuery(fQuery) do begin
|
||||
Database := (fConnection as TSQLDBNexusDBConnection).Database;
|
||||
Session := TSQLDBNexusDBConnection(fConnection).Database.Session;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
{ low-level NexusDB engine functions }
|
||||
|
||||
var
|
||||
vNexusEmbeddedEngine: TnxServerEngine;
|
||||
|
||||
function GetNXProtocol(const aConnectionString: RawUTF8; out aServerName: RawUTF8;
|
||||
out aAlias: RawUTF8): TNXProtocol;
|
||||
const
|
||||
NXPROTNAMES:array[nxpFOLDER..high(TNXProtocol)] of RawUTF8 = (
|
||||
'nxemb','nxtcp','nxpipe','nxcom','nxmem','nxbfish');
|
||||
var Prot, Alias,l,r: RawUTF8;
|
||||
IsPath: boolean;
|
||||
pr:TNXProtocol;
|
||||
begin
|
||||
Split(aConnectionString,':',Prot,Alias);
|
||||
IsPath := (Prot='') or // no protocol indicated: assume it's a path (relative)
|
||||
(Prot=NEXUSDB_INMEMORY) or
|
||||
((Length(Prot)=1) and // check for drive letter
|
||||
(Prot[1] in ['a'..'z','A' .. 'Z']) and
|
||||
DirectoryExists(TFileName(Prot[1])+':\')) or // check if root folder can be found
|
||||
IdemPChar(Pointer(aConnectionString),'.\') or
|
||||
IdemPChar(Pointer(aConnectionString),'..\');
|
||||
if IsPath then begin
|
||||
result := nxpFOLDER;
|
||||
aAlias := aConnectionString;
|
||||
end else begin
|
||||
result := nxpUnknown;
|
||||
for pr := Low(NXPROTNAMES) to High(NXPROTNAMES) do
|
||||
if prot=NXPROTNAMES[pr] then begin
|
||||
result := pr;
|
||||
break;
|
||||
end;
|
||||
if result=nxpFOLDER then begin
|
||||
if prot<>'' then
|
||||
aAlias := Alias else
|
||||
aAlias := aConnectionString;
|
||||
end else
|
||||
if result>nxpFOLDER then begin
|
||||
Split(aConnectionString,'://',l,r);
|
||||
Split(r,'/',aServerName,aAlias);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
function DropNexusEmbeddedEngine: TnxServerEngine;
|
||||
var cmp: TComponent;
|
||||
i: integer;
|
||||
begin
|
||||
if PtrInt(vNexusEmbeddedEngine)<>-1 then begin
|
||||
if Assigned(vNexusEmbeddedEngine) then begin
|
||||
vNexusEmbeddedEngine.Close;
|
||||
vNexusEmbeddedEngine.SqlEngine := nil;
|
||||
vNexusEmbeddedEngine.EventLog := nil;
|
||||
// ensure our components get destroyed before destroying the engine
|
||||
for i := vNexusEmbeddedEngine.ComponentCount-1 downto 0 do begin
|
||||
cmp := vNexusEmbeddedEngine.Components[i];
|
||||
{$ifdef SYNDB_FULLNEXUSDB}
|
||||
if cmp is TnxServerCommandHandler then
|
||||
with TnxServerCommandHandler(cmp) do begin
|
||||
ServerEngine := nil;
|
||||
Close;
|
||||
Free;
|
||||
end else
|
||||
{$endif}
|
||||
if cmp is TnxSqlEngine then
|
||||
with TnxSqlEngine(cmp) do begin
|
||||
Close;
|
||||
Free;
|
||||
end else
|
||||
if cmp is TnxEventLog then
|
||||
with TnxEventLog(cmp) do begin
|
||||
Flush;
|
||||
Free;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
FreeAndNil(vNexusEmbeddedEngine);
|
||||
end;
|
||||
result := vNexusEmbeddedEngine;
|
||||
end;
|
||||
|
||||
function NexusEmbeddedEngine: TnxServerEngine;
|
||||
{$ifdef SYNDB_FULLNEXUSDB}
|
||||
var CommandHandler: TnxServerCommandHandler;
|
||||
{$endif}
|
||||
begin
|
||||
if PtrInt(vNexusEmbeddedEngine)=-1 then
|
||||
raise ESQLDBNexusDB.Create('Nexus Embedded engine was already finalized!') else
|
||||
if vNexusEmbeddedEngine=nil then begin
|
||||
vNexusEmbeddedEngine := TnxServerEngine.Create(nil);
|
||||
//vNexusEmbeddedEngine.Options := vNexusEmbeddedEngine.Options+[seoInMemOnly];
|
||||
{$ifdef SYNDB_FULLNEXUSDB}
|
||||
CommandHandler := TnxServerCommandHandler.Create(vNexusEmbeddedEngine);
|
||||
{$endif}
|
||||
vNexusEmbeddedEngine.SqlEngine := TnxSqlEngine.Create(vNexusEmbeddedEngine);
|
||||
vNexusEmbeddedEngine.EventLog := TnxEventLog.Create(vNexusEmbeddedEngine);
|
||||
{$ifdef SYNDB_FULLNEXUSDB}
|
||||
CommandHandler.ServerEngine := vNexusEmbeddedEngine;
|
||||
{$endif}
|
||||
end;
|
||||
result := vNexusEmbeddedEngine;
|
||||
end;
|
||||
|
||||
procedure FinalizeNXEmbeddedEngine;
|
||||
begin
|
||||
if PtrInt(vNexusEmbeddedEngine)<>-1 then
|
||||
try
|
||||
DropNexusEmbeddedEngine;
|
||||
finally
|
||||
PtrInt(vNexusEmbeddedEngine) := -1; // mark always as finalized
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
initialization
|
||||
TSQLDBNexusDBConnectionProperties.RegisterClassNameForDefinition;
|
||||
|
||||
finalization
|
||||
FinalizeNXEmbeddedEngine;
|
||||
end.
|
||||
593
contrib/mORMot/SynDBDataset/SynDBUniDAC.pas
Normal file
593
contrib/mORMot/SynDBDataset/SynDBUniDAC.pas
Normal file
@@ -0,0 +1,593 @@
|
||||
/// UniDAC-based classes for SynDB units
|
||||
// - this unit is a part of the freeware Synopse framework,
|
||||
// licensed under a MPL/GPL/LGPL tri-license; version 1.18
|
||||
unit SynDBUniDAC;
|
||||
|
||||
{
|
||||
This file is part of Synopse framework.
|
||||
|
||||
Synopse framework. Copyright (C) 2020 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) 2020
|
||||
the Initial Developer. All Rights Reserved.
|
||||
|
||||
Contributor(s):
|
||||
- alexpirate
|
||||
- delphinium (louisyeow)
|
||||
- itSDS
|
||||
- milesyou
|
||||
|
||||
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 *****
|
||||
|
||||
}
|
||||
|
||||
{$I Synopse.inc} // define HASINLINE CPU32 CPU64 OWNNORMTOUPPER
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Windows,
|
||||
SysUtils,
|
||||
{$IFNDEF DELPHI5OROLDER}
|
||||
Variants,
|
||||
{$ENDIF}
|
||||
Classes,
|
||||
Contnrs,
|
||||
SynCommons,
|
||||
SynLog,
|
||||
SynDB,
|
||||
SynDBDataset,
|
||||
Uni,
|
||||
UniProvider,
|
||||
UniScript;
|
||||
|
||||
|
||||
{ -------------- UniDAC database access }
|
||||
|
||||
const
|
||||
cMSSQLProvider = 'prDirect';
|
||||
|
||||
type
|
||||
/// Exception type associated to UniDAC database access
|
||||
ESQLDBUniDAC = class(ESQLDBDataset);
|
||||
|
||||
|
||||
/// connection properties definition using UniDAC database access
|
||||
TSQLDBUniDACConnectionProperties = class(TSQLDBDatasetConnectionProperties)
|
||||
protected
|
||||
fSpecificOptions: TStringList;
|
||||
/// initialize fForeignKeys content with all foreign keys of this DB
|
||||
// - do nothing by now (UniDAC metadata may be used in the future)
|
||||
procedure GetForeignKeys; override;
|
||||
public
|
||||
/// initialize the properties to connect via UniDAC database access
|
||||
// - aServerName shall contain the UniDAC provider name, e.g. 'Oracle' - you
|
||||
// can use the TSQLDBUniDACConnectionProperties.URI() to retrieve the
|
||||
// provider name from its SynDB.TSQLDBDefinition enumeration, and optionally
|
||||
// set some options, which will be added to the internal SpecificOptions[]:
|
||||
// ! 'Oracle?ClientLibrary=oci64\oci.dll'
|
||||
// ! 'MySQL?Server=192.168.2.60;Port=3306', 'world', 'root', 'dev'
|
||||
// - aDatabaseName shall contain the database server name
|
||||
constructor Create(const aServerName, aDatabaseName, aUserID, aPassWord: RawUTF8); override;
|
||||
/// release internal structures
|
||||
destructor Destroy; override;
|
||||
/// create a new connection
|
||||
// - caller is responsible of freeing this instance
|
||||
// - this overridden method will create an TSQLDBUniDACConnection instance
|
||||
function NewConnection: TSQLDBConnection; override;
|
||||
|
||||
/// compute the UniDAC URI from a given database engine and server name
|
||||
// - the optional server name can contain a port number, specified after ':'
|
||||
// - you can set an optional full path to the client library name,
|
||||
// to be completed on the left side with the executable path
|
||||
// - possible use may be:
|
||||
// ! PropsOracle := TSQLDBUniDACConnectionProperties.Create(
|
||||
// ! TSQLDBUniDACConnectionProperties.URI(dOracle,'','oci64\oci.dll'),
|
||||
// ! 'tnsname','user',pass');
|
||||
// ! PropsFirebird := TSQLDBUniDACConnectionProperties.Create(
|
||||
// ! TSQLDBUniDACConnectionProperties.URI(dFirebird,'',
|
||||
// ! 'Firebird\fbembed.dll'),'databasefilename','','');
|
||||
// ! PropsMySQL := TSQLDBUniDACConnectionProperties.Create(
|
||||
// ! TSQLDBUniDACConnectionProperties.URI(dMySQL,'192.168.2.60:3306'),
|
||||
// ! 'world', 'root', 'dev');
|
||||
class function URI(aServer: TSQLDBDefinition; const aServerName: RawUTF8;
|
||||
const aLibraryLocation: TFileName='';
|
||||
aLibraryLocationAppendExePath: boolean=true): RawUTF8;
|
||||
|
||||
/// retrieve the column/field layout of a specified table
|
||||
// - this overridden method will use UniDAC metadata to retrieve the information
|
||||
procedure GetFields(const aTableName: RawUTF8; out Fields: TSQLDBColumnDefineDynArray); override;
|
||||
/// get all table names
|
||||
// - this overridden method will use UniDAC metadata to retrieve the information
|
||||
procedure GetTableNames(out Tables: TRawUTF8DynArray); override;
|
||||
/// retrieve the advanced indexed information of a specified Table
|
||||
// - this overridden method will use UniDAC metadata to retrieve the information
|
||||
procedure GetIndexes(const aTableName: RawUTF8; out Indexes: TSQLDBIndexDefineDynArray); override;
|
||||
/// allow to set the options specific to a UniDAC driver
|
||||
// - for instance, you can set for both SQLite3 and Firebird/Interbase:
|
||||
// ! Props.SpecificOptions.Values['ClientLibrary'] := ClientDllName;
|
||||
property SpecificOptions: TStringList read fSpecificOptions;
|
||||
end;
|
||||
|
||||
|
||||
/// implements a direct connection via UniDAC database access
|
||||
TSQLDBUniDACConnection = class(TSQLDBConnectionThreadSafe)
|
||||
protected
|
||||
fDatabase: TUniConnection;
|
||||
public
|
||||
/// prepare a connection for a specified UniDAC database access
|
||||
constructor Create(aProperties: TSQLDBConnectionProperties); override;
|
||||
/// release memory and connection
|
||||
destructor Destroy; override;
|
||||
/// connect to the specified database server using UniDAC
|
||||
// - should raise an ESQLDBUniDAC on error
|
||||
procedure Connect; override;
|
||||
/// stop connection to the specified database server using UniDAC
|
||||
// - should raise an ESQLDBUniDAC on error
|
||||
procedure Disconnect; override;
|
||||
/// return TRUE if Connect has been already successfully called
|
||||
function IsConnected: boolean; override;
|
||||
/// create a new statement instance
|
||||
function NewStatement: TSQLDBStatement; override;
|
||||
/// begin a Transaction for this connection
|
||||
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;
|
||||
/// access to the associated UniDAC connection instance
|
||||
property Database: TUniConnection read fDatabase;
|
||||
end;
|
||||
|
||||
/// implements a statement via a UniDAC connection
|
||||
TSQLDBUniDACStatement = class(TSQLDBDatasetStatement)
|
||||
protected
|
||||
/// initialize and set fQuery: TUniQuery internal field as expected
|
||||
procedure DatasetCreate; override;
|
||||
/// set fQueryParams internal field as expected
|
||||
function DatasetPrepare(const aSQL: string): boolean; override;
|
||||
/// execute underlying TUniQuery.ExecSQL
|
||||
procedure DatasetExecSQL; override;
|
||||
/// overriden by itSDS to properly handle UniDAC parameters
|
||||
procedure DataSetBindSQLParam(const aArrayIndex, aParamIndex: integer; const aParam: TSQLDBParam); override;
|
||||
public
|
||||
end;
|
||||
|
||||
|
||||
const
|
||||
/// UniDAC provider names corresponding to SynDB recognized SQL engines
|
||||
UNIDAC_PROVIDER: array[dOracle..high(TSQLDBDefinition)] of RawUTF8 = (
|
||||
'Oracle','SQL Server','Access','MySQL','SQLite','InterBase',
|
||||
'NexusDB','PostgreSQL','DB2','');
|
||||
|
||||
implementation
|
||||
|
||||
uses
|
||||
DAScript, CRDataTypeMap, DBAccess;
|
||||
|
||||
|
||||
{ TSQLDBUniDACConnectionProperties }
|
||||
|
||||
constructor TSQLDBUniDACConnectionProperties.Create(const aServerName, aDatabaseName, aUserID, aPassWord: RawUTF8);
|
||||
var p: TSQLDBDefinition;
|
||||
provider,options,namevalue: RawUTF8;
|
||||
opt: PUTF8Char;
|
||||
begin
|
||||
Split(aServerName,'?',provider,options);
|
||||
for p := Low(UNIDAC_PROVIDER) to high(UNIDAC_PROVIDER) do
|
||||
if SameTextU(UNIDAC_PROVIDER[p],provider) then begin
|
||||
fDBMS := p;
|
||||
break;
|
||||
end;
|
||||
inherited Create(provider,aDatabaseName,aUserID,aPassWord);
|
||||
fSpecificOptions := TStringList.Create;
|
||||
opt := pointer(options);
|
||||
while opt<>nil do begin
|
||||
GetNextItem(opt,';',namevalue);
|
||||
if namevalue<>'' then
|
||||
fSpecificOptions.Add(UTF8ToString(namevalue));
|
||||
end;
|
||||
case fDBMS of
|
||||
dSQLite: begin // UniDAC support of SQLite3 is just buggy
|
||||
fSpecificOptions.Values['ForceCreateDatabase'] := 'true';
|
||||
fSQLCreateField[ftInt64] := ' BIGINT'; // SQLite3 INTEGER = 32bit for UniDAC
|
||||
end;
|
||||
dFirebird: begin
|
||||
{$ifndef UNICODE}
|
||||
fForceUseWideString := true;
|
||||
{$endif}
|
||||
fSpecificOptions.Values['CharSet'] := 'UTF8';
|
||||
fSpecificOptions.Values['UseUnicode'] := 'true';
|
||||
fSpecificOptions.Values['CharLength'] := '2';
|
||||
fSpecificOptions.Values['DescribeParams'] := 'true';
|
||||
end; // http://www.devart.com/unidac/docs/index.html?ibprov_article.htm
|
||||
dOracle: begin
|
||||
fSpecificOptions.Values['UseUnicode'] := 'true';
|
||||
fSpecificOptions.Values['Direct'] := 'true';
|
||||
fSpecificOptions.Values['HOMENAME'] := '';
|
||||
end;
|
||||
dMySQL: begin
|
||||
// s.d. 30.11.19 Damit der Connect schneller geht ! CRVioTCP.pas WaitForConnect
|
||||
fSpecificOptions.Values['MySQL.ConnectionTimeout'] := '0';
|
||||
end;
|
||||
dMSSQL: begin
|
||||
if aUserID='' then
|
||||
fSpecificOptions.Values['Authentication'] := 'auWindows';
|
||||
fSpecificOptions.Values['SQL Server.Provider'] := cMSSQLProvider;
|
||||
// s.d. 30.11.19 Damit der Connect im Direct Mode so Schnell ist wie mit prAuto/OleDB
|
||||
fSpecificOptions.Values['SQL Server.ConnectionTimeout'] := '0';
|
||||
end; // http://www.devart.com/unidac/docs/index.html?sqlprov_article.htm
|
||||
dPostgreSQL: begin // thanks delphinium for the trick!
|
||||
fSpecificOptions.Values['CharSet'] := 'UTF8';
|
||||
fSpecificOptions.Values['UseUnicode'] := 'true';
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
destructor TSQLDBUniDACConnectionProperties.Destroy;
|
||||
begin
|
||||
fSpecificOptions.Free;
|
||||
inherited;
|
||||
end;
|
||||
|
||||
procedure TSQLDBUniDACConnectionProperties.GetFields(
|
||||
const aTableName: RawUTF8; out Fields: TSQLDBColumnDefineDynArray);
|
||||
var meta: TDAMetaData;
|
||||
n: integer;
|
||||
F: TSQLDBColumnDefine;
|
||||
FA: TDynArray;
|
||||
hasSubType: boolean;
|
||||
Owner,Table: RawUTF8;
|
||||
begin
|
||||
meta := (MainConnection as TSQLDBUniDACConnection).fDatabase.CreateMetaData;
|
||||
try
|
||||
FA.Init(TypeInfo(TSQLDBColumnDefineDynArray),Fields,@n);
|
||||
FA.Compare := SortDynArrayAnsiStringI; // FA.Find() case insensitive
|
||||
FillChar(F,sizeof(F),0);
|
||||
meta.MetaDataKind := 'Columns';
|
||||
Split(aTableName,'.',Owner,Table);
|
||||
if Table='' then begin
|
||||
Table := Owner;
|
||||
Owner := '';
|
||||
end;
|
||||
if Owner = '' then
|
||||
Owner := MainConnection.Properties.DatabaseName; // itSDS
|
||||
if Owner<>'' then
|
||||
meta.Restrictions.Values['TABLE_SCHEMA'] := UTF8ToString(UpperCase(Owner))
|
||||
meta.Restrictions.Values['SCOPE'] := 'LOCAL';
|
||||
meta.Restrictions.Values['TABLE_NAME'] := UTF8ToString(UpperCase(Table));
|
||||
meta.Open;
|
||||
hasSubType := meta.FindField('DATA_SUBTYPE')<>nil;
|
||||
while not meta.Eof do begin
|
||||
F.ColumnName := StringToUTF8(meta.FieldByName('COLUMN_NAME').AsString);
|
||||
F.ColumnTypeNative := StringToUTF8(meta.FieldByName('DATA_TYPE').AsString);
|
||||
if hasSubType then
|
||||
F.ColumnTypeNative := F.ColumnTypeNative+
|
||||
StringToUTF8(meta.FieldByName('DATA_SUBTYPE').AsString);
|
||||
F.ColumnLength := meta.FieldByName('DATA_LENGTH').AsInteger;
|
||||
F.ColumnScale := meta.FieldByName('DATA_SCALE').AsInteger;
|
||||
F.ColumnPrecision := meta.FieldByName('DATA_PRECISION').AsInteger;
|
||||
F.ColumnType := ColumnTypeNativeToDB(F.ColumnTypeNative,F.ColumnScale);
|
||||
if F.ColumnType=ftUnknown then begin // UniDAC metadata failed -> use SQL
|
||||
inherited GetFields(aTableName,Fields);
|
||||
exit;
|
||||
end;
|
||||
FA.Add(F);
|
||||
meta.Next;
|
||||
end;
|
||||
Setlength(Fields,n);
|
||||
GetIndexesAndSetFieldsColumnIndexed(aTableName,Fields);
|
||||
finally
|
||||
meta.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TSQLDBUniDACConnectionProperties.GetIndexes(
|
||||
const aTableName: RawUTF8; out Indexes: TSQLDBIndexDefineDynArray);
|
||||
var meta, indexs: TDAMetaData;
|
||||
F: TSQLDBIndexDefine;
|
||||
FA: TDynArray;
|
||||
n: integer;
|
||||
ColName: RawUTF8;
|
||||
ndxName: string;
|
||||
begin
|
||||
SetLength(Indexes,0);
|
||||
FA.Init(TypeInfo(TSQLDBIndexDefineDynArray),Indexes,@n);
|
||||
fillchar(F,sizeof(F),0);
|
||||
meta := (MainConnection as TSQLDBUniDACConnection).fDatabase.CreateMetaData;
|
||||
indexs := (MainConnection as TSQLDBUniDACConnection).fDatabase.CreateMetaData;
|
||||
try
|
||||
meta.MetaDataKind := 'Indexes';
|
||||
meta.Restrictions.Values['TABLE_NAME'] := UTF8ToString(UpperCase(aTableName));
|
||||
meta.Open;
|
||||
while not meta.Eof do begin
|
||||
ndxName := meta.FieldByName('INDEX_NAME').AsString;
|
||||
F.IndexName := StringToUTF8(ndxName);
|
||||
F.KeyColumns := '';
|
||||
indexs.MetaDataKind := 'indexcolumns';
|
||||
indexs.Restrictions.Values['TABLE_NAME'] := UTF8ToString(UpperCase(aTableName));
|
||||
indexs.Restrictions.Values['INDEX_NAME'] := ndxName;
|
||||
indexs.Open;
|
||||
while not indexs.Eof do begin
|
||||
ColName := StringToUTF8(indexs.FieldByName('COLUMN_NAME').AsString);
|
||||
if F.KeyColumns='' then
|
||||
F.KeyColumns := ColName else
|
||||
F.KeyColumns := F.KeyColumns+','+ColName;
|
||||
indexs.Next;
|
||||
end;
|
||||
FA.Add(f);
|
||||
indexs.Close;
|
||||
meta.Next;
|
||||
end;
|
||||
SetLength(Indexes,n);
|
||||
finally
|
||||
indexs.Free;
|
||||
meta.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TSQLDBUniDACConnectionProperties.GetForeignKeys;
|
||||
var conn: TUniConnection;
|
||||
begin
|
||||
conn := (MainConnection as TSQLDBUniDACConnection).Database;
|
||||
if conn=nil then
|
||||
exit;
|
||||
{ TODO : get FOREIGN KEYS from UniDAC metadata ? }
|
||||
end;
|
||||
|
||||
procedure TSQLDBUniDACConnectionProperties.GetTableNames(out Tables: TRawUTF8DynArray);
|
||||
var List: TStringList;
|
||||
begin
|
||||
List := TStringList.Create;
|
||||
try
|
||||
(MainConnection as TSQLDBUniDACConnection).fDatabase.GetTableNames(List);
|
||||
StringListToRawUTF8DynArray(List,Tables);
|
||||
exit;
|
||||
finally
|
||||
List.Free;
|
||||
end;
|
||||
inherited;
|
||||
end;
|
||||
|
||||
function TSQLDBUniDACConnectionProperties.NewConnection: TSQLDBConnection;
|
||||
begin
|
||||
result := TSQLDBUniDACConnection.Create(self);
|
||||
end;
|
||||
|
||||
class function TSQLDBUniDACConnectionProperties.URI(aServer: TSQLDBDefinition;
|
||||
const aServerName: RawUTF8; const aLibraryLocation: TFileName;
|
||||
aLibraryLocationAppendExePath: boolean): RawUTF8;
|
||||
var Server,Port: RawUTF8;
|
||||
begin
|
||||
if aServer<low(UNIDAC_PROVIDER) then
|
||||
result := '' else
|
||||
result := UNIDAC_PROVIDER[aServer];
|
||||
if result='' then
|
||||
exit;
|
||||
if aLibraryLocation<>'' then begin
|
||||
result := result+'?ClientLibrary=';
|
||||
if aLibraryLocationAppendExePath then
|
||||
result := result+StringToUTF8(ExtractFilePath(ParamStr(0)));
|
||||
result := result+StringToUTF8(aLibraryLocation);
|
||||
end;
|
||||
if aServerName<>'' then begin
|
||||
Split(aServerName,':',Server,Port);
|
||||
if aLibraryLocation='' then
|
||||
result := result+'?' else
|
||||
result := result+';';
|
||||
result := result+'Server='+Server;
|
||||
if Port<>'' then
|
||||
result := result+';Port='+Port;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
{ TSQLDBUniDACConnection }
|
||||
|
||||
procedure TSQLDBUniDACConnection.Commit;
|
||||
begin
|
||||
inherited Commit;
|
||||
try
|
||||
fDatabase.Commit;
|
||||
except
|
||||
inc(fTransactionCount); // the transaction is still active
|
||||
raise;
|
||||
end;
|
||||
end;
|
||||
|
||||
constructor TSQLDBUniDACConnection.Create(aProperties: TSQLDBConnectionProperties);
|
||||
var options: TStrings;
|
||||
PortNumber, i: Integer;
|
||||
begin
|
||||
inherited Create(aProperties);
|
||||
if (aProperties.DBMS = dMSSQL) and (not SameText(cMSSQLProvider, 'prDirect')) then
|
||||
CoInit;
|
||||
fDatabase := TUniConnection.Create(nil);
|
||||
fDatabase.LoginPrompt := false;
|
||||
fDatabase.ProviderName := UTF8ToString(fProperties.ServerName);
|
||||
case aProperties.DBMS of
|
||||
dSQLite, dFirebird, dPostgreSQL, dMySQL, dDB2, dMSSQL:
|
||||
fDatabase.Database := UTF8ToString(fProperties.DatabaseName);
|
||||
else
|
||||
fDatabase.Server := UTF8ToString(fProperties.DatabaseName);
|
||||
end;
|
||||
fDatabase.Username := UTF8ToString(fProperties.UserID);
|
||||
fDatabase.Password := UTF8ToString(fProperties.PassWord);
|
||||
if aProperties.DBMS = dMySQL then
|
||||
// s.d. 30.11.19 Damit der Connect schneller geht
|
||||
fDatabase.SpecificOptions.Add('MySQL.ConnectionTimeout=0');
|
||||
if aProperties.DBMS = dMSSQL then begin
|
||||
fDatabase.SpecificOptions.Add('SQL Server.Provider='+cMSSQLProvider);
|
||||
// s.d. 30.11.19 Damit der Connect im Direct Mode so Schnell ist wie mit prAuto/OleDB
|
||||
fDatabase.SpecificOptions.Add('SQL Server.ConnectionTimeout=0');
|
||||
end;
|
||||
// handle the options set by TSQLDBUniDACConnectionProperties.URI()
|
||||
options := (fProperties as TSQLDBUniDACConnectionProperties).fSpecificOptions;
|
||||
if fDatabase.Server='' then
|
||||
fDatabase.Server := options.Values['Server'];
|
||||
if fDatabase.Database='' then
|
||||
fDatabase.Database := options.Values['Database'];
|
||||
if (fDatabase.Port=0) and TryStrToInt(options.Values['Port'],PortNumber) then
|
||||
fDatabase.Port := PortNumber;
|
||||
for i := 0 to options.Count-1 do
|
||||
if FindRawUTF8(['Server','Database','Port'],
|
||||
StringToUTF8(options.Names[i]),false)<0 then
|
||||
fDatabase.SpecificOptions.Add(options[i]);
|
||||
end;
|
||||
|
||||
procedure TSQLDBUniDACConnection.Connect;
|
||||
var Log: ISynLog;
|
||||
begin
|
||||
if fDatabase=nil then
|
||||
raise ESQLDBUniDAC.CreateUTF8('%.Connect(%): Database=nil',
|
||||
[self,fProperties.ServerName]);
|
||||
Log := SynDBLog.Enter('Connect to ProviderName=% Database=% on Server=%',
|
||||
[fDatabase.ProviderName,fDatabase.Database,fDatabase.Server],self);
|
||||
try
|
||||
case fProperties.DBMS of
|
||||
dFirebird:
|
||||
if (fDatabase.Server= '') and not FileExists(fDatabase.Database) then
|
||||
with TUniScript.Create(nil) do // always create database for embedded Firebird
|
||||
try
|
||||
NoPreconnect := true;
|
||||
SQL.Text := UTF8ToString(fProperties.SQLCreateDatabase(fProperties.DatabaseName));
|
||||
Connection := fDatabase;
|
||||
Execute;
|
||||
finally
|
||||
Free;
|
||||
end;
|
||||
end;
|
||||
fDatabase.Open;
|
||||
inherited Connect; // notify any re-connection
|
||||
Log.Log(sllDB,'Connected to % (%)',
|
||||
[fDatabase.ProviderName,fDatabase.ServerVersionFull]);
|
||||
except
|
||||
on E: Exception do begin
|
||||
Log.Log(sllError,E);
|
||||
Disconnect; // clean up on fail
|
||||
raise;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TSQLDBUniDACConnection.Disconnect;
|
||||
begin
|
||||
try
|
||||
inherited Disconnect; // flush any cached statement
|
||||
finally
|
||||
if fDatabase<>nil then
|
||||
fDatabase.Close;
|
||||
end;
|
||||
end;
|
||||
|
||||
destructor TSQLDBUniDACConnection.Destroy;
|
||||
begin
|
||||
try
|
||||
Disconnect;
|
||||
if (fProperties.DBMS = dMSSQL) and (not SameText(cMSSQLProvider, 'prDirect')) then
|
||||
CoUnInit;
|
||||
except
|
||||
on Exception do
|
||||
end;
|
||||
inherited;
|
||||
FreeAndNil(fDatabase);
|
||||
end;
|
||||
|
||||
function TSQLDBUniDACConnection.IsConnected: boolean;
|
||||
begin
|
||||
result := Assigned(fDatabase) and fDatabase.Connected;
|
||||
end;
|
||||
|
||||
function TSQLDBUniDACConnection.NewStatement: TSQLDBStatement;
|
||||
begin
|
||||
result := TSQLDBUniDACStatement.Create(self);
|
||||
end;
|
||||
|
||||
procedure TSQLDBUniDACConnection.Rollback;
|
||||
begin
|
||||
inherited Rollback;
|
||||
fDatabase.Rollback;
|
||||
end;
|
||||
|
||||
procedure TSQLDBUniDACConnection.StartTransaction;
|
||||
begin
|
||||
inherited StartTransaction;
|
||||
fDatabase.StartTransaction;
|
||||
end;
|
||||
|
||||
|
||||
{ TSQLDBUniDACStatement }
|
||||
|
||||
procedure TSQLDBUniDACStatement.DataSetBindSQLParam(const aArrayIndex,
|
||||
aParamIndex: integer; const aParam: TSQLDBParam);
|
||||
var P: TDAParam;
|
||||
begin
|
||||
P := TDAParam(fQueryParams[aParamIndex]);
|
||||
if P.InheritsFrom(TDAParam) then
|
||||
with aParam do
|
||||
if (VinOut<>paramInOut) and (VType=SynTable.ftBlob) then begin
|
||||
P.ParamType := SQLParamTypeToDBParamType(VInOut);
|
||||
if aArrayIndex>=0 then
|
||||
{$ifdef UNICODE}
|
||||
P.SetBlobData(Pointer(VArray[aArrayIndex]),Length(VArray[aArrayIndex])) else
|
||||
P.SetBlobData(Pointer(VData),Length(VData));
|
||||
{$else} P.AsString := VArray[aArrayIndex] else
|
||||
P.AsString := VData;
|
||||
{$endif}exit;
|
||||
end;
|
||||
inherited DataSetBindSQLParam(aArrayIndex, aParamIndex, aParam);
|
||||
end;
|
||||
|
||||
procedure TSQLDBUniDACStatement.DatasetCreate;
|
||||
begin
|
||||
fQuery := TUniQuery.Create(nil);
|
||||
TUniQuery(fQuery).Connection := (fConnection as TSQLDBUniDACConnection).Database;
|
||||
end;
|
||||
|
||||
function TSQLDBUniDACStatement.DatasetPrepare(const aSQL: string): boolean;
|
||||
begin
|
||||
(fQuery as TUniQuery).SQL.Text := aSQL;
|
||||
fQueryParams := TUniQuery(fQuery).Params;
|
||||
result := fQueryParams<>nil;
|
||||
end;
|
||||
|
||||
procedure TSQLDBUniDACStatement.DatasetExecSQL;
|
||||
begin
|
||||
(fQuery as TUniQuery).Execute;
|
||||
end;
|
||||
|
||||
|
||||
initialization
|
||||
TSQLDBUniDACConnectionProperties.RegisterClassNameForDefinition;
|
||||
end.
|
||||
Reference in New Issue
Block a user