From a400014d544dabd69b60c6e5c347008a009614ad Mon Sep 17 00:00:00 2001 From: peter Date: Tue, 10 Apr 2001 21:31:35 +0000 Subject: [PATCH] * add mode objfpc --- fcl/db/interbase/interbase.pp | 169 +++++++++++++++++----------------- 1 file changed, 85 insertions(+), 84 deletions(-) diff --git a/fcl/db/interbase/interbase.pp b/fcl/db/interbase/interbase.pp index 499ded2b36..73015ff386 100644 --- a/fcl/db/interbase/interbase.pp +++ b/fcl/db/interbase/interbase.pp @@ -1,10 +1,10 @@ -{ $Id$ - +{ $Id$ + Copyright (c) 2000 by Pavel Stingl Interbase database & dataset - + See the file COPYING.FPC, included in this distribution, for details about the copyright. @@ -16,6 +16,7 @@ unit Interbase; +{$mode objfpc} {$H+} interface @@ -26,14 +27,14 @@ type PInteger = ^integer; PSmallInt= ^smallint; - + TIBDatabase = class; TIBTransaction = class; TIBQuery = class; TIBStoredProc = class; - + { TIBDatabase } - + TIBDatabase = class (TDatabase) private FIBDatabaseHandle : pointer; @@ -42,20 +43,20 @@ type FTransaction : TIBTransaction; FUserName : string; FDialect : integer; - + procedure SetDBDialect; procedure SetTransaction(Value : TIBTransaction); protected function GetHandle : pointer; virtual; { This procedure makes connection to Interbase server internally. Is visible only by descendants, in application programming - will be invisible. Connection you must establish by setting + will be invisible. Connection you must establish by setting @link(Connected) property to true, or by call of Open method. } procedure DoInternalConnect; override; { This procedure disconnects object from IB server internally. Is visible only by descendants, in application programming - will be invisible. Disconnection you must make by setting + will be invisible. Disconnection you must make by setting @link(Connected) property to false, or by call of Close method. } procedure DoInternalDisconnect; override; @@ -105,32 +106,32 @@ type If you, on other side, need only commit or rollback data without transaction closing, execute with CommitRetaining or RollbackRetaining. Transaction handle, environment etc. will be - as same as before action. Possible values are : caNone, caCommit, caCommitRetaining, caRollback, + as same as before action. Possible values are : caNone, caCommit, caCommitRetaining, caRollback, caRollbackRetaining } - - TCommitRollbackAction = (caNone, caCommit, caCommitRetaining, caRollback, + + TCommitRollbackAction = (caNone, caCommit, caCommitRetaining, caRollback, caRollbackRetaining); TAccessMode = (amReadWrite, amReadOnly); TIsolationLevel = (ilConcurrent, ilConsistent, ilReadCommittedRecV, ilReadCommitted); TLockResolution = (lrWait, lrNoWait); - TTableReservation = (trNone, trSharedLockRead, trSharedLockWrite, + TTableReservation = (trNone, trSharedLockRead, trSharedLockWrite, trProtectedLockRead, trProtectedLockWrite); - + TIBTransaction = class (TComponent) private FTransactionHandle : pointer; // Transaction handle - FAction : TCommitRollbackAction; + FAction : TCommitRollbackAction; FActive : boolean; FTPB : string; // Transaction parameter buffer FDatabase : TIBDatabase; FAccessMode : TAccessMode; FIsolationLevel : TIsolationLevel; FLockResolution : TLockResolution; - FTableReservation : TTableReservation; + FTableReservation : TTableReservation; FStatus : array [0..19] of ISC_STATUS; - + procedure SetActive(Value : boolean); procedure SetTPB; protected @@ -150,11 +151,11 @@ type constructor Create(AOwner : TComponent); override; destructor Destroy; override; published - { Default action while closing transaction by setting + { Default action while closing transaction by setting @link(Active) property. For details see @link(TCommitRollbackAction)} property Action : TCommitRollbackAction read FAction write FAction; { Is set to true while transaction is active, false if not. - If you set it manually to true, object executes + If you set it manually to true, object executes @link(StartTransaction) method, if transaction is active, and you set Active to false, object executes one of @link(Commit), @link(CommitRetaining), @link(Rollback), @@ -166,7 +167,7 @@ type you must use this property} property Database : TIBDatabase read FDatabase write FDatabase; end; - + { TIBQuery } PIBBookmark = ^TIBBookmark; @@ -174,11 +175,11 @@ type BookmarkData : integer; BookmarkFlag : TBookmarkFlag; end; - + TStatementType = (stNone, stSelect, stInsert, stUpdate, stDelete, stDDL, stGetSegment, stPutSegment, stExecProcedure, stStartTrans, stCommit, stRollback, stSelectForUpd); - + TIBQuery = class (TDBDataset) private FTransaction : TIBTransaction; @@ -197,7 +198,7 @@ type FIsEOF : boolean; FStatementType : TStatementType; FLoadingFieldDefs : boolean; - + procedure SetDatabase(Value : TIBDatabase); procedure SetTransaction(Value : TIBTransaction); procedure AllocSQLDA(Count : integer); @@ -218,13 +219,13 @@ type procedure ExecuteImmediate; procedure ExecuteParams; procedure Execute; - + // conversion methods procedure GetDateTime(CurrBuff, Buffer : pointer; AType : integer); procedure GetFloat(CurrBuff, Buffer : pointer; Field : TField); protected - + // abstract & virual methods of TDataset function AllocRecordBuffer: PChar; override; procedure FreeRecordBuffer(var Buffer: PChar); override; @@ -265,9 +266,9 @@ type { This property holds SQL command, which you want to execute } property SQL : TStrings read FSQL write FSQL; end; - + { TIBStoredProc - not implemented - yet :-/} - + TIBStoredProc = class (TDataset) private protected @@ -324,16 +325,16 @@ begin x := 0; while x < 40 do case ResBuf[x] of - isc_info_db_sql_dialect : + 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); + Inc(x, Len); end; isc_info_end : Break; - end; + end; end; procedure TIBDatabase.SetTransaction(Value : TIBTransaction); @@ -344,14 +345,14 @@ begin 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 Exception.Create('Cannot assign transaction while old transaction active!'); + else Exception.Create('Cannot assign transaction while old transaction active!'); end; function TIBDatabase.GetHandle: pointer; @@ -364,7 +365,7 @@ var DPB : string; begin if Connected then - Close; + Close; DPB := chr(isc_dpb_version1); if (FUserName <> '') then begin @@ -375,7 +376,7 @@ begin 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, + if isc_attach_database(@FStatus, Length(DatabaseName), @DatabaseName[1], @FIBDatabaseHandle, Length(DPB), @DPB[1]) <> 0 then CheckError('TIBDatabase.Open', FStatus); SetDBDialect; @@ -396,14 +397,14 @@ procedure TIBDatabase.StartTransaction; begin if FTransaction = nil then raise EDatabaseError.Create('TIBDatabase.StartTransaction: Transaction not set'); - FTransaction.Active := True; + FTransaction.Active := True; end; procedure TIBDatabase.EndTransaction; begin if FTransaction = nil then raise EDatabaseError.Create('TIBDatabase.EndTransaction: Transaction not set'); - FTransaction.Active := False; + FTransaction.Active := False; end; constructor TIBDatabase.Create(AOwner : TComponent); @@ -452,7 +453,7 @@ begin amReadWrite : FTPB := FTPB + chr(isc_tpb_write); amReadOnly : FTPB := FTPB + chr(isc_tpb_read); end; - + case FIsolationLevel of ilConsistent : FTPB := FTPB + chr(isc_tpb_consistency); ilConcurrent : FTPB := FTPB + chr(isc_tpb_concurrency); @@ -461,16 +462,16 @@ begin ilReadCommitted : FTPB := FTPB + chr(isc_tpb_read_committed) + chr(isc_tpb_no_rec_version); end; - + case FLockResolution of lrWait : FTPB := FTPB + chr(isc_tpb_wait); lrNoWait : FTPB := FTPB + chr(isc_tpb_nowait); end; - + case FTableReservation of - trSharedLockRead : FTPB := FTPB + chr(isc_tpb_shared) + + trSharedLockRead : FTPB := FTPB + chr(isc_tpb_shared) + chr(isc_tpb_lock_read); - trSharedLockWrite : FTPB := FTPB + chr(isc_tpb_shared) + + trSharedLockWrite : FTPB := FTPB + chr(isc_tpb_shared) + chr(isc_tpb_lock_write); trProtectedLockRead : FTPB := FTPB + chr(isc_tpb_protected) + chr(isc_tpb_lock_read); @@ -519,17 +520,17 @@ var DBHandle : pointer; begin if Active then Active := False; - + if FDatabase = nil then Exception.Create('TIBTransaction.StartTransaction: Database not assigned!'); - + if not Database.Connected then Database.Open; - + DBHandle := Database.GetHandle; SetTPB; FTransactionHandle := nil; - + if isc_start_transaction(@FStatus, @FTransactionHandle, 1, [@DBHandle, Length(FTPB), @FTPB[1]]) <> 0 then CheckError('TIBTransaction.StartTransaction',FStatus) @@ -548,7 +549,7 @@ begin FTableReservation := trNone; FTransactionHandle := nil; FDatabase := nil; - + FillChar(FStatus, SizeOf(FStatus), #0); end; @@ -560,14 +561,14 @@ begin { // i really can't allow commit of transaction // on destroy... } -{ +{ try - if Active then + if Active then Active := False; except end; } - + inherited Destroy; end; @@ -598,7 +599,7 @@ begin GetMem(FSQLDA, XSQLDA_Length * Count); FSQLDAAllocated := Count; FSQLDA^.Version := sqlda_version1; - FSQLDA^.SQLN := Count; + FSQLDA^.SQLN := Count; end; procedure TIBQuery.AllocStatement; @@ -608,7 +609,7 @@ begin if not FDatabase.Connected then FDatabase.Open; dh := FDatabase.GetHandle; - + if isc_dsql_allocate_statement(@FStatus, @dh, @FStatement) <> 0 then CheckError('TIBQuery.AllocStatement', FStatus); end; @@ -627,10 +628,10 @@ var tr : pointer; begin tr := FTransaction.GetHandle; - + for x := 0 to FSQL.Count - 1 do Buf := Buf + FSQL[x] + ' '; - + if isc_dsql_prepare(@FStatus, @tr, @FStatement, 0, @Buf[1], 1, nil) <> 0 then CheckError('TIBQuery.PrepareStatement', FStatus); end; @@ -654,23 +655,23 @@ begin for x := 0 to FSQLDA^.SQLN - 1 do begin case FSQLDA^.SQLVar[x].SQLType of - sql_varying + 1: + sql_varying + 1: FSQLDA^.SQLVar[x].SQLType := sql_varying; - sql_text + 1 : + sql_text + 1 : FSQLDA^.SQLVar[x].SQLType := sql_text; sql_short, sql_short + 1, sql_long + 1: FSQLDA^.SQLVar[x].SQLType := sql_long; sql_float + 1 : FSQLDA^.SQLVar[x].SQLType := sql_float; - sql_double + 1 : + sql_double + 1 : FSQLDA^.SQLVar[x].SQLType := sql_double; - sql_blob + 1 : + sql_blob + 1 : FSQLDA^.SQLVar[x].SQLType := sql_blob; sql_type_time + 1 : FSQLDA^.SQLVar[x].SQLType := sql_type_time; sql_timestamp + 1: FSQLDA^.SQLVar[x].SQLType := sql_timestamp; - end; + end; end; end; @@ -699,7 +700,7 @@ begin if FSQLDA^.SQLVar[x].SQLData <> nil then begin FreeMem(FSQLDA^.SQLVar[x].SQLData); - FSQLDA^.SQLVar[x].SQLData := nil; + FSQLDA^.SQLVar[x].SQLData := nil; end; end; {$R+} @@ -709,14 +710,14 @@ procedure TIBQuery.Fetch; var retcode : integer; begin - if not (FStatementType in [stSelect]) then + if not (FStatementType in [stSelect]) then Exit; retcode := isc_dsql_fetch(@FStatus, @FStatement, 1, FSQLDA); if (retcode <> 0) and (retcode <> 100) then CheckError('TIBQuery.Fetch', FStatus); - FIsEOF := (retcode = 100); + FIsEOF := (retcode = 100); end; function TIBQuery.LoadBufferFromSQLDA(Buffer : PChar): TGetResult; @@ -724,14 +725,14 @@ var x : integer; VarcharLen : word; begin - + Fetch; if FIsEOF then begin Result := grEOF; Exit; end; - + {$R-} for x := 0 to FSQLDA^.SQLD - 1 do begin @@ -747,7 +748,7 @@ begin Inc(Buffer, SQLLen); end; end; - {$R+} + {$R+} Result := grOK; end; @@ -759,7 +760,7 @@ var begin FStatementType := stNone; x := isc_info_sql_stmt_type; - if isc_dsql_sql_info(@FStatus, @FStatement, SizeOf(X), + if isc_dsql_sql_info(@FStatus, @FStatement, SizeOf(X), @x, SizeOf(ResBuf), @ResBuf) <> 0 then CheckError('TIBQuery.GetStatementType', FStatus); if Ord(ResBuf[0]) = isc_info_sql_stmt_type then @@ -788,13 +789,13 @@ begin LensSet := False; case (SQLType and not 1) of - SQL_VARYING : + SQL_VARYING : begin LensSet := True; TrType := ftString; TrLen := SQLLen; end; - SQL_TEXT : + SQL_TEXT : begin LensSet := True; TrType := ftString; @@ -809,7 +810,7 @@ begin SQL_ARRAY : begin end; - SQL_BLOB : + SQL_BLOB : begin end; SQL_SHORT : @@ -865,8 +866,8 @@ var STime : TSystemTime; // System time PTime : TDateTime; // Pascal time begin - case (AType and not 1) of - SQL_TYPE_DATE : + 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); @@ -880,7 +881,7 @@ begin STime.Minute := CTime.tm_min; STime.Second := CTime.tm_sec; STime.Millisecond := 0; - + PTime := SystemTimeToDateTime(STime); Move(PTime, Buffer^, SizeOf(PTime)); end; @@ -919,7 +920,7 @@ end; procedure TIBQuery.GetBookmarkData(Buffer: PChar; Data: Pointer); begin - PInteger(Data)^ := PIBBookmark(Buffer + FRecordSize)^.BookmarkData; + PInteger(Data)^ := PIBBookmark(Buffer + FRecordSize)^.BookmarkData; end; function TIBQuery.GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; @@ -935,14 +936,14 @@ var begin Result := False; CurrBuff := ActiveBuffer; - + for x := 0 to FSQLDA^.SQLD - 1 do begin {$R-} if (Field.FieldName = FSQLDA^.SQLVar[x].SQLName) then begin case Field.DataType of - ftInteger : + ftInteger : begin b := 0; Move(b, Buffer^, 4); @@ -955,12 +956,12 @@ begin Move(CurrBuff^, Buffer^, Field.Size); PChar(Buffer + Field.Size)^ := #0; end; - ftFloat : + ftFloat : GetFloat(CurrBuff, Buffer, Field); end; - + Result := True; - + Break; end else Inc(CurrBuff, FSQLDA^.SQLVar[x].SQLLen); @@ -970,7 +971,7 @@ end; function TIBQuery.GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult; begin - if FStatementType <> stSelect then + if FStatementType <> stSelect then begin Result := grEOF; Exit; @@ -987,10 +988,10 @@ begin FCurrentRecord := -1; end else Dec(FCurrentRecord); - gmCurrent : + gmCurrent : if (FCurrentRecord < 0) or (FCurrentRecord >= RecordCount) then Result := grError; - gmNext : + gmNext : if FCurrentRecord >= (RecordCount - 1) then begin Result := LoadBufferFromSQLDA(Buffer); @@ -1003,7 +1004,7 @@ begin else Inc(FCurrentRecord); end; end; - + if Result = grOK then begin with PIBBookmark(Buffer + FRecordSize)^ do @@ -1074,15 +1075,15 @@ begin Exit; FLoadingFieldDefs := True; - + try FieldDefs.Clear; {$R-} for x := 0 to FSQLDA^.SQLD - 1 do begin - TranslateFldType(FSQLDA^.SQLVar[x].SQLType, FSQLDA^.SQLVar[x].SQLLen, lenset, + TranslateFldType(FSQLDA^.SQLVar[x].SQLType, FSQLDA^.SQLVar[x].SQLLen, lenset, TransType, TransLen); - TFieldDef.Create(FieldDefs, FSQLDA^.SQLVar[x].SQLName, TransType, + TFieldDef.Create(FieldDefs, FSQLDA^.SQLVar[x].SQLName, TransType, TransLen, False, (x + 1)); end; {$R+}