ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/nongui/IBCustomDataSet.pas
Revision: 272
Committed: Mon Feb 4 13:34:37 2019 UTC (5 years, 1 month ago) by tony
Content type: text/x-pascal
File size: 152860 byte(s)
Log Message:
Fixes merged

File Contents

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