{************************************************************************} { } { Borland Delphi Visual Component Library } { InterBase Express core components } { } { Copyright (c) 1998-2000 Inprise Corporation } { } { InterBase Express is based in part on the product } { Free IB Components, written by Gregory H. Deatz for } { Hoagland, Longo, Moran, Dunst & Doukas Company. } { Free IB Components is used under license. } { } { The contents of this file are subject to the InterBase } { Public License Version 1.0 (the "License"); you may not } { use this file except in compliance with the License. You } { may obtain a copy of the License at http://www.Inprise.com/IPL.html } { Software distributed under the License is distributed on } { an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either } { express or implied. See the License for the specific language } { governing rights and limitations under the License. } { The Original Code was created by InterBase Software Corporation } { and its successors. } { Portions created by Inprise Corporation are Copyright (C) Inprise } { Corporation. All Rights Reserved. } { Contributor(s): Jeff Overcash } { } { IBX For Lazarus (Firebird Express) } { Contributor: Tony Whyman, MWA Software http://www.mwasoftware.co.uk } { Portions created by MWA Software are copyright McCallum Whyman } { Associates Ltd 2011 } { } {************************************************************************} unit IBCustomDataSet; {$Mode Delphi} {$IFDEF DELPHI} {$DEFINE TDBDFIELD_IS_BCD} {$ENDIF} interface uses {$IFDEF WINDOWS } Windows, {$ELSE} unix, {$ENDIF} SysUtils, Classes, Forms, Controls, IBDatabase, IBExternals, IB, IBHeader, IBSQL, Db, IBUtils, IBBlob; const BufferCacheSize = 1000; { Allocate cache in this many record chunks} UniCache = 2; { Uni-directional cache is 2 records big } type TIBCustomDataSet = class; TIBDataSet = class; { TIBDataSetUpdateObject } TIBDataSetUpdateObject = class(TComponent) private FRefreshSQL: TStrings; procedure SetRefreshSQL(value: TStrings); protected function GetDataSet: TIBCustomDataSet; virtual; abstract; procedure SetDataSet(ADataSet: TIBCustomDataSet); virtual; abstract; procedure Apply(UpdateKind: TUpdateKind; buff: PChar); virtual; abstract; function GetSQL(UpdateKind: TUpdateKind): TStrings; virtual; abstract; procedure InternalSetParams(Query: TIBSQL; buff: PChar); property DataSet: TIBCustomDataSet read GetDataSet write SetDataSet; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; published property RefreshSQL: TStrings read FRefreshSQL write SetRefreshSQL; end; TBlobDataArray = array[0..0] of TIBBlobStream; PBlobDataArray = ^TBlobDataArray; { TIBCustomDataSet } TFieldData = record fdDataType: Short; fdDataScale: Short; fdNullable: Boolean; fdIsNull: Boolean; fdDataSize: Short; fdDataLength: Short; fdDataOfs: Integer; end; PFieldData = ^TFieldData; TCachedUpdateStatus = ( cusUnmodified, cusModified, cusInserted, cusDeleted, cusUninserted ); TIBDBKey = record DBKey: array[0..7] of Byte; end; PIBDBKey = ^TIBDBKey; TRecordData = record rdBookmarkFlag: TBookmarkFlag; rdFieldCount: Short; rdRecordNumber: Integer; rdCachedUpdateStatus: TCachedUpdateStatus; rdUpdateStatus: TUpdateStatus; rdSavedOffset: DWORD; rdDBKey: TIBDBKey; rdFields: array[1..1] of TFieldData; end; PRecordData = ^TRecordData; { TIBStringField allows us to have strings longer than 8196 } TIBStringField = class(TStringField) public constructor create(AOwner: TComponent); override; class procedure CheckTypeSize(Value: Integer); override; function GetAsString: string; override; function GetAsVariant: Variant; override; function GetValue(var Value: string): Boolean; procedure SetAsString(const Value: string); override; end; { TIBBCDField } { Actually, there is no BCD involved in this type, instead it deals with currency types. In IB, this is an encapsulation of Numeric (x, y) where x < 18 and y <= 4. Note: y > 4 will default to Floats } TIBBCDField = class(TBCDField) protected class procedure CheckTypeSize(Value: Integer); override; function GetAsCurrency: Currency; override; function GetAsString: string; override; function GetAsVariant: Variant; override; function GetDataSize: Integer; override; public constructor Create(AOwner: TComponent); override; published property Size default 8; end; TIBDataLink = class(TDetailDataLink) private FDataSet: TIBCustomDataSet; protected procedure ActiveChanged; override; procedure RecordChanged(Field: TField); override; function GetDetailDataSet: TDataSet; override; procedure CheckBrowseMode; override; public constructor Create(ADataSet: TIBCustomDataSet); destructor Destroy; override; end; TIBGeneratorApplyOnEvent = (gaeOnNewRecord,gaeOnPostRecord); { TIBGenerator } TIBGenerator = class(TPersistent) private FOwner: TIBCustomDataSet; FApplyOnEvent: TIBGeneratorApplyOnEvent; FFieldName: string; FGeneratorName: string; FIncrement: integer; procedure SetIncrement(const AValue: integer); protected function GetNextValue(ADatabase: TIBDatabase; ATransaction: TIBTransaction): integer; public constructor Create(Owner: TIBCustomDataSet); procedure Apply; property Owner: TIBCustomDataSet read FOwner; published property Generator: string read FGeneratorName write FGeneratorName; property Field: string read FFieldName write FFieldName; property Increment: integer read FIncrement write SetIncrement default 1; property ApplyOnEvent: TIBGeneratorApplyOnEvent read FApplyOnEvent write FApplyOnEvent; end; { TIBCustomDataSet } TIBUpdateAction = (uaFail, uaAbort, uaSkip, uaRetry, uaApply, uaApplied); TIBUpdateErrorEvent = procedure(DataSet: TDataSet; E: EDatabaseError; UpdateKind: TUpdateKind; var UpdateAction: TIBUpdateAction) of object; TIBUpdateRecordEvent = procedure(DataSet: TDataSet; UpdateKind: TUpdateKind; var UpdateAction: TIBUpdateAction) of object; TIBUpdateRecordTypes = set of TCachedUpdateStatus; TIBCustomDataSet = class(TDataset) private FGeneratorField: TIBGenerator; FNeedsRefresh: Boolean; FForcedRefresh: Boolean; FDidActivate: Boolean; FIBLoaded: Boolean; FBase: TIBBase; FBlobCacheOffset: Integer; FBlobStreamList: TList; FBufferChunks: Integer; FBufferCache, FOldBufferCache: PChar; FBufferChunkSize, FCacheSize, FOldCacheSize: Integer; FFilterBuffer: PChar; FBPos, FOBPos, FBEnd, FOBEnd: DWord; FCachedUpdates: Boolean; FCalcFieldsOffset: Integer; FCurrentRecord: Long; FDeletedRecords: Long; FModelBuffer, FOldBuffer: PChar; FOpen: Boolean; FInternalPrepared: Boolean; FQDelete, FQInsert, FQRefresh, FQSelect, FQModify: TIBSQL; FRecordBufferSize: Integer; FRecordCount: Integer; FRecordSize: Integer; FUniDirectional: Boolean; FUpdateMode: TUpdateMode; FUpdateObject: TIBDataSetUpdateObject; FParamCheck: Boolean; FUpdatesPending: Boolean; FUpdateRecordTypes: TIBUpdateRecordTypes; FMappedFieldPosition: array of Integer; FDataLink: TIBDataLink; FBeforeDatabaseDisconnect, FAfterDatabaseDisconnect, FDatabaseFree: TNotifyEvent; FOnUpdateError: TIBUpdateErrorEvent; FOnUpdateRecord: TIBUpdateRecordEvent; FBeforeTransactionEnd, FAfterTransactionEnd, FTransactionFree: TNotifyEvent; function GetSelectStmtHandle: TISC_STMT_HANDLE; procedure SetUpdateMode(const Value: TUpdateMode); procedure SetUpdateObject(Value: TIBDataSetUpdateObject); function AdjustCurrentRecord(Buffer: Pointer; GetMode: TGetMode): TGetResult; procedure AdjustRecordOnInsert(Buffer: Pointer); function CanEdit: Boolean; function CanInsert: Boolean; function CanDelete: Boolean; function CanRefresh: Boolean; procedure CheckEditState; procedure ClearBlobCache; procedure CopyRecordBuffer(Source, Dest: Pointer); procedure DoBeforeDatabaseDisconnect(Sender: TObject); procedure DoAfterDatabaseDisconnect(Sender: TObject); procedure DoDatabaseFree(Sender: TObject); procedure DoBeforeTransactionEnd(Sender: TObject); procedure DoAfterTransactionEnd(Sender: TObject); procedure DoTransactionFree(Sender: TObject); procedure FetchCurrentRecordToBuffer(Qry: TIBSQL; RecordNumber: Integer; Buffer: PChar); function GetDatabase: TIBDatabase; function GetDBHandle: PISC_DB_HANDLE; function GetDeleteSQL: TStrings; function GetInsertSQL: TStrings; function GetSQLParams: TIBXSQLDA; function GetRefreshSQL: TStrings; function GetSelectSQL: TStrings; function GetStatementType: TIBSQLTypes; function GetModifySQL: TStrings; function GetTransaction: TIBTransaction; function GetTRHandle: PISC_TR_HANDLE; procedure InternalDeleteRecord(Qry: TIBSQL; Buff: Pointer); virtual; function InternalLocate(const KeyFields: string; const KeyValues: Variant; Options: TLocateOptions): Boolean; virtual; procedure InternalPostRecord(Qry: TIBSQL; Buff: Pointer); virtual; procedure InternalRevertRecord(RecordNumber: Integer); virtual; function IsVisible(Buffer: PChar): Boolean; procedure SaveOldBuffer(Buffer: PChar); procedure SetBufferChunks(Value: Integer); procedure SetDatabase(Value: TIBDatabase); procedure SetDeleteSQL(Value: TStrings); procedure SetInsertSQL(Value: TStrings); procedure SetInternalSQLParams(Qry: TIBSQL; Buffer: Pointer); procedure SetRefreshSQL(Value: TStrings); procedure SetSelectSQL(Value: TStrings); procedure SetModifySQL(Value: TStrings); procedure SetTransaction(Value: TIBTransaction); procedure SetUpdateRecordTypes(Value: TIBUpdateRecordTypes); procedure SetUniDirectional(Value: Boolean); procedure RefreshParams; procedure SQLChanging(Sender: TObject); virtual; function AdjustPosition(FCache: PChar; Offset: DWORD; Origin: Integer): DWORD; procedure ReadCache(FCache: PChar; Offset: DWORD; Origin: Integer; Buffer: PChar); procedure ReadRecordCache(RecordNumber: Integer; Buffer: PChar; ReadOldBuffer: Boolean); procedure WriteCache(FCache: PChar; Offset: DWORD; Origin: Integer; Buffer: PChar); procedure WriteRecordCache(RecordNumber: Integer; Buffer: PChar); function InternalGetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult; virtual; protected procedure ActivateConnection; function ActivateTransaction: Boolean; procedure DeactivateTransaction; procedure CheckDatasetClosed; procedure CheckDatasetOpen; function GetActiveBuf: PChar; procedure InternalBatchInput(InputObject: TIBBatchInput); virtual; procedure InternalBatchOutput(OutputObject: TIBBatchOutput); virtual; procedure InternalPrepare; virtual; procedure InternalUnPrepare; virtual; procedure InternalExecQuery; virtual; procedure InternalRefreshRow; virtual; procedure InternalSetParamsFromCursor; virtual; procedure CheckNotUniDirectional; (* { IProviderSupport } procedure PSEndTransaction(Commit: Boolean); override; function PSExecuteStatement(const ASQL: string; AParams: TParams; ResultSet: Pointer = nil): Integer; override; function PsGetTableName: string; override; function PSGetQuoteChar: string; override; function PSGetUpdateException(E: Exception; Prev: EUpdateError): EUpdateError; override; function PSInTransaction: Boolean; override; function PSIsSQLBased: Boolean; override; function PSIsSQLSupported: Boolean; override; procedure PSStartTransaction; override; procedure PSReset; override; function PSUpdateRecord(UpdateKind: TUpdateKind; Delta: TDataSet): Boolean; override; *) { TDataSet support } procedure InternalInsert; override; procedure InitRecord(Buffer: PChar); override; procedure Disconnect; virtual; function ConstraintsStored: Boolean; procedure ClearCalcFields(Buffer: PChar); override; function AllocRecordBuffer: PChar; override; procedure DoBeforeDelete; override; procedure DoBeforeEdit; override; procedure DoBeforeInsert; override; procedure DoAfterInsert; override; procedure DoBeforePost; override; procedure FreeRecordBuffer(var Buffer: PChar); override; procedure GetBookmarkData(Buffer: PChar; Data: Pointer); override; function GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; override; function GetCanModify: Boolean; override; function GetDataSource: TDataSource; override; function GetFieldClass(FieldType: TFieldType): TFieldClass; override; function GetRecNo: Integer; override; function GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult; override; function GetRecordCount: Integer; override; function GetRecordSize: Word; override; procedure InternalAddRecord(Buffer: Pointer; Append: Boolean); override; procedure InternalCancel; override; procedure InternalClose; override; procedure InternalDelete; override; procedure InternalFirst; override; function InternalGetFieldData(Field: TField; Buffer: Pointer): Boolean; virtual; procedure InternalGotoBookmark(Bookmark: Pointer); override; procedure InternalHandleException; override; procedure InternalInitFieldDefs; override; procedure InternalInitRecord(Buffer: PChar); override; procedure InternalLast; override; procedure InternalOpen; override; procedure InternalPost; override; procedure InternalRefresh; override; procedure InternalSetFieldData(Field: TField; Buffer: Pointer); virtual; procedure InternalSetToRecord(Buffer: PChar); override; function IsCursorOpen: Boolean; override; procedure ReQuery; procedure SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); override; procedure SetBookmarkData(Buffer: PChar; Data: Pointer); override; procedure SetCachedUpdates(Value: Boolean); procedure SetDataSource(Value: TDataSource); procedure SetFieldData(Field : TField; Buffer : Pointer); override; procedure SetFieldData(Field : TField; Buffer : Pointer; NativeFormat : Boolean); overload; override; procedure SetRecNo(Value: Integer); override; protected {Likely to be made public by descendant classes} property SQLParams: TIBXSQLDA read GetSQLParams; property Params: TIBXSQLDA read GetSQLParams; property InternalPrepared: Boolean read FInternalPrepared; property QDelete: TIBSQL read FQDelete; property QInsert: TIBSQL read FQInsert; property QRefresh: TIBSQL read FQRefresh; property QSelect: TIBSQL read FQSelect; property QModify: TIBSQL read FQModify; property StatementType: TIBSQLTypes read GetStatementType; property SelectStmtHandle: TISC_STMT_HANDLE read GetSelectStmtHandle; {Likely to be made published by descendant classes} property BufferChunks: Integer read FBufferChunks write SetBufferChunks; property CachedUpdates: Boolean read FCachedUpdates write SetCachedUpdates; property UniDirectional: Boolean read FUniDirectional write SetUniDirectional default False; property GeneratorField: TIBGenerator read FGeneratorField write FGeneratorField; property DeleteSQL: TStrings read GetDeleteSQL write SetDeleteSQL; property InsertSQL: TStrings read GetInsertSQL write SetInsertSQL; property RefreshSQL: TStrings read GetRefreshSQL write SetRefreshSQL; property SelectSQL: TStrings read GetSelectSQL write SetSelectSQL; property ModifySQL: TStrings read GetModifySQL write SetModifySQL; property UpdateMode: TUpdateMode read FUpdateMode write SetUpdateMode default upWhereAll; property ParamCheck: Boolean read FParamCheck write FParamCheck default True; property BeforeDatabaseDisconnect: TNotifyEvent read FBeforeDatabaseDisconnect write FBeforeDatabaseDisconnect; property AfterDatabaseDisconnect: TNotifyEvent read FAfterDatabaseDisconnect write FAfterDatabaseDisconnect; property DatabaseFree: TNotifyEvent read FDatabaseFree write FDatabaseFree; property BeforeTransactionEnd: TNotifyEvent read FBeforeTransactionEnd write FBeforeTransactionEnd; property AfterTransactionEnd: TNotifyEvent read FAfterTransactionEnd write FAfterTransactionEnd; property TransactionFree: TNotifyEvent read FTransactionFree write FTransactionFree; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure ApplyUpdates; function CachedUpdateStatus: TCachedUpdateStatus; procedure CancelUpdates; procedure FetchAll; function LocateNext(const KeyFields: string; const KeyValues: Variant; Options: TLocateOptions): Boolean; procedure RecordModified(Value: Boolean); procedure RevertRecord; procedure Undelete; { TDataSet support methods } function BookmarkValid(Bookmark: TBookmark): Boolean; override; function CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Integer; override; function CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; override; function GetCurrentRecord(Buffer: PChar): Boolean; override; function GetFieldData(Field : TField; Buffer : Pointer) : Boolean; overload; override; function GetFieldData(FieldNo: Integer; Buffer: Pointer): Boolean; overload; (*override;*) function GetFieldData(Field : TField; Buffer : Pointer; NativeFormat : Boolean) : Boolean; overload; override; function Locate(const KeyFields: string; const KeyValues: Variant; Options: TLocateOptions): Boolean; override; function Lookup(const KeyFields: string; const KeyValues: Variant; const ResultFields: string): Variant; override; function UpdateStatus: TUpdateStatus; override; function IsSequenced: Boolean; override; function ParamByName(ParamName: String): TIBXSQLVAR; property DBHandle: PISC_DB_HANDLE read GetDBHandle; property TRHandle: PISC_TR_HANDLE read GetTRHandle; property UpdateObject: TIBDataSetUpdateObject read FUpdateObject write SetUpdateObject; property UpdatesPending: Boolean read FUpdatesPending; property UpdateRecordTypes: TIBUpdateRecordTypes read FUpdateRecordTypes write SetUpdateRecordTypes; published property Database: TIBDatabase read GetDatabase write SetDatabase; property Transaction: TIBTransaction read GetTransaction write SetTransaction; property ForcedRefresh: Boolean read FForcedRefresh write FForcedRefresh default False; property AutoCalcFields; property AfterCancel; property AfterClose; property AfterDelete; property AfterEdit; property AfterInsert; property AfterOpen; property AfterPost; property AfterRefresh; property AfterScroll; property BeforeCancel; property BeforeClose; property BeforeDelete; property BeforeEdit; property BeforeInsert; property BeforeOpen; property BeforePost; property BeforeRefresh; property BeforeScroll; property OnCalcFields; property OnDeleteError; property OnEditError; property OnNewRecord; property OnPostError; property OnUpdateError: TIBUpdateErrorEvent read FOnUpdateError write FOnUpdateError; property OnUpdateRecord: TIBUpdateRecordEvent read FOnUpdateRecord write FOnUpdateRecord; end; TIBDataSet = class(TIBCustomDataSet) private function GetPrepared: Boolean; protected procedure SetFiltered(Value: Boolean); override; procedure InternalOpen; override; public procedure Prepare; procedure UnPrepare; procedure BatchInput(InputObject: TIBBatchInput); procedure BatchOutput(OutputObject: TIBBatchOutput); procedure ExecSQL; public property Params; property Prepared : Boolean read GetPrepared; property QDelete; property QInsert; property QRefresh; property QSelect; property QModify; property StatementType; property SelectStmtHandle; published { TIBCustomDataSet } property BufferChunks; property CachedUpdates; property DeleteSQL; property InsertSQL; property RefreshSQL; property SelectSQL; property ModifySQL; property GeneratorField; property ParamCheck; property UniDirectional; property Filtered; property BeforeDatabaseDisconnect; property AfterDatabaseDisconnect; property DatabaseFree; property BeforeTransactionEnd; property AfterTransactionEnd; property TransactionFree; { TIBDataSet } property Active; property AutoCalcFields; property DataSource read GetDataSource write SetDataSource; property AfterCancel; property AfterClose; property AfterDelete; property AfterEdit; property AfterInsert; property AfterOpen; property AfterPost; property AfterScroll; property BeforeCancel; property BeforeClose; property BeforeDelete; property BeforeEdit; property BeforeInsert; property BeforeOpen; property BeforePost; property BeforeScroll; property OnCalcFields; property OnDeleteError; property OnEditError; property OnFilterRecord; property OnNewRecord; property OnPostError; end; { TIBDSBlobStream } TIBDSBlobStream = class(TStream) protected FField: TField; FBlobStream: TIBBlobStream; public constructor Create(AField: TField; ABlobStream: TIBBlobStream; Mode: TBlobStreamMode); function Read(var Buffer; Count: Longint): Longint; override; function Seek(Offset: Longint; Origin: Word): Longint; override; procedure SetSize(NewSize: Longint); override; function Write(const Buffer; Count: Longint): Longint; override; end; const DefaultFieldClasses: array[TFieldType] of TFieldClass = ( nil, { ftUnknown } TIBStringField, { ftString } TSmallintField, { ftSmallint } TIntegerField, { ftInteger } TWordField, { ftWord } TBooleanField, { ftBoolean } TFloatField, { ftFloat } TCurrencyField, { ftCurrency } TIBBCDField, { ftBCD } TDateField, { ftDate } TTimeField, { ftTime } TDateTimeField, { ftDateTime } TBytesField, { ftBytes } TVarBytesField, { ftVarBytes } TAutoIncField, { ftAutoInc } TBlobField, { ftBlob } TMemoField, { ftMemo } TGraphicField, { ftGraphic } TBlobField, { ftFmtMemo } TBlobField, { ftParadoxOle } TBlobField, { ftDBaseOle } TBlobField, { ftTypedBinary } nil, { ftCursor } TStringField, { ftFixedChar } TWideStringField, { ftWideString } TLargeIntField, { ftLargeInt } nil, { ftADT } nil, { ftArray } nil, { ftReference } nil, { ftDataSet } TBlobField, { ftOraBlob } TMemoField, { ftOraClob } TVariantField, { ftVariant } nil, { ftInterface } nil, { ftIDispatch } TGuidField, { ftGuid } TDateTimeField, {ftTimestamp} TIBBCDField, {ftFMTBcd} nil, {ftFixedWideChar} TWideMemoField); {ftWideMemo} (* TADTField, { ftADT } TArrayField, { ftArray } TReferenceField, { ftReference } TDataSetField, { ftDataSet } TBlobField, { ftOraBlob } TMemoField, { ftOraClob } TVariantField, { ftVariant } TInterfaceField, { ftInterface } TIDispatchField, { ftIDispatch } TGuidField); { ftGuid } *) (*var CreateProviderProc: function(DataSet: TIBCustomDataSet): IProvider = nil;*) implementation uses IBIntf, Variants, FmtBCD; const FILE_BEGIN = 0; FILE_CURRENT = 1; FILE_END = 2; type TFieldNode = class(TObject) protected FieldName : String; COMPUTED_BLR : Boolean; DEFAULT_VALUE : boolean; NextField : TFieldNode; end; TRelationNode = class(TObject) protected RelationName : String; FieldNodes : TFieldNode; NextRelation : TRelationNode; end; { TIBStringField} constructor TIBStringField.Create(AOwner: TComponent); begin inherited Create(AOwner); end; class procedure TIBStringField.CheckTypeSize(Value: Integer); begin { don't check string size. all sizes valid } end; function TIBStringField.GetAsString: string; begin if not GetValue(Result) then Result := ''; end; function TIBStringField.GetAsVariant: Variant; var S: string; begin if GetValue(S) then Result := S else Result := Null; end; function TIBStringField.GetValue(var Value: string): Boolean; var Buffer: PChar; begin Buffer := nil; IBAlloc(Buffer, 0, Size + 1); try Result := GetData(Buffer); if Result then begin Value := string(Buffer); if Transliterate and (Value <> '') then DataSet.Translate(PChar(Value), PChar(Value), False); end finally FreeMem(Buffer); end; end; procedure TIBStringField.SetAsString(const Value: string); var Buffer: PChar; begin Buffer := nil; IBAlloc(Buffer, 0, Size + 1); try StrLCopy(Buffer, PChar(Value), Size); if Transliterate then DataSet.Translate(Buffer, Buffer, True); SetData(Buffer); finally FreeMem(Buffer); end; end; { TIBBCDField } constructor TIBBCDField.Create(AOwner: TComponent); begin inherited Create(AOwner); SetDataType(ftBCD); Size := 8; end; class procedure TIBBCDField.CheckTypeSize(Value: Integer); begin { No need to check as the base type is currency, not BCD } end; function TIBBCDField.GetAsCurrency: Currency; begin if not GetValue(Result) then Result := 0; end; function TIBBCDField.GetAsString: string; var C: System.Currency; begin if GetValue(C) then Result := CurrToStr(C) else Result := ''; end; function TIBBCDField.GetAsVariant: Variant; var C: System.Currency; begin if GetValue(C) then Result := C else Result := Null; end; function TIBBCDField.GetDataSize: Integer; begin {$IFDEF TBCDFIELD_IS_BCD} Result := 8; {$ELSE} Result := inherited GetDataSize {$ENDIF} end; { TIBDataLink } constructor TIBDataLink.Create(ADataSet: TIBCustomDataSet); begin inherited Create; FDataSet := ADataSet; end; destructor TIBDataLink.Destroy; begin FDataSet.FDataLink := nil; inherited Destroy; end; procedure TIBDataLink.ActiveChanged; begin if FDataSet.Active then FDataSet.RefreshParams; end; function TIBDataLink.GetDetailDataSet: TDataSet; begin Result := FDataSet; end; procedure TIBDataLink.RecordChanged(Field: TField); begin if (Field = nil) and FDataSet.Active then FDataSet.RefreshParams; end; procedure TIBDataLink.CheckBrowseMode; begin if FDataSet.Active then FDataSet.CheckBrowseMode; end; { TIBCustomDataSet } constructor TIBCustomDataSet.Create(AOwner: TComponent); begin inherited Create(AOwner); FIBLoaded := False; CheckIBLoaded; FIBLoaded := True; FBase := TIBBase.Create(Self); FCurrentRecord := -1; FDeletedRecords := 0; FUniDirectional := False; FBufferChunks := BufferCacheSize; FBlobStreamList := TList.Create; FGeneratorField := TIBGenerator.Create(self); FDataLink := TIBDataLink.Create(Self); FQDelete := TIBSQL.Create(Self); FQDelete.OnSQLChanging := SQLChanging; FQDelete.GoToFirstRecordOnExecute := False; FQInsert := TIBSQL.Create(Self); FQInsert.OnSQLChanging := SQLChanging; FQInsert.GoToFirstRecordOnExecute := False; FQRefresh := TIBSQL.Create(Self); FQRefresh.OnSQLChanging := SQLChanging; FQRefresh.GoToFirstRecordOnExecute := False; FQSelect := TIBSQL.Create(Self); FQSelect.OnSQLChanging := SQLChanging; FQSelect.GoToFirstRecordOnExecute := False; FQModify := TIBSQL.Create(Self); FQModify.OnSQLChanging := SQLChanging; FQModify.GoToFirstRecordOnExecute := False; FUpdateRecordTypes := [cusUnmodified, cusModified, cusInserted]; FParamCheck := True; FForcedRefresh := False; {Bookmark Size is Integer for IBX} BookmarkSize := SizeOf(Integer); FBase.BeforeDatabaseDisconnect := DoBeforeDatabaseDisconnect; FBase.AfterDatabaseDisconnect := DoAfterDatabaseDisconnect; FBase.OnDatabaseFree := DoDatabaseFree; FBase.BeforeTransactionEnd := DoBeforeTransactionEnd; FBase.AfterTransactionEnd := DoAfterTransactionEnd; FBase.OnTransactionFree := DoTransactionFree; if AOwner is TIBDatabase then Database := TIBDatabase(AOwner) else if AOwner is TIBTransaction then Transaction := TIBTransaction(AOwner); end; destructor TIBCustomDataSet.Destroy; begin if Active then Active := false; if FIBLoaded then begin if assigned(FGeneratorField) then FGeneratorField.Free; FDataLink.Free; FBase.Free; ClearBlobCache; FBlobStreamList.Free; FreeMem(FBufferCache); FBufferCache := nil; FreeMem(FOldBufferCache); FOldBufferCache := nil; FCacheSize := 0; FOldCacheSize := 0; FMappedFieldPosition := nil; end; inherited Destroy; end; function TIBCustomDataSet.AdjustCurrentRecord(Buffer: Pointer; GetMode: TGetMode): TGetResult; begin while not IsVisible(Buffer) do begin if GetMode = gmPrior then begin Dec(FCurrentRecord); if FCurrentRecord = -1 then begin result := grBOF; exit; end; ReadRecordCache(FCurrentRecord, Buffer, False); end else begin Inc(FCurrentRecord); if (FCurrentRecord = FRecordCount) then begin if (not FQSelect.EOF) and (FQSelect.Next <> nil) then begin FetchCurrentRecordToBuffer(FQSelect, FCurrentRecord, Buffer); Inc(FRecordCount); end else begin result := grEOF; exit; end; end else ReadRecordCache(FCurrentRecord, Buffer, False); end; end; result := grOK; end; procedure TIBCustomDataSet.ApplyUpdates; var {$IF FPC_FULLVERSION > 20600 } CurBookmark: TBookmark; {$ELSE} CurBookmark: string; {$ENDIF} Buffer: PRecordData; CurUpdateTypes: TIBUpdateRecordTypes; UpdateAction: TIBUpdateAction; UpdateKind: TUpdateKind; bRecordsSkipped: Boolean; procedure GetUpdateKind; begin case Buffer^.rdCachedUpdateStatus of cusModified: UpdateKind := ukModify; cusInserted: UpdateKind := ukInsert; else UpdateKind := ukDelete; end; end; procedure ResetBufferUpdateStatus; begin case Buffer^.rdCachedUpdateStatus of cusModified: begin PRecordData(Buffer)^.rdUpdateStatus := usUnmodified; PRecordData(Buffer)^.rdCachedUpdateStatus := cusUnmodified; end; cusInserted: begin PRecordData(Buffer)^.rdUpdateStatus := usUnmodified; PRecordData(Buffer)^.rdCachedUpdateStatus := cusUnmodified; end; cusDeleted: begin PRecordData(Buffer)^.rdUpdateStatus := usDeleted; PRecordData(Buffer)^.rdCachedUpdateStatus := cusUnmodified; end; end; WriteRecordCache(PRecordData(Buffer)^.rdRecordNumber, Pointer(Buffer)); end; procedure UpdateUsingOnUpdateRecord; begin UpdateAction := uaFail; try FOnUpdateRecord(Self, UpdateKind, UpdateAction); except on E: Exception do begin if (E is EDatabaseError) and Assigned(FOnUpdateError) then FOnUpdateError(Self, EIBError(E), UpdateKind, UpdateAction); if UpdateAction = uaFail then raise; end; end; end; procedure UpdateUsingUpdateObject; begin try FUpdateObject.Apply(UpdateKind,PChar(Buffer)); ResetBufferUpdateStatus; except on E: Exception do if (E is EDatabaseError) and Assigned(FOnUpdateError) then FOnUpdateError(Self, EIBError(E), UpdateKind, UpdateAction); end; end; procedure UpdateUsingInternalquery; begin try case Buffer^.rdCachedUpdateStatus of cusModified: InternalPostRecord(FQModify, Buffer); cusInserted: InternalPostRecord(FQInsert, Buffer); cusDeleted: InternalDeleteRecord(FQDelete, Buffer); end; except on E: EIBError do begin UpdateAction := uaFail; if Assigned(FOnUpdateError) then FOnUpdateError(Self, E, UpdateKind, UpdateAction); case UpdateAction of uaFail: raise; uaAbort: SysUtils.Abort; uaSkip: bRecordsSkipped := True; end; end; end; end; begin if State in [dsEdit, dsInsert] then Post; FBase.CheckDatabase; FBase.CheckTransaction; DisableControls; CurBookmark := Bookmark; CurUpdateTypes := FUpdateRecordTypes; FUpdateRecordTypes := [cusModified, cusInserted, cusDeleted]; try First; bRecordsSkipped := False; while not EOF do begin Buffer := PRecordData(GetActiveBuf); GetUpdateKind; UpdateAction := uaApply; if Assigned(FUpdateObject) or Assigned(FOnUpdateRecord) then begin if (Assigned(FOnUpdateRecord)) then UpdateUsingOnUpdateRecord else if Assigned(FUpdateObject) then UpdateUsingUpdateObject; case UpdateAction of uaFail: IBError(ibxeUserAbort, [nil]); uaAbort: SysUtils.Abort; uaApplied: ResetBufferUpdateStatus; uaSkip: bRecordsSkipped := True; uaRetry: Continue; end; end; if (not Assigned(FUpdateObject)) and (UpdateAction = UaApply) then begin UpdateUsingInternalquery; UpdateAction := uaApplied; end; Next; end; FUpdatesPending := bRecordsSkipped; finally FUpdateRecordTypes := CurUpdateTypes; Bookmark := CurBookmark; EnableControls; end; end; procedure TIBCustomDataSet.InternalBatchInput(InputObject: TIBBatchInput); begin FQSelect.BatchInput(InputObject); end; procedure TIBCustomDataSet.InternalBatchOutput(OutputObject: TIBBatchOutput); var Qry: TIBSQL; begin Qry := TIBSQL.Create(Self); try Qry.Database := FBase.Database; Qry.Transaction := FBase.Transaction; Qry.SQL.Assign(FQSelect.SQL); Qry.BatchOutput(OutputObject); finally Qry.Free; end; end; procedure TIBCustomDataSet.CancelUpdates; var CurUpdateTypes: TIBUpdateRecordTypes; begin if State in [dsEdit, dsInsert] then Post; if FCachedUpdates and FUpdatesPending then begin DisableControls; CurUpdateTypes := UpdateRecordTypes; UpdateRecordTypes := [cusModified, cusInserted, cusDeleted]; try First; while not EOF do begin if UpdateStatus = usInserted then RevertRecord else begin RevertRecord; Next; end; end; finally UpdateRecordTypes := CurUpdateTypes; First; FUpdatesPending := False; EnableControls; end; end; end; procedure TIBCustomDataSet.ActivateConnection; begin if not Assigned(Database) then IBError(ibxeDatabaseNotAssigned, [nil]); if not Assigned(Transaction) then IBError(ibxeTransactionNotAssigned, [nil]); if not Database.Connected then Database.Open; end; function TIBCustomDataSet.ActivateTransaction: Boolean; begin Result := False; if not Assigned(Transaction) then IBError(ibxeTransactionNotAssigned, [nil]); if not Transaction.Active then begin Result := True; Transaction.StartTransaction; FDidActivate := True; end; end; procedure TIBCustomDataSet.DeactivateTransaction; var i: Integer; begin if not Assigned(Transaction) then IBError(ibxeTransactionNotAssigned, [nil]); with Transaction do begin for i := 0 to SQLObjectCount - 1 do begin if (SQLObjects[i] <> nil) and ((SQLObjects[i]).owner is TDataSet) then begin if TDataSet(SQLObjects[i].owner).Active then begin FDidActivate := False; exit; end; end; end; end; FInternalPrepared := False; if Transaction.InTransaction then Transaction.Commit; FDidActivate := False; end; procedure TIBCustomDataSet.CheckDatasetClosed; begin if FOpen then IBError(ibxeDatasetOpen, [nil]); end; procedure TIBCustomDataSet.CheckDatasetOpen; begin if not FOpen then IBError(ibxeDatasetClosed, [nil]); end; procedure TIBCustomDataSet.CheckNotUniDirectional; begin if UniDirectional then IBError(ibxeDataSetUniDirectional, [nil]); end; procedure TIBCustomDataSet.AdjustRecordOnInsert(Buffer: Pointer); begin with PRecordData(Buffer)^ do if (State = dsInsert) and (not Modified) then begin rdRecordNumber := FRecordCount; FCurrentRecord := FRecordCount; end; end; function TIBCustomDataSet.CanEdit: Boolean; var Buff: PRecordData; begin Buff := PRecordData(GetActiveBuf); result := (FQModify.SQL.Text <> '') or (Assigned(FUpdateObject) and (FUpdateObject.GetSQL(ukModify).Text <> '')) or ((Buff <> nil) and (Buff^.rdCachedUpdateStatus = cusInserted) and (FCachedUpdates)); end; function TIBCustomDataSet.CanInsert: Boolean; begin result := (FQInsert.SQL.Text <> '') or (Assigned(FUpdateObject) and (FUpdateObject.GetSQL(ukInsert).Text <> '')); end; function TIBCustomDataSet.CanDelete: Boolean; begin if (FQDelete.SQL.Text <> '') or (Assigned(FUpdateObject) and (FUpdateObject.GetSQL(ukDelete).Text <> '')) then result := True else result := False; end; function TIBCustomDataSet.CanRefresh: Boolean; begin result := (FQRefresh.SQL.Text <> '') or (Assigned(FUpdateObject) and (FUpdateObject.RefreshSQL.Text <> '')); end; procedure TIBCustomDataSet.CheckEditState; begin case State of { Check all the wsEditMode types } dsEdit, dsInsert, dsSetKey, dsCalcFields, dsFilter, dsNewValue, dsInternalCalc : begin if (State in [dsEdit]) and (not CanEdit) then IBError(ibxeCannotUpdate, [nil]); if (State in [dsInsert]) and (not CanInsert) then IBError(ibxeCannotInsert, [nil]); end; else IBError(ibxeNotEditing, []) end; end; procedure TIBCustomDataSet.ClearBlobCache; var i: Integer; begin for i := 0 to FBlobStreamList.Count - 1 do begin TIBBlobStream(FBlobStreamList[i]).Free; FBlobStreamList[i] := nil; end; FBlobStreamList.Pack; end; procedure TIBCustomDataSet.CopyRecordBuffer(Source, Dest: Pointer); begin Move(Source^, Dest^, FRecordBufferSize); end; procedure TIBCustomDataSet.DoBeforeDatabaseDisconnect(Sender: TObject); begin if Active then Active := False; FInternalPrepared := False; if Assigned(FBeforeDatabaseDisconnect) then FBeforeDatabaseDisconnect(Sender); end; procedure TIBCustomDataSet.DoAfterDatabaseDisconnect(Sender: TObject); begin if Assigned(FAfterDatabaseDisconnect) then FAfterDatabaseDisconnect(Sender); end; procedure TIBCustomDataSet.DoDatabaseFree(Sender: TObject); begin if Assigned(FDatabaseFree) then FDatabaseFree(Sender); end; procedure TIBCustomDataSet.DoBeforeTransactionEnd(Sender: TObject); begin if Active then Active := False; if FQSelect <> nil then FQSelect.FreeHandle; if FQDelete <> nil then FQDelete.FreeHandle; if FQInsert <> nil then FQInsert.FreeHandle; if FQModify <> nil then FQModify.FreeHandle; if FQRefresh <> nil then FQRefresh.FreeHandle; if Assigned(FBeforeTransactionEnd) then FBeforeTransactionEnd(Sender); end; procedure TIBCustomDataSet.DoAfterTransactionEnd(Sender: TObject); begin if Assigned(FAfterTransactionEnd) then FAfterTransactionEnd(Sender); end; procedure TIBCustomDataSet.DoTransactionFree(Sender: TObject); begin if Assigned(FTransactionFree) then FTransactionFree(Sender); end; { Read the record from FQSelect.Current into the record buffer Then write the buffer to in memory cache } procedure TIBCustomDataSet.FetchCurrentRecordToBuffer(Qry: TIBSQL; RecordNumber: Integer; Buffer: PChar); var p: PRecordData; pbd: PBlobDataArray; i, j: Integer; LocalData: Pointer; LocalDate, LocalDouble: Double; LocalInt: Integer; LocalInt64: Int64; LocalCurrency: Currency; FieldsLoaded: Integer; temp: TIBXSQLVAR; begin p := PRecordData(Buffer); { Make sure blob cache is empty } pbd := PBlobDataArray(Buffer + FBlobCacheOffset); if RecordNumber > -1 then for i := 0 to BlobFieldCount - 1 do pbd^[i] := nil; { Get record information } p^.rdBookmarkFlag := bfCurrent; p^.rdFieldCount := Qry.Current.Count; p^.rdRecordNumber := RecordNumber; p^.rdUpdateStatus := usUnmodified; p^.rdCachedUpdateStatus := cusUnmodified; p^.rdSavedOffset := $FFFFFFFF; { Load up the fields } FieldsLoaded := FQSelect.Current.Count; j := 1; for i := 0 to Qry.Current.Count - 1 do begin if (Qry = FQSelect) then j := i + 1 else begin if FieldsLoaded = 0 then break; j := FQSelect.FieldIndex[Qry.Current[i].Name] + 1; if j < 1 then continue else Dec(FieldsLoaded); end; with FQSelect.Current[j - 1].Data^ do if aliasname = 'IBX_INTERNAL_DBKEY' then {do not localize} begin if sqllen <= 8 then p^.rdDBKey := PIBDBKEY(Qry.Current[i].AsPointer)^; continue; end; if j > 0 then with p^ do begin rdFields[j].fdDataType := Qry.Current[i].Data^.sqltype and (not 1); rdFields[j].fdDataScale := Qry.Current[i].Data^.sqlscale; rdFields[j].fdNullable := (Qry.Current[i].Data^.sqltype and 1 = 1); rdFields[j].fdIsNull := (rdFields[j].fdNullable and (Qry.Current[i].Data^.sqlind^ = -1)); LocalData := Qry.Current[i].Data^.sqldata; case rdFields[j].fdDataType of SQL_TIMESTAMP: begin rdFields[j].fdDataSize := SizeOf(TDateTime); if RecordNumber >= 0 then LocalDate := TimeStampToMSecs(DateTimeToTimeStamp(Qry.Current[i].AsDateTime)); LocalData := PChar(@LocalDate); end; SQL_TYPE_DATE: begin rdFields[j].fdDataSize := SizeOf(TDateTime); if RecordNumber >= 0 then LocalInt := DateTimeToTimeStamp(Qry.Current[i].AsDateTime).Date; LocalData := PChar(@LocalInt); end; SQL_TYPE_TIME: begin rdFields[j].fdDataSize := SizeOf(TDateTime); if RecordNumber >= 0 then LocalInt := DateTimeToTimeStamp(Qry.Current[i].AsDateTime).Time; LocalData := PChar(@LocalInt); end; SQL_SHORT, SQL_LONG: begin if (rdFields[j].fdDataScale = 0) then begin rdFields[j].fdDataSize := SizeOf(Integer); if RecordNumber >= 0 then LocalInt := Qry.Current[i].AsLong; LocalData := PChar(@LocalInt); end else if (rdFields[j].fdDataScale >= (-4)) then begin rdFields[j].fdDataSize := SizeOf(Currency); if RecordNumber >= 0 then LocalCurrency := Qry.Current[i].AsCurrency; LocalData := PChar(@LocalCurrency); end else begin rdFields[j].fdDataSize := SizeOf(Double); if RecordNumber >= 0 then LocalDouble := Qry.Current[i].AsDouble; LocalData := PChar(@LocalDouble); end; end; SQL_INT64: begin if (rdFields[j].fdDataScale = 0) then begin rdFields[j].fdDataSize := SizeOf(Int64); if RecordNumber >= 0 then LocalInt64 := Qry.Current[i].AsInt64; LocalData := PChar(@LocalInt64); end else if (rdFields[j].fdDataScale >= (-4)) then begin rdFields[j].fdDataSize := SizeOf(Currency); if RecordNumber >= 0 then LocalCurrency := Qry.Current[i].AsCurrency; LocalData := PChar(@LocalCurrency); end else begin rdFields[j].fdDataSize := SizeOf(Double); if RecordNumber >= 0 then LocalDouble := Qry.Current[i].AsDouble; LocalData := PChar(@LocalDouble); end end; SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT: begin rdFields[j].fdDataSize := SizeOf(Double); if RecordNumber >= 0 then LocalDouble := Qry.Current[i].AsDouble; LocalData := PChar(@LocalDouble); end; SQL_VARYING: begin rdFields[j].fdDataSize := Qry.Current[i].Data^.sqllen; rdFields[j].fdDataLength := isc_vax_integer(Qry.Current[i].Data^.sqldata, 2); if RecordNumber >= 0 then begin if (rdFields[j].fdDataLength = 0) then LocalData := nil else begin temp := Qry.Current[i]; LocalData := @temp.Data^.sqldata[2]; (* LocalData := @Qry.Current[i].Data^.sqldata[2];*) end; end; end; else { SQL_TEXT, SQL_BLOB, SQL_ARRAY, SQL_QUAD } begin rdFields[j].fdDataSize := Qry.Current[i].Data^.sqllen; if (rdFields[j].fdDataType = SQL_TEXT) then rdFields[j].fdDataLength := rdFields[j].fdDataSize; end; end; if RecordNumber < 0 then begin rdFields[j].fdIsNull := True; rdFields[j].fdDataOfs := FRecordSize; Inc(FRecordSize, rdFields[j].fdDataSize); end else begin if rdFields[j].fdDataType = SQL_VARYING then begin if LocalData <> nil then Move(LocalData^, Buffer[rdFields[j].fdDataOfs], rdFields[j].fdDataLength) end else Move(LocalData^, Buffer[rdFields[j].fdDataOfs], rdFields[j].fdDataSize) end; end; end; WriteRecordCache(RecordNumber, PChar(p)); end; function TIBCustomDataSet.GetActiveBuf: PChar; begin case State of dsBrowse: if IsEmpty then result := nil else result := ActiveBuffer; dsEdit, dsInsert: result := ActiveBuffer; dsCalcFields: result := CalcBuffer; dsFilter: result := FFilterBuffer; dsNewValue: result := ActiveBuffer; dsOldValue: if (PRecordData(ActiveBuffer)^.rdRecordNumber = PRecordData(FOldBuffer)^.rdRecordNumber) then result := FOldBuffer else result := ActiveBuffer; else if not FOpen then result := nil else result := ActiveBuffer; end; end; function TIBCustomDataSet.CachedUpdateStatus: TCachedUpdateStatus; begin if Active then result := PRecordData(GetActiveBuf)^.rdCachedUpdateStatus else result := cusUnmodified; end; function TIBCustomDataSet.GetDatabase: TIBDatabase; begin result := FBase.Database; end; function TIBCustomDataSet.GetDBHandle: PISC_DB_HANDLE; begin result := FBase.DBHandle; end; function TIBCustomDataSet.GetDeleteSQL: TStrings; begin result := FQDelete.SQL; end; function TIBCustomDataSet.GetInsertSQL: TStrings; begin result := FQInsert.SQL; end; function TIBCustomDataSet.GetSQLParams: TIBXSQLDA; begin if not FInternalPrepared then InternalPrepare; result := FQSelect.Params; end; function TIBCustomDataSet.GetRefreshSQL: TStrings; begin result := FQRefresh.SQL; end; function TIBCustomDataSet.GetSelectSQL: TStrings; begin result := FQSelect.SQL; end; function TIBCustomDataSet.GetStatementType: TIBSQLTypes; begin result := FQSelect.SQLType; end; function TIBCustomDataSet.GetModifySQL: TStrings; begin result := FQModify.SQL; end; function TIBCustomDataSet.GetTransaction: TIBTransaction; begin result := FBase.Transaction; end; function TIBCustomDataSet.GetTRHandle: PISC_TR_HANDLE; begin result := FBase.TRHandle; end; procedure TIBCustomDataSet.InternalDeleteRecord(Qry: TIBSQL; Buff: Pointer); begin if (Assigned(FUpdateObject) and (FUpdateObject.GetSQL(ukDelete).Text <> '')) then FUpdateObject.Apply(ukDelete,Buff) else begin SetInternalSQLParams(FQDelete, Buff); FQDelete.ExecQuery; end; with PRecordData(Buff)^ do begin rdUpdateStatus := usDeleted; rdCachedUpdateStatus := cusUnmodified; end; WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Buff); end; function TIBCustomDataSet.InternalLocate(const KeyFields: string; const KeyValues: Variant; Options: TLocateOptions): Boolean; var keyFieldList: TList; {$IF FPC_FULLVERSION > 20600 } CurBookmark: TBookmark; {$ELSE} CurBookmark: string; {$ENDIF} fieldValue: Variant; lookupValues: array of variant; i, fieldCount: Integer; fieldValueAsString: string; lookupValueAsString: string; begin keyFieldList := TList.Create; try GetFieldList(keyFieldList, KeyFields); fieldCount := keyFieldList.Count; CurBookmark := Bookmark; result := false; SetLength(lookupValues, fieldCount); if not EOF then begin for i := 0 to fieldCount - 1 do {expand key values into lookupValues array} begin if VarIsArray(KeyValues) then lookupValues[i] := KeyValues[i] else if i > 0 then lookupValues[i] := NULL else lookupValues[0] := KeyValues; {convert to upper case is case insensitive search} if (TField(keyFieldList[i]).DataType = ftString) and not VarIsNull(lookupValues[i]) and (loCaseInsensitive in Options) then lookupValues[i] := UpperCase(lookupValues[i]); end; end; while not result and not EOF do {search for a matching record} begin i := 0; result := true; while result and (i < fieldCount) do {see if all of the key fields matches} begin fieldValue := TField(keyFieldList[i]).Value; result := not (VarIsNull(fieldValue) xor VarIsNull(lookupValues[i])); if result and not VarIsNull(fieldValue) then begin try if TField(keyFieldList[i]).DataType = ftString then begin {strings need special handling because of the locate options that apply to them} fieldValueAsString := TField(keyFieldList[i]).AsString; lookupValueAsString := lookupValues[i]; if (loCaseInsensitive in Options) then fieldValueAsString := UpperCase(fieldValueAsString); if (loPartialKey in Options) then result := result and (Pos(lookupValueAsString, fieldValueAsString) = 1) else result := result and (fieldValueAsString = lookupValueAsString); end else result := result and (lookupValues[i] = VarAsType(fieldValue, VarType(lookupValues[i]))); except on EVariantError do result := False; end; end; Inc(i); end; if not result then Next; end; if not result then Bookmark := CurBookmark else CursorPosChanged; finally keyFieldList.Free; SetLength(lookupValues,0) end; end; procedure TIBCustomDataSet.InternalPostRecord(Qry: TIBSQL; Buff: Pointer); var i, j, k: Integer; pbd: PBlobDataArray; begin pbd := PBlobDataArray(PChar(Buff) + FBlobCacheOffset); j := 0; for i := 0 to FieldCount - 1 do if Fields[i].IsBlob then begin k := FMappedFieldPosition[Fields[i].FieldNo -1]; if pbd^[j] <> nil then begin pbd^[j].Finalize; PISC_QUAD( PChar(Buff) + PRecordData(Buff)^.rdFields[k].fdDataOfs)^ := pbd^[j].BlobID; PRecordData(Buff)^.rdFields[k].fdIsNull := pbd^[j].Size = 0; end; Inc(j); end; if Assigned(FUpdateObject) then begin if (Qry = FQDelete) then FUpdateObject.Apply(ukDelete,Buff) else if (Qry = FQInsert) then FUpdateObject.Apply(ukInsert,Buff) else FUpdateObject.Apply(ukModify,Buff); end else begin SetInternalSQLParams(Qry, Buff); Qry.ExecQuery; end; PRecordData(Buff)^.rdUpdateStatus := usUnmodified; PRecordData(Buff)^.rdCachedUpdateStatus := cusUnmodified; SetModified(False); WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Buff); if (FForcedRefresh or FNeedsRefresh) and CanRefresh then InternalRefreshRow; end; procedure TIBCustomDataSet.InternalRefreshRow; var Buff: PChar; SetCursor: Boolean; ofs: DWORD; Qry: TIBSQL; begin SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault); if SetCursor then Screen.Cursor := crHourGlass; try Buff := GetActiveBuf; if CanRefresh then begin if Buff <> nil then begin if (Assigned(FUpdateObject) and (FUpdateObject.RefreshSQL.Text <> '')) then begin Qry := TIBSQL.Create(self); Qry.Database := Database; Qry.Transaction := Transaction; Qry.GoToFirstRecordOnExecute := False; Qry.SQL.Text := FUpdateObject.RefreshSQL.Text; end else Qry := FQRefresh; SetInternalSQLParams(Qry, Buff); Qry.ExecQuery; try if (Qry.SQLType = SQLExecProcedure) or (Qry.Next <> nil) then begin ofs := PRecordData(Buff)^.rdSavedOffset; FetchCurrentRecordToBuffer(Qry, PRecordData(Buff)^.rdRecordNumber, Buff); if FCachedUpdates and (ofs <> $FFFFFFFF) then begin PRecordData(Buff)^.rdSavedOffset := ofs; WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Buff); SaveOldBuffer(Buff); end; end; finally Qry.Close; end; if Qry <> FQRefresh then Qry.Free; end end else IBError(ibxeCannotRefresh, [nil]); finally if SetCursor and (Screen.Cursor = crHourGlass) then Screen.Cursor := crDefault; end; end; procedure TIBCustomDataSet.InternalRevertRecord(RecordNumber: Integer); var NewBuffer, OldBuffer: PRecordData; begin NewBuffer := nil; OldBuffer := nil; NewBuffer := PRecordData(AllocRecordBuffer); OldBuffer := PRecordData(AllocRecordBuffer); try ReadRecordCache(RecordNumber, PChar(NewBuffer), False); ReadRecordCache(RecordNumber, PChar(OldBuffer), True); case NewBuffer^.rdCachedUpdateStatus of cusInserted: begin NewBuffer^.rdCachedUpdateStatus := cusUninserted; Inc(FDeletedRecords); end; cusModified, cusDeleted: begin if (NewBuffer^.rdCachedUpdateStatus = cusDeleted) then Dec(FDeletedRecords); CopyRecordBuffer(OldBuffer, NewBuffer); end; end; if State in dsEditModes then Cancel; WriteRecordCache(RecordNumber, PChar(NewBuffer)); if (NewBuffer^.rdCachedUpdateStatus = cusUninserted ) then ReSync([]); finally FreeRecordBuffer(PChar(NewBuffer)); FreeRecordBuffer(PChar(OldBuffer)); end; end; { A visible record is one that is not truly deleted, and it is also listed in the FUpdateRecordTypes set } function TIBCustomDataSet.IsVisible(Buffer: PChar): Boolean; begin result := True; if not (State = dsOldValue) then result := (PRecordData(Buffer)^.rdCachedUpdateStatus in FUpdateRecordTypes) and (not ((PRecordData(Buffer)^.rdCachedUpdateStatus = cusUnmodified) and (PRecordData(Buffer)^.rdUpdateStatus = usDeleted))); end; function TIBCustomDataSet.LocateNext(const KeyFields: string; const KeyValues: Variant; Options: TLocateOptions): Boolean; begin DisableControls; try result := InternalLocate(KeyFields, KeyValues, Options); finally EnableControls; end; end; procedure TIBCustomDataSet.InternalPrepare; var SetCursor: Boolean; DidActivate: Boolean; begin if FInternalPrepared then Exit; DidActivate := False; SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault); if SetCursor then Screen.Cursor := crHourGlass; try ActivateConnection; DidActivate := ActivateTransaction; FBase.CheckDatabase; FBase.CheckTransaction; if FQSelect.SQL.Text <> '' then begin if not FQSelect.Prepared then begin FQSelect.ParamCheck := ParamCheck; FQSelect.Prepare; end; if (Trim(FQDelete.SQL.Text) <> '') and (not FQDelete.Prepared) then FQDelete.Prepare; if (Trim(FQInsert.SQL.Text) <> '') and (not FQInsert.Prepared) then FQInsert.Prepare; if (Trim(FQRefresh.SQL.Text) <> '') and (not FQRefresh.Prepared) then FQRefresh.Prepare; if (Trim(FQModify.SQL.Text) <> '') and (not FQModify.Prepared) then FQModify.Prepare; FInternalPrepared := True; InternalInitFieldDefs; end else IBError(ibxeEmptyQuery, [nil]); finally if DidActivate then DeactivateTransaction; if SetCursor and (Screen.Cursor = crHourGlass) then Screen.Cursor := crDefault; end; end; procedure TIBCustomDataSet.RecordModified(Value: Boolean); begin SetModified(Value); end; procedure TIBCustomDataSet.RevertRecord; var Buff: PRecordData; begin if FCachedUpdates and FUpdatesPending then begin Buff := PRecordData(GetActiveBuf); InternalRevertRecord(Buff^.rdRecordNumber); ReadRecordCache(Buff^.rdRecordNumber, PChar(Buff), False); DataEvent(deRecordChange, 0); end; end; procedure TIBCustomDataSet.SaveOldBuffer(Buffer: PChar); var OldBuffer: Pointer; procedure CopyOldBuffer; begin CopyRecordBuffer(Buffer, OldBuffer); if BlobFieldCount > 0 then FillChar(PChar(OldBuffer)[FBlobCacheOffset], BlobFieldCount * SizeOf(TIBBlobStream), 0); end; begin if (Buffer <> nil) and (PRecordData(Buffer)^.rdRecordNumber >= 0) then begin OldBuffer := AllocRecordBuffer; try if (PRecordData(Buffer)^.rdSavedOffset = $FFFFFFFF) then begin PRecordData(Buffer)^.rdSavedOffset := AdjustPosition(FOldBufferCache, 0, FILE_END); CopyOldBuffer; WriteCache(FOldBufferCache, 0, FILE_CURRENT, OldBuffer); WriteCache(FBufferCache, PRecordData(Buffer)^.rdRecordNumber * FRecordBufferSize, FILE_BEGIN, Buffer); end else begin CopyOldBuffer; WriteCache(FOldBufferCache, PRecordData(Buffer)^.rdSavedOffset, FILE_BEGIN, OldBuffer); end; finally FreeRecordBuffer(PChar(OldBuffer)); end; end; end; procedure TIBCustomDataSet.SetBufferChunks(Value: Integer); begin if (Value <= 0) then FBufferChunks := BufferCacheSize else FBufferChunks := Value; end; procedure TIBCustomDataSet.SetDatabase(Value: TIBDatabase); begin if (FBase.Database <> Value) then begin CheckDatasetClosed; FBase.Database := Value; FQDelete.Database := Value; FQInsert.Database := Value; FQRefresh.Database := Value; FQSelect.Database := Value; FQModify.Database := Value; end; end; procedure TIBCustomDataSet.SetDeleteSQL(Value: TStrings); begin if FQDelete.SQL.Text <> Value.Text then begin Disconnect; FQDelete.SQL.Assign(Value); end; end; procedure TIBCustomDataSet.SetInsertSQL(Value: TStrings); begin if FQInsert.SQL.Text <> Value.Text then begin Disconnect; FQInsert.SQL.Assign(Value); end; end; procedure TIBCustomDataSet.SetInternalSQLParams(Qry: TIBSQL; Buffer: Pointer); var i, j: Integer; cr, data: PChar; fn, st: string; OldBuffer: Pointer; ts: TTimeStamp; begin if (Buffer = nil) then IBError(ibxeBufferNotSet, [nil]); if (not FInternalPrepared) then InternalPrepare; OldBuffer := nil; try for i := 0 to Qry.Params.Count - 1 do begin fn := Qry.Params[i].Name; if (Pos('OLD_', fn) = 1) then {mbcs ok} begin fn := Copy(fn, 5, Length(fn)); if not Assigned(OldBuffer) then begin OldBuffer := AllocRecordBuffer; ReadRecordCache(PRecordData(Buffer)^.rdRecordNumber, OldBuffer, True); end; cr := OldBuffer; end else if (Pos('NEW_', fn) = 1) then {mbcs ok} begin fn := Copy(fn, 5, Length(fn)); cr := Buffer; end else cr := Buffer; j := FQSelect.FieldIndex[fn] + 1; if (j > 0) then with PRecordData(cr)^ do begin if Qry.Params[i].name = 'IBX_INTERNAL_DBKEY' then {do not localize} begin PIBDBKey(Qry.Params[i].AsPointer)^ := rdDBKey; continue; end; if rdFields[j].fdIsNull then Qry.Params[i].IsNull := True else begin Qry.Params[i].IsNull := False; data := cr + rdFields[j].fdDataOfs; case rdFields[j].fdDataType of SQL_TEXT, SQL_VARYING: begin SetString(st, data, rdFields[j].fdDataLength); Qry.Params[i].AsString := st; end; SQL_FLOAT, SQL_DOUBLE, SQL_D_FLOAT: Qry.Params[i].AsDouble := PDouble(data)^; SQL_SHORT, SQL_LONG: begin if rdFields[j].fdDataScale = 0 then Qry.Params[i].AsLong := PLong(data)^ else if rdFields[j].fdDataScale >= (-4) then Qry.Params[i].AsCurrency := PCurrency(data)^ else Qry.Params[i].AsDouble := PDouble(data)^; end; SQL_INT64: begin if rdFields[j].fdDataScale = 0 then Qry.Params[i].AsInt64 := PInt64(data)^ else if rdFields[j].fdDataScale >= (-4) then Qry.Params[i].AsCurrency := PCurrency(data)^ else Qry.Params[i].AsDouble := PDouble(data)^; end; SQL_BLOB, SQL_ARRAY, SQL_QUAD: Qry.Params[i].AsQuad := PISC_QUAD(data)^; SQL_TYPE_DATE: begin ts.Date := PInt(data)^; ts.Time := 0; Qry.Params[i].AsDate := TimeStampToDateTime(ts); end; SQL_TYPE_TIME: begin ts.Date := 0; ts.Time := PInt(data)^; Qry.Params[i].AsTime := TimeStampToDateTime(ts); end; SQL_TIMESTAMP: Qry.Params[i].AsDateTime := TimeStampToDateTime(MSecsToTimeStamp(trunc(PDouble(data)^))); end; end; end; end; finally if (OldBuffer <> nil) then FreeRecordBuffer(PChar(OldBuffer)); end; end; procedure TIBCustomDataSet.SetRefreshSQL(Value: TStrings); begin if FQRefresh.SQL.Text <> Value.Text then begin Disconnect; FQRefresh.SQL.Assign(Value); end; end; procedure TIBCustomDataSet.SetSelectSQL(Value: TStrings); begin if FQSelect.SQL.Text <> Value.Text then begin Disconnect; FQSelect.SQL.Assign(Value); end; end; procedure TIBCustomDataSet.SetModifySQL(Value: TStrings); begin if FQModify.SQL.Text <> Value.Text then begin Disconnect; FQModify.SQL.Assign(Value); end; end; procedure TIBCustomDataSet.SetTransaction(Value: TIBTransaction); begin if (FBase.Transaction <> Value) then begin CheckDatasetClosed; FBase.Transaction := Value; FQDelete.Transaction := Value; FQInsert.Transaction := Value; FQRefresh.Transaction := Value; FQSelect.Transaction := Value; FQModify.Transaction := Value; end; end; procedure TIBCustomDataSet.SetUniDirectional(Value: Boolean); begin CheckDatasetClosed; FUniDirectional := Value; end; procedure TIBCustomDataSet.SetUpdateRecordTypes(Value: TIBUpdateRecordTypes); begin FUpdateRecordTypes := Value; if Active then First; end; procedure TIBCustomDataSet.RefreshParams; var DataSet: TDataSet; begin DisableControls; try if FDataLink.DataSource <> nil then begin DataSet := FDataLink.DataSource.DataSet; if DataSet <> nil then if DataSet.Active and (DataSet.State <> dsSetKey) then begin Close; Open; end; end; finally EnableControls; end; end; procedure TIBCustomDataSet.SQLChanging(Sender: TObject); begin if FOpen then InternalClose; if FInternalPrepared then InternalUnPrepare; end; { I can "undelete" uninserted records (make them "inserted" again). I can "undelete" cached deleted (the deletion hasn't yet occurred) } procedure TIBCustomDataSet.Undelete; var Buff: PRecordData; begin CheckActive; Buff := PRecordData(GetActiveBuf); with Buff^ do begin if rdCachedUpdateStatus = cusUninserted then begin rdCachedUpdateStatus := cusInserted; Dec(FDeletedRecords); end else if (rdUpdateStatus = usDeleted) and (rdCachedUpdateStatus = cusDeleted) then begin rdCachedUpdateStatus := cusUnmodified; rdUpdateStatus := usUnmodified; Dec(FDeletedRecords); end; WriteRecordCache(rdRecordNumber, PChar(Buff)); end; end; function TIBCustomDataSet.UpdateStatus: TUpdateStatus; begin if Active then if GetActiveBuf <> nil then result := PRecordData(GetActiveBuf)^.rdUpdateStatus else result := usUnmodified else result := usUnmodified; end; function TIBCustomDataSet.IsSequenced: Boolean; begin Result := Assigned( FQSelect ) and FQSelect.EOF; end; function TIBCustomDataSet.ParamByName(ParamName: String): TIBXSQLVAR; begin ActivateConnection; ActivateTransaction; if not FInternalPrepared then InternalPrepare; Result := Params.ByName(ParamName); end; {Beware: the parameter FCache is used as an identifier to determine which cache is being operated on and is not referenced in the computation. The result is an adjusted offset into the identified cache, either the Buffer Cache or the old Buffer Cache.} function TIBCustomDataSet.AdjustPosition(FCache: PChar; Offset: DWORD; Origin: Integer): DWORD; var OldCacheSize: Integer; begin if (FCache = FBufferCache) then begin case Origin of FILE_BEGIN: FBPos := Offset; FILE_CURRENT: FBPos := FBPos + Offset; FILE_END: FBPos := DWORD(FBEnd) + Offset; end; OldCacheSize := FCacheSize; while (FBPos >= DWORD(FCacheSize)) do Inc(FCacheSize, FBufferChunkSize); if FCacheSize > OldCacheSize then IBAlloc(FBufferCache, FCacheSize, FCacheSize); result := FBPos; end else begin case Origin of FILE_BEGIN: FOBPos := Offset; FILE_CURRENT: FOBPos := FOBPos + Offset; FILE_END: FOBPos := DWORD(FOBEnd) + Offset; end; OldCacheSize := FOldCacheSize; while (FBPos >= DWORD(FOldCacheSize)) do Inc(FOldCacheSize, FBufferChunkSize); if FOldCacheSize > OldCacheSize then IBAlloc(FOldBufferCache, FOldCacheSize, FOldCacheSize); result := FOBPos; end; end; procedure TIBCustomDataSet.ReadCache(FCache: PChar; Offset: DWORD; Origin: Integer; Buffer: PChar); var pCache: PChar; AdjustedOffset: DWORD; bOld: Boolean; begin bOld := (FCache = FOldBufferCache); AdjustedOffset := AdjustPosition(FCache, Offset, Origin); if not bOld then pCache := FBufferCache + AdjustedOffset else pCache := FOldBufferCache + AdjustedOffset; Move(pCache^, Buffer^, DWORD(FRecordBufferSize)); AdjustPosition(FCache, FRecordBufferSize, FILE_CURRENT); end; procedure TIBCustomDataSet.ReadRecordCache(RecordNumber: Integer; Buffer: PChar; ReadOldBuffer: Boolean); begin if FUniDirectional then RecordNumber := RecordNumber mod UniCache; if (ReadOldBuffer) then begin ReadRecordCache(RecordNumber, Buffer, False); if FCachedUpdates and (PRecordData(Buffer)^.rdSavedOffset <> $FFFFFFFF) then ReadCache(FOldBufferCache, PRecordData(Buffer)^.rdSavedOffset, FILE_BEGIN, Buffer) else if ReadOldBuffer and (PRecordData(FOldBuffer)^.rdRecordNumber = RecordNumber) then CopyRecordBuffer( FOldBuffer, Buffer ) end else ReadCache(FBufferCache, RecordNumber * FRecordBufferSize, FILE_BEGIN, Buffer); end; procedure TIBCustomDataSet.WriteCache(FCache: PChar; Offset: DWORD; Origin: Integer; Buffer: PChar); var pCache: PChar; AdjustedOffset: DWORD; bOld: Boolean; dwEnd: DWORD; begin bOld := (FCache = FOldBufferCache); AdjustedOffset := AdjustPosition(FCache, Offset, Origin); if not bOld then pCache := FBufferCache + AdjustedOffset else pCache := FOldBufferCache + AdjustedOffset; Move(Buffer^, pCache^, FRecordBufferSize); dwEnd := AdjustPosition(FCache, FRecordBufferSize, FILE_CURRENT); if not bOld then begin if (dwEnd > FBEnd) then FBEnd := dwEnd; end else begin if (dwEnd > FOBEnd) then FOBEnd := dwEnd; end; end; procedure TIBCustomDataSet.WriteRecordCache(RecordNumber: Integer; Buffer: PChar); begin if RecordNumber >= 0 then begin if FUniDirectional then RecordNumber := RecordNumber mod UniCache; WriteCache(FBufferCache, RecordNumber * FRecordBufferSize, FILE_BEGIN, Buffer); end; end; function TIBCustomDataSet.AllocRecordBuffer: PChar; begin result := nil; IBAlloc(result, FRecordBufferSize, FRecordBufferSize); Move(FModelBuffer^, result^, FRecordBufferSize); end; function TIBCustomDataSet.CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; var pb: PBlobDataArray; fs: TIBBlobStream; Buff: PChar; bTr, bDB: Boolean; begin Buff := GetActiveBuf; if Buff = nil then begin fs := TIBBlobStream.Create; fs.Mode := bmReadWrite; FBlobStreamList.Add(Pointer(fs)); result := TIBDSBlobStream.Create(Field, fs, Mode); exit; end; pb := PBlobDataArray(Buff + FBlobCacheOffset); if pb^[Field.Offset] = nil then begin AdjustRecordOnInsert(Buff); pb^[Field.Offset] := TIBBlobStream.Create; fs := pb^[Field.Offset]; FBlobStreamList.Add(Pointer(fs)); fs.Mode := bmReadWrite; fs.Database := Database; fs.Transaction := Transaction; fs.BlobID := PISC_QUAD(@Buff[PRecordData(Buff)^.rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataOfs])^; if (CachedUpdates) then begin bTr := not Transaction.InTransaction; bDB := not Database.Connected; if bDB then Database.Open; if bTr then Transaction.StartTransaction; fs.Seek(0, soFromBeginning); if bTr then Transaction.Commit; if bDB then Database.Close; end; WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Pointer(Buff)); end else fs := pb^[Field.Offset]; result := TIBDSBlobStream.Create(Field, fs, Mode); end; function TIBCustomDataSet.CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Integer; const CMPLess = -1; CMPEql = 0; CMPGtr = 1; RetCodes: array[Boolean, Boolean] of ShortInt = ((2, CMPLess), (CMPGtr, CMPEql)); begin result := RetCodes[Bookmark1 = nil, Bookmark2 = nil]; if Result = 2 then begin if PInteger(Bookmark1)^ < PInteger(Bookmark2)^ then Result := CMPLess else if PInteger(Bookmark1)^ > PInteger(Bookmark2)^ then Result := CMPGtr else Result := CMPEql; end; end; procedure TIBCustomDataSet.DoBeforeDelete; var Buff: PRecordData; begin if not CanDelete then IBError(ibxeCannotDelete, [nil]); Buff := PRecordData(GetActiveBuf); if FCachedUpdates and (Buff^.rdCachedUpdateStatus in [cusUnmodified]) then SaveOldBuffer(PChar(Buff)); inherited DoBeforeDelete; end; procedure TIBCustomDataSet.DoBeforeEdit; var Buff: PRecordData; begin Buff := PRecordData(GetActiveBuf); if not(CanEdit or (FQModify.SQL.Count <> 0) or (FCachedUpdates and Assigned(FOnUpdateRecord))) then IBError(ibxeCannotUpdate, [nil]); if FCachedUpdates and (Buff^.rdCachedUpdateStatus in [cusUnmodified, cusInserted]) then SaveOldBuffer(PChar(Buff)); CopyRecordBuffer(GetActiveBuf, FOldBuffer); inherited DoBeforeEdit; end; procedure TIBCustomDataSet.DoBeforeInsert; begin if not CanInsert then IBError(ibxeCannotInsert, [nil]); inherited DoBeforeInsert; end; procedure TIBCustomDataSet.DoAfterInsert; begin if GeneratorField.ApplyOnEvent = gaeOnNewRecord then GeneratorField.Apply; inherited DoAfterInsert; end; procedure TIBCustomDataSet.DoBeforePost; begin inherited DoBeforePost; if (State = dsInsert) and (GeneratorField.ApplyOnEvent = gaeOnPostRecord) then GeneratorField.Apply end; procedure TIBCustomDataSet.FetchAll; var SetCursor: Boolean; {$IF FPC_FULLVERSION > 20600 } CurBookmark: TBookmark; {$ELSE} CurBookmark: string; {$ENDIF} begin SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault); if SetCursor then Screen.Cursor := crHourGlass; try if FQSelect.EOF or not FQSelect.Open then exit; DisableControls; try CurBookmark := Bookmark; Last; Bookmark := CurBookmark; finally EnableControls; end; finally if SetCursor and (Screen.Cursor = crHourGlass) then Screen.Cursor := crDefault; end; end; procedure TIBCustomDataSet.FreeRecordBuffer(var Buffer: PChar); begin FreeMem(Buffer); Buffer := nil; end; procedure TIBCustomDataSet.GetBookmarkData(Buffer: PChar; Data: Pointer); begin Move(PRecordData(Buffer)^.rdRecordNumber, Data^, BookmarkSize); end; function TIBCustomDataSet.GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; begin result := PRecordData(Buffer)^.rdBookmarkFlag; end; function TIBCustomDataSet.GetCanModify: Boolean; begin result := (FQInsert.SQL.Text <> '') or (FQModify.SQL.Text <> '') or (FQDelete.SQL.Text <> '') or (Assigned(FUpdateObject)); end; function TIBCustomDataSet.GetCurrentRecord(Buffer: PChar): Boolean; begin if not IsEmpty and (GetBookmarkFlag(ActiveBuffer) = bfCurrent) then begin UpdateCursorPos; ReadRecordCache(PRecordData(ActiveBuffer)^.rdRecordNumber, Buffer, False); result := True; end else result := False; end; function TIBCustomDataSet.GetDataSource: TDataSource; begin if FDataLink = nil then result := nil else result := FDataLink.DataSource; end; function TIBCustomDataSet.GetFieldClass(FieldType: TFieldType): TFieldClass; begin Result := DefaultFieldClasses[FieldType]; end; function TIBCustomDataSet.GetFieldData(FieldNo: Integer; Buffer: Pointer): Boolean; begin result := GetFieldData(FieldByNumber(FieldNo), buffer); end; function TIBCustomDataSet.InternalGetFieldData(Field: TField; Buffer: Pointer): Boolean; var Buff, Data: PChar; CurrentRecord: PRecordData; begin result := False; Buff := GetActiveBuf; if (Buff = nil) or (not IsVisible(Buff)) or not assigned(Field.DataSet) then exit; { The intention here is to stuff the buffer with the data for the referenced field for the current record } CurrentRecord := PRecordData(Buff); if (Field.FieldNo < 0) then begin Inc(Buff, FRecordSize + Field.Offset); result := Boolean(Buff[0]); if result and (Buffer <> nil) then Move(Buff[1], Buffer^, Field.DataSize); end else if (FMappedFieldPosition[Field.FieldNo - 1] > 0) and (FMappedFieldPosition[Field.FieldNo - 1] <= CurrentRecord^.rdFieldCount) then begin result := not CurrentRecord^.rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdIsNull; if result and (Buffer <> nil) then with CurrentRecord^.rdFields[FMappedFieldPosition[Field.FieldNo - 1]] do begin Data := Buff + CurrentRecord^.rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataOfs; if (fdDataType = SQL_VARYING) or (fdDataType = SQL_TEXT) then begin if fdDataLength <= Field.Size then begin Move(Data^, Buffer^, fdDataLength); PChar(Buffer)[fdDataLength] := #0; end else IBError(ibxeFieldSizeError,[Field.FieldName]) end else Move(Data^, Buffer^, Field.DataSize); end; end; end; { GetRecNo and SetRecNo both operate off of 1-based indexes as opposed to 0-based indexes. This is because we want LastRecordNumber/RecordCount = 1 } function TIBCustomDataSet.GetRecNo: Integer; begin if GetActiveBuf = nil then result := 0 else result := PRecordData(GetActiveBuf)^.rdRecordNumber + 1; end; function TIBCustomDataSet.GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult; var Accept: Boolean; SaveState: TDataSetState; begin Result := grOK; if Filtered and Assigned(OnFilterRecord) then begin Accept := False; SaveState := SetTempState(dsFilter); while not Accept do begin Result := InternalGetRecord(Buffer, GetMode, DoCheck); if Result <> grOK then break; FFilterBuffer := Buffer; try Accept := True; OnFilterRecord(Self, Accept); if not Accept and (GetMode = gmCurrent) then GetMode := gmPrior; except // Application.HandleException(Self); end; end; RestoreState(SaveState); end else Result := InternalGetRecord(Buffer, GetMode, DoCheck); end; function TIBCustomDataSet.InternalGetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult; begin result := grError; case GetMode of gmCurrent: begin if (FCurrentRecord >= 0) then begin if FCurrentRecord < FRecordCount then ReadRecordCache(FCurrentRecord, Buffer, False) else begin while (not FQSelect.EOF) and (FQSelect.Next <> nil) and (FCurrentRecord >= FRecordCount) do begin FetchCurrentRecordToBuffer(FQSelect, FRecordCount, Buffer); Inc(FRecordCount); end; FCurrentRecord := FRecordCount - 1; if (FCurrentRecord >= 0) then ReadRecordCache(FCurrentRecord, Buffer, False); end; result := grOk; end else result := grBOF; end; gmNext: begin result := grOk; if FCurrentRecord = FRecordCount then result := grEOF else if FCurrentRecord = FRecordCount - 1 then begin if (not FQSelect.EOF) then begin FQSelect.Next; Inc(FCurrentRecord); end; if (FQSelect.EOF) then begin result := grEOF; end else begin Inc(FRecordCount); FetchCurrentRecordToBuffer(FQSelect, FCurrentRecord, Buffer); end; end else if (FCurrentRecord < FRecordCount) then begin Inc(FCurrentRecord); ReadRecordCache(FCurrentRecord, Buffer, False); end; end; else { gmPrior } begin if (FCurrentRecord = 0) then begin Dec(FCurrentRecord); result := grBOF; end else if (FCurrentRecord > 0) and (FCurrentRecord <= FRecordCount) then begin Dec(FCurrentRecord); ReadRecordCache(FCurrentRecord, Buffer, False); result := grOk; end else if (FCurrentRecord = -1) then result := grBOF; end; end; if result = grOk then result := AdjustCurrentRecord(Buffer, GetMode); if result = grOk then with PRecordData(Buffer)^ do begin rdBookmarkFlag := bfCurrent; GetCalcFields(Buffer); end else if (result = grEOF) then begin CopyRecordBuffer(FModelBuffer, Buffer); PRecordData(Buffer)^.rdBookmarkFlag := bfEOF; end else if (result = grBOF) then begin CopyRecordBuffer(FModelBuffer, Buffer); PRecordData(Buffer)^.rdBookmarkFlag := bfBOF; end else if (result = grError) then begin CopyRecordBuffer(FModelBuffer, Buffer); PRecordData(Buffer)^.rdBookmarkFlag := bfEOF; end;; end; function TIBCustomDataSet.GetRecordCount: Integer; begin result := FRecordCount - FDeletedRecords; end; function TIBCustomDataSet.GetRecordSize: Word; begin result := FRecordBufferSize; end; procedure TIBCustomDataSet.InternalAddRecord(Buffer: Pointer; Append: Boolean); begin CheckEditState; begin { When adding records, we *always* append. Insertion is just too costly } AdjustRecordOnInsert(Buffer); with PRecordData(Buffer)^ do begin rdUpdateStatus := usInserted; rdCachedUpdateStatus := cusInserted; end; if not CachedUpdates then InternalPostRecord(FQInsert, Buffer) else begin WriteRecordCache(FCurrentRecord, Buffer); FUpdatesPending := True; end; Inc(FRecordCount); InternalSetToRecord(Buffer); end end; procedure TIBCustomDataSet.InternalCancel; var Buff: PChar; CurRec: Integer; begin inherited InternalCancel; Buff := GetActiveBuf; if Buff <> nil then begin CurRec := FCurrentRecord; AdjustRecordOnInsert(Buff); if (State = dsEdit) then begin CopyRecordBuffer(FOldBuffer, Buff); WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Buff); end else begin CopyRecordBuffer(FModelBuffer, Buff); PRecordData(Buff)^.rdUpdateStatus := usDeleted; PRecordData(Buff)^.rdCachedUpdateStatus := cusUnmodified; PRecordData(Buff)^.rdBookmarkFlag := bfEOF; FCurrentRecord := CurRec; end; end; end; procedure TIBCustomDataSet.InternalClose; begin if FDidActivate then DeactivateTransaction; FQSelect.Close; ClearBlobCache; FreeRecordBuffer(FModelBuffer); FreeRecordBuffer(FOldBuffer); FCurrentRecord := -1; FOpen := False; FRecordCount := 0; FDeletedRecords := 0; FRecordSize := 0; FBPos := 0; FOBPos := 0; FCacheSize := 0; FOldCacheSize := 0; FBEnd := 0; FOBEnd := 0; FreeMem(FBufferCache); FBufferCache := nil; FreeMem(FOldBufferCache); FOldBufferCache := nil; BindFields(False); if DefaultFields then DestroyFields; end; procedure TIBCustomDataSet.InternalDelete; var Buff: PChar; SetCursor: Boolean; begin SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault); if SetCursor then Screen.Cursor := crHourGlass; try Buff := GetActiveBuf; if CanDelete then begin if not CachedUpdates then InternalDeleteRecord(FQDelete, Buff) else begin with PRecordData(Buff)^ do begin if rdCachedUpdateStatus = cusInserted then rdCachedUpdateStatus := cusUninserted else begin rdUpdateStatus := usDeleted; rdCachedUpdateStatus := cusDeleted; end; end; WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Buff); end; Inc(FDeletedRecords); FUpdatesPending := True; end else IBError(ibxeCannotDelete, [nil]); finally if SetCursor and (Screen.Cursor = crHourGlass) then Screen.Cursor := crDefault; end; end; procedure TIBCustomDataSet.InternalFirst; begin FCurrentRecord := -1; end; procedure TIBCustomDataSet.InternalGotoBookmark(Bookmark: Pointer); begin FCurrentRecord := PInteger(Bookmark)^; end; procedure TIBCustomDataSet.InternalHandleException; begin Application.HandleException(Self) end; procedure TIBCustomDataSet.InternalInitFieldDefs; const DefaultSQL = 'Select F.RDB$COMPUTED_BLR, ' + {do not localize} 'F.RDB$DEFAULT_VALUE, R.RDB$FIELD_NAME ' + {do not localize} 'from RDB$RELATION_FIELDS R, RDB$FIELDS F ' + {do not localize} 'where R.RDB$RELATION_NAME = :RELATION ' + {do not localize} 'and R.RDB$FIELD_SOURCE = F.RDB$FIELD_NAME '+ {do not localize} 'and ((not F.RDB$COMPUTED_BLR is NULL) or ' + {do not localize} ' (not F.RDB$DEFAULT_VALUE is NULL)) '; {do not localize} var FieldType: TFieldType; FieldSize: Word; FieldNullable : Boolean; i, FieldPosition, FieldPrecision: Integer; FieldAliasName: string; RelationName, FieldName: string; Query : TIBSQL; FieldIndex: Integer; FRelationNodes : TRelationNode; function Add_Node(Relation, Field : String) : TRelationNode; var FField : TFieldNode; begin if FRelationNodes.RelationName = '' then Result := FRelationNodes else begin Result := TRelationNode.Create; Result.NextRelation := FRelationNodes; end; Result.RelationName := Relation; FRelationNodes := Result; Query.Params[0].AsString := Relation; Query.ExecQuery; while not Query.Eof do begin FField := TFieldNode.Create; FField.FieldName := Query.Fields[2].AsString; FField.DEFAULT_VALUE := not Query.Fields[1].IsNull; FField.COMPUTED_BLR := not Query.Fields[0].IsNull; FField.NextField := Result.FieldNodes; Result.FieldNodes := FField; Query.Next; end; Query.Close; end; function Has_COMPUTED_BLR(Relation, Field : String) : Boolean; var FRelation : TRelationNode; FField : TFieldNode; begin FRelation := FRelationNodes; while Assigned(FRelation) and (FRelation.RelationName <> Relation) do FRelation := FRelation.NextRelation; if not Assigned(FRelation) then FRelation := Add_Node(Relation, Field); Result := false; FField := FRelation.FieldNodes; while Assigned(FField) do if FField.FieldName = Field then begin Result := Ffield.COMPUTED_BLR; Exit; end else FField := Ffield.NextField; end; function Has_DEFAULT_VALUE(Relation, Field : String) : Boolean; var FRelation : TRelationNode; FField : TFieldNode; begin FRelation := FRelationNodes; while Assigned(FRelation) and (FRelation.RelationName <> Relation) do FRelation := FRelation.NextRelation; if not Assigned(FRelation) then FRelation := Add_Node(Relation, Field); Result := false; FField := FRelation.FieldNodes; while Assigned(FField) do if FField.FieldName = Field then begin Result := Ffield.DEFAULT_VALUE; Exit; end else FField := Ffield.NextField; end; Procedure FreeNodes; var FRelation : TRelationNode; FField : TFieldNode; begin while Assigned(FRelationNodes) do begin While Assigned(FRelationNodes.FieldNodes) do begin FField := FRelationNodes.FieldNodes.NextField; FRelationNodes.FieldNodes.Free; FRelationNodes.FieldNodes := FField; end; FRelation := FRelationNodes.NextRelation; FRelationNodes.Free; FRelationNodes := FRelation; end; end; begin if not InternalPrepared then begin InternalPrepare; exit; end; FRelationNodes := TRelationNode.Create; FNeedsRefresh := False; Database.InternalTransaction.StartTransaction; Query := TIBSQL.Create(self); try Query.Database := DataBase; Query.Transaction := Database.InternalTransaction; FieldDefs.BeginUpdate; FieldDefs.Clear; FieldIndex := 0; if (Length(FMappedFieldPosition) < FQSelect.Current.Count) then SetLength(FMappedFieldPosition, FQSelect.Current.Count); Query.SQL.Text := DefaultSQL; Query.Prepare; for i := 0 to FQSelect.Current.Count - 1 do with FQSelect.Current[i].Data^ do begin { Get the field name } SetString(FieldAliasName, aliasname, aliasname_length); SetString(RelationName, relname, relname_length); SetString(FieldName, sqlname, sqlname_length); FieldSize := 0; FieldPrecision := 0; FieldNullable := FQSelect.Current[i].IsNullable; case sqltype and not 1 of { All VARCHAR's must be converted to strings before recording their values } SQL_VARYING, SQL_TEXT: begin FieldSize := sqllen; FieldType := ftString; end; { All Doubles/Floats should be cast to doubles } SQL_DOUBLE, SQL_FLOAT: FieldType := ftFloat; SQL_SHORT: begin if (sqlscale = 0) then FieldType := ftSmallInt else begin FieldType := ftBCD; FieldPrecision := 4; FieldSize := -sqlscale; end; end; SQL_LONG: begin if (sqlscale = 0) then FieldType := ftInteger else if (sqlscale >= (-4)) then begin FieldType := ftBCD; FieldPrecision := 9; FieldSize := -sqlscale; end else if Database.SQLDialect = 1 then FieldType := ftFloat else if (FieldCount > i) and (Fields[i] is TFloatField) then FieldType := ftFloat else begin FieldType := ftFMTBCD; FieldPrecision := 9; FieldSize := -sqlscale; end; end; SQL_INT64: begin if (sqlscale = 0) then FieldType := ftLargeInt else if (sqlscale >= (-4)) then begin FieldType := ftBCD; FieldPrecision := 18; FieldSize := -sqlscale; end else FieldType := ftFloat end; SQL_TIMESTAMP: FieldType := ftDateTime; SQL_TYPE_TIME: FieldType := ftTime; SQL_TYPE_DATE: FieldType := ftDate; SQL_BLOB: begin FieldSize := sizeof (TISC_QUAD); if (sqlsubtype = 1) then FieldType := ftmemo else FieldType := ftBlob; end; SQL_ARRAY: begin FieldSize := sizeof (TISC_QUAD); FieldType := ftUnknown; end; else FieldType := ftUnknown; end; FieldPosition := i + 1; if (FieldType <> ftUnknown) and (FieldAliasName <> 'IBX_INTERNAL_DBKEY') then {do not localize} begin FMappedFieldPosition[FieldIndex] := FieldPosition; Inc(FieldIndex); with FieldDefs.AddFieldDef do begin Name := FieldAliasName; (* FieldNo := FieldPosition;*) DataType := FieldType; Size := FieldSize; Precision := FieldPrecision; Required := not FieldNullable; InternalCalcField := False; if (FieldName <> '') and (RelationName <> '') then begin if Has_COMPUTED_BLR(RelationName, FieldName) then begin Attributes := [faReadOnly]; InternalCalcField := True; FNeedsRefresh := True; end else begin if Has_DEFAULT_VALUE(RelationName, FieldName) then begin if not FieldNullable then Attributes := [faRequired]; end else FNeedsRefresh := True; end; end; end; end; end; finally Query.free; FreeNodes; Database.InternalTransaction.Commit; FieldDefs.EndUpdate; end; end; procedure TIBCustomDataSet.InternalInitRecord(Buffer: PChar); begin CopyRecordBuffer(FModelBuffer, Buffer); end; procedure TIBCustomDataSet.InternalLast; var Buffer: PChar; begin if (FQSelect.EOF) then FCurrentRecord := FRecordCount else begin Buffer := AllocRecordBuffer; try while FQSelect.Next <> nil do begin FetchCurrentRecordToBuffer(FQSelect, FRecordCount, Buffer); Inc(FRecordCount); end; FCurrentRecord := FRecordCount; finally FreeRecordBuffer(Buffer); end; end; end; procedure TIBCustomDataSet.InternalSetParamsFromCursor; var i: Integer; cur_param: TIBXSQLVAR; cur_field: TField; s: TStream; begin if FQSelect.SQL.Text = '' then IBError(ibxeEmptyQuery, [nil]); if not FInternalPrepared then InternalPrepare; if (SQLParams.Count > 0) and (DataSource <> nil) and (DataSource.DataSet <> nil) then begin for i := 0 to SQLParams.Count - 1 do begin cur_field := DataSource.DataSet.FindField(SQLParams[i].Name); cur_param := SQLParams[i]; if (cur_field <> nil) then begin if (cur_field.IsNull) then cur_param.IsNull := True else case cur_field.DataType of ftString: cur_param.AsString := cur_field.AsString; ftBoolean, ftSmallint, ftWord: cur_param.AsShort := cur_field.AsInteger; ftInteger: cur_param.AsLong := cur_field.AsInteger; ftLargeInt: cur_param.AsInt64 := TLargeIntField(cur_field).AsLargeInt; ftFloat, ftCurrency: cur_param.AsDouble := cur_field.AsFloat; ftBCD: cur_param.AsCurrency := cur_field.AsCurrency; ftDate: cur_param.AsDate := cur_field.AsDateTime; ftTime: cur_param.AsTime := cur_field.AsDateTime; ftDateTime: cur_param.AsDateTime := cur_field.AsDateTime; ftBlob, ftMemo: begin s := nil; try s := DataSource.DataSet. CreateBlobStream(cur_field, bmRead); cur_param.LoadFromStream(s); finally s.free; end; end; else IBError(ibxeNotSupported, [nil]); end; end; end; end; end; procedure TIBCustomDataSet.ReQuery; begin FQSelect.Close; ClearBlobCache; FCurrentRecord := -1; FRecordCount := 0; FDeletedRecords := 0; FBPos := 0; FOBPos := 0; FBEnd := 0; FOBEnd := 0; FQSelect.Close; FQSelect.ExecQuery; FOpen := FQSelect.Open; First; end; procedure TIBCustomDataSet.InternalOpen; var SetCursor: Boolean; function RecordDataLength(n: Integer): Long; begin result := SizeOf(TRecordData) + ((n - 1) * SizeOf(TFieldData)); end; begin SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault); if SetCursor then Screen.Cursor := crHourGlass; try ActivateConnection; ActivateTransaction; if FQSelect.SQL.Text = '' then IBError(ibxeEmptyQuery, [nil]); if not FInternalPrepared then InternalPrepare; if FQSelect.SQLType = SQLSelect then begin if DefaultFields then CreateFields; BindFields(True); FCurrentRecord := -1; FQSelect.ExecQuery; FOpen := FQSelect.Open; { Initialize offsets, buffer sizes, etc... 1. Initially FRecordSize is just the "RecordDataLength". 2. Allocate a "model" buffer and do a dummy fetch 3. After the dummy fetch, FRecordSize will be appropriately adjusted to reflect the additional "weight" of the field data. 4. Set up the FCalcFieldsOffset, FBlobCacheOffset and FRecordBufferSize. 5. Now, with the BufferSize available, allocate memory for chunks of records 6. Re-allocate the model buffer, accounting for the new FRecordBufferSize. 7. Finally, calls to AllocRecordBuffer will work!. } {Step 1} FRecordSize := RecordDataLength(FQSelect.Current.Count); {Step 2, 3} IBAlloc(FModelBuffer, 0, FRecordSize); FetchCurrentRecordToBuffer(FQSelect, -1, FModelBuffer); {Step 4} FCalcFieldsOffset := FRecordSize; FBlobCacheOffset := FCalcFieldsOffset + CalcFieldsSize; FRecordBufferSize := (FBlobCacheOffset + (BlobFieldCount * SizeOf(TIBBlobStream))); {Step 5} if UniDirectional then FBufferChunkSize := FRecordBufferSize * UniCache else FBufferChunkSize := FRecordBufferSize * BufferChunks; IBAlloc(FBufferCache, FBufferChunkSize, FBufferChunkSize); if FCachedUpdates or (csReading in ComponentState) then IBAlloc(FOldBufferCache, FBufferChunkSize, FBufferChunkSize); FBPos := 0; FOBPos := 0; FBEnd := 0; FOBEnd := 0; FCacheSize := FBufferChunkSize; FOldCacheSize := FBufferChunkSize; {Step 6} IBAlloc(FModelBuffer, RecordDataLength(FQSelect.Current.Count), FRecordBufferSize); {Step 7} FOldBuffer := AllocRecordBuffer; end else FQSelect.ExecQuery; finally if SetCursor and (Screen.Cursor = crHourGlass) then Screen.Cursor := crDefault; end; end; procedure TIBCustomDataSet.InternalPost; var Qry: TIBSQL; Buff: PChar; SetCursor: Boolean; bInserting: Boolean; begin SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault); if SetCursor then Screen.Cursor := crHourGlass; try Buff := GetActiveBuf; CheckEditState; AdjustRecordOnInsert(Buff); if (State = dsInsert) then begin bInserting := True; Qry := FQInsert; PRecordData(Buff)^.rdUpdateStatus := usInserted; PRecordData(Buff)^.rdCachedUpdateStatus := cusInserted; WriteRecordCache(FRecordCount, Buff); FCurrentRecord := FRecordCount; end else begin bInserting := False; Qry := FQModify; if PRecordData(Buff)^.rdCachedUpdateStatus = cusUnmodified then begin PRecordData(Buff)^.rdUpdateStatus := usModified; PRecordData(Buff)^.rdCachedUpdateStatus := cusModified; end else if PRecordData(Buff)^. rdCachedUpdateStatus = cusUninserted then begin PRecordData(Buff)^.rdCachedUpdateStatus := cusInserted; Dec(FDeletedRecords); end; end; if (not CachedUpdates) then InternalPostRecord(Qry, Buff) else begin WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Buff); FUpdatesPending := True; end; if bInserting then Inc(FRecordCount); finally if SetCursor and (Screen.Cursor = crHourGlass) then Screen.Cursor := crDefault; end; end; procedure TIBCustomDataSet.InternalRefresh; begin inherited InternalRefresh; InternalRefreshRow; end; procedure TIBCustomDataSet.InternalSetToRecord(Buffer: PChar); begin InternalGotoBookmark(@(PRecordData(Buffer)^.rdRecordNumber)); end; function TIBCustomDataSet.IsCursorOpen: Boolean; begin result := FOpen; end; function TIBCustomDataSet.Locate(const KeyFields: string; const KeyValues: Variant; Options: TLocateOptions): Boolean; var {$IF FPC_FULLVERSION > 20600 } CurBookmark: TBookmark; {$ELSE} CurBookmark: string; {$ENDIF} begin DisableControls; try CurBookmark := Bookmark; First; result := InternalLocate(KeyFields, KeyValues, Options); if not result then Bookmark := CurBookmark; finally EnableControls; end; end; function TIBCustomDataSet.Lookup(const KeyFields: string; const KeyValues: Variant; const ResultFields: string): Variant; var fl: TList; {$IF FPC_FULLVERSION > 20600 } CurBookmark: TBookmark; {$ELSE} CurBookmark: string; {$ENDIF} begin DisableControls; fl := TList.Create; CurBookmark := Bookmark; try First; if InternalLocate(KeyFields, KeyValues, []) then begin if (ResultFields <> '') then result := FieldValues[ResultFields] else result := NULL; end else result := Null; finally Bookmark := CurBookmark; fl.Free; EnableControls; end; end; procedure TIBCustomDataSet.SetBookmarkData(Buffer: PChar; Data: Pointer); begin PRecordData(Buffer)^.rdRecordNumber := PInteger(Data)^; end; procedure TIBCustomDataSet.SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); begin PRecordData(Buffer)^.rdBookmarkFlag := Value; end; procedure TIBCustomDataSet.SetCachedUpdates(Value: Boolean); begin if not Value and FCachedUpdates then CancelUpdates; if (not (csReading in ComponentState)) and Value then CheckDatasetClosed; FCachedUpdates := Value; end; procedure TIBCustomDataSet.SetDataSource(Value: TDataSource); begin if IsLinkedTo(Value) then IBError(ibxeCircularReference, [nil]); if FDataLink <> nil then FDataLink.DataSource := Value; end; procedure TIBCustomDataSet.InternalSetFieldData(Field: TField; Buffer: Pointer); var Buff, TmpBuff: PChar; begin Buff := GetActiveBuf; if Field.FieldNo < 0 then begin TmpBuff := Buff + FRecordSize + Field.Offset; Boolean(TmpBuff[0]) := LongBool(Buffer); if Boolean(TmpBuff[0]) then Move(Buffer^, TmpBuff[1], Field.DataSize); WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Buff); end else begin CheckEditState; with PRecordData(Buff)^ do begin { If inserting, Adjust record position } AdjustRecordOnInsert(Buff); if (FMappedFieldPosition[Field.FieldNo - 1] > 0) and (FMappedFieldPosition[Field.FieldNo - 1] <= rdFieldCount) then begin Field.Validate(Buffer); if (Buffer = nil) or (Field is TIBStringField) and (PChar(Buffer)[0] = #0) then rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdIsNull := True else begin Move(Buffer^, Buff[rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataOfs], rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataSize); if (rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataType = SQL_TEXT) or (rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataType = SQL_VARYING) then rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataLength := StrLen(PChar(Buffer)); rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdIsNull := False; if rdUpdateStatus = usUnmodified then begin if CachedUpdates then begin FUpdatesPending := True; if State = dsInsert then rdCachedUpdateStatus := cusInserted else if State = dsEdit then rdCachedUpdateStatus := cusModified; end; if State = dsInsert then rdUpdateStatus := usInserted else rdUpdateStatus := usModified; end; WriteRecordCache(rdRecordNumber, Buff); SetModified(True); end; end; end; end; if not (State in [dsCalcFields, dsFilter, dsNewValue]) then DataEvent(deFieldChange, PtrInt(Field)); end; procedure TIBCustomDataSet.SetRecNo(Value: Integer); begin CheckBrowseMode; if (Value < 1) then Value := 1 else if Value > FRecordCount then begin InternalLast; Value := Min(FRecordCount, Value); end; if (Value <> RecNo) then begin DoBeforeScroll; FCurrentRecord := Value - 1; Resync([]); DoAfterScroll; end; end; procedure TIBCustomDataSet.Disconnect; begin Close; InternalUnPrepare; end; procedure TIBCustomDataSet.SetUpdateMode(const Value: TUpdateMode); begin if not CanModify then IBError(ibxeCannotUpdate, [nil]) else FUpdateMode := Value; end; procedure TIBCustomDataSet.SetUpdateObject(Value: TIBDataSetUpdateObject); begin if Value <> FUpdateObject then begin if Assigned(FUpdateObject) and (FUpdateObject.DataSet = Self) then FUpdateObject.DataSet := nil; FUpdateObject := Value; if Assigned(FUpdateObject) then begin if Assigned(FUpdateObject.DataSet) and (FUpdateObject.DataSet <> Self) then FUpdateObject.DataSet.UpdateObject := nil; FUpdateObject.DataSet := Self; end; end; end; function TIBCustomDataSet.ConstraintsStored: Boolean; begin Result := Constraints.Count > 0; end; procedure TIBCustomDataSet.ClearCalcFields(Buffer: PChar); begin FillChar(Buffer[FRecordSize], CalcFieldsSize, 0); end; procedure TIBCustomDataSet.InternalUnPrepare; begin if FInternalPrepared then begin CheckDatasetClosed; FieldDefs.Clear; FInternalPrepared := False; end; end; procedure TIBCustomDataSet.InternalExecQuery; var DidActivate: Boolean; SetCursor: Boolean; begin DidActivate := False; SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault); if SetCursor then Screen.Cursor := crHourGlass; try ActivateConnection; DidActivate := ActivateTransaction; if FQSelect.SQL.Text = '' then IBError(ibxeEmptyQuery, [nil]); if not FInternalPrepared then InternalPrepare; if FQSelect.SQLType = SQLSelect then begin IBError(ibxeIsASelectStatement, [nil]); end else FQSelect.ExecQuery; finally if DidActivate then DeactivateTransaction; if SetCursor and (Screen.Cursor = crHourGlass) then Screen.Cursor := crDefault; end; end; function TIBCustomDataSet.GetSelectStmtHandle: TISC_STMT_HANDLE; begin Result := FQSelect.Handle; end; procedure TIBCustomDataSet.InitRecord(Buffer: PChar); begin inherited InitRecord(Buffer); with PRecordData(Buffer)^ do begin rdUpdateStatus := TUpdateStatus(usInserted); rdBookMarkFlag := bfInserted; rdRecordNumber := -1; end; end; procedure TIBCustomDataSet.InternalInsert; begin CursorPosChanged; end; { TIBDataSet IProviderSupport } (*procedure TIBCustomDataSet.PSEndTransaction(Commit: Boolean); begin if Commit then Transaction.Commit else Transaction.Rollback; end; function TIBCustomDataSet.PSExecuteStatement(const ASQL: string; AParams: TParams; ResultSet: Pointer = nil): Integer; var FQuery: TIBQuery; begin if Assigned(ResultSet) then begin TDataSet(ResultSet^) := TIBQuery.Create(nil); with TIBQuery(ResultSet^) do begin SQL.Text := ASQL; Params.Assign(AParams); Open; Result := RowsAffected; end; end else begin FQuery := TIBQuery.Create(nil); try FQuery.Database := Database; FQuery.Transaction := Transaction; FQuery.GenerateParamNames := True; FQuery.SQL.Text := ASQL; FQuery.Params.Assign(AParams); FQuery.ExecSQL; Result := FQuery.RowsAffected; finally FQuery.Free; end; end; end; function TIBCustomDataSet.PSGetQuoteChar: string; begin if Database.SQLDialect = 3 then Result := '"' else Result := ''; end; function TIBCustomDataSet.PSGetUpdateException(E: Exception; Prev: EUpdateError): EUpdateError; var PrevErr: Integer; begin if Prev <> nil then PrevErr := Prev.ErrorCode else PrevErr := 0; if E is EIBError then with EIBError(E) do Result := EUpdateError.Create(E.Message, '', SQLCode, PrevErr, E) else Result := inherited PSGetUpdateException(E, Prev); end; function TIBCustomDataSet.PSInTransaction: Boolean; begin Result := Transaction.InTransaction; end; function TIBCustomDataSet.PSIsSQLBased: Boolean; begin Result := True; end; function TIBCustomDataSet.PSIsSQLSupported: Boolean; begin Result := True; end; procedure TIBCustomDataSet.PSReset; begin inherited PSReset; if Active then begin Close; Open; end; end; function TIBCustomDataSet.PSUpdateRecord(UpdateKind: TUpdateKind; Delta: TDataSet): Boolean; var UpdateAction: TIBUpdateAction; SQL: string; Params: TParams; procedure AssignParams(DataSet: TDataSet; Params: TParams); var I: Integer; Old: Boolean; Param: TParam; PName: string; Field: TField; Value: Variant; begin for I := 0 to Params.Count - 1 do begin Param := Params[I]; PName := Param.Name; Old := CompareText(Copy(PName, 1, 4), 'OLD_') = 0; {do not localize} if Old then System.Delete(PName, 1, 4); Field := DataSet.FindField(PName); if not Assigned(Field) then Continue; if Old then Param.AssignFieldValue(Field, Field.OldValue) else begin Value := Field.NewValue; if VarIsEmpty(Value) then Value := Field.OldValue; Param.AssignFieldValue(Field, Value); end; end; end; begin Result := False; if Assigned(OnUpdateRecord) then begin UpdateAction := uaFail; if Assigned(FOnUpdateRecord) then begin FOnUpdateRecord(Delta, UpdateKind, UpdateAction); Result := UpdateAction = uaApplied; end; end else if Assigned(FUpdateObject) then begin SQL := FUpdateObject.GetSQL(UpdateKind).Text; if SQL <> '' then begin Params := TParams.Create; try Params.ParseSQL(SQL, True); AssignParams(Delta, Params); if PSExecuteStatement(SQL, Params) = 0 then IBError(ibxeNoRecordsAffected, [nil]); Result := True; finally Params.Free; end; end; end; end; procedure TIBCustomDataSet.PSStartTransaction; begin ActivateConnection; Transaction.StartTransaction; end; function TIBCustomDataSet.PSGetTableName: string; begin // if not FInternalPrepared then // InternalPrepare; { It is possible for the FQSelectSQL to be unprepared with FInternalPreprepared being true (see DoBeforeTransactionEnd). So check the Prepared of the SelectSQL instead } if not FQSelect.Prepared then FQSelect.Prepare; Result := FQSelect.UniqueRelationName; end;*) procedure TIBDataSet.BatchInput(InputObject: TIBBatchInput); begin InternalBatchInput(InputObject); end; procedure TIBDataSet.BatchOutput(OutputObject: TIBBatchOutput); begin InternalBatchOutput(OutputObject); end; procedure TIBDataSet.ExecSQL; begin InternalExecQuery; end; procedure TIBDataSet.Prepare; begin InternalPrepare; end; procedure TIBDataSet.UnPrepare; begin InternalUnPrepare; end; function TIBDataSet.GetPrepared: Boolean; begin Result := InternalPrepared; end; procedure TIBDataSet.InternalOpen; begin ActivateConnection; ActivateTransaction; InternalSetParamsFromCursor; Inherited InternalOpen; end; procedure TIBDataSet.SetFiltered(Value: Boolean); begin if(Filtered <> Value) then begin inherited SetFiltered(value); if Active then begin Close; Open; end; end else inherited SetFiltered(value); end; function TIBCustomDataSet.BookmarkValid(Bookmark: TBookmark): Boolean; begin Result := false; if not Assigned(Bookmark) then exit; Result := PInteger(Bookmark)^ < FRecordCount; end; function TIBCustomDataSet.GetFieldData(Field: TField; Buffer: Pointer): Boolean; {$IFDEF TBCDFIELD_IS_BCD} var lTempCurr : System.Currency; begin if (Field.DataType = ftBCD) and (Buffer <> nil) then begin Result := InternalGetFieldData(Field, @lTempCurr); if Result then CurrToBCD(lTempCurr, TBCD(Buffer^), 32, Field.Size); end else {$ELSE} begin {$ENDIF} Result := InternalGetFieldData(Field, Buffer); end; function TIBCustomDataSet.GetFieldData(Field: TField; Buffer: Pointer; NativeFormat: Boolean): Boolean; begin if (Field.DataType = ftBCD) and not NativeFormat then Result := InternalGetFieldData(Field, Buffer) else Result := inherited GetFieldData(Field, Buffer, NativeFormat); end; procedure TIBCustomDataSet.SetFieldData(Field: TField; Buffer: Pointer); {$IFDEF TDBDFIELD_IS_BCD} var lTempCurr : System.Currency; begin if (Field.DataType = ftBCD) and (Buffer <> nil) then begin BCDToCurr(TBCD(Buffer^), lTempCurr); InternalSetFieldData(Field, @lTempCurr); end else {$ELSE} begin {$ENDIF} InternalSetFieldData(Field, Buffer); end; procedure TIBCustomDataSet.SetFieldData(Field: TField; Buffer: Pointer; NativeFormat: Boolean); begin if (not NativeFormat) and (Field.DataType = ftBCD) then InternalSetfieldData(Field, Buffer) else inherited SetFieldData(Field, buffer, NativeFormat); end; { TIBDataSetUpdateObject } constructor TIBDataSetUpdateObject.Create(AOwner: TComponent); begin inherited Create(AOwner); FRefreshSQL := TStringList.Create; end; destructor TIBDataSetUpdateObject.Destroy; begin FRefreshSQL.Free; inherited Destroy; end; procedure TIBDataSetUpdateObject.SetRefreshSQL(Value: TStrings); begin FRefreshSQL.Assign(Value); end; procedure TIBDataSetUpdateObject.InternalSetParams(Query: TIBSQL; buff: PChar); begin if not Assigned(DataSet) then Exit; DataSet.SetInternalSQLParams(Query, buff); end; { TIBDSBlobStream } constructor TIBDSBlobStream.Create(AField: TField; ABlobStream: TIBBlobStream; Mode: TBlobStreamMode); begin FField := AField; FBlobStream := ABlobStream; FBlobStream.Seek(0, soFromBeginning); if (Mode = bmWrite) then FBlobStream.Truncate; end; function TIBDSBlobStream.Read(var Buffer; Count: Longint): Longint; begin result := FBlobStream.Read(Buffer, Count); end; function TIBDSBlobStream.Seek(Offset: Longint; Origin: Word): Longint; begin result := FBlobStream.Seek(Offset, Origin); end; procedure TIBDSBlobStream.SetSize(NewSize: Longint); begin FBlobStream.SetSize(NewSize); end; function TIBDSBlobStream.Write(const Buffer; Count: Longint): Longint; begin if not (FField.DataSet.State in [dsEdit, dsInsert]) then IBError(ibxeNotEditing, [nil]); TIBCustomDataSet(FField.DataSet).RecordModified(True); TBlobField(FField).Modified := true; result := FBlobStream.Write(Buffer, Count); TIBCustomDataSet(FField.DataSet).DataEvent(deFieldChange, PtrInt(FField)); end; { TIBGenerator } procedure TIBGenerator.SetIncrement(const AValue: integer); begin if AValue < 0 then raise Exception.Create('A Generator Increment cannot be negative'); FIncrement := AValue end; function TIBGenerator.GetNextValue(ADatabase: TIBDatabase; ATransaction: TIBTransaction): integer; begin with TIBSQL.Create(nil) do try Database := ADatabase; Transaction := ATransaction; if not assigned(Database) then IBError(ibxeCannotSetDatabase,[]); if not assigned(Transaction) then IBError(ibxeCannotSetTransaction,[]); with Transaction do if not InTransaction then StartTransaction; SQL.Text := Format('Select Gen_ID(%s,%d) as ID From RDB$Database',[FGeneratorName,Increment]); Prepare; ExecQuery; try Result := FieldByName('ID').AsInteger finally Close end; finally Free end; end; constructor TIBGenerator.Create(Owner: TIBCustomDataSet); begin FOwner := Owner; FIncrement := 1; end; procedure TIBGenerator.Apply; begin if (FGeneratorName <> '') and (FFieldName <> '') then Owner.FieldByName(FFieldName).AsInteger := GetNextValue(Owner.Database,Owner.Transaction); end; end.