ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/nongui/IBCustomDataSet.pas
Revision: 241
Committed: Thu Oct 25 13:57:12 2018 UTC (5 years, 5 months ago) by tony
Content type: text/x-pascal
File size: 151455 byte(s)
Log Message:
Fixes merged

File Contents

# User Rev Content
1 tony 209 {************************************************************************}
2     { }
3     { Borland Delphi Visual Component Library }
4     { InterBase Express core components }
5     { }
6     { Copyright (c) 1998-2000 Inprise Corporation }
7     { }
8     { InterBase Express is based in part on the product }
9     { Free IB Components, written by Gregory H. Deatz for }
10     { Hoagland, Longo, Moran, Dunst & Doukas Company. }
11     { Free IB Components is used under license. }
12     { }
13     { The contents of this file are subject to the InterBase }
14     { Public License Version 1.0 (the "License"); you may not }
15     { use this file except in compliance with the License. You }
16     { may obtain a copy of the License at http://www.Inprise.com/IPL.html }
17     { Software distributed under the License is distributed on }
18     { an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either }
19     { express or implied. See the License for the specific language }
20     { governing rights and limitations under the License. }
21     { The Original Code was created by InterBase Software Corporation }
22     { and its successors. }
23     { Portions created by Inprise Corporation are Copyright (C) Inprise }
24     { Corporation. All Rights Reserved. }
25     { Contributor(s): Jeff Overcash }
26     { }
27     { IBX For Lazarus (Firebird Express) }
28     { Contributor: Tony Whyman, MWA Software http://www.mwasoftware.co.uk }
29     { Portions created by MWA Software are copyright McCallum Whyman }
30     { Associates Ltd 2011 - 2015 }
31     { }
32     {************************************************************************}
33    
34     unit IBCustomDataSet;
35    
36     {$R-}
37    
38     {$IFDEF FPC}
39     {$Mode Delphi}
40     {$codepage UTF8}
41     {$ENDIF}
42    
43     {$IFDEF DELPHI}
44     {$DEFINE TDBDFIELD_IS_BCD}
45     {$ENDIF}
46    
47     interface
48    
49     uses
50     {$IFDEF WINDOWS }
51     Windows,
52     {$ENDIF}
53 tony 215 {$IFDEF UNIX}
54 tony 216 unix,
55 tony 215 {$ENDIF}
56 tony 209 SysUtils, Classes, IBDatabase, IBExternals, IB, IBSQL, Db,
57     IBUtils, IBBlob, IBSQLParser, IBDatabaseInfo, fpTimer;
58    
59     const
60     BufferCacheSize = 1000; { Allocate cache in this many record chunks}
61     UniCache = 2; { Uni-directional cache is 2 records big }
62    
63     type
64     TIBCustomDataSet = class;
65     TIBDataSet = class;
66    
67     { TIBDataSetUpdateObject }
68    
69     TIBDataSetUpdateObject = class(TComponent)
70     private
71     FRefreshSQL: TStrings;
72     procedure SetRefreshSQL(value: TStrings);
73     protected
74     function GetDataSet: TIBCustomDataSet; virtual; abstract;
75     procedure SetDataSet(ADataSet: TIBCustomDataSet); virtual; abstract;
76     procedure Apply(UpdateKind: TUpdateKind; buff: PChar); virtual; abstract;
77     function GetSQL(UpdateKind: TUpdateKind): TStrings; virtual; abstract;
78     procedure InternalSetParams(Params: ISQLParams; buff: PChar); overload;
79     procedure InternalSetParams(Query: TIBSQL; buff: PChar); overload;
80     procedure UpdateRecordFromQuery(UpdateKind: TUpdateKind; QryResults: IResults; Buffer: PChar);
81     property DataSet: TIBCustomDataSet read GetDataSet write SetDataSet;
82     public
83     constructor Create(AOwner: TComponent); override;
84     destructor Destroy; override;
85     function GetRowsAffected(var SelectCount, InsertCount, UpdateCount,
86     DeleteCount: integer): boolean; virtual;
87     published
88     property RefreshSQL: TStrings read FRefreshSQL write SetRefreshSQL;
89     end;
90    
91     TBlobDataArray = array[0..0] of TIBBlobStream;
92     PBlobDataArray = ^TBlobDataArray;
93     TIBArrayField = class;
94    
95     { TIBArray }
96    
97     {Wrapper class to support array cache in TIBCustomDataset and event handling}
98    
99     TIBArray = class
100     private
101     FArray: IArray;
102     FRecNo: integer;
103     FField: TIBArrayField;
104     procedure EventHandler(Sender: IArray; Reason: TArrayEventReason);
105     public
106     constructor Create(aField: TIBArrayField; anArray: IArray);
107     destructor Destroy; override;
108     property ArrayIntf: IArray read FArray;
109     end;
110    
111     TArrayDataArray = array [0..0] of TIBArray;
112     PArrayDataArray = ^TArrayDataArray;
113    
114     { TIBCustomDataSet }
115    
116     TCachedUpdateStatus = (
117     cusUnmodified, cusModified, cusInserted,
118     cusDeleted, cusUninserted
119     );
120     TIBDBKey = record
121     DBKey: array[0..7] of Byte;
122     end;
123     PIBDBKey = ^TIBDBKey;
124    
125     PFieldData = ^TFieldData;
126     TFieldData = record
127     fdIsNull: Boolean;
128     fdDataLength: Short;
129     end;
130    
131     PColumnData = ^TColumnData;
132     TColumnData = record
133     fdDataType: Short;
134     fdDataScale: Short;
135     fdNullable: Boolean;
136     fdDataSize: Short;
137     fdDataOfs: Integer;
138     fdCodePage: TSystemCodePage;
139     end;
140    
141     PFieldColumns = ^TFieldColumns;
142     TFieldColumns = array[1..1] of TColumnData;
143    
144     TRecordData = record
145     rdBookmarkFlag: TBookmarkFlag;
146     rdFieldCount: Short;
147     rdRecordNumber: Integer;
148     rdCachedUpdateStatus: TCachedUpdateStatus;
149     rdUpdateStatus: TUpdateStatus;
150     rdSavedOffset: DWORD;
151     rdDBKey: TIBDBKey;
152     rdFields: array[1..1] of TFieldData;
153     end;
154     PRecordData = ^TRecordData;
155    
156     { TIBArrayField }
157    
158     TIBArrayField = class(TField)
159     private
160     FArrayBounds: TArrayBounds;
161     FArrayDimensions: integer;
162     FRelationName: string;
163     FCacheOffset: word;
164     function GetArrayID: TISC_QUAD;
165     function GetArrayIntf: IArray;
166     procedure SetArrayIntf(AValue: IArray);
167     protected
168     class procedure CheckTypeSize(AValue: Longint); override;
169     function GetAsString: string; override;
170     function GetDataSize: Integer; override;
171     procedure Bind(Binding: Boolean); override;
172     public
173     constructor Create(AOwner: TComponent); override;
174     function CreateArray: IArray;
175     property ArrayID: TISC_QUAD read GetArrayID;
176     property ArrayIntf: IArray read GetArrayIntf write SetArrayIntf;
177     property ArrayDimensions: integer read FArrayDimensions write FArrayDimensions;
178     property ArrayBounds: TArrayBounds read FArrayBounds write FArrayBounds;
179     end;
180    
181     { TIBStringField allows us to have strings longer than 8196 }
182    
183     TIBStringField = class(TStringField)
184     private
185     FCharacterSetName: RawByteString;
186     FCharacterSetSize: integer;
187     FAutoFieldSize: boolean;
188     FCodePage: TSystemCodePage;
189     FDataSize: integer;
190     protected
191     procedure Bind(Binding: Boolean); override;
192     function GetDataSize: Integer; override;
193     public
194     constructor Create(aOwner: TComponent); override;
195     class procedure CheckTypeSize(Value: Integer); override;
196     function GetAsString: string; override;
197     function GetAsVariant: Variant; override;
198     function GetValue(var Value: string): Boolean;
199     procedure SetAsString(const Value: string); override;
200     property CharacterSetName: RawByteString read FCharacterSetName write FCharacterSetName;
201     property CharacterSetSize: integer read FCharacterSetSize write FCharacterSetSize;
202     property CodePage: TSystemCodePage read FCodePage write FCodePage;
203     published
204     property AutoFieldSize: boolean read FAutoFieldSize write FAutoFieldSize default true;
205     end;
206    
207     { TIBBCDField }
208     { Actually, there is no BCD involved in this type,
209     instead it deals with currency types.
210     In IB, this is an encapsulation of Numeric (x, y)
211     where x < 18 and y <= 4.
212     Note: y > 4 will default to Floats
213     }
214     TIBBCDField = class(TBCDField)
215     private
216     FIdentityColumn: boolean;
217     protected
218     procedure Bind(Binding: Boolean); override;
219     class procedure CheckTypeSize(Value: Integer); override;
220     function GetAsCurrency: Currency; override;
221     function GetAsString: string; override;
222     function GetAsVariant: Variant; override;
223     function GetDataSize: Integer; override;
224     public
225     constructor Create(AOwner: TComponent); override;
226     property IdentityColumn: boolean read FIdentityColumn;
227     published
228     property Size default 8;
229     end;
230    
231     {The following integer field types extend the built in versions to enable IBX appplications
232     to check for an Identity column}
233    
234     { TIBSmallintField }
235    
236     TIBSmallintField = class(TSmallintField)
237     private
238     FIdentityColumn: boolean;
239     protected
240     procedure Bind(Binding: Boolean); override;
241     public
242     property IdentityColumn: boolean read FIdentityColumn;
243     end;
244    
245     { TIBIntegerField }
246    
247     TIBIntegerField = class(TIntegerField)
248     private
249     FIdentityColumn: boolean;
250     protected
251     procedure Bind(Binding: Boolean); override;
252     public
253     property IdentityColumn: boolean read FIdentityColumn;
254     end;
255    
256     { TIBLargeIntField }
257    
258     TIBLargeIntField = class(TLargeIntField)
259     private
260     FIdentityColumn: boolean;
261     protected
262     procedure Bind(Binding: Boolean); override;
263     public
264     property IdentityColumn: boolean read FIdentityColumn;
265     end;
266    
267     {TIBMemoField}
268     {Allows us to show truncated text in DBGrids and anything else that uses
269     DisplayText}
270    
271     TIBMemoField = class(TMemoField)
272     private
273     FCharacterSetName: RawByteString;
274     FCharacterSetSize: integer;
275     FDisplayTextAsClassName: boolean;
276     function GetTruncatedText: string;
277     protected
278     procedure Bind(Binding: Boolean); override;
279     function GetAsString: string; override;
280     function GetDefaultWidth: Longint; override;
281     procedure GetText(var AText: string; ADisplayText: Boolean); override;
282     procedure SetAsString(const AValue: string); override;
283     public
284     constructor Create(AOwner: TComponent); override;
285     property CharacterSetName: RawByteString read FCharacterSetName write FCharacterSetName;
286     property CharacterSetSize: integer read FCharacterSetSize write FCharacterSetSize;
287     published
288     property DisplayTextAsClassName: boolean read FDisplayTextAsClassName
289     write FDisplayTextAsClassName;
290     private
291     FCodePage: TSystemCodePage;
292     FFCodePage: TSystemCodePage;
293     public
294     property CodePage: TSystemCodePage read FFCodePage write FFCodePage;
295     end;
296    
297     { TIBDataLink }
298    
299     TIBDataLink = class(TDetailDataLink)
300     private
301     FDataSet: TIBCustomDataSet;
302     FDelayTimerValue: integer;
303     FTimer: TFPTimer;
304     procedure HandleRefreshTimer(Sender: TObject);
305 tony 213 procedure SetDelayTimerValue(AValue: integer);
306 tony 209 protected
307     procedure ActiveChanged; override;
308     procedure RecordChanged(Field: TField); override;
309     function GetDetailDataSet: TDataSet; override;
310     procedure CheckBrowseMode; override;
311     public
312     constructor Create(ADataSet: TIBCustomDataSet);
313     destructor Destroy; override;
314     property DelayTimerValue: integer {in Milliseconds}
315 tony 213 read FDelayTimerValue write SetDelayTimerValue;
316 tony 209 end;
317    
318     TIBGeneratorApplyOnEvent = (gaeOnNewRecord,gaeOnPostRecord);
319    
320     { TIBGenerator }
321    
322     TIBGenerator = class(TPersistent)
323     private
324     FOwner: TIBCustomDataSet;
325     FApplyOnEvent: TIBGeneratorApplyOnEvent;
326     FFieldName: string;
327     FGeneratorName: string;
328     FIncrement: integer;
329     FQuery: TIBSQL;
330     function GetDatabase: TIBDatabase;
331     function GetTransaction: TIBTransaction;
332     procedure SetDatabase(AValue: TIBDatabase);
333     procedure SetGeneratorName(AValue: string);
334     procedure SetIncrement(const AValue: integer);
335     procedure SetTransaction(AValue: TIBTransaction);
336     procedure SetQuerySQL;
337     protected
338     function GetNextValue: integer;
339     public
340     constructor Create(Owner: TIBCustomDataSet);
341     destructor Destroy; override;
342     procedure Apply;
343     property Owner: TIBCustomDataSet read FOwner;
344     property Database: TIBDatabase read GetDatabase write SetDatabase;
345     property Transaction: TIBTransaction read GetTransaction write SetTransaction;
346     published
347     property Generator: string read FGeneratorName write SetGeneratorName;
348     property Field: string read FFieldName write FFieldName;
349     property Increment: integer read FIncrement write SetIncrement default 1;
350     property ApplyOnEvent: TIBGeneratorApplyOnEvent read FApplyOnEvent write FApplyOnEvent;
351     end;
352    
353     {TIBControlLink - Allows IB Aware controls to react to dataset state changes}
354    
355     TIBControlLink = class
356     private
357     FTIBDataSet: TIBCustomDataSet;
358     procedure SetIBDataSet(AValue: TIBCustomDataSet);
359     protected
360     procedure UpdateSQL(Sender: TObject); virtual;
361     procedure UpdateParams(Sender: TObject); virtual;
362     public
363     destructor Destroy; override;
364     property IBDataSet: TIBCustomDataSet read FTIBDataSet write SetIBDataSet;
365     end;
366    
367     TIBAutoCommit = (acDisabled, acCommitRetaining);
368    
369     { TIBCustomDataSet }
370    
371     TIBUpdateAction = (uaFail, uaAbort, uaSkip, uaRetry, uaApply, uaApplied);
372    
373     TIBUpdateErrorEvent = procedure(DataSet: TDataSet; E: EDatabaseError;
374     UpdateKind: TUpdateKind; var TheUpdateAction: TIBUpdateAction)
375     of object;
376     TIBUpdateRecordEvent = procedure(DataSet: TDataSet; UpdateKind: TUpdateKind;
377     var UpdateAction: TIBUpdateAction) of object;
378    
379     TIBUpdateRecordTypes = set of TCachedUpdateStatus;
380    
381     TDataSetCloseAction = (dcDiscardChanges, dcSaveChanges);
382    
383     TOnValidatePost = procedure (Sender: TObject; var CancelPost: boolean) of object;
384    
385     TOnDeleteReturning = procedure (Sender: TObject; QryResults: IResults) of object;
386    
387     TIBCustomDataSet = class(TDataset)
388     private
389     FAllowAutoActivateTransaction: Boolean;
390     FArrayFieldCount: integer;
391     FArrayCacheOffset: integer;
392     FAutoCommit: TIBAutoCommit;
393     FEnableStatistics: boolean;
394     FGenerateParamNames: Boolean;
395     FGeneratorField: TIBGenerator;
396     FNeedsRefresh: Boolean;
397     FForcedRefresh: Boolean;
398     FDidActivate: Boolean;
399     FBase: TIBBase;
400     FBlobCacheOffset: Integer;
401     FBlobStreamList: TList;
402     FArrayList: TList;
403     FBufferChunks: Integer;
404     FBufferCache,
405     FOldBufferCache: PChar;
406     FBufferChunkSize,
407     FCacheSize,
408     FOldCacheSize: Integer;
409     FFilterBuffer: PChar;
410     FBPos,
411     FOBPos,
412     FBEnd,
413     FOBEnd: DWord;
414     FCachedUpdates: Boolean;
415     FCalcFieldsOffset: Integer;
416     FCurrentRecord: Long;
417     FDeletedRecords: Long;
418     FModelBuffer,
419     FOldBuffer: PChar;
420     FOnDeleteReturning: TOnDeleteReturning;
421     FOnValidatePost: TOnValidatePost;
422     FOpen: Boolean;
423     FInternalPrepared: Boolean;
424     FQDelete,
425     FQInsert,
426     FQRefresh,
427     FQSelect,
428     FQModify: TIBSQL;
429     FDatabaseInfo: TIBDatabaseInfo;
430     FRecordBufferSize: Integer;
431     FRecordCount: Integer;
432     FRecordSize: Integer;
433     FDataSetCloseAction: TDataSetCloseAction;
434     FUniDirectional: Boolean;
435     FUpdateMode: TUpdateMode;
436     FUpdateObject: TIBDataSetUpdateObject;
437     FParamCheck: Boolean;
438     FUpdatesPending: Boolean;
439     FUpdateRecordTypes: TIBUpdateRecordTypes;
440     FMappedFieldPosition: array of Integer;
441     FDataLink: TIBDataLink;
442    
443     FBeforeDatabaseDisconnect,
444     FAfterDatabaseDisconnect,
445     FDatabaseFree: TNotifyEvent;
446     FOnUpdateError: TIBUpdateErrorEvent;
447     FOnUpdateRecord: TIBUpdateRecordEvent;
448     FBeforeTransactionEnd,
449     FAfterTransactionEnd,
450     FTransactionFree: TNotifyEvent;
451     FAliasNameMap: array of string;
452     FAliasNameList: array of string;
453     FBaseSQLSelect: TStrings;
454     FParser: TSelectSQLParser;
455     FCloseAction: TTransactionAction;
456     FInTransactionEnd: boolean;
457     FIBLinks: TList;
458     FFieldColumns: PFieldColumns;
459     FBufferUpdatedOnQryReturn: boolean;
460     FSelectCount: integer;
461     FInsertCount: integer;
462     FUpdateCount: integer;
463     FDeleteCount: integer;
464     procedure ColumnDataToBuffer(QryResults: IResults; ColumnIndex,
465     FieldIndex: integer; Buffer: PChar);
466     procedure InitModelBuffer(Qry: TIBSQL; Buffer: PChar);
467     function GetSelectStmtIntf: IStatement;
468     procedure SetUpdateMode(const Value: TUpdateMode);
469     procedure SetUpdateObject(Value: TIBDataSetUpdateObject);
470    
471     function AdjustCurrentRecord(Buffer: Pointer; GetMode: TGetMode): TGetResult;
472     procedure AdjustRecordOnInsert(Buffer: Pointer);
473     function CanEdit: Boolean;
474     function CanInsert: Boolean;
475     function CanDelete: Boolean;
476     function CanRefresh: Boolean;
477     procedure CheckEditState;
478     procedure ClearBlobCache;
479     procedure ClearArrayCache;
480     procedure ClearIBLinks;
481     procedure CopyRecordBuffer(Source, Dest: Pointer);
482     procedure DoBeforeDatabaseDisconnect(Sender: TObject);
483     procedure DoAfterDatabaseDisconnect(Sender: TObject);
484     procedure DoDatabaseFree(Sender: TObject);
485     procedure DoBeforeTransactionEnd(Sender: TObject; Action: TTransactionAction);
486     procedure DoAfterTransactionEnd(Sender: TObject);
487     procedure DoTransactionFree(Sender: TObject);
488     procedure DoDeleteReturning(QryResults: IResults);
489     procedure FetchCurrentRecordToBuffer(Qry: TIBSQL; RecordNumber: Integer;
490     Buffer: PChar);
491     function GetDatabase: TIBDatabase;
492     function GetDeleteSQL: TStrings;
493     function GetInsertSQL: TStrings;
494     function GetSQLParams: ISQLParams;
495     function GetRefreshSQL: TStrings;
496     function GetSelectSQL: TStrings;
497     function GetStatementType: TIBSQLStatementTypes;
498     function GetModifySQL: TStrings;
499     function GetTransaction: TIBTransaction;
500     function GetParser: TSelectSQLParser;
501     procedure InternalDeleteRecord(Qry: TIBSQL; Buff: Pointer); virtual;
502     function InternalLocate(const KeyFields: string; const KeyValues: Variant;
503     Options: TLocateOptions): Boolean; virtual;
504     procedure InternalPostRecord(Qry: TIBSQL; Buff: Pointer); virtual;
505     procedure InternalRevertRecord(RecordNumber: Integer); virtual;
506     function IsVisible(Buffer: PChar): Boolean;
507     procedure RegisterIBLink(Sender: TIBControlLink);
508     procedure UnRegisterIBLink(Sender: TIBControlLink);
509     procedure SaveOldBuffer(Buffer: PChar);
510     procedure SetBufferChunks(Value: Integer);
511     procedure SetDatabase(Value: TIBDatabase);
512     procedure SetDeleteSQL(Value: TStrings);
513     procedure SetInsertSQL(Value: TStrings);
514     procedure SetInternalSQLParams(Params: ISQLParams; Buffer: Pointer);
515     procedure SetRefreshSQL(Value: TStrings);
516     procedure SetSelectSQL(Value: TStrings);
517     procedure SetModifySQL(Value: TStrings);
518     procedure SetTransaction(Value: TIBTransaction);
519     procedure SetUpdateRecordTypes(Value: TIBUpdateRecordTypes);
520     procedure SetUniDirectional(Value: Boolean);
521     procedure UpdateRecordFromQuery(QryResults: IResults; Buffer: PChar);
522     procedure RefreshParams;
523     function AdjustPosition(FCache: PChar; Offset: DWORD;
524     Origin: Integer): DWORD;
525     procedure ReadCache(FCache: PChar; Offset: DWORD; Origin: Integer;
526     Buffer: PChar);
527     procedure ReadRecordCache(RecordNumber: Integer; Buffer: PChar;
528     ReadOldBuffer: Boolean);
529     procedure WriteCache(FCache: PChar; Offset: DWORD; Origin: Integer;
530     Buffer: PChar);
531     procedure WriteRecordCache(RecordNumber: Integer; Buffer: PChar);
532     function InternalGetRecord(Buffer: PChar; GetMode: TGetMode;
533     DoCheck: Boolean): TGetResult; virtual;
534    
535     protected
536     function GetMasterDetailDelay: integer; virtual;
537     procedure SetMasterDetailDelay(AValue: integer); virtual;
538     procedure ActivateConnection;
539     function ActivateTransaction: Boolean;
540     procedure DeactivateTransaction;
541     procedure CheckDatasetClosed;
542     procedure CheckDatasetOpen;
543     function CreateParser: TSelectSQLParser; virtual;
544     procedure FieldDefsFromQuery(SourceQuery: TIBSQL);
545     function GetActiveBuf: PChar;
546     procedure InternalBatchInput(InputObject: TIBBatchInput); virtual;
547     procedure InternalBatchOutput(OutputObject: TIBBatchOutput); virtual;
548     procedure InternalPrepare; virtual;
549     procedure InternalUnPrepare; virtual;
550     procedure InternalExecQuery; virtual;
551     procedure InternalRefreshRow; virtual;
552     procedure InternalSetParamsFromCursor; virtual;
553     procedure CheckNotUniDirectional;
554     procedure SQLChanging(Sender: TObject); virtual;
555     procedure SQLChanged(Sender: TObject); virtual;
556    
557     { IProviderSupport }
558     procedure PSEndTransaction(Commit: Boolean); override;
559     function PSExecuteStatement(const ASQL: string; AParams: TParams;
560     ResultSet: Pointer = nil): Integer; override;
561     function PsGetTableName: string; override;
562     function PSGetQuoteChar: string; override;
563     function PSGetUpdateException(E: Exception; Prev: EUpdateError): EUpdateError; override;
564     function PSInTransaction: Boolean; override;
565     function PSIsSQLBased: Boolean; override;
566     function PSIsSQLSupported: Boolean; override;
567     procedure PSStartTransaction; override;
568     procedure PSReset; override;
569     function PSUpdateRecord(UpdateKind: TUpdateKind; Delta: TDataSet): Boolean; override;
570    
571     { TDataSet support }
572     procedure InternalInsert; override;
573     procedure InitRecord(Buffer: PChar); override;
574     procedure Disconnect; virtual;
575     function ConstraintsStored: Boolean;
576     procedure ClearCalcFields(Buffer: PChar); override;
577     function AllocRecordBuffer: PChar; override;
578     procedure DoBeforeDelete; override;
579     procedure DoAfterDelete; override;
580     procedure DoBeforeEdit; override;
581     procedure DoAfterEdit; override;
582     procedure DoBeforeInsert; override;
583     procedure DoAfterInsert; override;
584     procedure DoBeforeClose; override;
585     procedure DoBeforeOpen; override;
586     procedure DoBeforePost; override;
587     procedure DoAfterPost; override;
588     procedure FreeRecordBuffer(var Buffer: PChar); override;
589     procedure GetBookmarkData(Buffer: PChar; Data: Pointer); override;
590     function GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; override;
591     function GetCanModify: Boolean; override;
592     function GetDataSource: TDataSource; override;
593     function GetDBAliasName(FieldNo: integer): string;
594     function GetFieldDefFromAlias(aliasName: string): TFieldDef;
595     function GetFieldClass(FieldType: TFieldType): TFieldClass; override;
596     function GetRecNo: Integer; override;
597     function GetRecord(Buffer: PChar; GetMode: TGetMode;
598     DoCheck: Boolean): TGetResult; override;
599     function GetRecordCount: Integer; override;
600     function GetRecordSize: Word; override;
601     procedure InternalAutoCommit;
602     procedure InternalAddRecord(Buffer: Pointer; Append: Boolean); override;
603     procedure InternalCancel; override;
604     procedure InternalClose; override;
605     procedure InternalDelete; override;
606     procedure InternalFirst; override;
607     function InternalGetFieldData(Field: TField; Buffer: Pointer): Boolean; virtual;
608     procedure InternalGotoBookmark(Bookmark: Pointer); override;
609     procedure InternalHandleException; override;
610     procedure InternalInitFieldDefs; override;
611     procedure InternalInitRecord(Buffer: PChar); override;
612     procedure InternalLast; override;
613     procedure InternalOpen; override;
614     procedure InternalPost; override;
615     procedure InternalRefresh; override;
616     procedure InternalSetFieldData(Field: TField; Buffer: Pointer); virtual;
617     procedure InternalSetToRecord(Buffer: PChar); override;
618     function IsCursorOpen: Boolean; override;
619     procedure Loaded; override;
620     procedure ReQuery;
621     procedure SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); override;
622     procedure SetBookmarkData(Buffer: PChar; Data: Pointer); override;
623     procedure SetCachedUpdates(Value: Boolean);
624     procedure SetDataSource(Value: TDataSource);
625     procedure SetGenerateParamNames(AValue: Boolean); virtual;
626     procedure SetFieldData(Field : TField; Buffer : Pointer); override;
627     procedure SetFieldData(Field : TField; Buffer : Pointer;
628     NativeFormat : Boolean); overload; override;
629     procedure SetRecNo(Value: Integer); override;
630    
631     protected
632     {Likely to be made public by descendant classes}
633     property AutoCommit: TIBAutoCommit read FAutoCommit write FAutoCommit default acDisabled;
634     property SQLParams: ISQLParams read GetSQLParams;
635     property Params: ISQLParams read GetSQLParams;
636     property InternalPrepared: Boolean read FInternalPrepared;
637     property QDelete: TIBSQL read FQDelete;
638     property QInsert: TIBSQL read FQInsert;
639     property QRefresh: TIBSQL read FQRefresh;
640     property QSelect: TIBSQL read FQSelect;
641     property QModify: TIBSQL read FQModify;
642     property StatementType: TIBSQLStatementTypes read GetStatementType;
643     property SelectStmtHandle: IStatement read GetSelectStmtIntf;
644    
645     {Likely to be made published by descendant classes}
646     property BufferChunks: Integer read FBufferChunks write SetBufferChunks;
647     property CachedUpdates: Boolean read FCachedUpdates write SetCachedUpdates;
648     property UniDirectional: Boolean read FUniDirectional write SetUniDirectional default False;
649     property GeneratorField: TIBGenerator read FGeneratorField write FGeneratorField;
650     property DeleteSQL: TStrings read GetDeleteSQL write SetDeleteSQL;
651     property InsertSQL: TStrings read GetInsertSQL write SetInsertSQL;
652     property RefreshSQL: TStrings read GetRefreshSQL write SetRefreshSQL;
653     property SelectSQL: TStrings read GetSelectSQL write SetSelectSQL;
654     property ModifySQL: TStrings read GetModifySQL write SetModifySQL;
655     property UpdateMode: TUpdateMode read FUpdateMode write SetUpdateMode default upWhereAll;
656     property ParamCheck: Boolean read FParamCheck write FParamCheck default True;
657     property Parser: TSelectSQLParser read GetParser;
658     property BaseSQLSelect: TStrings read FBaseSQLSelect;
659    
660     property BeforeDatabaseDisconnect: TNotifyEvent read FBeforeDatabaseDisconnect
661     write FBeforeDatabaseDisconnect;
662     property AfterDatabaseDisconnect: TNotifyEvent read FAfterDatabaseDisconnect
663     write FAfterDatabaseDisconnect;
664     property DatabaseFree: TNotifyEvent read FDatabaseFree
665     write FDatabaseFree;
666     property BeforeTransactionEnd: TNotifyEvent read FBeforeTransactionEnd
667     write FBeforeTransactionEnd;
668     property AfterTransactionEnd: TNotifyEvent read FAfterTransactionEnd
669     write FAfterTransactionEnd;
670     property TransactionFree: TNotifyEvent read FTransactionFree
671     write FTransactionFree;
672     property OnValidatePost: TOnValidatePost read FOnValidatePost write FOnValidatePost;
673    
674     public
675     constructor Create(AOwner: TComponent); override;
676     destructor Destroy; override;
677     procedure ApplyUpdates;
678     function CachedUpdateStatus: TCachedUpdateStatus;
679     procedure CancelUpdates;
680     function GetFieldPosition(AliasName: string): integer;
681     procedure FetchAll;
682     function LocateNext(const KeyFields: string; const KeyValues: Variant;
683     Options: TLocateOptions): Boolean;
684     procedure RecordModified(Value: Boolean);
685     procedure RevertRecord;
686     procedure Undelete;
687     procedure ResetParser; virtual;
688     function HasParser: boolean;
689    
690     { TDataSet support methods }
691     function BookmarkValid(Bookmark: TBookmark): Boolean; override;
692     function CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Integer; override;
693     function CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; override;
694     function GetArray(Field: TIBArrayField): IArray;
695     procedure SetArrayIntf(AnArray: IArray; Field: TIBArrayField);
696     function GetCurrentRecord(Buffer: PChar): Boolean; override;
697     function GetFieldData(Field : TField; Buffer : Pointer) : Boolean; overload; override;
698     function GetFieldData(FieldNo: Integer; Buffer: Pointer): Boolean; overload; (*override;*)
699     function GetFieldData(Field : TField; Buffer : Pointer;
700     NativeFormat : Boolean) : Boolean; overload; override;
701     property GenerateParamNames: Boolean read FGenerateParamNames write SetGenerateParamNames;
702     function Locate(const KeyFields: string; const KeyValues: Variant;
703     Options: TLocateOptions): Boolean; override;
704     function Lookup(const KeyFields: string; const KeyValues: Variant;
705     const ResultFields: string): Variant; override;
706     function UpdateStatus: TUpdateStatus; override;
707     function IsSequenced: Boolean; override;
708     procedure Post; override;
709     function ParamByName(ParamName: String): ISQLParam;
710     property ArrayFieldCount: integer read FArrayFieldCount;
711     property DatabaseInfo: TIBDatabaseInfo read FDatabaseInfo;
712     property UpdateObject: TIBDataSetUpdateObject read FUpdateObject write SetUpdateObject;
713     property UpdatesPending: Boolean read FUpdatesPending;
714     property UpdateRecordTypes: TIBUpdateRecordTypes read FUpdateRecordTypes
715     write SetUpdateRecordTypes;
716     property MasterDetailDelay: integer read GetMasterDetailDelay write SetMasterDetailDelay;
717     property DataSetCloseAction: TDataSetCloseAction
718     read FDataSetCloseAction write FDataSetCloseAction;
719    
720     public
721     {Performance Statistics}
722     function GetRowsAffected(var SelectCount, InsertCount, UpdateCount, DeleteCount: integer): boolean;
723     function GetPerfStatistics(var stats: TPerfCounters): boolean;
724     property EnableStatistics: boolean read FEnableStatistics write FEnableStatistics;
725    
726     published
727     property AllowAutoActivateTransaction: Boolean read FAllowAutoActivateTransaction
728     write FAllowAutoActivateTransaction;
729     property Database: TIBDatabase read GetDatabase write SetDatabase;
730     property Transaction: TIBTransaction read GetTransaction
731     write SetTransaction;
732     property ForcedRefresh: Boolean read FForcedRefresh
733     write FForcedRefresh default False;
734     property AutoCalcFields;
735    
736     property AfterCancel;
737     property AfterClose;
738     property AfterDelete;
739     property AfterEdit;
740     property AfterInsert;
741     property AfterOpen;
742     property AfterPost;
743     property AfterRefresh;
744     property AfterScroll;
745     property BeforeCancel;
746     property BeforeClose;
747     property BeforeDelete;
748     property BeforeEdit;
749     property BeforeInsert;
750     property BeforeOpen;
751     property BeforePost;
752     property BeforeRefresh;
753     property BeforeScroll;
754     property OnCalcFields;
755     property OnDeleteError;
756     property OnEditError;
757     property OnNewRecord;
758     property OnPostError;
759     property OnUpdateError: TIBUpdateErrorEvent read FOnUpdateError
760     write FOnUpdateError;
761     property OnUpdateRecord: TIBUpdateRecordEvent read FOnUpdateRecord
762     write FOnUpdateRecord;
763     property OnDeleteReturning: TOnDeleteReturning read FOnDeleteReturning
764     write FOnDeleteReturning;
765     end;
766    
767     TIBParserDataSet = class(TIBCustomDataSet)
768     public
769     property Parser;
770     end;
771    
772     TIBDataSet = class(TIBParserDataSet)
773     private
774     function GetPrepared: Boolean;
775    
776     protected
777     procedure SetFiltered(Value: Boolean); override;
778     procedure InternalOpen; override;
779    
780     public
781     procedure Prepare;
782     procedure UnPrepare;
783     procedure BatchInput(InputObject: TIBBatchInput);
784     procedure BatchOutput(OutputObject: TIBBatchOutput);
785     procedure ExecSQL;
786    
787     public
788     property Params;
789     property Prepared : Boolean read GetPrepared;
790     property QDelete;
791     property QInsert;
792     property QRefresh;
793     property QSelect;
794     property QModify;
795     property StatementType;
796     property SelectStmtHandle;
797     property BaseSQLSelect;
798    
799     published
800     { TIBCustomDataSet }
801     property AutoCommit;
802     property BufferChunks;
803     property CachedUpdates;
804     property EnableStatistics;
805     property DeleteSQL;
806     property InsertSQL;
807     property RefreshSQL;
808     property SelectSQL;
809     property ModifySQL;
810     property GeneratorField;
811     property GenerateParamNames;
812     property MasterDetailDelay;
813     property ParamCheck;
814     property UniDirectional;
815     property Filtered;
816     property DataSetCloseAction;
817    
818     property BeforeDatabaseDisconnect;
819     property AfterDatabaseDisconnect;
820     property DatabaseFree;
821     property BeforeTransactionEnd;
822     property AfterTransactionEnd;
823     property TransactionFree;
824    
825     { TIBDataSet }
826     property Active;
827     property AutoCalcFields;
828     property DataSource read GetDataSource write SetDataSource;
829    
830     property AfterCancel;
831     property AfterClose;
832     property AfterDelete;
833     property AfterEdit;
834     property AfterInsert;
835     property AfterOpen;
836     property AfterPost;
837     property AfterScroll;
838     property BeforeCancel;
839     property BeforeClose;
840     property BeforeDelete;
841     property BeforeEdit;
842     property BeforeInsert;
843     property BeforeOpen;
844     property BeforePost;
845     property BeforeScroll;
846     property OnCalcFields;
847     property OnDeleteError;
848     property OnEditError;
849     property OnFilterRecord;
850     property OnNewRecord;
851     property OnPostError;
852     property OnValidatePost;
853     property OnDeleteReturning;
854     end;
855    
856     { TIBDSBlobStream }
857     TIBDSBlobStream = class(TStream)
858     private
859     FHasWritten: boolean;
860     protected
861     FField: TField;
862     FBlobStream: TIBBlobStream;
863     function GetSize: Int64; override;
864     public
865     constructor Create(AField: TField; ABlobStream: TIBBlobStream;
866     Mode: TBlobStreamMode);
867     destructor Destroy; override;
868     function Read(var Buffer; Count: Longint): Longint; override;
869     function Seek(Offset: Longint; Origin: Word): Longint; override;
870     procedure SetSize(NewSize: Longint); override;
871     function Write(const Buffer; Count: Longint): Longint; override;
872     end;
873    
874     {Extended Field Def for character set info}
875    
876     { TIBFieldDef }
877    
878     TIBFieldDef = class(TFieldDef)
879     private
880     FArrayBounds: TArrayBounds;
881     FArrayDimensions: integer;
882     FCharacterSetName: RawByteString;
883     FCharacterSetSize: integer;
884     FCodePage: TSystemCodePage;
885     FIdentityColumn: boolean;
886     FRelationName: string;
887     FDataSize: integer;
888     published
889     property CharacterSetName: RawByteString read FCharacterSetName write FCharacterSetName;
890     property CharacterSetSize: integer read FCharacterSetSize write FCharacterSetSize;
891     property CodePage: TSystemCodePage read FCodePage write FCodePage;
892     property DataSize: integer read FDataSize write FDataSize;
893     property RelationName: string read FRelationName write FRelationName;
894     property ArrayDimensions: integer read FArrayDimensions write FArrayDimensions;
895     property ArrayBounds: TArrayBounds read FArrayBounds write FArrayBounds;
896     property IdentityColumn: boolean read FIdentityColumn write FIdentityColumn default false;
897     end;
898    
899     const
900     DefaultFieldClasses: array[TFieldType] of TFieldClass = (
901     nil, { ftUnknown }
902     TIBStringField, { ftString }
903     TIBSmallintField, { ftSmallint }
904     TIBIntegerField, { ftInteger }
905     TWordField, { ftWord }
906     TBooleanField, { ftBoolean }
907     TFloatField, { ftFloat }
908     TCurrencyField, { ftCurrency }
909     TIBBCDField, { ftBCD }
910     TDateField, { ftDate }
911     TTimeField, { ftTime }
912     TDateTimeField, { ftDateTime }
913     TBytesField, { ftBytes }
914     TVarBytesField, { ftVarBytes }
915     TAutoIncField, { ftAutoInc }
916     TBlobField, { ftBlob }
917     TIBMemoField, { ftMemo }
918     TGraphicField, { ftGraphic }
919     TBlobField, { ftFmtMemo }
920     TBlobField, { ftParadoxOle }
921     TBlobField, { ftDBaseOle }
922     TBlobField, { ftTypedBinary }
923     nil, { ftCursor }
924     TStringField, { ftFixedChar }
925     nil, { ftWideString }
926     TIBLargeIntField, { ftLargeInt }
927     nil, { ftADT }
928     TIBArrayField, { ftArray }
929     nil, { ftReference }
930     nil, { ftDataSet }
931     TBlobField, { ftOraBlob }
932     TMemoField, { ftOraClob }
933     TVariantField, { ftVariant }
934     nil, { ftInterface }
935     nil, { ftIDispatch }
936     TGuidField, { ftGuid }
937     TDateTimeField, {ftTimestamp}
938     TIBBCDField, {ftFMTBcd}
939     nil, {ftFixedWideChar}
940     nil); {ftWideMemo}
941     (*
942     TADTField, { ftADT }
943     TArrayField, { ftArray }
944     TReferenceField, { ftReference }
945     TDataSetField, { ftDataSet }
946     TBlobField, { ftOraBlob }
947     TMemoField, { ftOraClob }
948     TVariantField, { ftVariant }
949     TInterfaceField, { ftInterface }
950     TIDispatchField, { ftIDispatch }
951     TGuidField); { ftGuid } *)
952     (*var
953     CreateProviderProc: function(DataSet: TIBCustomDataSet): IProvider = nil;*)
954    
955     implementation
956    
957     uses Variants, FmtBCD, LazUTF8, FBMessages, IBQuery;
958    
959     const FILE_BEGIN = 0;
960     FILE_CURRENT = 1;
961     FILE_END = 2;
962    
963     type
964    
965     TFieldNode = class(TObject)
966     protected
967     FieldName : String;
968     COMPUTED_BLR : Boolean;
969     DEFAULT_VALUE : boolean;
970     IDENTITY_COLUMN : boolean;
971     NextField : TFieldNode;
972     end;
973    
974     TRelationNode = class(TObject)
975     protected
976     RelationName : String;
977     FieldNodes : TFieldNode;
978     NextRelation : TRelationNode;
979     end;
980    
981    
982     { Copied from LCLProc in order to avoid LCL dependency
983    
984     Ensures the covenient look of multiline string
985     when displaying it in the single line
986     * Replaces CR and LF with spaces
987     * Removes duplicate spaces
988     }
989     function TextToSingleLine(const AText: string): string;
990     var
991     str: string;
992     i, wstart, wlen: Integer;
993     begin
994     str := Trim(AText);
995     wstart := 0;
996     wlen := 0;
997     i := 1;
998     while i < Length(str) - 1 do
999     begin
1000     if (str[i] in [' ', #13, #10]) then
1001     begin
1002     if (wstart = 0) then
1003     begin
1004     wstart := i;
1005     wlen := 1;
1006     end else
1007     Inc(wlen);
1008     end else
1009     begin
1010     if wstart > 0 then
1011     begin
1012     str[wstart] := ' ';
1013     Delete(str, wstart+1, wlen-1);
1014     Dec(i, wlen-1);
1015     wstart := 0;
1016     end;
1017     end;
1018     Inc(i);
1019     end;
1020     Result := str;
1021     end;
1022    
1023     { TIBLargeIntField }
1024    
1025     procedure TIBLargeIntField.Bind(Binding: Boolean);
1026     begin
1027     inherited Bind(Binding);
1028     if Binding and (FieldDef <> nil) then
1029     FIdentityColumn := (FieldDef as TIBFieldDef).IdentityColumn;
1030     end;
1031    
1032     { TIBIntegerField }
1033    
1034     procedure TIBIntegerField.Bind(Binding: Boolean);
1035     begin
1036     inherited Bind(Binding);
1037     if Binding and (FieldDef <> nil) then
1038     FIdentityColumn := (FieldDef as TIBFieldDef).IdentityColumn;
1039     end;
1040    
1041     { TIBSmallintField }
1042    
1043     procedure TIBSmallintField.Bind(Binding: Boolean);
1044     begin
1045     inherited Bind(Binding);
1046     if Binding and (FieldDef <> nil) then
1047     FIdentityColumn := (FieldDef as TIBFieldDef).IdentityColumn;
1048     end;
1049    
1050     { TIBArray }
1051    
1052     procedure TIBArray.EventHandler(Sender: IArray; Reason: TArrayEventReason);
1053     begin
1054     case Reason of
1055     arChanging:
1056     if FRecNo <> FField.Dataset.RecNo then
1057     IBError(ibxeNotCurrentArray,[nil]);
1058    
1059     arChanged:
1060     FField.DataChanged;
1061     end;
1062     end;
1063    
1064     constructor TIBArray.Create(aField: TIBArrayField; anArray: IArray);
1065     begin
1066     inherited Create;
1067     FField := aField;
1068     FArray := anArray;
1069     FRecNo := FField.Dataset.RecNo;
1070     FArray.AddEventHandler(EventHandler);
1071     end;
1072    
1073     destructor TIBArray.Destroy;
1074     begin
1075     FArray.RemoveEventHandler(EventHandler);
1076     inherited Destroy;
1077     end;
1078    
1079     { TIBArrayField }
1080    
1081     function TIBArrayField.GetArrayIntf: IArray;
1082     begin
1083     Result := TIBCustomDataSet(DataSet).GetArray(self);
1084     end;
1085    
1086     function TIBArrayField.GetArrayID: TISC_QUAD;
1087     begin
1088     GetData(@Result);
1089     end;
1090    
1091     procedure TIBArrayField.SetArrayIntf(AValue: IArray);
1092     begin
1093     TIBCustomDataSet(DataSet).SetArrayIntf(AValue,self);
1094     DataChanged;
1095     end;
1096    
1097     class procedure TIBArrayField.CheckTypeSize(AValue: Longint);
1098     begin
1099     //Ignore
1100     end;
1101    
1102     function TIBArrayField.GetAsString: string;
1103     begin
1104     Result := '(Array)';
1105     end;
1106    
1107     function TIBArrayField.GetDataSize: Integer;
1108     begin
1109     Result := sizeof(TISC_QUAD);
1110     end;
1111    
1112     procedure TIBArrayField.Bind(Binding: Boolean);
1113     begin
1114     inherited Bind(Binding);
1115     if Binding then
1116     begin
1117     FCacheOffset := TIBCustomDataSet(DataSet).ArrayFieldCount;
1118     Inc(TIBCustomDataSet(DataSet).FArrayFieldCount);
1119     if FieldDef <> nil then
1120     begin
1121     FRelationName := TIBFieldDef(FieldDef).FRelationName;
1122     FArrayDimensions := TIBFieldDef(FieldDef).ArrayDimensions;
1123     FArrayBounds := TIBFieldDef(FieldDef).ArrayBounds;
1124     end;
1125     end;
1126     end;
1127    
1128     constructor TIBArrayField.Create(AOwner: TComponent);
1129     begin
1130     inherited Create(AOwner);
1131     SetDataType(ftArray);
1132     end;
1133    
1134     function TIBArrayField.CreateArray: IArray;
1135     begin
1136     with DataSet as TIBCustomDataSet do
1137     Result := Database.Attachment.CreateArray(Transaction.TransactionIntf,FRelationName,FieldName);
1138     end;
1139    
1140     { TIBMemoField }
1141    
1142     function TIBMemoField.GetTruncatedText: string;
1143     begin
1144     Result := GetAsString;
1145    
1146     if Result <> '' then
1147     begin
1148     case CharacterSetSize of
1149     1:
1150     if DisplayWidth = 0 then
1151     Result := TextToSingleLine(Result)
1152     else
1153     if Length(Result) > DisplayWidth then {Show truncation with elipses}
1154     Result := TextToSingleLine(system.copy(Result,1,DisplayWidth-3)) + '...';
1155    
1156     {2: case 2 ignored. This should be handled by TIBWideMemo}
1157    
1158     3, {Assume UNICODE_FSS is really UTF8}
1159     4: {Include GB18030 - assuming UTF8 routines work for this codeset}
1160     if DisplayWidth = 0 then
1161 tony 241 {$if not defined(ValidUTF8String)}
1162     Result := Utf8EscapeControlChars(TextToSingleLine(Result))
1163     {$else}
1164 tony 209 Result := ValidUTF8String(TextToSingleLine(Result))
1165 tony 241 {$endif}
1166 tony 209 else
1167     if UTF8Length(Result) > DisplayWidth then {Show truncation with elipses}
1168 tony 241 {$if not defined(ValidUTF8String)}
1169     Result := Utf8EscapeControlChars(TextToSingleLine(UTF8Copy(Result,1,DisplayWidth-3))) + '...';
1170     {$else}
1171 tony 209 Result := ValidUTF8String(TextToSingleLine(UTF8Copy(Result,1,DisplayWidth-3))) + '...';
1172 tony 241 {$endif}
1173 tony 209 end;
1174     end
1175     end;
1176    
1177     procedure TIBMemoField.Bind(Binding: Boolean);
1178     var IBFieldDef: TIBFieldDef;
1179     begin
1180     inherited Bind(Binding);
1181     if Binding and (FieldDef <> nil) then
1182     begin
1183     IBFieldDef := FieldDef as TIBFieldDef;
1184     CharacterSetSize := IBFieldDef.CharacterSetSize;
1185     CharacterSetName := IBFieldDef.CharacterSetName;
1186     CodePage := IBFieldDef.CodePage;
1187     end;
1188     end;
1189    
1190     function TIBMemoField.GetAsString: string;
1191     var s: RawByteString;
1192     begin
1193     s := inherited GetAsString;
1194     SetCodePage(s,CodePage,false);
1195     if (CodePage <> CP_NONE) and (CodePage <> CP_UTF8) then
1196     SetCodePage(s,CP_UTF8,true); {LCL only accepts UTF8}
1197     Result := s;
1198     end;
1199    
1200     function TIBMemoField.GetDefaultWidth: Longint;
1201     begin
1202     if DisplayTextAsClassName then
1203     Result := inherited
1204     else
1205     Result := 128;
1206     end;
1207    
1208     procedure TIBMemoField.GetText(var AText: string; ADisplayText: Boolean);
1209     begin
1210     if ADisplayText then
1211     begin
1212     if not DisplayTextAsClassName and (CharacterSetName <> '') then
1213     AText := GetTruncatedText
1214     else
1215     inherited GetText(AText, ADisplayText);
1216     end
1217     else
1218     AText := GetAsString;
1219     end;
1220    
1221     procedure TIBMemoField.SetAsString(const AValue: string);
1222     var s: RawByteString;
1223     begin
1224     s := AValue;
1225     if StringCodePage(s) <> CodePage then
1226     SetCodePage(s,CodePage,CodePage<>CP_NONE);
1227     inherited SetAsString(s);
1228     end;
1229    
1230     constructor TIBMemoField.Create(AOwner: TComponent);
1231     begin
1232     inherited Create(AOwner);
1233     BlobType := ftMemo;
1234     FCodePage := CP_NONE;
1235     end;
1236    
1237     { TIBControlLink }
1238    
1239     destructor TIBControlLink.Destroy;
1240     begin
1241     IBDataSet := nil;
1242     inherited Destroy;
1243     end;
1244    
1245     procedure TIBControlLink.UpdateParams(Sender: TObject);
1246     begin
1247    
1248     end;
1249    
1250     procedure TIBControlLink.UpdateSQL(Sender: TObject);
1251     begin
1252    
1253     end;
1254    
1255     procedure TIBControlLink.SetIBDataSet(AValue: TIBCustomDataSet);
1256     begin
1257     if FTIBDataSet = AValue then Exit;
1258     if IBDataSet <> nil then
1259     IBDataSet.UnRegisterIBLink(self);
1260     FTIBDataSet := AValue;
1261     if IBDataSet <> nil then
1262     IBDataSet.RegisterIBLink(self);
1263     end;
1264    
1265    
1266     { TIBStringField}
1267    
1268     procedure TIBStringField.Bind(Binding: Boolean);
1269     var IBFieldDef: TIBFieldDef;
1270     begin
1271     inherited Bind(Binding);
1272     if Binding and (FieldDef <> nil) then
1273     begin
1274     IBFieldDef := FieldDef as TIBFieldDef;
1275     CharacterSetSize := IBFieldDef.CharacterSetSize;
1276     CharacterSetName := IBFieldDef.CharacterSetName;
1277     FDataSize := IBFieldDef.DataSize + 1;
1278     if AutoFieldSize then
1279     Size := IBFieldDef.Size;
1280     CodePage := IBFieldDef.CodePage;
1281     end;
1282     end;
1283    
1284     function TIBStringField.GetDataSize: Integer;
1285     begin
1286     Result := FDataSize;
1287     end;
1288    
1289     constructor TIBStringField.Create(aOwner: TComponent);
1290     begin
1291     inherited Create(aOwner);
1292     FCharacterSetSize := 1;
1293     FCodePage := CP_NONE;
1294     FAutoFieldSize := true;
1295     end;
1296    
1297     class procedure TIBStringField.CheckTypeSize(Value: Integer);
1298     begin
1299     { don't check string size. all sizes valid }
1300     end;
1301    
1302     function TIBStringField.GetAsString: string;
1303     begin
1304     if not GetValue(Result) then Result := '';
1305     end;
1306    
1307     function TIBStringField.GetAsVariant: Variant;
1308     var
1309     S: string;
1310     begin
1311     if GetValue(S) then Result := S else Result := Null;
1312     end;
1313    
1314     function TIBStringField.GetValue(var Value: string): Boolean;
1315     var
1316     Buffer: PChar;
1317     s: RawByteString;
1318     begin
1319     Buffer := nil;
1320     IBAlloc(Buffer, 0, DataSize);
1321     try
1322     Result := GetData(Buffer);
1323     if Result then
1324     begin
1325     s := strpas(Buffer);
1326     SetCodePage(s,CodePage,false);
1327     if (CodePage <> CP_NONE) and (CodePage <> CP_UTF8) then
1328     SetCodePage(s,CP_UTF8,true); {LCL only accepts UTF8}
1329     Value := s;
1330     // writeln(FieldName,': ', StringCodePage(Value),', ',Value);
1331     if Transliterate and (Value <> '') then
1332     DataSet.Translate(PChar(Value), PChar(Value), False);
1333     end
1334     finally
1335     FreeMem(Buffer);
1336     end;
1337     end;
1338    
1339     procedure TIBStringField.SetAsString(const Value: string);
1340     var
1341     Buffer: PChar;
1342     s: RawByteString;
1343     begin
1344     Buffer := nil;
1345     IBAlloc(Buffer, 0, DataSize);
1346     try
1347     s := Value;
1348     if StringCodePage(s) <> CodePage then
1349     SetCodePage(s,CodePage,CodePage<>CP_NONE);
1350     StrLCopy(Buffer, PChar(s), DataSize-1);
1351     if Transliterate then
1352     DataSet.Translate(Buffer, Buffer, True);
1353     SetData(Buffer);
1354     finally
1355     FreeMem(Buffer);
1356     end;
1357     end;
1358    
1359    
1360     { TIBBCDField }
1361    
1362     constructor TIBBCDField.Create(AOwner: TComponent);
1363     begin
1364     inherited Create(AOwner);
1365     SetDataType(ftBCD);
1366     Size := 8;
1367     end;
1368    
1369     procedure TIBBCDField.Bind(Binding: Boolean);
1370     begin
1371     inherited Bind(Binding);
1372     if Binding and (FieldDef <> nil) then
1373     FIdentityColumn := (FieldDef as TIBFieldDef).IdentityColumn;
1374     end;
1375    
1376     class procedure TIBBCDField.CheckTypeSize(Value: Integer);
1377     begin
1378     { No need to check as the base type is currency, not BCD }
1379     end;
1380    
1381     function TIBBCDField.GetAsCurrency: Currency;
1382     begin
1383     if not GetValue(Result) then
1384     Result := 0;
1385     end;
1386    
1387     function TIBBCDField.GetAsString: string;
1388     var
1389     C: System.Currency;
1390     begin
1391     if GetValue(C) then
1392     Result := CurrToStr(C)
1393     else
1394     Result := '';
1395     end;
1396    
1397     function TIBBCDField.GetAsVariant: Variant;
1398     var
1399     C: System.Currency;
1400     begin
1401     if GetValue(C) then
1402     Result := C
1403     else
1404     Result := Null;
1405     end;
1406    
1407     function TIBBCDField.GetDataSize: Integer;
1408     begin
1409     {$IFDEF TBCDFIELD_IS_BCD}
1410     Result := 8;
1411     {$ELSE}
1412     Result := inherited GetDataSize
1413     {$ENDIF}
1414     end;
1415    
1416     { TIBDataLink }
1417    
1418     constructor TIBDataLink.Create(ADataSet: TIBCustomDataSet);
1419     begin
1420     inherited Create;
1421     FDataSet := ADataSet;
1422     FTimer := TFPTimer.Create(nil);
1423 tony 215 FTimer.Enabled := false;
1424 tony 209 FTimer.Interval := 0;
1425     FTimer.OnTimer := HandleRefreshTimer;
1426     FDelayTimerValue := 0;
1427     end;
1428    
1429     destructor TIBDataLink.Destroy;
1430     begin
1431     FDataSet.FDataLink := nil;
1432     if assigned(FTimer) then FTimer.Free;
1433     inherited Destroy;
1434     end;
1435    
1436     procedure TIBDataLink.HandleRefreshTimer(Sender: TObject);
1437     begin
1438 tony 215 FTimer.Enabled := false;
1439 tony 213 if FDataSet.Active then
1440     FDataSet.RefreshParams;
1441 tony 209 end;
1442    
1443 tony 213 procedure TIBDataLink.SetDelayTimerValue(AValue: integer);
1444     begin
1445     if FDelayTimerValue = AValue then Exit;
1446     FDelayTimerValue := AValue;
1447 tony 216 {$IF FPC_FULLVERSION >= 30002}
1448 tony 217 if (AValue > 0) and not IsMultiThread then
1449 tony 221 IBError(ibxeMultiThreadRequired,['TIBQuery/TIBDataset MasterDetailDelay']);
1450 tony 213 FTimer.Interval := FDelayTimerValue;
1451 tony 216 {$IFEND}
1452 tony 213 end;
1453    
1454 tony 209 procedure TIBDataLink.ActiveChanged;
1455     begin
1456     if FDataSet.Active then
1457     FDataSet.RefreshParams;
1458     end;
1459    
1460    
1461     function TIBDataLink.GetDetailDataSet: TDataSet;
1462     begin
1463     Result := FDataSet;
1464     end;
1465    
1466     procedure TIBDataLink.RecordChanged(Field: TField);
1467     begin
1468     if (Field = nil) and FDataSet.Active then
1469     begin
1470 tony 213 {$IF FPC_FULLVERSION >= 30002}
1471 tony 209 if FDelayTimerValue > 0 then
1472 tony 215 with FTimer do
1473     begin
1474 tony 217 CheckSynchronize; {Ensure not waiting on Synchronize}
1475 tony 215 if Enabled then
1476     begin
1477     StopTimer;
1478     StartTimer;
1479     end
1480     else
1481     Enabled := true;
1482     end
1483 tony 209 else
1484 tony 213 {$IFEND}
1485 tony 209 FDataSet.RefreshParams;
1486     end;
1487     end;
1488    
1489     procedure TIBDataLink.CheckBrowseMode;
1490     begin
1491     if FDataSet.Active then
1492     FDataSet.CheckBrowseMode;
1493     end;
1494    
1495     { TIBCustomDataSet }
1496    
1497     constructor TIBCustomDataSet.Create(AOwner: TComponent);
1498     begin
1499     inherited Create(AOwner);
1500     FBase := TIBBase.Create(Self);
1501     FDatabaseInfo := TIBDatabaseInfo.Create(self);
1502     FIBLinks := TList.Create;
1503     FCurrentRecord := -1;
1504     FDeletedRecords := 0;
1505     FUniDirectional := False;
1506     FBufferChunks := BufferCacheSize;
1507     FBlobStreamList := TList.Create;
1508     FArrayList := TList.Create;
1509     FGeneratorField := TIBGenerator.Create(self);
1510     FDataLink := TIBDataLink.Create(Self);
1511     FQDelete := TIBSQL.Create(Self);
1512     FQDelete.OnSQLChanging := SQLChanging;
1513     FQDelete.GoToFirstRecordOnExecute := False;
1514     FQInsert := TIBSQL.Create(Self);
1515     FQInsert.OnSQLChanging := SQLChanging;
1516     FQInsert.GoToFirstRecordOnExecute := False;
1517     FQRefresh := TIBSQL.Create(Self);
1518     FQRefresh.OnSQLChanging := SQLChanging;
1519     FQRefresh.GoToFirstRecordOnExecute := False;
1520     FQSelect := TIBSQL.Create(Self);
1521     FQSelect.OnSQLChanging := SQLChanging;
1522     FQSelect.OnSQLChanged := SQLChanged;
1523     FQSelect.GoToFirstRecordOnExecute := False;
1524     FQModify := TIBSQL.Create(Self);
1525     FQModify.OnSQLChanging := SQLChanging;
1526     FQModify.GoToFirstRecordOnExecute := False;
1527     FUpdateRecordTypes := [cusUnmodified, cusModified, cusInserted];
1528     FParamCheck := True;
1529     FGenerateParamNames := False;
1530     FForcedRefresh := False;
1531     FAutoCommit:= acDisabled;
1532     FDataSetCloseAction := dcDiscardChanges;
1533     {Bookmark Size is Integer for IBX}
1534     BookmarkSize := SizeOf(Integer);
1535     FBase.BeforeDatabaseDisconnect := DoBeforeDatabaseDisconnect;
1536     FBase.AfterDatabaseDisconnect := DoAfterDatabaseDisconnect;
1537     FBase.OnDatabaseFree := DoDatabaseFree;
1538     FBase.BeforeTransactionEnd := DoBeforeTransactionEnd;
1539     FBase.AfterTransactionEnd := DoAfterTransactionEnd;
1540     FBase.OnTransactionFree := DoTransactionFree;
1541     if AOwner is TIBDatabase then
1542     Database := TIBDatabase(AOwner)
1543     else
1544     if AOwner is TIBTransaction then
1545     Transaction := TIBTransaction(AOwner);
1546     FBaseSQLSelect := TStringList.Create;
1547     end;
1548    
1549     destructor TIBCustomDataSet.Destroy;
1550     begin
1551     if Active then Active := false;
1552     if assigned(FGeneratorField) then FGeneratorField.Free;
1553     FDataLink.Free;
1554     FBase.Free;
1555     ClearBlobCache;
1556     ClearIBLinks;
1557     FIBLinks.Free;
1558     FBlobStreamList.Free;
1559     FArrayList.Free;
1560     FreeMem(FBufferCache);
1561     FBufferCache := nil;
1562     FreeMem(FOldBufferCache);
1563     FOldBufferCache := nil;
1564     FCacheSize := 0;
1565     FOldCacheSize := 0;
1566     FMappedFieldPosition := nil;
1567     if assigned(FBaseSQLSelect) then FBaseSQLSelect.Free;
1568     if assigned(FParser) then FParser.Free;
1569     inherited Destroy;
1570     end;
1571    
1572     function TIBCustomDataSet.AdjustCurrentRecord(Buffer: Pointer; GetMode: TGetMode):
1573     TGetResult;
1574     begin
1575     while not IsVisible(Buffer) do
1576     begin
1577     if GetMode = gmPrior then
1578     begin
1579     Dec(FCurrentRecord);
1580     if FCurrentRecord = -1 then
1581     begin
1582     result := grBOF;
1583     exit;
1584     end;
1585     ReadRecordCache(FCurrentRecord, Buffer, False);
1586     end
1587     else begin
1588     Inc(FCurrentRecord);
1589     if (FCurrentRecord = FRecordCount) then
1590     begin
1591     if (not FQSelect.EOF) and FQSelect.Next then
1592     begin
1593     FetchCurrentRecordToBuffer(FQSelect, FCurrentRecord, Buffer);
1594     Inc(FRecordCount);
1595     end
1596     else begin
1597     result := grEOF;
1598     exit;
1599     end;
1600     end
1601     else
1602     ReadRecordCache(FCurrentRecord, Buffer, False);
1603     end;
1604     end;
1605     result := grOK;
1606     end;
1607    
1608     procedure TIBCustomDataSet.ApplyUpdates;
1609     var
1610     CurBookmark: TBookmark;
1611     Buffer: PRecordData;
1612     CurUpdateTypes: TIBUpdateRecordTypes;
1613     UpdateAction: TIBUpdateAction;
1614     UpdateKind: TUpdateKind;
1615     bRecordsSkipped: Boolean;
1616    
1617     procedure GetUpdateKind;
1618     begin
1619     case Buffer^.rdCachedUpdateStatus of
1620     cusModified:
1621     UpdateKind := ukModify;
1622     cusInserted:
1623     UpdateKind := ukInsert;
1624     else
1625     UpdateKind := ukDelete;
1626     end;
1627     end;
1628    
1629     procedure ResetBufferUpdateStatus;
1630     begin
1631     case Buffer^.rdCachedUpdateStatus of
1632     cusModified:
1633     begin
1634     PRecordData(Buffer)^.rdUpdateStatus := usUnmodified;
1635     PRecordData(Buffer)^.rdCachedUpdateStatus := cusUnmodified;
1636     end;
1637     cusInserted:
1638     begin
1639     PRecordData(Buffer)^.rdUpdateStatus := usUnmodified;
1640     PRecordData(Buffer)^.rdCachedUpdateStatus := cusUnmodified;
1641     end;
1642     cusDeleted:
1643     begin
1644     PRecordData(Buffer)^.rdUpdateStatus := usDeleted;
1645     PRecordData(Buffer)^.rdCachedUpdateStatus := cusUnmodified;
1646     end;
1647     end;
1648     WriteRecordCache(PRecordData(Buffer)^.rdRecordNumber, Pointer(Buffer));
1649     end;
1650    
1651     procedure UpdateUsingOnUpdateRecord;
1652     begin
1653     UpdateAction := uaFail;
1654     try
1655     FOnUpdateRecord(Self, UpdateKind, UpdateAction);
1656     except
1657     on E: Exception do
1658     begin
1659     if (E is EDatabaseError) and Assigned(FOnUpdateError) then
1660     FOnUpdateError(Self, EIBError(E), UpdateKind, UpdateAction);
1661     if UpdateAction = uaFail then
1662     raise;
1663     end;
1664     end;
1665     end;
1666    
1667     procedure UpdateUsingUpdateObject;
1668     begin
1669     try
1670     FUpdateObject.Apply(UpdateKind,PChar(Buffer));
1671     ResetBufferUpdateStatus;
1672     except
1673     on E: Exception do
1674     if (E is EDatabaseError) and Assigned(FOnUpdateError) then
1675     FOnUpdateError(Self, EIBError(E), UpdateKind, UpdateAction);
1676     end;
1677     end;
1678    
1679     procedure UpdateUsingInternalquery;
1680     begin
1681     try
1682     case Buffer^.rdCachedUpdateStatus of
1683     cusModified:
1684     InternalPostRecord(FQModify, Buffer);
1685     cusInserted:
1686     InternalPostRecord(FQInsert, Buffer);
1687     cusDeleted:
1688     InternalDeleteRecord(FQDelete, Buffer);
1689     end;
1690     except
1691     on E: EIBError do begin
1692     UpdateAction := uaFail;
1693     if Assigned(FOnUpdateError) then
1694     FOnUpdateError(Self, E, UpdateKind, UpdateAction);
1695     case UpdateAction of
1696     uaFail: raise;
1697     uaAbort: SysUtils.Abort;
1698     uaSkip: bRecordsSkipped := True;
1699     end;
1700     end;
1701     end;
1702     end;
1703    
1704     begin
1705     if State in [dsEdit, dsInsert] then
1706     Post;
1707     FBase.CheckDatabase;
1708     FBase.CheckTransaction;
1709     DisableControls;
1710     CurBookmark := Bookmark;
1711     CurUpdateTypes := FUpdateRecordTypes;
1712     FUpdateRecordTypes := [cusModified, cusInserted, cusDeleted];
1713     try
1714     First;
1715     bRecordsSkipped := False;
1716     while not EOF do
1717     begin
1718     Buffer := PRecordData(GetActiveBuf);
1719     GetUpdateKind;
1720     UpdateAction := uaApply;
1721     if Assigned(FUpdateObject) or Assigned(FOnUpdateRecord) then
1722     begin
1723     if (Assigned(FOnUpdateRecord)) then
1724     UpdateUsingOnUpdateRecord
1725     else
1726     if Assigned(FUpdateObject) then
1727     UpdateUsingUpdateObject;
1728     case UpdateAction of
1729     uaFail:
1730     IBError(ibxeUserAbort, [nil]);
1731     uaAbort:
1732     SysUtils.Abort;
1733     uaApplied:
1734     ResetBufferUpdateStatus;
1735     uaSkip:
1736     bRecordsSkipped := True;
1737     uaRetry:
1738     Continue;
1739     end;
1740     end;
1741     if (not Assigned(FUpdateObject)) and (UpdateAction = UaApply) then
1742     begin
1743     UpdateUsingInternalquery;
1744     UpdateAction := uaApplied;
1745     end;
1746     Next;
1747     end;
1748     FUpdatesPending := bRecordsSkipped;
1749     finally
1750     FUpdateRecordTypes := CurUpdateTypes;
1751     Bookmark := CurBookmark;
1752     EnableControls;
1753     end;
1754     end;
1755    
1756     procedure TIBCustomDataSet.InternalBatchInput(InputObject: TIBBatchInput);
1757     begin
1758     FQSelect.BatchInput(InputObject);
1759     end;
1760    
1761     procedure TIBCustomDataSet.InternalBatchOutput(OutputObject: TIBBatchOutput);
1762     var
1763     Qry: TIBSQL;
1764     begin
1765     Qry := TIBSQL.Create(Self);
1766     try
1767     Qry.Database := FBase.Database;
1768     Qry.Transaction := FBase.Transaction;
1769     Qry.SQL.Assign(FQSelect.SQL);
1770     Qry.BatchOutput(OutputObject);
1771     finally
1772     Qry.Free;
1773     end;
1774     end;
1775    
1776     procedure TIBCustomDataSet.CancelUpdates;
1777     var
1778     CurUpdateTypes: TIBUpdateRecordTypes;
1779     begin
1780     if State in [dsEdit, dsInsert] then
1781     Post;
1782     if FCachedUpdates and FUpdatesPending then
1783     begin
1784     DisableControls;
1785     CurUpdateTypes := UpdateRecordTypes;
1786     UpdateRecordTypes := [cusModified, cusInserted, cusDeleted];
1787     try
1788     First;
1789     while not EOF do
1790     begin
1791     if UpdateStatus = usInserted then
1792     RevertRecord
1793     else
1794     begin
1795     RevertRecord;
1796     Next;
1797     end;
1798     end;
1799     finally
1800     UpdateRecordTypes := CurUpdateTypes;
1801     First;
1802     FUpdatesPending := False;
1803     EnableControls;
1804     end;
1805     end;
1806     end;
1807    
1808     function TIBCustomDataSet.GetFieldPosition(AliasName: string): integer;
1809     var i: integer;
1810     Prepared: boolean;
1811     begin
1812     Result := 0;
1813     Prepared := FInternalPrepared;
1814     if not Prepared then
1815     InternalPrepare;
1816     try
1817     for i := 0 to Length(FAliasNameList) - 1 do
1818     if FAliasNameList[i] = AliasName then
1819     begin
1820     Result := i + 1;
1821     Exit
1822     end;
1823     finally
1824     if not Prepared then
1825     InternalUnPrepare;
1826     end;
1827     end;
1828    
1829     procedure TIBCustomDataSet.ActivateConnection;
1830     begin
1831     if not Assigned(Database) then
1832     IBError(ibxeDatabaseNotAssigned, [nil]);
1833     if not Assigned(Transaction) then
1834     IBError(ibxeTransactionNotAssigned, [nil]);
1835     if not Database.Connected then Database.Open;
1836     end;
1837    
1838     function TIBCustomDataSet.ActivateTransaction: Boolean;
1839     begin
1840     Result := False;
1841     if AllowAutoActivateTransaction or (csDesigning in ComponentState) then
1842     begin
1843     if not Assigned(Transaction) then
1844     IBError(ibxeTransactionNotAssigned, [nil]);
1845     if not Transaction.Active then
1846     begin
1847     Result := True;
1848     Transaction.StartTransaction;
1849     FDidActivate := True;
1850     end;
1851     end;
1852     end;
1853    
1854     procedure TIBCustomDataSet.DeactivateTransaction;
1855     var
1856     i: Integer;
1857     begin
1858     if not Assigned(Transaction) then
1859     IBError(ibxeTransactionNotAssigned, [nil]);
1860     with Transaction do
1861     begin
1862     for i := 0 to SQLObjectCount - 1 do
1863     begin
1864     if (SQLObjects[i] <> nil) and ((SQLObjects[i]).owner is TDataSet) then
1865     begin
1866     if TDataSet(SQLObjects[i].owner).Active then
1867     begin
1868     FDidActivate := False;
1869     exit;
1870     end;
1871     end;
1872     end;
1873     end;
1874     FInternalPrepared := False;
1875     if Transaction.InTransaction then
1876     Transaction.Commit;
1877     FDidActivate := False;
1878     end;
1879    
1880     procedure TIBCustomDataSet.CheckDatasetClosed;
1881     begin
1882     if FOpen then
1883     IBError(ibxeDatasetOpen, [nil]);
1884     end;
1885    
1886     procedure TIBCustomDataSet.CheckDatasetOpen;
1887     begin
1888     if not FOpen then
1889     IBError(ibxeDatasetClosed, [nil]);
1890     end;
1891    
1892     function TIBCustomDataSet.CreateParser: TSelectSQLParser;
1893     begin
1894     Result := TSelectSQLParser.Create(self,FBaseSQLSelect);
1895     Result.OnSQLChanging := SQLChanging
1896     end;
1897    
1898     procedure TIBCustomDataSet.CheckNotUniDirectional;
1899     begin
1900     if UniDirectional then
1901     IBError(ibxeDataSetUniDirectional, [nil]);
1902     end;
1903    
1904     procedure TIBCustomDataSet.AdjustRecordOnInsert(Buffer: Pointer);
1905     begin
1906     with PRecordData(Buffer)^ do
1907     if (State = dsInsert) and (not Modified) then
1908     begin
1909     rdRecordNumber := FRecordCount;
1910     FCurrentRecord := FRecordCount;
1911     end;
1912     end;
1913    
1914     function TIBCustomDataSet.CanEdit: Boolean;
1915     var
1916     Buff: PRecordData;
1917     begin
1918     Buff := PRecordData(GetActiveBuf);
1919     result := (FQModify.SQL.Text <> '') or
1920     (Assigned(FUpdateObject) and (FUpdateObject.GetSQL(ukModify).Text <> '')) or
1921     ((Buff <> nil) and (Buff^.rdCachedUpdateStatus = cusInserted) and
1922     (FCachedUpdates));
1923     end;
1924    
1925     function TIBCustomDataSet.CanInsert: Boolean;
1926     begin
1927     result := (FQInsert.SQL.Text <> '') or
1928     (Assigned(FUpdateObject) and (FUpdateObject.GetSQL(ukInsert).Text <> ''));
1929     end;
1930    
1931     function TIBCustomDataSet.CanDelete: Boolean;
1932     begin
1933     if (FQDelete.SQL.Text <> '') or
1934     (Assigned(FUpdateObject) and (FUpdateObject.GetSQL(ukDelete).Text <> '')) then
1935     result := True
1936     else
1937     result := False;
1938     end;
1939    
1940     function TIBCustomDataSet.CanRefresh: Boolean;
1941     begin
1942     result := (FQRefresh.SQL.Text <> '') or
1943     (Assigned(FUpdateObject) and (FUpdateObject.RefreshSQL.Text <> ''));
1944     end;
1945    
1946     procedure TIBCustomDataSet.CheckEditState;
1947     begin
1948     case State of
1949     { Check all the wsEditMode types }
1950     dsEdit, dsInsert, dsSetKey, dsCalcFields, dsFilter,
1951     dsNewValue, dsInternalCalc :
1952     begin
1953     if (State in [dsEdit]) and (not CanEdit) then
1954     IBError(ibxeCannotUpdate, [nil]);
1955     if (State in [dsInsert]) and (not CanInsert) then
1956     IBError(ibxeCannotInsert, [nil]);
1957     end;
1958     else
1959     IBError(ibxeNotEditing, [])
1960     end;
1961     end;
1962    
1963     procedure TIBCustomDataSet.ClearBlobCache;
1964     var
1965     i: Integer;
1966     begin
1967     for i := 0 to FBlobStreamList.Count - 1 do
1968     begin
1969     TIBBlobStream(FBlobStreamList[i]).Free;
1970     FBlobStreamList[i] := nil;
1971     end;
1972     FBlobStreamList.Pack;
1973     end;
1974    
1975     procedure TIBCustomDataSet.ClearArrayCache;
1976     var
1977     i: Integer;
1978     begin
1979     for i := 0 to FArrayList.Count - 1 do
1980     begin
1981     TIBArray(FArrayList[i]).Free;
1982     FArrayList[i] := nil;
1983     end;
1984     FArrayList.Pack;
1985     end;
1986    
1987     procedure TIBCustomDataSet.CopyRecordBuffer(Source, Dest: Pointer);
1988     begin
1989     Move(Source^, Dest^, FRecordBufferSize);
1990     end;
1991    
1992     procedure TIBCustomDataSet.DoBeforeDatabaseDisconnect(Sender: TObject);
1993     begin
1994     if Active then
1995     Active := False;
1996     InternalUnPrepare;
1997     if Assigned(FBeforeDatabaseDisconnect) then
1998     FBeforeDatabaseDisconnect(Sender);
1999     end;
2000    
2001     procedure TIBCustomDataSet.DoAfterDatabaseDisconnect(Sender: TObject);
2002     begin
2003     if Assigned(FAfterDatabaseDisconnect) then
2004     FAfterDatabaseDisconnect(Sender);
2005     end;
2006    
2007     procedure TIBCustomDataSet.DoDatabaseFree(Sender: TObject);
2008     begin
2009     if Assigned(FDatabaseFree) then
2010     FDatabaseFree(Sender);
2011     end;
2012    
2013     procedure TIBCustomDataSet.DoBeforeTransactionEnd(Sender: TObject;
2014     Action: TTransactionAction);
2015     begin
2016     FCloseAction := Action;
2017     FInTransactionEnd := true;
2018     try
2019     if Active then
2020     Active := False;
2021     finally
2022     FInTransactionEnd := false;
2023     end;
2024     if FQSelect <> nil then
2025     FQSelect.FreeHandle;
2026     if FQDelete <> nil then
2027     FQDelete.FreeHandle;
2028     if FQInsert <> nil then
2029     FQInsert.FreeHandle;
2030     if FQModify <> nil then
2031     FQModify.FreeHandle;
2032     if FQRefresh <> nil then
2033     FQRefresh.FreeHandle;
2034     InternalUnPrepare;
2035     if Assigned(FBeforeTransactionEnd) then
2036     FBeforeTransactionEnd(Sender);
2037     end;
2038    
2039     procedure TIBCustomDataSet.DoAfterTransactionEnd(Sender: TObject);
2040     begin
2041     if Assigned(FAfterTransactionEnd) then
2042     FAfterTransactionEnd(Sender);
2043     end;
2044    
2045     procedure TIBCustomDataSet.DoTransactionFree(Sender: TObject);
2046     begin
2047     if Assigned(FTransactionFree) then
2048     FTransactionFree(Sender);
2049     end;
2050    
2051     procedure TIBCustomDataSet.DoDeleteReturning(QryResults: IResults);
2052     begin
2053     if assigned(FOnDeleteReturning) then
2054     OnDeleteReturning(self,QryResults);
2055     end;
2056    
2057     procedure TIBCustomDataSet.InitModelBuffer(Qry: TIBSQL; Buffer: PChar);
2058     var i, j: Integer;
2059     FieldsLoaded: integer;
2060     p: PRecordData;
2061     colMetadata: IColumnMetaData;
2062     begin
2063     p := PRecordData(Buffer);
2064     { Get record information }
2065     p^.rdBookmarkFlag := bfCurrent;
2066     p^.rdFieldCount := Qry.FieldCount;
2067     p^.rdRecordNumber := -1;
2068     p^.rdUpdateStatus := usUnmodified;
2069     p^.rdCachedUpdateStatus := cusUnmodified;
2070     p^.rdSavedOffset := $FFFFFFFF;
2071    
2072     { Load up the fields }
2073     FieldsLoaded := FQSelect.MetaData.Count;
2074     j := 1;
2075     for i := 0 to Qry.MetaData.Count - 1 do
2076     begin
2077     if (Qry = FQSelect) then
2078     j := i + 1
2079     else
2080     begin
2081     if FieldsLoaded = 0 then
2082     break;
2083     j := FQSelect.FieldIndex[Qry[i].Name] + 1;
2084     if j < 1 then
2085     continue
2086     else
2087     Dec(FieldsLoaded);
2088     end;
2089     if j > 0 then
2090     begin
2091     colMetadata := Qry.MetaData[i];
2092     with p^.rdFields[j], FFieldColumns^[j] do
2093     begin
2094     fdDataType := colMetadata.GetSQLType;
2095     if fdDataType = SQL_BLOB then
2096     fdDataScale := 0
2097     else
2098     fdDataScale := colMetadata.getScale;
2099     fdNullable := colMetadata.getIsNullable;
2100     fdIsNull := true;
2101     fdDataSize := colMetadata.GetSize;
2102     fdDataLength := 0;
2103     fdCodePage := CP_NONE;
2104    
2105     case fdDataType of
2106     SQL_TIMESTAMP,
2107     SQL_TYPE_DATE,
2108     SQL_TYPE_TIME:
2109     fdDataSize := SizeOf(TDateTime);
2110     SQL_SHORT, SQL_LONG:
2111     begin
2112     if (fdDataScale = 0) then
2113     fdDataSize := SizeOf(Integer)
2114     else
2115     if (fdDataScale >= (-4)) then
2116     fdDataSize := SizeOf(Currency)
2117     else
2118     fdDataSize := SizeOf(Double);
2119     end;
2120     SQL_INT64:
2121     begin
2122     if (fdDataScale = 0) then
2123     fdDataSize := SizeOf(Int64)
2124     else
2125     if (fdDataScale >= (-4)) then
2126     fdDataSize := SizeOf(Currency)
2127     else
2128     fdDataSize := SizeOf(Double);
2129     end;
2130     SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT:
2131     fdDataSize := SizeOf(Double);
2132     SQL_BOOLEAN:
2133     fdDataSize := SizeOf(wordBool);
2134     SQL_VARYING,
2135     SQL_TEXT,
2136     SQL_BLOB:
2137     fdCodePage := Qry.Metadata[i].getCodePage;
2138     end;
2139     fdDataOfs := FRecordSize;
2140     Inc(FRecordSize, fdDataSize);
2141     end;
2142     end;
2143     end;
2144     end;
2145    
2146     {Update Buffer Fields from Query Results}
2147    
2148     procedure TIBCustomDataSet.UpdateRecordFromQuery(QryResults: IResults;
2149     Buffer: PChar);
2150     var i, j: integer;
2151     begin
2152     for i := 0 to QryResults.Count - 1 do
2153     begin
2154     j := GetFieldPosition(QryResults[i].GetAliasName);
2155     if j > 0 then
2156     begin
2157     ColumnDataToBuffer(QryResults,i,j,Buffer);
2158     FBufferUpdatedOnQryReturn := true;
2159     end;
2160     end;
2161     end;
2162    
2163    
2164     {Move column data returned from query to row buffer}
2165    
2166     procedure TIBCustomDataSet.ColumnDataToBuffer(QryResults: IResults;
2167     ColumnIndex, FieldIndex: integer; Buffer: PChar);
2168     var
2169     LocalData: PByte;
2170     LocalDate: TDateTime;
2171     LocalDouble: Double;
2172     LocalInt: Integer;
2173     LocalBool: wordBool;
2174     LocalInt64: Int64;
2175     LocalCurrency: Currency;
2176     ColData: ISQLData;
2177     begin
2178     LocalData := nil;
2179     with PRecordData(Buffer)^.rdFields[FieldIndex], FFieldColumns^[FieldIndex] do
2180     begin
2181     QryResults.GetData(ColumnIndex,fdIsNull,fdDataLength,LocalData);
2182     if not fdIsNull then
2183     begin
2184     ColData := QryResults[ColumnIndex];
2185     case fdDataType of {Get Formatted data for column types that need formatting}
2186     SQL_TYPE_DATE,
2187     SQL_TYPE_TIME,
2188     SQL_TIMESTAMP:
2189     begin
2190     {This is an IBX native format and not the TDataset approach. See also GetFieldData}
2191     LocalDate := ColData.AsDateTime;
2192     LocalData := PByte(@LocalDate);
2193     end;
2194     SQL_SHORT, SQL_LONG:
2195     begin
2196     if (fdDataScale = 0) then
2197     begin
2198     LocalInt := ColData.AsLong;
2199     LocalData := PByte(@LocalInt);
2200     end
2201     else
2202     if (fdDataScale >= (-4)) then
2203     begin
2204     LocalCurrency := ColData.AsCurrency;
2205     LocalData := PByte(@LocalCurrency);
2206     end
2207     else
2208     begin
2209     LocalDouble := ColData.AsDouble;
2210     LocalData := PByte(@LocalDouble);
2211     end;
2212     end;
2213     SQL_INT64:
2214     begin
2215     if (fdDataScale = 0) then
2216     begin
2217     LocalInt64 := ColData.AsInt64;
2218     LocalData := PByte(@LocalInt64);
2219     end
2220     else
2221     if (fdDataScale >= (-4)) then
2222     begin
2223     LocalCurrency := ColData.AsCurrency;
2224     LocalData := PByte(@LocalCurrency);
2225     end
2226     else
2227     begin
2228     LocalDouble := ColData.AsDouble;
2229     LocalData := PByte(@LocalDouble);
2230     end
2231     end;
2232     SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT:
2233     begin
2234     LocalDouble := ColData.AsDouble;
2235     LocalData := PByte(@LocalDouble);
2236     end;
2237     SQL_BOOLEAN:
2238     begin
2239     LocalBool := ColData.AsBoolean;
2240     LocalData := PByte(@LocalBool);
2241     end;
2242     end;
2243    
2244     if fdDataType = SQL_VARYING then
2245     Move(LocalData^, Buffer[fdDataOfs], fdDataLength)
2246     else
2247     Move(LocalData^, Buffer[fdDataOfs], fdDataSize)
2248     end
2249     else {Null column}
2250     if fdDataType = SQL_VARYING then
2251     FillChar(Buffer[fdDataOfs],fdDataLength,0)
2252     else
2253     FillChar(Buffer[fdDataOfs],fdDataSize,0);
2254     end;
2255     end;
2256    
2257     function TIBCustomDataSet.GetMasterDetailDelay: integer;
2258     begin
2259     Result := FDataLink.DelayTimerValue;
2260     end;
2261    
2262     { Read the record from FQSelect.Current into the record buffer
2263     Then write the buffer to in memory cache }
2264     procedure TIBCustomDataSet.FetchCurrentRecordToBuffer(Qry: TIBSQL;
2265     RecordNumber: Integer; Buffer: PChar);
2266     var
2267     pbd: PBlobDataArray;
2268     pda: PArrayDataArray;
2269     i, j: Integer;
2270     FieldsLoaded: Integer;
2271     p: PRecordData;
2272     begin
2273     if RecordNumber = -1 then
2274     begin
2275     InitModelBuffer(Qry,Buffer);
2276     Exit;
2277     end;
2278     p := PRecordData(Buffer);
2279     { Make sure blob cache is empty }
2280     pbd := PBlobDataArray(Buffer + FBlobCacheOffset);
2281     pda := PArrayDataArray(Buffer + FArrayCacheOffset);
2282     for i := 0 to BlobFieldCount - 1 do
2283     pbd^[i] := nil;
2284     for i := 0 to ArrayFieldCount - 1 do
2285     pda^[i] := nil;
2286    
2287     { Get record information }
2288     p^.rdBookmarkFlag := bfCurrent;
2289     p^.rdFieldCount := Qry.FieldCount;
2290     p^.rdRecordNumber := RecordNumber;
2291     p^.rdUpdateStatus := usUnmodified;
2292     p^.rdCachedUpdateStatus := cusUnmodified;
2293     p^.rdSavedOffset := $FFFFFFFF;
2294    
2295     { Load up the fields }
2296     FieldsLoaded := FQSelect.MetaData.Count;
2297     j := 1;
2298     for i := 0 to Qry.FieldCount - 1 do
2299     begin
2300     if (Qry = FQSelect) then
2301     j := i + 1
2302     else
2303     begin
2304     if FieldsLoaded = 0 then
2305     break;
2306     j := FQSelect.FieldIndex[Qry[i].Name] + 1;
2307     if j < 1 then
2308     continue
2309     else
2310     Dec(FieldsLoaded);
2311     end;
2312     with FQSelect.MetaData[j - 1] do
2313     if GetAliasname = 'IBX_INTERNAL_DBKEY' then {do not localize}
2314     begin
2315     if (GetSize <= 8) then
2316     p^.rdDBKey := PIBDBKEY(Qry[i].AsPointer)^;
2317     continue;
2318     end;
2319     if j > 0 then
2320     ColumnDataToBuffer(Qry.Current,i,j,Buffer);
2321     end;
2322     WriteRecordCache(RecordNumber, Buffer);
2323     end;
2324    
2325     function TIBCustomDataSet.GetActiveBuf: PChar;
2326     begin
2327     case State of
2328     dsBrowse:
2329     if IsEmpty then
2330     result := nil
2331     else
2332     result := ActiveBuffer;
2333     dsEdit, dsInsert:
2334     result := ActiveBuffer;
2335     dsCalcFields:
2336     result := CalcBuffer;
2337     dsFilter:
2338     result := FFilterBuffer;
2339     dsNewValue:
2340     result := ActiveBuffer;
2341     dsOldValue:
2342     if (PRecordData(ActiveBuffer)^.rdRecordNumber =
2343     PRecordData(FOldBuffer)^.rdRecordNumber) then
2344     result := FOldBuffer
2345     else
2346     result := ActiveBuffer;
2347     else if not FOpen then
2348     result := nil
2349     else
2350     result := ActiveBuffer;
2351     end;
2352     end;
2353    
2354     function TIBCustomDataSet.CachedUpdateStatus: TCachedUpdateStatus;
2355     begin
2356     if Active then
2357     result := PRecordData(GetActiveBuf)^.rdCachedUpdateStatus
2358     else
2359     result := cusUnmodified;
2360     end;
2361    
2362     function TIBCustomDataSet.GetDatabase: TIBDatabase;
2363     begin
2364     result := FBase.Database;
2365     end;
2366    
2367     function TIBCustomDataSet.GetDeleteSQL: TStrings;
2368     begin
2369     result := FQDelete.SQL;
2370     end;
2371    
2372     function TIBCustomDataSet.GetInsertSQL: TStrings;
2373     begin
2374     result := FQInsert.SQL;
2375     end;
2376    
2377     function TIBCustomDataSet.GetSQLParams: ISQLParams;
2378     begin
2379     if not FInternalPrepared then
2380     InternalPrepare;
2381     result := FQSelect.Params;
2382     end;
2383    
2384     function TIBCustomDataSet.GetRefreshSQL: TStrings;
2385     begin
2386     result := FQRefresh.SQL;
2387     end;
2388    
2389     function TIBCustomDataSet.GetSelectSQL: TStrings;
2390     begin
2391     result := FQSelect.SQL;
2392     end;
2393    
2394     function TIBCustomDataSet.GetStatementType: TIBSQLStatementTypes;
2395     begin
2396     result := FQSelect.SQLStatementType;
2397     end;
2398    
2399     function TIBCustomDataSet.GetModifySQL: TStrings;
2400     begin
2401     result := FQModify.SQL;
2402     end;
2403    
2404     function TIBCustomDataSet.GetTransaction: TIBTransaction;
2405     begin
2406     result := FBase.Transaction;
2407     end;
2408    
2409     procedure TIBCustomDataSet.InternalDeleteRecord(Qry: TIBSQL; Buff: Pointer);
2410     begin
2411     if (Assigned(FUpdateObject) and (FUpdateObject.GetSQL(ukDelete).Text <> '')) then
2412     FUpdateObject.Apply(ukDelete,Buff)
2413     else
2414     begin
2415     SetInternalSQLParams(FQDelete.Params, Buff);
2416     FQDelete.ExecQuery;
2417     if (FQDelete.FieldCount > 0) then
2418     DoDeleteReturning(FQDelete.Current);
2419     end;
2420     with PRecordData(Buff)^ do
2421     begin
2422     rdUpdateStatus := usDeleted;
2423     rdCachedUpdateStatus := cusUnmodified;
2424     end;
2425     WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Buff);
2426     end;
2427    
2428     function TIBCustomDataSet.InternalLocate(const KeyFields: string;
2429     const KeyValues: Variant; Options: TLocateOptions): Boolean;
2430     var
2431     keyFieldList: TList;
2432     CurBookmark: TBookmark;
2433     fieldValue: Variant;
2434     lookupValues: array of variant;
2435     i, fieldCount: Integer;
2436     fieldValueAsString: string;
2437     lookupValueAsString: string;
2438     begin
2439     keyFieldList := TList.Create;
2440     try
2441     GetFieldList(keyFieldList, KeyFields);
2442     fieldCount := keyFieldList.Count;
2443     CurBookmark := Bookmark;
2444     result := false;
2445     SetLength(lookupValues, fieldCount);
2446     if not EOF then
2447     begin
2448     for i := 0 to fieldCount - 1 do {expand key values into lookupValues array}
2449     begin
2450     if VarIsArray(KeyValues) then
2451     lookupValues[i] := KeyValues[i]
2452     else
2453     if i > 0 then
2454     lookupValues[i] := NULL
2455     else
2456     lookupValues[0] := KeyValues;
2457    
2458     {convert to upper case is case insensitive search}
2459     if (TField(keyFieldList[i]).DataType = ftString) and
2460     not VarIsNull(lookupValues[i]) and (loCaseInsensitive in Options) then
2461     lookupValues[i] := UpperCase(lookupValues[i]);
2462     end;
2463     end;
2464     while not result and not EOF do {search for a matching record}
2465     begin
2466     i := 0;
2467     result := true;
2468     while result and (i < fieldCount) do
2469     {see if all of the key fields matches}
2470     begin
2471     fieldValue := TField(keyFieldList[i]).Value;
2472     result := not (VarIsNull(fieldValue) xor VarIsNull(lookupValues[i]));
2473     if result and not VarIsNull(fieldValue) then
2474     begin
2475     try
2476     if TField(keyFieldList[i]).DataType = ftString then
2477     begin
2478     {strings need special handling because of the locate options that
2479     apply to them}
2480     fieldValueAsString := TField(keyFieldList[i]).AsString;
2481     lookupValueAsString := lookupValues[i];
2482     if (loCaseInsensitive in Options) then
2483     fieldValueAsString := UpperCase(fieldValueAsString);
2484    
2485     if (loPartialKey in Options) then
2486     result := result and (Pos(lookupValueAsString, fieldValueAsString) = 1)
2487     else
2488     result := result and (fieldValueAsString = lookupValueAsString);
2489     end
2490     else
2491     result := result and (lookupValues[i] =
2492     VarAsType(fieldValue, VarType(lookupValues[i])));
2493     except on EVariantError do
2494     result := False;
2495     end;
2496     end;
2497     Inc(i);
2498     end;
2499     if not result then
2500     Next;
2501     end;
2502     if not result then
2503     Bookmark := CurBookmark
2504     else
2505     CursorPosChanged;
2506     finally
2507     keyFieldList.Free;
2508     SetLength(lookupValues,0)
2509     end;
2510     end;
2511    
2512     procedure TIBCustomDataSet.InternalPostRecord(Qry: TIBSQL; Buff: Pointer);
2513     var
2514     i, j, k, arr: Integer;
2515     pbd: PBlobDataArray;
2516     pda: PArrayDataArray;
2517     begin
2518     pbd := PBlobDataArray(PChar(Buff) + FBlobCacheOffset);
2519     pda := PArrayDataArray(PChar(Buff) + FArrayCacheOffset);
2520     j := 0; arr := 0;
2521     for i := 0 to FieldCount - 1 do
2522     if Fields[i].IsBlob then
2523     begin
2524     k := FMappedFieldPosition[Fields[i].FieldNo -1];
2525     if pbd^[j] <> nil then
2526     begin
2527     pbd^[j].Finalize;
2528     PISC_QUAD(
2529     PChar(Buff) + FFieldColumns^[k].fdDataOfs)^ :=
2530     pbd^[j].BlobID;
2531     PRecordData(Buff)^.rdFields[k].fdIsNull := pbd^[j].Size = 0;
2532     end
2533     else
2534     begin
2535     PRecordData(Buff)^.rdFields[k].fdIsNull := true;
2536     with PISC_QUAD(PChar(Buff) + FFieldColumns^[k].fdDataOfs)^ do
2537     begin
2538     gds_quad_high := 0;
2539     gds_quad_low := 0;
2540     end;
2541     end;
2542     Inc(j);
2543     end
2544     else
2545     if Fields[i] is TIBArrayField then
2546     begin
2547     if pda^[arr] <> nil then
2548     begin
2549     k := FMappedFieldPosition[Fields[i].FieldNo -1];
2550     PISC_QUAD(
2551     PChar(Buff) + FFieldColumns^[k].fdDataOfs)^ := pda^[arr].ArrayIntf.GetArrayID;
2552     PRecordData(Buff)^.rdFields[k].fdIsNull := pda^[arr].ArrayIntf.IsEmpty;
2553     end;
2554     Inc(arr);
2555     end;
2556     FBufferUpdatedOnQryReturn := false;
2557     if Assigned(FUpdateObject) then
2558     begin
2559     if (Qry = FQDelete) then
2560     FUpdateObject.Apply(ukDelete,Buff)
2561     else if (Qry = FQInsert) then
2562     FUpdateObject.Apply(ukInsert,Buff)
2563     else
2564     FUpdateObject.Apply(ukModify,Buff);
2565     FUpdateObject.GetRowsAffected(FSelectCount, FInsertCount, FUpdateCount, FDeleteCount);
2566     end
2567     else begin
2568     SetInternalSQLParams(Qry.Params, Buff);
2569     Qry.ExecQuery;
2570     Qry.Statement.GetRowsAffected(FSelectCount, FInsertCount, FUpdateCount, FDeleteCount);
2571     if Qry.FieldCount > 0 then {Has RETURNING Clause}
2572     UpdateRecordFromQuery(Qry.Current,Buff);
2573     end;
2574     PRecordData(Buff)^.rdUpdateStatus := usUnmodified;
2575     PRecordData(Buff)^.rdCachedUpdateStatus := cusUnmodified;
2576     SetModified(False);
2577     WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Buff);
2578     if (FForcedRefresh or (FNeedsRefresh and not FBufferUpdatedOnQryReturn)) and CanRefresh then
2579     InternalRefreshRow;
2580     end;
2581    
2582     procedure TIBCustomDataSet.InternalRefreshRow;
2583     var
2584     Buff: PChar;
2585     ofs: DWORD;
2586     Qry: TIBSQL;
2587     begin
2588     FBase.SetCursor;
2589     try
2590     Buff := GetActiveBuf;
2591     if CanRefresh then
2592     begin
2593     if Buff <> nil then
2594     begin
2595     if (Assigned(FUpdateObject) and (FUpdateObject.RefreshSQL.Text <> '')) then
2596     begin
2597     Qry := TIBSQL.Create(self);
2598     Qry.Database := Database;
2599     Qry.Transaction := Transaction;
2600     Qry.GoToFirstRecordOnExecute := False;
2601     Qry.SQL.Text := FUpdateObject.RefreshSQL.Text;
2602     end
2603     else
2604     Qry := FQRefresh;
2605     SetInternalSQLParams(Qry.Params, Buff);
2606     Qry.ExecQuery;
2607     try
2608     if (Qry.SQLStatementType = SQLExecProcedure) or Qry.Next then
2609     begin
2610     ofs := PRecordData(Buff)^.rdSavedOffset;
2611     FetchCurrentRecordToBuffer(Qry,
2612     PRecordData(Buff)^.rdRecordNumber,
2613     Buff);
2614     if FCachedUpdates and (ofs <> $FFFFFFFF) then
2615     begin
2616     PRecordData(Buff)^.rdSavedOffset := ofs;
2617     WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Buff);
2618     SaveOldBuffer(Buff);
2619     end;
2620     end;
2621     finally
2622     Qry.Close;
2623     end;
2624     if Qry <> FQRefresh then
2625     Qry.Free;
2626     end
2627     end
2628     else
2629     IBError(ibxeCannotRefresh, [nil]);
2630     finally
2631     FBase.RestoreCursor;
2632     end;
2633     end;
2634    
2635     procedure TIBCustomDataSet.InternalRevertRecord(RecordNumber: Integer);
2636     var
2637     NewBuffer, OldBuffer: PRecordData;
2638    
2639     begin
2640     NewBuffer := nil;
2641     OldBuffer := nil;
2642     NewBuffer := PRecordData(AllocRecordBuffer);
2643     OldBuffer := PRecordData(AllocRecordBuffer);
2644     try
2645     ReadRecordCache(RecordNumber, PChar(NewBuffer), False);
2646     ReadRecordCache(RecordNumber, PChar(OldBuffer), True);
2647     case NewBuffer^.rdCachedUpdateStatus of
2648     cusInserted:
2649     begin
2650     NewBuffer^.rdCachedUpdateStatus := cusUninserted;
2651     Inc(FDeletedRecords);
2652     end;
2653     cusModified,
2654     cusDeleted:
2655     begin
2656     if (NewBuffer^.rdCachedUpdateStatus = cusDeleted) then
2657     Dec(FDeletedRecords);
2658     CopyRecordBuffer(OldBuffer, NewBuffer);
2659     end;
2660     end;
2661    
2662     if State in dsEditModes then
2663     Cancel;
2664    
2665     WriteRecordCache(RecordNumber, PChar(NewBuffer));
2666    
2667     if (NewBuffer^.rdCachedUpdateStatus = cusUninserted ) then
2668     ReSync([]);
2669     finally
2670     FreeRecordBuffer(PChar(NewBuffer));
2671     FreeRecordBuffer(PChar(OldBuffer));
2672     end;
2673     end;
2674    
2675     { A visible record is one that is not truly deleted,
2676     and it is also listed in the FUpdateRecordTypes set }
2677    
2678     function TIBCustomDataSet.IsVisible(Buffer: PChar): Boolean;
2679     begin
2680     result := True;
2681     if not (State = dsOldValue) then
2682     result :=
2683     (PRecordData(Buffer)^.rdCachedUpdateStatus in FUpdateRecordTypes) and
2684     (not ((PRecordData(Buffer)^.rdCachedUpdateStatus = cusUnmodified) and
2685     (PRecordData(Buffer)^.rdUpdateStatus = usDeleted)));
2686     end;
2687    
2688    
2689     function TIBCustomDataSet.LocateNext(const KeyFields: string;
2690     const KeyValues: Variant; Options: TLocateOptions): Boolean;
2691     begin
2692     DisableControls;
2693     try
2694     result := InternalLocate(KeyFields, KeyValues, Options);
2695     finally
2696     EnableControls;
2697     end;
2698     end;
2699    
2700     procedure TIBCustomDataSet.InternalPrepare;
2701     begin
2702     if FInternalPrepared then
2703     Exit;
2704     FBase.SetCursor;
2705     try
2706     ActivateConnection;
2707     ActivateTransaction;
2708     FBase.CheckDatabase;
2709     FBase.CheckTransaction;
2710     if HasParser and (FParser.SQLText <> FQSelect.SQL.Text) then
2711     begin
2712     FQSelect.OnSQLChanged := nil; {Do not react to change}
2713     try
2714     FQSelect.SQL.Text := FParser.SQLText;
2715     finally
2716     FQSelect.OnSQLChanged := SQLChanged;
2717     end;
2718     end;
2719     // writeln( FQSelect.SQL.Text);
2720     if FQSelect.SQL.Text <> '' then
2721     begin
2722     if not FQSelect.Prepared then
2723     begin
2724     FQSelect.GenerateParamNames := FGenerateParamNames;
2725     FQSelect.ParamCheck := ParamCheck;
2726     FQSelect.Prepare;
2727     end;
2728     FQDelete.GenerateParamNames := FGenerateParamNames;
2729     if (Trim(FQDelete.SQL.Text) <> '') and (not FQDelete.Prepared) then
2730     FQDelete.Prepare;
2731     FQInsert.GenerateParamNames := FGenerateParamNames;
2732     if (Trim(FQInsert.SQL.Text) <> '') and (not FQInsert.Prepared) then
2733     FQInsert.Prepare;
2734     FQRefresh.GenerateParamNames := FGenerateParamNames;
2735     if (Trim(FQRefresh.SQL.Text) <> '') and (not FQRefresh.Prepared) then
2736     FQRefresh.Prepare;
2737     FQModify.GenerateParamNames := FGenerateParamNames;
2738     if (Trim(FQModify.SQL.Text) <> '') and (not FQModify.Prepared) then
2739     FQModify.Prepare;
2740     FInternalPrepared := True;
2741     InternalInitFieldDefs;
2742     end else
2743     IBError(ibxeEmptyQuery, [nil]);
2744     finally
2745     FBase.RestoreCursor;
2746     end;
2747     end;
2748    
2749     procedure TIBCustomDataSet.RecordModified(Value: Boolean);
2750     begin
2751     SetModified(Value);
2752     end;
2753    
2754     procedure TIBCustomDataSet.RevertRecord;
2755     var
2756     Buff: PRecordData;
2757     begin
2758     if FCachedUpdates and FUpdatesPending then
2759     begin
2760     Buff := PRecordData(GetActiveBuf);
2761     InternalRevertRecord(Buff^.rdRecordNumber);
2762     ReadRecordCache(Buff^.rdRecordNumber, PChar(Buff), False);
2763     DataEvent(deRecordChange, 0);
2764     end;
2765     end;
2766    
2767     procedure TIBCustomDataSet.SaveOldBuffer(Buffer: PChar);
2768     var
2769     OldBuffer: Pointer;
2770     procedure CopyOldBuffer;
2771     begin
2772     CopyRecordBuffer(Buffer, OldBuffer);
2773     if BlobFieldCount > 0 then
2774     FillChar(PChar(OldBuffer)[FBlobCacheOffset],
2775     BlobFieldCount * SizeOf(TIBBlobStream) + ArrayFieldCount * SizeOf(IArray),
2776     0);
2777     end;
2778    
2779     begin
2780     if (Buffer <> nil) and (PRecordData(Buffer)^.rdRecordNumber >= 0) then
2781     begin
2782     OldBuffer := AllocRecordBuffer;
2783     try
2784     if (PRecordData(Buffer)^.rdSavedOffset = $FFFFFFFF) then
2785     begin
2786     PRecordData(Buffer)^.rdSavedOffset := AdjustPosition(FOldBufferCache, 0,
2787     FILE_END);
2788     CopyOldBuffer;
2789     WriteCache(FOldBufferCache, 0, FILE_CURRENT, OldBuffer);
2790     WriteCache(FBufferCache, PRecordData(Buffer)^.rdRecordNumber * FRecordBufferSize,
2791     FILE_BEGIN, Buffer);
2792     end
2793     else begin
2794     CopyOldBuffer;
2795     WriteCache(FOldBufferCache, PRecordData(Buffer)^.rdSavedOffset, FILE_BEGIN,
2796     OldBuffer);
2797     end;
2798     finally
2799     FreeRecordBuffer(PChar(OldBuffer));
2800     end;
2801     end;
2802     end;
2803    
2804     procedure TIBCustomDataSet.SetBufferChunks(Value: Integer);
2805     begin
2806     if (Value <= 0) then
2807     FBufferChunks := BufferCacheSize
2808     else
2809     FBufferChunks := Value;
2810     end;
2811    
2812     procedure TIBCustomDataSet.SetDatabase(Value: TIBDatabase);
2813     begin
2814     if (csLoading in ComponentState) or (FBase.Database <> Value) then
2815     begin
2816     CheckDatasetClosed;
2817     InternalUnPrepare;
2818     FBase.Database := Value;
2819     FQDelete.Database := Value;
2820     FQInsert.Database := Value;
2821     FQRefresh.Database := Value;
2822     FQSelect.Database := Value;
2823     FQModify.Database := Value;
2824     FDatabaseInfo.Database := Value;
2825     FGeneratorField.Database := Value;
2826     end;
2827     end;
2828    
2829     procedure TIBCustomDataSet.SetDeleteSQL(Value: TStrings);
2830     begin
2831     if FQDelete.SQL.Text <> Value.Text then
2832     begin
2833     Disconnect;
2834     FQDelete.SQL.Assign(Value);
2835     end;
2836     end;
2837    
2838     procedure TIBCustomDataSet.SetInsertSQL(Value: TStrings);
2839     begin
2840     if FQInsert.SQL.Text <> Value.Text then
2841     begin
2842     Disconnect;
2843     FQInsert.SQL.Assign(Value);
2844     end;
2845     end;
2846    
2847     procedure TIBCustomDataSet.SetInternalSQLParams(Params: ISQLParams; Buffer: Pointer);
2848     var
2849     i, j: Integer;
2850     cr, data: PChar;
2851     fn: string;
2852     st: RawByteString;
2853     OldBuffer: Pointer;
2854     Param: ISQLParam;
2855     begin
2856     if (Buffer = nil) then
2857     IBError(ibxeBufferNotSet, [nil]);
2858     if (not FInternalPrepared) then
2859     InternalPrepare;
2860     OldBuffer := nil;
2861     try
2862     for i := 0 to Params.GetCount - 1 do
2863     begin
2864     Param := Params[i];
2865     fn := Param.Name;
2866     if (Pos('OLD_', fn) = 1) then {mbcs ok}
2867     begin
2868     fn := Copy(fn, 5, Length(fn));
2869     if not Assigned(OldBuffer) then
2870     begin
2871     OldBuffer := AllocRecordBuffer;
2872     ReadRecordCache(PRecordData(Buffer)^.rdRecordNumber, OldBuffer, True);
2873     end;
2874     cr := OldBuffer;
2875     end
2876     else if (Pos('NEW_', fn) = 1) then {mbcs ok}
2877     begin
2878     fn := Copy(fn, 5, Length(fn));
2879     cr := Buffer;
2880     end
2881     else
2882     cr := Buffer;
2883     j := FQSelect.FieldIndex[fn] + 1;
2884     if (j > 0) then
2885     with PRecordData(cr)^,rdFields[j], FFieldColumns^[j] do
2886     begin
2887     if Param.name = 'IBX_INTERNAL_DBKEY' then {do not localize}
2888     begin
2889     PIBDBKey(Param.AsPointer)^ := rdDBKey;
2890     continue;
2891     end;
2892     if fdIsNull then
2893     Param.IsNull := True
2894     else begin
2895     Param.IsNull := False;
2896     data := cr + fdDataOfs;
2897     case fdDataType of
2898     SQL_TEXT, SQL_VARYING:
2899     begin
2900     SetString(st, data, fdDataLength);
2901     SetCodePage(st,fdCodePage,false);
2902     Param.AsString := st;
2903     end;
2904     SQL_FLOAT, SQL_DOUBLE, SQL_D_FLOAT:
2905     Param.AsDouble := PDouble(data)^;
2906     SQL_SHORT, SQL_LONG:
2907     begin
2908     if fdDataScale = 0 then
2909     Param.AsLong := PLong(data)^
2910     else
2911     if fdDataScale >= (-4) then
2912     Param.AsCurrency := PCurrency(data)^
2913     else
2914     Param.AsDouble := PDouble(data)^;
2915     end;
2916     SQL_INT64:
2917     begin
2918     if fdDataScale = 0 then
2919     Param.AsInt64 := PInt64(data)^
2920     else
2921     if fdDataScale >= (-4) then
2922     Param.AsCurrency := PCurrency(data)^
2923     else
2924     Param.AsDouble := PDouble(data)^;
2925     end;
2926     SQL_BLOB, SQL_ARRAY, SQL_QUAD:
2927     Param.AsQuad := PISC_QUAD(data)^;
2928     SQL_TYPE_DATE,
2929     SQL_TYPE_TIME,
2930     SQL_TIMESTAMP:
2931     {This is an IBX native format and not the TDataset approach. See also SetFieldData}
2932     Param.AsDateTime := PDateTime(data)^;
2933     SQL_BOOLEAN:
2934     Param.AsBoolean := PWordBool(data)^;
2935     end;
2936     end;
2937     end;
2938     end;
2939     finally
2940     if (OldBuffer <> nil) then
2941     FreeRecordBuffer(PChar(OldBuffer));
2942     end;
2943     end;
2944    
2945     procedure TIBCustomDataSet.SetRefreshSQL(Value: TStrings);
2946     begin
2947     if FQRefresh.SQL.Text <> Value.Text then
2948     begin
2949     Disconnect;
2950     FQRefresh.SQL.Assign(Value);
2951     end;
2952     end;
2953    
2954     procedure TIBCustomDataSet.SetSelectSQL(Value: TStrings);
2955     begin
2956     if FQSelect.SQL.Text <> Value.Text then
2957     begin
2958     Disconnect;
2959     FQSelect.SQL.Assign(Value);
2960     end;
2961     end;
2962    
2963     procedure TIBCustomDataSet.SetModifySQL(Value: TStrings);
2964     begin
2965     if FQModify.SQL.Text <> Value.Text then
2966     begin
2967     Disconnect;
2968     FQModify.SQL.Assign(Value);
2969     end;
2970     end;
2971    
2972     procedure TIBCustomDataSet.SetTransaction(Value: TIBTransaction);
2973     begin
2974     if (FBase.Transaction <> Value) then
2975     begin
2976     CheckDatasetClosed;
2977     FBase.Transaction := Value;
2978     FQDelete.Transaction := Value;
2979     FQInsert.Transaction := Value;
2980     FQRefresh.Transaction := Value;
2981     FQSelect.Transaction := Value;
2982     FQModify.Transaction := Value;
2983     FGeneratorField.Transaction := Value;
2984     end;
2985     end;
2986    
2987     procedure TIBCustomDataSet.SetUniDirectional(Value: Boolean);
2988     begin
2989     CheckDatasetClosed;
2990     FUniDirectional := Value;
2991     end;
2992    
2993     procedure TIBCustomDataSet.SetUpdateRecordTypes(Value: TIBUpdateRecordTypes);
2994     begin
2995     FUpdateRecordTypes := Value;
2996     if Active then
2997     First;
2998     end;
2999    
3000     procedure TIBCustomDataSet.RefreshParams;
3001     var
3002     DataSet: TDataSet;
3003     begin
3004     DisableControls;
3005     try
3006     if FDataLink.DataSource <> nil then
3007     begin
3008     DataSet := FDataLink.DataSource.DataSet;
3009     if DataSet <> nil then
3010     if DataSet.Active and (DataSet.State <> dsSetKey) then
3011     begin
3012     Close;
3013     Open;
3014     end;
3015     end;
3016     finally
3017     EnableControls;
3018     end;
3019     end;
3020    
3021     procedure TIBCustomDataSet.RegisterIBLink(Sender: TIBControlLink);
3022     begin
3023     if FIBLinks.IndexOf(Sender) = -1 then
3024     begin
3025     FIBLinks.Add(Sender);
3026     if Active then
3027     begin
3028     Active := false;
3029     Active := true;
3030     end;
3031     end;
3032     end;
3033    
3034    
3035     procedure TIBCustomDataSet.SQLChanging(Sender: TObject);
3036     begin
3037     Active := false;
3038     { if FOpen then
3039     InternalClose;}
3040     if FInternalPrepared then
3041     InternalUnPrepare;
3042     FieldDefs.Clear;
3043     FieldDefs.Updated := false;
3044     end;
3045    
3046     procedure TIBCustomDataSet.SQLChanged(Sender: TObject);
3047     begin
3048     FBaseSQLSelect.assign(FQSelect.SQL);
3049     end;
3050    
3051     { I can "undelete" uninserted records (make them "inserted" again).
3052     I can "undelete" cached deleted (the deletion hasn't yet occurred) }
3053     procedure TIBCustomDataSet.Undelete;
3054     var
3055     Buff: PRecordData;
3056     begin
3057     CheckActive;
3058     Buff := PRecordData(GetActiveBuf);
3059     with Buff^ do
3060     begin
3061     if rdCachedUpdateStatus = cusUninserted then
3062     begin
3063     rdCachedUpdateStatus := cusInserted;
3064     Dec(FDeletedRecords);
3065     end
3066     else if (rdUpdateStatus = usDeleted) and
3067     (rdCachedUpdateStatus = cusDeleted) then
3068     begin
3069     rdCachedUpdateStatus := cusUnmodified;
3070     rdUpdateStatus := usUnmodified;
3071     Dec(FDeletedRecords);
3072     end;
3073     WriteRecordCache(rdRecordNumber, PChar(Buff));
3074     end;
3075     end;
3076    
3077     procedure TIBCustomDataSet.UnRegisterIBLink(Sender: TIBControlLink);
3078     begin
3079     FIBLinks.Remove(Sender);
3080     end;
3081    
3082     function TIBCustomDataSet.UpdateStatus: TUpdateStatus;
3083     begin
3084     if Active then
3085     if GetActiveBuf <> nil then
3086     result := PRecordData(GetActiveBuf)^.rdUpdateStatus
3087     else
3088     result := usUnmodified
3089     else
3090     result := usUnmodified;
3091     end;
3092    
3093     function TIBCustomDataSet.IsSequenced: Boolean;
3094     begin
3095     Result := Assigned( FQSelect ) and FQSelect.EOF;
3096     end;
3097    
3098     function TIBCustomDataSet.ParamByName(ParamName: String): ISQLParam;
3099     begin
3100     ActivateConnection;
3101     ActivateTransaction;
3102     if not FInternalPrepared then
3103     InternalPrepare;
3104     Result := Params.ByName(ParamName);
3105     end;
3106    
3107     function TIBCustomDataSet.GetRowsAffected(var SelectCount, InsertCount,
3108     UpdateCount, DeleteCount: integer): boolean;
3109     begin
3110     Result := Active;
3111     SelectCount := FSelectCount;
3112     InsertCount := FInsertCount;
3113     UpdateCount := FUpdateCount;
3114     DeleteCount := FDeleteCount;
3115     end;
3116    
3117     function TIBCustomDataSet.GetPerfStatistics(var stats: TPerfCounters): boolean;
3118     begin
3119     Result := EnableStatistics and (FQSelect.Statement <> nil) and
3120     FQSelect.Statement.GetPerfStatistics(stats);
3121     end;
3122    
3123     {Beware: the parameter FCache is used as an identifier to determine which
3124     cache is being operated on and is not referenced in the computation.
3125     The result is an adjusted offset into the identified cache, either the
3126     Buffer Cache or the old Buffer Cache.}
3127    
3128     function TIBCustomDataSet.AdjustPosition(FCache: PChar; Offset: DWORD;
3129     Origin: Integer): DWORD;
3130     var
3131     OldCacheSize: Integer;
3132     begin
3133     if (FCache = FBufferCache) then
3134     begin
3135     case Origin of
3136     FILE_BEGIN: FBPos := Offset;
3137     FILE_CURRENT: FBPos := FBPos + Offset;
3138     FILE_END: FBPos := DWORD(FBEnd) + Offset;
3139     end;
3140     OldCacheSize := FCacheSize;
3141     while (FBPos >= DWORD(FCacheSize)) do
3142     Inc(FCacheSize, FBufferChunkSize);
3143     if FCacheSize > OldCacheSize then
3144     IBAlloc(FBufferCache, FCacheSize, FCacheSize);
3145     result := FBPos;
3146     end
3147     else begin
3148     case Origin of
3149     FILE_BEGIN: FOBPos := Offset;
3150     FILE_CURRENT: FOBPos := FOBPos + Offset;
3151     FILE_END: FOBPos := DWORD(FOBEnd) + Offset;
3152     end;
3153     OldCacheSize := FOldCacheSize;
3154     while (FBPos >= DWORD(FOldCacheSize)) do
3155     Inc(FOldCacheSize, FBufferChunkSize);
3156     if FOldCacheSize > OldCacheSize then
3157     IBAlloc(FOldBufferCache, FOldCacheSize, FOldCacheSize);
3158     result := FOBPos;
3159     end;
3160     end;
3161    
3162     procedure TIBCustomDataSet.ReadCache(FCache: PChar; Offset: DWORD; Origin: Integer;
3163     Buffer: PChar);
3164     var
3165     pCache: PChar;
3166     AdjustedOffset: DWORD;
3167     bOld: Boolean;
3168     begin
3169     bOld := (FCache = FOldBufferCache);
3170     AdjustedOffset := AdjustPosition(FCache, Offset, Origin);
3171     if not bOld then
3172     pCache := FBufferCache + AdjustedOffset
3173     else
3174     pCache := FOldBufferCache + AdjustedOffset;
3175     Move(pCache^, Buffer^, DWORD(FRecordBufferSize));
3176     AdjustPosition(FCache, FRecordBufferSize, FILE_CURRENT);
3177     end;
3178    
3179     procedure TIBCustomDataSet.ReadRecordCache(RecordNumber: Integer; Buffer: PChar;
3180     ReadOldBuffer: Boolean);
3181     begin
3182     if FUniDirectional then
3183     RecordNumber := RecordNumber mod UniCache;
3184     if (ReadOldBuffer) then
3185     begin
3186     ReadRecordCache(RecordNumber, Buffer, False);
3187     if FCachedUpdates and
3188     (PRecordData(Buffer)^.rdSavedOffset <> $FFFFFFFF) then
3189     ReadCache(FOldBufferCache, PRecordData(Buffer)^.rdSavedOffset, FILE_BEGIN,
3190     Buffer)
3191     else
3192     if ReadOldBuffer and
3193     (PRecordData(FOldBuffer)^.rdRecordNumber = RecordNumber) then
3194     CopyRecordBuffer( FOldBuffer, Buffer )
3195     end
3196     else
3197     ReadCache(FBufferCache, RecordNumber * FRecordBufferSize, FILE_BEGIN, Buffer);
3198     end;
3199    
3200     procedure TIBCustomDataSet.WriteCache(FCache: PChar; Offset: DWORD; Origin: Integer;
3201     Buffer: PChar);
3202     var
3203     pCache: PChar;
3204     AdjustedOffset: DWORD;
3205     bOld: Boolean;
3206     dwEnd: DWORD;
3207     begin
3208     bOld := (FCache = FOldBufferCache);
3209     AdjustedOffset := AdjustPosition(FCache, Offset, Origin);
3210     if not bOld then
3211     pCache := FBufferCache + AdjustedOffset
3212     else
3213     pCache := FOldBufferCache + AdjustedOffset;
3214     Move(Buffer^, pCache^, FRecordBufferSize);
3215     dwEnd := AdjustPosition(FCache, FRecordBufferSize, FILE_CURRENT);
3216     if not bOld then
3217     begin
3218     if (dwEnd > FBEnd) then
3219     FBEnd := dwEnd;
3220     end
3221     else begin
3222     if (dwEnd > FOBEnd) then
3223     FOBEnd := dwEnd;
3224     end;
3225     end;
3226    
3227     procedure TIBCustomDataSet.WriteRecordCache(RecordNumber: Integer; Buffer: PChar);
3228     begin
3229     if RecordNumber >= 0 then
3230     begin
3231     if FUniDirectional then
3232     RecordNumber := RecordNumber mod UniCache;
3233     WriteCache(FBufferCache, RecordNumber * FRecordBufferSize, FILE_BEGIN, Buffer);
3234     end;
3235     end;
3236    
3237     function TIBCustomDataSet.AllocRecordBuffer: PChar;
3238     begin
3239     result := nil;
3240     IBAlloc(result, FRecordBufferSize, FRecordBufferSize);
3241     Move(FModelBuffer^, result^, FRecordBufferSize);
3242     end;
3243    
3244     function TIBCustomDataSet.CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream;
3245     var
3246     pb: PBlobDataArray;
3247     fs: TIBBlobStream;
3248     Buff: PChar;
3249     bTr, bDB: Boolean;
3250     begin
3251     if (Field = nil) or (Field.DataSet <> self) then
3252     IBError(ibxFieldNotinDataSet,[Field.Name,Name]);
3253     Buff := GetActiveBuf;
3254     if Buff = nil then
3255     begin
3256     fs := TIBBlobStream.Create;
3257     fs.Mode := bmReadWrite;
3258     fs.Database := Database;
3259     fs.Transaction := Transaction;
3260     fs.SetField(Field);
3261     FBlobStreamList.Add(Pointer(fs));
3262     result := TIBDSBlobStream.Create(Field, fs, Mode);
3263     exit;
3264     end;
3265     pb := PBlobDataArray(Buff + FBlobCacheOffset);
3266     if pb^[Field.Offset] = nil then
3267     begin
3268     AdjustRecordOnInsert(Buff);
3269     pb^[Field.Offset] := TIBBlobStream.Create;
3270     fs := pb^[Field.Offset];
3271     FBlobStreamList.Add(Pointer(fs));
3272     fs.Mode := bmReadWrite;
3273     fs.Database := Database;
3274     fs.Transaction := Transaction;
3275     fs.SetField(Field);
3276     fs.BlobID :=
3277     PISC_QUAD(@Buff[FFieldColumns^[FMappedFieldPosition[Field.FieldNo - 1]].fdDataOfs])^;
3278     if (CachedUpdates) then
3279     begin
3280     bTr := not Transaction.InTransaction;
3281     bDB := not Database.Connected;
3282     if bDB then
3283     Database.Open;
3284     if bTr then
3285     Transaction.StartTransaction;
3286     fs.Seek(0, soFromBeginning);
3287     if bTr then
3288     Transaction.Commit;
3289     if bDB then
3290     Database.Close;
3291     end;
3292     WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Pointer(Buff));
3293     end else
3294     fs := pb^[Field.Offset];
3295     result := TIBDSBlobStream.Create(Field, fs, Mode);
3296     end;
3297    
3298     function TIBCustomDataSet.GetArray(Field: TIBArrayField): IArray;
3299     var Buff: PChar;
3300     pda: PArrayDataArray;
3301     bTr, bDB: Boolean;
3302     begin
3303     if (Field = nil) or (Field.DataSet <> self) then
3304     IBError(ibxFieldNotinDataSet,[Field.Name,Name]);
3305     Buff := GetActiveBuf;
3306     if Buff = nil then
3307     Result := Database.Attachment.CreateArray(Transaction.TransactionIntf,
3308     Field.FRelationName,Field.FieldName)
3309     else
3310     begin
3311     pda := PArrayDataArray(Buff + FArrayCacheOffset);
3312     if pda^[Field.FCacheOffset] = nil then
3313     begin
3314     AdjustRecordOnInsert(Buff);
3315     if Field.IsNull then
3316     Result := Database.Attachment.CreateArray(Transaction.TransactionIntf,
3317     Field.FRelationName,Field.FieldName)
3318     else
3319     Result := Database.Attachment.OpenArray(Transaction.TransactionIntf,
3320     Field.FRelationName,Field.FieldName,Field.ArrayID);
3321     pda^[Field.FCacheOffset] := TIBArray.Create(Field,Result);
3322     FArrayList.Add(pda^[Field.FCacheOffset]);
3323     if (CachedUpdates) then
3324     begin
3325     bTr := not Transaction.InTransaction;
3326     bDB := not Database.Connected;
3327     if bDB then
3328     Database.Open;
3329     if bTr then
3330     Transaction.StartTransaction;
3331     pda^[Field.FCacheOffset].ArrayIntf.PreLoad;
3332     if bTr then
3333     Transaction.Commit;
3334     if bDB then
3335     Database.Close;
3336     end;
3337     WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Pointer(Buff));
3338     end
3339     else
3340     Result := pda^[Field.FCacheOffset].ArrayIntf;
3341     end;
3342     end;
3343    
3344     procedure TIBCustomDataSet.SetArrayIntf(AnArray: IArray; Field: TIBArrayField);
3345     var Buff: PChar;
3346     pda: PArrayDataArray;
3347     begin
3348     if (Field = nil) or (Field.DataSet <> self) then
3349     IBError(ibxFieldNotinDataSet,[Field.Name,Name]);
3350     Buff := GetActiveBuf;
3351     if Buff <> nil then
3352     begin
3353     AdjustRecordOnInsert(Buff);
3354     pda := PArrayDataArray(Buff + FArrayCacheOffset);
3355     pda^[Field.FCacheOffset].FArray := AnArray;
3356     WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Pointer(Buff));
3357     end;
3358     end;
3359    
3360     function TIBCustomDataSet.CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Integer;
3361     const
3362     CMPLess = -1;
3363     CMPEql = 0;
3364     CMPGtr = 1;
3365     RetCodes: array[Boolean, Boolean] of ShortInt = ((2, CMPLess),
3366     (CMPGtr, CMPEql));
3367     begin
3368     result := RetCodes[Bookmark1 = nil, Bookmark2 = nil];
3369    
3370     if Result = 2 then
3371     begin
3372     if PInteger(Bookmark1)^ < PInteger(Bookmark2)^ then
3373     Result := CMPLess
3374     else
3375     if PInteger(Bookmark1)^ > PInteger(Bookmark2)^ then
3376     Result := CMPGtr
3377     else
3378     Result := CMPEql;
3379     end;
3380     end;
3381    
3382     procedure TIBCustomDataSet.DoBeforeDelete;
3383     var
3384     Buff: PRecordData;
3385     begin
3386     if not CanDelete then
3387     IBError(ibxeCannotDelete, [nil]);
3388     Buff := PRecordData(GetActiveBuf);
3389     if FCachedUpdates and
3390     (Buff^.rdCachedUpdateStatus in [cusUnmodified]) then
3391     SaveOldBuffer(PChar(Buff));
3392     inherited DoBeforeDelete;
3393     end;
3394    
3395     procedure TIBCustomDataSet.DoAfterDelete;
3396     begin
3397     inherited DoAfterDelete;
3398     FBase.DoAfterDelete(self);
3399     InternalAutoCommit;
3400     end;
3401    
3402     procedure TIBCustomDataSet.DoBeforeEdit;
3403     var
3404     Buff: PRecordData;
3405     begin
3406     Buff := PRecordData(GetActiveBuf);
3407     if not(CanEdit or (FQModify.SQL.Count <> 0) or
3408     (FCachedUpdates and Assigned(FOnUpdateRecord))) then
3409     IBError(ibxeCannotUpdate, [nil]);
3410     if FCachedUpdates and (Buff^.rdCachedUpdateStatus in [cusUnmodified, cusInserted]) then
3411     SaveOldBuffer(PChar(Buff));
3412     CopyRecordBuffer(GetActiveBuf, FOldBuffer);
3413     inherited DoBeforeEdit;
3414     end;
3415    
3416     procedure TIBCustomDataSet.DoAfterEdit;
3417     begin
3418     inherited DoAfterEdit;
3419     FBase.DoAfterEdit(self);
3420     end;
3421    
3422     procedure TIBCustomDataSet.DoBeforeInsert;
3423     begin
3424     if not CanInsert then
3425     IBError(ibxeCannotInsert, [nil]);
3426     inherited DoBeforeInsert;
3427     end;
3428    
3429     procedure TIBCustomDataSet.DoAfterInsert;
3430     begin
3431     if GeneratorField.ApplyOnEvent = gaeOnNewRecord then
3432     GeneratorField.Apply;
3433     inherited DoAfterInsert;
3434     FBase.DoAfterInsert(self);
3435     end;
3436    
3437     procedure TIBCustomDataSet.DoBeforeClose;
3438     begin
3439     inherited DoBeforeClose;
3440     if FInTransactionEnd and (FCloseAction = TARollback) then
3441     Exit;
3442     if State in [dsInsert,dsEdit] then
3443     begin
3444     if DataSetCloseAction = dcSaveChanges then
3445     Post;
3446     {Note this can fail with an exception e.g. due to
3447     database validation error. In which case the dataset remains open }
3448     end;
3449     if FCachedUpdates and FUpdatesPending and (DataSetCloseAction = dcSaveChanges) then
3450     ApplyUpdates;
3451     end;
3452    
3453     procedure TIBCustomDataSet.DoBeforeOpen;
3454     var i: integer;
3455     begin
3456     if assigned(FParser) then
3457     FParser.Reset;
3458     for i := 0 to FIBLinks.Count - 1 do
3459     TIBControlLink(FIBLinks[i]).UpdateSQL(self);
3460     inherited DoBeforeOpen;
3461     for i := 0 to FIBLinks.Count - 1 do
3462     TIBControlLink(FIBLinks[i]).UpdateParams(self);
3463     end;
3464    
3465     procedure TIBCustomDataSet.DoBeforePost;
3466     begin
3467     inherited DoBeforePost;
3468     if (State = dsInsert) and
3469     (GeneratorField.ApplyOnEvent = gaeOnPostRecord) then
3470     GeneratorField.Apply
3471     end;
3472    
3473     procedure TIBCustomDataSet.DoAfterPost;
3474     begin
3475     inherited DoAfterPost;
3476     FBase.DoAfterPost(self);
3477     InternalAutoCommit;
3478     end;
3479    
3480     procedure TIBCustomDataSet.FetchAll;
3481     var
3482     CurBookmark: TBookmark;
3483     begin
3484     FBase.SetCursor;
3485     try
3486     if FQSelect.EOF or not FQSelect.Open then
3487     exit;
3488     DisableControls;
3489     try
3490     CurBookmark := Bookmark;
3491     Last;
3492     Bookmark := CurBookmark;
3493     finally
3494     EnableControls;
3495     end;
3496     finally
3497     FBase.RestoreCursor;
3498     end;
3499     end;
3500    
3501     procedure TIBCustomDataSet.FreeRecordBuffer(var Buffer: PChar);
3502     begin
3503     FreeMem(Buffer);
3504     Buffer := nil;
3505     end;
3506    
3507     procedure TIBCustomDataSet.GetBookmarkData(Buffer: PChar; Data: Pointer);
3508     begin
3509     Move(PRecordData(Buffer)^.rdRecordNumber, Data^, BookmarkSize);
3510     end;
3511    
3512     function TIBCustomDataSet.GetBookmarkFlag(Buffer: PChar): TBookmarkFlag;
3513     begin
3514     result := PRecordData(Buffer)^.rdBookmarkFlag;
3515     end;
3516    
3517     function TIBCustomDataSet.GetCanModify: Boolean;
3518     begin
3519     result := (FQInsert.SQL.Text <> '') or
3520     (FQModify.SQL.Text <> '') or
3521     (FQDelete.SQL.Text <> '') or
3522     (Assigned(FUpdateObject));
3523     end;
3524    
3525     function TIBCustomDataSet.GetCurrentRecord(Buffer: PChar): Boolean;
3526     begin
3527     if not IsEmpty and (GetBookmarkFlag(ActiveBuffer) = bfCurrent) then
3528     begin
3529     UpdateCursorPos;
3530     ReadRecordCache(PRecordData(ActiveBuffer)^.rdRecordNumber, Buffer, False);
3531     result := True;
3532     end
3533     else
3534     result := False;
3535     end;
3536    
3537     function TIBCustomDataSet.GetDataSource: TDataSource;
3538     begin
3539     if FDataLink = nil then
3540     result := nil
3541     else
3542     result := FDataLink.DataSource;
3543     end;
3544    
3545     function TIBCustomDataSet.GetDBAliasName(FieldNo: integer): string;
3546     begin
3547     Result := FAliasNameMap[FieldNo-1]
3548     end;
3549    
3550     function TIBCustomDataSet.GetFieldDefFromAlias(aliasName: string): TFieldDef;
3551     var
3552     i: integer;
3553     begin
3554     Result := nil;
3555     for i := 0 to Length(FAliasNameMap) - 1 do
3556     if FAliasNameMap[i] = aliasName then
3557     begin
3558     Result := FieldDefs[i];
3559     Exit
3560     end;
3561     end;
3562    
3563     function TIBCustomDataSet.GetFieldClass(FieldType: TFieldType): TFieldClass;
3564     begin
3565     Result := DefaultFieldClasses[FieldType];
3566     end;
3567    
3568     function TIBCustomDataSet.GetFieldData(FieldNo: Integer; Buffer: Pointer): Boolean;
3569     begin
3570     result := GetFieldData(FieldByNumber(FieldNo), buffer);
3571     end;
3572    
3573     function TIBCustomDataSet.InternalGetFieldData(Field: TField; Buffer: Pointer): Boolean;
3574     var
3575     Buff, Data: PChar;
3576     CurrentRecord: PRecordData;
3577     begin
3578     result := False;
3579     Buff := GetActiveBuf;
3580     if (Buff = nil) or
3581     (not IsVisible(Buff)) or not assigned(Field.DataSet) then
3582     exit;
3583     { The intention here is to stuff the buffer with the data for the
3584     referenced field for the current record }
3585     CurrentRecord := PRecordData(Buff);
3586     if (Field.FieldNo < 0) then
3587     begin
3588     Inc(Buff, FRecordSize + Field.Offset);
3589     result := Boolean(Buff[0]);
3590     if result and (Buffer <> nil) then
3591     Move(Buff[1], Buffer^, Field.DataSize);
3592     end
3593     else
3594     if (FMappedFieldPosition[Field.FieldNo - 1] > 0) and
3595     (FMappedFieldPosition[Field.FieldNo - 1] <= CurrentRecord^.rdFieldCount) then
3596     with CurrentRecord^.rdFields[FMappedFieldPosition[Field.FieldNo - 1]],
3597     FFieldColumns^[FMappedFieldPosition[Field.FieldNo - 1]] do
3598     begin
3599     result := not fdIsNull;
3600     if result and (Buffer <> nil) then
3601     begin
3602     Data := Buff + fdDataOfs;
3603     if (fdDataType = SQL_VARYING) or (fdDataType = SQL_TEXT) then
3604     begin
3605     if fdDataLength < Field.DataSize then
3606     begin
3607     Move(Data^, Buffer^, fdDataLength);
3608     PChar(Buffer)[fdDataLength] := #0;
3609     end
3610     else
3611     IBError(ibxeFieldSizeError,[Field.FieldName])
3612     end
3613     else
3614     Move(Data^, Buffer^, Field.DataSize);
3615     end;
3616     end;
3617     end;
3618    
3619     { GetRecNo and SetRecNo both operate off of 1-based indexes as
3620     opposed to 0-based indexes.
3621     This is because we want LastRecordNumber/RecordCount = 1 }
3622    
3623     function TIBCustomDataSet.GetRecNo: Integer;
3624     begin
3625     if GetActiveBuf = nil then
3626     result := 0
3627     else
3628     result := PRecordData(GetActiveBuf)^.rdRecordNumber + 1;
3629     end;
3630    
3631     function TIBCustomDataSet.GetRecord(Buffer: PChar; GetMode: TGetMode;
3632     DoCheck: Boolean): TGetResult;
3633     var
3634     Accept: Boolean;
3635     SaveState: TDataSetState;
3636     begin
3637     Result := grOK;
3638     if Filtered and Assigned(OnFilterRecord) then
3639     begin
3640     Accept := False;
3641     SaveState := SetTempState(dsFilter);
3642     while not Accept do
3643     begin
3644     Result := InternalGetRecord(Buffer, GetMode, DoCheck);
3645     if Result <> grOK then
3646     break;
3647     FFilterBuffer := Buffer;
3648     try
3649     Accept := True;
3650     OnFilterRecord(Self, Accept);
3651     if not Accept and (GetMode = gmCurrent) then
3652     GetMode := gmPrior;
3653     except
3654     // FBase.HandleException(Self);
3655     end;
3656     end;
3657     RestoreState(SaveState);
3658     end
3659     else
3660     Result := InternalGetRecord(Buffer, GetMode, DoCheck);
3661     end;
3662    
3663     function TIBCustomDataSet.InternalGetRecord(Buffer: PChar; GetMode: TGetMode;
3664     DoCheck: Boolean): TGetResult;
3665     begin
3666     result := grError;
3667     case GetMode of
3668     gmCurrent: begin
3669     if (FCurrentRecord >= 0) then begin
3670     if FCurrentRecord < FRecordCount then
3671     ReadRecordCache(FCurrentRecord, Buffer, False)
3672     else begin
3673     while (not FQSelect.EOF) and FQSelect.Next and
3674     (FCurrentRecord >= FRecordCount) do begin
3675     FetchCurrentRecordToBuffer(FQSelect, FRecordCount, Buffer);
3676     Inc(FRecordCount);
3677     end;
3678     FCurrentRecord := FRecordCount - 1;
3679     if (FCurrentRecord >= 0) then
3680     ReadRecordCache(FCurrentRecord, Buffer, False);
3681     end;
3682     result := grOk;
3683     end else
3684     result := grBOF;
3685     end;
3686     gmNext: begin
3687     result := grOk;
3688     if FCurrentRecord = FRecordCount then
3689     result := grEOF
3690     else if FCurrentRecord = FRecordCount - 1 then begin
3691     if (not FQSelect.EOF) then begin
3692     FQSelect.Next;
3693     Inc(FCurrentRecord);
3694     end;
3695     if (FQSelect.EOF) then begin
3696     result := grEOF;
3697     end else begin
3698     Inc(FRecordCount);
3699     FetchCurrentRecordToBuffer(FQSelect, FCurrentRecord, Buffer);
3700     end;
3701     end else if (FCurrentRecord < FRecordCount) then begin
3702     Inc(FCurrentRecord);
3703     ReadRecordCache(FCurrentRecord, Buffer, False);
3704     end;
3705     end;
3706     else { gmPrior }
3707     begin
3708     if (FCurrentRecord = 0) then begin
3709     Dec(FCurrentRecord);
3710     result := grBOF;
3711     end else if (FCurrentRecord > 0) and
3712     (FCurrentRecord <= FRecordCount) then begin
3713     Dec(FCurrentRecord);
3714     ReadRecordCache(FCurrentRecord, Buffer, False);
3715     result := grOk;
3716     end else if (FCurrentRecord = -1) then
3717     result := grBOF;
3718     end;
3719     end;
3720     if result = grOk then
3721     result := AdjustCurrentRecord(Buffer, GetMode);
3722     if result = grOk then with PRecordData(Buffer)^ do begin
3723     rdBookmarkFlag := bfCurrent;
3724     GetCalcFields(Buffer);
3725     end else if (result = grEOF) then begin
3726     CopyRecordBuffer(FModelBuffer, Buffer);
3727     PRecordData(Buffer)^.rdBookmarkFlag := bfEOF;
3728     end else if (result = grBOF) then begin
3729     CopyRecordBuffer(FModelBuffer, Buffer);
3730     PRecordData(Buffer)^.rdBookmarkFlag := bfBOF;
3731     end else if (result = grError) then begin
3732     CopyRecordBuffer(FModelBuffer, Buffer);
3733     PRecordData(Buffer)^.rdBookmarkFlag := bfEOF;
3734     end;;
3735     end;
3736    
3737     function TIBCustomDataSet.GetRecordCount: Integer;
3738     begin
3739     result := FRecordCount - FDeletedRecords;
3740     end;
3741    
3742     function TIBCustomDataSet.GetRecordSize: Word;
3743     begin
3744     result := FRecordBufferSize;
3745     end;
3746    
3747     procedure TIBCustomDataSet.InternalAutoCommit;
3748     begin
3749     with Transaction do
3750     if InTransaction and (FAutoCommit = acCommitRetaining) then
3751     begin
3752     if CachedUpdates then ApplyUpdates;
3753     CommitRetaining;
3754     end;
3755     end;
3756    
3757     procedure TIBCustomDataSet.InternalAddRecord(Buffer: Pointer; Append: Boolean);
3758     begin
3759     CheckEditState;
3760     begin
3761     { When adding records, we *always* append.
3762     Insertion is just too costly }
3763     AdjustRecordOnInsert(Buffer);
3764     with PRecordData(Buffer)^ do
3765     begin
3766     rdUpdateStatus := usInserted;
3767     rdCachedUpdateStatus := cusInserted;
3768     end;
3769     if not CachedUpdates then
3770     InternalPostRecord(FQInsert, Buffer)
3771     else begin
3772     WriteRecordCache(FCurrentRecord, Buffer);
3773     FUpdatesPending := True;
3774     end;
3775     Inc(FRecordCount);
3776     InternalSetToRecord(Buffer);
3777     end
3778     end;
3779    
3780     procedure TIBCustomDataSet.InternalCancel;
3781     var
3782     Buff: PChar;
3783     CurRec: Integer;
3784     pda: PArrayDataArray;
3785     i: integer;
3786     begin
3787     inherited InternalCancel;
3788     Buff := GetActiveBuf;
3789     if Buff <> nil then
3790     begin
3791     pda := PArrayDataArray(Buff + FArrayCacheOffset);
3792     for i := 0 to ArrayFieldCount - 1 do
3793     pda^[i].ArrayIntf.CancelChanges;
3794     CurRec := FCurrentRecord;
3795     AdjustRecordOnInsert(Buff);
3796     if (State = dsEdit) then begin
3797     CopyRecordBuffer(FOldBuffer, Buff);
3798     WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Buff);
3799     end else begin
3800     CopyRecordBuffer(FModelBuffer, Buff);
3801     PRecordData(Buff)^.rdUpdateStatus := usDeleted;
3802     PRecordData(Buff)^.rdCachedUpdateStatus := cusUnmodified;
3803     PRecordData(Buff)^.rdBookmarkFlag := bfEOF;
3804     FCurrentRecord := CurRec;
3805     end;
3806     end;
3807     end;
3808    
3809    
3810     procedure TIBCustomDataSet.InternalClose;
3811     begin
3812     if FDidActivate then
3813     DeactivateTransaction;
3814     FQSelect.Close;
3815     ClearBlobCache;
3816     ClearArrayCache;
3817     FreeRecordBuffer(FModelBuffer);
3818     FreeRecordBuffer(FOldBuffer);
3819     FCurrentRecord := -1;
3820     FOpen := False;
3821     FRecordCount := 0;
3822     FDeletedRecords := 0;
3823     FRecordSize := 0;
3824     FBPos := 0;
3825     FOBPos := 0;
3826     FCacheSize := 0;
3827     FOldCacheSize := 0;
3828     FBEnd := 0;
3829     FOBEnd := 0;
3830     FreeMem(FBufferCache);
3831     FBufferCache := nil;
3832     FreeMem(FFieldColumns);
3833     FFieldColumns := nil;
3834     FreeMem(FOldBufferCache);
3835     FOldBufferCache := nil;
3836     BindFields(False);
3837     ResetParser;
3838     if DefaultFields then DestroyFields;
3839     end;
3840    
3841     procedure TIBCustomDataSet.InternalDelete;
3842     var
3843     Buff: PChar;
3844     begin
3845     FBase.SetCursor;
3846     try
3847     Buff := GetActiveBuf;
3848     if CanDelete then
3849     begin
3850     if not CachedUpdates then
3851     InternalDeleteRecord(FQDelete, Buff)
3852     else
3853     begin
3854     with PRecordData(Buff)^ do
3855     begin
3856     if rdCachedUpdateStatus = cusInserted then
3857     rdCachedUpdateStatus := cusUninserted
3858     else begin
3859     rdUpdateStatus := usDeleted;
3860     rdCachedUpdateStatus := cusDeleted;
3861     end;
3862     end;
3863     WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Buff);
3864     end;
3865     Inc(FDeletedRecords);
3866     FUpdatesPending := True;
3867     end else
3868     IBError(ibxeCannotDelete, [nil]);
3869     finally
3870     FBase.RestoreCursor;
3871     end;
3872     end;
3873    
3874     procedure TIBCustomDataSet.InternalFirst;
3875     begin
3876     FCurrentRecord := -1;
3877     end;
3878    
3879     procedure TIBCustomDataSet.InternalGotoBookmark(Bookmark: Pointer);
3880     begin
3881     FCurrentRecord := PInteger(Bookmark)^;
3882     end;
3883    
3884     procedure TIBCustomDataSet.InternalHandleException;
3885     begin
3886     FBase.HandleException(Self)
3887     end;
3888    
3889     procedure TIBCustomDataSet.InternalInitFieldDefs;
3890     begin
3891     if not InternalPrepared then
3892     begin
3893     InternalPrepare;
3894     exit;
3895     end;
3896     FieldDefsFromQuery(FQSelect);
3897     end;
3898    
3899     procedure TIBCustomDataSet.FieldDefsFromQuery(SourceQuery: TIBSQL);
3900     const
3901     DefaultSQL = 'Select F.RDB$COMPUTED_BLR, ' + {do not localize}
3902     'F.RDB$DEFAULT_VALUE, R.RDB$FIELD_NAME ' + {do not localize}
3903     'from RDB$RELATION_FIELDS R, RDB$FIELDS F ' + {do not localize}
3904     'where R.RDB$RELATION_NAME = :RELATION ' + {do not localize}
3905     'and R.RDB$FIELD_SOURCE = F.RDB$FIELD_NAME '+ {do not localize}
3906     'and ((not F.RDB$COMPUTED_BLR is NULL) or ' + {do not localize}
3907     ' (not F.RDB$DEFAULT_VALUE is NULL)) '; {do not localize}
3908    
3909     DefaultSQLODS12 = 'Select F.RDB$COMPUTED_BLR, ' + {do not localize}
3910     'F.RDB$DEFAULT_VALUE, R.RDB$FIELD_NAME, R.RDB$IDENTITY_TYPE ' + {do not localize}
3911     'from RDB$RELATION_FIELDS R, RDB$FIELDS F ' + {do not localize}
3912     'where R.RDB$RELATION_NAME = :RELATION ' + {do not localize}
3913     'and R.RDB$FIELD_SOURCE = F.RDB$FIELD_NAME '+ {do not localize}
3914     'and ((not F.RDB$COMPUTED_BLR is NULL) or ' + {do not localize}
3915     ' (not F.RDB$DEFAULT_VALUE is NULL) or ' + {do not localize}
3916     ' ( not R.RDB$IDENTITY_TYPE is NULL))' ; {do not localize}
3917    
3918     var
3919     FieldType: TFieldType;
3920     FieldSize: Word;
3921     FieldDataSize: integer;
3922     CharSetSize: integer;
3923     CharSetName: RawByteString;
3924     FieldCodePage: TSystemCodePage;
3925     FieldNullable : Boolean;
3926     i, FieldPosition, FieldPrecision: Integer;
3927     FieldAliasName, DBAliasName: string;
3928     aRelationName, FieldName: string;
3929     Query : TIBSQL;
3930     FieldIndex: Integer;
3931     FRelationNodes : TRelationNode;
3932     aArrayDimensions: integer;
3933     aArrayBounds: TArrayBounds;
3934     ArrayMetaData: IArrayMetaData;
3935    
3936     function Add_Node(Relation, Field : String) : TRelationNode;
3937     var
3938     FField : TFieldNode;
3939     begin
3940     if FRelationNodes.RelationName = '' then
3941     Result := FRelationNodes
3942     else
3943     begin
3944     Result := TRelationNode.Create;
3945     Result.NextRelation := FRelationNodes;
3946     end;
3947     Result.RelationName := Relation;
3948     FRelationNodes := Result;
3949     Query.Params[0].AsString := Relation;
3950     Query.ExecQuery;
3951     while not Query.Eof do
3952     begin
3953     FField := TFieldNode.Create;
3954     FField.FieldName := Query.Fields[2].AsString;
3955     FField.DEFAULT_VALUE := not Query.Fields[1].IsNull;
3956     FField.COMPUTED_BLR := not Query.Fields[0].IsNull;
3957     FField.IDENTITY_COLUMN := (Query.FieldCount > 3) and not Query.Fields[3].IsNull;
3958     FField.NextField := Result.FieldNodes;
3959     Result.FieldNodes := FField;
3960     Query.Next;
3961     end;
3962     Query.Close;
3963     end;
3964    
3965     function Has_COMPUTED_BLR(Relation, Field : String) : Boolean;
3966     var
3967     FRelation : TRelationNode;
3968     FField : TFieldNode;
3969     begin
3970     FRelation := FRelationNodes;
3971     while Assigned(FRelation) and
3972     (FRelation.RelationName <> Relation) do
3973     FRelation := FRelation.NextRelation;
3974     if not Assigned(FRelation) then
3975     FRelation := Add_Node(Relation, Field);
3976     Result := false;
3977     FField := FRelation.FieldNodes;
3978     while Assigned(FField) do
3979     if FField.FieldName = Field then
3980     begin
3981     Result := Ffield.COMPUTED_BLR;
3982     Exit;
3983     end
3984     else
3985     FField := Ffield.NextField;
3986     end;
3987    
3988     function Has_DEFAULT_VALUE(Relation, Field : String) : Boolean;
3989     var
3990     FRelation : TRelationNode;
3991     FField : TFieldNode;
3992     begin
3993     FRelation := FRelationNodes;
3994     while Assigned(FRelation) and
3995     (FRelation.RelationName <> Relation) do
3996     FRelation := FRelation.NextRelation;
3997     if not Assigned(FRelation) then
3998     FRelation := Add_Node(Relation, Field);
3999     Result := false;
4000     FField := FRelation.FieldNodes;
4001     while Assigned(FField) do
4002     if FField.FieldName = Field then
4003     begin
4004     Result := Ffield.DEFAULT_VALUE;
4005     Exit;
4006     end
4007     else
4008     FField := Ffield.NextField;
4009     end;
4010    
4011     function Is_IDENTITY_COLUMN(Relation, Field : String) : Boolean;
4012     var
4013     FRelation : TRelationNode;
4014     FField : TFieldNode;
4015     begin
4016     FRelation := FRelationNodes;
4017     while Assigned(FRelation) and
4018     (FRelation.RelationName <> Relation) do
4019     FRelation := FRelation.NextRelation;
4020     if not Assigned(FRelation) then
4021     FRelation := Add_Node(Relation, Field);
4022     Result := false;
4023     FField := FRelation.FieldNodes;
4024     while Assigned(FField) do
4025     if FField.FieldName = Field then
4026     begin
4027     Result := Ffield.IDENTITY_COLUMN;
4028     Exit;
4029     end
4030     else
4031     FField := Ffield.NextField;
4032     end;
4033    
4034     Procedure FreeNodes;
4035     var
4036     FRelation : TRelationNode;
4037     FField : TFieldNode;
4038     begin
4039     while Assigned(FRelationNodes) do
4040     begin
4041     While Assigned(FRelationNodes.FieldNodes) do
4042     begin
4043     FField := FRelationNodes.FieldNodes.NextField;
4044     FRelationNodes.FieldNodes.Free;
4045     FRelationNodes.FieldNodes := FField;
4046     end;
4047     FRelation := FRelationNodes.NextRelation;
4048     FRelationNodes.Free;
4049     FRelationNodes := FRelation;
4050     end;
4051     end;
4052    
4053     begin
4054     FRelationNodes := TRelationNode.Create;
4055     FNeedsRefresh := False;
4056     if not Database.InternalTransaction.InTransaction then
4057     Database.InternalTransaction.StartTransaction;
4058     Query := TIBSQL.Create(self);
4059     try
4060     Query.Database := DataBase;
4061     Query.Transaction := Database.InternalTransaction;
4062     FieldDefs.BeginUpdate;
4063     FieldDefs.Clear;
4064     FieldIndex := 0;
4065     if (Length(FMappedFieldPosition) < SourceQuery.MetaData.Count) then
4066     SetLength(FMappedFieldPosition, SourceQuery.MetaData.Count);
4067     if FDatabaseInfo.ODSMajorVersion >= 12 then
4068     Query.SQL.Text := DefaultSQLODS12
4069     else
4070     Query.SQL.Text := DefaultSQL;
4071     Query.Prepare;
4072     SetLength(FAliasNameMap, SourceQuery.MetaData.Count);
4073     SetLength(FAliasNameList, SourceQuery.MetaData.Count);
4074     for i := 0 to SourceQuery.MetaData.GetCount - 1 do
4075     with SourceQuery.MetaData[i] do
4076     begin
4077     { Get the field name }
4078     FieldAliasName := GetName;
4079     DBAliasName := GetAliasname;
4080     aRelationName := getRelationName;
4081     FieldName := getSQLName;
4082     FAliasNameList[i] := DBAliasName;
4083     FieldSize := 0;
4084     FieldDataSize := GetSize;
4085     FieldPrecision := 0;
4086     FieldNullable := IsNullable;
4087     CharSetSize := 0;
4088     CharSetName := '';
4089     FieldCodePage := CP_NONE;
4090     aArrayDimensions := 0;
4091     SetLength(aArrayBounds,0);
4092     case SQLType of
4093     { All VARCHAR's must be converted to strings before recording
4094     their values }
4095     SQL_VARYING, SQL_TEXT:
4096     begin
4097     if not Database.Attachment.CharSetWidth(getCharSetID,CharSetSize) then
4098     CharSetSize := 1;
4099     CharSetName := Database.Attachment.GetCharsetName(getCharSetID);
4100     Database.Attachment.CharSetID2CodePage(getCharSetID,FieldCodePage);
4101     FieldSize := FieldDataSize div CharSetSize;
4102     FieldType := ftString;
4103     end;
4104     { All Doubles/Floats should be cast to doubles }
4105     SQL_DOUBLE, SQL_FLOAT:
4106     FieldType := ftFloat;
4107     SQL_SHORT:
4108     begin
4109     if (getScale = 0) then
4110     FieldType := ftSmallInt
4111     else begin
4112     FieldType := ftBCD;
4113     FieldPrecision := 4;
4114     FieldSize := -getScale;
4115     end;
4116     end;
4117     SQL_LONG:
4118     begin
4119     if (getScale = 0) then
4120     FieldType := ftInteger
4121     else if (getScale >= (-4)) then
4122     begin
4123     FieldType := ftBCD;
4124     FieldPrecision := 9;
4125     FieldSize := -getScale;
4126     end
4127     else
4128     if Database.SQLDialect = 1 then
4129     FieldType := ftFloat
4130     else
4131     if (FieldCount > i) and (Fields[i] is TFloatField) then
4132     FieldType := ftFloat
4133     else
4134     begin
4135     FieldType := ftFMTBCD;
4136     FieldPrecision := 9;
4137     FieldSize := -getScale;
4138     end;
4139     end;
4140    
4141     SQL_INT64:
4142     begin
4143     if (getScale = 0) then
4144     FieldType := ftLargeInt
4145     else if (getScale >= (-4)) then
4146     begin
4147     FieldType := ftBCD;
4148     FieldPrecision := 18;
4149     FieldSize := -getScale;
4150     end
4151     else
4152     FieldType := ftFloat;
4153     end;
4154     SQL_TIMESTAMP: FieldType := ftDateTime;
4155     SQL_TYPE_TIME: FieldType := ftTime;
4156     SQL_TYPE_DATE: FieldType := ftDate;
4157     SQL_BLOB:
4158     begin
4159     FieldSize := sizeof (TISC_QUAD);
4160     if (getSubtype = 1) then
4161     begin
4162     if not Database.Attachment.CharSetWidth(getCharSetID,CharSetSize) then
4163     CharSetSize := 1;
4164     CharSetName := Database.Attachment.GetCharsetName(getCharSetID);
4165     Database.Attachment.CharSetID2CodePage(getCharSetID,FieldCodePage);
4166     FieldType := ftMemo;
4167     end
4168     else
4169     FieldType := ftBlob;
4170     end;
4171     SQL_ARRAY:
4172     begin
4173     FieldSize := sizeof (TISC_QUAD);
4174     FieldType := ftArray;
4175     ArrayMetaData := GetArrayMetaData;
4176     if ArrayMetaData <> nil then
4177     begin
4178     aArrayDimensions := ArrayMetaData.GetDimensions;
4179     aArrayBounds := ArrayMetaData.GetBounds;
4180     end;
4181     end;
4182     SQL_BOOLEAN:
4183     FieldType:= ftBoolean;
4184     else
4185     FieldType := ftUnknown;
4186     end;
4187     FieldPosition := i + 1;
4188     if (FieldType <> ftUnknown) and (FieldAliasName <> 'IBX_INTERNAL_DBKEY') then {do not localize}
4189     begin
4190     FMappedFieldPosition[FieldIndex] := FieldPosition;
4191     Inc(FieldIndex);
4192     with TIBFieldDef.Create(FieldDefs,'',FieldType,0,False,FieldDefs.Count+1) do
4193     begin
4194     Name := FieldAliasName;
4195     FAliasNameMap[FieldNo-1] := DBAliasName;
4196     Size := FieldSize;
4197     DataSize := FieldDataSize;
4198     Precision := FieldPrecision;
4199     Required := not FieldNullable;
4200     RelationName := aRelationName;
4201     InternalCalcField := False;
4202     CharacterSetSize := CharSetSize;
4203     CharacterSetName := CharSetName;
4204     CodePage := FieldCodePage;
4205     ArrayDimensions := aArrayDimensions;
4206     ArrayBounds := aArrayBounds;
4207     if (FieldName <> '') and (RelationName <> '') then
4208     begin
4209     IdentityColumn := Is_IDENTITY_COLUMN(RelationName, FieldName);
4210     if Has_COMPUTED_BLR(RelationName, FieldName) then
4211     begin
4212     Attributes := [faReadOnly];
4213     InternalCalcField := True;
4214     FNeedsRefresh := True;
4215     end
4216     else
4217     begin
4218     if Has_DEFAULT_VALUE(RelationName, FieldName) then
4219     begin
4220     if not FieldNullable then
4221     Attributes := [faRequired];
4222     end
4223     else
4224     FNeedsRefresh := True;
4225     end;
4226     end;
4227     end;
4228     end;
4229     end;
4230     finally
4231     Query.free;
4232     FreeNodes;
4233     Database.InternalTransaction.Commit;
4234     FieldDefs.EndUpdate;
4235     FieldDefs.Updated := true;
4236     end;
4237     end;
4238    
4239     procedure TIBCustomDataSet.InternalInitRecord(Buffer: PChar);
4240     begin
4241     CopyRecordBuffer(FModelBuffer, Buffer);
4242     end;
4243    
4244     procedure TIBCustomDataSet.InternalLast;
4245     var
4246     Buffer: PChar;
4247     begin
4248     if (FQSelect.EOF) then
4249     FCurrentRecord := FRecordCount
4250     else begin
4251     Buffer := AllocRecordBuffer;
4252     try
4253     while FQSelect.Next do
4254     begin
4255     FetchCurrentRecordToBuffer(FQSelect, FRecordCount, Buffer);
4256     Inc(FRecordCount);
4257     end;
4258     FCurrentRecord := FRecordCount;
4259     finally
4260     FreeRecordBuffer(Buffer);
4261     end;
4262     end;
4263     end;
4264    
4265     procedure TIBCustomDataSet.InternalSetParamsFromCursor;
4266     var
4267     i: Integer;
4268     cur_param: ISQLParam;
4269     cur_field: TField;
4270     s: TStream;
4271     begin
4272     if FQSelect.SQL.Text = '' then
4273     IBError(ibxeEmptyQuery, [nil]);
4274     if not FInternalPrepared then
4275     InternalPrepare;
4276     if (SQLParams.GetCount > 0) and (DataSource <> nil) and (DataSource.DataSet <> nil) then
4277     begin
4278     for i := 0 to SQLParams.GetCount - 1 do
4279     begin
4280     cur_field := DataSource.DataSet.FindField(SQLParams[i].Name);
4281     if (cur_field <> nil) then
4282     begin
4283     cur_param := SQLParams[i];
4284     if (cur_field.IsNull) then
4285     cur_param.IsNull := True
4286     else
4287     case cur_field.DataType of
4288     ftString:
4289     cur_param.AsString := cur_field.AsString;
4290     ftBoolean:
4291     cur_param.AsBoolean := cur_field.AsBoolean;
4292     ftSmallint, ftWord:
4293     cur_param.AsShort := cur_field.AsInteger;
4294     ftInteger:
4295     cur_param.AsLong := cur_field.AsInteger;
4296     ftLargeInt:
4297     cur_param.AsInt64 := cur_field.AsLargeInt;
4298     ftFloat, ftCurrency:
4299     cur_param.AsDouble := cur_field.AsFloat;
4300     ftBCD:
4301     cur_param.AsCurrency := cur_field.AsCurrency;
4302     ftDate:
4303     cur_param.AsDate := cur_field.AsDateTime;
4304     ftTime:
4305     cur_param.AsTime := cur_field.AsDateTime;
4306     ftDateTime:
4307     cur_param.AsDateTime := cur_field.AsDateTime;
4308     ftBlob, ftMemo:
4309     begin
4310     s := nil;
4311     try
4312     s := DataSource.DataSet.
4313     CreateBlobStream(cur_field, bmRead);
4314     cur_param.AsBlob := TIBDSBlobStream(s).FBlobStream.Blob;
4315     finally
4316     s.free;
4317     end;
4318     end;
4319     ftArray:
4320     cur_param.AsArray := TIBArrayField(cur_field).ArrayIntf;
4321     else
4322     IBError(ibxeNotSupported, [nil]);
4323     end;
4324     end;
4325     end;
4326     end;
4327     end;
4328    
4329     procedure TIBCustomDataSet.ReQuery;
4330     begin
4331     FQSelect.Close;
4332     ClearBlobCache;
4333     FCurrentRecord := -1;
4334     FRecordCount := 0;
4335     FDeletedRecords := 0;
4336     FBPos := 0;
4337     FOBPos := 0;
4338     FBEnd := 0;
4339     FOBEnd := 0;
4340     FQSelect.Close;
4341     FQSelect.ExecQuery;
4342     FOpen := FQSelect.Open;
4343     First;
4344     end;
4345    
4346     procedure TIBCustomDataSet.InternalOpen;
4347    
4348     function RecordDataLength(n: Integer): Long;
4349     begin
4350     result := SizeOf(TRecordData) + ((n - 1) * SizeOf(TFieldData));
4351     end;
4352    
4353     begin
4354     FBase.SetCursor;
4355     try
4356     ActivateConnection;
4357     ActivateTransaction;
4358     if FQSelect.SQL.Text = '' then
4359     IBError(ibxeEmptyQuery, [nil]);
4360     if not FInternalPrepared then
4361     InternalPrepare;
4362     if FQSelect.Statement <> nil then
4363     FQSelect.Statement.EnableStatistics(FEnableStatistics);
4364     if FQSelect.SQLStatementType = SQLSelect then
4365     begin
4366     if DefaultFields then
4367     CreateFields;
4368     FArrayFieldCount := 0;
4369     BindFields(True);
4370     FCurrentRecord := -1;
4371     FQSelect.ExecQuery;
4372     FOpen := FQSelect.Open;
4373    
4374     { Initialize offsets, buffer sizes, etc...
4375     1. Initially FRecordSize is just the "RecordDataLength".
4376     2. Allocate a "model" buffer and do a dummy fetch
4377     3. After the dummy fetch, FRecordSize will be appropriately
4378     adjusted to reflect the additional "weight" of the field
4379     data.
4380     4. Set up the FCalcFieldsOffset, FBlobCacheOffset, FArrayCacheOffset and FRecordBufferSize.
4381     5. Now, with the BufferSize available, allocate memory for chunks of records
4382     6. Re-allocate the model buffer, accounting for the new
4383     FRecordBufferSize.
4384     7. Finally, calls to AllocRecordBuffer will work!.
4385     }
4386     {Step 1}
4387     FRecordSize := RecordDataLength(FQSelect.FieldCount);
4388     {Step 2, 3}
4389     GetMem(FFieldColumns,sizeof(TFieldColumns) * (FQSelect.FieldCount));
4390     IBAlloc(FModelBuffer, 0, FRecordSize);
4391     InitModelBuffer(FQSelect, FModelBuffer);
4392     {Step 4}
4393     FCalcFieldsOffset := FRecordSize;
4394     FBlobCacheOffset := FCalcFieldsOffset + CalcFieldsSize;
4395     FArrayCacheOffset := (FBlobCacheOffset + (BlobFieldCount * SizeOf(TIBBlobStream)));
4396     FRecordBufferSize := FArrayCacheOffset + (ArrayFieldCount * sizeof(IArray));
4397     {Step 5}
4398     if UniDirectional then
4399     FBufferChunkSize := FRecordBufferSize * UniCache
4400     else
4401     FBufferChunkSize := FRecordBufferSize * BufferChunks;
4402     IBAlloc(FBufferCache, FBufferChunkSize, FBufferChunkSize);
4403     if FCachedUpdates or (csReading in ComponentState) then
4404     IBAlloc(FOldBufferCache, FBufferChunkSize, FBufferChunkSize);
4405     FBPos := 0;
4406     FOBPos := 0;
4407     FBEnd := 0;
4408     FOBEnd := 0;
4409     FCacheSize := FBufferChunkSize;
4410     FOldCacheSize := FBufferChunkSize;
4411     {Step 6}
4412     IBAlloc(FModelBuffer, RecordDataLength(FQSelect.FieldCount),
4413     FRecordBufferSize);
4414     {Step 7}
4415     FOldBuffer := AllocRecordBuffer;
4416     end
4417     else
4418     FQSelect.ExecQuery;
4419     finally
4420     FBase.RestoreCursor;
4421     end;
4422     end;
4423    
4424     procedure TIBCustomDataSet.InternalPost;
4425     var
4426     Qry: TIBSQL;
4427     Buff: PChar;
4428     bInserting: Boolean;
4429     begin
4430     FBase.SetCursor;
4431     try
4432     Buff := GetActiveBuf;
4433     CheckEditState;
4434     AdjustRecordOnInsert(Buff);
4435     if (State = dsInsert) then
4436     begin
4437     bInserting := True;
4438     Qry := FQInsert;
4439     PRecordData(Buff)^.rdUpdateStatus := usInserted;
4440     PRecordData(Buff)^.rdCachedUpdateStatus := cusInserted;
4441     WriteRecordCache(FRecordCount, Buff);
4442     FCurrentRecord := FRecordCount;
4443     end
4444     else begin
4445     bInserting := False;
4446     Qry := FQModify;
4447     if PRecordData(Buff)^.rdCachedUpdateStatus = cusUnmodified then
4448     begin
4449     PRecordData(Buff)^.rdUpdateStatus := usModified;
4450     PRecordData(Buff)^.rdCachedUpdateStatus := cusModified;
4451     end
4452     else if PRecordData(Buff)^.
4453     rdCachedUpdateStatus = cusUninserted then
4454     begin
4455     PRecordData(Buff)^.rdCachedUpdateStatus := cusInserted;
4456     Dec(FDeletedRecords);
4457     end;
4458     end;
4459     if (not CachedUpdates) then
4460     InternalPostRecord(Qry, Buff)
4461     else begin
4462     WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Buff);
4463     FUpdatesPending := True;
4464     end;
4465     if bInserting then
4466     Inc(FRecordCount);
4467     finally
4468     FBase.RestoreCursor;
4469     end;
4470     end;
4471    
4472     procedure TIBCustomDataSet.InternalRefresh;
4473     begin
4474     inherited InternalRefresh;
4475     InternalRefreshRow;
4476     end;
4477    
4478     procedure TIBCustomDataSet.InternalSetToRecord(Buffer: PChar);
4479     begin
4480     InternalGotoBookmark(@(PRecordData(Buffer)^.rdRecordNumber));
4481     end;
4482    
4483     function TIBCustomDataSet.IsCursorOpen: Boolean;
4484     begin
4485     result := FOpen;
4486     end;
4487    
4488     procedure TIBCustomDataSet.Loaded;
4489     begin
4490     if assigned(FQSelect) then
4491     FBaseSQLSelect.assign(FQSelect.SQL);
4492     inherited Loaded;
4493     end;
4494    
4495     procedure TIBCustomDataSet.Post;
4496     var CancelPost: boolean;
4497     begin
4498     CancelPost := false;
4499     if assigned(FOnValidatePost) then
4500     OnValidatePost(self,CancelPost);
4501     if CancelPost then
4502     Cancel
4503     else
4504     inherited Post;
4505     end;
4506    
4507     function TIBCustomDataSet.Locate(const KeyFields: string; const KeyValues: Variant;
4508     Options: TLocateOptions): Boolean;
4509     var
4510     CurBookmark: TBookmark;
4511     begin
4512     DisableControls;
4513     try
4514     CurBookmark := Bookmark;
4515     First;
4516     result := InternalLocate(KeyFields, KeyValues, Options);
4517     if not result then
4518     Bookmark := CurBookmark;
4519     finally
4520     EnableControls;
4521     end;
4522     end;
4523    
4524     function TIBCustomDataSet.Lookup(const KeyFields: string; const KeyValues: Variant;
4525     const ResultFields: string): Variant;
4526     var
4527     fl: TList;
4528     CurBookmark: TBookmark;
4529     begin
4530     DisableControls;
4531     fl := TList.Create;
4532     CurBookmark := Bookmark;
4533     try
4534     First;
4535     if InternalLocate(KeyFields, KeyValues, []) then
4536     begin
4537     if (ResultFields <> '') then
4538     result := FieldValues[ResultFields]
4539     else
4540     result := NULL;
4541     end
4542     else
4543     result := Null;
4544     finally
4545     Bookmark := CurBookmark;
4546     fl.Free;
4547     EnableControls;
4548     end;
4549     end;
4550    
4551     procedure TIBCustomDataSet.SetBookmarkData(Buffer: PChar; Data: Pointer);
4552     begin
4553     PRecordData(Buffer)^.rdRecordNumber := PInteger(Data)^;
4554     end;
4555    
4556     procedure TIBCustomDataSet.SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag);
4557     begin
4558     PRecordData(Buffer)^.rdBookmarkFlag := Value;
4559     end;
4560    
4561     procedure TIBCustomDataSet.SetCachedUpdates(Value: Boolean);
4562     begin
4563     if not Value and FCachedUpdates then
4564     CancelUpdates;
4565     if (not (csReading in ComponentState)) and Value then
4566     CheckDatasetClosed;
4567     FCachedUpdates := Value;
4568     end;
4569    
4570     procedure TIBCustomDataSet.SetDataSource(Value: TDataSource);
4571     begin
4572     if IsLinkedTo(Value) then
4573     IBError(ibxeCircularReference, [nil]);
4574     if FDataLink <> nil then
4575     FDataLink.DataSource := Value;
4576     end;
4577    
4578     procedure TIBCustomDataSet.InternalSetFieldData(Field: TField; Buffer: Pointer);
4579     var
4580     Buff, TmpBuff: PChar;
4581     MappedFieldPos: integer;
4582     begin
4583     Buff := GetActiveBuf;
4584     if Field.FieldNo < 0 then
4585     begin
4586     TmpBuff := Buff + FRecordSize + Field.Offset;
4587     Boolean(TmpBuff[0]) := LongBool(Buffer);
4588     if Boolean(TmpBuff[0]) then
4589     Move(Buffer^, TmpBuff[1], Field.DataSize);
4590     WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Buff);
4591     end
4592     else begin
4593     CheckEditState;
4594     with PRecordData(Buff)^ do
4595     begin
4596     { If inserting, Adjust record position }
4597     AdjustRecordOnInsert(Buff);
4598     MappedFieldPos := FMappedFieldPosition[Field.FieldNo - 1];
4599     if (MappedFieldPos > 0) and
4600     (MappedFieldPos <= rdFieldCount) then
4601     with rdFields[MappedFieldPos], FFieldColumns^[MappedFieldPos] do
4602     begin
4603     Field.Validate(Buffer);
4604     if (Buffer = nil) or
4605     (Field is TIBStringField) and (PChar(Buffer)[0] = #0) then
4606     fdIsNull := True
4607     else
4608     begin
4609     Move(Buffer^, Buff[fdDataOfs],fdDataSize);
4610     if (fdDataType = SQL_TEXT) or (fdDataType = SQL_VARYING) then
4611     fdDataLength := StrLen(PChar(Buffer));
4612     fdIsNull := False;
4613     if rdUpdateStatus = usUnmodified then
4614     begin
4615     if CachedUpdates then
4616     begin
4617     FUpdatesPending := True;
4618     if State = dsInsert then
4619     rdCachedUpdateStatus := cusInserted
4620     else if State = dsEdit then
4621     rdCachedUpdateStatus := cusModified;
4622     end;
4623    
4624     if State = dsInsert then
4625     rdUpdateStatus := usInserted
4626     else
4627     rdUpdateStatus := usModified;
4628     end;
4629     WriteRecordCache(rdRecordNumber, Buff);
4630     SetModified(True);
4631     end;
4632     end;
4633     end;
4634     end;
4635     if not (State in [dsCalcFields, dsFilter, dsNewValue]) then
4636     DataEvent(deFieldChange, PtrInt(Field));
4637     end;
4638    
4639     procedure TIBCustomDataSet.SetRecNo(Value: Integer);
4640     begin
4641     CheckBrowseMode;
4642     if (Value < 1) then
4643     Value := 1
4644     else if Value > FRecordCount then
4645     begin
4646     InternalLast;
4647     Value := Min(FRecordCount, Value);
4648     end;
4649     if (Value <> RecNo) then
4650     begin
4651     DoBeforeScroll;
4652     FCurrentRecord := Value - 1;
4653     Resync([]);
4654     DoAfterScroll;
4655     end;
4656     end;
4657    
4658     procedure TIBCustomDataSet.Disconnect;
4659     begin
4660     Close;
4661     InternalUnPrepare;
4662     end;
4663    
4664     procedure TIBCustomDataSet.SetUpdateMode(const Value: TUpdateMode);
4665     begin
4666     if not CanModify then
4667     IBError(ibxeCannotUpdate, [nil])
4668     else
4669     FUpdateMode := Value;
4670     end;
4671    
4672    
4673     procedure TIBCustomDataSet.SetUpdateObject(Value: TIBDataSetUpdateObject);
4674     begin
4675     if Value <> FUpdateObject then
4676     begin
4677     if Assigned(FUpdateObject) and (FUpdateObject.DataSet = Self) then
4678     FUpdateObject.DataSet := nil;
4679     FUpdateObject := Value;
4680     if Assigned(FUpdateObject) then
4681     begin
4682     if Assigned(FUpdateObject.DataSet) and
4683     (FUpdateObject.DataSet <> Self) then
4684     FUpdateObject.DataSet.UpdateObject := nil;
4685     FUpdateObject.DataSet := Self;
4686     end;
4687     end;
4688     end;
4689    
4690     function TIBCustomDataSet.ConstraintsStored: Boolean;
4691     begin
4692     Result := Constraints.Count > 0;
4693     end;
4694    
4695     procedure TIBCustomDataSet.ClearCalcFields(Buffer: PChar);
4696     begin
4697     FillChar(Buffer[FRecordSize], CalcFieldsSize, 0);
4698     end;
4699    
4700     procedure TIBCustomDataSet.ClearIBLinks;
4701     var i: integer;
4702     begin
4703     for i := FIBLinks.Count - 1 downto 0 do
4704     TIBControlLink(FIBLinks[i]).IBDataSet := nil;
4705     end;
4706    
4707    
4708     procedure TIBCustomDataSet.InternalUnPrepare;
4709     begin
4710     if FInternalPrepared then
4711     begin
4712     CheckDatasetClosed;
4713     if FDidActivate then
4714     DeactivateTransaction;
4715     FieldDefs.Clear;
4716     FieldDefs.Updated := false;
4717     FInternalPrepared := False;
4718     Setlength(FAliasNameList,0);
4719     end;
4720     end;
4721    
4722     procedure TIBCustomDataSet.InternalExecQuery;
4723     var
4724     DidActivate: Boolean;
4725     begin
4726     DidActivate := False;
4727     FBase.SetCursor;
4728     try
4729     ActivateConnection;
4730     DidActivate := ActivateTransaction;
4731     if FQSelect.SQL.Text = '' then
4732     IBError(ibxeEmptyQuery, [nil]);
4733     if not FInternalPrepared then
4734     InternalPrepare;
4735     if FQSelect.SQLStatementType = SQLSelect then
4736     begin
4737     IBError(ibxeIsASelectStatement, [nil]);
4738     end
4739     else
4740     FQSelect.ExecQuery;
4741     finally
4742     if DidActivate then
4743     DeactivateTransaction;
4744     FBase.RestoreCursor;
4745     end;
4746     end;
4747    
4748     function TIBCustomDataSet.GetSelectStmtIntf: IStatement;
4749     begin
4750     Result := FQSelect.Statement;
4751     end;
4752    
4753     procedure TIBCustomDataSet.SetMasterDetailDelay(AValue: integer);
4754     begin
4755     FDataLink.DelayTimerValue := AValue;
4756     end;
4757    
4758     function TIBCustomDataSet.GetParser: TSelectSQLParser;
4759     begin
4760     if not assigned(FParser) then
4761     FParser := CreateParser;
4762     Result := FParser
4763     end;
4764    
4765     procedure TIBCustomDataSet.ResetParser;
4766     begin
4767     if assigned(FParser) then
4768     begin
4769     FParser.Free;
4770     FParser := nil;
4771     FQSelect.OnSQLChanged := nil; {Do not react to change}
4772     try
4773     FQSelect.SQL.Assign(FBaseSQLSelect);
4774     finally
4775     FQSelect.OnSQLChanged := SQLChanged;
4776     end;
4777     end;
4778     end;
4779    
4780     function TIBCustomDataSet.HasParser: boolean;
4781     begin
4782     Result := not (csDesigning in ComponentState) and (FParser <> nil)
4783     end;
4784    
4785     procedure TIBCustomDataSet.SetGenerateParamNames(AValue: Boolean);
4786     begin
4787     if FGenerateParamNames = AValue then Exit;
4788     FGenerateParamNames := AValue;
4789     Disconnect
4790     end;
4791    
4792     procedure TIBCustomDataSet.InitRecord(Buffer: PChar);
4793     begin
4794     inherited InitRecord(Buffer);
4795     with PRecordData(Buffer)^ do
4796     begin
4797     rdUpdateStatus := TUpdateStatus(usInserted);
4798     rdBookMarkFlag := bfInserted;
4799     rdRecordNumber := -1;
4800     end;
4801     end;
4802    
4803     procedure TIBCustomDataSet.InternalInsert;
4804     begin
4805     CursorPosChanged;
4806     end;
4807    
4808     { TIBDataSet IProviderSupport }
4809    
4810     procedure TIBCustomDataSet.PSEndTransaction(Commit: Boolean);
4811     begin
4812     if Commit then
4813     Transaction.Commit else
4814     Transaction.Rollback;
4815     end;
4816    
4817     function TIBCustomDataSet.PSExecuteStatement(const ASQL: string; AParams: TParams;
4818     ResultSet: Pointer = nil): Integer;
4819     var
4820     FQuery: TIBQuery;
4821     begin
4822     if Assigned(ResultSet) then
4823     begin
4824     TDataSet(ResultSet^) := TIBQuery.Create(nil);
4825     with TIBQuery(ResultSet^) do
4826     begin
4827     SQL.Text := ASQL;
4828     Params.Assign(AParams);
4829     Open;
4830     Result := RowsAffected;
4831     end;
4832     end
4833     else
4834     begin
4835     FQuery := TIBQuery.Create(nil);
4836     try
4837     FQuery.Database := Database;
4838     FQuery.Transaction := Transaction;
4839     FQuery.GenerateParamNames := True;
4840     FQuery.SQL.Text := ASQL;
4841     FQuery.Params.Assign(AParams);
4842     FQuery.ExecSQL;
4843     Result := FQuery.RowsAffected;
4844     finally
4845     FQuery.Free;
4846     end;
4847     end;
4848     end;
4849    
4850     function TIBCustomDataSet.PSGetQuoteChar: string;
4851     begin
4852     if Database.SQLDialect = 3 then
4853     Result := '"' else
4854     Result := '';
4855     end;
4856    
4857     function TIBCustomDataSet.PSGetUpdateException(E: Exception; Prev: EUpdateError): EUpdateError;
4858     var
4859     PrevErr: Integer;
4860     begin
4861     if Prev <> nil then
4862     PrevErr := Prev.ErrorCode else
4863     PrevErr := 0;
4864     if E is EIBError then
4865     with EIBError(E) do
4866     Result := EUpdateError.Create(E.Message, '', SQLCode, PrevErr, E) else
4867     Result := inherited PSGetUpdateException(E, Prev);
4868     end;
4869    
4870     function TIBCustomDataSet.PSInTransaction: Boolean;
4871     begin
4872     Result := Transaction.InTransaction;
4873     end;
4874    
4875     function TIBCustomDataSet.PSIsSQLBased: Boolean;
4876     begin
4877     Result := True;
4878     end;
4879    
4880     function TIBCustomDataSet.PSIsSQLSupported: Boolean;
4881     begin
4882     Result := True;
4883     end;
4884    
4885     procedure TIBCustomDataSet.PSReset;
4886     begin
4887     inherited PSReset;
4888     if Active then
4889     begin
4890     Close;
4891     Open;
4892     end;
4893     end;
4894    
4895     function TIBCustomDataSet.PSUpdateRecord(UpdateKind: TUpdateKind; Delta: TDataSet): Boolean;
4896     var
4897     UpdateAction: TIBUpdateAction;
4898     SQL: string;
4899     Params: TParams;
4900    
4901     procedure AssignParams(DataSet: TDataSet; Params: TParams);
4902     var
4903     I: Integer;
4904     Old: Boolean;
4905     Param: TParam;
4906     PName: string;
4907     Field: TField;
4908     Value: Variant;
4909     begin
4910     for I := 0 to Params.Count - 1 do
4911     begin
4912     Param := Params[I];
4913     PName := Param.Name;
4914     Old := CompareText(Copy(PName, 1, 4), 'OLD_') = 0; {do not localize}
4915     if Old then System.Delete(PName, 1, 4);
4916     Field := DataSet.FindField(PName);
4917     if not Assigned(Field) then Continue;
4918     if Old then Param.AssignFieldValue(Field, Field.OldValue) else
4919     begin
4920     Value := Field.NewValue;
4921     if VarIsEmpty(Value) then Value := Field.OldValue;
4922     Param.AssignFieldValue(Field, Value);
4923     end;
4924     end;
4925     end;
4926    
4927     begin
4928     Result := False;
4929     if Assigned(OnUpdateRecord) then
4930     begin
4931     UpdateAction := uaFail;
4932     if Assigned(FOnUpdateRecord) then
4933     begin
4934     FOnUpdateRecord(Delta, UpdateKind, UpdateAction);
4935     Result := UpdateAction = uaApplied;
4936     end;
4937     end
4938     else if Assigned(FUpdateObject) then
4939     begin
4940     SQL := FUpdateObject.GetSQL(UpdateKind).Text;
4941     if SQL <> '' then
4942     begin
4943     Params := TParams.Create;
4944     try
4945     Params.ParseSQL(SQL, True);
4946     AssignParams(Delta, Params);
4947     if PSExecuteStatement(SQL, Params) = 0 then
4948     IBError(ibxeNoRecordsAffected, [nil]);
4949     Result := True;
4950     finally
4951     Params.Free;
4952     end;
4953     end;
4954     end;
4955     end;
4956    
4957     procedure TIBCustomDataSet.PSStartTransaction;
4958     begin
4959     ActivateConnection;
4960     Transaction.StartTransaction;
4961     end;
4962    
4963     function TIBCustomDataSet.PsGetTableName: string;
4964     begin
4965     // if not FInternalPrepared then
4966     // InternalPrepare;
4967     { It is possible for the FQSelectSQL to be unprepared
4968     with FInternalPreprepared being true (see DoBeforeTransactionEnd).
4969     So check the Prepared of the SelectSQL instead }
4970     if not FQSelect.Prepared then
4971     FQSelect.Prepare;
4972     Result := FQSelect.UniqueRelationName;
4973     end;
4974    
4975     procedure TIBDataSet.BatchInput(InputObject: TIBBatchInput);
4976     begin
4977     InternalBatchInput(InputObject);
4978     end;
4979    
4980     procedure TIBDataSet.BatchOutput(OutputObject: TIBBatchOutput);
4981     begin
4982     InternalBatchOutput(OutputObject);
4983     end;
4984    
4985     procedure TIBDataSet.ExecSQL;
4986     begin
4987     InternalExecQuery;
4988     end;
4989    
4990     procedure TIBDataSet.Prepare;
4991     begin
4992     InternalPrepare;
4993     end;
4994    
4995     procedure TIBDataSet.UnPrepare;
4996     begin
4997     InternalUnPrepare;
4998     end;
4999    
5000     function TIBDataSet.GetPrepared: Boolean;
5001     begin
5002     Result := InternalPrepared;
5003     end;
5004    
5005     procedure TIBDataSet.InternalOpen;
5006     begin
5007     ActivateConnection;
5008     ActivateTransaction;
5009     InternalSetParamsFromCursor;
5010     Inherited InternalOpen;
5011     end;
5012    
5013     procedure TIBDataSet.SetFiltered(Value: Boolean);
5014     begin
5015     if(Filtered <> Value) then
5016     begin
5017     inherited SetFiltered(value);
5018     if Active then
5019     begin
5020     Close;
5021     Open;
5022     end;
5023     end
5024     else
5025     inherited SetFiltered(value);
5026     end;
5027    
5028     function TIBCustomDataSet.BookmarkValid(Bookmark: TBookmark): Boolean;
5029     begin
5030     Result := false;
5031     if not Assigned(Bookmark) then
5032     exit;
5033     Result := PInteger(Bookmark)^ < FRecordCount;
5034     end;
5035    
5036     function TIBCustomDataSet.GetFieldData(Field: TField;
5037     Buffer: Pointer): Boolean;
5038     {$IFDEF TBCDFIELD_IS_BCD}
5039     var
5040     lTempCurr : System.Currency;
5041     begin
5042     if (Field.DataType = ftBCD) and (Buffer <> nil) then
5043     begin
5044     Result := InternalGetFieldData(Field, @lTempCurr);
5045     if Result then
5046     CurrToBCD(lTempCurr, TBCD(Buffer^), 32, Field.Size);
5047     end
5048     else
5049     {$ELSE}
5050     begin
5051     {$ENDIF}
5052     Result := InternalGetFieldData(Field, Buffer);
5053     end;
5054    
5055     function TIBCustomDataSet.GetFieldData(Field: TField; Buffer: Pointer;
5056     NativeFormat: Boolean): Boolean;
5057     begin
5058     {These datatypes use IBX conventions and not TDataset conventions}
5059     if (Field.DataType in [ftBCD,ftDateTime,ftDate,ftTime]) and not NativeFormat then
5060     Result := InternalGetFieldData(Field, Buffer)
5061     else
5062     Result := inherited GetFieldData(Field, Buffer, NativeFormat);
5063     end;
5064    
5065     procedure TIBCustomDataSet.SetFieldData(Field: TField; Buffer: Pointer);
5066     {$IFDEF TDBDFIELD_IS_BCD}
5067     var
5068     lTempCurr : System.Currency;
5069     begin
5070     if (Field.DataType = ftBCD) and (Buffer <> nil) then
5071     begin
5072     BCDToCurr(TBCD(Buffer^), lTempCurr);
5073     InternalSetFieldData(Field, @lTempCurr);
5074     end
5075     else
5076     {$ELSE}
5077     begin
5078     {$ENDIF}
5079     InternalSetFieldData(Field, Buffer);
5080     end;
5081    
5082     procedure TIBCustomDataSet.SetFieldData(Field: TField; Buffer: Pointer;
5083     NativeFormat: Boolean);
5084     begin
5085     {These datatypes use IBX conventions and not TDataset conventions}
5086     if (not NativeFormat) and (Field.DataType in [ftBCD,ftDateTime,ftDate,ftTime]) then
5087     InternalSetfieldData(Field, Buffer)
5088     else
5089     inherited SetFieldData(Field, buffer, NativeFormat);
5090     end;
5091    
5092     { TIBDataSetUpdateObject }
5093    
5094     constructor TIBDataSetUpdateObject.Create(AOwner: TComponent);
5095     begin
5096     inherited Create(AOwner);
5097     FRefreshSQL := TStringList.Create;
5098     end;
5099    
5100     destructor TIBDataSetUpdateObject.Destroy;
5101     begin
5102     FRefreshSQL.Free;
5103     inherited Destroy;
5104     end;
5105    
5106     function TIBDataSetUpdateObject.GetRowsAffected(
5107     var SelectCount, InsertCount, UpdateCount, DeleteCount: integer): boolean;
5108     begin
5109 tony 217 Result := true;
5110 tony 209 SelectCount := 0;
5111     InsertCount := 0;
5112     UpdateCount := 0;
5113     DeleteCount := 0;
5114     end;
5115    
5116     procedure TIBDataSetUpdateObject.SetRefreshSQL(value: TStrings);
5117     begin
5118     FRefreshSQL.Assign(Value);
5119     end;
5120    
5121     procedure TIBDataSetUpdateObject.InternalSetParams(Params: ISQLParams;
5122     buff: PChar);
5123     begin
5124     if not Assigned(DataSet) then Exit;
5125     DataSet.SetInternalSQLParams(Params, buff);
5126     end;
5127    
5128     procedure TIBDataSetUpdateObject.InternalSetParams(Query: TIBSQL; buff: PChar);
5129     begin
5130     InternalSetParams(Query.Params,buff);
5131     end;
5132    
5133     procedure TIBDataSetUpdateObject.UpdateRecordFromQuery(UpdateKind: TUpdateKind;
5134     QryResults: IResults; Buffer: PChar);
5135     begin
5136     if not Assigned(DataSet) then Exit;
5137     case UpdateKind of
5138     ukModify, ukInsert:
5139     DataSet.UpdateRecordFromQuery(QryResults, Buffer);
5140     ukDelete:
5141     DataSet.DoDeleteReturning(QryResults);
5142     end;
5143     end;
5144    
5145     function TIBDSBlobStream.GetSize: Int64;
5146     begin
5147     Result := FBlobStream.BlobSize;
5148     end;
5149    
5150     { TIBDSBlobStream }
5151     constructor TIBDSBlobStream.Create(AField: TField; ABlobStream: TIBBlobStream;
5152     Mode: TBlobStreamMode);
5153     begin
5154     FField := AField;
5155     FBlobStream := ABlobStream;
5156     FBlobStream.Seek(0, soFromBeginning);
5157     if (Mode = bmWrite) then
5158     begin
5159     FBlobStream.Truncate;
5160     TIBCustomDataSet(FField.DataSet).RecordModified(True);
5161     TBlobField(FField).Modified := true;
5162     FHasWritten := true;
5163     end;
5164     end;
5165    
5166     destructor TIBDSBlobStream.Destroy;
5167     begin
5168     if FHasWritten then
5169     TIBCustomDataSet(FField.DataSet).DataEvent(deFieldChange, PtrInt(FField));
5170     inherited Destroy;
5171     end;
5172    
5173     function TIBDSBlobStream.Read(var Buffer; Count: Longint): Longint;
5174     begin
5175     result := FBlobStream.Read(Buffer, Count);
5176     end;
5177    
5178     function TIBDSBlobStream.Seek(Offset: Longint; Origin: Word): Longint;
5179     begin
5180     result := FBlobStream.Seek(Offset, Origin);
5181     end;
5182    
5183     procedure TIBDSBlobStream.SetSize(NewSize: Longint);
5184     begin
5185     FBlobStream.SetSize(NewSize);
5186     end;
5187    
5188     function TIBDSBlobStream.Write(const Buffer; Count: Longint): Longint;
5189     begin
5190     if not (FField.DataSet.State in [dsEdit, dsInsert]) then
5191     IBError(ibxeNotEditing, [nil]);
5192     TIBCustomDataSet(FField.DataSet).RecordModified(True);
5193     TBlobField(FField).Modified := true;
5194     result := FBlobStream.Write(Buffer, Count);
5195     FHasWritten := true;
5196     { TIBCustomDataSet(FField.DataSet).DataEvent(deFieldChange, PtrInt(FField));
5197     Removed as this caused a seek to beginning of the blob stream thus corrupting
5198     the blob stream. Moved to the destructor i.e. called after blob written}
5199     end;
5200    
5201     { TIBGenerator }
5202    
5203     procedure TIBGenerator.SetIncrement(const AValue: integer);
5204     begin
5205     if FIncrement = AValue then Exit;
5206     if AValue < 0 then
5207     IBError(ibxeNegativeGenerator,[]);
5208     FIncrement := AValue;
5209     SetQuerySQL;
5210     end;
5211    
5212     procedure TIBGenerator.SetTransaction(AValue: TIBTransaction);
5213     begin
5214     FQuery.Transaction := AValue;
5215     end;
5216    
5217     procedure TIBGenerator.SetQuerySQL;
5218     begin
5219     FQuery.SQL.Text := Format('Select Gen_ID(%s,%d) From RDB$Database',[FGeneratorName,Increment]);
5220     end;
5221    
5222     function TIBGenerator.GetDatabase: TIBDatabase;
5223     begin
5224     Result := FQuery.Database;
5225     end;
5226    
5227     function TIBGenerator.GetTransaction: TIBTransaction;
5228     begin
5229     Result := FQuery.Transaction;
5230     end;
5231    
5232     procedure TIBGenerator.SetDatabase(AValue: TIBDatabase);
5233     begin
5234     FQuery.Database := AValue;
5235     end;
5236    
5237     procedure TIBGenerator.SetGeneratorName(AValue: string);
5238     begin
5239     if FGeneratorName = AValue then Exit;
5240     FGeneratorName := AValue;
5241     SetQuerySQL;
5242     end;
5243    
5244     function TIBGenerator.GetNextValue: integer;
5245     begin
5246     with FQuery do
5247     begin
5248     Transaction.Active := true;
5249     ExecQuery;
5250     try
5251     Result := Fields[0].AsInteger
5252     finally
5253     Close
5254     end;
5255     end;
5256     end;
5257    
5258     constructor TIBGenerator.Create(Owner: TIBCustomDataSet);
5259     begin
5260     FOwner := Owner;
5261     FIncrement := 1;
5262     FQuery := TIBSQL.Create(nil);
5263     end;
5264    
5265     destructor TIBGenerator.Destroy;
5266     begin
5267     if assigned(FQuery) then FQuery.Free;
5268     inherited Destroy;
5269     end;
5270    
5271    
5272     procedure TIBGenerator.Apply;
5273     begin
5274     if assigned(Database) and assigned(Transaction) and
5275     (FGeneratorName <> '') and (FFieldName <> '') and Owner.FieldByName(FFieldName).IsNull then
5276     Owner.FieldByName(FFieldName).AsInteger := GetNextValue;
5277     end;
5278    
5279    
5280     end.