unit Aurelius.Drivers.FireDacRtti;

{$I Aurelius.inc}

interface

uses
  SysUtils, Classes, DB, Variants, Rtti, Generics.Collections,
  Aurelius.Comp.Adapters,
  Aurelius.Drivers.Base,
  Aurelius.Drivers.Interfaces;

type
  TFireDacRttiResultSetAdapter = class(TDriverResultSetAdapter<TDataset>)
  end;

  TFireDacRttiStatementAdapter = class(TInterfacedObject, IDBStatement, IDBDatasetStatement)
  private
    FADQuery: TDataset;
    function GetDataset: TDataset;
  public
    constructor Create(ADQuery: TDataset);
    destructor Destroy; override;
    procedure SetSQLCommand(SQLCommand: string);
    procedure SetParams(Params: TEnumerable<TDBParam>);
    function Execute: Integer;
    function ExecuteQuery: IDBResultSet;
  end;

  TFireDacRttiConnectionAdapter = class(TDriverConnectionAdapter<TCustomConnection>, IDBConnection)
  strict private
    FRtti: TRttiContext;
  public
    procedure AfterConstruction; override;
    procedure BeforeDestruction; override;
  public
    procedure Connect;
    procedure Disconnect;
    function IsConnected: Boolean;
    function CreateStatement: IDBStatement;
    function BeginTransaction: IDBTransaction;
    function RetrieveSqlDialect: string; override;
  end;

  TFireDacRttiTransactionAdapter = class(TInterfacedObject, IDBTransaction)
  private
    FFDConnection: TCustomConnection;
  public
    constructor Create(FDConnection: TCustomConnection);
    procedure Commit;
    procedure Rollback;
  end;

implementation

{ TFireDacRttiStatementAdapter }

uses
  Bcl.Utils,
  Bcl.Rtti.Utils,
  Aurelius.Drivers.Exceptions;

constructor TFireDacRttiStatementAdapter.Create(ADQuery: TDataset);
begin
  FADQuery := ADQuery;
end;

destructor TFireDacRttiStatementAdapter.Destroy;
begin
  FreeObj(FADQuery);
  inherited;
end;

function TFireDacRttiStatementAdapter.Execute: Integer;
begin
  if FADQuery = nil then Exit(0);
  SafeInvoke(FADQuery, 'ExecSQL', []);
  Result := SafeGetProp(FADQuery, 'RowsAffected').AsInteger;
end;

function TFireDacRttiStatementAdapter.ExecuteQuery: IDBResultSet;
begin
  if FADQuery = nil then Exit;
  SafeInvoke(FADQuery, 'OpenOrExecute', []);
  Result := TFireDacRttiResultSetAdapter.Create(FADQuery);
  FADQuery := nil;
end;

function TFireDacRttiStatementAdapter.GetDataset: TDataset;
begin
  Result := FADQuery;
end;

procedure TFireDacRttiStatementAdapter.SetParams(Params: TEnumerable<TDBParam>);
var
  P: TDBParam;
  Parameter: TObject;
  I: Integer;
  FDParams: TCollection;
begin
  if FADQuery = nil then Exit;
  I := 0;
  for P in Params do
  begin
    FDParams := SafeGetProp(FADQuery, 'Params').AsType<TCollection>;
    if (P.ParamName = '') and (I < FDParams.Count) then
      Parameter := FDParams.Items[I]
    else
      Parameter := SafeInvoke(FADQuery, 'ParamByName', [P.ParamName]).AsObject;
    Inc(I);

    SafeSetProp(Parameter, 'DataType', TValue.From<TFieldType>(P.ParamType));
    SafeSetProp(Parameter, 'Value', TValue.From<Variant>(P.ParamValue));

    case SafeGetProp(Parameter, 'DataType').AsType<TFieldType> of
      ftFixedChar, ftFixedWideChar:
        begin
          // On Oracle, from Delphi Tokyo, leaving Size with 0 value will cause
          // an error of Data Too Large (500). Let's force the size here then
          if VarIsStr(SafeGetProp(Parameter, 'Value').AsType<Variant>) then
            SafeSetProp(Parameter, 'Size',
              Length(SafeGetProp(Parameter, 'Value').AsType<Variant>)
            );
        end;
    end;
  end;
end;

procedure TFireDacRttiStatementAdapter.SetSQLCommand(SQLCommand: string);
begin
  if FADQuery = nil then Exit;
  SafeGetProp(FADQuery, 'SQL').AsType<TStrings>.Text := SQLCommand;
end;

{ TFireDacRttiConnectionAdapter }

procedure TFireDacRttiConnectionAdapter.Disconnect;
begin
  if Connection <> nil then
    Connection.Connected := False;
end;

function TFireDacRttiConnectionAdapter.RetrieveSqlDialect: string;
begin
  if Connection = nil then
    Exit('');

  case SafeGetProp(Connection, 'RDBMSKind').AsInteger of
    2: //{$IFDEF DELPHIXE8_LVL}TFDRDBMSKinds.MSSQL{$ELSE}mkMSSQL{$ENDIF}:
      result := 'MSSQL';
    4: //{$IFDEF DELPHIXE8_LVL}TFDRDBMSKinds.MySQL{$ELSE}mkMySQL{$ENDIF}:
      result := 'MySQL';
    9: //{$IFDEF DELPHIXE8_LVL}TFDRDBMSKinds.Firebird{$ELSE}mkFirebird{$ENDIF}:
      result := 'Firebird';
    8: //{$IFDEF DELPHIXE8_LVL}TFDRDBMSKinds.Interbase{$ELSE}mkInterbase{$ENDIF}:
      result := 'Interbase';
    1: //{$IFDEF DELPHIXE8_LVL}TFDRDBMSKinds.Oracle{$ELSE}mkOracle{$ENDIF}:
      result := 'Oracle';
    10: //{$IFDEF DELPHIXE8_LVL}TFDRDBMSKinds.SQLite{$ELSE}mkSQLite{$ENDIF}:
      result := 'SQLite';
    11: //{$IFDEF DELPHIXE8_LVL}TFDRDBMSKinds.PostgreSQL{$ELSE}mkPostgreSQL{$ENDIF}:
      result := 'PostgreSQL';
    5: //{$IFDEF DELPHIXE8_LVL}TFDRDBMSKinds.DB2{$ELSE}mkDB2{$ENDIF}:
      result := 'DB2';
    7: //{$IFDEF DELPHIXE8_LVL}TFDRDBMSKinds.Advantage{$ELSE}mkADS{$ENDIF}:
      result := 'ADVANTAGE';
  else
    // for firebird, RDBMSKind is mkOther (bug in FireDac?)
    // Let's find by the driver id
    if SafeGetProp(Connection, 'DriverName').AsString = 'FB' then
      Result := 'Firebird'
    else
      result := '';
  end;
end;

function TFireDacRttiConnectionAdapter.IsConnected: Boolean;
begin
  if Connection <> nil then
    Result := Connection.Connected
  else
    Result := false;
end;

function TFireDacRttiConnectionAdapter.CreateStatement: IDBStatement;
var
  Statement: TDataset;
begin
  if Connection = nil then
    Exit(nil);

  Statement := TDatasetClass(SafeFindType(FRtti, 'FireDAC.Comp.Client.TFDQuery')
    .AsInstance.MetaclassType).Create(nil);
  try
    SafeSetProp(Statement, 'Connection', Connection);
    SafeSetProp(SafeGetProp(Statement, 'FetchOptions').AsObject, 'Unidirectional', True);
  except
    FreeObj(Statement);
    raise;
  end;
  Result := TFireDacRttiStatementAdapter.Create(Statement);
end;

procedure TFireDacRttiConnectionAdapter.Connect;
begin
  if Connection <> nil then
    Connection.Connected := True;
end;

procedure TFireDacRttiConnectionAdapter.AfterConstruction;
begin
  inherited;
  FRtti := TRttiContext.Create;
  if (Connection = nil) or not Connection.InheritsFrom(
    SafeFindType(FRtti, 'FireDAC.Comp.Client.TFDConnection').MetaclassType) then
    raise EAureliusDBException.Create('Could not create FireDac RTTI adapter. Connection is not a TFDConnection.');
end;

procedure TFireDacRttiConnectionAdapter.BeforeDestruction;
begin
  FRtti.Free;
  inherited;
end;

function TFireDacRttiConnectionAdapter.BeginTransaction: IDBTransaction;
begin
  if Connection = nil then
    Exit(nil);

  Connection.Connected := true;

  if not SafeGetProp(Connection, 'InTransaction').AsBoolean then
  begin
    SafeInvoke(Connection, 'StartTransaction', []);
    Result := TFireDacRttiTransactionAdapter.Create(Connection);
  end else
    Result := TFireDacRttiTransactionAdapter.Create(nil);
end;

{ TFireDacRttiTransactionAdapter }

procedure TFireDacRttiTransactionAdapter.Commit;
begin
  if (FFDConnection = nil) then
    Exit;

  SafeInvoke(FFDConnection, 'Commit', []);
end;

constructor TFireDacRttiTransactionAdapter.Create(FDConnection: TCustomConnection);
begin
  FFDConnection := FDConnection;
end;

procedure TFireDacRttiTransactionAdapter.Rollback;
begin
  if (FFDConnection = nil) then
    Exit;

  SafeInvoke(FFDConnection, 'Rollback', []);
end;

procedure RegisterDriverAdapter;
begin
  TAureliusAdapterRegister.Instance.RegisterDesignAdapterFactory('FireDac',
    function(Args: TAdapterFactoryArgs): IDBConnection
      begin
        Result := TFireDacRttiConnectionAdapter.Create(
          Args.AdaptedConnection as TCustomConnection, Args.SqlDialect, Args.Owner);
      end
  );
end;

initialization
  RegisterDriverAdapter;
end.
