Componentes.Terceros.RemObjects/official/5.0.23.613/Data Abstract for Delphi/Source/Drivers/uDAIBDACDriver.pas

unit uDAIBDACDriver;

{----------------------------------------------------------------------------}
{ 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.
{----------------------------------------------------------------------------}

{$I ..\DataAbstract.inc}

{$R DataAbstract_IBDACDriver_Glyphs.res}

interface

uses
  DB, Classes, uDAEngine, uDAInterfaces, uDAADOInterfaces, uROClasses,
  DBAccess, IBC, DASQLMonitor,
  IBCSQLMonitor, Variants, uDAUtils, uDAIBInterfaces;

type { TDAIBDACDriver }
  TDAIBDACDriver = class(TDADriverReference)
  end;

  { TDAEIBDACDriver }
  TDAEIBDACDriver = class(TDAIBDriver)
  private
    fMonitor: TIBCSQLMonitor;
    fTraceCallBack: TDALogTraceEvent;
    procedure OnIBDACTrace(Sender: TObject; Text: string; Flag: TDATraceFlag);
  protected
    function GetConnectionClass: TDAEConnectionClass; override;
    procedure DoSetTraceOptions(TraceActive: boolean; TraceOptions: TDATraceOptions; Callback: TDALogTraceEvent); override;
    procedure CustomizeConnectionObject(aConnection: TDAEConnection); override;
    // IDADriver
    function GetDriverID: string; override;
    function GetDescription: string; override;
  end;

  { TDAEIBDACConnection }
  TDAEIBDACConnection = class(TDAIBConnection, IDAInterbaseConnection, IDAIBTransactionAccess, IDAIBConnectionProperties, IDAUseGenerators, IDAFileBasedDatabase)
  private
    fConnection: TIBCConnection;
  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;
  end;

  { TDAEIBDACQuery }
  TDAEIBDACQuery = 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;

    // IDAMustSetParams
    procedure SetParamValues(Params: TDAParamCollection); safecall;
    procedure GetParamValues(Params: TDAParamCollection); safecall;

  public
  end;

  { TDAEIBDACStoredProcedure }
  TDAEIBDACStoredProcedure = class(TDAEStoredProcedure, IDAMustSetParams)
  protected
    function CreateDataset(aConnection: TDAEConnection): TDataset; override;

    function GetStoredProcedureName: string; override;
    procedure SetStoredProcedureName(const Name: string); override;
    function Execute: integer; override;
    procedure RefreshParams; override;    

    // IDAMustSetParams
    procedure GetParamValues(Params: TDAParamCollection); safecall;
    procedure SetParamValues(Params: TDAParamCollection); safecall;

  end;

procedure Register;

function GetDriverObject: IDADriver; stdcall;

implementation

uses
  SysUtils,
  uDADriverManager, uDARes,
  uROBinaryHelpers;

var
  _driver: TDAEDriver = nil;

procedure Register;
begin
  RegisterComponents(DAPalettePageName, [TDAIBDACDriver]);
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 := TDAEIBDACDriver.Create(nil);
  result := _driver;
end;

{$I uDACRLabsUtils.inc}

{ TDAEIBDACConnection }

procedure TDAEIBDACConnection.DoApplyConnectionString(
  aConnStrParser: TDAConnectionStringParser; aConnectionObject: TCustomConnection);
begin
  inherited;
  SetSQLDialect(3);
  with aConnStrParser do begin
    if (Self.UserID <> '') then
      fConnection.Username := Self.UserID
    else
      fConnection.Username := UserID;

    if (Self.Password <> '') then
      fConnection.Password := Self.Password
    else
      fConnection.Password := Password;

    if Server <> '' then
      fConnection.Database := Server + ':' + Database
    else
      fConnection.Database := Database;

    if AuxParams['Dialect'] <> '' then
      SetSQLDialect(StrToInt(AuxParams['Dialect']))
    else if AuxParams['SQLDialect'] <> '' then
      SetSQLDialect(StrToInt(AuxParams['SQLDialect']));

    if AuxParams['Role'] <> '' then SetRole(AuxParams['Role']);

    if AuxParams['Charset'] <> '' then SetCharset(AuxParams['Charset']);
  end;
end;

function TDAEIBDACConnection.DoBeginTransaction: integer;
begin
  result := -1;
  fConnection.StartTransaction;
end;

procedure TDAEIBDACConnection.DoCommitTransaction;
begin
  fConnection.Commit;
end;

function TDAEIBDACConnection.CreateCustomConnection: TCustomConnection;
begin
  fConnection := TIBCConnection.Create(nil);
  fConnection.LoginPrompt := FALSE;

  result := fConnection;
end;

function TDAEIBDACConnection.GetDatasetClass: TDAEDatasetClass;
begin
  result := TDAEIBDACQuery;
end;

function TDAEIBDACConnection.GetStoredProcedureClass: TDAEStoredProcedureClass;
begin
  result := TDAEIBDACStoredProcedure;
end;

(*function SqlServerToDAType(aType:integer):TDADataType;
begin
  case aType of
    34:result := datBlob;
    35:result := datMemo;
    36:result := datString; //uniqueidentifier
    48:result := datInteger;
    52:result := datInteger;
    56:result := datInteger;
    58:result := datDateTime;
    59:result := datFloat;
    60:result := datCurrency;
    61:result := datDateTime;
    62:result := datFloat;
    //98    sql_variant
    99:result := datMemo;//    ntext
    104:result := datBoolean;
    106:result := datFloat;
    108:result := datFloat;
    122:result := datCurrency;
    127:result := datInteger;
    165:result := datBlob; // varbinary
    167:result := datString;
    173:result := datBlob;   // binary
    175:result := datString; //   char
    189:result := datBlob;   //   timestamp
    231:result := datString; //  nvarchar
    239:result := datString; //nchar
    240:result := datDateTime;
    241:result := datBlob;//   xml
    else result := datUnknown;
  end;
end;

procedure TDAEIBDACConnection.DoGetStoredProcedureParams(const aStoredProcedureName: string; out Params: TDAParamCollection);
var
  ds : TIBCQuery;
  lID:string;
begin
  ds := TIBCQuery.Create(NIL);
  try

    ds.Connection := fConnection;
    ds.SQL.Text := 'select * from sysobjects where xtype=''P'' and name='''+aStoredProcedureName+'''';
    ds.Open;
    try
      if ds.EOF then RaiseError('Stored Procedure %s not found in database',[aStoredProcedureName]);
      lID := ds.FieldbyName('id').AsString;
    finally
      ds.Close();
    end;

    ds.SQL.Text := 'select * from sys.parameters where object_id='''+lID+''' ORDER BY parameter_id';
    ds.Open;
    try
      Params := TDAParamCollection.Create(nil);
      while not ds.Eof do begin
        with Params.Add() do begin
          Name := ds.FieldByName('name').AsString;

          DataType := SqlServerToDAType(ds.FieldByName('system_type_id').AsInteger);
          Size := ds.FieldByName('max_length').AsInteger;

          {if ds.FieldByName('has_default_value').AsBoolean then
            DefaultValue := ds.FieldByName('default_Value').AsInteger;}

          if ds.FieldByName('is_output').AsBoolean then
            ParamType := daptOutput
          else
            ParamType := daptInput;

        end;
        ds.Next();
      end;
    finally
      Close();
    end;

  finally
    ds.Free;
  end;
end;*)

procedure TDAEIBDACConnection.DoRollbackTransaction;
begin
  fConnection.Rollback;
end;

function TDAEIBDACConnection.DoGetInTransaction: boolean;
begin
  result := fConnection.InTransaction
end;

procedure TDAEIBDACConnection.Commit;
begin
  fConnection.Commit;
end;

procedure TDAEIBDACConnection.CommitRetaining;
begin
  fConnection.CommitRetaining;
end;

function TDAEIBDACConnection.GetCharset: string;
begin
  result := fConnection.Options.Charset;
end;

function TDAEIBDACConnection.GetRole: string;
begin
  Result := fConnection.Options.Role;
end;

function TDAEIBDACConnection.GetSQLDialect: integer;
begin
  Result := fConnection.SQLDialect;
end;

function TDAEIBDACConnection.GetTransaction: TObject;
begin
  Result := fConnection.DefaultTransaction;
end;

procedure TDAEIBDACConnection.Rollback;
begin
  fConnection.Rollback;
end;

procedure TDAEIBDACConnection.RollbackRetaining;
begin
  fConnection.RollbackRetaining;
end;

procedure TDAEIBDACConnection.SetCharset(const Value: string);
begin
  fConnection.Options.Charset := Value;
end;

procedure TDAEIBDACConnection.SetRole(const Value: string);
begin
  fConnection.Options.Role := Value;
end;

procedure TDAEIBDACConnection.SetSQLDialect(Value: integer);
begin
  fConnection.SQLDialect := Value;
end;

{ TDAEIBDACDriver }

function TDAEIBDACDriver.GetConnectionClass: TDAEConnectionClass;
begin
  result := TDAEIBDACConnection;
end;

function TDAEIBDACDriver.GetDescription: string;
begin
  result := 'Core Lab IBDAC Driver'{$IFDEF DataAbstract_SchemaModelerOnly} + SchemaModelerOnly{$ENDIF};
end;

function TDAEIBDACDriver.GetDriverID: string;
begin
  result := 'IBDAC';
end;

procedure TDAEIBDACDriver.OnIBDACTrace(Sender: TObject; Text: string; Flag: TDATraceFlag);
begin
  inherited;
  //  if Assigned(fTraceCallback) then fTraceCallback(Sender, Text, integer(Flag));
end;

procedure TDAEIBDACDriver.DoSetTraceOptions(TraceActive: boolean; TraceOptions: TDATraceOptions; Callback: TDALogTraceEvent);
var
  IBDACopts: TDATraceFlags;
begin
  inherited;
  exit;
  if TraceActive then begin
    if (fMonitor = nil) then fMonitor := TIBCSQLMonitor.Create(Self);

    fMonitor.Active := FALSE;
    fMonitor.OnSQL := OnIBDACTrace;

    IBDACopts := [];
    if (toPrepare in TraceOptions) then IBDACopts := IBDACopts + [tfQPrepare];
    if (toExecute in TraceOptions) then IBDACopts := IBDACopts + [tfQExecute];
    if (toFetch in TraceOptions) then IBDACopts := IBDACopts + [tfQFetch];
    if (toError in TraceOptions) then IBDACopts := IBDACopts + [tfError];
    if (toStmt in TraceOptions) then IBDACopts := IBDACopts + [tfStmt];
    if (toConnect in TraceOptions) then IBDACopts := IBDACopts + [tfConnect];
    if (toTransact in TraceOptions) then IBDACopts := IBDACopts + [tfTransact];
    if (toBlob in TraceOptions) then IBDACopts := IBDACopts + [tfBlob];
    if (toService in TraceOptions) then IBDACopts := IBDACopts + [tfService];
    if (toMisc in TraceOptions) then IBDACopts := IBDACopts + [tfMisc];
    if (toParams in TraceOptions) then IBDACopts := IBDACopts + [tfParams];

    fTraceCallBack := Callback;

    fMonitor.TraceFlags := IBDACopts;
    fMonitor.Active := TRUE;
  end
  else begin
    FreeAndNIL(fMonitor);
    fTraceCallback := nil;
  end;
end;

procedure TDAEIBDACDriver.CustomizeConnectionObject(
  aConnection: TDAEConnection);
begin
  //
end;

{ TDAEIBDACQuery }

function TDAEIBDACQuery.CreateDataset(aConnection: TDAEConnection): TDataset;
begin
  result := TIBCQuery.Create(nil);
  TIBCQuery(result).FetchAll := True;  //for preventing creating an additional session when you call StartTransaction (an known issue of OLEDB)
  TIBCQuery(result).Unidirectional := True;
  TIBCQuery(result).ReadOnly := TRUE;
  TIBCQuery(result).Connection := TDAEIBDACConnection(aConnection).fConnection;
end;

function TDAEIBDACQuery.DoExecute: integer;
begin
  inherited DoExecute;
  result := TIBCQuery(Dataset).RowsAffected;
end;

function TDAEIBDACQuery.DoGetRecordCount: integer;
begin
  Result := TIBCQuery(Dataset).RecordCount;
end;

function TDAEIBDACQuery.DoGetSQL: string;
begin
  result := TIBCQuery(Dataset).SQL.Text;
end;

procedure TDAEIBDACQuery.DoPrepare(Value: boolean);
begin
  TIBCQuery(Dataset).Prepared := Value;
end;

procedure TDAEIBDACQuery.DoSetSQL(const Value: string);
begin
  TIBCQuery(Dataset).SQL.Text := Value;
end;

procedure TDAEIBDACQuery.GetParamValues(Params: TDAParamCollection);
var
  I: Integer;
begin
  for i := 0 to TIBCQuery(DataSet).Params.Count - 1 do
    if (TIBCQuery(DataSet).Params[i].ParamType in [ptOutput, ptInputOutput, ptResult]) then params[i].Value := TIBCQuery(DataSet).Params[i].Value;
end;

procedure TDAEIBDACQuery.SetParamValues(Params: TDAParamCollection);
begin
  WriteCrLabsParamValues(Params, TIBCQuery(Dataset).Params, true);
end;

{ TDAEIBDACStoredProcedure }

function TDAEIBDACStoredProcedure.CreateDataset(
  aConnection: TDAEConnection): TDataset;
begin
  result := TIBCStoredProc.Create(nil);
  TIBCStoredProc(result).Connection := TDAEIBDACConnection(aConnection).fConnection;
end;

function TDAEIBDACStoredProcedure.Execute: integer;
begin
  TIBCStoredProc(Dataset).Prepare;
  SetParamValues(GetParams);
  TIBCStoredProc(Dataset).ExecProc;
  result := TIBCStoredProc(Dataset).RowsAffected;
  GetParamValues(GetParams);
end;


procedure TDAEIBDACStoredProcedure.GetParamValues(Params: TDAParamCollection);
var
  i: Integer;
begin
  for i := 0 to TIBCStoredProc(DataSet).Params.Count - 1 do
    if (TIBCStoredProc(DataSet).Params[i].ParamType in [ptOutput, ptInputOutput, ptResult]) then
      params[i].Value := TIBCStoredProc(DataSet).Params[i].Value;
end;

function TDAEIBDACStoredProcedure.GetStoredProcedureName: string;
begin
  result := TIBCStoredProc(Dataset).StoredProcName;
end;

procedure TDAEIBDACStoredProcedure.SetStoredProcedureName(
  const Name: string);
begin
  TIBCStoredProc(Dataset).StoredProcName := Name;
end;

procedure TDAEIBDACStoredProcedure.RefreshParams; 
begin
  TIBCStoredProc(Dataset).Prepare;
  inherited;
end;

procedure TDAEIBDACStoredProcedure.SetParamValues(Params: TDAParamCollection);
begin
  WriteCrLabsParamValues(Params, TIBCStoredProc(Dataset).Params);
end;

exports
  GetDriverObject name func_GetDriverObject;

initialization
  _driver := nil;
  RegisterDriverProc(GetDriverObject);

finalization
  UnregisterDriverProc(GetDriverObject);
  FreeAndNIL(_driver);

end.