unit uDAPGDACDriver;
{----------------------------------------------------------------------------}
{ Data Abstract Library - Driver Library                                     }
{                                                                            }
{ compiler: Delphi 6 and up, Kylix 3 and up                                  }
{ platform: Win32, Linux                                                     }
{                                                                            }
{ (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}
{$ELSE}
{$I ../DataAbstract.inc}
{$ENDIF}

{$R DataAbstract_PgDACDriver_Glyphs.res}
interface

uses
  DB, Classes,
  DBAccess, PgAccess, DASQLMonitor, PgSQLMonitor,
  uDAEngine, uDAInterfaces, uDAADOInterfaces, uROClasses,
  uROBinaryHelpers, uDAUtils, uDAPostgresInterfaces;

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

  { TDAEPgDACDriver }
  TDAEPgDACDriver = class(TDAPostgresDriver)
  private
    fMonitor: TPgSQLMonitor;
    fTraceCallBack: TDALogTraceEvent;
    procedure OnSDACTrace(Sender: TObject; Text: string; Flag: TDATraceFlag);
  protected
    function GetConnectionClass: TDAEConnectionClass; override;
    procedure DoSetTraceOptions(TraceActive: boolean; TraceOptions: TDATraceOptions; Callback: TDALogTraceEvent); override;
       // IDADriver
    function GetDriverID: string; override; safecall;
    function GetDescription: string; override; safecall;
    procedure GetAuxParams(const AuxDriver: string; out List: IROStrings); override;

  end;

     { TDAEMyConnection }
  TDAEPgDACConnection = class(TDAEPostgresConnection)
  private
    fConnection: TPgConnection;
  protected
    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;

     { TDAEPgDACQuery }
  TDAEPgDACQuery = class(TDAEDataset,IDAMustSetParams)
  private

  protected
    function CreateDataset(aConnection: TDAEConnection): TDataset; override;
    procedure ClearParams; override;
    function DoExecute: integer; override;{$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
    function DoGetSQL: string; override;{$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
    procedure DoSetSQL(const Value: string); override;{$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
    procedure DoPrepare(Value: boolean); override;{$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
    procedure SetParamValues(AParams: TDAParamCollection); override;{$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
    procedure GetParamValues(AParams: TDAParamCollection); override;{$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}

  public
  end;

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

    function GetStoredProcedureName: string; override;
    procedure SetStoredProcedureName(const Name: string); override;
    function DoExecute: integer; override;
    function Execute: integer; override;
    procedure RefreshParams; override; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}

       // IDAMustSetParams
    procedure SetParamValues(AParams: TDAParamCollection); override;{$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
    procedure GetParamValues(AParams: TDAParamCollection); override;{$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
  end;




procedure Register;

function GetDriverObject: IDADriver; stdcall;

implementation

uses
  SysUtils, Variants,TypInfo,
  uDADriverManager, uDARes;

var
  _driver: TDAEDriver = nil;

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

{$I uDACRLabsUtils.inc}


exports GetDriverObject name func_GetDriverObject;


{ TDAEPgDACDriver }

procedure TDAEPgDACDriver.DoSetTraceOptions(TraceActive: boolean;
  TraceOptions: TDATraceOptions; Callback: TDALogTraceEvent);
var
  sdacopts: TDATraceFlags;
begin
  inherited;
  if TraceActive then begin
    if (fMonitor = nil) then fMonitor := TPgSQLMonitor.Create(Self);

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

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

    fTraceCallBack := Callback;

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

procedure TDAEPgDACDriver.GetAuxParams(const AuxDriver: string;
  out List: IROStrings);
begin
  inherited;
  List.Add('Options.<Param>=<Value>');
  List.Add('PoolingOptions.<Param>=<Value>');
  List.Add('Port=5432');
  List.Add('SSLOptions.<Param>=<Value>');
  List.Add('');
  List.Add('Consult to PgDAC documentation about Options, PoolingOptions and SSLOptions options.');
end;

function TDAEPgDACDriver.GetConnectionClass: TDAEConnectionClass;
begin
  result := TDAEPgDacConnection;
end;

function TDAEPgDACDriver.GetDescription: string;
begin
  result := 'Devart''s PostgreSQL Data Access Components'{$IFDEF DataAbstract_SchemaModelerOnly} + SchemaModelerOnly{$ENDIF};
end;

function TDAEPgDACDriver.GetDriverID: string;
begin
  Result := 'PgDAC';
end;

procedure TDAEPgDACDriver.OnSDACTrace(Sender: TObject; Text: string;
  Flag: TDATraceFlag);
begin
  if Assigned(fTraceCallback) then fTraceCallback(Sender, Text, integer(Flag));
end;

{ TDAEPgDACConnection }

function TDAEPgDACConnection.CreateCustomConnection: TCustomConnection;
begin
  fConnection := TPgConnection.Create(nil);
  fConnection.LoginPrompt := FALSE;

  result := fConnection;
end;

procedure TDAEPgDACConnection.DoApplyConnectionString(
  aConnStrParser: TDAConnectionStringParser;
  aConnectionObject: TCustomConnection);
var
  i: integer;
  sName, sValue: string;
begin
  inherited;

  with aConnStrParser do begin
    fConnection.Database := Database;

    fConnection.Server := Server;

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

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

    for i := 0 to AuxParamsCount -1 do begin
      sName := AuxParamNames[i];
      sValue := AuxParams[sName];

      if Pos('options.', AnsiLowerCase(sName)) = 1 then begin
        sName := Copy(sName,9, Length(sName)-8);
        SetPropValue(fConnection.Options, sName, sValue);
      end
      else if Pos('poolingoptions.', AnsiLowerCase(sName)) = 1 then begin
        sName := Copy(sName,16, Length(sName)-15);
        SetPropValue(fConnection.PoolingOptions, sName, sValue);
      end
      else if AnsiSameStr(sName, 'PORT') then begin
        fConnection.Port := StrToIntDef(sValue,0);
      end
      else if Pos('ssloptions.', AnsiLowerCase(sName)) = 1 then begin
        sName := Copy(sName,12, Length(sName)-11);
        SetPropValue(fConnection.SSLOptions, sName, sValue);
      end;
    end;
  end;
end;

function TDAEPgDACConnection.DoBeginTransaction: integer;
begin
  fConnection.StartTransaction;
  result := 0;
end;

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

function TDAEPgDACConnection.DoGetInTransaction: boolean;
begin
  Result := fConnection.InTransaction;
end;

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


function TDAEPgDACConnection.GetDatasetClass: TDAEDatasetClass;
begin
  Result := TDAEPgDACQuery;
end;

function TDAEPgDACConnection.GetStoredProcedureClass: TDAEStoredProcedureClass;
begin
  Result := TDAEPgDACStoredProcedure;
end;

{ TDAEPgDACQuery }

procedure TDAEPgDACQuery.ClearParams;
begin
  inherited;
  TPgQuery(Dataset).Params.Clear;
end;

function TDAEPgDACQuery.CreateDataset(aConnection: TDAEConnection): TDataset;
begin
  result := TPgQuery.Create(nil);

  TPgQuery(result).FetchAll := True;  //for preventing creating an additional session when you call StartTransaction (an known issue of OLEDB)
  TPgQuery(result).Unidirectional := True;
  TPgQuery(result).ReadOnly := TRUE;
  TPgQuery(result).Connection := TDAEPgDACConnection(aConnection).fConnection;
end;

function TDAEPgDACQuery.DoExecute: integer;
begin
  TPgQuery(Dataset).Execute;
  result := TPgQuery(Dataset).RowsAffected;
end;

function TDAEPgDACQuery.DoGetSQL: string;
begin
  result := TPgQuery(Dataset).SQL.Text;
end;

procedure TDAEPgDACQuery.DoPrepare(Value: boolean);
var
  i: integer;
  par: TPgParam;
begin
  if Value and not TPgQuery(Dataset).Prepared and (TPgQuery(Dataset).ParamCount<>0) then begin
    for I := 0 to GetParams.Count - 1 do begin
      par:=TPgQuery(Dataset).ParamByName(GetParams[i].Name);
      par.DataType:= DATypeToVCLType(GetParams[i].DataType);
      if par.DataType = ftAutoInc then par.DataType:= ftInteger;
    end;
  end;
  TPgQuery(Dataset).Prepared := Value;
end;

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

procedure TDAEPgDACQuery.GetParamValues(AParams: TDAParamCollection);
var
  I: Integer;
  lParam: TPgParam;
begin
  for i := 0 to TPgQuery(DataSet).Params.Count - 1 do begin
    lParam:=TPgQuery(DataSet).Params[i];
    if (lParam.ParamType in [ptOutput, ptInputOutput, ptResult]) then
      Aparams.ParamByName(lParam.Name).Value := lParam.Value;
  end;
end;

procedure TDAEPgDACQuery.SetParamValues(AParams: TDAParamCollection);
begin
  WriteCrLabsParamValues(AParams, TPgQuery(Dataset).Params, true);
end;

{ TDAEPgDACStoredProcedure }

function TDAEPgDACStoredProcedure.CreateDataset(
  aConnection: TDAEConnection): TDataset;
begin
  result := TPgStoredProc.Create(nil);
  TPgStoredProc(result).Connection := TDAEPgDACConnection(aConnection).fConnection;
end;

function TDAEPgDACStoredProcedure.DoExecute: integer;
begin
  with TPgStoredProc(Dataset) do begin
    ExecProc;
    result := RowsAffected;
  end;
end;

function TDAEPgDACStoredProcedure.Execute: integer;
var
  i: integer;
  _params: TDAParamCollection;
  lParam: uDAInterfaces.TDAParam;
begin
  _params := GetParams;

  with TPgStoredProc(Dataset) do begin
    for i := 0 to (Params.Count - 1) do
      if (Params[i].ParamType in [ptInput, ptInputOutput]) then begin
        lParam := _params.ParamByName(Params[i].Name);
        if (Params[i].DataType in [ftMemo, ftBlob, ftGraphic]) and VarIsArray(lParam.Value)then
          Params[i].Value := VariantToAnsiString(lParam.Value)
        else
          Params[i].Value := lParam.Value;
      end;

    result := DoExecute;

    for i := 0 to (_params.Count-1) do
      if (_params[i].ParamType in [daptOutput, daptInputOutput, daptResult])
        then _params[i].Value := params.ParamByName(_params[i].Name).Value;
  end;
end;

procedure TDAEPgDACStoredProcedure.GetParamValues(AParams: TDAParamCollection);
var
  i: Integer;
  lParam: TPgParam;
begin
  for i := 0 to TPgStoredProc(DataSet).Params.Count - 1 do begin
    lParam:=TPgStoredProc(DataSet).Params[i];
    if (lParam.ParamType in [ptOutput, ptInputOutput, ptResult]) then
      Aparams.ParamByName(lParam.Name).Value := lParam.Value;
    end;
end;

function TDAEPgDACStoredProcedure.GetStoredProcedureName: string;
begin
  result := TPgStoredProc(Dataset).StoredProcName;
end;

procedure TDAEPgDACStoredProcedure.RefreshParams;
begin
  TPgStoredProc(Dataset).Prepare;
  RefreshParamsStd(TPgStoredProc(Dataset).Params);
end;

procedure TDAEPgDACStoredProcedure.SetParamValues(AParams: TDAParamCollection);
begin
  WriteCrLabsParamValues(AParams, TPgStoredProc(Dataset).Params);
end;

procedure TDAEPgDACStoredProcedure.SetStoredProcedureName(const Name: string);
begin
  TPgStoredProc(Dataset).StoredProcName := Name;
end;

initialization
  _driver := nil;
  RegisterDriverProc(GetDriverObject);

finalization
  UnregisterDriverProc(GetDriverObject);
  FreeAndNIL(_driver);
end.