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

+ Initial implementation in FCL

Browse Source
This commit is contained in:
michael 2000-06-04 08:15:42 +00:00
parent b856a450bd
commit 80a5033038
7 changed files with 2236 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
fcl/db/interbase/BUGS.known Normal file
View File

@ -0,0 +1,2 @@
* TDateTime field interpretation
* Some problems with TIBDataset.Close (fields)

1218
fcl/db/interbase/Makefile Normal file
View File

File diff suppressed because it is too large Load Diff

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

@ -0,0 +1,22 @@
#
# Makefile.fpc for interbase dataset
#
[targets]
units=interbase
programs=testib
[defaults]
defaultcpu=i386
[require]
options=-S2
packages=fcl ibase
[dirs]
fpcdir=../..
targetdir=.
unitdir=..
[libs]
libgcc=1

23
fcl/db/interbase/README Normal file
View File

@ -0,0 +1,23 @@
This is first working release of TDatabase and TDataset
implementation for Interbase SQL server.
Compiling the units:
Run 'make; make examples' command, if something goes wrong, look if you have
1) unit ibase60 in compiler path
2) gds.so.0 library in /usr/lib
Command 'sh mkdb' creates testing database in current directory.
Unit interbase.pp was made and tested on Linux, on ib60 server,
I don't know if it's working on other OS platforms or other
versions of IB server.
Unit in these days provides objective connectivity to IB server,
basic SQL statement support. It's still buggy, so volunteers
and contributors are welcome. It supports SQL dialect 1 only
(You cannot use date & time datatypes in tables).
Pavel Stingl
stingp1.eti@mail.cez.cz

848
fcl/db/interbase/interbase.pp Normal file
View File

@ -0,0 +1,848 @@
{
$Id$
Copyright (c) 2000 by Pavel Stingl
Interbase database & dataset
Roughly based on work of FPC development team,
especially Michael Van Canneyt
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 interbase;
{$H+}
interface
uses SysUtils, Classes, ibase60, Db;
type
PInteger = ^integer;
TIBDatabase = class (TDatabase)
private
FIBDatabaseHandle : pointer;
FIBTransactionHandle : pointer;
FPassword : string;
FStatus : array [0..19] of ISC_STATUS;
FUserName : string;
procedure CheckError(ProcName : string);
protected
procedure DoInternalConnect; override;
procedure DoInternalDisconnect; override;
public
constructor Create(AOwner : TComponent); override;
procedure CommitTransaction; virtual;
procedure RollbackTransaction; virtual;
procedure StartTransaction; override;
procedure EndTransaction; override;
property DatabaseHandle: pointer read FIBDatabaseHandle;
property TransactionHandle: pointer read FIBTransactionHandle;
published
property Password: string read FPassword write FPassword;
property UserName: string read FUserName write FUserName;
property Connected;
property DatabaseName;
property KeepConnection;
property LoginPrompt;
property Params;
property OnLogin;
end;
PIBBookmark = ^TIBBookmark;
TIBBookmark = record
BookmarkData: Integer;
BookmarkFlag: TBookmarkFlag;
end;
// TStatementType indicates if SQL statement returns
// result set.
TStatementType = (stResult, stNoResult, stDDL);
TIBDataset = class (TDataset)
private
FBufferSize : longint;
FCurrentRecord : longint;
FCurrStmtType : TStatementType;
FDatabase : TIBDatabase;
FFlag : array [0..1024] of shortint;
FIsEOF : boolean;
FLoadingFieldDefs : boolean;
FSQLPrepared : boolean;
FRecordSize : word;
FRecordCount : integer;
FSQL : TStrings;
FSQLDA : PXSQLDA;
FSQLDAAllocated : longint;
FStatementHandle : pointer;
FStatus : array [0..19] of ISC_STATUS;
FDBHandle : pointer;
FTRHandle : pointer;
procedure CheckError(ProcName : string);
procedure DoAssignBuffers;
procedure DoExecSQL;
procedure DoFetch;
procedure DoFreeBuffers;
procedure DoParseSQL;
procedure DoSQLDAAlloc(Count : longint);
procedure DoStmtAlloc;
procedure DoStmtDealloc;
procedure SetBufExtended(Field : TField; CurrBuff,Buffer : pointer);
procedure SetBufInteger(Field : TField; CurrBuff,Buffer : pointer);
procedure SetBufDateTime(Field : TField; CurrBuff,Buffer : pointer; AType : integer);
procedure SetBufString(Field : TField; CurrBuff,Buffer : pointer);
function GetStmtType: TStatementType;
function LoadBufferFromData(Buffer : PChar): TGetResult;
procedure SetDatabase(Value : TIBDatabase);
procedure SetSizes;
procedure TranslateFieldType(AType, AScale: longint;
var XType: TFieldType; var XScale: word);
protected
function AllocRecordBuffer: PChar; override;
procedure FreeRecordBuffer(var Buffer: PChar); override;
procedure GetBookmarkData(Buffer: PChar; Data: Pointer); override;
function GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; override;
function GetFieldData(Field: TField; Buffer: Pointer): Boolean; override;
function GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult; override;
function GetRecordSize: Word; override;
function GetRecordCount: integer; override;
procedure InternalAddRecord(Buffer: Pointer; AAppend: Boolean); override;
procedure InternalClose; override;
procedure InternalDelete; override;
procedure InternalFirst; override;
procedure InternalGotoBookmark(ABookmark: Pointer); override;
procedure InternalHandleException; override;
procedure InternalInitFieldDefs; override;
procedure InternalInitRecord(Buffer: PChar); override;
procedure InternalLast; override;
procedure InternalOpen; override;
procedure InternalPost; override;
procedure InternalSetToRecord(Buffer: PChar); override;
function IsCursorOpen: Boolean; override;
procedure SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); override;
procedure SetBookmarkData(Buffer: PChar; Data: Pointer); override;
procedure SetFieldData(Field: TField; Buffer: Pointer); override;
public
constructor Create(AOwner : TComponent); override;
destructor Destroy; override;
published
property SQL : TStrings read FSQL write FSQL;
property Database : TIBDatabase read FDatabase write SetDatabase;
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;
///////////////////////////////////////////////////////////////////////
// TIBDatabase implementation
//
// PRIVATE PART of TIBDatabase
{---------------------------------------------------------------------}
{ CheckError }
{ This procedure checks IB status vector and, if found some error }
{ condition, raises exception with IB error text }
{---------------------------------------------------------------------}
procedure TIBDatabase.CheckError(ProcName:string);
var
buf : array [0..1024] of char;
P : pointer;
x : integer;
begin
if ((FStatus[0] = 1) and (FStatus[1] <> 0)) then
begin
p := @FStatus;
isc_interprete(Buf, @p);
raise Exception.Create(ProcName + ': ' + StrPas(buf));
end;
end;
// PROTECTED PART of TIBDatabase
procedure TIBDatabase.DoInternalConnect;
var
DPB : string;
begin
if Connected then
Close;
DPB := chr(isc_dpb_version1);
if (FUserName <> '') then
begin
DPB := DPB + chr(isc_dpb_user_name) + chr(Length(FUserName)) + FUserName;
if (FPassword <> '') then
DPB := DPB + chr(isc_dpb_password) + chr(Length(FPassword)) + FPassword;
end;
if (DatabaseName = '') then
raise Exception.Create('TIBDatabase.Open: Database connect string not filled in!');
FIBDatabaseHandle := nil;
if isc_attach_database(@FStatus, Length(DatabaseName), @DatabaseName[1], @FIBDatabaseHandle,
Length(DPB), @DPB[1]) <> 0 then
CheckError('TIBDatabase.Open');
end;
procedure TIBDatabase.DoInternalDisconnect;
begin
if not Connected then
begin
FIBDatabaseHandle := nil;
Exit;
end;
isc_detach_database(@FStatus[0], @FIBDatabaseHandle);
CheckError('TIBDatabase.Close');
end;
// PUBLIC PART of TIBDatabase
constructor TIBDatabase.Create(AOwner : TComponent);
begin
inherited Create(AOwner);
FIBDatabaseHandle := nil;
FIBTransactionHandle := nil;
FUserName := '';
FPassword := '';
end;
procedure TIBDatabase.CommitTransaction;
begin
if FIBTransactionHandle <> nil then
if isc_commit_retaining(@FStatus, @FIBTransactionHandle) <> 0 then
CheckError('TIBDatabase.CommitTransaction');
end;
procedure TIBDatabase.RollbackTransaction;
begin
if FIBTransactionHandle <> nil then
if isc_rollback_retaining(@FStatus, FIBTransactionHandle) <> 0 then
CheckError('TIBDatabase.RollbackTransaction');
end;
procedure TIBDatabase.StartTransaction;
begin
if FIBTransactionHandle = nil then
begin
if isc_start_transaction(@FStatus, @FIBTransactionHandle, 1, [@FIBDatabaseHandle, 0, nil]) <> 0 then
CheckError('TIBDatabase.StartTransaction');
end;
end;
procedure TIBDatabase.EndTransaction;
begin
if FIBTransactionHandle <> nil then
begin
if isc_commit_transaction(@FStatus, @FIBTransactionHandle) <> 0 then
CheckError('TIBDatabase.EndTransaction');
FIBTransactionHandle := nil;
end;
end;
///////////////////////////////////////////////////////////////////////
// TIBDataset implementation
//
// PRIVATE PART
procedure TIBDataset.CheckError(ProcName : string);
var
buf : array [0..1024] of char;
P : pointer;
Msg : string;
x : integer;
begin
if ((FStatus[0] = 1) and (FStatus[1] <> 0)) then
begin
p := @FStatus;
while isc_interprete(Buf, @p) > 0 do
Msg := Msg + #10' -' + StrPas(Buf);
raise Exception.Create(ProcName + ': ' + Msg);
end;
end;
procedure TIBDataset.DoAssignBuffers;
var
Buf : PChar;
x : longint;
begin
for x := 0 to FSQLDA^.SQLD - 1 do
begin
Buf := AllocMem(FSQLDA^.SQLVar[x].SQLLen);
FSQLDA^.SQLVar[x].SQLData := Buf;
FSQLDA^.SQLVar[x].SQLInd := @FFlag[x];
end;
end;
procedure TIBDataset.DoExecSQL;
begin
if isc_dsql_execute(@FStatus, @FTrHandle, @FStatementHandle, 1, nil) <> 0 then
CheckError('TIBDataset.DoExecSQL');
end;
procedure TIBDataset.DoFetch;
var
Res : longint;
begin
if FCurrStmtType <> stResult then Exit;
Res := isc_dsql_fetch(@FStatus, @FStatementHandle, 1, FSQLDA);
if (Res <> 100) then
CheckError('TIBDataset.DoFetch');
FIsEOF := (Res = 100);
end;
procedure TIBDataset.DoFreeBuffers;
var
x : longint;
begin
for x := 0 to FSQLDA^.SQLD - 1 do
if (FSQLDA^.SQLVar[x].SQLData <> nil) then
FreeMem(FSQLDA^.SQLVar[x].SQLData);
end;
procedure TIBDataset.DoParseSQL;
var
Buf : string;
x : longint;
begin
if FSQL.Count < 1 then
raise Exception.Create('TIBDataset.DoParseSQL: Empty SQL statement');
Buf := '';
for x := 0 to FSQL.Count - 1 do
Buf := Buf + FSQL[x] + ' ';
if isc_dsql_prepare(@FStatus, @FTrHandle, @FStatementHandle, 0, @Buf[1], 1, nil) <> 0 then CheckError('TIBDataset.DoParseSQL - Prepare');
if isc_dsql_describe(@FStatus, @FStatementHandle, 1, FSQLDA) <> 0 then
CheckError('TIBDataset.DoParseSQL - Describe');
if FSQLDA^.SQLN < FSQLDA^.SQLD then
begin
x := FSQLDA^.SQLD;
DoSQLDAAlloc(x);
if isc_dsql_describe(@FStatus, @FStatementHandle, 1, FSQLDA) <> 0 then
CheckError('TIBDataset.DoParseSQL - Describe');
end;
FCurrStmtType := GetStmtType;
FSQLPrepared := True;
end;
procedure TIBDataset.DoSQLDAAlloc(Count : longint);
begin
if FSQLDAAllocated > 0 then
FreeMem(FSQLDA, XSQLDA_Length * FSQLDAAllocated);
GetMem(FSQLDA, XSQLDA_Length * Count);
FSQLDAAllocated := Count;
FSQLDA^.Version := SQLDA_VERSION1;
FSQLDA^.SQLN := Count;
end;
procedure TIBDataset.DoStmtAlloc;
begin
if not FDatabase.Connected then
FDatabase.Open;
if FDatabase.TransactionHandle = nil then
FDatabase.StartTransaction;
FDBHandle := FDatabase.DatabaseHandle;
FTRHandle := FDatabase.TransactionHandle;
if isc_dsql_allocate_statement(@FStatus, @FDBHandle, @FStatementHandle) <> 0 then
CheckError('TIBDataset.DoStmtAlloc');
end;
procedure TIBDataset.DoStmtDealloc;
begin
if isc_dsql_free_statement(@FStatus, @FStatementHandle, DSQL_Drop) <> 0 then
CheckError('TIBDataset.DoStmtDealloc');
FStatementHandle := nil;
end;
function TIBDataset.GetStmtType: TStatementType;
var
ResBuf : array [0..7] of char;
x : integer;
SType : integer;
begin
x := isc_info_sql_stmt_type;
isc_dsql_sql_info(@FStatus, @FStatementHandle, SizeOf(x),
@x, SizeOf(ResBuf), @ResBuf);
if Ord(ResBuf[0]) = isc_info_sql_stmt_type then
begin
x := isc_vax_integer(@ResBuf[1], 2);
SType := isc_vax_integer(@ResBuf[3], x);
end;
case SType of
isc_info_sql_stmt_select:
Result := stResult;
isc_info_sql_stmt_insert, isc_info_sql_stmt_update,
isc_info_sql_stmt_delete:
Result := stNoResult;
else Result := stDDL;
end;
end;
function TIBDataset.LoadBufferFromData(Buffer : PChar): TGetResult;
var
x : integer;
p : word;
T : TISC_TIMESTAMP;
begin
DoFetch;
if FIsEOF then
Result := grEOF
else begin
for x := 0 to FSQLDA^.SQLD - 1 do
begin
if (FSQLDA^.SQLVar[x].SQLType = SQL_VARYING) or
(FSQLDA^.SQLVar[x].SQLType = SQL_VARYING + 1) then
begin
Move(FSQLDA^.SQLVar[x].SQLData^, P, 2);
Move((FSQLDA^.SQLVar[x].SQLData + 2)^, Buffer^, P);
PChar(Buffer+P)^ := #0;
end
else
Move(FSQLDA^.SQLVar[x].SQLData^, Buffer^, FSQLDA^.SQLVar[x].SQLLen);
Inc(Buffer,FSQLDA^.SQLVar[x].SQLLen);
end;
Result := grOK;
end;
end;
procedure TIBDataset.SetDatabase(Value : TIBDatabase);
begin
CheckInactive;
If Value<>FDatabase then
begin
if Value<>Nil Then
FDatabase:=Value;
end;
end;
procedure TIBDataset.SetSizes;
var
x : integer;
begin
FRecordSize := 0;
FBufferSize := 0;
for x := 0 to FSQLDA^.SQLD - 1 do
begin
Inc(FRecordSize, FSQLDA^.SQLVar[x].SQLLen);
end;
FBufferSize := FRecordSize + SizeOf(TIBBookmark);
end;
procedure TIBDataset.TranslateFieldType(AType, AScale: longint;
var XType: TFieldType; var XScale: word);
begin
case AType of
SQL_TEXT, SQL_VARYING, SQL_TEXT+1, SQL_VARYING+1:
begin
XType := ftString;
XScale := AScale;
end;
SQL_DOUBLE, SQL_DOUBLE+1:
begin
XType := ftFloat;
XScale := AScale;
end;
SQL_LONG, SQL_LONG+1, SQL_SHORT, SQL_SHORT+1:
begin
XType := ftInteger;
XScale := AScale;
end;
{ SQL_DATE, SQL_DATE+1, SQL_TIME, SQL_TIME+1,}
SQL_TYPE_TIME:
begin
XType := ftTime;
XScale := AScale;
end;
SQL_TYPE_DATE:
begin
XType := ftDate;
XScale := AScale;
end;
SQL_FLOAT,SQL_FLOAT+1:
begin
XType := ftFloat;
XScale := AScale;
end;
SQL_TIMESTAMP, SQL_TIMESTAMP+1:
begin
XType := ftDateTime;
XScale := AScale;
end;
end;
end;
// PROTECTED PART
function TIBDataset.AllocRecordBuffer: PChar;
begin
Result := AllocMem(FBufferSize);
end;
procedure TIBDataset.FreeRecordBuffer(var Buffer: PChar);
begin
FreeMem(Buffer);
end;
procedure TIBDataset.GetBookmarkData(Buffer: PChar; Data: Pointer);
begin
PInteger(Data)^ := PIBBookmark(Buffer + FRecordSize)^.BookmarkData;
end;
function TIBDataset.GetBookmarkFlag(Buffer: PChar): TBookmarkFlag;
begin
Result := PIBBookmark(Buffer + FRecordSize)^.BookmarkFlag;
end;
procedure TIBDataset.SetBufExtended(Field : TField; CurrBuff,Buffer : pointer);
var
E : extended;
D : double;
S : single;
begin
case Field.Size of
4 :
begin
Move(CurrBuff^,S,4);
E := S;
end;
8 :
begin
Move(CurrBuff^,D,8);
E := D;
end;
10 : Move(CurrBuff^,E,10);
end;
Move(E, Buffer^, 10);
end;
procedure TIBDataset.SetBufInteger(Field : TField; CurrBuff,Buffer : pointer);
var
I : integer;
begin
I := 0;
Move(I, Buffer^, SizeOf(Integer));
Move(CurrBuff^, Buffer^, Field.Size);
end;
procedure TIBDataset.SetBufDateTime(Field : TField; CurrBuff,Buffer : pointer; AType : integer);
var
D : TDateTime;
S : TSystemTime;
TM : TTm;
TT : TIsc_timestamp;
begin
case AType of
SQL_TYPE_DATE:
isc_decode_sql_date(PISC_DATE(CurrBuff), @TM);
SQL_TYPE_TIME:
isc_decode_sql_time(PISC_TIME(CurrBuff), @TM);
SQL_TIMESTAMP, SQL_TIMESTAMP+1:
isc_decode_timestamp(PISC_TIMESTAMP(CurrBuff), @TM);
end;
S.Year := TM.tm_year + 1900;
S.Month := TM.tm_mon + 1;
S.Day := TM.tm_mday;
S.Hour := TM.tm_hour;
S.Minute := TM.tm_min;
S.Second := TM.tm_sec;
S.Millisecond := 0;
D := SystemTimeToDateTime(S);
{$warning !!! D is okay, but Field.AsDateTime returns wrong value !!! }
// WriteLn(DateTimeToStr(D));
Move(D, Buffer^, SizeOf(D));
end;
procedure TIBDataset.SetBufString(Field : TField; CurrBuff,Buffer : pointer);
begin
Move(CurrBuff^, Buffer^, Field.Size);
PChar(Buffer + Field.Size)^ := #0;
end;
function TIBDataset.GetFieldData(Field: TField; Buffer: Pointer): Boolean;
var
x : longint;
CurrBuff : PChar;
begin
Result := False;
CurrBuff := ActiveBuffer;
for x := 0 to FSQLDA^.SQLD - 1 do
begin
if (Field.FieldName = FSQLDA^.SQLVar[x].SQLName) then
begin
case Field.DataType of
ftFloat:
SetBufExtended(Field, CurrBuff, Buffer);
ftString:
SetBufString(Field, CurrBuff, Buffer);
ftDate,ftTime,ftDateTime:
SetBufDateTime(Field, CurrBuff, Buffer, FSQLDA^.SQLVar[x].SQLType);
ftInteger:
SetBufInteger(Field, CurrBuff, Buffer);
end;
Result := True;
break;
end
else Inc(CurrBuff, FSQLDA^.SQLVar[x].SQLLen);
end;
end;
function TIBDataset.GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult;
begin
if FCurrStmtType <> stResult then Exit;
if FIsEOF then
Result := grEOF
else begin
Result := grOk;
case GetMode of
gmPrior:
if FCurrentRecord <= 0 then
begin
Result := grBOF;
FCurrentRecord := -1;
end
else Dec(FCurrentRecord);
gmCurrent:
if (FCurrentRecord < 0) or (FCurrentRecord >= RecordCount) then
Result := grError;
gmNext:
if FCurrentRecord >= (RecordCount - 1) then
begin
Result := LoadBufferFromData(Buffer);
if Result = grOk then
begin
Inc(FCurrentRecord);
Inc(FRecordCount);
end;
end
else Inc(FCurrentRecord);
end;
if Result = grOK then
begin
with PIBBookmark(Buffer + FRecordSize)^ do
begin
BookmarkData := FCurrentRecord;
BookmarkFlag := bfCurrent;
end;
end
else if (Result = grError) {and (DoCheck)} then
DatabaseError('No record');
end;
end;
function TIBDataset.GetRecordCount: integer;
begin
Result := FRecordCount;
end;
function TIBDataset.GetRecordSize: Word;
begin
Result := FRecordSize;
end;
procedure TIBDataset.InternalAddRecord(Buffer: Pointer; AAppend: Boolean);
begin
end;
procedure TIBDataset.InternalClose;
begin
DoFreeBuffers;
DoStmtDealloc;
if DefaultFields then
DestroyFields;
FIsEOF := False;
FCurrentRecord := -1;
FBufferSize := 0;
FRecordSize := 0;
FRecordCount := 0;
// DoSQLDAAlloc(50);
end;
procedure TIBDataset.InternalDelete;
begin
end;
procedure TIBDataset.InternalFirst;
begin
FCurrentRecord := -1;
end;
procedure TIBDataset.InternalGotoBookmark(ABookmark: Pointer);
begin
FCurrentRecord := PInteger(ABookmark)^;
end;
procedure TIBDataset.InternalHandleException;
begin
// not implemented
end;
procedure TIBDataset.InternalInitFieldDefs;
var
x : longint;
TransFt : TFieldType;
TransSz : word;
begin
if FLoadingFieldDefs then
begin
WriteLn('Loading FieldDefs...');
Exit;
end;
FLoadingFieldDefs := True;
try
try
FieldDefs.Clear;
for x := 0 to FSQLDA^.SQLD - 1 do
begin
TranslateFieldType(FSQLDA^.SQLVar[x].SQLType, FSQLDA^.SQLVar[x].SQLLen,
TransFt, TransSz);
TFieldDef.Create(FieldDefs,
FSQLDA^.SQLVar[x].SQLName,
TransFt, TransSz, False, (x+1));
end;
finally
end;
finally
FLoadingFieldDefs := False;
end;
end;
procedure TIBDataset.InternalInitRecord(Buffer: PChar);
begin
FillChar(Buffer^, FBufferSize, #0);
end;
procedure TIBDataset.InternalLast;
begin
FCurrentRecord := RecordCount;
end;
procedure TIBDataset.InternalOpen;
begin
try
DoStmtAlloc;
DoParseSQL;
if FCurrStmtType = stResult then
begin
DoAssignBuffers;
DoExecSQL;
InternalInitFieldDefs;
if DefaultFields then
CreateFields;
SetSizes;
BindFields(True);
end
else DoExecSQL;
except
raise;
end;
end;
procedure TIBDataset.InternalPost;
begin
end;
procedure TIBDataset.InternalSetToRecord(Buffer: PChar);
begin
FCurrentRecord := PIBBookmark(Buffer + FRecordSize)^.BookmarkData;
end;
function TIBDataset.IsCursorOpen: Boolean;
begin
Result := FStatementHandle <> nil; //??
end;
procedure TIBDataset.SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag);
begin
PIBBookmark(Buffer + FRecordSize)^.BookmarkFlag := Value;
end;
procedure TIBDataset.SetBookmarkData(Buffer: PChar; Data: Pointer);
begin
PIBBookmark(Buffer + FRecordSize)^.BookmarkData := PInteger(Data)^;
end;
procedure TIBDataset.SetFieldData(Field: TField; Buffer: Pointer);
begin
end;
// PUBLIC PART
constructor TIBDataset.Create(AOwner : TComponent);
begin
inherited Create(AOwner);
FSQL := TStringList.Create;
FIsEOF := False;
FCurrentRecord := -1;
FBufferSize := 0;
FRecordSize := 0;
FRecordCount := 0;
DoSQLDAAlloc(50);
end;
destructor TIBDataset.Destroy;
begin
FSQL.Free;
inherited Destroy;
FreeMem(FSQLDA, XSQLDA_Length * FSQLDAAllocated);
end;
end.
{
$Log$
Revision 1.1 2000-06-04 08:15:42 michael
+ Initial implementation in FCL
Revision 1.1.1.1 2000/06/02 06:56:37 stingp1
Initial release
}

48
fcl/db/interbase/mkdb Normal file
View File

@ -0,0 +1,48 @@
#!/bin/sh
#
# Script to create a table 'FPdev' and to fill it with data.
# The script accepts an optional argument :
# A database to connect to. (default 'testdb')
#
# Collect the database
DATABASE=testdb.gdb
# Choose one of the following:
# ISQL=isql
ISQL=/usr/interbase/bin/isql
#
# Don't edit after this.
#
echo -n "Creating and filling table FPdev in database $DATABASE..."
# >/dev/null 2>&1
${ISQL} << EOF
CREATE DATABASE "$DATABASE";
create table FPdev (
id INT NOT NULL,
UserName varchar(50),
InstEmail CHAR(50),
PRIMARY KEY (id));
insert into FPdev values ('1','Michael Van Canneyt','Michael@tfdec1.fys.kuleuven.ac.be');
insert into FPdev values ('2','Florian Klaempfl','ba2395@fen.baynet.de');
insert into FPdev values ('3','Carl-Eric Codere','codc01@gel.usherb.ca');
insert into FPdev values ('4','Daniel Mantione','d.s.p.mantione@twi.tudelft.nl');
insert into FPdev values ('5','Pierre Muller','muller@europe.u-strasbg.fr');
insert into FPdev values ('6','Jonas Maebe','jmaebe@mail.dma.be');
insert into FPdev values ('7','Peter Vreman','pfv@worldonline.nl');
insert into FPdev values ('8','Gerry Dubois','gerry@webworks.ml.org');
create table test (
timestamp_fld timestamp,
smallint_fld smallint,
integer_fld integer,
float_fld float,
double_fld double precision,
char_fld char(10),
varchar_fld varchar(50));
insert into test values ('12.1.2000 00:30',10,70000,12.5,20.5,'testchar','testvarchar');
commit;
EOF
if [ ! $? = 0 ]; then
echo "Failed."
else
echo "Done."
fi
# Ready

75
fcl/db/interbase/testib.pp Normal file
View File

@ -0,0 +1,75 @@
// $Id$
// Test program for interbase.pp unit
program testib;
uses Interbase,SysUtils,db;
{$linklib dl}
{$linklib crypt}
const
dbpath = 'obelix.wisa.be:/home/interbase/helpdesk.gdb';
var
DBS : TIBDatabase;
DS : TIBDataset;
x : integer;
S : TSystemTime;
begin
DBS := TIBDatabase.Create(nil);
DS := TIBDataset.Create(nil);
DS.Database := DBS;
DBS.DatabaseName := dbpath;
DBS.UserName := 'SYSDBA';
DBS.Password := 'masterkey';
DBS.Connected:=True;
DS.SQL.Add('select * from scholen');
DS.Open;
while not DS.EOF do
begin
for x := 0 to DS.FieldCount - 2 do
Write(DS.Fields[x].AsString,',');
WriteLn(DS.Fields[DS.FieldCount-1].AsString);
DS.Next;
end;
DS.Close;
DS.SQL.Clear;
DS.Free;
{
WriteLn;
WriteLn('Trying to perform test of datatypes interpretation...');
WriteLn('Some problems with TDateTimeField, see source');
DS := TIBDataset.Create(nil);
DS.Database := DBS;
DS.SQL.Add('select * from test');
DS.Open;
while not DS.EOF do
begin
{ Warning - TDateTimeField.AsDateTime returns wrong values,
but conversions in TIBDataset are OK! }
for x := 0 to DS.FieldCount - 1 do
if (DS.Fields[x].DataType = ftDateTime) then
WriteLn(DS.Fields[x].FieldName, ' : "',
FormatDateTime('DD.MM.YYYY HH:MM:SS',DS.Fields[x].AsDateTime),'"')
else WriteLn(DS.Fields[x].FieldName, ' : "',DS.Fields[x].AsString,'"');
DS.Next;
end;
DS.Free;
}
DBS.EndTransaction;
DBS.Close;
DBS.Free;
end.
{
$Log$
Revision 1.1 2000-06-04 08:15:43 michael
+ Initial implementation in FCL
Revision 1.1.1.1 2000/06/02 06:56:37 stingp1
Initial release
}