mORMot2 IBX/FB Pascal API Connection

mormot.db.sql.ibx.pas

/// Database Framework IBX/FB Pascal API Connection
// - this unit is a part of the Open Source Synopse mORMot framework 2,
// licensed under a MPL/GPL/LGPL three license - see LICENSE.md
unit mormot.db.sql.ibx;

{
  *****************************************************************************

   Efficient FirebirdSQL Database Connection using the FB Pascal API layer
   part of IBX2 Firebird database library

  *****************************************************************************

  Inspired by transaction handling of ZeosLib and Firebird
  more details on https://synopse.info/forum/viewtopic.php?pid=14086#p14086
  and goal to have zero started transaction on Firebird server when nobody is connected
  I create this mORMot2 database connection for FirebirdSQL.

  For low level connection I use MWA Software Firebird Pascal API package (fbintf),
  part of IBX for Lazarus.
  More details on https://www.mwasoftware.co.uk/fb-pascal-api

  - With explicit StartTransaction (Batch) all statements in connection
    is executed with this main transaction owned by connection.
  - If no explicit StartTransaction is called, all statements create internal transaction
    on prepare and COMMIT after execution or Eof or ReleseRows. This is sotware simulated auto commit.
    This internal transaction is owned by Statement.
  - TSqlDBIbxConnectionProperties.CreateDescendingPK if set to True (Default is False)
    will create only one descending PK index using statement
      PRIMARY KEY(ID) using desc index PK_TableName
    default dFirebird create two indexes on ID, one ascending, second descending
    nedded for select max(ID)
    see http://www.firebirdfaq.org/faq205

    @ab
    This future need some change in mormot.orm.sql.pas at line 1883
    For testing in my code i now have this impovisation, I change fEngineName when set this property :-)
      dFirebird:
        // see http://www.firebirdfaq.org/faq205
        if fProperties.Engine='IBX1' then
        begin
          result := true;
          exit;
        end
        else
          Descending := true;

  - Batch implemented for insert,update,delete using execute block
  - ToDo Firebird4 API interface have new IBatch interface for insert/update
    also implemented in fbintf package.
  - You must patch FB30Statement.pas and FB25Statement.pas of fbintf, I'm waiting
    for response of MWA Software. fbintf raise exception if Execute is executed
    with different transaction then Prepare transaction.
    Just comment this lines in InternalExecute and InternalOpenCursor and rebuild package.
    more details on https://forum.lazarus.freepascal.org/index.php/topic,56267.0.html

}

interface

// simulate transaction management like ZeosLib, just for testing
// Zeos don't commit read (select) statements and transaction is open for long period of time
// Only CommitRetaining transaction with write (insert, update, delete) statements
// This define is only for testing and compare performance with ZeosLib
{.$define ZeosTrans}

{$I mormot.defines.inc}

uses
  types,
  sysutils,
  classes,
  variants,
  // main IBX/FB Pascal API units
  IB,
  // mORMot units
  mormot.core.base,
  mormot.core.os,
  mormot.core.unicode,
  mormot.core.text,
  mormot.core.json,
  mormot.core.datetime,
  mormot.core.data,
  mormot.core.perf,
  mormot.core.rtti,
  mormot.core.log,
  mormot.db.core,
  mormot.db.sql;

type
  /// Exception type associated to the IBX/FB Pascal API database components
  ESqlDBIbx = class(ESqlDBException);

  /// implement properties shared by IBX/FB Pascal API connections

  { TSqlDBIbxConnectionProperties }

  TSqlDBIbxConnectionProperties = class(TSqlDBConnectionPropertiesThreadSafe)
  private
    fCreateDescendingPK: boolean;
    fFirebirdLibraryPathName: string;
    fIbxDBParams: TStringList;
    fCreateIfNotExists: boolean;
    procedure SetCreateDescendingPK(AValue: boolean);
  protected
    function IbxSQLTypeToTSqlDBFieldType(aColMeta: IColumnMetaData): TSqlDBFieldType;
    // Override to enable descending PK
    function SqlFieldCreate(const aField: TSqlDBColumnCreate;
      var aAddPrimaryKey: RawUtf8): RawUtf8; override;
  public
    /// initialize the properties to connect to the IBX/FB Pascal API engine
    // - aServerName shall contain the Firebird server and port URI, e.g:
    // HOST[:PORT], empty for embbeded firebird will set ThreadingMode to tmMainConnection
    // - aDatabaseName, aUserID, aPassword
    // - note that when run from mORMot's ORM, this class will by default
    // create one connection per thread
    constructor Create(const aServerName, aDatabaseName,
      aUserID, aPassWord: RawUtf8); override;
    destructor Destroy; override;
    /// create a new connection
    // - caller is responsible of freeing this instance
    // - this overridden method will create an TSqlDBIbxConnection instance
    function NewConnection: TSqlDBConnection; override;
    // Override to enable descending PK
    function SqlCreate(const aTableName: RawUtf8;
      const aFields: TSqlDBColumnCreateDynArray; aAddID: boolean): RawUtf8; override;
  published
    // Full file path name to firebird client dll (fbclient.dll), default ''
    property FirebirdLibraryPathName: RawUtf8 read fFirebirdLibraryPathName write fFirebirdLibraryPathName;
    // You can add additional DB Params, see documentation in IBX/FB Pascal API
    property IbxDBParams: TStringList read fIbxDBParams;
    // Create database file if not exists, default is True
    property CreateIfNotExists: boolean read fCreateIfNotExists;
    // All firebird mormot drivers create ascending PK index on ID and another descending index on ID
    // see http://www.firebirdfaq.org/faq205
    // Having two indexes on same column slow down any insert, updata, delete
    // Setting CreateDescendingPK := True driver will create only one descending PK index
    // using statement
    //  PRIMARY KEY(ID) using desc index PK_TableName
    property CreateDescendingPK: boolean read fCreateDescendingPK write SetCreateDescendingPK;
  end;

  /// implements a connection via the IBX/FB Pascal API access layer
  TSqlDBIbxConnection = class(TSqlDBConnectionThreadSafe)
  private
    function GetFirebirdAPI: IFirebirdAPI;
  protected
    fFbLibraryPathName: string;
    fDBParams: TStringList;
    fCreateDBIfNotExists: boolean;
    fDBName: string;
    fFirebirdAPI: IFirebirdAPI;
    fAttachment: IAttachment;
    // Main Transaction used with Begin(Start)Transaction/Batch
    fTPB: ITPB;
    fTransaction: ITransaction;
    function GenerateTPB: ITPB;
  public
    /// prepare a connection to a specified Firebird database server
    constructor Create(aProperties: TSqlDBConnectionProperties); override;
    destructor Destroy; override;
    /// connect to the specified Firebird server
    // - should raise an ESqlDBIbx on error
    procedure Connect; override;
    /// stop connection to the specified Firebird database server
    // - should raise an ESqlDBIbx 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 IBX/FB Pascal API connection instance
    property Attachment:  IAttachment  read fAttachment;
    property FirebirdAPI: IFirebirdAPI read GetFirebirdAPI;
    // Main Transaction used with Begin(Start)Transaction/Batch
    property Transaction: ITransaction read fTransaction;
  end;

  /// implements a statement via a IBX/FB Pascal API database connection

  { TSqlDBIbxStatement }

  TSqlDBIbxStatement = class(TSqlDBStatementWithParamsAndColumns)
  protected
    fAutoStartCommitTrans: boolean;
    fStatement: IStatement;
    fResultSet: IResultSet;
    fResults: IResults;
    // Internal Transaction used for all statements if not explicit StartTransaction/Batch
    // This transaction is Started and COMMIT after execution (auto commit)
    fInternalTPB: ITPB;
    fInternalTransaction: ITransaction;
    procedure InternalStartTransaction;
    procedure InternalCommitTransaction;
  public
    destructor Destroy; override;
    /// 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 ESqlDBIbx on any error
    procedure Prepare(const aSQL: RawUtf8;
      ExpectResults: boolean = false); overload; override;
    /// Execute a prepared SQL statement
    // - parameters marked as ? should have been already bound with Bind*() functions
    // - this implementation will also handle bound array of values (if any)
    // - this overridden method will log the SQL statement if sllSQL has been
    // enabled in SynDBLog.Family.Level
    // - raise an ESqlDBIbx on any error
    procedure ExecutePrepared; override;
    /// gets a number of updates made by latest executed statement
    function UpdateCount: integer; override;
    /// Reset the previous prepared statement
    // - this overridden implementation will reset all bindings and the cursor state
    // - raise an ESqlDBIbx on any error
    procedure Reset; override;

    /// Access the next or first row of data from the SQL Statement result
    // - return true on success, with data ready to be retrieved by Column*() methods
    // - return false if no more row is available (e.g. if the SQL statement
    // is not a SELECT but an UPDATE or INSERT command)
    // - if SeekFirst is TRUE, will put the cursor on the first row of results
    // - raise an ESqlDBIbx on any error
    function Step(SeekFirst: boolean = false): boolean; override;
    /// free IResultSet/IResultSetMetaData when ISqlDBStatement is back in cache
    procedure ReleaseRows; override;
    /// return a Column integer value of the current Row, first Col is 0
    function ColumnInt(Col: integer): Int64; override;
    /// returns TRUE if the column contains NULL
    function ColumnNull(Col: integer): boolean; override;
    /// return a Column floating point value of the current Row, first Col is 0
    function ColumnDouble(Col: integer): double; override;
    /// return a Column date and time value of the current Row, first Col is 0
    function ColumnDateTime(Col: integer): TDateTime; override;
    /// return a Column currency value of the current Row, first Col is 0
    function ColumnCurrency(Col: integer): currency; override;
    /// return a Column UTF-8 encoded text value of the current Row, first Col is 0
    function ColumnUtf8(Col: integer): RawUtf8; override;
    /// return a Column as a blob value of the current Row, first Col is 0
    function ColumnBlob(Col: integer): RawByteString; override;
  end;

implementation

uses IBErrorCodes;

{ TSqlDBIbxStatement }

procedure TSqlDBIbxStatement.InternalStartTransaction;
begin
  {$ifndef ZeosTrans}
  if (fInternalTransaction <> nil) and  fInternalTransaction.InTransaction then
     raise ESqlDBIbx.CreateUtf8('Invalid Internal %.StartTransaction: ' +
    'Transaction is Started/InTransactions', [self]);
  {$endif}
  if fInternalTransaction <> nil then
  {$ifdef ZeosTrans}
  begin
    if not fInternalTransaction.InTransaction then
      fInternalTransaction.Start(TACommit)
  end
  {$else}
    fInternalTransaction.Start(TACommit)
  {$endif}
  else
  begin
    if (fInternalTPB = nil) then
       fInternalTPB := TSqlDBIbxConnection(Connection).GenerateTPB;
    fInternalTransaction :=  TSqlDBIbxConnection(Connection).Attachment.StartTransaction(fInternalTPB, TACommit);
  end;
end;

procedure TSqlDBIbxStatement.InternalCommitTransaction;
begin
  if (fInternalTransaction <> nil) and fInternalTransaction.InTransaction then
  {$ifdef ZeosTrans}
    if fStatement.GetSQLStatementType in [SQLInsert,
                  SQLUpdate, SQLDelete, SQLDDL,
                  SQLSelectForUpdate, SQLSetGenerator] then
  {$endif}
    fInternalTransaction.Commit;
end;

destructor TSqlDBIbxStatement.Destroy;
begin
  InternalCommitTransaction;
  if fResults <> nil then
    fResults.SetRetainInterfaces(false);
  if fResultSet <> nil then
    fResultSet.SetRetainInterfaces(false);
  fResultSet := nil;
  fResults := nil;
  if fStatement <> nil then
    fStatement.SetRetainInterfaces(false);
  fStatement := nil;
  fInternalTransaction := nil;
  fInternalTPB := nil;
  inherited Destroy;
end;

procedure TSqlDBIbxStatement.Prepare(const aSQL: RawUtf8; ExpectResults: boolean);
var
  con: TSqlDBIbxConnection;
  tr: ITransaction;
begin
  SQLLogBegin(sllDB);
  if (fStatement <> nil) or
     (fResultSet <> nil) then
    raise ESqlDBIbx.CreateUtf8('%.Prepare() shall be called once', [self]);
  inherited Prepare(aSQL, ExpectResults); // connect if necessary
  con := (fConnection as TSqlDBIbxConnection);
  if not con.IsConnected then
    con.Connect;
  if (con.Transaction=nil) or
     (not con.Transaction.GetInTransaction) then
  begin
    fAutoStartCommitTrans := True;
    InternalStartTransaction;
    tr := fInternalTransaction;
  end
  else
  begin
    fAutoStartCommitTrans := False;
    tr := con.Transaction;
  end;
  fStatement := con.Attachment.Prepare(
    tr,
    {$ifdef UNICODE}Utf8ToString(fSQL){$else}fSQL{$endif});
  SQLLogEnd;
end;

procedure TSqlDBIbxStatement.ExecutePrepared;
var
  con: TSqlDBIbxConnection;
  iParams: ISQLParams;
  iParam : ISQLParam;
  iMeta: IMetaData;
  iColMeta: IColumnMetaData;
  i, n: integer;
  name: string;
  Props: TSqlDBIbxConnectionProperties;

  function DynRawUtf8ArrayToConst(const aValue: TRawUtf8DynArray): TTVarRecDynArray;
  var ndx: PtrInt;
  begin
    SetLength(Result, Length(aValue));
    for ndx := 0 to Length(aValue) - 1 do
    begin
      Result[ndx].VType := vtAnsiString;
      Result[ndx].VAnsiString := @aValue[ndx][1];
    end;
  end;

  function Param2Type(aParam: ISQLParam): RawUtf8;
  begin
    case aParam.GetSQLType of
      SQL_VARYING, SQL_TEXT:
         result := FormatUtf8('VARCHAR(%)', [aParam.GetSize]);
      SQL_DOUBLE, SQL_D_FLOAT:
         result := 'DOUBLE PRECISION';
      SQL_FLOAT:
         result := 'FLOAT';
      SQL_LONG:
        if aParam.getScale = 0 then
          result := 'INTEGER'
        else begin
          if aParam.getSubtype = 1 then
            result := FormatUtf8('NUMERIC(9,%)', [aParam.getScale])
          else
            result := FormatUtf8('DECIMAL(9,%)', [aParam.getScale]);
        end;
      SQL_SHORT:
        if aParam.getScale = 0 then
          result := 'SMALLINT'
        else begin
          if aParam.getSubtype = 1 then
            result := FormatUtf8('NUMERIC(4,%)', [aParam.getScale])
          else
            result := FormatUtf8('DECIMAL(4,%)', [aParam.getScale]);
        end;
      SQL_TIMESTAMP:
         result := 'TIMESTAMP';
      SQL_BLOB:
        if aParam.getSubtype = isc_blob_text then
          result := 'BLOB SUB_TYPE TEXT'
        else
          result := 'BLOB';
      //SQL_ARRAY                      = 540;
      //SQL_QUAD                       = 550;
      SQL_TYPE_TIME:
         result := 'TIME';
      SQL_TYPE_DATE:
         result := 'DATE';
      SQL_INT64: // IB7
        if aParam.getScale = 0 then
          result := 'BIGINT'
        else begin
          if aParam.getSubtype = 1 then
            result := FormatUtf8('NUMERIC(18,%)', [aParam.getScale])
          else
            result := FormatUtf8('DECIMAL(18,%)', [aParam.getScale]);
        end;
      SQL_BOOLEAN:
         result := 'BOOLEAN';
      SQL_NULL{FB25}:
         result := 'CHAR(1)';
    end;
  end;

  procedure BlockArrayExecute;
  const cMaxStm = 100;  // max statements in execute block, FB max is 255
  var oldSQL: RawUTF8;
      aPar: TRawUtf8DynArray = [];
      aParTyp: TRawUtf8DynArray = [];
      iP, iA, iStart, iEnd, iCnt, iStmCount: integer;
      W: TTextWriter;
      newStatement: IStatement;

      function Min(a, b: PtrInt): PtrInt; {$ifdef HASINLINE}inline;{$endif}
      begin
        if a < b then
          result := a
        else
          result := b;
      end;

      procedure PrepareBlockStatement;
      begin
        // New Statemnt
        newStatement := con.Attachment.Prepare(
          fStatement.GetTransaction,
          {$ifdef UNICODE}Utf8ToString(W.Text){$else}W.Text{$endif});
      end;

      procedure ExecuteBlockStatement;
      var iP, iA, ndx: integer;
      begin
        // Bind Params
        iParams := newStatement.GetSQLParams;
        if iParams.Count<>fParamCount*(iEnd-iStart+1) then
          raise ESqlDBIbx.CreateUtf8('%.ExecutePrepared expected % bound parameters, got %',
                [self, iParams.Count, fParamCount*(iEnd-iStart+1)]);
        for iP := 0 to fParamCount - 1 do
        begin
          if fParams[iP].VInt64 <> fParamsArrayCount then
            raise ESqlDBIbx.CreateUtf8(
              '%.ExecutePrepared: #% parameter expected array count %, got %',
              [self, iP, fParamsArrayCount, fParams[iP].VInt64]);
          with fParams[iP] do
          begin
            case VType of
              ftUnknown:
                raise ESqlDBIbx.CreateUtf8(
                  '%.ExecutePrepared: Unknown type array parameter #%',
                  [self, iP]);
              ftNull:
                // handle null column
                for iA := 0 to iEnd-iStart do
                  iParams.Params[iA*fParamCount + iP].SetIsNull(true);
            else
              for iA := 0 to iEnd-iStart do
              begin
                iParam := iParams.Params[iA*fParamCount + iP];
                ndx := iA + iStart;
                if VArray[ndx] = 'null' then
                  iParam.SetIsNull(true)
                else
                begin
                  case VType of
                    ftDate:
                      iParam.AsDateTime:=Iso8601ToDateTimePUtf8Char(
                        PUtf8Char(pointer(VArray[ndx])) + 1, Length(VArray[ndx]) - 2);
                    ftInt64:
                      iParam.AsInt64 := GetInt64(pointer(VArray[ndx]));
                    ftDouble:
                      iParam.AsDouble := GetExtended(pointer(VArray[ndx]));
                    ftCurrency:
                      iParam.AsCurrency := StrToCurrency(pointer(VArray[ndx]));
                    ftUtf8:
                      iParam.AsString := UnQuoteSqlString(VArray[ndx]);
                    ftBlob:
                      iParam.AsString:=VData[ndx];
                    else
                      raise ESqlDBIbx.CreateUtf8(
                        '%.ExecutePrepared: Invalid type parameter #%', [self, ndx]);
                end;
              end;
              end;
            end;
          end;
        end;
        // 4. Execute
        newStatement.Execute;
      end;

  begin
    // 1. Create execute block SQL
    oldSQL := StringReplaceAll(fSql, '?', '%');
    SetLength(aParTyp, fParamCount);
    SetLength(aPar, fParamCount);
    for iP:=0 to fParamCount-1 do
      aParTyp[iP] := Param2Type(iParams.Params[iP]);
    iStart := 0;
    iStmCount := Round(fParamsArrayCount / round( fParamsArrayCount / cMaxStm + 0.5));
    W := TTextWriter.CreateOwnedStream(49152);
    try
      while iStart<fParamsArrayCount do
      begin
        iEnd := min(iStart+iStmCount-1, fParamsArrayCount-1);
        if (iStart=0) or
           (iEnd-iStart+1<>iStmCount) then
        begin
          iStmCount := iEnd - iStart + 1;
          W.CancelAll;
          W.AddShort('execute block('#10);
          iCnt := 0;
          for iA:=iStart to iEnd do
            for iP:=0 to fParamCount-1 do
            begin
              W.Add('p');
              W.AddU(iCnt);
              W.Add(' ');
              W.AddString(aParTyp[iP]);
              W.Add('=','?');
              W.AddComma;
              Inc(iCnt);
            end;
          W.CancelLastComma;
          W.AddShort(') as begin'#10);
          iCnt := 0;
          for iA:=iStart to iEnd do
          begin
            for iP:=0 to fParamCount-1 do
            begin
              aPar[iP] := FormatUtf8(':p%', [iCnt]);
              Inc(iCnt);
            end;
            W.Add(oldSQL, DynRawUtf8ArrayToConst(aPar));
            W.Add(';', #10);
          end;
          W.AddShort('end');

          PrepareBlockStatement;
        end;
        ExecuteBlockStatement;
        Inc(iStart, iStmCount);
      end;
    finally
      W.Free;
    end;
  end;
begin
  SQLLogBegin(sllSQL);
  inherited ExecutePrepared;
  if fStatement = nil then
    raise ESqlDBIbx.CreateUtf8('%.ExecutePrepared() invalid call', [self]);

  con := (fConnection as TSqlDBIbxConnection);
  fAutoStartCommitTrans := (con.fTransaction=nil) or (not con.fTransaction.GetInTransaction);
  if fAutoStartCommitTrans and
     ((fInternalTransaction=nil) or
      not (fInternalTransaction.GetInTransaction)) then
  begin
    InternalStartTransaction;
    if not fStatement.IsPrepared then
      fStatement.Prepare(fInternalTransaction);
  end;
  iParams := fStatement.GetSQLParams;
  if fParamsArrayCount > 0 then      // Array Bindings
  begin
    if iParams.Count<>fParamCount then
      raise ESqlDBIbx.CreateUtf8('%.ExecutePrepared expected % bound parameters, got %',
            [self, iParams.Count, fParamCount]);
    if fExpectResults then
      raise ESqlDBIbx.CreateUtf8('%.ExecutePrepared cant ExpextResults with ArrayParams', []);
    BlockArrayExecute;
  end
  else
  begin
    if iParams.Count<>fParamCount then
      raise ESqlDBIbx.CreateUtf8('%.ExecutePrepared expected % bound parameters, got %',
            [self, iParams.Count, fParamCount]);

    for i := 0 to fParamCount - 1 do // set parameters as expected by FirebirdSQL
    begin
      iParam := iParams.Params[i];
      with fParams[i] do
      begin
        case VType of
          ftUnknown,ftNull:
            begin
              iParam.IsNull:=True;
            end;
          ftDate:
            begin
              iParam.AsDateTime:=PDateTime(@VInt64)^;
            end;
          ftInt64:
            begin
              iParam.AsInt64:=PInt64(@VInt64)^;
            end;
          ftDouble:
            begin
              iParam.AsDouble:=unaligned(PDouble(@VInt64)^);
            end;
          ftCurrency:
            begin
              iParam.AsCurrency:=PCurrency(@VInt64)^;
            end;
          ftUtf8:
            begin
              iParam.AsString:=VData;
            end;
          ftBlob:
            begin
              iParam.AsString:=VData;
            end;
          else
            raise ESqlDBIbx.CreateUtf8(
              '%.ExecutePrepared: Invalid type parameter #%', [self, i]);
        end;
      end;
    end;
    if fExpectResults then
    begin
      fColumnCount := 0;
      fColumn.ReHash;
      fCurrentRow := -1;

      if fAutoStartCommitTrans then
        fResultSet := fStatement.OpenCursor(fInternalTransaction)
      else
        fResultSet := fStatement.OpenCursor(con.fTransaction);
      fResults := fResultSet;
      fResultSet.SetRetainInterfaces(true);
      fResults.SetRetainInterfaces(true);
      if not fResultSet.IsEof then
        fCurrentRow:=0;

      if fResultSet = nil then
      begin
        SynDBLog.Add.Log(sllWarning,'Ibx.ExecutePrepared returned nil %',
          [fSQL], self);
      end
      else
      begin
        Props := fConnection.Properties as TSqlDBIbxConnectionProperties;
        iMeta := fStatement.GetMetaData;
        n := iMeta.getCount;
        fColumn.Capacity := n;
        for i := 0 to n - 1 do
        begin
          iColMeta := iMeta.getColumnMetaData(i);
          name := iColMeta.getName;
          PSqlDBColumnProperty(fColumn.AddAndMakeUniqueName(
            // Delphi<2009: already UTF-8 encoded due to controls_cp=CP_UTF8
            {$ifdef UNICODE}StringToUtf8{$endif}(name)))^.ColumnType :=
              Props.IbxSQLTypeToTSqlDBFieldType(iColMeta);
        end;
      end;
    end else
    begin
      if fAutoStartCommitTrans then
      begin
        fResults := fStatement.Execute(fInternalTransaction);
        InternalCommitTransaction;
      end
      else
        fResults := fStatement.Execute(con.fTransaction);
    end;
  end;
  SQLLogEnd;
end;

function TSqlDBIbxStatement.UpdateCount: integer;
var
  s: integer = 0;
  i: integer = 0;
  u: integer = 0;
  d: integer = 0;
begin
  result := 0;
  if fStatement <> nil then
    if fStatement.GetRowsAffected(s, i, u, d) then
      result := i + u + d;
end;

procedure TSqlDBIbxStatement.Reset;
begin
  InternalCommitTransaction;
  inherited Reset;
end;

function TSqlDBIbxStatement.Step(SeekFirst: boolean): boolean;
begin
  if fColumnCount = 0 then // no row returned
    result := false
  else if fResultSet = nil then
    raise ESqlDBIbx.CreateUtf8('%.Step() invalid self', [self])
  else if SeekFirst then
  begin
    result := fResultSet.FetchNext;
    if result then
      fCurrentRow := 1
    else
    begin
      fCurrentRow := 0;
      InternalCommitTransaction;
    end;
  end
  else
  begin
    result := fResultSet.FetchNext;
    if result then
      inc(fCurrentRow)
    else
      InternalCommitTransaction;
  end;
  if not result then
    fResultSet.Close;
end;

procedure TSqlDBIbxStatement.ReleaseRows;
begin
  InternalCommitTransaction;
  if fResultSet<>nil then
  begin
    fResultSet.SetRetainInterfaces(false);
    fResultSet.Close;
    fResultSet := nil;
  end;
  if fResults<>nil then
  begin
    fResults.SetRetainInterfaces(false);
    fResults := nil;
  end;
  inherited ReleaseRows;
end;

function TSqlDBIbxStatement.ColumnInt(Col: integer): Int64;
begin
  if (fResultSet = nil) or
     (cardinal(Col) >= cardinal(fColumnCount)) then
    raise ESqlDBIbx.CreateUtf8('%.ColumnInt(%) ResultSet=%',
      [self, Col, fResultSet]);
  result := fResultSet.Data[Col].GetAsInt64;
end;

function TSqlDBIbxStatement.ColumnNull(Col: integer): boolean;
begin
  if (fResultSet = nil) or
     (cardinal(Col) >= cardinal(fColumnCount)) then
    raise ESqlDBIbx.CreateUtf8('%.ColumnNull(%) ResultSet=%',
      [self, Col, fResultSet]);
  result := fResultSet.Data[Col].GetIsNull;
end;

function TSqlDBIbxStatement.ColumnDouble(Col: integer): double;
begin
  if (fResultSet = nil) or
     (cardinal(Col) >= cardinal(fColumnCount)) then
    raise ESqlDBIbx.CreateUtf8('%.ColumnDouble(%) ResultSet=%',
      [self, Col, fResultSet]);
  result := fResultSet.Data[Col].GetAsDouble;
end;

function TSqlDBIbxStatement.ColumnDateTime(Col: integer): TDateTime;
begin
  if (fResultSet = nil) or
     (cardinal(Col) >= cardinal(fColumnCount)) then
    raise ESqlDBIbx.CreateUtf8('%.ColumnDateTime(%) ResultSet=%',
      [self, Col, fResultSet]);
  result := fResultSet.Data[Col].GetAsDateTime;
end;

function TSqlDBIbxStatement.ColumnCurrency(Col: integer): currency;
begin
  if (fResultSet = nil) or
     (cardinal(Col) >= cardinal(fColumnCount)) then
    raise ESqlDBIbx.CreateUtf8('%.ColumnCurrency(%) ResultSet=%',
      [self, Col, fResultSet]);
  result := fResultSet.Data[Col].GetAsCurrency;
end;

function TSqlDBIbxStatement.ColumnUtf8(Col: integer): RawUtf8;
begin
  if (fResultSet = nil) or
     (cardinal(Col) >= cardinal(fColumnCount)) then
    raise ESqlDBIbx.CreateUtf8('%.ColumnUtf8(%) ResultSet=%',
      [self, Col, fResultSet]);
  result := fResultSet.Data[Col].GetAsString;
end;

function TSqlDBIbxStatement.ColumnBlob(Col: integer): RawByteString;
begin
  if (fResultSet = nil) or
     (cardinal(Col) >= cardinal(fColumnCount)) then
    raise ESqlDBIbx.CreateUtf8('%.ColumnBlob(%) ResultSet=%',
      [self, Col, fResultSet]);
  result := fResultSet.Data[Col].GetAsString;
end;

{ TSqlDBIbxConnection }

function TSqlDBIbxConnection.GetFirebirdAPI: IFirebirdAPI;
var fblib: IFirebirdLibrary;
begin
  if fFirebirdAPI = nil then
  begin
    if Trim(fFbLibraryPathName) = '' then
      fFirebirdAPI := IB.FirebirdAPI
    else
    begin
      fblib := IB.LoadFBLibrary(fFbLibraryPathName);
      if assigned(fblib) then
        fFirebirdAPI := fblib.GetFirebirdAPI;
    end;
  end;
  Result := fFirebirdAPI;
end;

function TSqlDBIbxConnection.GenerateTPB: ITPB;
begin
  result := FirebirdAPI.AllocateTPB;
  result.Add(isc_tpb_read_committed);
  result.Add(isc_tpb_rec_version);
  result.Add(isc_tpb_nowait);
end;

constructor TSqlDBIbxConnection.Create(aProperties: TSqlDBConnectionProperties);
begin
  inherited Create(aProperties);
  fDBParams := TStringList.Create;
  with (aProperties as TSqlDBIbxConnectionProperties) do
  begin
    if DatabaseName='' then
       raise ESqlDBIbx.CreateUtf8('% DatabaseName=''''', [self]);
    fFbLibraryPathName := FirebirdLibraryPathName;
    fCreateDbIfNotExists := CreateIfNotExists;

    fDBParams.Assign(IbxDBParams);
    if UserID<>'' then
      fDBParams.Values['user_name'] := UserID;
    if PassWord<>'' then
      fDBParams.Values['password'] := PassWord;
    if ServerName='' then
      fDBName:=DatabaseName
    else
      fDBName:=ServerName+':'+DatabaseName;
  end;
  if fDBParams.Values['lc_ctype']='' then;
    fDBParams.Add('lc_ctype=UTF8');
end;

destructor TSqlDBIbxConnection.Destroy;
begin
  fDBParams.Free;
  inherited Destroy;
end;

procedure TSqlDBIbxConnection.Connect;
var
  DPB: IDPB;
  Status: IStatus;
  procedure GenerateDPB;
  var
    i: Integer;
    ParamValue: string;
    DPBItem: IDPBItem;
  begin
    DPB := FirebirdAPI.AllocateDPB;

    {Iterate through the textual database parameters, constructing
     a DPB on-the-fly }
    for i := 0 to fDBParams.Count - 1 do
    begin
      { Get the parameter's name and value from the list,
        and make sure that the name is all lowercase with
        no leading 'isc_dpb_' prefix
      }
      if (Trim(fDBParams.Names[i]) = '') then
        continue;

      DPBItem := DPB.AddByTypeName(fDBParams.Names[i]); {mbcs ok}
      ParamValue := fDBParams.ValueFromIndex[i]; {mbcs ok}
       {  A database parameter either contains a string value (case 1)
         or an Integer value (case 2)
         or no value at all (case 3)
         or an error needs to be generated (case else)  }
      case DPBItem.getParamType of
        isc_dpb_user_name, isc_dpb_password, isc_dpb_password_enc,
        isc_dpb_sys_user_name, isc_dpb_license, isc_dpb_encrypt_key,
        isc_dpb_lc_messages, isc_dpb_lc_ctype, isc_dpb_page_size,
        isc_dpb_sql_role_name:
          DPBItem.SetAsString(ParamValue);

        isc_dpb_sql_dialect:
        begin
          if (ParamValue = '') or (ParamValue[1] = '3') then
            DPBItem.SetAsString(#03)
          else
            DPBItem.SetAsString(#01)
        end;


        isc_dpb_num_buffers, isc_dpb_dbkey_scope, isc_dpb_force_write,
        isc_dpb_no_reserve, isc_dpb_damaged, isc_dpb_verify:
          DPBItem.SetAsByte(byte(ParamValue[1]));

        isc_dpb_sweep:
          DPBItem.SetAsByte(isc_dpb_records);

        isc_dpb_sweep_interval:
          DPBItem.SetAsInteger(StrToInt(ParamValue));

        isc_dpb_activate_shadow, isc_dpb_delete_shadow, isc_dpb_begin_log,
        isc_dpb_map_attach, isc_dpb_quit_log:
          DPBItem.SetAsByte(0);
        else
          raise ESqlDBIbx.CreateUtf8('%.Connect() on % failed. DBPConstantNotSupported: %', [self,
             fProperties.ServerName, DPBItem.getParamTypeName]);
      end;
    end;
  end;

begin
  if fAttachment<>nil then
     raise ESqlDBIbx.CreateUtf8('%.Connect() on % failed: Attachment<>nil', [self,
        fProperties.ServerName]);

  GenerateDPB;

  fAttachment := FirebirdAPI.OpenDatabase(fDBName,DPB,false);

  if fAttachment = nil then
  begin
    Status := FirebirdAPI.GetStatus;
    if ((Status.GetSQLCode = -902) and (Status.GetIBErrorCode = isc_io_error)) {Database not found}
        and fCreateDbIfNotExists then
    begin
      DPB.Add(isc_dpb_set_db_SQL_dialect).AsByte := 3; {create with this SQL Dialect 3}
      fAttachment := FirebirdAPI.CreateDatabase(fDBName,DPB, false);
    end;
    if fAttachment = nil then
      raise ESqlDBIbx.CreateUtf8('%.Connect() on % failed. SQLErrorCode: %, FbErrorCode: % ', [self,
        fDBName, Status.Getsqlcode, Status.GetIBErrorCode]);
  end;

  inherited Connect;
end;

procedure TSqlDBIbxConnection.Disconnect;
begin
  try
    inherited Disconnect; // flush any cached statement
  finally
    if (fAttachment <> nil) then
    begin
      fAttachment.Disconnect(true);
      fAttachment:=nil;
    end;
  end;
end;

function TSqlDBIbxConnection.IsConnected: boolean;
begin
  result := (fAttachment <> nil) and
             fAttachment.IsConnected;
end;

function TSqlDBIbxConnection.NewStatement: TSqlDBStatement;
begin
  result := TSqlDBIbxStatement.Create(self);
end;

procedure TSqlDBIbxConnection.StartTransaction;
var
  log: ISynLog;
begin
  log := SynDBLog.Enter(self, 'StartTransaction');
  if TransactionCount > 0 then
    raise ESqlDBIbx.CreateUtf8('Invalid %.StartTransaction: nested ' +
      'transactions are not supported/implemented', [self]);
  try
    inherited StartTransaction;
    if (fAttachment = nil) or not IsConnected then
       raise ESqlDBIbx.CreateUtf8('Invalid %.StartTransaction: ' +
       'Database not connected', [self]);
    if (fTransaction <> nil) and  fTransaction.InTransaction then
       raise ESqlDBIbx.CreateUtf8('Invalid %.StartTransaction: ' +
      'Transaction is Started/InTransactions', [self]);
    if fTransaction <> nil then
      fTransaction.Start(TACommit)
    else
    begin
      if (fTPB = nil) then
         fTPB := GenerateTPB;
      fTransaction := fAttachment.StartTransaction(fTPB, TACommit);
    end;
  except
    on E: Exception do
    begin
      if fTransactionCount > 0 then
         dec(fTransactionCount);
      raise;
    end;
  end;
end;

procedure TSqlDBIbxConnection.Commit;
begin
  inherited Commit;
  if fTransaction = nil then
    raise ESqlDBIbx.CreateUtf8('Invalid %.Commit call', [self]);
  try
    if fTransaction.InTransaction then
       fTransaction.Commit;
  except
    inc(fTransactionCount); // the transaction is still active
    raise;
  end;
end;

procedure TSqlDBIbxConnection.Rollback;
begin
  inherited Rollback;
  if fTransaction = nil then
    raise ESqlDBIbx.CreateUtf8('Invalid %.Rollback call', [self]);
  try
    if InTransaction then
       fTransaction.Rollback;
  except
    raise;
  end;
end;

{ TSqlDBIbxConnectionProperties }

procedure TSqlDBIbxConnectionProperties.SetCreateDescendingPK(AValue: boolean);
begin
  fCreateDescendingPK:=AValue;
  fEngineName:=FormatUtf8('IBX%', [AValue]);
end;

function TSqlDBIbxConnectionProperties.IbxSQLTypeToTSqlDBFieldType(
  aColMeta: IColumnMetaData): TSqlDBFieldType;
begin
  case aColMeta.GetSQLType of
    SQL_VARYING, SQL_TEXT:
      result := ftUtf8;
    SQL_DOUBLE, SQL_FLOAT:
      result := ftDouble;
    SQL_TIMESTAMP, SQL_TIMESTAMP_TZ_EX, SQL_TIME_TZ_EX,
    SQL_TIMESTAMP_TZ, SQL_TIME_TZ,SQL_TYPE_TIME, SQL_TYPE_DATE:
      result := ftDate;
    SQL_BOOLEAN, SQL_LONG, SQL_SHORT,
    SQL_D_FLOAT, SQL_QUAD, SQL_INT64:
      begin
        if aColMeta.getScale >= (-4) then
          result := ftCurrency
        else
          result := ftInt64;
      end;
    SQL_BLOB:
      result := ftBlob;
  else
    //    SQL_INT128, SQL_DEC_FIXED, SQL_DEC16, SQL_DEC34
    //    SQL_NULL, SQL_ARRAY
    raise ESqlDBIbx.CreateUtf8('%: unexpected TIbxType % "%"', [self,
      aColMeta.GetSQLType, aColMeta.GetSQLTypeName]);
  end;
end;

function TSqlDBIbxConnectionProperties.SqlFieldCreate(
  const aField: TSqlDBColumnCreate; var aAddPrimaryKey: RawUtf8): RawUtf8;
begin
  if (aField.DBType = ftUtf8) and
     (cardinal(aField.Width - 1) < fSqlCreateFieldMax) then
    FormatUtf8(fSqlCreateField[ftNull], [aField.Width], result)
  else
    result := fSqlCreateField[aField.DBType];
  if aField.NonNullable or aField.Unique or aField.PrimaryKey then
    result := result + ' NOT NULL';
  if aField.Unique and
     not aField.PrimaryKey then
    result := result + ' UNIQUE'; // see http://www.w3schools.com/sql/sql_unique.asp
  if aField.PrimaryKey then
  begin
    if fCreateDescendingPK then
      aAddPrimaryKey := aField.Name
    else
      result := result + ' PRIMARY KEY';
  end;
  result := aField.Name + result;
end;

constructor TSqlDBIbxConnectionProperties.Create(const aServerName,
  aDatabaseName, aUserID, aPassWord: RawUtf8);
begin
  fFirebirdLibraryPathName := '';
  fIbxDBParams := TStringList.Create;
  fCreateIfNotExists := True;
  CreateDescendingPK := False;
  fDbms := dFirebird;
  fBatchSendingAbilities := [cCreate, cUpdate, cDelete];
  fBatchMaxSentAtOnce := 1000;  // iters <= 32767 for better performance
  if aServerName='' then
    ThreadingMode := tmMainConnection;
  inherited Create(aServerName, aDatabaseName, aUserID, aPassWord);
end;

destructor TSqlDBIbxConnectionProperties.Destroy;
begin
  fIbxDBParams.Free;
  inherited Destroy;
end;

function TSqlDBIbxConnectionProperties.NewConnection: TSqlDBConnection;
begin
  result := TSqlDBIbxConnection.Create(self);
end;

function TSqlDBIbxConnectionProperties.SqlCreate(const aTableName: RawUtf8;
  const aFields: TSqlDBColumnCreateDynArray; aAddID: boolean): RawUtf8;
var
  i: integer;
  F: RawUtf8;
  FieldID: TSqlDBColumnCreate;
  AddPrimaryKey: RawUtf8;
begin
  // use 'ID' instead of 'RowID' here since some DB (e.g. Oracle) use it
  result := '';
  if high(aFields) < 0 then
    exit; // nothing to create
  if aAddID then
  begin
    FieldID.DBType := ftInt64;
    FieldID.Name := ID_TXT;
    FieldID.Unique := true;
    FieldID.NonNullable := true;
    FieldID.PrimaryKey := true;
    result := SqlFieldCreate(FieldID, AddPrimaryKey) + ',';
  end;
  for i := 0 to high(aFields) do
  begin
    F := SqlFieldCreate(aFields[i], AddPrimaryKey);
    if i <> high(aFields) then
      F := F + ',';
    result := result + F;
  end;
  if AddPrimaryKey <> '' then
  begin
    if fCreateDescendingPK then
      result := result + ', PRIMARY KEY(' + AddPrimaryKey + ') using desc index PK_'+aTableName
    else
      result := result + ', PRIMARY KEY(' + AddPrimaryKey + ')';
  end;
  result := 'CREATE TABLE ' + aTableName + ' (' + result + ')';
end;

end.