ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/nongui/IBCustomDataSet.pas
Revision: 216
Committed: Thu Mar 15 17:21:13 2018 UTC (6 years ago) by tony
Content type: text/x-pascal
File size: 150906 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     Result := ValidUTF8String(TextToSingleLine(Result))
1162     else
1163     if UTF8Length(Result) > DisplayWidth then {Show truncation with elipses}
1164     Result := ValidUTF8String(TextToSingleLine(UTF8Copy(Result,1,DisplayWidth-3))) + '...';
1165     end;
1166     end
1167     end;
1168    
1169     procedure TIBMemoField.Bind(Binding: Boolean);
1170     var IBFieldDef: TIBFieldDef;
1171     begin
1172     inherited Bind(Binding);
1173     if Binding and (FieldDef <> nil) then
1174     begin
1175     IBFieldDef := FieldDef as TIBFieldDef;
1176     CharacterSetSize := IBFieldDef.CharacterSetSize;
1177     CharacterSetName := IBFieldDef.CharacterSetName;
1178     CodePage := IBFieldDef.CodePage;
1179     end;
1180     end;
1181    
1182     function TIBMemoField.GetAsString: string;
1183     var s: RawByteString;
1184     begin
1185     s := inherited GetAsString;
1186     SetCodePage(s,CodePage,false);
1187     if (CodePage <> CP_NONE) and (CodePage <> CP_UTF8) then
1188     SetCodePage(s,CP_UTF8,true); {LCL only accepts UTF8}
1189     Result := s;
1190     end;
1191    
1192     function TIBMemoField.GetDefaultWidth: Longint;
1193     begin
1194     if DisplayTextAsClassName then
1195     Result := inherited
1196     else
1197     Result := 128;
1198     end;
1199    
1200     procedure TIBMemoField.GetText(var AText: string; ADisplayText: Boolean);
1201     begin
1202     if ADisplayText then
1203     begin
1204     if not DisplayTextAsClassName and (CharacterSetName <> '') then
1205     AText := GetTruncatedText
1206     else
1207     inherited GetText(AText, ADisplayText);
1208     end
1209     else
1210     AText := GetAsString;
1211     end;
1212    
1213     procedure TIBMemoField.SetAsString(const AValue: string);
1214     var s: RawByteString;
1215     begin
1216     s := AValue;
1217     if StringCodePage(s) <> CodePage then
1218     SetCodePage(s,CodePage,CodePage<>CP_NONE);
1219     inherited SetAsString(s);
1220     end;
1221    
1222     constructor TIBMemoField.Create(AOwner: TComponent);
1223     begin
1224     inherited Create(AOwner);
1225     BlobType := ftMemo;
1226     FCodePage := CP_NONE;
1227     end;
1228    
1229     { TIBControlLink }
1230    
1231     destructor TIBControlLink.Destroy;
1232     begin
1233     IBDataSet := nil;
1234     inherited Destroy;
1235     end;
1236    
1237     procedure TIBControlLink.UpdateParams(Sender: TObject);
1238     begin
1239    
1240     end;
1241    
1242     procedure TIBControlLink.UpdateSQL(Sender: TObject);
1243     begin
1244    
1245     end;
1246    
1247     procedure TIBControlLink.SetIBDataSet(AValue: TIBCustomDataSet);
1248     begin
1249     if FTIBDataSet = AValue then Exit;
1250     if IBDataSet <> nil then
1251     IBDataSet.UnRegisterIBLink(self);
1252     FTIBDataSet := AValue;
1253     if IBDataSet <> nil then
1254     IBDataSet.RegisterIBLink(self);
1255     end;
1256    
1257    
1258     { TIBStringField}
1259    
1260     procedure TIBStringField.Bind(Binding: Boolean);
1261     var IBFieldDef: TIBFieldDef;
1262     begin
1263     inherited Bind(Binding);
1264     if Binding and (FieldDef <> nil) then
1265     begin
1266     IBFieldDef := FieldDef as TIBFieldDef;
1267     CharacterSetSize := IBFieldDef.CharacterSetSize;
1268     CharacterSetName := IBFieldDef.CharacterSetName;
1269     FDataSize := IBFieldDef.DataSize + 1;
1270     if AutoFieldSize then
1271     Size := IBFieldDef.Size;
1272     CodePage := IBFieldDef.CodePage;
1273     end;
1274     end;
1275    
1276     function TIBStringField.GetDataSize: Integer;
1277     begin
1278     Result := FDataSize;
1279     end;
1280    
1281     constructor TIBStringField.Create(aOwner: TComponent);
1282     begin
1283     inherited Create(aOwner);
1284     FCharacterSetSize := 1;
1285     FCodePage := CP_NONE;
1286     FAutoFieldSize := true;
1287     end;
1288    
1289     class procedure TIBStringField.CheckTypeSize(Value: Integer);
1290     begin
1291     { don't check string size. all sizes valid }
1292     end;
1293    
1294     function TIBStringField.GetAsString: string;
1295     begin
1296     if not GetValue(Result) then Result := '';
1297     end;
1298    
1299     function TIBStringField.GetAsVariant: Variant;
1300     var
1301     S: string;
1302     begin
1303     if GetValue(S) then Result := S else Result := Null;
1304     end;
1305    
1306     function TIBStringField.GetValue(var Value: string): Boolean;
1307     var
1308     Buffer: PChar;
1309     s: RawByteString;
1310     begin
1311     Buffer := nil;
1312     IBAlloc(Buffer, 0, DataSize);
1313     try
1314     Result := GetData(Buffer);
1315     if Result then
1316     begin
1317     s := strpas(Buffer);
1318     SetCodePage(s,CodePage,false);
1319     if (CodePage <> CP_NONE) and (CodePage <> CP_UTF8) then
1320     SetCodePage(s,CP_UTF8,true); {LCL only accepts UTF8}
1321     Value := s;
1322     // writeln(FieldName,': ', StringCodePage(Value),', ',Value);
1323     if Transliterate and (Value <> '') then
1324     DataSet.Translate(PChar(Value), PChar(Value), False);
1325     end
1326     finally
1327     FreeMem(Buffer);
1328     end;
1329     end;
1330    
1331     procedure TIBStringField.SetAsString(const Value: string);
1332     var
1333     Buffer: PChar;
1334     s: RawByteString;
1335     begin
1336     Buffer := nil;
1337     IBAlloc(Buffer, 0, DataSize);
1338     try
1339     s := Value;
1340     if StringCodePage(s) <> CodePage then
1341     SetCodePage(s,CodePage,CodePage<>CP_NONE);
1342     StrLCopy(Buffer, PChar(s), DataSize-1);
1343     if Transliterate then
1344     DataSet.Translate(Buffer, Buffer, True);
1345     SetData(Buffer);
1346     finally
1347     FreeMem(Buffer);
1348     end;
1349     end;
1350    
1351    
1352     { TIBBCDField }
1353    
1354     constructor TIBBCDField.Create(AOwner: TComponent);
1355     begin
1356     inherited Create(AOwner);
1357     SetDataType(ftBCD);
1358     Size := 8;
1359     end;
1360    
1361     procedure TIBBCDField.Bind(Binding: Boolean);
1362     begin
1363     inherited Bind(Binding);
1364     if Binding and (FieldDef <> nil) then
1365     FIdentityColumn := (FieldDef as TIBFieldDef).IdentityColumn;
1366     end;
1367    
1368     class procedure TIBBCDField.CheckTypeSize(Value: Integer);
1369     begin
1370     { No need to check as the base type is currency, not BCD }
1371     end;
1372    
1373     function TIBBCDField.GetAsCurrency: Currency;
1374     begin
1375     if not GetValue(Result) then
1376     Result := 0;
1377     end;
1378    
1379     function TIBBCDField.GetAsString: string;
1380     var
1381     C: System.Currency;
1382     begin
1383     if GetValue(C) then
1384     Result := CurrToStr(C)
1385     else
1386     Result := '';
1387     end;
1388    
1389     function TIBBCDField.GetAsVariant: Variant;
1390     var
1391     C: System.Currency;
1392     begin
1393     if GetValue(C) then
1394     Result := C
1395     else
1396     Result := Null;
1397     end;
1398    
1399     function TIBBCDField.GetDataSize: Integer;
1400     begin
1401     {$IFDEF TBCDFIELD_IS_BCD}
1402     Result := 8;
1403     {$ELSE}
1404     Result := inherited GetDataSize
1405     {$ENDIF}
1406     end;
1407    
1408     { TIBDataLink }
1409    
1410     constructor TIBDataLink.Create(ADataSet: TIBCustomDataSet);
1411     begin
1412     inherited Create;
1413     FDataSet := ADataSet;
1414     FTimer := TFPTimer.Create(nil);
1415 tony 215 FTimer.Enabled := false;
1416 tony 209 FTimer.Interval := 0;
1417     FTimer.OnTimer := HandleRefreshTimer;
1418     FDelayTimerValue := 0;
1419     end;
1420    
1421     destructor TIBDataLink.Destroy;
1422     begin
1423     FDataSet.FDataLink := nil;
1424     if assigned(FTimer) then FTimer.Free;
1425     inherited Destroy;
1426     end;
1427    
1428     procedure TIBDataLink.HandleRefreshTimer(Sender: TObject);
1429     begin
1430 tony 215 FTimer.Enabled := false;
1431 tony 213 if FDataSet.Active then
1432     FDataSet.RefreshParams;
1433 tony 209 end;
1434    
1435 tony 213 procedure TIBDataLink.SetDelayTimerValue(AValue: integer);
1436     begin
1437     if FDelayTimerValue = AValue then Exit;
1438     FDelayTimerValue := AValue;
1439 tony 216 {$IF FPC_FULLVERSION >= 30002}
1440 tony 213 FTimer.Interval := FDelayTimerValue;
1441 tony 216 {$IFEND}
1442 tony 213 end;
1443    
1444 tony 209 procedure TIBDataLink.ActiveChanged;
1445     begin
1446     if FDataSet.Active then
1447     FDataSet.RefreshParams;
1448     end;
1449    
1450    
1451     function TIBDataLink.GetDetailDataSet: TDataSet;
1452     begin
1453     Result := FDataSet;
1454     end;
1455    
1456     procedure TIBDataLink.RecordChanged(Field: TField);
1457     begin
1458     if (Field = nil) and FDataSet.Active then
1459     begin
1460 tony 213 {$IF FPC_FULLVERSION >= 30002}
1461 tony 209 if FDelayTimerValue > 0 then
1462 tony 215 with FTimer do
1463     begin
1464     if Enabled then
1465     begin
1466     StopTimer;
1467     StartTimer;
1468     end
1469     else
1470     Enabled := true;
1471     end
1472 tony 209 else
1473 tony 213 {$IFEND}
1474 tony 209 FDataSet.RefreshParams;
1475     end;
1476     end;
1477    
1478     procedure TIBDataLink.CheckBrowseMode;
1479     begin
1480     if FDataSet.Active then
1481     FDataSet.CheckBrowseMode;
1482     end;
1483    
1484     { TIBCustomDataSet }
1485    
1486     constructor TIBCustomDataSet.Create(AOwner: TComponent);
1487     begin
1488     inherited Create(AOwner);
1489     FBase := TIBBase.Create(Self);
1490     FDatabaseInfo := TIBDatabaseInfo.Create(self);
1491     FIBLinks := TList.Create;
1492     FCurrentRecord := -1;
1493     FDeletedRecords := 0;
1494     FUniDirectional := False;
1495     FBufferChunks := BufferCacheSize;
1496     FBlobStreamList := TList.Create;
1497     FArrayList := TList.Create;
1498     FGeneratorField := TIBGenerator.Create(self);
1499     FDataLink := TIBDataLink.Create(Self);
1500     FQDelete := TIBSQL.Create(Self);
1501     FQDelete.OnSQLChanging := SQLChanging;
1502     FQDelete.GoToFirstRecordOnExecute := False;
1503     FQInsert := TIBSQL.Create(Self);
1504     FQInsert.OnSQLChanging := SQLChanging;
1505     FQInsert.GoToFirstRecordOnExecute := False;
1506     FQRefresh := TIBSQL.Create(Self);
1507     FQRefresh.OnSQLChanging := SQLChanging;
1508     FQRefresh.GoToFirstRecordOnExecute := False;
1509     FQSelect := TIBSQL.Create(Self);
1510     FQSelect.OnSQLChanging := SQLChanging;
1511     FQSelect.OnSQLChanged := SQLChanged;
1512     FQSelect.GoToFirstRecordOnExecute := False;
1513     FQModify := TIBSQL.Create(Self);
1514     FQModify.OnSQLChanging := SQLChanging;
1515     FQModify.GoToFirstRecordOnExecute := False;
1516     FUpdateRecordTypes := [cusUnmodified, cusModified, cusInserted];
1517     FParamCheck := True;
1518     FGenerateParamNames := False;
1519     FForcedRefresh := False;
1520     FAutoCommit:= acDisabled;
1521     FDataSetCloseAction := dcDiscardChanges;
1522     {Bookmark Size is Integer for IBX}
1523     BookmarkSize := SizeOf(Integer);
1524     FBase.BeforeDatabaseDisconnect := DoBeforeDatabaseDisconnect;
1525     FBase.AfterDatabaseDisconnect := DoAfterDatabaseDisconnect;
1526     FBase.OnDatabaseFree := DoDatabaseFree;
1527     FBase.BeforeTransactionEnd := DoBeforeTransactionEnd;
1528     FBase.AfterTransactionEnd := DoAfterTransactionEnd;
1529     FBase.OnTransactionFree := DoTransactionFree;
1530     if AOwner is TIBDatabase then
1531     Database := TIBDatabase(AOwner)
1532     else
1533     if AOwner is TIBTransaction then
1534     Transaction := TIBTransaction(AOwner);
1535     FBaseSQLSelect := TStringList.Create;
1536     end;
1537    
1538     destructor TIBCustomDataSet.Destroy;
1539     begin
1540     if Active then Active := false;
1541     if assigned(FGeneratorField) then FGeneratorField.Free;
1542     FDataLink.Free;
1543     FBase.Free;
1544     ClearBlobCache;
1545     ClearIBLinks;
1546     FIBLinks.Free;
1547     FBlobStreamList.Free;
1548     FArrayList.Free;
1549     FreeMem(FBufferCache);
1550     FBufferCache := nil;
1551     FreeMem(FOldBufferCache);
1552     FOldBufferCache := nil;
1553     FCacheSize := 0;
1554     FOldCacheSize := 0;
1555     FMappedFieldPosition := nil;
1556     if assigned(FBaseSQLSelect) then FBaseSQLSelect.Free;
1557     if assigned(FParser) then FParser.Free;
1558     inherited Destroy;
1559     end;
1560    
1561     function TIBCustomDataSet.AdjustCurrentRecord(Buffer: Pointer; GetMode: TGetMode):
1562     TGetResult;
1563     begin
1564     while not IsVisible(Buffer) do
1565     begin
1566     if GetMode = gmPrior then
1567     begin
1568     Dec(FCurrentRecord);
1569     if FCurrentRecord = -1 then
1570     begin
1571     result := grBOF;
1572     exit;
1573     end;
1574     ReadRecordCache(FCurrentRecord, Buffer, False);
1575     end
1576     else begin
1577     Inc(FCurrentRecord);
1578     if (FCurrentRecord = FRecordCount) then
1579     begin
1580     if (not FQSelect.EOF) and FQSelect.Next then
1581     begin
1582     FetchCurrentRecordToBuffer(FQSelect, FCurrentRecord, Buffer);
1583     Inc(FRecordCount);
1584     end
1585     else begin
1586     result := grEOF;
1587     exit;
1588     end;
1589     end
1590     else
1591     ReadRecordCache(FCurrentRecord, Buffer, False);
1592     end;
1593     end;
1594     result := grOK;
1595     end;
1596    
1597     procedure TIBCustomDataSet.ApplyUpdates;
1598     var
1599     CurBookmark: TBookmark;
1600     Buffer: PRecordData;
1601     CurUpdateTypes: TIBUpdateRecordTypes;
1602     UpdateAction: TIBUpdateAction;
1603     UpdateKind: TUpdateKind;
1604     bRecordsSkipped: Boolean;
1605    
1606     procedure GetUpdateKind;
1607     begin
1608     case Buffer^.rdCachedUpdateStatus of
1609     cusModified:
1610     UpdateKind := ukModify;
1611     cusInserted:
1612     UpdateKind := ukInsert;
1613     else
1614     UpdateKind := ukDelete;
1615     end;
1616     end;
1617    
1618     procedure ResetBufferUpdateStatus;
1619     begin
1620     case Buffer^.rdCachedUpdateStatus of
1621     cusModified:
1622     begin
1623     PRecordData(Buffer)^.rdUpdateStatus := usUnmodified;
1624     PRecordData(Buffer)^.rdCachedUpdateStatus := cusUnmodified;
1625     end;
1626     cusInserted:
1627     begin
1628     PRecordData(Buffer)^.rdUpdateStatus := usUnmodified;
1629     PRecordData(Buffer)^.rdCachedUpdateStatus := cusUnmodified;
1630     end;
1631     cusDeleted:
1632     begin
1633     PRecordData(Buffer)^.rdUpdateStatus := usDeleted;
1634     PRecordData(Buffer)^.rdCachedUpdateStatus := cusUnmodified;
1635     end;
1636     end;
1637     WriteRecordCache(PRecordData(Buffer)^.rdRecordNumber, Pointer(Buffer));
1638     end;
1639    
1640     procedure UpdateUsingOnUpdateRecord;
1641     begin
1642     UpdateAction := uaFail;
1643     try
1644     FOnUpdateRecord(Self, UpdateKind, UpdateAction);
1645     except
1646     on E: Exception do
1647     begin
1648     if (E is EDatabaseError) and Assigned(FOnUpdateError) then
1649     FOnUpdateError(Self, EIBError(E), UpdateKind, UpdateAction);
1650     if UpdateAction = uaFail then
1651     raise;
1652     end;
1653     end;
1654     end;
1655    
1656     procedure UpdateUsingUpdateObject;
1657     begin
1658     try
1659     FUpdateObject.Apply(UpdateKind,PChar(Buffer));
1660     ResetBufferUpdateStatus;
1661     except
1662     on E: Exception do
1663     if (E is EDatabaseError) and Assigned(FOnUpdateError) then
1664     FOnUpdateError(Self, EIBError(E), UpdateKind, UpdateAction);
1665     end;
1666     end;
1667    
1668     procedure UpdateUsingInternalquery;
1669     begin
1670     try
1671     case Buffer^.rdCachedUpdateStatus of
1672     cusModified:
1673     InternalPostRecord(FQModify, Buffer);
1674     cusInserted:
1675     InternalPostRecord(FQInsert, Buffer);
1676     cusDeleted:
1677     InternalDeleteRecord(FQDelete, Buffer);
1678     end;
1679     except
1680     on E: EIBError do begin
1681     UpdateAction := uaFail;
1682     if Assigned(FOnUpdateError) then
1683     FOnUpdateError(Self, E, UpdateKind, UpdateAction);
1684     case UpdateAction of
1685     uaFail: raise;
1686     uaAbort: SysUtils.Abort;
1687     uaSkip: bRecordsSkipped := True;
1688     end;
1689     end;
1690     end;
1691     end;
1692    
1693     begin
1694     if State in [dsEdit, dsInsert] then
1695     Post;
1696     FBase.CheckDatabase;
1697     FBase.CheckTransaction;
1698     DisableControls;
1699     CurBookmark := Bookmark;
1700     CurUpdateTypes := FUpdateRecordTypes;
1701     FUpdateRecordTypes := [cusModified, cusInserted, cusDeleted];
1702     try
1703     First;
1704     bRecordsSkipped := False;
1705     while not EOF do
1706     begin
1707     Buffer := PRecordData(GetActiveBuf);
1708     GetUpdateKind;
1709     UpdateAction := uaApply;
1710     if Assigned(FUpdateObject) or Assigned(FOnUpdateRecord) then
1711     begin
1712     if (Assigned(FOnUpdateRecord)) then
1713     UpdateUsingOnUpdateRecord
1714     else
1715     if Assigned(FUpdateObject) then
1716     UpdateUsingUpdateObject;
1717     case UpdateAction of
1718     uaFail:
1719     IBError(ibxeUserAbort, [nil]);
1720     uaAbort:
1721     SysUtils.Abort;
1722     uaApplied:
1723     ResetBufferUpdateStatus;
1724     uaSkip:
1725     bRecordsSkipped := True;
1726     uaRetry:
1727     Continue;
1728     end;
1729     end;
1730     if (not Assigned(FUpdateObject)) and (UpdateAction = UaApply) then
1731     begin
1732     UpdateUsingInternalquery;
1733     UpdateAction := uaApplied;
1734     end;
1735     Next;
1736     end;
1737     FUpdatesPending := bRecordsSkipped;
1738     finally
1739     FUpdateRecordTypes := CurUpdateTypes;
1740     Bookmark := CurBookmark;
1741     EnableControls;
1742     end;
1743     end;
1744    
1745     procedure TIBCustomDataSet.InternalBatchInput(InputObject: TIBBatchInput);
1746     begin
1747     FQSelect.BatchInput(InputObject);
1748     end;
1749    
1750     procedure TIBCustomDataSet.InternalBatchOutput(OutputObject: TIBBatchOutput);
1751     var
1752     Qry: TIBSQL;
1753     begin
1754     Qry := TIBSQL.Create(Self);
1755     try
1756     Qry.Database := FBase.Database;
1757     Qry.Transaction := FBase.Transaction;
1758     Qry.SQL.Assign(FQSelect.SQL);
1759     Qry.BatchOutput(OutputObject);
1760     finally
1761     Qry.Free;
1762     end;
1763     end;
1764    
1765     procedure TIBCustomDataSet.CancelUpdates;
1766     var
1767     CurUpdateTypes: TIBUpdateRecordTypes;
1768     begin
1769     if State in [dsEdit, dsInsert] then
1770     Post;
1771     if FCachedUpdates and FUpdatesPending then
1772     begin
1773     DisableControls;
1774     CurUpdateTypes := UpdateRecordTypes;
1775     UpdateRecordTypes := [cusModified, cusInserted, cusDeleted];
1776     try
1777     First;
1778     while not EOF do
1779     begin
1780     if UpdateStatus = usInserted then
1781     RevertRecord
1782     else
1783     begin
1784     RevertRecord;
1785     Next;
1786     end;
1787     end;
1788     finally
1789     UpdateRecordTypes := CurUpdateTypes;
1790     First;
1791     FUpdatesPending := False;
1792     EnableControls;
1793     end;
1794     end;
1795     end;
1796    
1797     function TIBCustomDataSet.GetFieldPosition(AliasName: string): integer;
1798     var i: integer;
1799     Prepared: boolean;
1800     begin
1801     Result := 0;
1802     Prepared := FInternalPrepared;
1803     if not Prepared then
1804     InternalPrepare;
1805     try
1806     for i := 0 to Length(FAliasNameList) - 1 do
1807     if FAliasNameList[i] = AliasName then
1808     begin
1809     Result := i + 1;
1810     Exit
1811     end;
1812     finally
1813     if not Prepared then
1814     InternalUnPrepare;
1815     end;
1816     end;
1817    
1818     procedure TIBCustomDataSet.ActivateConnection;
1819     begin
1820     if not Assigned(Database) then
1821     IBError(ibxeDatabaseNotAssigned, [nil]);
1822     if not Assigned(Transaction) then
1823     IBError(ibxeTransactionNotAssigned, [nil]);
1824     if not Database.Connected then Database.Open;
1825     end;
1826    
1827     function TIBCustomDataSet.ActivateTransaction: Boolean;
1828     begin
1829     Result := False;
1830     if AllowAutoActivateTransaction or (csDesigning in ComponentState) then
1831     begin
1832     if not Assigned(Transaction) then
1833     IBError(ibxeTransactionNotAssigned, [nil]);
1834     if not Transaction.Active then
1835     begin
1836     Result := True;
1837     Transaction.StartTransaction;
1838     FDidActivate := True;
1839     end;
1840     end;
1841     end;
1842    
1843     procedure TIBCustomDataSet.DeactivateTransaction;
1844     var
1845     i: Integer;
1846     begin
1847     if not Assigned(Transaction) then
1848     IBError(ibxeTransactionNotAssigned, [nil]);
1849     with Transaction do
1850     begin
1851     for i := 0 to SQLObjectCount - 1 do
1852     begin
1853     if (SQLObjects[i] <> nil) and ((SQLObjects[i]).owner is TDataSet) then
1854     begin
1855     if TDataSet(SQLObjects[i].owner).Active then
1856     begin
1857     FDidActivate := False;
1858     exit;
1859     end;
1860     end;
1861     end;
1862     end;
1863     FInternalPrepared := False;
1864     if Transaction.InTransaction then
1865     Transaction.Commit;
1866     FDidActivate := False;
1867     end;
1868    
1869     procedure TIBCustomDataSet.CheckDatasetClosed;
1870     begin
1871     if FOpen then
1872     IBError(ibxeDatasetOpen, [nil]);
1873     end;
1874    
1875     procedure TIBCustomDataSet.CheckDatasetOpen;
1876     begin
1877     if not FOpen then
1878     IBError(ibxeDatasetClosed, [nil]);
1879     end;
1880    
1881     function TIBCustomDataSet.CreateParser: TSelectSQLParser;
1882     begin
1883     Result := TSelectSQLParser.Create(self,FBaseSQLSelect);
1884     Result.OnSQLChanging := SQLChanging
1885     end;
1886    
1887     procedure TIBCustomDataSet.CheckNotUniDirectional;
1888     begin
1889     if UniDirectional then
1890     IBError(ibxeDataSetUniDirectional, [nil]);
1891     end;
1892    
1893     procedure TIBCustomDataSet.AdjustRecordOnInsert(Buffer: Pointer);
1894     begin
1895     with PRecordData(Buffer)^ do
1896     if (State = dsInsert) and (not Modified) then
1897     begin
1898     rdRecordNumber := FRecordCount;
1899     FCurrentRecord := FRecordCount;
1900     end;
1901     end;
1902    
1903     function TIBCustomDataSet.CanEdit: Boolean;
1904     var
1905     Buff: PRecordData;
1906     begin
1907     Buff := PRecordData(GetActiveBuf);
1908     result := (FQModify.SQL.Text <> '') or
1909     (Assigned(FUpdateObject) and (FUpdateObject.GetSQL(ukModify).Text <> '')) or
1910     ((Buff <> nil) and (Buff^.rdCachedUpdateStatus = cusInserted) and
1911     (FCachedUpdates));
1912     end;
1913    
1914     function TIBCustomDataSet.CanInsert: Boolean;
1915     begin
1916     result := (FQInsert.SQL.Text <> '') or
1917     (Assigned(FUpdateObject) and (FUpdateObject.GetSQL(ukInsert).Text <> ''));
1918     end;
1919    
1920     function TIBCustomDataSet.CanDelete: Boolean;
1921     begin
1922     if (FQDelete.SQL.Text <> '') or
1923     (Assigned(FUpdateObject) and (FUpdateObject.GetSQL(ukDelete).Text <> '')) then
1924     result := True
1925     else
1926     result := False;
1927     end;
1928    
1929     function TIBCustomDataSet.CanRefresh: Boolean;
1930     begin
1931     result := (FQRefresh.SQL.Text <> '') or
1932     (Assigned(FUpdateObject) and (FUpdateObject.RefreshSQL.Text <> ''));
1933     end;
1934    
1935     procedure TIBCustomDataSet.CheckEditState;
1936     begin
1937     case State of
1938     { Check all the wsEditMode types }
1939     dsEdit, dsInsert, dsSetKey, dsCalcFields, dsFilter,
1940     dsNewValue, dsInternalCalc :
1941     begin
1942     if (State in [dsEdit]) and (not CanEdit) then
1943     IBError(ibxeCannotUpdate, [nil]);
1944     if (State in [dsInsert]) and (not CanInsert) then
1945     IBError(ibxeCannotInsert, [nil]);
1946     end;
1947     else
1948     IBError(ibxeNotEditing, [])
1949     end;
1950     end;
1951    
1952     procedure TIBCustomDataSet.ClearBlobCache;
1953     var
1954     i: Integer;
1955     begin
1956     for i := 0 to FBlobStreamList.Count - 1 do
1957     begin
1958     TIBBlobStream(FBlobStreamList[i]).Free;
1959     FBlobStreamList[i] := nil;
1960     end;
1961     FBlobStreamList.Pack;
1962     end;
1963    
1964     procedure TIBCustomDataSet.ClearArrayCache;
1965     var
1966     i: Integer;
1967     begin
1968     for i := 0 to FArrayList.Count - 1 do
1969     begin
1970     TIBArray(FArrayList[i]).Free;
1971     FArrayList[i] := nil;
1972     end;
1973     FArrayList.Pack;
1974     end;
1975    
1976     procedure TIBCustomDataSet.CopyRecordBuffer(Source, Dest: Pointer);
1977     begin
1978     Move(Source^, Dest^, FRecordBufferSize);
1979     end;
1980    
1981     procedure TIBCustomDataSet.DoBeforeDatabaseDisconnect(Sender: TObject);
1982     begin
1983     if Active then
1984     Active := False;
1985     InternalUnPrepare;
1986     if Assigned(FBeforeDatabaseDisconnect) then
1987     FBeforeDatabaseDisconnect(Sender);
1988     end;
1989    
1990     procedure TIBCustomDataSet.DoAfterDatabaseDisconnect(Sender: TObject);
1991     begin
1992     if Assigned(FAfterDatabaseDisconnect) then
1993     FAfterDatabaseDisconnect(Sender);
1994     end;
1995    
1996     procedure TIBCustomDataSet.DoDatabaseFree(Sender: TObject);
1997     begin
1998     if Assigned(FDatabaseFree) then
1999     FDatabaseFree(Sender);
2000     end;
2001    
2002     procedure TIBCustomDataSet.DoBeforeTransactionEnd(Sender: TObject;
2003     Action: TTransactionAction);
2004     begin
2005     FCloseAction := Action;
2006     FInTransactionEnd := true;
2007     try
2008     if Active then
2009     Active := False;
2010     finally
2011     FInTransactionEnd := false;
2012     end;
2013     if FQSelect <> nil then
2014     FQSelect.FreeHandle;
2015     if FQDelete <> nil then
2016     FQDelete.FreeHandle;
2017     if FQInsert <> nil then
2018     FQInsert.FreeHandle;
2019     if FQModify <> nil then
2020     FQModify.FreeHandle;
2021     if FQRefresh <> nil then
2022     FQRefresh.FreeHandle;
2023     InternalUnPrepare;
2024     if Assigned(FBeforeTransactionEnd) then
2025     FBeforeTransactionEnd(Sender);
2026     end;
2027    
2028     procedure TIBCustomDataSet.DoAfterTransactionEnd(Sender: TObject);
2029     begin
2030     if Assigned(FAfterTransactionEnd) then
2031     FAfterTransactionEnd(Sender);
2032     end;
2033    
2034     procedure TIBCustomDataSet.DoTransactionFree(Sender: TObject);
2035     begin
2036     if Assigned(FTransactionFree) then
2037     FTransactionFree(Sender);
2038     end;
2039    
2040     procedure TIBCustomDataSet.DoDeleteReturning(QryResults: IResults);
2041     begin
2042     if assigned(FOnDeleteReturning) then
2043     OnDeleteReturning(self,QryResults);
2044     end;
2045    
2046     procedure TIBCustomDataSet.InitModelBuffer(Qry: TIBSQL; Buffer: PChar);
2047     var i, j: Integer;
2048     FieldsLoaded: integer;
2049     p: PRecordData;
2050     colMetadata: IColumnMetaData;
2051     begin
2052     p := PRecordData(Buffer);
2053     { Get record information }
2054     p^.rdBookmarkFlag := bfCurrent;
2055     p^.rdFieldCount := Qry.FieldCount;
2056     p^.rdRecordNumber := -1;
2057     p^.rdUpdateStatus := usUnmodified;
2058     p^.rdCachedUpdateStatus := cusUnmodified;
2059     p^.rdSavedOffset := $FFFFFFFF;
2060    
2061     { Load up the fields }
2062     FieldsLoaded := FQSelect.MetaData.Count;
2063     j := 1;
2064     for i := 0 to Qry.MetaData.Count - 1 do
2065     begin
2066     if (Qry = FQSelect) then
2067     j := i + 1
2068     else
2069     begin
2070     if FieldsLoaded = 0 then
2071     break;
2072     j := FQSelect.FieldIndex[Qry[i].Name] + 1;
2073     if j < 1 then
2074     continue
2075     else
2076     Dec(FieldsLoaded);
2077     end;
2078     if j > 0 then
2079     begin
2080     colMetadata := Qry.MetaData[i];
2081     with p^.rdFields[j], FFieldColumns^[j] do
2082     begin
2083     fdDataType := colMetadata.GetSQLType;
2084     if fdDataType = SQL_BLOB then
2085     fdDataScale := 0
2086     else
2087     fdDataScale := colMetadata.getScale;
2088     fdNullable := colMetadata.getIsNullable;
2089     fdIsNull := true;
2090     fdDataSize := colMetadata.GetSize;
2091     fdDataLength := 0;
2092     fdCodePage := CP_NONE;
2093    
2094     case fdDataType of
2095     SQL_TIMESTAMP,
2096     SQL_TYPE_DATE,
2097     SQL_TYPE_TIME:
2098     fdDataSize := SizeOf(TDateTime);
2099     SQL_SHORT, SQL_LONG:
2100     begin
2101     if (fdDataScale = 0) then
2102     fdDataSize := SizeOf(Integer)
2103     else
2104     if (fdDataScale >= (-4)) then
2105     fdDataSize := SizeOf(Currency)
2106     else
2107     fdDataSize := SizeOf(Double);
2108     end;
2109     SQL_INT64:
2110     begin
2111     if (fdDataScale = 0) then
2112     fdDataSize := SizeOf(Int64)
2113     else
2114     if (fdDataScale >= (-4)) then
2115     fdDataSize := SizeOf(Currency)
2116     else
2117     fdDataSize := SizeOf(Double);
2118     end;
2119     SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT:
2120     fdDataSize := SizeOf(Double);
2121     SQL_BOOLEAN:
2122     fdDataSize := SizeOf(wordBool);
2123     SQL_VARYING,
2124     SQL_TEXT,
2125     SQL_BLOB:
2126     fdCodePage := Qry.Metadata[i].getCodePage;
2127     end;
2128     fdDataOfs := FRecordSize;
2129     Inc(FRecordSize, fdDataSize);
2130     end;
2131     end;
2132     end;
2133     end;
2134    
2135     {Update Buffer Fields from Query Results}
2136    
2137     procedure TIBCustomDataSet.UpdateRecordFromQuery(QryResults: IResults;
2138     Buffer: PChar);
2139     var i, j: integer;
2140     begin
2141     for i := 0 to QryResults.Count - 1 do
2142     begin
2143     j := GetFieldPosition(QryResults[i].GetAliasName);
2144     if j > 0 then
2145     begin
2146     ColumnDataToBuffer(QryResults,i,j,Buffer);
2147     FBufferUpdatedOnQryReturn := true;
2148     end;
2149     end;
2150     end;
2151    
2152    
2153     {Move column data returned from query to row buffer}
2154    
2155     procedure TIBCustomDataSet.ColumnDataToBuffer(QryResults: IResults;
2156     ColumnIndex, FieldIndex: integer; Buffer: PChar);
2157     var
2158     LocalData: PByte;
2159     LocalDate: TDateTime;
2160     LocalDouble: Double;
2161     LocalInt: Integer;
2162     LocalBool: wordBool;
2163     LocalInt64: Int64;
2164     LocalCurrency: Currency;
2165     ColData: ISQLData;
2166     begin
2167     LocalData := nil;
2168     with PRecordData(Buffer)^.rdFields[FieldIndex], FFieldColumns^[FieldIndex] do
2169     begin
2170     QryResults.GetData(ColumnIndex,fdIsNull,fdDataLength,LocalData);
2171     if not fdIsNull then
2172     begin
2173     ColData := QryResults[ColumnIndex];
2174     case fdDataType of {Get Formatted data for column types that need formatting}
2175     SQL_TYPE_DATE,
2176     SQL_TYPE_TIME,
2177     SQL_TIMESTAMP:
2178     begin
2179     {This is an IBX native format and not the TDataset approach. See also GetFieldData}
2180     LocalDate := ColData.AsDateTime;
2181     LocalData := PByte(@LocalDate);
2182     end;
2183     SQL_SHORT, SQL_LONG:
2184     begin
2185     if (fdDataScale = 0) then
2186     begin
2187     LocalInt := ColData.AsLong;
2188     LocalData := PByte(@LocalInt);
2189     end
2190     else
2191     if (fdDataScale >= (-4)) then
2192     begin
2193     LocalCurrency := ColData.AsCurrency;
2194     LocalData := PByte(@LocalCurrency);
2195     end
2196     else
2197     begin
2198     LocalDouble := ColData.AsDouble;
2199     LocalData := PByte(@LocalDouble);
2200     end;
2201     end;
2202     SQL_INT64:
2203     begin
2204     if (fdDataScale = 0) then
2205     begin
2206     LocalInt64 := ColData.AsInt64;
2207     LocalData := PByte(@LocalInt64);
2208     end
2209     else
2210     if (fdDataScale >= (-4)) then
2211     begin
2212     LocalCurrency := ColData.AsCurrency;
2213     LocalData := PByte(@LocalCurrency);
2214     end
2215     else
2216     begin
2217     LocalDouble := ColData.AsDouble;
2218     LocalData := PByte(@LocalDouble);
2219     end
2220     end;
2221     SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT:
2222     begin
2223     LocalDouble := ColData.AsDouble;
2224     LocalData := PByte(@LocalDouble);
2225     end;
2226     SQL_BOOLEAN:
2227     begin
2228     LocalBool := ColData.AsBoolean;
2229     LocalData := PByte(@LocalBool);
2230     end;
2231     end;
2232    
2233     if fdDataType = SQL_VARYING then
2234     Move(LocalData^, Buffer[fdDataOfs], fdDataLength)
2235     else
2236     Move(LocalData^, Buffer[fdDataOfs], fdDataSize)
2237     end
2238     else {Null column}
2239     if fdDataType = SQL_VARYING then
2240     FillChar(Buffer[fdDataOfs],fdDataLength,0)
2241     else
2242     FillChar(Buffer[fdDataOfs],fdDataSize,0);
2243     end;
2244     end;
2245    
2246     function TIBCustomDataSet.GetMasterDetailDelay: integer;
2247     begin
2248     Result := FDataLink.DelayTimerValue;
2249     end;
2250    
2251     { Read the record from FQSelect.Current into the record buffer
2252     Then write the buffer to in memory cache }
2253     procedure TIBCustomDataSet.FetchCurrentRecordToBuffer(Qry: TIBSQL;
2254     RecordNumber: Integer; Buffer: PChar);
2255     var
2256     pbd: PBlobDataArray;
2257     pda: PArrayDataArray;
2258     i, j: Integer;
2259     FieldsLoaded: Integer;
2260     p: PRecordData;
2261     begin
2262     if RecordNumber = -1 then
2263     begin
2264     InitModelBuffer(Qry,Buffer);
2265     Exit;
2266     end;
2267     p := PRecordData(Buffer);
2268     { Make sure blob cache is empty }
2269     pbd := PBlobDataArray(Buffer + FBlobCacheOffset);
2270     pda := PArrayDataArray(Buffer + FArrayCacheOffset);
2271     for i := 0 to BlobFieldCount - 1 do
2272     pbd^[i] := nil;
2273     for i := 0 to ArrayFieldCount - 1 do
2274     pda^[i] := nil;
2275    
2276     { Get record information }
2277     p^.rdBookmarkFlag := bfCurrent;
2278     p^.rdFieldCount := Qry.FieldCount;
2279     p^.rdRecordNumber := RecordNumber;
2280     p^.rdUpdateStatus := usUnmodified;
2281     p^.rdCachedUpdateStatus := cusUnmodified;
2282     p^.rdSavedOffset := $FFFFFFFF;
2283    
2284     { Load up the fields }
2285     FieldsLoaded := FQSelect.MetaData.Count;
2286     j := 1;
2287     for i := 0 to Qry.FieldCount - 1 do
2288     begin
2289     if (Qry = FQSelect) then
2290     j := i + 1
2291     else
2292     begin
2293     if FieldsLoaded = 0 then
2294     break;
2295     j := FQSelect.FieldIndex[Qry[i].Name] + 1;
2296     if j < 1 then
2297     continue
2298     else
2299     Dec(FieldsLoaded);
2300     end;
2301     with FQSelect.MetaData[j - 1] do
2302     if GetAliasname = 'IBX_INTERNAL_DBKEY' then {do not localize}
2303     begin
2304     if (GetSize <= 8) then
2305     p^.rdDBKey := PIBDBKEY(Qry[i].AsPointer)^;
2306     continue;
2307     end;
2308     if j > 0 then
2309     ColumnDataToBuffer(Qry.Current,i,j,Buffer);
2310     end;
2311     WriteRecordCache(RecordNumber, Buffer);
2312     end;
2313    
2314     function TIBCustomDataSet.GetActiveBuf: PChar;
2315     begin
2316     case State of
2317     dsBrowse:
2318     if IsEmpty then
2319     result := nil
2320     else
2321     result := ActiveBuffer;
2322     dsEdit, dsInsert:
2323     result := ActiveBuffer;
2324     dsCalcFields:
2325     result := CalcBuffer;
2326     dsFilter:
2327     result := FFilterBuffer;
2328     dsNewValue:
2329     result := ActiveBuffer;
2330     dsOldValue:
2331     if (PRecordData(ActiveBuffer)^.rdRecordNumber =
2332     PRecordData(FOldBuffer)^.rdRecordNumber) then
2333     result := FOldBuffer
2334     else
2335     result := ActiveBuffer;
2336     else if not FOpen then
2337     result := nil
2338     else
2339     result := ActiveBuffer;
2340     end;
2341     end;
2342    
2343     function TIBCustomDataSet.CachedUpdateStatus: TCachedUpdateStatus;
2344     begin
2345     if Active then
2346     result := PRecordData(GetActiveBuf)^.rdCachedUpdateStatus
2347     else
2348     result := cusUnmodified;
2349     end;
2350    
2351     function TIBCustomDataSet.GetDatabase: TIBDatabase;
2352     begin
2353     result := FBase.Database;
2354     end;
2355    
2356     function TIBCustomDataSet.GetDeleteSQL: TStrings;
2357     begin
2358     result := FQDelete.SQL;
2359     end;
2360    
2361     function TIBCustomDataSet.GetInsertSQL: TStrings;
2362     begin
2363     result := FQInsert.SQL;
2364     end;
2365    
2366     function TIBCustomDataSet.GetSQLParams: ISQLParams;
2367     begin
2368     if not FInternalPrepared then
2369     InternalPrepare;
2370     result := FQSelect.Params;
2371     end;
2372    
2373     function TIBCustomDataSet.GetRefreshSQL: TStrings;
2374     begin
2375     result := FQRefresh.SQL;
2376     end;
2377    
2378     function TIBCustomDataSet.GetSelectSQL: TStrings;
2379     begin
2380     result := FQSelect.SQL;
2381     end;
2382    
2383     function TIBCustomDataSet.GetStatementType: TIBSQLStatementTypes;
2384     begin
2385     result := FQSelect.SQLStatementType;
2386     end;
2387    
2388     function TIBCustomDataSet.GetModifySQL: TStrings;
2389     begin
2390     result := FQModify.SQL;
2391     end;
2392    
2393     function TIBCustomDataSet.GetTransaction: TIBTransaction;
2394     begin
2395     result := FBase.Transaction;
2396     end;
2397    
2398     procedure TIBCustomDataSet.InternalDeleteRecord(Qry: TIBSQL; Buff: Pointer);
2399     begin
2400     if (Assigned(FUpdateObject) and (FUpdateObject.GetSQL(ukDelete).Text <> '')) then
2401     FUpdateObject.Apply(ukDelete,Buff)
2402     else
2403     begin
2404     SetInternalSQLParams(FQDelete.Params, Buff);
2405     FQDelete.ExecQuery;
2406     if (FQDelete.FieldCount > 0) then
2407     DoDeleteReturning(FQDelete.Current);
2408     end;
2409     with PRecordData(Buff)^ do
2410     begin
2411     rdUpdateStatus := usDeleted;
2412     rdCachedUpdateStatus := cusUnmodified;
2413     end;
2414     WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Buff);
2415     end;
2416    
2417     function TIBCustomDataSet.InternalLocate(const KeyFields: string;
2418     const KeyValues: Variant; Options: TLocateOptions): Boolean;
2419     var
2420     keyFieldList: TList;
2421     CurBookmark: TBookmark;
2422     fieldValue: Variant;
2423     lookupValues: array of variant;
2424     i, fieldCount: Integer;
2425     fieldValueAsString: string;
2426     lookupValueAsString: string;
2427     begin
2428     keyFieldList := TList.Create;
2429     try
2430     GetFieldList(keyFieldList, KeyFields);
2431     fieldCount := keyFieldList.Count;
2432     CurBookmark := Bookmark;
2433     result := false;
2434     SetLength(lookupValues, fieldCount);
2435     if not EOF then
2436     begin
2437     for i := 0 to fieldCount - 1 do {expand key values into lookupValues array}
2438     begin
2439     if VarIsArray(KeyValues) then
2440     lookupValues[i] := KeyValues[i]
2441     else
2442     if i > 0 then
2443     lookupValues[i] := NULL
2444     else
2445     lookupValues[0] := KeyValues;
2446    
2447     {convert to upper case is case insensitive search}
2448     if (TField(keyFieldList[i]).DataType = ftString) and
2449     not VarIsNull(lookupValues[i]) and (loCaseInsensitive in Options) then
2450     lookupValues[i] := UpperCase(lookupValues[i]);
2451     end;
2452     end;
2453     while not result and not EOF do {search for a matching record}
2454     begin
2455     i := 0;
2456     result := true;
2457     while result and (i < fieldCount) do
2458     {see if all of the key fields matches}
2459     begin
2460     fieldValue := TField(keyFieldList[i]).Value;
2461     result := not (VarIsNull(fieldValue) xor VarIsNull(lookupValues[i]));
2462     if result and not VarIsNull(fieldValue) then
2463     begin
2464     try
2465     if TField(keyFieldList[i]).DataType = ftString then
2466     begin
2467     {strings need special handling because of the locate options that
2468     apply to them}
2469     fieldValueAsString := TField(keyFieldList[i]).AsString;
2470     lookupValueAsString := lookupValues[i];
2471     if (loCaseInsensitive in Options) then
2472     fieldValueAsString := UpperCase(fieldValueAsString);
2473    
2474     if (loPartialKey in Options) then
2475     result := result and (Pos(lookupValueAsString, fieldValueAsString) = 1)
2476     else
2477     result := result and (fieldValueAsString = lookupValueAsString);
2478     end
2479     else
2480     result := result and (lookupValues[i] =
2481     VarAsType(fieldValue, VarType(lookupValues[i])));
2482     except on EVariantError do
2483     result := False;
2484     end;
2485     end;
2486     Inc(i);
2487     end;
2488     if not result then
2489     Next;
2490     end;
2491     if not result then
2492     Bookmark := CurBookmark
2493     else
2494     CursorPosChanged;
2495     finally
2496     keyFieldList.Free;
2497     SetLength(lookupValues,0)
2498     end;
2499     end;
2500    
2501     procedure TIBCustomDataSet.InternalPostRecord(Qry: TIBSQL; Buff: Pointer);
2502     var
2503     i, j, k, arr: Integer;
2504     pbd: PBlobDataArray;
2505     pda: PArrayDataArray;
2506     begin
2507     pbd := PBlobDataArray(PChar(Buff) + FBlobCacheOffset);
2508     pda := PArrayDataArray(PChar(Buff) + FArrayCacheOffset);
2509     j := 0; arr := 0;
2510     for i := 0 to FieldCount - 1 do
2511     if Fields[i].IsBlob then
2512     begin
2513     k := FMappedFieldPosition[Fields[i].FieldNo -1];
2514     if pbd^[j] <> nil then
2515     begin
2516     pbd^[j].Finalize;
2517     PISC_QUAD(
2518     PChar(Buff) + FFieldColumns^[k].fdDataOfs)^ :=
2519     pbd^[j].BlobID;
2520     PRecordData(Buff)^.rdFields[k].fdIsNull := pbd^[j].Size = 0;
2521     end
2522     else
2523     begin
2524     PRecordData(Buff)^.rdFields[k].fdIsNull := true;
2525     with PISC_QUAD(PChar(Buff) + FFieldColumns^[k].fdDataOfs)^ do
2526     begin
2527     gds_quad_high := 0;
2528     gds_quad_low := 0;
2529     end;
2530     end;
2531     Inc(j);
2532     end
2533     else
2534     if Fields[i] is TIBArrayField then
2535     begin
2536     if pda^[arr] <> nil then
2537     begin
2538     k := FMappedFieldPosition[Fields[i].FieldNo -1];
2539     PISC_QUAD(
2540     PChar(Buff) + FFieldColumns^[k].fdDataOfs)^ := pda^[arr].ArrayIntf.GetArrayID;
2541     PRecordData(Buff)^.rdFields[k].fdIsNull := pda^[arr].ArrayIntf.IsEmpty;
2542     end;
2543     Inc(arr);
2544     end;
2545     FBufferUpdatedOnQryReturn := false;
2546     if Assigned(FUpdateObject) then
2547     begin
2548     if (Qry = FQDelete) then
2549     FUpdateObject.Apply(ukDelete,Buff)
2550     else if (Qry = FQInsert) then
2551     FUpdateObject.Apply(ukInsert,Buff)
2552     else
2553     FUpdateObject.Apply(ukModify,Buff);
2554     FUpdateObject.GetRowsAffected(FSelectCount, FInsertCount, FUpdateCount, FDeleteCount);
2555     end
2556     else begin
2557     SetInternalSQLParams(Qry.Params, Buff);
2558     Qry.ExecQuery;
2559     Qry.Statement.GetRowsAffected(FSelectCount, FInsertCount, FUpdateCount, FDeleteCount);
2560     if Qry.FieldCount > 0 then {Has RETURNING Clause}
2561     UpdateRecordFromQuery(Qry.Current,Buff);
2562     end;
2563     PRecordData(Buff)^.rdUpdateStatus := usUnmodified;
2564     PRecordData(Buff)^.rdCachedUpdateStatus := cusUnmodified;
2565     SetModified(False);
2566     WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Buff);
2567     if (FForcedRefresh or (FNeedsRefresh and not FBufferUpdatedOnQryReturn)) and CanRefresh then
2568     InternalRefreshRow;
2569     end;
2570    
2571     procedure TIBCustomDataSet.InternalRefreshRow;
2572     var
2573     Buff: PChar;
2574     ofs: DWORD;
2575     Qry: TIBSQL;
2576     begin
2577     FBase.SetCursor;
2578     try
2579     Buff := GetActiveBuf;
2580     if CanRefresh then
2581     begin
2582     if Buff <> nil then
2583     begin
2584     if (Assigned(FUpdateObject) and (FUpdateObject.RefreshSQL.Text <> '')) then
2585     begin
2586     Qry := TIBSQL.Create(self);
2587     Qry.Database := Database;
2588     Qry.Transaction := Transaction;
2589     Qry.GoToFirstRecordOnExecute := False;
2590     Qry.SQL.Text := FUpdateObject.RefreshSQL.Text;
2591     end
2592     else
2593     Qry := FQRefresh;
2594     SetInternalSQLParams(Qry.Params, Buff);
2595     Qry.ExecQuery;
2596     try
2597     if (Qry.SQLStatementType = SQLExecProcedure) or Qry.Next then
2598     begin
2599     ofs := PRecordData(Buff)^.rdSavedOffset;
2600     FetchCurrentRecordToBuffer(Qry,
2601     PRecordData(Buff)^.rdRecordNumber,
2602     Buff);
2603     if FCachedUpdates and (ofs <> $FFFFFFFF) then
2604     begin
2605     PRecordData(Buff)^.rdSavedOffset := ofs;
2606     WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Buff);
2607     SaveOldBuffer(Buff);
2608     end;
2609     end;
2610     finally
2611     Qry.Close;
2612     end;
2613     if Qry <> FQRefresh then
2614     Qry.Free;
2615     end
2616     end
2617     else
2618     IBError(ibxeCannotRefresh, [nil]);
2619     finally
2620     FBase.RestoreCursor;
2621     end;
2622     end;
2623    
2624     procedure TIBCustomDataSet.InternalRevertRecord(RecordNumber: Integer);
2625     var
2626     NewBuffer, OldBuffer: PRecordData;
2627    
2628     begin
2629     NewBuffer := nil;
2630     OldBuffer := nil;
2631     NewBuffer := PRecordData(AllocRecordBuffer);
2632     OldBuffer := PRecordData(AllocRecordBuffer);
2633     try
2634     ReadRecordCache(RecordNumber, PChar(NewBuffer), False);
2635     ReadRecordCache(RecordNumber, PChar(OldBuffer), True);
2636     case NewBuffer^.rdCachedUpdateStatus of
2637     cusInserted:
2638     begin
2639     NewBuffer^.rdCachedUpdateStatus := cusUninserted;
2640     Inc(FDeletedRecords);
2641     end;
2642     cusModified,
2643     cusDeleted:
2644     begin
2645     if (NewBuffer^.rdCachedUpdateStatus = cusDeleted) then
2646     Dec(FDeletedRecords);
2647     CopyRecordBuffer(OldBuffer, NewBuffer);
2648     end;
2649     end;
2650    
2651     if State in dsEditModes then
2652     Cancel;
2653    
2654     WriteRecordCache(RecordNumber, PChar(NewBuffer));
2655    
2656     if (NewBuffer^.rdCachedUpdateStatus = cusUninserted ) then
2657     ReSync([]);
2658     finally
2659     FreeRecordBuffer(PChar(NewBuffer));
2660     FreeRecordBuffer(PChar(OldBuffer));
2661     end;
2662     end;
2663    
2664     { A visible record is one that is not truly deleted,
2665     and it is also listed in the FUpdateRecordTypes set }
2666    
2667     function TIBCustomDataSet.IsVisible(Buffer: PChar): Boolean;
2668     begin
2669     result := True;
2670     if not (State = dsOldValue) then
2671     result :=
2672     (PRecordData(Buffer)^.rdCachedUpdateStatus in FUpdateRecordTypes) and
2673     (not ((PRecordData(Buffer)^.rdCachedUpdateStatus = cusUnmodified) and
2674     (PRecordData(Buffer)^.rdUpdateStatus = usDeleted)));
2675     end;
2676    
2677    
2678     function TIBCustomDataSet.LocateNext(const KeyFields: string;
2679     const KeyValues: Variant; Options: TLocateOptions): Boolean;
2680     begin
2681     DisableControls;
2682     try
2683     result := InternalLocate(KeyFields, KeyValues, Options);
2684     finally
2685     EnableControls;
2686     end;
2687     end;
2688    
2689     procedure TIBCustomDataSet.InternalPrepare;
2690     begin
2691     if FInternalPrepared then
2692     Exit;
2693     FBase.SetCursor;
2694     try
2695     ActivateConnection;
2696     ActivateTransaction;
2697     FBase.CheckDatabase;
2698     FBase.CheckTransaction;
2699     if HasParser and (FParser.SQLText <> FQSelect.SQL.Text) then
2700     begin
2701     FQSelect.OnSQLChanged := nil; {Do not react to change}
2702     try
2703     FQSelect.SQL.Text := FParser.SQLText;
2704     finally
2705     FQSelect.OnSQLChanged := SQLChanged;
2706     end;
2707     end;
2708     // writeln( FQSelect.SQL.Text);
2709     if FQSelect.SQL.Text <> '' then
2710     begin
2711     if not FQSelect.Prepared then
2712     begin
2713     FQSelect.GenerateParamNames := FGenerateParamNames;
2714     FQSelect.ParamCheck := ParamCheck;
2715     FQSelect.Prepare;
2716     end;
2717     FQDelete.GenerateParamNames := FGenerateParamNames;
2718     if (Trim(FQDelete.SQL.Text) <> '') and (not FQDelete.Prepared) then
2719     FQDelete.Prepare;
2720     FQInsert.GenerateParamNames := FGenerateParamNames;
2721     if (Trim(FQInsert.SQL.Text) <> '') and (not FQInsert.Prepared) then
2722     FQInsert.Prepare;
2723     FQRefresh.GenerateParamNames := FGenerateParamNames;
2724     if (Trim(FQRefresh.SQL.Text) <> '') and (not FQRefresh.Prepared) then
2725     FQRefresh.Prepare;
2726     FQModify.GenerateParamNames := FGenerateParamNames;
2727     if (Trim(FQModify.SQL.Text) <> '') and (not FQModify.Prepared) then
2728     FQModify.Prepare;
2729     FInternalPrepared := True;
2730     InternalInitFieldDefs;
2731     end else
2732     IBError(ibxeEmptyQuery, [nil]);
2733     finally
2734     FBase.RestoreCursor;
2735     end;
2736     end;
2737    
2738     procedure TIBCustomDataSet.RecordModified(Value: Boolean);
2739     begin
2740     SetModified(Value);
2741     end;
2742    
2743     procedure TIBCustomDataSet.RevertRecord;
2744     var
2745     Buff: PRecordData;
2746     begin
2747     if FCachedUpdates and FUpdatesPending then
2748     begin
2749     Buff := PRecordData(GetActiveBuf);
2750     InternalRevertRecord(Buff^.rdRecordNumber);
2751     ReadRecordCache(Buff^.rdRecordNumber, PChar(Buff), False);
2752     DataEvent(deRecordChange, 0);
2753     end;
2754     end;
2755    
2756     procedure TIBCustomDataSet.SaveOldBuffer(Buffer: PChar);
2757     var
2758     OldBuffer: Pointer;
2759     procedure CopyOldBuffer;
2760     begin
2761     CopyRecordBuffer(Buffer, OldBuffer);
2762     if BlobFieldCount > 0 then
2763     FillChar(PChar(OldBuffer)[FBlobCacheOffset],
2764     BlobFieldCount * SizeOf(TIBBlobStream) + ArrayFieldCount * SizeOf(IArray),
2765     0);
2766     end;
2767    
2768     begin
2769     if (Buffer <> nil) and (PRecordData(Buffer)^.rdRecordNumber >= 0) then
2770     begin
2771     OldBuffer := AllocRecordBuffer;
2772     try
2773     if (PRecordData(Buffer)^.rdSavedOffset = $FFFFFFFF) then
2774     begin
2775     PRecordData(Buffer)^.rdSavedOffset := AdjustPosition(FOldBufferCache, 0,
2776     FILE_END);
2777     CopyOldBuffer;
2778     WriteCache(FOldBufferCache, 0, FILE_CURRENT, OldBuffer);
2779     WriteCache(FBufferCache, PRecordData(Buffer)^.rdRecordNumber * FRecordBufferSize,
2780     FILE_BEGIN, Buffer);
2781     end
2782     else begin
2783     CopyOldBuffer;
2784     WriteCache(FOldBufferCache, PRecordData(Buffer)^.rdSavedOffset, FILE_BEGIN,
2785     OldBuffer);
2786     end;
2787     finally
2788     FreeRecordBuffer(PChar(OldBuffer));
2789     end;
2790     end;
2791     end;
2792    
2793     procedure TIBCustomDataSet.SetBufferChunks(Value: Integer);
2794     begin
2795     if (Value <= 0) then
2796     FBufferChunks := BufferCacheSize
2797     else
2798     FBufferChunks := Value;
2799     end;
2800    
2801     procedure TIBCustomDataSet.SetDatabase(Value: TIBDatabase);
2802     begin
2803     if (csLoading in ComponentState) or (FBase.Database <> Value) then
2804     begin
2805     CheckDatasetClosed;
2806     InternalUnPrepare;
2807     FBase.Database := Value;
2808     FQDelete.Database := Value;
2809     FQInsert.Database := Value;
2810     FQRefresh.Database := Value;
2811     FQSelect.Database := Value;
2812     FQModify.Database := Value;
2813     FDatabaseInfo.Database := Value;
2814     FGeneratorField.Database := Value;
2815     end;
2816     end;
2817    
2818     procedure TIBCustomDataSet.SetDeleteSQL(Value: TStrings);
2819     begin
2820     if FQDelete.SQL.Text <> Value.Text then
2821     begin
2822     Disconnect;
2823     FQDelete.SQL.Assign(Value);
2824     end;
2825     end;
2826    
2827     procedure TIBCustomDataSet.SetInsertSQL(Value: TStrings);
2828     begin
2829     if FQInsert.SQL.Text <> Value.Text then
2830     begin
2831     Disconnect;
2832     FQInsert.SQL.Assign(Value);
2833     end;
2834     end;
2835    
2836     procedure TIBCustomDataSet.SetInternalSQLParams(Params: ISQLParams; Buffer: Pointer);
2837     var
2838     i, j: Integer;
2839     cr, data: PChar;
2840     fn: string;
2841     st: RawByteString;
2842     OldBuffer: Pointer;
2843     Param: ISQLParam;
2844     begin
2845     if (Buffer = nil) then
2846     IBError(ibxeBufferNotSet, [nil]);
2847     if (not FInternalPrepared) then
2848     InternalPrepare;
2849     OldBuffer := nil;
2850     try
2851     for i := 0 to Params.GetCount - 1 do
2852     begin
2853     Param := Params[i];
2854     fn := Param.Name;
2855     if (Pos('OLD_', fn) = 1) then {mbcs ok}
2856     begin
2857     fn := Copy(fn, 5, Length(fn));
2858     if not Assigned(OldBuffer) then
2859     begin
2860     OldBuffer := AllocRecordBuffer;
2861     ReadRecordCache(PRecordData(Buffer)^.rdRecordNumber, OldBuffer, True);
2862     end;
2863     cr := OldBuffer;
2864     end
2865     else if (Pos('NEW_', fn) = 1) then {mbcs ok}
2866     begin
2867     fn := Copy(fn, 5, Length(fn));
2868     cr := Buffer;
2869     end
2870     else
2871     cr := Buffer;
2872     j := FQSelect.FieldIndex[fn] + 1;
2873     if (j > 0) then
2874     with PRecordData(cr)^,rdFields[j], FFieldColumns^[j] do
2875     begin
2876     if Param.name = 'IBX_INTERNAL_DBKEY' then {do not localize}
2877     begin
2878     PIBDBKey(Param.AsPointer)^ := rdDBKey;
2879     continue;
2880     end;
2881     if fdIsNull then
2882     Param.IsNull := True
2883     else begin
2884     Param.IsNull := False;
2885     data := cr + fdDataOfs;
2886     case fdDataType of
2887     SQL_TEXT, SQL_VARYING:
2888     begin
2889     SetString(st, data, fdDataLength);
2890     SetCodePage(st,fdCodePage,false);
2891     Param.AsString := st;
2892     end;
2893     SQL_FLOAT, SQL_DOUBLE, SQL_D_FLOAT:
2894     Param.AsDouble := PDouble(data)^;
2895     SQL_SHORT, SQL_LONG:
2896     begin
2897     if fdDataScale = 0 then
2898     Param.AsLong := PLong(data)^
2899     else
2900     if fdDataScale >= (-4) then
2901     Param.AsCurrency := PCurrency(data)^
2902     else
2903     Param.AsDouble := PDouble(data)^;
2904     end;
2905     SQL_INT64:
2906     begin
2907     if fdDataScale = 0 then
2908     Param.AsInt64 := PInt64(data)^
2909     else
2910     if fdDataScale >= (-4) then
2911     Param.AsCurrency := PCurrency(data)^
2912     else
2913     Param.AsDouble := PDouble(data)^;
2914     end;
2915     SQL_BLOB, SQL_ARRAY, SQL_QUAD:
2916     Param.AsQuad := PISC_QUAD(data)^;
2917     SQL_TYPE_DATE,
2918     SQL_TYPE_TIME,
2919     SQL_TIMESTAMP:
2920     {This is an IBX native format and not the TDataset approach. See also SetFieldData}
2921     Param.AsDateTime := PDateTime(data)^;
2922     SQL_BOOLEAN:
2923     Param.AsBoolean := PWordBool(data)^;
2924     end;
2925     end;
2926     end;
2927     end;
2928     finally
2929     if (OldBuffer <> nil) then
2930     FreeRecordBuffer(PChar(OldBuffer));
2931     end;
2932     end;
2933    
2934     procedure TIBCustomDataSet.SetRefreshSQL(Value: TStrings);
2935     begin
2936     if FQRefresh.SQL.Text <> Value.Text then
2937     begin
2938     Disconnect;
2939     FQRefresh.SQL.Assign(Value);
2940     end;
2941     end;
2942    
2943     procedure TIBCustomDataSet.SetSelectSQL(Value: TStrings);
2944     begin
2945     if FQSelect.SQL.Text <> Value.Text then
2946     begin
2947     Disconnect;
2948     FQSelect.SQL.Assign(Value);
2949     end;
2950     end;
2951    
2952     procedure TIBCustomDataSet.SetModifySQL(Value: TStrings);
2953     begin
2954     if FQModify.SQL.Text <> Value.Text then
2955     begin
2956     Disconnect;
2957     FQModify.SQL.Assign(Value);
2958     end;
2959     end;
2960    
2961     procedure TIBCustomDataSet.SetTransaction(Value: TIBTransaction);
2962     begin
2963     if (FBase.Transaction <> Value) then
2964     begin
2965     CheckDatasetClosed;
2966     FBase.Transaction := Value;
2967     FQDelete.Transaction := Value;
2968     FQInsert.Transaction := Value;
2969     FQRefresh.Transaction := Value;
2970     FQSelect.Transaction := Value;
2971     FQModify.Transaction := Value;
2972     FGeneratorField.Transaction := Value;
2973     end;
2974     end;
2975    
2976     procedure TIBCustomDataSet.SetUniDirectional(Value: Boolean);
2977     begin
2978     CheckDatasetClosed;
2979     FUniDirectional := Value;
2980     end;
2981    
2982     procedure TIBCustomDataSet.SetUpdateRecordTypes(Value: TIBUpdateRecordTypes);
2983     begin
2984     FUpdateRecordTypes := Value;
2985     if Active then
2986     First;
2987     end;
2988    
2989     procedure TIBCustomDataSet.RefreshParams;
2990     var
2991     DataSet: TDataSet;
2992     begin
2993     DisableControls;
2994     try
2995     if FDataLink.DataSource <> nil then
2996     begin
2997     DataSet := FDataLink.DataSource.DataSet;
2998     if DataSet <> nil then
2999     if DataSet.Active and (DataSet.State <> dsSetKey) then
3000     begin
3001     Close;
3002     Open;
3003     end;
3004     end;
3005     finally
3006     EnableControls;
3007     end;
3008     end;
3009    
3010     procedure TIBCustomDataSet.RegisterIBLink(Sender: TIBControlLink);
3011     begin
3012     if FIBLinks.IndexOf(Sender) = -1 then
3013     begin
3014     FIBLinks.Add(Sender);
3015     if Active then
3016     begin
3017     Active := false;
3018     Active := true;
3019     end;
3020     end;
3021     end;
3022    
3023    
3024     procedure TIBCustomDataSet.SQLChanging(Sender: TObject);
3025     begin
3026     Active := false;
3027     { if FOpen then
3028     InternalClose;}
3029     if FInternalPrepared then
3030     InternalUnPrepare;
3031     FieldDefs.Clear;
3032     FieldDefs.Updated := false;
3033     end;
3034    
3035     procedure TIBCustomDataSet.SQLChanged(Sender: TObject);
3036     begin
3037     FBaseSQLSelect.assign(FQSelect.SQL);
3038     end;
3039    
3040     { I can "undelete" uninserted records (make them "inserted" again).
3041     I can "undelete" cached deleted (the deletion hasn't yet occurred) }
3042     procedure TIBCustomDataSet.Undelete;
3043     var
3044     Buff: PRecordData;
3045     begin
3046     CheckActive;
3047     Buff := PRecordData(GetActiveBuf);
3048     with Buff^ do
3049     begin
3050     if rdCachedUpdateStatus = cusUninserted then
3051     begin
3052     rdCachedUpdateStatus := cusInserted;
3053     Dec(FDeletedRecords);
3054     end
3055     else if (rdUpdateStatus = usDeleted) and
3056     (rdCachedUpdateStatus = cusDeleted) then
3057     begin
3058     rdCachedUpdateStatus := cusUnmodified;
3059     rdUpdateStatus := usUnmodified;
3060     Dec(FDeletedRecords);
3061     end;
3062     WriteRecordCache(rdRecordNumber, PChar(Buff));
3063     end;
3064     end;
3065    
3066     procedure TIBCustomDataSet.UnRegisterIBLink(Sender: TIBControlLink);
3067     begin
3068     FIBLinks.Remove(Sender);
3069     end;
3070    
3071     function TIBCustomDataSet.UpdateStatus: TUpdateStatus;
3072     begin
3073     if Active then
3074     if GetActiveBuf <> nil then
3075     result := PRecordData(GetActiveBuf)^.rdUpdateStatus
3076     else
3077     result := usUnmodified
3078     else
3079     result := usUnmodified;
3080     end;
3081    
3082     function TIBCustomDataSet.IsSequenced: Boolean;
3083     begin
3084     Result := Assigned( FQSelect ) and FQSelect.EOF;
3085     end;
3086    
3087     function TIBCustomDataSet.ParamByName(ParamName: String): ISQLParam;
3088     begin
3089     ActivateConnection;
3090     ActivateTransaction;
3091     if not FInternalPrepared then
3092     InternalPrepare;
3093     Result := Params.ByName(ParamName);
3094     end;
3095    
3096     function TIBCustomDataSet.GetRowsAffected(var SelectCount, InsertCount,
3097     UpdateCount, DeleteCount: integer): boolean;
3098     begin
3099     Result := Active;
3100     SelectCount := FSelectCount;
3101     InsertCount := FInsertCount;
3102     UpdateCount := FUpdateCount;
3103     DeleteCount := FDeleteCount;
3104     end;
3105    
3106     function TIBCustomDataSet.GetPerfStatistics(var stats: TPerfCounters): boolean;
3107     begin
3108     Result := EnableStatistics and (FQSelect.Statement <> nil) and
3109     FQSelect.Statement.GetPerfStatistics(stats);
3110     end;
3111    
3112     {Beware: the parameter FCache is used as an identifier to determine which
3113     cache is being operated on and is not referenced in the computation.
3114     The result is an adjusted offset into the identified cache, either the
3115     Buffer Cache or the old Buffer Cache.}
3116    
3117     function TIBCustomDataSet.AdjustPosition(FCache: PChar; Offset: DWORD;
3118     Origin: Integer): DWORD;
3119     var
3120     OldCacheSize: Integer;
3121     begin
3122     if (FCache = FBufferCache) then
3123     begin
3124     case Origin of
3125     FILE_BEGIN: FBPos := Offset;
3126     FILE_CURRENT: FBPos := FBPos + Offset;
3127     FILE_END: FBPos := DWORD(FBEnd) + Offset;
3128     end;
3129     OldCacheSize := FCacheSize;
3130     while (FBPos >= DWORD(FCacheSize)) do
3131     Inc(FCacheSize, FBufferChunkSize);
3132     if FCacheSize > OldCacheSize then
3133     IBAlloc(FBufferCache, FCacheSize, FCacheSize);
3134     result := FBPos;
3135     end
3136     else begin
3137     case Origin of
3138     FILE_BEGIN: FOBPos := Offset;
3139     FILE_CURRENT: FOBPos := FOBPos + Offset;
3140     FILE_END: FOBPos := DWORD(FOBEnd) + Offset;
3141     end;
3142     OldCacheSize := FOldCacheSize;
3143     while (FBPos >= DWORD(FOldCacheSize)) do
3144     Inc(FOldCacheSize, FBufferChunkSize);
3145     if FOldCacheSize > OldCacheSize then
3146     IBAlloc(FOldBufferCache, FOldCacheSize, FOldCacheSize);
3147     result := FOBPos;
3148     end;
3149     end;
3150    
3151     procedure TIBCustomDataSet.ReadCache(FCache: PChar; Offset: DWORD; Origin: Integer;
3152     Buffer: PChar);
3153     var
3154     pCache: PChar;
3155     AdjustedOffset: DWORD;
3156     bOld: Boolean;
3157     begin
3158     bOld := (FCache = FOldBufferCache);
3159     AdjustedOffset := AdjustPosition(FCache, Offset, Origin);
3160     if not bOld then
3161     pCache := FBufferCache + AdjustedOffset
3162     else
3163     pCache := FOldBufferCache + AdjustedOffset;
3164     Move(pCache^, Buffer^, DWORD(FRecordBufferSize));
3165     AdjustPosition(FCache, FRecordBufferSize, FILE_CURRENT);
3166     end;
3167    
3168     procedure TIBCustomDataSet.ReadRecordCache(RecordNumber: Integer; Buffer: PChar;
3169     ReadOldBuffer: Boolean);
3170     begin
3171     if FUniDirectional then
3172     RecordNumber := RecordNumber mod UniCache;
3173     if (ReadOldBuffer) then
3174     begin
3175     ReadRecordCache(RecordNumber, Buffer, False);
3176     if FCachedUpdates and
3177     (PRecordData(Buffer)^.rdSavedOffset <> $FFFFFFFF) then
3178     ReadCache(FOldBufferCache, PRecordData(Buffer)^.rdSavedOffset, FILE_BEGIN,
3179     Buffer)
3180     else
3181     if ReadOldBuffer and
3182     (PRecordData(FOldBuffer)^.rdRecordNumber = RecordNumber) then
3183     CopyRecordBuffer( FOldBuffer, Buffer )
3184     end
3185     else
3186     ReadCache(FBufferCache, RecordNumber * FRecordBufferSize, FILE_BEGIN, Buffer);
3187     end;
3188    
3189     procedure TIBCustomDataSet.WriteCache(FCache: PChar; Offset: DWORD; Origin: Integer;
3190     Buffer: PChar);
3191     var
3192     pCache: PChar;
3193     AdjustedOffset: DWORD;
3194     bOld: Boolean;
3195     dwEnd: DWORD;
3196     begin
3197     bOld := (FCache = FOldBufferCache);
3198     AdjustedOffset := AdjustPosition(FCache, Offset, Origin);
3199     if not bOld then
3200     pCache := FBufferCache + AdjustedOffset
3201     else
3202     pCache := FOldBufferCache + AdjustedOffset;
3203     Move(Buffer^, pCache^, FRecordBufferSize);
3204     dwEnd := AdjustPosition(FCache, FRecordBufferSize, FILE_CURRENT);
3205     if not bOld then
3206     begin
3207     if (dwEnd > FBEnd) then
3208     FBEnd := dwEnd;
3209     end
3210     else begin
3211     if (dwEnd > FOBEnd) then
3212     FOBEnd := dwEnd;
3213     end;
3214     end;
3215    
3216     procedure TIBCustomDataSet.WriteRecordCache(RecordNumber: Integer; Buffer: PChar);
3217     begin
3218     if RecordNumber >= 0 then
3219     begin
3220     if FUniDirectional then
3221     RecordNumber := RecordNumber mod UniCache;
3222     WriteCache(FBufferCache, RecordNumber * FRecordBufferSize, FILE_BEGIN, Buffer);
3223     end;
3224     end;
3225    
3226     function TIBCustomDataSet.AllocRecordBuffer: PChar;
3227     begin
3228     result := nil;
3229     IBAlloc(result, FRecordBufferSize, FRecordBufferSize);
3230     Move(FModelBuffer^, result^, FRecordBufferSize);
3231     end;
3232    
3233     function TIBCustomDataSet.CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream;
3234     var
3235     pb: PBlobDataArray;
3236     fs: TIBBlobStream;
3237     Buff: PChar;
3238     bTr, bDB: Boolean;
3239     begin
3240     if (Field = nil) or (Field.DataSet <> self) then
3241     IBError(ibxFieldNotinDataSet,[Field.Name,Name]);
3242     Buff := GetActiveBuf;
3243     if Buff = nil then
3244     begin
3245     fs := TIBBlobStream.Create;
3246     fs.Mode := bmReadWrite;
3247     fs.Database := Database;
3248     fs.Transaction := Transaction;
3249     fs.SetField(Field);
3250     FBlobStreamList.Add(Pointer(fs));
3251     result := TIBDSBlobStream.Create(Field, fs, Mode);
3252     exit;
3253     end;
3254     pb := PBlobDataArray(Buff + FBlobCacheOffset);
3255     if pb^[Field.Offset] = nil then
3256     begin
3257     AdjustRecordOnInsert(Buff);
3258     pb^[Field.Offset] := TIBBlobStream.Create;
3259     fs := pb^[Field.Offset];
3260     FBlobStreamList.Add(Pointer(fs));
3261     fs.Mode := bmReadWrite;
3262     fs.Database := Database;
3263     fs.Transaction := Transaction;
3264     fs.SetField(Field);
3265     fs.BlobID :=
3266     PISC_QUAD(@Buff[FFieldColumns^[FMappedFieldPosition[Field.FieldNo - 1]].fdDataOfs])^;
3267     if (CachedUpdates) then
3268     begin
3269     bTr := not Transaction.InTransaction;
3270     bDB := not Database.Connected;
3271     if bDB then
3272     Database.Open;
3273     if bTr then
3274     Transaction.StartTransaction;
3275     fs.Seek(0, soFromBeginning);
3276     if bTr then
3277     Transaction.Commit;
3278     if bDB then
3279     Database.Close;
3280     end;
3281     WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Pointer(Buff));
3282     end else
3283     fs := pb^[Field.Offset];
3284     result := TIBDSBlobStream.Create(Field, fs, Mode);
3285     end;
3286    
3287     function TIBCustomDataSet.GetArray(Field: TIBArrayField): IArray;
3288     var Buff: PChar;
3289     pda: PArrayDataArray;
3290     bTr, bDB: Boolean;
3291     begin
3292     if (Field = nil) or (Field.DataSet <> self) then
3293     IBError(ibxFieldNotinDataSet,[Field.Name,Name]);
3294     Buff := GetActiveBuf;
3295     if Buff = nil then
3296     Result := Database.Attachment.CreateArray(Transaction.TransactionIntf,
3297     Field.FRelationName,Field.FieldName)
3298     else
3299     begin
3300     pda := PArrayDataArray(Buff + FArrayCacheOffset);
3301     if pda^[Field.FCacheOffset] = nil then
3302     begin
3303     AdjustRecordOnInsert(Buff);
3304     if Field.IsNull then
3305     Result := Database.Attachment.CreateArray(Transaction.TransactionIntf,
3306     Field.FRelationName,Field.FieldName)
3307     else
3308     Result := Database.Attachment.OpenArray(Transaction.TransactionIntf,
3309     Field.FRelationName,Field.FieldName,Field.ArrayID);
3310     pda^[Field.FCacheOffset] := TIBArray.Create(Field,Result);
3311     FArrayList.Add(pda^[Field.FCacheOffset]);
3312     if (CachedUpdates) then
3313     begin
3314     bTr := not Transaction.InTransaction;
3315     bDB := not Database.Connected;
3316     if bDB then
3317     Database.Open;
3318     if bTr then
3319     Transaction.StartTransaction;
3320     pda^[Field.FCacheOffset].ArrayIntf.PreLoad;
3321     if bTr then
3322     Transaction.Commit;
3323     if bDB then
3324     Database.Close;
3325     end;
3326     WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Pointer(Buff));
3327     end
3328     else
3329     Result := pda^[Field.FCacheOffset].ArrayIntf;
3330     end;
3331     end;
3332    
3333     procedure TIBCustomDataSet.SetArrayIntf(AnArray: IArray; Field: TIBArrayField);
3334     var Buff: PChar;
3335     pda: PArrayDataArray;
3336     begin
3337     if (Field = nil) or (Field.DataSet <> self) then
3338     IBError(ibxFieldNotinDataSet,[Field.Name,Name]);
3339     Buff := GetActiveBuf;
3340     if Buff <> nil then
3341     begin
3342     AdjustRecordOnInsert(Buff);
3343     pda := PArrayDataArray(Buff + FArrayCacheOffset);
3344     pda^[Field.FCacheOffset].FArray := AnArray;
3345     WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Pointer(Buff));
3346     end;
3347     end;
3348    
3349     function TIBCustomDataSet.CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Integer;
3350     const
3351     CMPLess = -1;
3352     CMPEql = 0;
3353     CMPGtr = 1;
3354     RetCodes: array[Boolean, Boolean] of ShortInt = ((2, CMPLess),
3355     (CMPGtr, CMPEql));
3356     begin
3357     result := RetCodes[Bookmark1 = nil, Bookmark2 = nil];
3358    
3359     if Result = 2 then
3360     begin
3361     if PInteger(Bookmark1)^ < PInteger(Bookmark2)^ then
3362     Result := CMPLess
3363     else
3364     if PInteger(Bookmark1)^ > PInteger(Bookmark2)^ then
3365     Result := CMPGtr
3366     else
3367     Result := CMPEql;
3368     end;
3369     end;
3370    
3371     procedure TIBCustomDataSet.DoBeforeDelete;
3372     var
3373     Buff: PRecordData;
3374     begin
3375     if not CanDelete then
3376     IBError(ibxeCannotDelete, [nil]);
3377     Buff := PRecordData(GetActiveBuf);
3378     if FCachedUpdates and
3379     (Buff^.rdCachedUpdateStatus in [cusUnmodified]) then
3380     SaveOldBuffer(PChar(Buff));
3381     inherited DoBeforeDelete;
3382     end;
3383    
3384     procedure TIBCustomDataSet.DoAfterDelete;
3385     begin
3386     inherited DoAfterDelete;
3387     FBase.DoAfterDelete(self);
3388     InternalAutoCommit;
3389     end;
3390    
3391     procedure TIBCustomDataSet.DoBeforeEdit;
3392     var
3393     Buff: PRecordData;
3394     begin
3395     Buff := PRecordData(GetActiveBuf);
3396     if not(CanEdit or (FQModify.SQL.Count <> 0) or
3397     (FCachedUpdates and Assigned(FOnUpdateRecord))) then
3398     IBError(ibxeCannotUpdate, [nil]);
3399     if FCachedUpdates and (Buff^.rdCachedUpdateStatus in [cusUnmodified, cusInserted]) then
3400     SaveOldBuffer(PChar(Buff));
3401     CopyRecordBuffer(GetActiveBuf, FOldBuffer);
3402     inherited DoBeforeEdit;
3403     end;
3404    
3405     procedure TIBCustomDataSet.DoAfterEdit;
3406     begin
3407     inherited DoAfterEdit;
3408     FBase.DoAfterEdit(self);
3409     end;
3410    
3411     procedure TIBCustomDataSet.DoBeforeInsert;
3412     begin
3413     if not CanInsert then
3414     IBError(ibxeCannotInsert, [nil]);
3415     inherited DoBeforeInsert;
3416     end;
3417    
3418     procedure TIBCustomDataSet.DoAfterInsert;
3419     begin
3420     if GeneratorField.ApplyOnEvent = gaeOnNewRecord then
3421     GeneratorField.Apply;
3422     inherited DoAfterInsert;
3423     FBase.DoAfterInsert(self);
3424     end;
3425    
3426     procedure TIBCustomDataSet.DoBeforeClose;
3427     begin
3428     inherited DoBeforeClose;
3429     if FInTransactionEnd and (FCloseAction = TARollback) then
3430     Exit;
3431     if State in [dsInsert,dsEdit] then
3432     begin
3433     if DataSetCloseAction = dcSaveChanges then
3434     Post;
3435     {Note this can fail with an exception e.g. due to
3436     database validation error. In which case the dataset remains open }
3437     end;
3438     if FCachedUpdates and FUpdatesPending and (DataSetCloseAction = dcSaveChanges) then
3439     ApplyUpdates;
3440     end;
3441    
3442     procedure TIBCustomDataSet.DoBeforeOpen;
3443     var i: integer;
3444     begin
3445     if assigned(FParser) then
3446     FParser.Reset;
3447     for i := 0 to FIBLinks.Count - 1 do
3448     TIBControlLink(FIBLinks[i]).UpdateSQL(self);
3449     inherited DoBeforeOpen;
3450     for i := 0 to FIBLinks.Count - 1 do
3451     TIBControlLink(FIBLinks[i]).UpdateParams(self);
3452     end;
3453    
3454     procedure TIBCustomDataSet.DoBeforePost;
3455     begin
3456     inherited DoBeforePost;
3457     if (State = dsInsert) and
3458     (GeneratorField.ApplyOnEvent = gaeOnPostRecord) then
3459     GeneratorField.Apply
3460     end;
3461    
3462     procedure TIBCustomDataSet.DoAfterPost;
3463     begin
3464     inherited DoAfterPost;
3465     FBase.DoAfterPost(self);
3466     InternalAutoCommit;
3467     end;
3468    
3469     procedure TIBCustomDataSet.FetchAll;
3470     var
3471     CurBookmark: TBookmark;
3472     begin
3473     FBase.SetCursor;
3474     try
3475     if FQSelect.EOF or not FQSelect.Open then
3476     exit;
3477     DisableControls;
3478     try
3479     CurBookmark := Bookmark;
3480     Last;
3481     Bookmark := CurBookmark;
3482     finally
3483     EnableControls;
3484     end;
3485     finally
3486     FBase.RestoreCursor;
3487     end;
3488     end;
3489    
3490     procedure TIBCustomDataSet.FreeRecordBuffer(var Buffer: PChar);
3491     begin
3492     FreeMem(Buffer);
3493     Buffer := nil;
3494     end;
3495    
3496     procedure TIBCustomDataSet.GetBookmarkData(Buffer: PChar; Data: Pointer);
3497     begin
3498     Move(PRecordData(Buffer)^.rdRecordNumber, Data^, BookmarkSize);
3499     end;
3500    
3501     function TIBCustomDataSet.GetBookmarkFlag(Buffer: PChar): TBookmarkFlag;
3502     begin
3503     result := PRecordData(Buffer)^.rdBookmarkFlag;
3504     end;
3505    
3506     function TIBCustomDataSet.GetCanModify: Boolean;
3507     begin
3508     result := (FQInsert.SQL.Text <> '') or
3509     (FQModify.SQL.Text <> '') or
3510     (FQDelete.SQL.Text <> '') or
3511     (Assigned(FUpdateObject));
3512     end;
3513    
3514     function TIBCustomDataSet.GetCurrentRecord(Buffer: PChar): Boolean;
3515     begin
3516     if not IsEmpty and (GetBookmarkFlag(ActiveBuffer) = bfCurrent) then
3517     begin
3518     UpdateCursorPos;
3519     ReadRecordCache(PRecordData(ActiveBuffer)^.rdRecordNumber, Buffer, False);
3520     result := True;
3521     end
3522     else
3523     result := False;
3524     end;
3525    
3526     function TIBCustomDataSet.GetDataSource: TDataSource;
3527     begin
3528     if FDataLink = nil then
3529     result := nil
3530     else
3531     result := FDataLink.DataSource;
3532     end;
3533    
3534     function TIBCustomDataSet.GetDBAliasName(FieldNo: integer): string;
3535     begin
3536     Result := FAliasNameMap[FieldNo-1]
3537     end;
3538    
3539     function TIBCustomDataSet.GetFieldDefFromAlias(aliasName: string): TFieldDef;
3540     var
3541     i: integer;
3542     begin
3543     Result := nil;
3544     for i := 0 to Length(FAliasNameMap) - 1 do
3545     if FAliasNameMap[i] = aliasName then
3546     begin
3547     Result := FieldDefs[i];
3548     Exit
3549     end;
3550     end;
3551    
3552     function TIBCustomDataSet.GetFieldClass(FieldType: TFieldType): TFieldClass;
3553     begin
3554     Result := DefaultFieldClasses[FieldType];
3555     end;
3556    
3557     function TIBCustomDataSet.GetFieldData(FieldNo: Integer; Buffer: Pointer): Boolean;
3558     begin
3559     result := GetFieldData(FieldByNumber(FieldNo), buffer);
3560     end;
3561    
3562     function TIBCustomDataSet.InternalGetFieldData(Field: TField; Buffer: Pointer): Boolean;
3563     var
3564     Buff, Data: PChar;
3565     CurrentRecord: PRecordData;
3566     begin
3567     result := False;
3568     Buff := GetActiveBuf;
3569     if (Buff = nil) or
3570     (not IsVisible(Buff)) or not assigned(Field.DataSet) then
3571     exit;
3572     { The intention here is to stuff the buffer with the data for the
3573     referenced field for the current record }
3574     CurrentRecord := PRecordData(Buff);
3575     if (Field.FieldNo < 0) then
3576     begin
3577     Inc(Buff, FRecordSize + Field.Offset);
3578     result := Boolean(Buff[0]);
3579     if result and (Buffer <> nil) then
3580     Move(Buff[1], Buffer^, Field.DataSize);
3581     end
3582     else
3583     if (FMappedFieldPosition[Field.FieldNo - 1] > 0) and
3584     (FMappedFieldPosition[Field.FieldNo - 1] <= CurrentRecord^.rdFieldCount) then
3585     with CurrentRecord^.rdFields[FMappedFieldPosition[Field.FieldNo - 1]],
3586     FFieldColumns^[FMappedFieldPosition[Field.FieldNo - 1]] do
3587     begin
3588     result := not fdIsNull;
3589     if result and (Buffer <> nil) then
3590     begin
3591     Data := Buff + fdDataOfs;
3592     if (fdDataType = SQL_VARYING) or (fdDataType = SQL_TEXT) then
3593     begin
3594     if fdDataLength < Field.DataSize then
3595     begin
3596     Move(Data^, Buffer^, fdDataLength);
3597     PChar(Buffer)[fdDataLength] := #0;
3598     end
3599     else
3600     IBError(ibxeFieldSizeError,[Field.FieldName])
3601     end
3602     else
3603     Move(Data^, Buffer^, Field.DataSize);
3604     end;
3605     end;
3606     end;
3607    
3608     { GetRecNo and SetRecNo both operate off of 1-based indexes as
3609     opposed to 0-based indexes.
3610     This is because we want LastRecordNumber/RecordCount = 1 }
3611    
3612     function TIBCustomDataSet.GetRecNo: Integer;
3613     begin
3614     if GetActiveBuf = nil then
3615     result := 0
3616     else
3617     result := PRecordData(GetActiveBuf)^.rdRecordNumber + 1;
3618     end;
3619    
3620     function TIBCustomDataSet.GetRecord(Buffer: PChar; GetMode: TGetMode;
3621     DoCheck: Boolean): TGetResult;
3622     var
3623     Accept: Boolean;
3624     SaveState: TDataSetState;
3625     begin
3626     Result := grOK;
3627     if Filtered and Assigned(OnFilterRecord) then
3628     begin
3629     Accept := False;
3630     SaveState := SetTempState(dsFilter);
3631     while not Accept do
3632     begin
3633     Result := InternalGetRecord(Buffer, GetMode, DoCheck);
3634     if Result <> grOK then
3635     break;
3636     FFilterBuffer := Buffer;
3637     try
3638     Accept := True;
3639     OnFilterRecord(Self, Accept);
3640     if not Accept and (GetMode = gmCurrent) then
3641     GetMode := gmPrior;
3642     except
3643     // FBase.HandleException(Self);
3644     end;
3645     end;
3646     RestoreState(SaveState);
3647     end
3648     else
3649     Result := InternalGetRecord(Buffer, GetMode, DoCheck);
3650     end;
3651    
3652     function TIBCustomDataSet.InternalGetRecord(Buffer: PChar; GetMode: TGetMode;
3653     DoCheck: Boolean): TGetResult;
3654     begin
3655     result := grError;
3656     case GetMode of
3657     gmCurrent: begin
3658     if (FCurrentRecord >= 0) then begin
3659     if FCurrentRecord < FRecordCount then
3660     ReadRecordCache(FCurrentRecord, Buffer, False)
3661     else begin
3662     while (not FQSelect.EOF) and FQSelect.Next and
3663     (FCurrentRecord >= FRecordCount) do begin
3664     FetchCurrentRecordToBuffer(FQSelect, FRecordCount, Buffer);
3665     Inc(FRecordCount);
3666     end;
3667     FCurrentRecord := FRecordCount - 1;
3668     if (FCurrentRecord >= 0) then
3669     ReadRecordCache(FCurrentRecord, Buffer, False);
3670     end;
3671     result := grOk;
3672     end else
3673     result := grBOF;
3674     end;
3675     gmNext: begin
3676     result := grOk;
3677     if FCurrentRecord = FRecordCount then
3678     result := grEOF
3679     else if FCurrentRecord = FRecordCount - 1 then begin
3680     if (not FQSelect.EOF) then begin
3681     FQSelect.Next;
3682     Inc(FCurrentRecord);
3683     end;
3684     if (FQSelect.EOF) then begin
3685     result := grEOF;
3686     end else begin
3687     Inc(FRecordCount);
3688     FetchCurrentRecordToBuffer(FQSelect, FCurrentRecord, Buffer);
3689     end;
3690     end else if (FCurrentRecord < FRecordCount) then begin
3691     Inc(FCurrentRecord);
3692     ReadRecordCache(FCurrentRecord, Buffer, False);
3693     end;
3694     end;
3695     else { gmPrior }
3696     begin
3697     if (FCurrentRecord = 0) then begin
3698     Dec(FCurrentRecord);
3699     result := grBOF;
3700     end else if (FCurrentRecord > 0) and
3701     (FCurrentRecord <= FRecordCount) then begin
3702     Dec(FCurrentRecord);
3703     ReadRecordCache(FCurrentRecord, Buffer, False);
3704     result := grOk;
3705     end else if (FCurrentRecord = -1) then
3706     result := grBOF;
3707     end;
3708     end;
3709     if result = grOk then
3710     result := AdjustCurrentRecord(Buffer, GetMode);
3711     if result = grOk then with PRecordData(Buffer)^ do begin
3712     rdBookmarkFlag := bfCurrent;
3713     GetCalcFields(Buffer);
3714     end else if (result = grEOF) then begin
3715     CopyRecordBuffer(FModelBuffer, Buffer);
3716     PRecordData(Buffer)^.rdBookmarkFlag := bfEOF;
3717     end else if (result = grBOF) then begin
3718     CopyRecordBuffer(FModelBuffer, Buffer);
3719     PRecordData(Buffer)^.rdBookmarkFlag := bfBOF;
3720     end else if (result = grError) then begin
3721     CopyRecordBuffer(FModelBuffer, Buffer);
3722     PRecordData(Buffer)^.rdBookmarkFlag := bfEOF;
3723     end;;
3724     end;
3725    
3726     function TIBCustomDataSet.GetRecordCount: Integer;
3727     begin
3728     result := FRecordCount - FDeletedRecords;
3729     end;
3730    
3731     function TIBCustomDataSet.GetRecordSize: Word;
3732     begin
3733     result := FRecordBufferSize;
3734     end;
3735    
3736     procedure TIBCustomDataSet.InternalAutoCommit;
3737     begin
3738     with Transaction do
3739     if InTransaction and (FAutoCommit = acCommitRetaining) then
3740     begin
3741     if CachedUpdates then ApplyUpdates;
3742     CommitRetaining;
3743     end;
3744     end;
3745    
3746     procedure TIBCustomDataSet.InternalAddRecord(Buffer: Pointer; Append: Boolean);
3747     begin
3748     CheckEditState;
3749     begin
3750     { When adding records, we *always* append.
3751     Insertion is just too costly }
3752     AdjustRecordOnInsert(Buffer);
3753     with PRecordData(Buffer)^ do
3754     begin
3755     rdUpdateStatus := usInserted;
3756     rdCachedUpdateStatus := cusInserted;
3757     end;
3758     if not CachedUpdates then
3759     InternalPostRecord(FQInsert, Buffer)
3760     else begin
3761     WriteRecordCache(FCurrentRecord, Buffer);
3762     FUpdatesPending := True;
3763     end;
3764     Inc(FRecordCount);
3765     InternalSetToRecord(Buffer);
3766     end
3767     end;
3768    
3769     procedure TIBCustomDataSet.InternalCancel;
3770     var
3771     Buff: PChar;
3772     CurRec: Integer;
3773     pda: PArrayDataArray;
3774     i: integer;
3775     begin
3776     inherited InternalCancel;
3777     Buff := GetActiveBuf;
3778     if Buff <> nil then
3779     begin
3780     pda := PArrayDataArray(Buff + FArrayCacheOffset);
3781     for i := 0 to ArrayFieldCount - 1 do
3782     pda^[i].ArrayIntf.CancelChanges;
3783     CurRec := FCurrentRecord;
3784     AdjustRecordOnInsert(Buff);
3785     if (State = dsEdit) then begin
3786     CopyRecordBuffer(FOldBuffer, Buff);
3787     WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Buff);
3788     end else begin
3789     CopyRecordBuffer(FModelBuffer, Buff);
3790     PRecordData(Buff)^.rdUpdateStatus := usDeleted;
3791     PRecordData(Buff)^.rdCachedUpdateStatus := cusUnmodified;
3792     PRecordData(Buff)^.rdBookmarkFlag := bfEOF;
3793     FCurrentRecord := CurRec;
3794     end;
3795     end;
3796     end;
3797    
3798    
3799     procedure TIBCustomDataSet.InternalClose;
3800     begin
3801     if FDidActivate then
3802     DeactivateTransaction;
3803     FQSelect.Close;
3804     ClearBlobCache;
3805     ClearArrayCache;
3806     FreeRecordBuffer(FModelBuffer);
3807     FreeRecordBuffer(FOldBuffer);
3808     FCurrentRecord := -1;
3809     FOpen := False;
3810     FRecordCount := 0;
3811     FDeletedRecords := 0;
3812     FRecordSize := 0;
3813     FBPos := 0;
3814     FOBPos := 0;
3815     FCacheSize := 0;
3816     FOldCacheSize := 0;
3817     FBEnd := 0;
3818     FOBEnd := 0;
3819     FreeMem(FBufferCache);
3820     FBufferCache := nil;
3821     FreeMem(FFieldColumns);
3822     FFieldColumns := nil;
3823     FreeMem(FOldBufferCache);
3824     FOldBufferCache := nil;
3825     BindFields(False);
3826     ResetParser;
3827     if DefaultFields then DestroyFields;
3828     end;
3829    
3830     procedure TIBCustomDataSet.InternalDelete;
3831     var
3832     Buff: PChar;
3833     begin
3834     FBase.SetCursor;
3835     try
3836     Buff := GetActiveBuf;
3837     if CanDelete then
3838     begin
3839     if not CachedUpdates then
3840     InternalDeleteRecord(FQDelete, Buff)
3841     else
3842     begin
3843     with PRecordData(Buff)^ do
3844     begin
3845     if rdCachedUpdateStatus = cusInserted then
3846     rdCachedUpdateStatus := cusUninserted
3847     else begin
3848     rdUpdateStatus := usDeleted;
3849     rdCachedUpdateStatus := cusDeleted;
3850     end;
3851     end;
3852     WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Buff);
3853     end;
3854     Inc(FDeletedRecords);
3855     FUpdatesPending := True;
3856     end else
3857     IBError(ibxeCannotDelete, [nil]);
3858     finally
3859     FBase.RestoreCursor;
3860     end;
3861     end;
3862    
3863     procedure TIBCustomDataSet.InternalFirst;
3864     begin
3865     FCurrentRecord := -1;
3866     end;
3867    
3868     procedure TIBCustomDataSet.InternalGotoBookmark(Bookmark: Pointer);
3869     begin
3870     FCurrentRecord := PInteger(Bookmark)^;
3871     end;
3872    
3873     procedure TIBCustomDataSet.InternalHandleException;
3874     begin
3875     FBase.HandleException(Self)
3876     end;
3877    
3878     procedure TIBCustomDataSet.InternalInitFieldDefs;
3879     begin
3880     if not InternalPrepared then
3881     begin
3882     InternalPrepare;
3883     exit;
3884     end;
3885     FieldDefsFromQuery(FQSelect);
3886     end;
3887    
3888     procedure TIBCustomDataSet.FieldDefsFromQuery(SourceQuery: TIBSQL);
3889     const
3890     DefaultSQL = 'Select F.RDB$COMPUTED_BLR, ' + {do not localize}
3891     'F.RDB$DEFAULT_VALUE, R.RDB$FIELD_NAME ' + {do not localize}
3892     'from RDB$RELATION_FIELDS R, RDB$FIELDS F ' + {do not localize}
3893     'where R.RDB$RELATION_NAME = :RELATION ' + {do not localize}
3894     'and R.RDB$FIELD_SOURCE = F.RDB$FIELD_NAME '+ {do not localize}
3895     'and ((not F.RDB$COMPUTED_BLR is NULL) or ' + {do not localize}
3896     ' (not F.RDB$DEFAULT_VALUE is NULL)) '; {do not localize}
3897    
3898     DefaultSQLODS12 = 'Select F.RDB$COMPUTED_BLR, ' + {do not localize}
3899     'F.RDB$DEFAULT_VALUE, R.RDB$FIELD_NAME, R.RDB$IDENTITY_TYPE ' + {do not localize}
3900     'from RDB$RELATION_FIELDS R, RDB$FIELDS F ' + {do not localize}
3901     'where R.RDB$RELATION_NAME = :RELATION ' + {do not localize}
3902     'and R.RDB$FIELD_SOURCE = F.RDB$FIELD_NAME '+ {do not localize}
3903     'and ((not F.RDB$COMPUTED_BLR is NULL) or ' + {do not localize}
3904     ' (not F.RDB$DEFAULT_VALUE is NULL) or ' + {do not localize}
3905     ' ( not R.RDB$IDENTITY_TYPE is NULL))' ; {do not localize}
3906    
3907     var
3908     FieldType: TFieldType;
3909     FieldSize: Word;
3910     FieldDataSize: integer;
3911     CharSetSize: integer;
3912     CharSetName: RawByteString;
3913     FieldCodePage: TSystemCodePage;
3914     FieldNullable : Boolean;
3915     i, FieldPosition, FieldPrecision: Integer;
3916     FieldAliasName, DBAliasName: string;
3917     aRelationName, FieldName: string;
3918     Query : TIBSQL;
3919     FieldIndex: Integer;
3920     FRelationNodes : TRelationNode;
3921     aArrayDimensions: integer;
3922     aArrayBounds: TArrayBounds;
3923     ArrayMetaData: IArrayMetaData;
3924    
3925     function Add_Node(Relation, Field : String) : TRelationNode;
3926     var
3927     FField : TFieldNode;
3928     begin
3929     if FRelationNodes.RelationName = '' then
3930     Result := FRelationNodes
3931     else
3932     begin
3933     Result := TRelationNode.Create;
3934     Result.NextRelation := FRelationNodes;
3935     end;
3936     Result.RelationName := Relation;
3937     FRelationNodes := Result;
3938     Query.Params[0].AsString := Relation;
3939     Query.ExecQuery;
3940     while not Query.Eof do
3941     begin
3942     FField := TFieldNode.Create;
3943     FField.FieldName := Query.Fields[2].AsString;
3944     FField.DEFAULT_VALUE := not Query.Fields[1].IsNull;
3945     FField.COMPUTED_BLR := not Query.Fields[0].IsNull;
3946     FField.IDENTITY_COLUMN := (Query.FieldCount > 3) and not Query.Fields[3].IsNull;
3947     FField.NextField := Result.FieldNodes;
3948     Result.FieldNodes := FField;
3949     Query.Next;
3950     end;
3951     Query.Close;
3952     end;
3953    
3954     function Has_COMPUTED_BLR(Relation, Field : String) : Boolean;
3955     var
3956     FRelation : TRelationNode;
3957     FField : TFieldNode;
3958     begin
3959     FRelation := FRelationNodes;
3960     while Assigned(FRelation) and
3961     (FRelation.RelationName <> Relation) do
3962     FRelation := FRelation.NextRelation;
3963     if not Assigned(FRelation) then
3964     FRelation := Add_Node(Relation, Field);
3965     Result := false;
3966     FField := FRelation.FieldNodes;
3967     while Assigned(FField) do
3968     if FField.FieldName = Field then
3969     begin
3970     Result := Ffield.COMPUTED_BLR;
3971     Exit;
3972     end
3973     else
3974     FField := Ffield.NextField;
3975     end;
3976    
3977     function Has_DEFAULT_VALUE(Relation, Field : String) : Boolean;
3978     var
3979     FRelation : TRelationNode;
3980     FField : TFieldNode;
3981     begin
3982     FRelation := FRelationNodes;
3983     while Assigned(FRelation) and
3984     (FRelation.RelationName <> Relation) do
3985     FRelation := FRelation.NextRelation;
3986     if not Assigned(FRelation) then
3987     FRelation := Add_Node(Relation, Field);
3988     Result := false;
3989     FField := FRelation.FieldNodes;
3990     while Assigned(FField) do
3991     if FField.FieldName = Field then
3992     begin
3993     Result := Ffield.DEFAULT_VALUE;
3994     Exit;
3995     end
3996     else
3997     FField := Ffield.NextField;
3998     end;
3999    
4000     function Is_IDENTITY_COLUMN(Relation, Field : String) : Boolean;
4001     var
4002     FRelation : TRelationNode;
4003     FField : TFieldNode;
4004     begin
4005     FRelation := FRelationNodes;
4006     while Assigned(FRelation) and
4007     (FRelation.RelationName <> Relation) do
4008     FRelation := FRelation.NextRelation;
4009     if not Assigned(FRelation) then
4010     FRelation := Add_Node(Relation, Field);
4011     Result := false;
4012     FField := FRelation.FieldNodes;
4013     while Assigned(FField) do
4014     if FField.FieldName = Field then
4015     begin
4016     Result := Ffield.IDENTITY_COLUMN;
4017     Exit;
4018     end
4019     else
4020     FField := Ffield.NextField;
4021     end;
4022    
4023     Procedure FreeNodes;
4024     var
4025     FRelation : TRelationNode;
4026     FField : TFieldNode;
4027     begin
4028     while Assigned(FRelationNodes) do
4029     begin
4030     While Assigned(FRelationNodes.FieldNodes) do
4031     begin
4032     FField := FRelationNodes.FieldNodes.NextField;
4033     FRelationNodes.FieldNodes.Free;
4034     FRelationNodes.FieldNodes := FField;
4035     end;
4036     FRelation := FRelationNodes.NextRelation;
4037     FRelationNodes.Free;
4038     FRelationNodes := FRelation;
4039     end;
4040     end;
4041    
4042     begin
4043     FRelationNodes := TRelationNode.Create;
4044     FNeedsRefresh := False;
4045     if not Database.InternalTransaction.InTransaction then
4046     Database.InternalTransaction.StartTransaction;
4047     Query := TIBSQL.Create(self);
4048     try
4049     Query.Database := DataBase;
4050     Query.Transaction := Database.InternalTransaction;
4051     FieldDefs.BeginUpdate;
4052     FieldDefs.Clear;
4053     FieldIndex := 0;
4054     if (Length(FMappedFieldPosition) < SourceQuery.MetaData.Count) then
4055     SetLength(FMappedFieldPosition, SourceQuery.MetaData.Count);
4056     if FDatabaseInfo.ODSMajorVersion >= 12 then
4057     Query.SQL.Text := DefaultSQLODS12
4058     else
4059     Query.SQL.Text := DefaultSQL;
4060     Query.Prepare;
4061     SetLength(FAliasNameMap, SourceQuery.MetaData.Count);
4062     SetLength(FAliasNameList, SourceQuery.MetaData.Count);
4063     for i := 0 to SourceQuery.MetaData.GetCount - 1 do
4064     with SourceQuery.MetaData[i] do
4065     begin
4066     { Get the field name }
4067     FieldAliasName := GetName;
4068     DBAliasName := GetAliasname;
4069     aRelationName := getRelationName;
4070     FieldName := getSQLName;
4071     FAliasNameList[i] := DBAliasName;
4072     FieldSize := 0;
4073     FieldDataSize := GetSize;
4074     FieldPrecision := 0;
4075     FieldNullable := IsNullable;
4076     CharSetSize := 0;
4077     CharSetName := '';
4078     FieldCodePage := CP_NONE;
4079     aArrayDimensions := 0;
4080     SetLength(aArrayBounds,0);
4081     case SQLType of
4082     { All VARCHAR's must be converted to strings before recording
4083     their values }
4084     SQL_VARYING, SQL_TEXT:
4085     begin
4086     if not Database.Attachment.CharSetWidth(getCharSetID,CharSetSize) then
4087     CharSetSize := 1;
4088     CharSetName := Database.Attachment.GetCharsetName(getCharSetID);
4089     Database.Attachment.CharSetID2CodePage(getCharSetID,FieldCodePage);
4090     FieldSize := FieldDataSize div CharSetSize;
4091     FieldType := ftString;
4092     end;
4093     { All Doubles/Floats should be cast to doubles }
4094     SQL_DOUBLE, SQL_FLOAT:
4095     FieldType := ftFloat;
4096     SQL_SHORT:
4097     begin
4098     if (getScale = 0) then
4099     FieldType := ftSmallInt
4100     else begin
4101     FieldType := ftBCD;
4102     FieldPrecision := 4;
4103     FieldSize := -getScale;
4104     end;
4105     end;
4106     SQL_LONG:
4107     begin
4108     if (getScale = 0) then
4109     FieldType := ftInteger
4110     else if (getScale >= (-4)) then
4111     begin
4112     FieldType := ftBCD;
4113     FieldPrecision := 9;
4114     FieldSize := -getScale;
4115     end
4116     else
4117     if Database.SQLDialect = 1 then
4118     FieldType := ftFloat
4119     else
4120     if (FieldCount > i) and (Fields[i] is TFloatField) then
4121     FieldType := ftFloat
4122     else
4123     begin
4124     FieldType := ftFMTBCD;
4125     FieldPrecision := 9;
4126     FieldSize := -getScale;
4127     end;
4128     end;
4129    
4130     SQL_INT64:
4131     begin
4132     if (getScale = 0) then
4133     FieldType := ftLargeInt
4134     else if (getScale >= (-4)) then
4135     begin
4136     FieldType := ftBCD;
4137     FieldPrecision := 18;
4138     FieldSize := -getScale;
4139     end
4140     else
4141     FieldType := ftFloat;
4142     end;
4143     SQL_TIMESTAMP: FieldType := ftDateTime;
4144     SQL_TYPE_TIME: FieldType := ftTime;
4145     SQL_TYPE_DATE: FieldType := ftDate;
4146     SQL_BLOB:
4147     begin
4148     FieldSize := sizeof (TISC_QUAD);
4149     if (getSubtype = 1) then
4150     begin
4151     if not Database.Attachment.CharSetWidth(getCharSetID,CharSetSize) then
4152     CharSetSize := 1;
4153     CharSetName := Database.Attachment.GetCharsetName(getCharSetID);
4154     Database.Attachment.CharSetID2CodePage(getCharSetID,FieldCodePage);
4155     FieldType := ftMemo;
4156     end
4157     else
4158     FieldType := ftBlob;
4159     end;
4160     SQL_ARRAY:
4161     begin
4162     FieldSize := sizeof (TISC_QUAD);
4163     FieldType := ftArray;
4164     ArrayMetaData := GetArrayMetaData;
4165     if ArrayMetaData <> nil then
4166     begin
4167     aArrayDimensions := ArrayMetaData.GetDimensions;
4168     aArrayBounds := ArrayMetaData.GetBounds;
4169     end;
4170     end;
4171     SQL_BOOLEAN:
4172     FieldType:= ftBoolean;
4173     else
4174     FieldType := ftUnknown;
4175     end;
4176     FieldPosition := i + 1;
4177     if (FieldType <> ftUnknown) and (FieldAliasName <> 'IBX_INTERNAL_DBKEY') then {do not localize}
4178     begin
4179     FMappedFieldPosition[FieldIndex] := FieldPosition;
4180     Inc(FieldIndex);
4181     with TIBFieldDef.Create(FieldDefs,'',FieldType,0,False,FieldDefs.Count+1) do
4182     begin
4183     Name := FieldAliasName;
4184     FAliasNameMap[FieldNo-1] := DBAliasName;
4185     Size := FieldSize;
4186     DataSize := FieldDataSize;
4187     Precision := FieldPrecision;
4188     Required := not FieldNullable;
4189     RelationName := aRelationName;
4190     InternalCalcField := False;
4191     CharacterSetSize := CharSetSize;
4192     CharacterSetName := CharSetName;
4193     CodePage := FieldCodePage;
4194     ArrayDimensions := aArrayDimensions;
4195     ArrayBounds := aArrayBounds;
4196     if (FieldName <> '') and (RelationName <> '') then
4197     begin
4198     IdentityColumn := Is_IDENTITY_COLUMN(RelationName, FieldName);
4199     if Has_COMPUTED_BLR(RelationName, FieldName) then
4200     begin
4201     Attributes := [faReadOnly];
4202     InternalCalcField := True;
4203     FNeedsRefresh := True;
4204     end
4205     else
4206     begin
4207     if Has_DEFAULT_VALUE(RelationName, FieldName) then
4208     begin
4209     if not FieldNullable then
4210     Attributes := [faRequired];
4211     end
4212     else
4213     FNeedsRefresh := True;
4214     end;
4215     end;
4216     end;
4217     end;
4218     end;
4219     finally
4220     Query.free;
4221     FreeNodes;
4222     Database.InternalTransaction.Commit;
4223     FieldDefs.EndUpdate;
4224     FieldDefs.Updated := true;
4225     end;
4226     end;
4227    
4228     procedure TIBCustomDataSet.InternalInitRecord(Buffer: PChar);
4229     begin
4230     CopyRecordBuffer(FModelBuffer, Buffer);
4231     end;
4232    
4233     procedure TIBCustomDataSet.InternalLast;
4234     var
4235     Buffer: PChar;
4236     begin
4237     if (FQSelect.EOF) then
4238     FCurrentRecord := FRecordCount
4239     else begin
4240     Buffer := AllocRecordBuffer;
4241     try
4242     while FQSelect.Next do
4243     begin
4244     FetchCurrentRecordToBuffer(FQSelect, FRecordCount, Buffer);
4245     Inc(FRecordCount);
4246     end;
4247     FCurrentRecord := FRecordCount;
4248     finally
4249     FreeRecordBuffer(Buffer);
4250     end;
4251     end;
4252     end;
4253    
4254     procedure TIBCustomDataSet.InternalSetParamsFromCursor;
4255     var
4256     i: Integer;
4257     cur_param: ISQLParam;
4258     cur_field: TField;
4259     s: TStream;
4260     begin
4261     if FQSelect.SQL.Text = '' then
4262     IBError(ibxeEmptyQuery, [nil]);
4263     if not FInternalPrepared then
4264     InternalPrepare;
4265     if (SQLParams.GetCount > 0) and (DataSource <> nil) and (DataSource.DataSet <> nil) then
4266     begin
4267     for i := 0 to SQLParams.GetCount - 1 do
4268     begin
4269     cur_field := DataSource.DataSet.FindField(SQLParams[i].Name);
4270     if (cur_field <> nil) then
4271     begin
4272     cur_param := SQLParams[i];
4273     if (cur_field.IsNull) then
4274     cur_param.IsNull := True
4275     else
4276     case cur_field.DataType of
4277     ftString:
4278     cur_param.AsString := cur_field.AsString;
4279     ftBoolean:
4280     cur_param.AsBoolean := cur_field.AsBoolean;
4281     ftSmallint, ftWord:
4282     cur_param.AsShort := cur_field.AsInteger;
4283     ftInteger:
4284     cur_param.AsLong := cur_field.AsInteger;
4285     ftLargeInt:
4286     cur_param.AsInt64 := cur_field.AsLargeInt;
4287     ftFloat, ftCurrency:
4288     cur_param.AsDouble := cur_field.AsFloat;
4289     ftBCD:
4290     cur_param.AsCurrency := cur_field.AsCurrency;
4291     ftDate:
4292     cur_param.AsDate := cur_field.AsDateTime;
4293     ftTime:
4294     cur_param.AsTime := cur_field.AsDateTime;
4295     ftDateTime:
4296     cur_param.AsDateTime := cur_field.AsDateTime;
4297     ftBlob, ftMemo:
4298     begin
4299     s := nil;
4300     try
4301     s := DataSource.DataSet.
4302     CreateBlobStream(cur_field, bmRead);
4303     cur_param.AsBlob := TIBDSBlobStream(s).FBlobStream.Blob;
4304     finally
4305     s.free;
4306     end;
4307     end;
4308     ftArray:
4309     cur_param.AsArray := TIBArrayField(cur_field).ArrayIntf;
4310     else
4311     IBError(ibxeNotSupported, [nil]);
4312     end;
4313     end;
4314     end;
4315     end;
4316     end;
4317    
4318     procedure TIBCustomDataSet.ReQuery;
4319     begin
4320     FQSelect.Close;
4321     ClearBlobCache;
4322     FCurrentRecord := -1;
4323     FRecordCount := 0;
4324     FDeletedRecords := 0;
4325     FBPos := 0;
4326     FOBPos := 0;
4327     FBEnd := 0;
4328     FOBEnd := 0;
4329     FQSelect.Close;
4330     FQSelect.ExecQuery;
4331     FOpen := FQSelect.Open;
4332     First;
4333     end;
4334    
4335     procedure TIBCustomDataSet.InternalOpen;
4336    
4337     function RecordDataLength(n: Integer): Long;
4338     begin
4339     result := SizeOf(TRecordData) + ((n - 1) * SizeOf(TFieldData));
4340     end;
4341    
4342     begin
4343     FBase.SetCursor;
4344     try
4345     ActivateConnection;
4346     ActivateTransaction;
4347     if FQSelect.SQL.Text = '' then
4348     IBError(ibxeEmptyQuery, [nil]);
4349     if not FInternalPrepared then
4350     InternalPrepare;
4351     if FQSelect.Statement <> nil then
4352     FQSelect.Statement.EnableStatistics(FEnableStatistics);
4353     if FQSelect.SQLStatementType = SQLSelect then
4354     begin
4355     if DefaultFields then
4356     CreateFields;
4357     FArrayFieldCount := 0;
4358     BindFields(True);
4359     FCurrentRecord := -1;
4360     FQSelect.ExecQuery;
4361     FOpen := FQSelect.Open;
4362    
4363     { Initialize offsets, buffer sizes, etc...
4364     1. Initially FRecordSize is just the "RecordDataLength".
4365     2. Allocate a "model" buffer and do a dummy fetch
4366     3. After the dummy fetch, FRecordSize will be appropriately
4367     adjusted to reflect the additional "weight" of the field
4368     data.
4369     4. Set up the FCalcFieldsOffset, FBlobCacheOffset, FArrayCacheOffset and FRecordBufferSize.
4370     5. Now, with the BufferSize available, allocate memory for chunks of records
4371     6. Re-allocate the model buffer, accounting for the new
4372     FRecordBufferSize.
4373     7. Finally, calls to AllocRecordBuffer will work!.
4374     }
4375     {Step 1}
4376     FRecordSize := RecordDataLength(FQSelect.FieldCount);
4377     {Step 2, 3}
4378     GetMem(FFieldColumns,sizeof(TFieldColumns) * (FQSelect.FieldCount));
4379     IBAlloc(FModelBuffer, 0, FRecordSize);
4380     InitModelBuffer(FQSelect, FModelBuffer);
4381     {Step 4}
4382     FCalcFieldsOffset := FRecordSize;
4383     FBlobCacheOffset := FCalcFieldsOffset + CalcFieldsSize;
4384     FArrayCacheOffset := (FBlobCacheOffset + (BlobFieldCount * SizeOf(TIBBlobStream)));
4385     FRecordBufferSize := FArrayCacheOffset + (ArrayFieldCount * sizeof(IArray));
4386     {Step 5}
4387     if UniDirectional then
4388     FBufferChunkSize := FRecordBufferSize * UniCache
4389     else
4390     FBufferChunkSize := FRecordBufferSize * BufferChunks;
4391     IBAlloc(FBufferCache, FBufferChunkSize, FBufferChunkSize);
4392     if FCachedUpdates or (csReading in ComponentState) then
4393     IBAlloc(FOldBufferCache, FBufferChunkSize, FBufferChunkSize);
4394     FBPos := 0;
4395     FOBPos := 0;
4396     FBEnd := 0;
4397     FOBEnd := 0;
4398     FCacheSize := FBufferChunkSize;
4399     FOldCacheSize := FBufferChunkSize;
4400     {Step 6}
4401     IBAlloc(FModelBuffer, RecordDataLength(FQSelect.FieldCount),
4402     FRecordBufferSize);
4403     {Step 7}
4404     FOldBuffer := AllocRecordBuffer;
4405     end
4406     else
4407     FQSelect.ExecQuery;
4408     finally
4409     FBase.RestoreCursor;
4410     end;
4411     end;
4412    
4413     procedure TIBCustomDataSet.InternalPost;
4414     var
4415     Qry: TIBSQL;
4416     Buff: PChar;
4417     bInserting: Boolean;
4418     begin
4419     FBase.SetCursor;
4420     try
4421     Buff := GetActiveBuf;
4422     CheckEditState;
4423     AdjustRecordOnInsert(Buff);
4424     if (State = dsInsert) then
4425     begin
4426     bInserting := True;
4427     Qry := FQInsert;
4428     PRecordData(Buff)^.rdUpdateStatus := usInserted;
4429     PRecordData(Buff)^.rdCachedUpdateStatus := cusInserted;
4430     WriteRecordCache(FRecordCount, Buff);
4431     FCurrentRecord := FRecordCount;
4432     end
4433     else begin
4434     bInserting := False;
4435     Qry := FQModify;
4436     if PRecordData(Buff)^.rdCachedUpdateStatus = cusUnmodified then
4437     begin
4438     PRecordData(Buff)^.rdUpdateStatus := usModified;
4439     PRecordData(Buff)^.rdCachedUpdateStatus := cusModified;
4440     end
4441     else if PRecordData(Buff)^.
4442     rdCachedUpdateStatus = cusUninserted then
4443     begin
4444     PRecordData(Buff)^.rdCachedUpdateStatus := cusInserted;
4445     Dec(FDeletedRecords);
4446     end;
4447     end;
4448     if (not CachedUpdates) then
4449     InternalPostRecord(Qry, Buff)
4450     else begin
4451     WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Buff);
4452     FUpdatesPending := True;
4453     end;
4454     if bInserting then
4455     Inc(FRecordCount);
4456     finally
4457     FBase.RestoreCursor;
4458     end;
4459     end;
4460    
4461     procedure TIBCustomDataSet.InternalRefresh;
4462     begin
4463     inherited InternalRefresh;
4464     InternalRefreshRow;
4465     end;
4466    
4467     procedure TIBCustomDataSet.InternalSetToRecord(Buffer: PChar);
4468     begin
4469     InternalGotoBookmark(@(PRecordData(Buffer)^.rdRecordNumber));
4470     end;
4471    
4472     function TIBCustomDataSet.IsCursorOpen: Boolean;
4473     begin
4474     result := FOpen;
4475     end;
4476    
4477     procedure TIBCustomDataSet.Loaded;
4478     begin
4479     if assigned(FQSelect) then
4480     FBaseSQLSelect.assign(FQSelect.SQL);
4481     inherited Loaded;
4482     end;
4483    
4484     procedure TIBCustomDataSet.Post;
4485     var CancelPost: boolean;
4486     begin
4487     CancelPost := false;
4488     if assigned(FOnValidatePost) then
4489     OnValidatePost(self,CancelPost);
4490     if CancelPost then
4491     Cancel
4492     else
4493     inherited Post;
4494     end;
4495    
4496     function TIBCustomDataSet.Locate(const KeyFields: string; const KeyValues: Variant;
4497     Options: TLocateOptions): Boolean;
4498     var
4499     CurBookmark: TBookmark;
4500     begin
4501     DisableControls;
4502     try
4503     CurBookmark := Bookmark;
4504     First;
4505     result := InternalLocate(KeyFields, KeyValues, Options);
4506     if not result then
4507     Bookmark := CurBookmark;
4508     finally
4509     EnableControls;
4510     end;
4511     end;
4512    
4513     function TIBCustomDataSet.Lookup(const KeyFields: string; const KeyValues: Variant;
4514     const ResultFields: string): Variant;
4515     var
4516     fl: TList;
4517     CurBookmark: TBookmark;
4518     begin
4519     DisableControls;
4520     fl := TList.Create;
4521     CurBookmark := Bookmark;
4522     try
4523     First;
4524     if InternalLocate(KeyFields, KeyValues, []) then
4525     begin
4526     if (ResultFields <> '') then
4527     result := FieldValues[ResultFields]
4528     else
4529     result := NULL;
4530     end
4531     else
4532     result := Null;
4533     finally
4534     Bookmark := CurBookmark;
4535     fl.Free;
4536     EnableControls;
4537     end;
4538     end;
4539    
4540     procedure TIBCustomDataSet.SetBookmarkData(Buffer: PChar; Data: Pointer);
4541     begin
4542     PRecordData(Buffer)^.rdRecordNumber := PInteger(Data)^;
4543     end;
4544    
4545     procedure TIBCustomDataSet.SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag);
4546     begin
4547     PRecordData(Buffer)^.rdBookmarkFlag := Value;
4548     end;
4549    
4550     procedure TIBCustomDataSet.SetCachedUpdates(Value: Boolean);
4551     begin
4552     if not Value and FCachedUpdates then
4553     CancelUpdates;
4554     if (not (csReading in ComponentState)) and Value then
4555     CheckDatasetClosed;
4556     FCachedUpdates := Value;
4557     end;
4558    
4559     procedure TIBCustomDataSet.SetDataSource(Value: TDataSource);
4560     begin
4561     if IsLinkedTo(Value) then
4562     IBError(ibxeCircularReference, [nil]);
4563     if FDataLink <> nil then
4564     FDataLink.DataSource := Value;
4565     end;
4566    
4567     procedure TIBCustomDataSet.InternalSetFieldData(Field: TField; Buffer: Pointer);
4568     var
4569     Buff, TmpBuff: PChar;
4570     MappedFieldPos: integer;
4571     begin
4572     Buff := GetActiveBuf;
4573     if Field.FieldNo < 0 then
4574     begin
4575     TmpBuff := Buff + FRecordSize + Field.Offset;
4576     Boolean(TmpBuff[0]) := LongBool(Buffer);
4577     if Boolean(TmpBuff[0]) then
4578     Move(Buffer^, TmpBuff[1], Field.DataSize);
4579     WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Buff);
4580     end
4581     else begin
4582     CheckEditState;
4583     with PRecordData(Buff)^ do
4584     begin
4585     { If inserting, Adjust record position }
4586     AdjustRecordOnInsert(Buff);
4587     MappedFieldPos := FMappedFieldPosition[Field.FieldNo - 1];
4588     if (MappedFieldPos > 0) and
4589     (MappedFieldPos <= rdFieldCount) then
4590     with rdFields[MappedFieldPos], FFieldColumns^[MappedFieldPos] do
4591     begin
4592     Field.Validate(Buffer);
4593     if (Buffer = nil) or
4594     (Field is TIBStringField) and (PChar(Buffer)[0] = #0) then
4595     fdIsNull := True
4596     else
4597     begin
4598     Move(Buffer^, Buff[fdDataOfs],fdDataSize);
4599     if (fdDataType = SQL_TEXT) or (fdDataType = SQL_VARYING) then
4600     fdDataLength := StrLen(PChar(Buffer));
4601     fdIsNull := False;
4602     if rdUpdateStatus = usUnmodified then
4603     begin
4604     if CachedUpdates then
4605     begin
4606     FUpdatesPending := True;
4607     if State = dsInsert then
4608     rdCachedUpdateStatus := cusInserted
4609     else if State = dsEdit then
4610     rdCachedUpdateStatus := cusModified;
4611     end;
4612    
4613     if State = dsInsert then
4614     rdUpdateStatus := usInserted
4615     else
4616     rdUpdateStatus := usModified;
4617     end;
4618     WriteRecordCache(rdRecordNumber, Buff);
4619     SetModified(True);
4620     end;
4621     end;
4622     end;
4623     end;
4624     if not (State in [dsCalcFields, dsFilter, dsNewValue]) then
4625     DataEvent(deFieldChange, PtrInt(Field));
4626     end;
4627    
4628     procedure TIBCustomDataSet.SetRecNo(Value: Integer);
4629     begin
4630     CheckBrowseMode;
4631     if (Value < 1) then
4632     Value := 1
4633     else if Value > FRecordCount then
4634     begin
4635     InternalLast;
4636     Value := Min(FRecordCount, Value);
4637     end;
4638     if (Value <> RecNo) then
4639     begin
4640     DoBeforeScroll;
4641     FCurrentRecord := Value - 1;
4642     Resync([]);
4643     DoAfterScroll;
4644     end;
4645     end;
4646    
4647     procedure TIBCustomDataSet.Disconnect;
4648     begin
4649     Close;
4650     InternalUnPrepare;
4651     end;
4652    
4653     procedure TIBCustomDataSet.SetUpdateMode(const Value: TUpdateMode);
4654     begin
4655     if not CanModify then
4656     IBError(ibxeCannotUpdate, [nil])
4657     else
4658     FUpdateMode := Value;
4659     end;
4660    
4661    
4662     procedure TIBCustomDataSet.SetUpdateObject(Value: TIBDataSetUpdateObject);
4663     begin
4664     if Value <> FUpdateObject then
4665     begin
4666     if Assigned(FUpdateObject) and (FUpdateObject.DataSet = Self) then
4667     FUpdateObject.DataSet := nil;
4668     FUpdateObject := Value;
4669     if Assigned(FUpdateObject) then
4670     begin
4671     if Assigned(FUpdateObject.DataSet) and
4672     (FUpdateObject.DataSet <> Self) then
4673     FUpdateObject.DataSet.UpdateObject := nil;
4674     FUpdateObject.DataSet := Self;
4675     end;
4676     end;
4677     end;
4678    
4679     function TIBCustomDataSet.ConstraintsStored: Boolean;
4680     begin
4681     Result := Constraints.Count > 0;
4682     end;
4683    
4684     procedure TIBCustomDataSet.ClearCalcFields(Buffer: PChar);
4685     begin
4686     FillChar(Buffer[FRecordSize], CalcFieldsSize, 0);
4687     end;
4688    
4689     procedure TIBCustomDataSet.ClearIBLinks;
4690     var i: integer;
4691     begin
4692     for i := FIBLinks.Count - 1 downto 0 do
4693     TIBControlLink(FIBLinks[i]).IBDataSet := nil;
4694     end;
4695    
4696    
4697     procedure TIBCustomDataSet.InternalUnPrepare;
4698     begin
4699     if FInternalPrepared then
4700     begin
4701     CheckDatasetClosed;
4702     if FDidActivate then
4703     DeactivateTransaction;
4704     FieldDefs.Clear;
4705     FieldDefs.Updated := false;
4706     FInternalPrepared := False;
4707     Setlength(FAliasNameList,0);
4708     end;
4709     end;
4710    
4711     procedure TIBCustomDataSet.InternalExecQuery;
4712     var
4713     DidActivate: Boolean;
4714     begin
4715     DidActivate := False;
4716     FBase.SetCursor;
4717     try
4718     ActivateConnection;
4719     DidActivate := ActivateTransaction;
4720     if FQSelect.SQL.Text = '' then
4721     IBError(ibxeEmptyQuery, [nil]);
4722     if not FInternalPrepared then
4723     InternalPrepare;
4724     if FQSelect.SQLStatementType = SQLSelect then
4725     begin
4726     IBError(ibxeIsASelectStatement, [nil]);
4727     end
4728     else
4729     FQSelect.ExecQuery;
4730     finally
4731     if DidActivate then
4732     DeactivateTransaction;
4733     FBase.RestoreCursor;
4734     end;
4735     end;
4736    
4737     function TIBCustomDataSet.GetSelectStmtIntf: IStatement;
4738     begin
4739     Result := FQSelect.Statement;
4740     end;
4741    
4742     procedure TIBCustomDataSet.SetMasterDetailDelay(AValue: integer);
4743     begin
4744     FDataLink.DelayTimerValue := AValue;
4745     end;
4746    
4747     function TIBCustomDataSet.GetParser: TSelectSQLParser;
4748     begin
4749     if not assigned(FParser) then
4750     FParser := CreateParser;
4751     Result := FParser
4752     end;
4753    
4754     procedure TIBCustomDataSet.ResetParser;
4755     begin
4756     if assigned(FParser) then
4757     begin
4758     FParser.Free;
4759     FParser := nil;
4760     FQSelect.OnSQLChanged := nil; {Do not react to change}
4761     try
4762     FQSelect.SQL.Assign(FBaseSQLSelect);
4763     finally
4764     FQSelect.OnSQLChanged := SQLChanged;
4765     end;
4766     end;
4767     end;
4768    
4769     function TIBCustomDataSet.HasParser: boolean;
4770     begin
4771     Result := not (csDesigning in ComponentState) and (FParser <> nil)
4772     end;
4773    
4774     procedure TIBCustomDataSet.SetGenerateParamNames(AValue: Boolean);
4775     begin
4776     if FGenerateParamNames = AValue then Exit;
4777     FGenerateParamNames := AValue;
4778     Disconnect
4779     end;
4780    
4781     procedure TIBCustomDataSet.InitRecord(Buffer: PChar);
4782     begin
4783     inherited InitRecord(Buffer);
4784     with PRecordData(Buffer)^ do
4785     begin
4786     rdUpdateStatus := TUpdateStatus(usInserted);
4787     rdBookMarkFlag := bfInserted;
4788     rdRecordNumber := -1;
4789     end;
4790     end;
4791    
4792     procedure TIBCustomDataSet.InternalInsert;
4793     begin
4794     CursorPosChanged;
4795     end;
4796    
4797     { TIBDataSet IProviderSupport }
4798    
4799     procedure TIBCustomDataSet.PSEndTransaction(Commit: Boolean);
4800     begin
4801     if Commit then
4802     Transaction.Commit else
4803     Transaction.Rollback;
4804     end;
4805    
4806     function TIBCustomDataSet.PSExecuteStatement(const ASQL: string; AParams: TParams;
4807     ResultSet: Pointer = nil): Integer;
4808     var
4809     FQuery: TIBQuery;
4810     begin
4811     if Assigned(ResultSet) then
4812     begin
4813     TDataSet(ResultSet^) := TIBQuery.Create(nil);
4814     with TIBQuery(ResultSet^) do
4815     begin
4816     SQL.Text := ASQL;
4817     Params.Assign(AParams);
4818     Open;
4819     Result := RowsAffected;
4820     end;
4821     end
4822     else
4823     begin
4824     FQuery := TIBQuery.Create(nil);
4825     try
4826     FQuery.Database := Database;
4827     FQuery.Transaction := Transaction;
4828     FQuery.GenerateParamNames := True;
4829     FQuery.SQL.Text := ASQL;
4830     FQuery.Params.Assign(AParams);
4831     FQuery.ExecSQL;
4832     Result := FQuery.RowsAffected;
4833     finally
4834     FQuery.Free;
4835     end;
4836     end;
4837     end;
4838    
4839     function TIBCustomDataSet.PSGetQuoteChar: string;
4840     begin
4841     if Database.SQLDialect = 3 then
4842     Result := '"' else
4843     Result := '';
4844     end;
4845    
4846     function TIBCustomDataSet.PSGetUpdateException(E: Exception; Prev: EUpdateError): EUpdateError;
4847     var
4848     PrevErr: Integer;
4849     begin
4850     if Prev <> nil then
4851     PrevErr := Prev.ErrorCode else
4852     PrevErr := 0;
4853     if E is EIBError then
4854     with EIBError(E) do
4855     Result := EUpdateError.Create(E.Message, '', SQLCode, PrevErr, E) else
4856     Result := inherited PSGetUpdateException(E, Prev);
4857     end;
4858    
4859     function TIBCustomDataSet.PSInTransaction: Boolean;
4860     begin
4861     Result := Transaction.InTransaction;
4862     end;
4863    
4864     function TIBCustomDataSet.PSIsSQLBased: Boolean;
4865     begin
4866     Result := True;
4867     end;
4868    
4869     function TIBCustomDataSet.PSIsSQLSupported: Boolean;
4870     begin
4871     Result := True;
4872     end;
4873    
4874     procedure TIBCustomDataSet.PSReset;
4875     begin
4876     inherited PSReset;
4877     if Active then
4878     begin
4879     Close;
4880     Open;
4881     end;
4882     end;
4883    
4884     function TIBCustomDataSet.PSUpdateRecord(UpdateKind: TUpdateKind; Delta: TDataSet): Boolean;
4885     var
4886     UpdateAction: TIBUpdateAction;
4887     SQL: string;
4888     Params: TParams;
4889    
4890     procedure AssignParams(DataSet: TDataSet; Params: TParams);
4891     var
4892     I: Integer;
4893     Old: Boolean;
4894     Param: TParam;
4895     PName: string;
4896     Field: TField;
4897     Value: Variant;
4898     begin
4899     for I := 0 to Params.Count - 1 do
4900     begin
4901     Param := Params[I];
4902     PName := Param.Name;
4903     Old := CompareText(Copy(PName, 1, 4), 'OLD_') = 0; {do not localize}
4904     if Old then System.Delete(PName, 1, 4);
4905     Field := DataSet.FindField(PName);
4906     if not Assigned(Field) then Continue;
4907     if Old then Param.AssignFieldValue(Field, Field.OldValue) else
4908     begin
4909     Value := Field.NewValue;
4910     if VarIsEmpty(Value) then Value := Field.OldValue;
4911     Param.AssignFieldValue(Field, Value);
4912     end;
4913     end;
4914     end;
4915    
4916     begin
4917     Result := False;
4918     if Assigned(OnUpdateRecord) then
4919     begin
4920     UpdateAction := uaFail;
4921     if Assigned(FOnUpdateRecord) then
4922     begin
4923     FOnUpdateRecord(Delta, UpdateKind, UpdateAction);
4924     Result := UpdateAction = uaApplied;
4925     end;
4926     end
4927     else if Assigned(FUpdateObject) then
4928     begin
4929     SQL := FUpdateObject.GetSQL(UpdateKind).Text;
4930     if SQL <> '' then
4931     begin
4932     Params := TParams.Create;
4933     try
4934     Params.ParseSQL(SQL, True);
4935     AssignParams(Delta, Params);
4936     if PSExecuteStatement(SQL, Params) = 0 then
4937     IBError(ibxeNoRecordsAffected, [nil]);
4938     Result := True;
4939     finally
4940     Params.Free;
4941     end;
4942     end;
4943     end;
4944     end;
4945    
4946     procedure TIBCustomDataSet.PSStartTransaction;
4947     begin
4948     ActivateConnection;
4949     Transaction.StartTransaction;
4950     end;
4951    
4952     function TIBCustomDataSet.PsGetTableName: string;
4953     begin
4954     // if not FInternalPrepared then
4955     // InternalPrepare;
4956     { It is possible for the FQSelectSQL to be unprepared
4957     with FInternalPreprepared being true (see DoBeforeTransactionEnd).
4958     So check the Prepared of the SelectSQL instead }
4959     if not FQSelect.Prepared then
4960     FQSelect.Prepare;
4961     Result := FQSelect.UniqueRelationName;
4962     end;
4963    
4964     procedure TIBDataSet.BatchInput(InputObject: TIBBatchInput);
4965     begin
4966     InternalBatchInput(InputObject);
4967     end;
4968    
4969     procedure TIBDataSet.BatchOutput(OutputObject: TIBBatchOutput);
4970     begin
4971     InternalBatchOutput(OutputObject);
4972     end;
4973    
4974     procedure TIBDataSet.ExecSQL;
4975     begin
4976     InternalExecQuery;
4977     end;
4978    
4979     procedure TIBDataSet.Prepare;
4980     begin
4981     InternalPrepare;
4982     end;
4983    
4984     procedure TIBDataSet.UnPrepare;
4985     begin
4986     InternalUnPrepare;
4987     end;
4988    
4989     function TIBDataSet.GetPrepared: Boolean;
4990     begin
4991     Result := InternalPrepared;
4992     end;
4993    
4994     procedure TIBDataSet.InternalOpen;
4995     begin
4996     ActivateConnection;
4997     ActivateTransaction;
4998     InternalSetParamsFromCursor;
4999     Inherited InternalOpen;
5000     end;
5001    
5002     procedure TIBDataSet.SetFiltered(Value: Boolean);
5003     begin
5004     if(Filtered <> Value) then
5005     begin
5006     inherited SetFiltered(value);
5007     if Active then
5008     begin
5009     Close;
5010     Open;
5011     end;
5012     end
5013     else
5014     inherited SetFiltered(value);
5015     end;
5016    
5017     function TIBCustomDataSet.BookmarkValid(Bookmark: TBookmark): Boolean;
5018     begin
5019     Result := false;
5020     if not Assigned(Bookmark) then
5021     exit;
5022     Result := PInteger(Bookmark)^ < FRecordCount;
5023     end;
5024    
5025     function TIBCustomDataSet.GetFieldData(Field: TField;
5026     Buffer: Pointer): Boolean;
5027     {$IFDEF TBCDFIELD_IS_BCD}
5028     var
5029     lTempCurr : System.Currency;
5030     begin
5031     if (Field.DataType = ftBCD) and (Buffer <> nil) then
5032     begin
5033     Result := InternalGetFieldData(Field, @lTempCurr);
5034     if Result then
5035     CurrToBCD(lTempCurr, TBCD(Buffer^), 32, Field.Size);
5036     end
5037     else
5038     {$ELSE}
5039     begin
5040     {$ENDIF}
5041     Result := InternalGetFieldData(Field, Buffer);
5042     end;
5043    
5044     function TIBCustomDataSet.GetFieldData(Field: TField; Buffer: Pointer;
5045     NativeFormat: Boolean): Boolean;
5046     begin
5047     {These datatypes use IBX conventions and not TDataset conventions}
5048     if (Field.DataType in [ftBCD,ftDateTime,ftDate,ftTime]) and not NativeFormat then
5049     Result := InternalGetFieldData(Field, Buffer)
5050     else
5051     Result := inherited GetFieldData(Field, Buffer, NativeFormat);
5052     end;
5053    
5054     procedure TIBCustomDataSet.SetFieldData(Field: TField; Buffer: Pointer);
5055     {$IFDEF TDBDFIELD_IS_BCD}
5056     var
5057     lTempCurr : System.Currency;
5058     begin
5059     if (Field.DataType = ftBCD) and (Buffer <> nil) then
5060     begin
5061     BCDToCurr(TBCD(Buffer^), lTempCurr);
5062     InternalSetFieldData(Field, @lTempCurr);
5063     end
5064     else
5065     {$ELSE}
5066     begin
5067     {$ENDIF}
5068     InternalSetFieldData(Field, Buffer);
5069     end;
5070    
5071     procedure TIBCustomDataSet.SetFieldData(Field: TField; Buffer: Pointer;
5072     NativeFormat: Boolean);
5073     begin
5074     {These datatypes use IBX conventions and not TDataset conventions}
5075     if (not NativeFormat) and (Field.DataType in [ftBCD,ftDateTime,ftDate,ftTime]) then
5076     InternalSetfieldData(Field, Buffer)
5077     else
5078     inherited SetFieldData(Field, buffer, NativeFormat);
5079     end;
5080    
5081     { TIBDataSetUpdateObject }
5082    
5083     constructor TIBDataSetUpdateObject.Create(AOwner: TComponent);
5084     begin
5085     inherited Create(AOwner);
5086     FRefreshSQL := TStringList.Create;
5087     end;
5088    
5089     destructor TIBDataSetUpdateObject.Destroy;
5090     begin
5091     FRefreshSQL.Free;
5092     inherited Destroy;
5093     end;
5094    
5095     function TIBDataSetUpdateObject.GetRowsAffected(
5096     var SelectCount, InsertCount, UpdateCount, DeleteCount: integer): boolean;
5097     begin
5098     SelectCount := 0;
5099     InsertCount := 0;
5100     UpdateCount := 0;
5101     DeleteCount := 0;
5102     end;
5103    
5104     procedure TIBDataSetUpdateObject.SetRefreshSQL(value: TStrings);
5105     begin
5106     FRefreshSQL.Assign(Value);
5107     end;
5108    
5109     procedure TIBDataSetUpdateObject.InternalSetParams(Params: ISQLParams;
5110     buff: PChar);
5111     begin
5112     if not Assigned(DataSet) then Exit;
5113     DataSet.SetInternalSQLParams(Params, buff);
5114     end;
5115    
5116     procedure TIBDataSetUpdateObject.InternalSetParams(Query: TIBSQL; buff: PChar);
5117     begin
5118     InternalSetParams(Query.Params,buff);
5119     end;
5120    
5121     procedure TIBDataSetUpdateObject.UpdateRecordFromQuery(UpdateKind: TUpdateKind;
5122     QryResults: IResults; Buffer: PChar);
5123     begin
5124     if not Assigned(DataSet) then Exit;
5125     case UpdateKind of
5126     ukModify, ukInsert:
5127     DataSet.UpdateRecordFromQuery(QryResults, Buffer);
5128     ukDelete:
5129     DataSet.DoDeleteReturning(QryResults);
5130     end;
5131     end;
5132    
5133     function TIBDSBlobStream.GetSize: Int64;
5134     begin
5135     Result := FBlobStream.BlobSize;
5136     end;
5137    
5138     { TIBDSBlobStream }
5139     constructor TIBDSBlobStream.Create(AField: TField; ABlobStream: TIBBlobStream;
5140     Mode: TBlobStreamMode);
5141     begin
5142     FField := AField;
5143     FBlobStream := ABlobStream;
5144     FBlobStream.Seek(0, soFromBeginning);
5145     if (Mode = bmWrite) then
5146     begin
5147     FBlobStream.Truncate;
5148     TIBCustomDataSet(FField.DataSet).RecordModified(True);
5149     TBlobField(FField).Modified := true;
5150     FHasWritten := true;
5151     end;
5152     end;
5153    
5154     destructor TIBDSBlobStream.Destroy;
5155     begin
5156     if FHasWritten then
5157     TIBCustomDataSet(FField.DataSet).DataEvent(deFieldChange, PtrInt(FField));
5158     inherited Destroy;
5159     end;
5160    
5161     function TIBDSBlobStream.Read(var Buffer; Count: Longint): Longint;
5162     begin
5163     result := FBlobStream.Read(Buffer, Count);
5164     end;
5165    
5166     function TIBDSBlobStream.Seek(Offset: Longint; Origin: Word): Longint;
5167     begin
5168     result := FBlobStream.Seek(Offset, Origin);
5169     end;
5170    
5171     procedure TIBDSBlobStream.SetSize(NewSize: Longint);
5172     begin
5173     FBlobStream.SetSize(NewSize);
5174     end;
5175    
5176     function TIBDSBlobStream.Write(const Buffer; Count: Longint): Longint;
5177     begin
5178     if not (FField.DataSet.State in [dsEdit, dsInsert]) then
5179     IBError(ibxeNotEditing, [nil]);
5180     TIBCustomDataSet(FField.DataSet).RecordModified(True);
5181     TBlobField(FField).Modified := true;
5182     result := FBlobStream.Write(Buffer, Count);
5183     FHasWritten := true;
5184     { TIBCustomDataSet(FField.DataSet).DataEvent(deFieldChange, PtrInt(FField));
5185     Removed as this caused a seek to beginning of the blob stream thus corrupting
5186     the blob stream. Moved to the destructor i.e. called after blob written}
5187     end;
5188    
5189     { TIBGenerator }
5190    
5191     procedure TIBGenerator.SetIncrement(const AValue: integer);
5192     begin
5193     if FIncrement = AValue then Exit;
5194     if AValue < 0 then
5195     IBError(ibxeNegativeGenerator,[]);
5196     FIncrement := AValue;
5197     SetQuerySQL;
5198     end;
5199    
5200     procedure TIBGenerator.SetTransaction(AValue: TIBTransaction);
5201     begin
5202     FQuery.Transaction := AValue;
5203     end;
5204    
5205     procedure TIBGenerator.SetQuerySQL;
5206     begin
5207     FQuery.SQL.Text := Format('Select Gen_ID(%s,%d) From RDB$Database',[FGeneratorName,Increment]);
5208     end;
5209    
5210     function TIBGenerator.GetDatabase: TIBDatabase;
5211     begin
5212     Result := FQuery.Database;
5213     end;
5214    
5215     function TIBGenerator.GetTransaction: TIBTransaction;
5216     begin
5217     Result := FQuery.Transaction;
5218     end;
5219    
5220     procedure TIBGenerator.SetDatabase(AValue: TIBDatabase);
5221     begin
5222     FQuery.Database := AValue;
5223     end;
5224    
5225     procedure TIBGenerator.SetGeneratorName(AValue: string);
5226     begin
5227     if FGeneratorName = AValue then Exit;
5228     FGeneratorName := AValue;
5229     SetQuerySQL;
5230     end;
5231    
5232     function TIBGenerator.GetNextValue: integer;
5233     begin
5234     with FQuery do
5235     begin
5236     Transaction.Active := true;
5237     ExecQuery;
5238     try
5239     Result := Fields[0].AsInteger
5240     finally
5241     Close
5242     end;
5243     end;
5244     end;
5245    
5246     constructor TIBGenerator.Create(Owner: TIBCustomDataSet);
5247     begin
5248     FOwner := Owner;
5249     FIncrement := 1;
5250     FQuery := TIBSQL.Create(nil);
5251     end;
5252    
5253     destructor TIBGenerator.Destroy;
5254     begin
5255     if assigned(FQuery) then FQuery.Free;
5256     inherited Destroy;
5257     end;
5258    
5259    
5260     procedure TIBGenerator.Apply;
5261     begin
5262     if assigned(Database) and assigned(Transaction) and
5263     (FGeneratorName <> '') and (FFieldName <> '') and Owner.FieldByName(FFieldName).IsNull then
5264     Owner.FieldByName(FFieldName).AsInteger := GetNextValue;
5265     end;
5266    
5267    
5268     end.