ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/IBCustomDataSet.pas
Revision: 118
Committed: Mon Jan 22 13:58:14 2018 UTC (6 years, 2 months ago) by tony
Content type: text/x-pascal
File size: 147640 byte(s)
Log Message:
Fixes Merged

File Contents

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