paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-21 11:29:24 +02:00
Code Issues Packages Projects Releases Wiki Activity

+ initial implementation of TSQLQuery

Browse Source
This commit is contained in:
michael 2004-08-31 09:49:47 +00:00
parent d7b63f9440
commit cc17451cd4
6 changed files with 4633 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1701
fcl/db/sqldb/Makefile Normal file
View File

File diff suppressed because it is too large Load Diff

31
fcl/db/sqldb/Makefile.fpc Normal file
View File

@ -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=../../..

1621
fcl/db/sqldb/interbase/Makefile Normal file
View File

File diff suppressed because it is too large Load Diff

22
fcl/db/sqldb/interbase/Makefile.fpc Normal file
View File

@ -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=../../../..

642
fcl/db/sqldb/interbase/ibconnection.pp Normal file
View File

@ -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.

616
fcl/db/sqldb/sqldb.pp Normal file
View File

@ -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
}