Componentes.Terceros.RemObj.../internal/5.0.24.615/1/Data Abstract for Delphi/Source/Drivers/uDAFIBDriver.pas

685 lines
20 KiB
ObjectPascal

unit uDAFIBDriver;
{----------------------------------------------------------------------------}
{ Data Abstract Library - Driver Library
{
{ compiler: Delphi 6 and up
{ platform: Win32
{
{ (c)opyright RemObjects Software. all rights reserved.
{
{ Using this code requires a valid license of the Data Abstract
{ which can be obtained at http://www.remobjects.com.
{----------------------------------------------------------------------------}
{$IFDEF MSWINDOWS}
{$I ..\DataAbstract.inc}
{$ENDIF MSWINDOWS}
{$IFDEF LINUX}
{$I ../DataAbstract.inc}
{$ENDIF LINUX}
{$R DataAbstract_FIBDriver_Glyphs.res}
interface
uses
Classes, DB, uDAEngine, uDAInterfaces, uDAIBInterfaces, FIBDatabase,
uROClasses, pFIBDatabase, FIBQuery, pFIBQuery, pFIBStoredProc, uDAUtils,
FIBDataSet, ibase, FIBSQLMonitor;
type
{ TDAFIBDriver }
TDAFIBDriver = class(TDADriverReference)
end;
{ TFIBConnection }
TFIBConnection = class(TDAConnectionWrapper)
private
fDatabase: TpFIBDatabase;
fTransaction: TFIBTransaction;
protected
function GetConnected: Boolean; override;
procedure SetConnected(Value: boolean); override;
public
constructor Create(AOwner: TComponent); override;
property Database: TpFIBDatabase read fDatabase;
property Transaction: TFIBTransaction read fTransaction;
end;
{ TDAEFIBDriver }
TDAEFIBDriver = class(TDAIBDriver)
private
fFIBTraceOptions: TFIBTraceFlags;
fTraceCallback: TDALogTraceEvent;
fMonitor: TFIBSQLMonitor;
procedure OnTrace(EventText: string; EventTime: TDateTime);
protected
function GetConnectionClass: TDAEConnectionClass; override;
procedure CustomizeConnectionObject(aConnection: TDAEConnection); override;
procedure DoSetTraceOptions(TraceActive: boolean; TraceOptions: TDATraceOptions; Callback: TDALogTraceEvent); override;
// IDADriver
function GetDriverID: string; override;
function GetDescription: string; override;
public
end;
{ TDAEFIBConnection }
TDAEFIBConnection = class(TDAIBConnection, IDAInterbaseConnection, IDAIBTransactionAccess, IDAIBConnectionProperties, IDAUseGenerators, IDAFileBasedDatabase)
private
fConnection: TFIBConnection;
protected
// IIBTransactionAccess
function GetTransaction: TObject; safecall;
procedure Commit; safecall;
procedure CommitRetaining; safecall;
procedure Rollback; safecall;
procedure RollbackRetaining; safecall;
// IIBConnectionProperties
function GetRole: string; safecall;
procedure SetRole(const Value: string); safecall;
function GetSQLDialect: integer; override; safecall;
procedure SetSQLDialect(Value: integer); safecall;
function GetCharset: string; safecall;
procedure SetCharset(const Value: string); safecall;
// IDAConnection
function CreateCustomConnection: TCustomConnection; override;
function GetDatasetClass: TDAEDatasetClass; override;
function GetStoredProcedureClass: TDAEStoredProcedureClass; override;
procedure DoApplyConnectionString(aConnStrParser: TDAConnectionStringParser;
aConnectionObject: TCustomConnection); override;
function DoBeginTransaction: integer; override;
procedure DoCommitTransaction; override;
procedure DoRollbackTransaction; override;
function DoGetInTransaction: boolean; override;
public
end;
{ TDAEFIBQuery }
TDAEFIBQuery = class(TDAEDataset, IDAMustSetParams)
private
protected
function DoGetRecordCount: integer; override;
function CreateDataset(aConnection: TDAEConnection): TDataset; override;
function DoExecute: integer; override;
function DoGetSQL: string; override;
procedure DoSetSQL(const Value: string); override;
procedure DoPrepare(Value: boolean); override;
procedure RefreshParams; override;
procedure DoSetActive(Value: Boolean); override;
procedure SetParamValues(Params: TDAParamCollection); safecall;
procedure GetParamValues(Params: TDAParamCollection); safecall;
public
end;
{ TDAEFIBStoredProcedure }
TDAEFIBStoredProcedure = class(TDAEStoredProcedure, IDAMustSetParams)
private
FSP: TpFIBStoredProc;
protected
function CreateDataset(aConnection: TDAEConnection): TDataset; override;
function GetStoredProcedureName: string; override;
procedure SetStoredProcedureName(const Name: string); override;
procedure RefreshParams; override;
function Execute: integer; override;
procedure SetParamValues(Params: TDAParamCollection); safecall;
procedure GetParamValues(Params: TDAParamCollection); safecall;
end;
procedure Register;
function GetDriverObject: IDADriver; stdcall;
implementation
uses SysUtils, uDADriverManager, uDARes,
pFIBProps;
var
_driver: TDAEDriver = nil;
procedure Register;
begin
RegisterComponents(DAPalettePageName, [TDAFIBDriver]);
end;
{$IFDEF DataAbstract_SchemaModelerOnly}
{$INCLUDE ..\DataAbstract_SchemaModelerOnly.inc}
{$ENDIF DataAbstract_SchemaModelerOnly}
function GetDriverObject: IDADriver;
begin
{$IFDEF DataAbstract_SchemaModelerOnly}
if not RunningInSchemaModeler then begin
result := nil;
exit;
end;
{$ENDIF}
if (_driver = nil) then _driver := TDAEFIBDriver.Create(nil);
result := _driver;
end;
{ TFIBConnection }
constructor TFIBConnection.Create(AOwner: TComponent);
begin
inherited;
fDatabase := TpFIBDatabase.Create(Self);
fTransaction := TFIBTransaction.Create(Self);
fDatabase.UseLoginPrompt := FALSE;
fDatabase.DefaultTransaction := fTransaction;
end;
function TFIBConnection.GetConnected: Boolean;
begin
result := fDatabase.Connected
end;
procedure TFIBConnection.SetConnected(Value: boolean);
begin
// This first check is required.
// I think there's a bug in the FIB destroying sequence and the notification. TCustomConnection gets to this point *after*
// the owned components are destroyed. Only happens with FIB...
if (csDestroying in ComponentState) then Exit;
fDatabase.Connected := Value
end;
{ TDAEFIBConnection }
procedure TDAEFIBConnection.DoApplyConnectionString(
aConnStrParser: TDAConnectionStringParser; aConnectionObject: TCustomConnection);
begin
inherited;
fConnection.Database.SQLDialect := 3;
with aConnStrParser do begin
if (Self.UserID <> '') then
fConnection.Database.ConnectParams.UserName := Self.UserID
else
fConnection.Database.ConnectParams.UserName := UserID;
if (Self.Password <> '') then
fConnection.Database.ConnectParams.Password := Self.Password
else
fConnection.Database.ConnectParams.Password := Password;
if Server <> '' then
fConnection.Database.DatabaseName := Server + ':' + Database
else
fConnection.Database.DatabaseName := Database;
if AuxParams['Dialect'] <> '' then
fConnection.Database.SQLDialect := StrtoInt(AuxParams['Dialect'])
else if AuxParams['SQLDialect'] <> '' then
fConnection.Database.SQLDialect := StrtoInt(AuxParams['SQLDialect']);
if AuxParams['Role'] <> '' then
fConnection.Database.ConnectParams.RoleName := AuxParams['Role'];
if AuxParams['Charset'] <> '' then
SetCharset(AuxParams['Charset']);
end;
end;
function TDAEFIBConnection.DoBeginTransaction: integer;
begin
result := -1;
fConnection.Database.DefaultTransaction.StartTransaction;
end;
procedure TDAEFIBConnection.DoCommitTransaction;
begin
fConnection.Database.DefaultTransaction.Commit;
end;
function TDAEFIBConnection.CreateCustomConnection: TCustomConnection;
begin
fConnection := TFIBConnection.Create(nil);
result := fConnection;
end;
function TDAEFIBConnection.GetDatasetClass: TDAEDatasetClass;
begin
result := TDAEFIBQuery
end;
function TDAEFIBConnection.GetStoredProcedureClass: TDAEStoredProcedureClass;
begin
result := TDAEFIBStoredProcedure
end;
function TDAEFIBConnection.GetTransaction: TObject;
begin
result := fConnection.fTransaction;
end;
procedure TDAEFIBConnection.DoRollbackTransaction;
begin
fConnection.Database.DefaultTransaction.Rollback;
end;
function TDAEFIBConnection.GetRole: string;
begin
result := fConnection.Database.ConnectParams.RoleName;
end;
function TDAEFIBConnection.GetSQLDialect: integer;
begin
result := fConnection.Database.SQLDialect
end;
function TDAEFIBConnection.GetCharset: string;
begin
result := fConnection.Database.ConnectParams.CharSet
end;
procedure TDAEFIBConnection.SetRole(const Value: string);
begin
fConnection.Database.ConnectParams.RoleName := Value
end;
procedure TDAEFIBConnection.SetSQLDialect(Value: integer);
begin
fConnection.Database.SQLDialect := Value
end;
procedure TDAEFIBConnection.SetCharset(const Value: string);
begin
fConnection.Database.ConnectParams.CharSet := Value;
end;
procedure TDAEFIBConnection.Commit;
begin
fConnection.fTransaction.Commit
end;
procedure TDAEFIBConnection.CommitRetaining;
begin
fConnection.fTransaction.CommitRetaining
end;
procedure TDAEFIBConnection.Rollback;
begin
fConnection.fTransaction.Rollback
end;
procedure TDAEFIBConnection.RollbackRetaining;
begin
fConnection.fTransaction.RollbackRetaining
end;
function TDAEFIBConnection.DoGetInTransaction: boolean;
begin
result := fConnection.fTransaction.InTransaction
end;
{ TDAEFIBDriver }
procedure TDAEFIBDriver.CustomizeConnectionObject(aConnection: TDAEConnection);
begin
// 25/04/06 13:05 Donald Shimoda . To do.
//TDAEFIBConnection(aConnection).fConnection.Database.TraceFlags := fIBTraceOptions;
end;
procedure TDAEFIBDriver.DoSetTraceOptions(TraceActive: boolean;
TraceOptions: TDATraceOptions; Callback: TDALogTraceEvent);
begin
inherited;
if TraceActive then begin
if (fMonitor = nil) then fMonitor := TFIBSQLMonitor.Create(Self);
fMonitor.Active := False;
fMonitor.OnSQL := OnTrace;
fFIBTraceOptions := [];
if (toPrepare in TraceOptions) then fFIBTraceOptions := fFIBTraceOptions + [tfQPrepare];
if (toExecute in TraceOptions) then fFIBTraceOptions := fFIBTraceOptions + [tfQExecute];
if (toFetch in TraceOptions) then fFIBTraceOptions := fFIBTraceOptions + [tfQFetch];
if (toConnect in TraceOptions) then fFIBTraceOptions := fFIBTraceOptions + [tfConnect];
if (toTransact in TraceOptions) then fFIBTraceOptions := fFIBTraceOptions + [tfTransact];
if (toService in TraceOptions) then fFIBTraceOptions := fFIBTraceOptions + [tfService];
if (toMisc in TraceOptions) then fFIBTraceOptions := fFIBTraceOptions + [tfMisc];
fTraceCallBack := Callback;
fMonitor.TraceFlags := fFIBTraceOptions;
fMonitor.Active := True;
end
else begin
FreeAndNIL(fMonitor);
fTraceCallback := nil;
end;
end;
function TDAEFIBDriver.GetConnectionClass: TDAEConnectionClass;
begin
result := TDAEFIBConnection;
end;
function TDAEFIBDriver.GetDescription: string;
begin
result := 'FIBPlus Driver'{$IFDEF DataAbstract_SchemaModelerOnly} + SchemaModelerOnly{$ENDIF};
end;
function TDAEFIBDriver.GetDriverID: string;
begin
result := 'FIB';
end;
procedure CreateParams(FQuery: TFIBQuery; Pars: TDAParamCollection; CreateOutputParams: Boolean = False);
var
i: Integer;
par: TDAParam;
sqPar: TFIBXSQLVAR;
begin
if FQuery.Database.Handle = nil then
FQuery.Database.Open;
if not FQuery.Prepared then
FQuery.Prepare;
pars.Clear;
for i := 0 to FQuery.ParamCount -1 do begin
sqpar := FQuery.Params[i];
if sqpar.IsParam then begin
par := pars.Add;
par.Name := sqPar.Name;
par.ParamType:= daptInput;
case sqpar.SQLType and not 1 of
SQL_VARYING, SQL_TEXT:
begin
if sqPar.CharacterSet = 'UNICODE_FSS' then
par.DataType := datWideString
else
par.DataType := datString;
par.Size := sqPar.Size;
end;
SQL_DOUBLE, SQL_FLOAT,SQL_D_FLOAT:par.DataType := datFloat;
SQL_SHORT, SQL_LONG: begin
if sqPar.Scale <> 0 then
par.DataType := datFloat
else
par.DataType := datInteger;
end;
SQL_INT64: begin
if sqPar.Scale <> 0 then
par.DataType := datFloat
else
par.DataType := datLargeInt;
end;
SQL_TIMESTAMP,
SQL_TYPE_TIME,
SQL_TYPE_DATE: par.DataType := datDateTime;
SQL_BLOB:
if sqPar.SQLSubtype = 1 then
par.DataType := datMemo
else
par.DataType := datBlob;
SQL_BOOLEAN: par.DataType := datBoolean;
else
par.DataType := datUnknown;
end;
end;
end;
if CreateOutputParams then
for i := 0 to FQuery.FieldCount -1 do begin
sqpar := FQuery.Fields[i];
par := pars.Add;
par.Name := sqPar.Name;
par.ParamType:= daptOutput;
case sqpar.SQLType and not 1 of
SQL_VARYING, SQL_TEXT:
begin
if sqPar.CharacterSet = 'UNICODE_FSS' then
par.DataType := datWideString
else
par.DataType := datString;
par.Size := sqPar.Size;
end;
SQL_DOUBLE, SQL_FLOAT,SQL_D_FLOAT:par.DataType := datFloat;
SQL_SHORT, SQL_LONG: begin
if sqPar.Scale <> 0 then
par.DataType := datFloat
else
par.DataType := datInteger;
end;
SQL_INT64: begin
if sqPar.Scale <> 0 then
par.DataType := datFloat
else
par.DataType := datLargeInt;
end;
SQL_TIMESTAMP,
SQL_TYPE_TIME,
SQL_TYPE_DATE: par.DataType := datDateTime;
SQL_BLOB:
if sqPar.SQLSubtype = 1 then
par.DataType := datMemo
else
par.DataType := datBlob;
SQL_BOOLEAN: par.DataType := datBoolean;
else
par.DataType := datUnknown;
end;
end;
end;
{ TDAEFIBQuery }
procedure TDAEFIBDriver.OnTrace(EventText: string; EventTime: TDateTime);
begin
if Assigned(fTraceCallback) then fTraceCallback(fMonitor, EventText, 0);
end;
{ TDAEFIBStoredProcedure }
function TDAEFIBStoredProcedure.CreateDataset(
aConnection: TDAEConnection): TDataset;
begin
FreeAndNil(FSP);
FSP := TpFIBStoredProc.Create(nil);
FSP.Database := TDAEFIBConnection(aConnection).fConnection.Database;
result := nil;
end;
function TDAEFIBStoredProcedure.Execute: integer;
begin
if not TDAEFIBConnection(Connection).fConnection.Connected then TDAEFIBConnection(Connection).fConnection.Open;
if not TDAEFIBConnection(Connection).fConnection.Transaction.InTransaction then
TDAEFIBConnection(Connection).fConnection.Transaction.StartTransaction;
if FSP.Database.Handle = nil then
FSP.Database.Open;
SetParamValues(GetParams);
FSP.ExecQuery;
result := FSP.RowsAffected;
GetParamValues(GetParams);
end;
procedure TDAEFIBStoredProcedure.SetParamValues(Params: TDAParamCollection);
var
i: integer;
_params: TDAParamCollection;
sqPar: TFIBXSQLVAR;
begin
_params := Params;
for i := 0 to _params.Count - 1 do begin
if (_Params[i].ParamType in [daptInput, daptInputOutput, daptUnknown]) then begin
sqPar:= FSP.ParamByName(_Params[i].Name);
if (sqPar <> nil) and sqPar.IsParam then sqPar.Value:=_params[i].Value;
end;
end;
end;
procedure TDAEFIBStoredProcedure.GetParamValues(Params: TDAParamCollection);
var
i: integer;
_params: TDAParamCollection;
sqPar: TFIBXSQLVAR;
begin
_params := Params;
for i := 0 to _params.Count - 1 do begin
if (Params[i].ParamType in [daptOutput, daptInputOutput, daptResult]) then begin
sqPar:= FSP.FieldByName(_Params[i].Name);
if (sqPar <> nil) then _params[i].Value:=sqPar.Value;
end;
end;
end;
function TDAEFIBStoredProcedure.GetStoredProcedureName: string;
begin
result := FSP.StoredProcName;
end;
procedure TDAEFIBStoredProcedure.SetStoredProcedureName(
const Name: string);
begin
if not TDAEFIBConnection(Connection).fConnection.Connected then TDAEFIBConnection(Connection).fConnection.Open;
if not TDAEFIBConnection(Connection).fConnection.Transaction.InTransaction then
TDAEFIBConnection(Connection).fConnection.Transaction.StartTransaction;
FSP.StoredProcName := Name;
end;
procedure TDAEFIBStoredProcedure.RefreshParams;
begin
if not TDAEFIBConnection(Connection).fConnection.Connected then TDAEFIBConnection(Connection).fConnection.Open;
if not TDAEFIBConnection(Connection).fConnection.Transaction.InTransaction then
TDAEFIBConnection(Connection).fConnection.Transaction.StartTransaction;
CreateParams(FSP, GetParams,True);
end;
exports
GetDriverObject name func_GetDriverObject;
{ TDAEFIBQuery }
function TDAEFIBQuery.CreateDataset(aConnection: TDAEConnection): TDataset;
var
ds: TFIBDataSet;
begin
ds := TFIBDataSet.Create(nil);
ds.Database := TDAEFIBConnection(aConnection).fConnection.Database;
ds.Transaction := TDAEFIBConnection(aConnection).fConnection.Transaction;
ds.PrepareOptions := ds.PrepareOptions + [psUseLargeIntField];
result := ds;
end;
function TDAEFIBQuery.DoExecute: integer;
begin
if not TDAEFIBConnection(Connection).fConnection.Connected then TDAEFIBConnection(Connection).fConnection.Open;
if not TDAEFIBConnection(Connection).fConnection.Transaction.InTransaction then
TDAEFIBConnection(Connection).fConnection.Transaction.StartTransaction;
TFIBDataSet(Dataset).QSelect.ExecQuery;
result := TFIBDataSet(Dataset).QSelect.RowsAffected;
end;
function TDAEFIBQuery.DoGetRecordCount: integer;
begin
result := TFIBDataSet(DAtaset).QSelect.RecordCount;
end;
function TDAEFIBQuery.DoGetSQL: string;
begin
result := TFIBDataSet(DAtaset).QSelect.SQL.Text;
end;
procedure TDAEFIBQuery.DoPrepare(Value: boolean);
begin
if not TDAEFIBConnection(Connection).fConnection.Connected then TDAEFIBConnection(Connection).fConnection.Open;
if not TDAEFIBConnection(Connection).fConnection.Transaction.InTransaction then
TDAEFIBConnection(Connection).fConnection.Transaction.StartTransaction;
if Value then TFIBDataSet(DAtaset).QSelect.Prepare;
end;
procedure TDAEFIBQuery.DoSetActive(Value: Boolean);
begin
if not TDAEFIBConnection(Connection).fConnection.Connected then TDAEFIBConnection(Connection).fConnection.Open;
if not TDAEFIBConnection(Connection).fConnection.Transaction.InTransaction then
TDAEFIBConnection(Connection).fConnection.Transaction.StartTransaction;
if Value then begin
if not TFIBDataSet(Dataset).Database.Connected then
TFIBDataSet(Dataset).Database.Connected := true;
end;
inherited DoSetActive(Value);
end;
procedure TDAEFIBQuery.DoSetSQL(const Value: string);
begin
TFIBDataSet(DAtaset).QSelect.SQL.Text := Value;
end;
procedure TDAEFIBQuery.RefreshParams;
begin
CreateParams(TFIBDataSet(Dataset).QSelect, GetParams);
end;
procedure TDAEFIBQuery.SetParamValues(Params: TDAParamCollection);
var
i: integer;
_params: TDAParamCollection;
_par: TDAParam;
begin
_params := GetParams;
for i := 0 to TFIBDataSet(Dataset).ParamCount - 1 do begin
_Par := _params.ParamByName(TFIBDataSet(Dataset).Params[i].Name);
if (_Par.ParamType in [daptInput, daptInputOutput, daptUnknown]) then
if (TFIBDataSet(Dataset).Params[i].IsParam) then TFIBDataSet(Dataset).Params[i].Value := _Par.Value;
end;
end;
procedure TDAEFIBQuery.GetParamValues(Params: TDAParamCollection);
var
i: integer;
_params: TDAParamCollection;
_Par: TDAParam;
begin
_params := GetParams;
for i := 0 to TFIBDataSet(Dataset).ParamCount - 1 do begin
_Par := _params.ParamByName(TFIBDataSet(Dataset).Params[i].Name);
if (_Par.ParamType in [daptOutput, daptInputOutput, daptResult]) then
_Par.Value := TFIBDataSet(Dataset).Params[i].Value;
end;
end;
initialization
_driver := nil;
RegisterDriverProc(GetDriverObject);
finalization
UnregisterDriverProc(GetDriverObject);
FreeAndNIL(_driver);
end.