+ initial implementation of TSQLQuery

fcl/db/sqldb/Makefile.fpc

@@ -0,0 +1,31 @@
+#
+# Makefile.fpc for SQL FCL db units
+#
+
+[package]
+main=fcl
+
+[target]
+dirs_linux=interbase
+dirs_freebsd=interbase
+dirs_darwin=interbase
+dirs_netbsd=interbase
+dirs_openbsd=interbase
+dirs_win32=interbase
+units=sqldb
+
+[clean]
+units=ibas40 ibase60
+
+[require]
+packages=ibase
+
+[compiler]
+options=-S2 
+targetdir=../../$(OS_TARGET)
+
+[install]
+fpcpackage=y
+
+[default]
+fpcdir=../../..

fcl/db/sqldb/interbase/Makefile.fpc

@@ -0,0 +1,22 @@
+#
+# Makefile.fpc for SQL IBConnection
+#
+
+[package]
+main=fcl
+
+[target]
+units=ibconnection
+
+[require]
+packages=ibase
+
+[compiler]
+options=-S2 
+targetdir=../../../$(OS_TARGET)
+
+[install]
+fpcpackage=y
+
+[default]
+fpcdir=../../../..

fcl/db/sqldb/interbase/ibconnection.pp

@@ -0,0 +1,642 @@
+unit IBConnection;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, IBase60, sqldb, db;
+  
+type
+  TIBCursor = record
+                Status    : array [0..19] of ISC_STATUS;
+                Statement : pointer;
+                SQLDA     : PXSQLDA;
+              end;
+  PIBCursor = ^TIBCursor;
+
+  TAccessMode = (amReadWrite, amReadOnly);
+  TIsolationLevel = (ilConcurrent, ilConsistent, ilReadCommittedRecV,
+    ilReadCommitted);
+  TLockResolution = (lrWait, lrNoWait);
+  TTableReservation = (trNone, trSharedLockRead, trSharedLockWrite,
+    trProtectedLockRead, trProtectedLockWrite);
+
+  TIBTrans  = record
+                TransactionHandle   : pointer;
+                TPB                 : string;                // Transaction parameter buffer
+                Status              : array [0..19] of ISC_STATUS;
+                AccessMode          : TAccessMode;
+                IsolationLevel      : TIsolationLevel;
+                LockResolution      : TLockResolution;
+                TableReservation    : TTableReservation;
+              end;
+  PIBTrans = ^TIBTrans;
+
+  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 : pointer;Count : integer);
+    procedure TranslateFldType(SQLType, SQLLen : integer; var LensSet : boolean;
+      var TrType : TFieldType; var TrLen : word);
+    procedure SetTPB(trans : pointer);
+    // conversion methods
+    procedure GetDateTime(CurrBuff, Buffer : pointer; AType : integer);
+    procedure GetFloat(CurrBuff, Buffer : pointer; Field : TField);
+  protected
+    procedure DoInternalConnect; override;
+    procedure DoInternalDisconnect; override;
+    function GetHandle : pointer; override;
+
+  public
+    function GetCursor : pointer; override;
+    procedure FreeCursor(cursor : pointer); override;
+    function GetTrans : pointer; override;
+    procedure FreeTrans(trans : pointer); override;
+    procedure AllocStatement(cursor : Pointer); override;
+    procedure FreeStatement(cursor : pointer); override;
+    procedure PrepareStatement(cursor: pointer;ATransaction : TSQLTransaction;buf : string); override;
+    procedure DescribeStatement(cursor : pointer); override;
+    procedure AllocFldBuffers(cursor : pointer); override;
+    procedure FreeFldBuffers(cursor : pointer); override;
+    procedure Execute(cursor: pointer;atransaction:tSQLtransaction); override;
+    procedure AddFieldDefs(cursor: pointer; FieldDefs : TfieldDefs); override;
+    function GetFieldSizes(cursor : pointer) : integer; override;
+    function Fetch(cursor : pointer) : boolean; override;
+    procedure LoadFieldsFromBuffer(cursor : pointer;buffer: pchar); override;
+    function GetFieldData(cursor : pointer; Field: TField; Buffer: Pointer;currbuff:pchar): Boolean; override;
+    function GetStatementType(cursor : pointer) : tStatementType; override;
+    function GetTransactionHandle(trans : pointer): pointer; override;
+    function Commit(trans : pointer) : boolean; override;
+    function RollBack(trans : pointer) : boolean; override;
+    function StartTransaction(trans : pointer) : boolean; override;
+    procedure CommitRetaining(trans : pointer); override;
+    procedure RollBackRetaining(trans : pointer); override;
+
+  published
+    property Dialect  : integer read FDialect write FDialect;
+    property DatabaseName;
+    property KeepConnection;
+    property LoginPrompt;
+    property Params;
+    property OnLogin;
+  end;
+
+implementation
+
+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 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);
+    raise ESQLdbError.Create(ProcName + ': ' + Msg);
+  end;
+end;
+
+procedure TIBConnection.SetTPB(trans : pointer);
+begin
+  with PIBTrans(trans)^ do
+    begin
+    TPB := chr(isc_tpb_version3);
+
+    case PIBTrans(trans)^.AccessMode of
+      amReadWrite : TPB := TPB + chr(isc_tpb_write);
+      amReadOnly  : TPB := TPB + chr(isc_tpb_read);
+    end;
+
+    case PIBTrans(trans)^.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 PIBTrans(trans)^.LockResolution of
+      lrWait   : TPB := TPB + chr(isc_tpb_wait);
+      lrNoWait : TPB := TPB + chr(isc_tpb_nowait);
+    end;
+
+    case PIBTrans(trans)^.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 : pointer): pointer;
+begin
+  Result := PIBTrans(trans)^.TransactionHandle;
+end;
+
+function TIBConnection.Commit(trans : pointer) : boolean;
+begin
+  result := false;
+  if isc_commit_transaction(@PIBTrans(trans)^.Status, @PIBTrans(trans)^.TransactionHandle) <> 0 then
+    CheckError('TSQLTransaction.Commit', PIBTrans(trans)^.Status)
+  else result := true;
+end;
+
+function TIBConnection.RollBack(trans : pointer) : boolean;
+begin
+  result := false;
+  if isc_rollback_transaction(@PIBTrans(trans)^.Status, @PIBTrans(trans)^.TransactionHandle) <> 0 then
+    CheckError('TIBConnection.Rollback', PIBTrans(trans)^.Status)
+  else result := true;
+end;
+
+function TIBConnection.StartTransaction(trans : pointer) : boolean;
+var
+  DBHandle : pointer;
+begin
+  result := false;
+
+  DBHandle := GetHandle;
+  SetTPB(trans);
+  pibtrans(trans)^.TransactionHandle := nil;
+
+  if isc_start_transaction(@pibtrans(trans)^.Status, @pibtrans(trans)^.TransactionHandle, 1,
+     [@DBHandle, Length(pibtrans(trans)^.TPB), @pibtrans(trans)^.TPB[1]]) <> 0 then
+    CheckError('TIBConnection.StartTransaction',pibtrans(trans)^.Status)
+  else Result := True;
+end;
+
+
+procedure TIBConnection.CommitRetaining(trans : pointer);
+begin
+  if isc_commit_retaining(@PIBTrans(trans)^.Status, @PIBTrans(trans)^.TransactionHandle) <> 0 then
+    CheckError('TIBConnection.CommitRetaining', PIBTrans(trans)^.Status);
+end;
+
+procedure TIBConnection.RollBackRetaining(trans : pointer);
+begin
+  if isc_rollback_retaining(@PIBTrans(trans)^.Status, @PIBTrans(trans)^.TransactionHandle) <> 0 then
+    CheckError('TIBConnection.RollBackRetaining', PIBTrans(trans)^.Status);
+end;
+
+function TIBConnection.GetTrans : pointer;
+
+begin
+  Result := AllocMem(sizeof(TIBTrans));
+  PIBTrans(result)^.IsolationLevel := ilReadCommitted;
+end;
+
+procedure TIBConnection.FreeTrans(trans : pointer);
+
+begin
+  if assigned(PIBTrans(trans)) then
+    freemem(PIBTrans(trans));
+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
+    raise ESQLdbError.Create('TIBConnection.DoInternalConnect: Database connect string (DatabaseName) not filled in!');
+  FSQLDatabaseHandle := nil;
+  if isc_attach_database(@FStatus, Length(DatabaseName), @DatabaseName[1], @FSQLDatabaseHandle,
+         Length(DPB), @DPB[1]) <> 0 then
+    CheckError('TIBConnection.DoInternalConnect', FStatus);
+  SetDBDialect;
+end;
+
+procedure TIBConnection.DoInternalDisconnect;
+begin
+  if not Connected then
+  begin
+    FSQLDatabaseHandle := nil;
+    Exit;
+  end;
+
+  isc_detach_database(@FStatus[0], @FSQLDatabaseHandle);
+  CheckError('TIBConnection.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('TIBDatabse.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 : pointer;Count : integer);
+begin
+  if FSQLDAAllocated > 0 then
+    FreeMem(PIBCursor(cursor)^.SQLDA);
+  GetMem(PIBCursor(cursor)^.SQLDA, XSQLDA_Length(Count));
+  { Zero out the memory block to avoid problems with exceptions within the
+    constructor of this class. }
+  FillChar(PIBCursor(cursor)^.SQLDA^, XSQLDA_Length(Count), 0);
+  FSQLDAAllocated := Count;
+  PIBCursor(cursor)^.SQLDA^.Version := sqlda_version1;
+  PIBCursor(cursor)^.SQLDA^.SQLN := Count;
+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.GetCursor : pointer;
+
+begin
+  Result := AllocMem(sizeof(TIBCursor));
+  AllocSQLDA(result,10);
+end;
+
+procedure TIBConnection.FreeCursor(cursor : pointer);
+
+begin
+  if assigned(PIBCursor(cursor)) then
+    freemem(PIBCursor(cursor));
+end;
+
+procedure TIBConnection.FreeStatement(cursor : pointer);
+begin
+  if isc_dsql_free_statement(@PIBCursor(cursor)^.Status, @PIBCursor(cursor)^.Statement, DSQL_Drop) <> 0 then
+    CheckError('TIBConnection.FreeStatement', PIBCursor(cursor)^.Status);
+  PIBCursor(cursor)^.Statement := nil;
+end;
+
+procedure TIBConnection.AllocStatement(cursor : pointer);
+var
+  dh    : pointer;
+begin
+  dh := GetHandle;
+
+  if isc_dsql_allocate_statement(@PIBCursor(cursor)^.Status, @dh, @PIBCursor(cursor)^.Statement) <> 0 then
+    CheckError('TIBConnection.AllocStatement', PIBCursor(cursor)^.Status);
+end;
+
+
+procedure TIBConnection.PrepareStatement(cursor: pointer;ATransaction : TSQLTransaction;buf : string);
+
+var tr : pointer;
+
+begin
+  tr := aTransaction.Handle;
+
+  if isc_dsql_prepare(@PIBCursor(cursor)^.Status, @tr, @PIBCursor(cursor)^.Statement, 0, @Buf[1], Dialect, nil) <> 0 then
+    CheckError('TIBConnection.PrepareStatement', PIBCursor(cursor)^.Status);
+end;
+
+procedure TIBConnection.DescribeStatement(cursor : pointer);
+
+begin
+  with PIBCursor(cursor)^ do
+    begin
+    if isc_dsql_describe(@Status, @Statement, 1, SQLDA) <> 0 then
+      CheckError('TSQLQuery.DescribeStatement', Status);
+    if SQLDA^.SQLD > SQLDA^.SQLN then
+      begin
+      AllocSQLDA(PIBCursor(cursor),SQLDA^.SQLD);
+      if isc_dsql_describe(@Status, @Statement, 1, SQLDA) <> 0 then
+        CheckError('TSQLQuery.DescribeStatement', Status);
+      end;
+    end;
+end;
+
+procedure TIBConnection.FreeFldBuffers(cursor : pointer);
+var
+  x  : shortint;
+begin
+  {$R-}
+  for x := 0 to PIBCursor(cursor)^.SQLDA^.SQLD - 1 do
+  begin
+    if PIBCursor(cursor)^.SQLDA^.SQLVar[x].SQLData <> nil then
+    begin
+      FreeMem(PIBCursor(cursor)^.SQLDA^.SQLVar[x].SQLData);
+      PIBCursor(cursor)^.SQLDA^.SQLVar[x].SQLData := nil;
+    end;
+  end;
+  {$R+}
+end;
+
+
+procedure TIBConnection.AllocFldBuffers(cursor : pointer);
+var
+  x  : shortint;
+begin
+  {$R-}
+  for x := 0 to PIBCursor(cursor)^.SQLDA^.SQLD - 1 do
+  begin
+    PIBCursor(cursor)^.SQLDA^.SQLVar[x].SQLData := AllocMem(PIBCursor(cursor)^.SQLDA^.SQLVar[x].SQLLen);
+    PIBCursor(cursor)^.SQLDA^.SQLVar[x].SQLInd  := @FFieldFlag[x];
+  end;
+  {$R+}
+end;
+
+procedure TIBConnection.Execute(cursor: pointer;atransaction:tSQLtransaction);
+var tr : pointer;
+begin
+  tr := aTransaction.Handle;
+
+  if isc_dsql_execute(@PIBCursor(cursor)^.Status, @tr, @PIBCursor(cursor)^.Statement, 1, nil) <> 0 then
+    CheckError('TSQLQuery.Execute', PIBCursor(cursor)^.Status);
+end;
+
+procedure TIBConnection.AddFieldDefs(cursor: pointer; FieldDefs : TfieldDefs);
+var
+  x         : integer;
+  lenset    : boolean;
+  TransLen  : word;
+  TransType : TFieldType;
+
+begin
+  {$R-}
+  with PIBCursor(cursor)^ 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 : pointer) : integer;
+var
+  x,recsize : integer;
+begin
+  recsize := 0;
+  {$R-}
+  with PIBCursor(cursor)^ 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 : pointer) : boolean;
+var
+  retcode : integer;
+begin
+  retcode := isc_dsql_fetch(@PIBCursor(cursor)^.Status, @PIBCursor(cursor)^.Statement, 1, PIBCursor(cursor)^.SQLDA);
+  if (retcode <> 0) and (retcode <> 100) then
+    CheckError('TSQLQuery.Fetch', PIBCursor(cursor)^.Status);
+
+  Result := (retcode = 100);
+end;
+
+procedure TIBConnection.LoadFieldsFromBuffer(cursor : pointer;buffer : pchar);
+var
+  x          : integer;
+  VarcharLen : word;
+begin
+  {$R-}
+  with PIBCursor(cursor)^ 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 : pointer;Field: TField; Buffer: Pointer;currbuff : pchar): Boolean;
+var
+  x : longint;
+  b : longint;
+begin
+  Result := False;
+
+  with PIBCursor(cursor)^ 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 : pointer) : TStatementType;
+var
+  x : integer;
+  ResBuf : array [0..7] of char;
+begin
+  Result := stNone;
+  x := isc_info_sql_stmt_type;
+  if isc_dsql_sql_info(@PIBCursor(cursor)^.Status, @PIBCursor(cursor)^.Statement, SizeOf(X),
+    @x, SizeOf(ResBuf), @ResBuf) <> 0 then
+    CheckError('TIBConnection.GetStatementType', PIBCursor(cursor)^.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.
+

fcl/db/sqldb/sqldb.pp

@@ -0,0 +1,616 @@
+{   $Id$
+
+    Copyright (c) 2004 by Joost van der Sluis
+
+
+    SQL database & dataset
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+unit sqldb;
+
+{$mode objfpc}
+{$H+}
+{$M+}   // ### remove this!!!
+
+interface
+
+uses SysUtils, Classes, DB;
+
+type
+  TSQLConnection = class;
+  TSQLTransaction = class;
+  TSQLQuery = class;
+
+  ESQLdbError = class(Exception);
+
+  TStatementType = (stNone, stSelect, stInsert, stUpdate, stDelete,
+    stDDL, stGetSegment, stPutSegment, stExecProcedure,
+    stStartTrans, stCommit, stRollback, stSelectForUpd);
+
+{ TSQLConnection }
+
+  TSQLConnection = class (TDatabase)
+  private
+    FPassword            : string;
+    FTransaction         : TSQLTransaction;
+    FUserName            : string;
+    FCharSet             : string;
+    FRole                : String;
+    
+    procedure SetTransaction(Value : TSQLTransaction);
+  protected
+    procedure DoInternalConnect; override;
+    procedure DoInternalDisconnect; override;
+    function GetHandle : pointer; virtual; abstract;
+  public
+    procedure StartTransaction; override;
+    procedure EndTransaction; override;
+    destructor Destroy; override;
+    function GetCursor : pointer; virtual; abstract;
+    procedure FreeCursor(cursor : pointer); virtual; abstract;
+    function GetTrans : pointer; virtual; abstract;
+    procedure FreeTrans(trans : pointer); virtual; abstract;
+    procedure AllocStatement(cursor : pointer); virtual; abstract;
+    procedure FreeStatement(cursor : pointer); virtual; abstract;
+    procedure PrepareStatement(cursor: pointer;ATransaction : TSQLTransaction;buf : string); virtual; abstract;
+    procedure DescribeStatement(cursor : pointer); virtual; abstract;
+    procedure AllocFldBuffers(cursor : pointer); virtual; abstract;
+    procedure FreeFldBuffers(cursor : pointer); virtual; abstract;
+    procedure Execute(cursor: pointer;atransaction:tSQLtransaction); virtual; abstract;
+    procedure AddFieldDefs(cursor: pointer; FieldDefs : TfieldDefs); virtual; abstract;
+    function GetFieldSizes(cursor : pointer) : integer; virtual; abstract;
+    function Fetch(cursor : pointer) : boolean; virtual; abstract;
+    procedure LoadFieldsFromBuffer(cursor : pointer;buffer : pchar); virtual; abstract;
+    function GetFieldData(cursor : pointer; Field: TField; Buffer: Pointer;currbuff : pchar): Boolean; virtual; abstract;
+    function GetStatementType(cursor : pointer) : tStatementType; virtual; abstract;
+    function GetTransactionHandle(trans : pointer): pointer; virtual; abstract;
+    function Commit(trans : pointer) : boolean; virtual; abstract;
+    function RollBack(trans : pointer) : boolean; virtual; abstract;
+    function StartTransaction(trans : pointer) : boolean; virtual; abstract;
+    procedure CommitRetaining(trans : pointer); virtual; abstract;
+    procedure RollBackRetaining(trans : pointer); virtual; abstract;
+
+    property Handle: Pointer read GetHandle;
+  published
+    property Password : string read FPassword write FPassword;
+    property Transaction : TSQLTransaction read FTransaction write SetTransaction;
+    property UserName : string read FUserName write FUserName;
+    property CharSet : string read FCharSet write FCharSet;
+
+    property Connected;
+    Property Role :  String read FRole write FRole;
+    property DatabaseName;
+    property KeepConnection;
+    property LoginPrompt;
+    property Params;
+    property OnLogin;
+  end;
+
+{ TSQLTransaction }
+
+
+  TCommitRollbackAction = (caNone, caCommit, caCommitRetaining, caRollback,
+    caRollbackRetaining);
+
+  TSQLTransaction = class (TComponent)
+  private
+    FTrans               : pointer;
+    FAction              : TCommitRollbackAction;
+    FActive              : boolean;
+    FDatabase            : TSQLConnection;
+
+    procedure SetActive(Value : boolean);
+  protected
+    function GetHandle : pointer; virtual;
+  public
+    procedure Commit; virtual;
+    procedure CommitRetaining; virtual;
+    procedure Rollback; virtual;
+    procedure RollbackRetaining; virtual;
+    procedure StartTransaction;
+    constructor Create(AOwner : TComponent); override;
+    destructor Destroy; override;
+    property Handle: Pointer read GetHandle;
+  published
+    property Action : TCommitRollbackAction read FAction write FAction;
+    property Active : boolean read FActive write SetActive;
+    property Database : TSQLConnection read FDatabase write FDatabase;
+  end;
+
+{ TSQLQuery }
+
+  TSQLQuery = class (Tbufdataset)
+  private
+    FCursor              : pointer;
+    FOpen                : Boolean;
+    FTransaction         : TSQLTransaction;
+    FDatabase            : TSQLConnection;
+    FSQL                 : TStrings;
+    FIsEOF               : boolean;
+    FStatementType       : TStatementType;
+    FLoadingFieldDefs    : boolean;
+    FRecordSize          : Integer;
+
+    procedure SetDatabase(Value : TSQLConnection);
+    procedure SetTransaction(Value : TSQLTransaction);
+    procedure AllocStatement;
+    procedure FreeStatement;
+    procedure PrepareStatement;
+    procedure DescribeStatement;
+    procedure AllocFldBuffers;
+    procedure FreeFldBuffers;
+    procedure Fetch;
+    function LoadBuffer(Buffer : PChar): TGetResult;
+    procedure GetStatementType;
+    procedure SetFieldSizes;
+
+    procedure ExecuteImmediate;
+    procedure ExecuteParams;
+    procedure Execute;
+
+  protected
+    // abstract & virual methods of TDataset
+    function AllocRecord: PChar; override;
+    procedure FreeRecord(var Buffer: PChar); override;
+    function GetFieldData(Field: TField; Buffer: Pointer): Boolean; override;
+    function GetNextRecord(Buffer : pchar) : TGetResult; override;
+    function GetRecordSize: Word; override;
+    procedure InternalAddRecord(Buffer: Pointer; AAppend: Boolean); override;
+    procedure InternalClose; override;
+    procedure InternalDelete; override;
+    procedure InternalHandleException; override;
+    procedure InternalInitFieldDefs; override;
+    procedure InternalInitRecord(Buffer: PChar); override;
+    procedure InternalOpen; override;
+    procedure InternalPost; override;
+    function IsCursorOpen: Boolean; override;
+    procedure SetFieldData(Field: TField; Buffer: Pointer); override;
+  public
+    procedure ExecSQL; virtual;
+    constructor Create(AOwner : TComponent); override;
+    destructor Destroy; override;
+  published
+    property Transaction : TSQLTransaction read FTransaction write SetTransaction;
+    property Database    : TSQLConnection read FDatabase write SetDatabase;
+    property SQL         : TStrings read FSQL write FSQL;
+    // Publish TDataset properties.
+    property Active;
+    property AutoCalcFields;
+    property BeforeOpen;
+    property AfterOpen;
+    property BeforeClose;
+    property AfterClose;
+    property BeforeInsert;
+    property AfterInsert;
+    property BeforeEdit;
+    property AfterEdit;
+    property BeforePost;
+    property AfterPost;
+    property BeforeCancel;
+    property AfterCancel;
+    property BeforeDelete;
+    property AfterDelete;
+    property BeforeScroll;
+    property AfterScroll;
+    property OnCalcFields;
+    property OnDeleteError;
+    property OnEditError;
+    property OnFilterRecord;
+    property OnNewRecord;
+    property OnPostError;
+  end;
+
+implementation
+
+{ TSQLConnection }
+
+procedure TSQLConnection.SetTransaction(Value : TSQLTransaction);
+begin
+  if FTransaction = nil then
+  begin
+    FTransaction := Value;
+    if Assigned(FTransaction) then
+      FTransaction.Database := Self;
+    exit;
+  end;
+
+  if (Value <> FTransaction) and (Value <> nil) then
+    if (not FTransaction.Active) then
+    begin
+      FTransaction := Value;
+      FTransaction.Database := Self;
+    end
+    else
+      raise ESQLdbError.Create('Cannot assign transaction while old transaction active!');
+end;
+
+procedure TSQLConnection.DoInternalConnect;
+begin
+  if Connected then
+    Close;
+end;
+
+procedure TSQLConnection.DoInternalDisconnect;
+begin
+end;
+
+procedure TSQLConnection.StartTransaction;
+begin
+  if FTransaction = nil then
+    raise EDatabaseError.Create('TSQLConnection.StartTransaction: Transaction not set');
+  FTransaction.Active := True;
+end;
+
+procedure TSQLConnection.EndTransaction;
+begin
+  if FTransaction = nil then
+    raise EDatabaseError.Create('TSQLConnection.EndTransaction: Transaction not set');
+  FTransaction.Active := False;
+end;
+
+destructor TSQLConnection.Destroy;
+begin
+  if FTransaction <> nil then
+  begin
+    FTransaction.Active := False;
+    FTransaction.Database := nil;
+  end;
+  inherited Destroy;
+end;
+
+{ TSQLTransaction }
+
+procedure TSQLTransaction.SetActive(Value : boolean);
+begin
+  if FActive and (not Value) then
+    Rollback
+  else if (not FActive) and Value then
+    StartTransaction;
+end;
+
+function TSQLTransaction.GetHandle: pointer;
+begin
+  Result := FDatabase.GetTransactionHandle(FTrans);
+end;
+
+procedure TSQLTransaction.Commit;
+begin
+  if not FActive then Exit;
+  if FDatabase.commit(FTrans) then FActive := false;
+end;
+
+procedure TSQLTransaction.CommitRetaining;
+begin
+  if not FActive then Exit;
+  FDatabase.commitRetaining(FTrans);
+end;
+
+procedure TSQLTransaction.Rollback;
+begin
+  if not FActive then Exit;
+  if FDatabase.RollBack(FTrans) then FActive := false;
+end;
+
+procedure TSQLTransaction.RollbackRetaining;
+begin
+  if not FActive then Exit;
+  FDatabase.RollBackRetaining(FTrans);
+end;
+
+procedure TSQLTransaction.StartTransaction;
+begin
+  if Active then Active := False;
+
+  if FDatabase = nil then
+    raise ESQLdbError.Create('TSQLTransaction.StartTransaction: Database not assigned!');
+
+  if not Database.Connected then
+    Database.Open;
+  if not assigned(FTrans) then FTrans := FDatabase.GetTrans;
+
+  if FDatabase.StartTransaction(FTrans) then FActive := true;
+end;
+
+constructor TSQLTransaction.Create(AOwner : TComponent);
+begin
+  inherited Create(AOwner);
+end;
+
+destructor TSQLTransaction.Destroy;
+begin
+  // This will also do a Rollback, if the transaction is currently active
+  Active := False;
+  
+  Database.FreeTrans(FTrans);
+
+  if Database <> nil then
+    Database.Transaction := nil;
+  inherited Destroy;
+end;
+
+{ TSQLQuery }
+
+procedure TSQLQuery.AllocStatement;
+
+begin
+  if FDatabase = nil then
+    raise ESQLdbError.Create('TSQLQuery.Allocstatement: Database not assigned!');
+
+  if not FDatabase.Connected then
+    Fdatabase.Open;
+  FDatabase.AllocStatement(Fcursor);
+end;
+
+procedure TSQLQuery.SetTransaction(Value : TSQLTransaction);
+begin
+  CheckInactive;
+  if (FTransaction <> Value) then
+    FTransaction := Value;
+end;
+
+procedure TSQLQuery.SetDatabase(Value : TSQLConnection);
+begin
+  CheckInactive;
+  if (FDatabase <> Value) then
+  begin
+    FDatabase := Value;
+    if (FTransaction = nil) and (Assigned(FDatabase.Transaction)) then
+      SetTransaction(FDatabase.Transaction);
+    if assigned(fcursor) then freemem(FCursor);
+    FCursor := FDatabase.getcursor;
+  end;
+end;
+
+procedure TSQLQuery.FreeStatement;
+begin
+  FDatabase.FreeStatement(FCursor);
+end;
+
+procedure TSQLQuery.PrepareStatement;
+var
+  Buf : string;
+  x   : integer;
+begin
+  if FTransaction = nil then
+    raise EDatabaseError.Create('TSQLQuery.Execute: Transaction not set');
+  if not FTransaction.Active then
+    FTransaction.StartTransaction;
+
+  for x := 0 to FSQL.Count - 1 do
+    Buf := Buf + FSQL[x] + ' ';
+
+  if Buf='' then
+    begin
+    DatabaseError('TSQLQuery: SQL statement not set');
+    exit;
+    end;
+  FDatabase.PrepareStatement(Fcursor,FTransaction,buf);
+end;
+
+procedure TSQLQuery.DescribeStatement;
+begin
+  FDatabase.DescribeStatement(FCursor);
+end;
+
+procedure TSQLQuery.AllocFldBuffers;
+
+begin
+  FDatabase.AllocFldBuffers(FCursor);
+end;
+
+procedure TSQLQuery.FreeFldBuffers;
+begin
+  FDatabase.FreeFldBuffers(FCursor);
+end;
+
+procedure TSQLQuery.Fetch;
+begin
+  if not (FStatementType in [stSelect]) then
+    Exit;
+
+  FIsEof := FDatabase.Fetch(Fcursor);
+end;
+
+function TSQLQuery.LoadBuffer(Buffer : PChar): TGetResult;
+begin
+  Fetch;
+  if FIsEOF then
+  begin
+    Result := grEOF;
+    Exit;
+  end;
+  FDatabase.LoadFieldsFromBuffer(FCursor,buffer);
+  Result := grOK;
+end;
+
+procedure TSQLQuery.GetStatementType;
+begin
+  FStatementType := FDatabase.GetStatementType(Fcursor);
+end;
+
+procedure TSQLQuery.SetFieldSizes;
+begin
+  FRecordSize := FDatabase.GetfieldSizes(Fcursor);
+end;
+
+procedure TSQLQuery.ExecuteImmediate;
+begin
+end;
+
+procedure TSQLQuery.ExecuteParams;
+begin
+  //!! to be implemented
+end;
+
+procedure TSQLQuery.Execute;
+begin
+  if FTransaction = nil then
+    raise EDatabaseError.Create('TSQLQuery.Execute: Transaction not set');
+  if not FTransaction.Active then
+    FTransaction.StartTransaction;
+  FDatabase.execute(Fcursor,FTransaction);
+end;
+
+function TSQLQuery.AllocRecord: PChar;
+begin
+  writeln('AllocRecord, Recordsize:' + inttostr(FRecordSize));
+  Result := AllocMem(FRecordSize);
+end;
+
+procedure TSQLQuery.FreeRecord(var Buffer: PChar);
+begin
+  if Assigned(@Buffer) then
+    FreeMem(Buffer);
+end;
+
+function TSQLQuery.GetFieldData(Field: TField; Buffer: Pointer): Boolean;
+begin
+  result := FDatabase.GetFieldData(Fcursor,Field,buffer,activebuffer);
+end;
+
+function TSQLQuery.GetNextRecord(Buffer: PChar): TGetResult;
+begin
+  if FIsEOF then
+    Result := grEof
+  else
+    Result := LoadBuffer(Buffer);
+end;
+
+procedure TSQLQuery.InternalAddRecord(Buffer: Pointer; AAppend: Boolean);
+begin
+  // not implemented - sql dataset
+end;
+
+procedure TSQLQuery.InternalClose;
+begin
+  FreeFldBuffers;
+  FreeStatement;
+  if DefaultFields then
+    DestroyFields;
+  FIsEOF := False;
+  FRecordSize := 0;
+  FOpen:=False;
+  inherited internalclose;
+end;
+
+procedure TSQLQuery.InternalDelete;
+begin
+  // not implemented - sql dataset
+end;
+
+procedure TSQLQuery.InternalHandleException;
+begin
+end;
+
+procedure TSQLQuery.InternalInitFieldDefs;
+begin
+  if FLoadingFieldDefs then
+    Exit;
+
+  FLoadingFieldDefs := True;
+
+  try
+    FieldDefs.Clear;
+    
+    FDatabase.AddFieldDefs(fcursor,FieldDefs);
+  finally
+    FLoadingFieldDefs := False;
+  end;
+end;
+
+procedure TSQLQuery.InternalInitRecord(Buffer: PChar);
+begin
+  FillChar(Buffer^, FRecordSize, #0);
+end;
+
+procedure TSQLQuery.InternalOpen;
+begin
+  try
+    AllocStatement;
+    PrepareStatement;
+    GetStatementType;
+    if FStatementType in [stSelect] then
+    begin
+      DescribeStatement;
+      AllocFldBuffers;
+      Execute;
+      FOpen:=True;
+      InternalInitFieldDefs;
+      if DefaultFields then
+        CreateFields;
+      SetFieldSizes;
+      BindFields(True);
+    end
+    else Execute;
+  except
+    on E:Exception do
+      raise;
+  end;
+  inherited InternalOpen;
+end;
+
+procedure TSQLQuery.InternalPost;
+begin
+  // not implemented - sql dataset
+end;
+
+function TSQLQuery.IsCursorOpen: Boolean;
+begin
+  Result := FOpen;
+end;
+
+procedure TSQLQuery.SetFieldData(Field: TField; Buffer: Pointer);
+begin
+end;
+
+// public part
+
+procedure TSQLQuery.ExecSQL;
+begin
+  AllocStatement;
+  try
+    PrepareStatement;
+    GetStatementType;
+    Execute;
+  finally
+    FreeStatement;
+  end;
+end;
+
+constructor TSQLQuery.Create(AOwner : TComponent);
+begin
+  inherited Create(AOwner);
+  FSQL := TStringList.Create;
+end;
+
+destructor TSQLQuery.Destroy;
+begin
+  if Active then Close;
+// This gives the strangest results?
+//  if assigned(Fdatabase) then FDatabase.freecursor(FCursor);
+  FSQL.Free;
+  inherited Destroy;
+end;
+
+function TSQLQuery.getrecordsize : Word;
+
+begin
+  result := FRecordSize;
+end;
+
+end.
+
+{
+  $Log$
+  Revision 1.1  2004-08-31 09:49:47  michael
+  + initial implementation of TSQLQuery
+
+}