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