fpc/fcl/db/sqldb/interbase/ibconnection.pp

unit IBConnection;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, IBase60, sqldb, db;
  
type
  TAccessMode = (amReadWrite, amReadOnly);
  TIsolationLevel = (ilConcurrent, ilConsistent, ilReadCommittedRecV,
    ilReadCommitted);
  TLockResolution = (lrWait, lrNoWait);
  TTableReservation = (trNone, trSharedLockRead, trSharedLockWrite,
    trProtectedLockRead, trProtectedLockWrite);

  TIBCursor = Class(TSQLHandle)
    protected
    Status    : array [0..19] of ISC_STATUS;
    Statement : pointer;
    SQLDA     : PXSQLDA;
  end;

  TIBTrans = Class(TSQLHandle)
    protected
    TransactionHandle   : pointer;
    TPB                 : string;                // Transaction parameter buffer
    Status              : array [0..19] of ISC_STATUS;
    AccessMode          : TAccessMode;
    IsolationLevel      : TIsolationLevel;
    LockResolution      : TLockResolution;
    TableReservation    : TTableReservation;
  end;

  TIBConnection = class (TSQLConnection)
  private
    FSQLDAAllocated      : integer;
    FSQLDatabaseHandle   : pointer;
    FStatus              : array [0..19] of ISC_STATUS;
    FFieldFlag           : array [0..1023] of shortint;
    FDialect             : integer;
    procedure SetDBDialect;
    procedure AllocSQLDA(Cursor : TIBCursor;Count : integer);
    procedure TranslateFldType(SQLType, SQLLen : integer; var LensSet : boolean;
      var TrType : TFieldType; var TrLen : word);
    procedure SetTPB(trans : TIBtrans);
    // conversion methods
    procedure GetDateTime(CurrBuff, Buffer : pointer; AType : integer);
    procedure GetFloat(CurrBuff, Buffer : pointer; Field : TField);
    procedure CheckError(ProcName : string; Status : array of ISC_STATUS);
  protected
    procedure DoInternalConnect; override;
    procedure DoInternalDisconnect; override;
    function GetHandle : pointer; override;

    Function AllocateCursorHandle : TSQLHandle; override;
    Function AllocateTransactionHandle : TSQLHandle; override;

    procedure FreeStatement(cursor : TSQLHandle); override;
    procedure FreeSelect(cursor : TSQLHandle); override;
    procedure PrepareStatement(cursor: TSQLHandle;ATransaction : TSQLTransaction;buf : string); override;
    procedure PrepareSelect(cursor : TSQLHandle); override;
    procedure FreeFldBuffers(cursor : TSQLHandle); override;
    procedure Execute(cursor: TSQLHandle;atransaction:tSQLtransaction); override;
    procedure AddFieldDefs(cursor: TSQLHandle; FieldDefs : TfieldDefs); override;
    function GetFieldSizes(cursor : TSQLHandle) : integer; override;
    function Fetch(cursor : TSQLHandle) : boolean; override;
    procedure LoadFieldsFromBuffer(cursor : TSQLHandle;buffer: pchar); override;
    function GetFieldData(cursor : TSQLHandle; Field: TField; Buffer: Pointer;currbuff:pchar): Boolean; override;
    function GetStatementType(cursor : TSQLHandle) : tStatementType; override;
    function GetTransactionHandle(trans : TSQLHandle): pointer; override;
    function Commit(trans : TSQLHandle) : boolean; override;
    function RollBack(trans : TSQLHandle) : boolean; override;
    function StartTransaction(trans : TSQLHandle) : boolean; override;
    procedure CommitRetaining(trans : TSQLHandle); override;
    procedure RollBackRetaining(trans : TSQLHandle); override;

  published
    property Dialect  : integer read FDialect write FDialect;
    property DatabaseName;
    property KeepConnection;
    property LoginPrompt;
    property Params;
    property OnLogin;
  end;

implementation

resourcestring
  SErrNoDatabaseName = 'Database connect string (DatabaseName) not filled in!';

type
  TTm = packed record
    tm_sec : longint;
    tm_min : longint;
    tm_hour : longint;
    tm_mday : longint;
    tm_mon : longint;
    tm_year : longint;
    tm_wday : longint;
    tm_yday : longint;
    tm_isdst : longint;
    __tm_gmtoff : longint;
    __tm_zone : Pchar;
  end;

procedure TIBConnection.CheckError(ProcName : string; Status : array of ISC_STATUS);
var
  buf : array [0..1024] of char;
  p   : pointer;
  Msg : string;
begin
  if ((Status[0] = 1) and (Status[1] <> 0)) then
  begin
    p := @Status;
    while isc_interprete(Buf, @p) > 0 do
      Msg := Msg + #10' -' + StrPas(Buf);
    DatabaseError(ProcName + ': ' + Msg,self);
  end;
end;

procedure TIBConnection.SetTPB(trans : TIBtrans);
begin
  with trans do
    begin
    TPB := chr(isc_tpb_version3);

    case AccessMode of
      amReadWrite : TPB := TPB + chr(isc_tpb_write);
      amReadOnly  : TPB := TPB + chr(isc_tpb_read);
    end;

    case IsolationLevel of
      ilConsistent        : TPB := TPB + chr(isc_tpb_consistency);
      ilConcurrent        : TPB := TPB + chr(isc_tpb_concurrency);
      ilReadCommittedRecV : TPB := TPB + chr(isc_tpb_read_committed) +
        chr(isc_tpb_rec_version);
      ilReadCommitted     : TPB := TPB + chr(isc_tpb_read_committed) +
        chr(isc_tpb_no_rec_version);
    end;

    case LockResolution of
      lrWait   : TPB := TPB + chr(isc_tpb_wait);
      lrNoWait : TPB := TPB + chr(isc_tpb_nowait);
    end;

    case TableReservation of
      trSharedLockRead     : TPB := TPB + chr(isc_tpb_shared) +
        chr(isc_tpb_lock_read);
      trSharedLockWrite    : TPB := TPB + chr(isc_tpb_shared) +
        chr(isc_tpb_lock_write);
      trProtectedLockRead  : TPB := TPB + chr(isc_tpb_protected) +
        chr(isc_tpb_lock_read);
      trProtectedLockWrite : TPB := TPB + chr(isc_tpb_protected) +
        chr(isc_tpb_lock_write);
    end;
    end;
end;

function TIBConnection.GetTransactionHandle(trans : TSQLHandle): pointer;
begin
  Result := (trans as TIBtrans).TransactionHandle;
end;

function TIBConnection.Commit(trans : TSQLHandle) : boolean;
begin
  result := false;
  with (trans as TIBTrans) do
    if isc_commit_transaction(@Status, @TransactionHandle) <> 0 then
      CheckError('Commit', Status)
    else result := true;
end;

function TIBConnection.RollBack(trans : TSQLHandle) : boolean;
begin
  result := false;
  if isc_rollback_transaction(@TIBTrans(trans).Status, @TIBTrans(trans).TransactionHandle) <> 0 then
    CheckError('Rollback', TIBTrans(trans).Status)
  else result := true;
end;

function TIBConnection.StartTransaction(trans : TSQLHandle) : boolean;
var
  DBHandle : pointer;
  tr       : TIBTrans;
begin
  result := false;

  DBHandle := GetHandle;
  tr := trans as TIBtrans;
  SetTPB(tr);
  with tr do
    begin
    TransactionHandle := nil;

    if isc_start_transaction(@Status, @TransactionHandle, 1,
       [@DBHandle, Length(TPB), @TPB[1]]) <> 0 then
      CheckError('StartTransaction',Status)
    else Result := True;
    end;
end;


procedure TIBConnection.CommitRetaining(trans : TSQLHandle);
begin
  with trans as TIBtrans do
    if isc_commit_retaining(@Status, @TransactionHandle) <> 0 then
      CheckError('CommitRetaining', Status);
end;

procedure TIBConnection.RollBackRetaining(trans : TSQLHandle);
begin
  with trans as TIBtrans do
    if isc_rollback_retaining(@Status, @TransactionHandle) <> 0 then
      CheckError('RollBackRetaining', Status);
end;


procedure TIBConnection.DoInternalConnect;
var
  DPB : string;
begin
  inherited dointernalconnect;

  DPB := chr(isc_dpb_version1);
  if (UserName <> '') then
  begin
    DPB := DPB + chr(isc_dpb_user_name) + chr(Length(UserName)) + UserName;
    if (Password <> '') then
      DPB := DPB + chr(isc_dpb_password) + chr(Length(Password)) + Password;
  end;
  if (Role <> '') then
     DPB := DPB + chr(isc_dpb_sql_role_name) + chr(Length(Role)) + Role;
  if Length(CharSet) > 0 then
    DPB := DPB + Chr(isc_dpb_lc_ctype) + Chr(Length(CharSet)) + CharSet;

  if (DatabaseName = '') then
    DatabaseError(SErrNoDatabaseName,self);
  FSQLDatabaseHandle := nil;
  if isc_attach_database(@FStatus, Length(DatabaseName), @DatabaseName[1], @FSQLDatabaseHandle,
         Length(DPB), @DPB[1]) <> 0 then
    CheckError('DoInternalConnect', FStatus);
  SetDBDialect;
end;

procedure TIBConnection.DoInternalDisconnect;
begin
  if not Connected then
  begin
    FSQLDatabaseHandle := nil;
    Exit;
  end;

  isc_detach_database(@FStatus[0], @FSQLDatabaseHandle);
  CheckError('Close', FStatus);
end;


procedure TIBConnection.SetDBDialect;
var
  x : integer;
  Len : integer;
  Buffer : string;
  ResBuf : array [0..39] of byte;
begin
  Buffer := Chr(isc_info_db_sql_dialect) + Chr(isc_info_end);
  if isc_database_info(@FStatus, @FSQLDatabaseHandle, Length(Buffer),
    @Buffer[1], SizeOf(ResBuf), @ResBuf) <> 0 then
      CheckError('SetDBDialect', FStatus);
  x := 0;
  while x < 40 do
    case ResBuf[x] of
      isc_info_db_sql_dialect :
        begin
          Inc(x);
          Len := isc_vax_integer(@ResBuf[x], 2);
          Inc(x, 2);
          FDialect := isc_vax_integer(@ResBuf[x], Len);
          Inc(x, Len);
        end;
      isc_info_end : Break;
    end;
end;


procedure TIBConnection.AllocSQLDA(Cursor : TIBcursor;Count : integer);

begin
  with cursor as TIBCursor do
    begin
    if FSQLDAAllocated > 0 then
      FreeMem(SQLDA);
    GetMem(SQLDA, XSQLDA_Length(Count));
    { Zero out the memory block to avoid problems with exceptions within the
      constructor of this class. }
    FillChar(SQLDA^, XSQLDA_Length(Count), 0);
    FSQLDAAllocated := Count;
    SQLDA^.Version := sqlda_version1;
    SQLDA^.SQLN := Count;
    end;
end;

procedure TIBConnection.TranslateFldType(SQLType, SQLLen : integer; var LensSet : boolean;
  var TrType : TFieldType; var TrLen : word);
begin
  LensSet := False;

  case (SQLType and not 1) of
    SQL_VARYING :
      begin
        LensSet := True;
        TrType := ftString;
        TrLen := SQLLen;
      end;
    SQL_TEXT :
      begin
        LensSet := True;
        TrType := ftString;
        TrLen := SQLLen;
      end;
    SQL_TYPE_DATE :
        TrType := ftDateTime;
    SQL_TYPE_TIME :
        TrType := ftDateTime;
    SQL_TIMESTAMP :
        TrType := ftDateTime;
    SQL_ARRAY :
      begin
      end;
    SQL_BLOB :
      begin
      end;
    SQL_SHORT :
      begin
        LensSet := True;
        TrLen := SQLLen;
        TrType := ftInteger;
      end;
    SQL_LONG :
      begin
        LensSet := True;
        TrLen := SQLLen;
        TrType := ftInteger;
      end;
    SQL_INT64 :
        {TrType := ftInt64};
    SQL_DOUBLE :
      begin
        LensSet := True;
        TrLen := SQLLen;
        TrType := ftFloat;
      end;
    SQL_FLOAT :
      begin
        LensSet := True;
        TrLen := SQLLen;
        TrType := ftFloat;
      end;
  end;
end;

Function TIBConnection.AllocateCursorHandle : TSQLHandle;

var curs : TIBCursor;

begin
  curs := TIBCursor.create;
  AllocSQLDA(curs,10);
  result := curs;
end;

Function TIBConnection.AllocateTransactionHandle : TSQLHandle;

begin
  result := TIBTrans.create;
end;

procedure TIBConnection.FreeSelect(cursor : TSQLHandle);

begin
end;

procedure TIBConnection.FreeStatement(cursor : TSQLHandle);
begin
  with cursor as TIBcursor do
    begin
    if isc_dsql_free_statement(@Status, @Statement, DSQL_Drop) <> 0 then
      CheckError('FreeStatement', Status);
    Statement := nil;
    end;
end;

procedure TIBConnection.PrepareStatement(cursor: TSQLHandle;ATransaction : TSQLTransaction;buf : string);
var
  dh    : pointer;
  tr : pointer;

begin
  with cursor as TIBcursor do
    begin
    dh := GetHandle;
    if isc_dsql_allocate_statement(@Status, @dh, @Statement) <> 0 then
      CheckError('PrepareStatement', Status);
    tr := aTransaction.Handle;
    if isc_dsql_prepare(@Status, @tr, @Statement, 0, @Buf[1], Dialect, nil) <> 0 then
      CheckError('PrepareStatement', Status);
    end;
end;

procedure TIBConnection.PrepareSelect(cursor : TSQLHandle);
var
  x  : shortint;
begin
  with cursor as TIBCursor do
    begin
    if isc_dsql_describe(@Status, @Statement, 1, SQLDA) <> 0 then
      CheckError('PrepareSelect', Status);
    if SQLDA^.SQLD > SQLDA^.SQLN then
      begin
      AllocSQLDA((cursor as TIBCursor),SQLDA^.SQLD);
      if isc_dsql_describe(@Status, @Statement, 1, SQLDA) <> 0 then
        CheckError('PrepareSelect', Status);
      end;
    {$R-}
    for x := 0 to SQLDA^.SQLD - 1 do
      begin
      SQLDA^.SQLVar[x].SQLData := AllocMem(SQLDA^.SQLVar[x].SQLLen);
      SQLDA^.SQLVar[x].SQLInd  := @FFieldFlag[x];
      end;
    {$R+}
    end;
end;

procedure TIBConnection.FreeFldBuffers(cursor : TSQLHandle);
var
  x  : shortint;
begin
  {$R-}
  with cursor as TIBCursor do
    for x := 0 to SQLDA^.SQLD - 1 do
      begin
      if SQLDA^.SQLVar[x].SQLData <> nil then
        begin
        FreeMem(SQLDA^.SQLVar[x].SQLData);
        SQLDA^.SQLVar[x].SQLData := nil;
        end;
      end;
  {$R+}
end;

procedure TIBConnection.Execute(cursor: TSQLHandle;atransaction:tSQLtransaction);
var tr : pointer;
begin
  tr := aTransaction.Handle;

  with cursor as TIBCursor do
    if isc_dsql_execute(@Status, @tr, @Statement, 1, nil) <> 0 then
      CheckError('Execute', Status);
end;

procedure TIBConnection.AddFieldDefs(cursor: TSQLHandle; FieldDefs : TfieldDefs);
var
  x         : integer;
  lenset    : boolean;
  TransLen  : word;
  TransType : TFieldType;

begin
  {$R-}
  with cursor as TIBCursor do
    begin
    for x := 0 to SQLDA^.SQLD - 1 do
      begin
      TranslateFldType(SQLDA^.SQLVar[x].SQLType, SQLDA^.SQLVar[x].SQLLen, lenset,
        TransType, TransLen);
      TFieldDef.Create(FieldDefs, SQLDA^.SQLVar[x].SQLName, TransType,
        TransLen, False, (x + 1));
      end;
    end;
  {$R+}
end;

function TIBConnection.GetFieldSizes(cursor : TSQLHandle) : integer;
var
  x,recsize : integer;
begin
  recsize := 0;
  {$R-}
  with cursor as TIBCursor do
    for x := 0 to SQLDA^.SQLD - 1 do
      Inc(recsize, SQLDA^.SQLVar[x].SQLLen);
  {$R+}
  result := recsize;
end;

function TIBConnection.GetHandle: pointer;
begin
  Result := FSQLDatabaseHandle;
end;

function TIBConnection.Fetch(cursor : TSQLHandle) : boolean;
var
  retcode : integer;
begin
  with cursor as TIBCursor do
    begin
    retcode := isc_dsql_fetch(@Status, @Statement, 1, SQLDA);
    if (retcode <> 0) and (retcode <> 100) then
      CheckError('Fetch', Status);
    end;
  Result := (retcode = 100);
end;

procedure TIBConnection.LoadFieldsFromBuffer(cursor : TSQLHandle;buffer : pchar);
var
  x          : integer;
  VarcharLen : word;
begin
  {$R-}
  with cursor as TIBCursor do for x := 0 to SQLDA^.SQLD - 1 do
    begin
    with SQLDA^.SQLVar[x] do
      begin
      if ((SQLType and not 1) = SQL_VARYING) then
        begin
        Move(SQLData^, VarcharLen, 2);
        Move((SQLData + 2)^, Buffer^, VarcharLen);
        PChar(Buffer + VarcharLen)^ := #0;
        end
      else Move(SQLData^, Buffer^, SQLLen);
      Inc(Buffer, SQLLen);
      end;
    end;
  {$R+}
end;

function TIBConnection.GetFieldData(Cursor : TSQLHandle;Field: TField; Buffer: Pointer;currbuff : pchar): Boolean;
var
  x : longint;
  b : longint;
begin
  Result := False;

  with cursor as TIBCursor do for x := 0 to SQLDA^.SQLD - 1 do
    begin
    {$R-}
    if (Field.FieldName = SQLDA^.SQLVar[x].SQLName) then
      begin
      case Field.DataType of
        ftInteger :
          begin
            b := 0;
            Move(b, Buffer^, 4);
            Move(CurrBuff^, Buffer^, Field.Size);
          end;
        ftDate, ftTime, ftDateTime:
          GetDateTime(CurrBuff, Buffer, SQLDA^.SQLVar[x].SQLType);
        ftString  :
          begin
            Move(CurrBuff^, Buffer^, Field.Size);
            PChar(Buffer + Field.Size)^ := #0;
          end;
        ftFloat   :
          GetFloat(CurrBuff, Buffer, Field);
      end;

      Result := True;

      Break;
      end
    else Inc(CurrBuff, SQLDA^.SQLVar[x].SQLLen);
    {$R+}
    end;
end;

procedure TIBConnection.GetDateTime(CurrBuff, Buffer : pointer; AType : integer);
var
  CTime : TTm;          // C struct time
  STime : TSystemTime;  // System time
  PTime : TDateTime;    // Pascal time
begin
  case (AType and not 1) of
    SQL_TYPE_DATE :
      isc_decode_sql_date(PISC_DATE(CurrBuff), @CTime);
    SQL_TYPE_TIME :
      isc_decode_sql_time(PISC_TIME(CurrBuff), @CTime);
    SQL_TIMESTAMP :
      isc_decode_timestamp(PISC_TIMESTAMP(CurrBuff), @CTime);
  end;
  STime.Year        := CTime.tm_year + 1900;
  STime.Month       := CTime.tm_mon + 1;
  STime.Day         := CTime.tm_mday;
  STime.Hour        := CTime.tm_hour;
  STime.Minute      := CTime.tm_min;
  STime.Second      := CTime.tm_sec;
  STime.Millisecond := 0;

  PTime := SystemTimeToDateTime(STime);
  Move(PTime, Buffer^, SizeOf(PTime));
end;

procedure TIBConnection.GetFloat(CurrBuff, Buffer : pointer; Field : TField);
var
  Ext : extended;
  Dbl : double;
  Sin : single;
begin
  case Field.Size of
    4 :
      begin
        Move(CurrBuff^, Sin, 4);
        Ext := Sin;
      end;
    8 :
      begin
        Move(CurrBuff^, Dbl, 8);
        Ext := Dbl;
      end;
    10: Move(CurrBuff^, Ext, 10);
  end;
  Move(Ext, Buffer^, 10);
end;

function TIBConnection.GetStatementType(cursor : TSQLhandle) : TStatementType;
var
  x : integer;
  ResBuf : array [0..7] of char;
begin
  Result := stNone;
  with cursor as TIBCursor do
    begin
    x := isc_info_sql_stmt_type;
    if isc_dsql_sql_info(@Status, @Statement, SizeOf(X),
      @x, SizeOf(ResBuf), @ResBuf) <> 0 then
      CheckError('GetStatementType', Status);
    if Ord(ResBuf[0]) = isc_info_sql_stmt_type then
      begin
      x := isc_vax_integer(@ResBuf[1], 2);
      Result := TStatementType(isc_vax_integer(@ResBuf[3], x));
      end;
    end;
end;

end.