ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/journaling/runtime/nongui/IBCustomDataSet.pas
Revision: 291
Committed: Fri Apr 17 10:26:08 2020 UTC (3 years, 11 months ago) by tony
Content type: text/x-pascal
Original Path: ibx/trunk/runtime/nongui/IBCustomDataSet.pas
File size: 152993 byte(s)
Log Message:
Changed for 2.3.4 merged into public release

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 tony 291 uses Variants, FmtBCD, LazUTF8, IBMessages, IBQuery;
977 tony 209
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 tony 291 inherited SetUniDirectional(Value);
3029 tony 209 end;
3030    
3031     procedure TIBCustomDataSet.SetUpdateRecordTypes(Value: TIBUpdateRecordTypes);
3032     begin
3033     FUpdateRecordTypes := Value;
3034     if Active then
3035     First;
3036     end;
3037    
3038     procedure TIBCustomDataSet.RefreshParams;
3039     var
3040     DataSet: TDataSet;
3041     begin
3042     DisableControls;
3043     try
3044     if FDataLink.DataSource <> nil then
3045     begin
3046     DataSet := FDataLink.DataSource.DataSet;
3047     if DataSet <> nil then
3048     if DataSet.Active and (DataSet.State <> dsSetKey) then
3049     begin
3050     Close;
3051     Open;
3052     end;
3053     end;
3054     finally
3055     EnableControls;
3056     end;
3057     end;
3058    
3059     procedure TIBCustomDataSet.RegisterIBLink(Sender: TIBControlLink);
3060     begin
3061     if FIBLinks.IndexOf(Sender) = -1 then
3062     begin
3063     FIBLinks.Add(Sender);
3064     if Active then
3065     begin
3066     Active := false;
3067     Active := true;
3068     end;
3069     end;
3070     end;
3071    
3072    
3073     procedure TIBCustomDataSet.SQLChanging(Sender: TObject);
3074     begin
3075     Active := false;
3076     { if FOpen then
3077     InternalClose;}
3078     if FInternalPrepared then
3079     InternalUnPrepare;
3080     FieldDefs.Clear;
3081     FieldDefs.Updated := false;
3082     end;
3083    
3084     procedure TIBCustomDataSet.SQLChanged(Sender: TObject);
3085     begin
3086     FBaseSQLSelect.assign(FQSelect.SQL);
3087     end;
3088    
3089     { I can "undelete" uninserted records (make them "inserted" again).
3090     I can "undelete" cached deleted (the deletion hasn't yet occurred) }
3091     procedure TIBCustomDataSet.Undelete;
3092     var
3093     Buff: PRecordData;
3094     begin
3095     CheckActive;
3096     Buff := PRecordData(GetActiveBuf);
3097     with Buff^ do
3098     begin
3099     if rdCachedUpdateStatus = cusUninserted then
3100     begin
3101     rdCachedUpdateStatus := cusInserted;
3102     Dec(FDeletedRecords);
3103     end
3104     else if (rdUpdateStatus = usDeleted) and
3105     (rdCachedUpdateStatus = cusDeleted) then
3106     begin
3107     rdCachedUpdateStatus := cusUnmodified;
3108     rdUpdateStatus := usUnmodified;
3109     Dec(FDeletedRecords);
3110     end;
3111     WriteRecordCache(rdRecordNumber, PChar(Buff));
3112     end;
3113     end;
3114    
3115     procedure TIBCustomDataSet.UnRegisterIBLink(Sender: TIBControlLink);
3116     begin
3117     FIBLinks.Remove(Sender);
3118     end;
3119    
3120     function TIBCustomDataSet.UpdateStatus: TUpdateStatus;
3121     begin
3122     if Active then
3123     if GetActiveBuf <> nil then
3124     result := PRecordData(GetActiveBuf)^.rdUpdateStatus
3125     else
3126     result := usUnmodified
3127     else
3128     result := usUnmodified;
3129     end;
3130    
3131     function TIBCustomDataSet.IsSequenced: Boolean;
3132     begin
3133     Result := Assigned( FQSelect ) and FQSelect.EOF;
3134     end;
3135    
3136     function TIBCustomDataSet.ParamByName(ParamName: String): ISQLParam;
3137     begin
3138 tony 272 Result := FindParam(ParamName);
3139     if Result = nil then
3140     IBError(ibxeParameterNameNotFound,[ParamName]);
3141     end;
3142    
3143     function TIBCustomDataSet.FindParam(ParamName: String): ISQLParam;
3144     begin
3145 tony 209 ActivateConnection;
3146     ActivateTransaction;
3147     if not FInternalPrepared then
3148     InternalPrepare;
3149     Result := Params.ByName(ParamName);
3150     end;
3151    
3152     function TIBCustomDataSet.GetRowsAffected(var SelectCount, InsertCount,
3153     UpdateCount, DeleteCount: integer): boolean;
3154     begin
3155     Result := Active;
3156     SelectCount := FSelectCount;
3157     InsertCount := FInsertCount;
3158     UpdateCount := FUpdateCount;
3159     DeleteCount := FDeleteCount;
3160     end;
3161    
3162     function TIBCustomDataSet.GetPerfStatistics(var stats: TPerfCounters): boolean;
3163     begin
3164     Result := EnableStatistics and (FQSelect.Statement <> nil) and
3165     FQSelect.Statement.GetPerfStatistics(stats);
3166     end;
3167    
3168     {Beware: the parameter FCache is used as an identifier to determine which
3169     cache is being operated on and is not referenced in the computation.
3170     The result is an adjusted offset into the identified cache, either the
3171     Buffer Cache or the old Buffer Cache.}
3172    
3173     function TIBCustomDataSet.AdjustPosition(FCache: PChar; Offset: DWORD;
3174     Origin: Integer): DWORD;
3175     var
3176     OldCacheSize: Integer;
3177     begin
3178     if (FCache = FBufferCache) then
3179     begin
3180     case Origin of
3181     FILE_BEGIN: FBPos := Offset;
3182     FILE_CURRENT: FBPos := FBPos + Offset;
3183     FILE_END: FBPos := DWORD(FBEnd) + Offset;
3184     end;
3185     OldCacheSize := FCacheSize;
3186     while (FBPos >= DWORD(FCacheSize)) do
3187     Inc(FCacheSize, FBufferChunkSize);
3188     if FCacheSize > OldCacheSize then
3189     IBAlloc(FBufferCache, FCacheSize, FCacheSize);
3190     result := FBPos;
3191     end
3192     else begin
3193     case Origin of
3194     FILE_BEGIN: FOBPos := Offset;
3195     FILE_CURRENT: FOBPos := FOBPos + Offset;
3196     FILE_END: FOBPos := DWORD(FOBEnd) + Offset;
3197     end;
3198     OldCacheSize := FOldCacheSize;
3199     while (FBPos >= DWORD(FOldCacheSize)) do
3200     Inc(FOldCacheSize, FBufferChunkSize);
3201     if FOldCacheSize > OldCacheSize then
3202     IBAlloc(FOldBufferCache, FOldCacheSize, FOldCacheSize);
3203     result := FOBPos;
3204     end;
3205     end;
3206    
3207     procedure TIBCustomDataSet.ReadCache(FCache: PChar; Offset: DWORD; Origin: Integer;
3208     Buffer: PChar);
3209     var
3210     pCache: PChar;
3211     AdjustedOffset: DWORD;
3212     bOld: Boolean;
3213     begin
3214     bOld := (FCache = FOldBufferCache);
3215     AdjustedOffset := AdjustPosition(FCache, Offset, Origin);
3216     if not bOld then
3217     pCache := FBufferCache + AdjustedOffset
3218     else
3219     pCache := FOldBufferCache + AdjustedOffset;
3220     Move(pCache^, Buffer^, DWORD(FRecordBufferSize));
3221     AdjustPosition(FCache, FRecordBufferSize, FILE_CURRENT);
3222     end;
3223    
3224     procedure TIBCustomDataSet.ReadRecordCache(RecordNumber: Integer; Buffer: PChar;
3225     ReadOldBuffer: Boolean);
3226     begin
3227     if FUniDirectional then
3228     RecordNumber := RecordNumber mod UniCache;
3229     if (ReadOldBuffer) then
3230     begin
3231     ReadRecordCache(RecordNumber, Buffer, False);
3232     if FCachedUpdates and
3233     (PRecordData(Buffer)^.rdSavedOffset <> $FFFFFFFF) then
3234     ReadCache(FOldBufferCache, PRecordData(Buffer)^.rdSavedOffset, FILE_BEGIN,
3235     Buffer)
3236     else
3237     if ReadOldBuffer and
3238     (PRecordData(FOldBuffer)^.rdRecordNumber = RecordNumber) then
3239     CopyRecordBuffer( FOldBuffer, Buffer )
3240     end
3241     else
3242     ReadCache(FBufferCache, RecordNumber * FRecordBufferSize, FILE_BEGIN, Buffer);
3243     end;
3244    
3245     procedure TIBCustomDataSet.WriteCache(FCache: PChar; Offset: DWORD; Origin: Integer;
3246     Buffer: PChar);
3247     var
3248     pCache: PChar;
3249     AdjustedOffset: DWORD;
3250     bOld: Boolean;
3251     dwEnd: DWORD;
3252     begin
3253     bOld := (FCache = FOldBufferCache);
3254     AdjustedOffset := AdjustPosition(FCache, Offset, Origin);
3255     if not bOld then
3256     pCache := FBufferCache + AdjustedOffset
3257     else
3258     pCache := FOldBufferCache + AdjustedOffset;
3259     Move(Buffer^, pCache^, FRecordBufferSize);
3260     dwEnd := AdjustPosition(FCache, FRecordBufferSize, FILE_CURRENT);
3261     if not bOld then
3262     begin
3263     if (dwEnd > FBEnd) then
3264     FBEnd := dwEnd;
3265     end
3266     else begin
3267     if (dwEnd > FOBEnd) then
3268     FOBEnd := dwEnd;
3269     end;
3270     end;
3271    
3272     procedure TIBCustomDataSet.WriteRecordCache(RecordNumber: Integer; Buffer: PChar);
3273     begin
3274     if RecordNumber >= 0 then
3275     begin
3276     if FUniDirectional then
3277     RecordNumber := RecordNumber mod UniCache;
3278     WriteCache(FBufferCache, RecordNumber * FRecordBufferSize, FILE_BEGIN, Buffer);
3279     end;
3280     end;
3281    
3282     function TIBCustomDataSet.AllocRecordBuffer: PChar;
3283     begin
3284     result := nil;
3285     IBAlloc(result, FRecordBufferSize, FRecordBufferSize);
3286     Move(FModelBuffer^, result^, FRecordBufferSize);
3287     end;
3288    
3289     function TIBCustomDataSet.CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream;
3290     var
3291     pb: PBlobDataArray;
3292     fs: TIBBlobStream;
3293     Buff: PChar;
3294     bTr, bDB: Boolean;
3295     begin
3296     if (Field = nil) or (Field.DataSet <> self) then
3297     IBError(ibxFieldNotinDataSet,[Field.Name,Name]);
3298     Buff := GetActiveBuf;
3299     if Buff = nil then
3300     begin
3301     fs := TIBBlobStream.Create;
3302     fs.Mode := bmReadWrite;
3303     fs.Database := Database;
3304     fs.Transaction := Transaction;
3305     fs.SetField(Field);
3306     FBlobStreamList.Add(Pointer(fs));
3307     result := TIBDSBlobStream.Create(Field, fs, Mode);
3308     exit;
3309     end;
3310     pb := PBlobDataArray(Buff + FBlobCacheOffset);
3311     if pb^[Field.Offset] = nil then
3312     begin
3313     AdjustRecordOnInsert(Buff);
3314     pb^[Field.Offset] := TIBBlobStream.Create;
3315     fs := pb^[Field.Offset];
3316     FBlobStreamList.Add(Pointer(fs));
3317     fs.Mode := bmReadWrite;
3318     fs.Database := Database;
3319     fs.Transaction := Transaction;
3320     fs.SetField(Field);
3321     fs.BlobID :=
3322     PISC_QUAD(@Buff[FFieldColumns^[FMappedFieldPosition[Field.FieldNo - 1]].fdDataOfs])^;
3323     if (CachedUpdates) then
3324     begin
3325     bTr := not Transaction.InTransaction;
3326     bDB := not Database.Connected;
3327     if bDB then
3328     Database.Open;
3329     if bTr then
3330     Transaction.StartTransaction;
3331     fs.Seek(0, soFromBeginning);
3332     if bTr then
3333     Transaction.Commit;
3334     if bDB then
3335     Database.Close;
3336     end;
3337     WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Pointer(Buff));
3338     end else
3339     fs := pb^[Field.Offset];
3340     result := TIBDSBlobStream.Create(Field, fs, Mode);
3341     end;
3342    
3343     function TIBCustomDataSet.GetArray(Field: TIBArrayField): IArray;
3344     var Buff: PChar;
3345     pda: PArrayDataArray;
3346     bTr, bDB: Boolean;
3347     begin
3348     if (Field = nil) or (Field.DataSet <> self) then
3349     IBError(ibxFieldNotinDataSet,[Field.Name,Name]);
3350     Buff := GetActiveBuf;
3351     if Buff = nil then
3352     Result := Database.Attachment.CreateArray(Transaction.TransactionIntf,
3353     Field.FRelationName,Field.FieldName)
3354     else
3355     begin
3356     pda := PArrayDataArray(Buff + FArrayCacheOffset);
3357     if pda^[Field.FCacheOffset] = nil then
3358     begin
3359     AdjustRecordOnInsert(Buff);
3360     if Field.IsNull then
3361     Result := Database.Attachment.CreateArray(Transaction.TransactionIntf,
3362     Field.FRelationName,Field.FieldName)
3363     else
3364     Result := Database.Attachment.OpenArray(Transaction.TransactionIntf,
3365     Field.FRelationName,Field.FieldName,Field.ArrayID);
3366     pda^[Field.FCacheOffset] := TIBArray.Create(Field,Result);
3367     FArrayList.Add(pda^[Field.FCacheOffset]);
3368     if (CachedUpdates) then
3369     begin
3370     bTr := not Transaction.InTransaction;
3371     bDB := not Database.Connected;
3372     if bDB then
3373     Database.Open;
3374     if bTr then
3375     Transaction.StartTransaction;
3376     pda^[Field.FCacheOffset].ArrayIntf.PreLoad;
3377     if bTr then
3378     Transaction.Commit;
3379     if bDB then
3380     Database.Close;
3381     end;
3382     WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Pointer(Buff));
3383     end
3384     else
3385     Result := pda^[Field.FCacheOffset].ArrayIntf;
3386     end;
3387     end;
3388    
3389     procedure TIBCustomDataSet.SetArrayIntf(AnArray: IArray; Field: TIBArrayField);
3390     var Buff: PChar;
3391     pda: PArrayDataArray;
3392     begin
3393     if (Field = nil) or (Field.DataSet <> self) then
3394     IBError(ibxFieldNotinDataSet,[Field.Name,Name]);
3395     Buff := GetActiveBuf;
3396     if Buff <> nil then
3397     begin
3398     AdjustRecordOnInsert(Buff);
3399     pda := PArrayDataArray(Buff + FArrayCacheOffset);
3400     pda^[Field.FCacheOffset].FArray := AnArray;
3401     WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Pointer(Buff));
3402     end;
3403     end;
3404    
3405     function TIBCustomDataSet.CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Integer;
3406     const
3407     CMPLess = -1;
3408     CMPEql = 0;
3409     CMPGtr = 1;
3410     RetCodes: array[Boolean, Boolean] of ShortInt = ((2, CMPLess),
3411     (CMPGtr, CMPEql));
3412     begin
3413     result := RetCodes[Bookmark1 = nil, Bookmark2 = nil];
3414    
3415     if Result = 2 then
3416     begin
3417     if PInteger(Bookmark1)^ < PInteger(Bookmark2)^ then
3418     Result := CMPLess
3419     else
3420     if PInteger(Bookmark1)^ > PInteger(Bookmark2)^ then
3421     Result := CMPGtr
3422     else
3423     Result := CMPEql;
3424     end;
3425     end;
3426    
3427     procedure TIBCustomDataSet.DoBeforeDelete;
3428     var
3429     Buff: PRecordData;
3430     begin
3431     if not CanDelete then
3432     IBError(ibxeCannotDelete, [nil]);
3433     Buff := PRecordData(GetActiveBuf);
3434     if FCachedUpdates and
3435     (Buff^.rdCachedUpdateStatus in [cusUnmodified]) then
3436     SaveOldBuffer(PChar(Buff));
3437     inherited DoBeforeDelete;
3438     end;
3439    
3440     procedure TIBCustomDataSet.DoAfterDelete;
3441     begin
3442     inherited DoAfterDelete;
3443     FBase.DoAfterDelete(self);
3444     InternalAutoCommit;
3445     end;
3446    
3447     procedure TIBCustomDataSet.DoBeforeEdit;
3448     var
3449     Buff: PRecordData;
3450     begin
3451     Buff := PRecordData(GetActiveBuf);
3452     if not(CanEdit or (FQModify.SQL.Count <> 0) or
3453     (FCachedUpdates and Assigned(FOnUpdateRecord))) then
3454     IBError(ibxeCannotUpdate, [nil]);
3455     if FCachedUpdates and (Buff^.rdCachedUpdateStatus in [cusUnmodified, cusInserted]) then
3456     SaveOldBuffer(PChar(Buff));
3457     CopyRecordBuffer(GetActiveBuf, FOldBuffer);
3458     inherited DoBeforeEdit;
3459     end;
3460    
3461     procedure TIBCustomDataSet.DoAfterEdit;
3462     begin
3463     inherited DoAfterEdit;
3464     FBase.DoAfterEdit(self);
3465     end;
3466    
3467     procedure TIBCustomDataSet.DoBeforeInsert;
3468     begin
3469     if not CanInsert then
3470     IBError(ibxeCannotInsert, [nil]);
3471     inherited DoBeforeInsert;
3472     end;
3473    
3474     procedure TIBCustomDataSet.DoAfterInsert;
3475     begin
3476     if GeneratorField.ApplyOnEvent = gaeOnNewRecord then
3477     GeneratorField.Apply;
3478     inherited DoAfterInsert;
3479     FBase.DoAfterInsert(self);
3480     end;
3481    
3482     procedure TIBCustomDataSet.DoBeforeClose;
3483     begin
3484     inherited DoBeforeClose;
3485     if FInTransactionEnd and (FCloseAction = TARollback) then
3486     Exit;
3487     if State in [dsInsert,dsEdit] then
3488     begin
3489     if DataSetCloseAction = dcSaveChanges then
3490     Post;
3491     {Note this can fail with an exception e.g. due to
3492     database validation error. In which case the dataset remains open }
3493     end;
3494     if FCachedUpdates and FUpdatesPending and (DataSetCloseAction = dcSaveChanges) then
3495     ApplyUpdates;
3496     end;
3497    
3498     procedure TIBCustomDataSet.DoBeforePost;
3499     begin
3500     inherited DoBeforePost;
3501     if (State = dsInsert) and
3502     (GeneratorField.ApplyOnEvent = gaeOnPostRecord) then
3503     GeneratorField.Apply
3504     end;
3505    
3506     procedure TIBCustomDataSet.DoAfterPost;
3507     begin
3508     inherited DoAfterPost;
3509     FBase.DoAfterPost(self);
3510     InternalAutoCommit;
3511     end;
3512    
3513     procedure TIBCustomDataSet.FetchAll;
3514     var
3515     CurBookmark: TBookmark;
3516     begin
3517     FBase.SetCursor;
3518     try
3519     if FQSelect.EOF or not FQSelect.Open then
3520     exit;
3521     DisableControls;
3522     try
3523     CurBookmark := Bookmark;
3524     Last;
3525     Bookmark := CurBookmark;
3526     finally
3527     EnableControls;
3528     end;
3529     finally
3530     FBase.RestoreCursor;
3531     end;
3532     end;
3533    
3534     procedure TIBCustomDataSet.FreeRecordBuffer(var Buffer: PChar);
3535     begin
3536     FreeMem(Buffer);
3537     Buffer := nil;
3538     end;
3539    
3540     procedure TIBCustomDataSet.GetBookmarkData(Buffer: PChar; Data: Pointer);
3541     begin
3542     Move(PRecordData(Buffer)^.rdRecordNumber, Data^, BookmarkSize);
3543     end;
3544    
3545     function TIBCustomDataSet.GetBookmarkFlag(Buffer: PChar): TBookmarkFlag;
3546     begin
3547     result := PRecordData(Buffer)^.rdBookmarkFlag;
3548     end;
3549    
3550     function TIBCustomDataSet.GetCanModify: Boolean;
3551     begin
3552     result := (FQInsert.SQL.Text <> '') or
3553     (FQModify.SQL.Text <> '') or
3554     (FQDelete.SQL.Text <> '') or
3555     (Assigned(FUpdateObject));
3556     end;
3557    
3558     function TIBCustomDataSet.GetCurrentRecord(Buffer: PChar): Boolean;
3559     begin
3560     if not IsEmpty and (GetBookmarkFlag(ActiveBuffer) = bfCurrent) then
3561     begin
3562     UpdateCursorPos;
3563     ReadRecordCache(PRecordData(ActiveBuffer)^.rdRecordNumber, Buffer, False);
3564     result := True;
3565     end
3566     else
3567     result := False;
3568     end;
3569    
3570     function TIBCustomDataSet.GetDataSource: TDataSource;
3571     begin
3572     if FDataLink = nil then
3573     result := nil
3574     else
3575     result := FDataLink.DataSource;
3576     end;
3577    
3578     function TIBCustomDataSet.GetDBAliasName(FieldNo: integer): string;
3579     begin
3580     Result := FAliasNameMap[FieldNo-1]
3581     end;
3582    
3583     function TIBCustomDataSet.GetFieldDefFromAlias(aliasName: string): TFieldDef;
3584     var
3585     i: integer;
3586     begin
3587     Result := nil;
3588     for i := 0 to Length(FAliasNameMap) - 1 do
3589     if FAliasNameMap[i] = aliasName then
3590     begin
3591     Result := FieldDefs[i];
3592     Exit
3593     end;
3594     end;
3595    
3596     function TIBCustomDataSet.GetFieldClass(FieldType: TFieldType): TFieldClass;
3597     begin
3598     Result := DefaultFieldClasses[FieldType];
3599     end;
3600    
3601     function TIBCustomDataSet.GetFieldData(FieldNo: Integer; Buffer: Pointer): Boolean;
3602     begin
3603     result := GetFieldData(FieldByNumber(FieldNo), buffer);
3604     end;
3605    
3606     function TIBCustomDataSet.InternalGetFieldData(Field: TField; Buffer: Pointer): Boolean;
3607     var
3608     Buff, Data: PChar;
3609     CurrentRecord: PRecordData;
3610     begin
3611     result := False;
3612     Buff := GetActiveBuf;
3613     if (Buff = nil) or
3614     (not IsVisible(Buff)) or not assigned(Field.DataSet) then
3615     exit;
3616     { The intention here is to stuff the buffer with the data for the
3617     referenced field for the current record }
3618     CurrentRecord := PRecordData(Buff);
3619     if (Field.FieldNo < 0) then
3620     begin
3621     Inc(Buff, FRecordSize + Field.Offset);
3622     result := Boolean(Buff[0]);
3623     if result and (Buffer <> nil) then
3624     Move(Buff[1], Buffer^, Field.DataSize);
3625     end
3626     else
3627     if (FMappedFieldPosition[Field.FieldNo - 1] > 0) and
3628     (FMappedFieldPosition[Field.FieldNo - 1] <= CurrentRecord^.rdFieldCount) then
3629     with CurrentRecord^.rdFields[FMappedFieldPosition[Field.FieldNo - 1]],
3630     FFieldColumns^[FMappedFieldPosition[Field.FieldNo - 1]] do
3631     begin
3632     result := not fdIsNull;
3633     if result and (Buffer <> nil) then
3634     begin
3635     Data := Buff + fdDataOfs;
3636     if (fdDataType = SQL_VARYING) or (fdDataType = SQL_TEXT) then
3637     begin
3638     if fdDataLength < Field.DataSize then
3639     begin
3640     Move(Data^, Buffer^, fdDataLength);
3641     PChar(Buffer)[fdDataLength] := #0;
3642     end
3643     else
3644     IBError(ibxeFieldSizeError,[Field.FieldName])
3645     end
3646     else
3647     Move(Data^, Buffer^, Field.DataSize);
3648     end;
3649     end;
3650     end;
3651    
3652     { GetRecNo and SetRecNo both operate off of 1-based indexes as
3653     opposed to 0-based indexes.
3654     This is because we want LastRecordNumber/RecordCount = 1 }
3655    
3656     function TIBCustomDataSet.GetRecNo: Integer;
3657     begin
3658     if GetActiveBuf = nil then
3659     result := 0
3660     else
3661     result := PRecordData(GetActiveBuf)^.rdRecordNumber + 1;
3662     end;
3663    
3664     function TIBCustomDataSet.GetRecord(Buffer: PChar; GetMode: TGetMode;
3665     DoCheck: Boolean): TGetResult;
3666     var
3667     Accept: Boolean;
3668     SaveState: TDataSetState;
3669     begin
3670     Result := grOK;
3671     if Filtered and Assigned(OnFilterRecord) then
3672     begin
3673     Accept := False;
3674     SaveState := SetTempState(dsFilter);
3675     while not Accept do
3676     begin
3677     Result := InternalGetRecord(Buffer, GetMode, DoCheck);
3678     if Result <> grOK then
3679     break;
3680     FFilterBuffer := Buffer;
3681     try
3682     Accept := True;
3683     OnFilterRecord(Self, Accept);
3684     if not Accept and (GetMode = gmCurrent) then
3685     GetMode := gmPrior;
3686     except
3687     // FBase.HandleException(Self);
3688     end;
3689     end;
3690     RestoreState(SaveState);
3691     end
3692     else
3693     Result := InternalGetRecord(Buffer, GetMode, DoCheck);
3694     end;
3695    
3696     function TIBCustomDataSet.InternalGetRecord(Buffer: PChar; GetMode: TGetMode;
3697     DoCheck: Boolean): TGetResult;
3698     begin
3699     result := grError;
3700     case GetMode of
3701     gmCurrent: begin
3702     if (FCurrentRecord >= 0) then begin
3703     if FCurrentRecord < FRecordCount then
3704     ReadRecordCache(FCurrentRecord, Buffer, False)
3705     else begin
3706     while (not FQSelect.EOF) and FQSelect.Next and
3707     (FCurrentRecord >= FRecordCount) do begin
3708     FetchCurrentRecordToBuffer(FQSelect, FRecordCount, Buffer);
3709     Inc(FRecordCount);
3710     end;
3711     FCurrentRecord := FRecordCount - 1;
3712     if (FCurrentRecord >= 0) then
3713     ReadRecordCache(FCurrentRecord, Buffer, False);
3714     end;
3715     result := grOk;
3716     end else
3717     result := grBOF;
3718     end;
3719     gmNext: begin
3720     result := grOk;
3721     if FCurrentRecord = FRecordCount then
3722     result := grEOF
3723     else if FCurrentRecord = FRecordCount - 1 then begin
3724     if (not FQSelect.EOF) then begin
3725     FQSelect.Next;
3726     Inc(FCurrentRecord);
3727     end;
3728     if (FQSelect.EOF) then begin
3729     result := grEOF;
3730     end else begin
3731     Inc(FRecordCount);
3732     FetchCurrentRecordToBuffer(FQSelect, FCurrentRecord, Buffer);
3733     end;
3734     end else if (FCurrentRecord < FRecordCount) then begin
3735     Inc(FCurrentRecord);
3736     ReadRecordCache(FCurrentRecord, Buffer, False);
3737     end;
3738     end;
3739     else { gmPrior }
3740     begin
3741     if (FCurrentRecord = 0) then begin
3742     Dec(FCurrentRecord);
3743     result := grBOF;
3744     end else if (FCurrentRecord > 0) and
3745     (FCurrentRecord <= FRecordCount) then begin
3746     Dec(FCurrentRecord);
3747     ReadRecordCache(FCurrentRecord, Buffer, False);
3748     result := grOk;
3749     end else if (FCurrentRecord = -1) then
3750     result := grBOF;
3751     end;
3752     end;
3753     if result = grOk then
3754     result := AdjustCurrentRecord(Buffer, GetMode);
3755     if result = grOk then with PRecordData(Buffer)^ do begin
3756     rdBookmarkFlag := bfCurrent;
3757     GetCalcFields(Buffer);
3758     end else if (result = grEOF) then begin
3759     CopyRecordBuffer(FModelBuffer, Buffer);
3760     PRecordData(Buffer)^.rdBookmarkFlag := bfEOF;
3761     end else if (result = grBOF) then begin
3762     CopyRecordBuffer(FModelBuffer, Buffer);
3763     PRecordData(Buffer)^.rdBookmarkFlag := bfBOF;
3764     end else if (result = grError) then begin
3765     CopyRecordBuffer(FModelBuffer, Buffer);
3766     PRecordData(Buffer)^.rdBookmarkFlag := bfEOF;
3767     end;;
3768     end;
3769    
3770     function TIBCustomDataSet.GetRecordCount: Integer;
3771     begin
3772     result := FRecordCount - FDeletedRecords;
3773     end;
3774    
3775     function TIBCustomDataSet.GetRecordSize: Word;
3776     begin
3777     result := FRecordBufferSize;
3778     end;
3779    
3780     procedure TIBCustomDataSet.InternalAutoCommit;
3781     begin
3782     with Transaction do
3783     if InTransaction and (FAutoCommit = acCommitRetaining) then
3784     begin
3785     if CachedUpdates then ApplyUpdates;
3786     CommitRetaining;
3787     end;
3788     end;
3789    
3790     procedure TIBCustomDataSet.InternalAddRecord(Buffer: Pointer; Append: Boolean);
3791     begin
3792     CheckEditState;
3793     begin
3794     { When adding records, we *always* append.
3795     Insertion is just too costly }
3796     AdjustRecordOnInsert(Buffer);
3797     with PRecordData(Buffer)^ do
3798     begin
3799     rdUpdateStatus := usInserted;
3800     rdCachedUpdateStatus := cusInserted;
3801     end;
3802     if not CachedUpdates then
3803     InternalPostRecord(FQInsert, Buffer)
3804     else begin
3805     WriteRecordCache(FCurrentRecord, Buffer);
3806     FUpdatesPending := True;
3807     end;
3808     Inc(FRecordCount);
3809     InternalSetToRecord(Buffer);
3810     end
3811     end;
3812    
3813     procedure TIBCustomDataSet.InternalCancel;
3814     var
3815     Buff: PChar;
3816     CurRec: Integer;
3817     pda: PArrayDataArray;
3818     i: integer;
3819     begin
3820     inherited InternalCancel;
3821     Buff := GetActiveBuf;
3822     if Buff <> nil then
3823     begin
3824     pda := PArrayDataArray(Buff + FArrayCacheOffset);
3825     for i := 0 to ArrayFieldCount - 1 do
3826     pda^[i].ArrayIntf.CancelChanges;
3827     CurRec := FCurrentRecord;
3828     AdjustRecordOnInsert(Buff);
3829     if (State = dsEdit) then begin
3830     CopyRecordBuffer(FOldBuffer, Buff);
3831     WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Buff);
3832     end else begin
3833     CopyRecordBuffer(FModelBuffer, Buff);
3834     PRecordData(Buff)^.rdUpdateStatus := usDeleted;
3835     PRecordData(Buff)^.rdCachedUpdateStatus := cusUnmodified;
3836     PRecordData(Buff)^.rdBookmarkFlag := bfEOF;
3837     FCurrentRecord := CurRec;
3838     end;
3839     end;
3840     end;
3841    
3842    
3843     procedure TIBCustomDataSet.InternalClose;
3844     begin
3845     if FDidActivate then
3846     DeactivateTransaction;
3847     FQSelect.Close;
3848     ClearBlobCache;
3849     ClearArrayCache;
3850     FreeRecordBuffer(FModelBuffer);
3851     FreeRecordBuffer(FOldBuffer);
3852     FCurrentRecord := -1;
3853     FOpen := False;
3854     FRecordCount := 0;
3855     FDeletedRecords := 0;
3856     FRecordSize := 0;
3857     FBPos := 0;
3858     FOBPos := 0;
3859     FCacheSize := 0;
3860     FOldCacheSize := 0;
3861     FBEnd := 0;
3862     FOBEnd := 0;
3863     FreeMem(FBufferCache);
3864     FBufferCache := nil;
3865     FreeMem(FFieldColumns);
3866     FFieldColumns := nil;
3867     FreeMem(FOldBufferCache);
3868     FOldBufferCache := nil;
3869     BindFields(False);
3870     ResetParser;
3871     if DefaultFields then DestroyFields;
3872     end;
3873    
3874     procedure TIBCustomDataSet.InternalDelete;
3875     var
3876     Buff: PChar;
3877     begin
3878     FBase.SetCursor;
3879     try
3880     Buff := GetActiveBuf;
3881     if CanDelete then
3882     begin
3883     if not CachedUpdates then
3884     InternalDeleteRecord(FQDelete, Buff)
3885     else
3886     begin
3887     with PRecordData(Buff)^ do
3888     begin
3889     if rdCachedUpdateStatus = cusInserted then
3890     rdCachedUpdateStatus := cusUninserted
3891     else begin
3892     rdUpdateStatus := usDeleted;
3893     rdCachedUpdateStatus := cusDeleted;
3894     end;
3895     end;
3896     WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Buff);
3897     end;
3898     Inc(FDeletedRecords);
3899     FUpdatesPending := True;
3900     end else
3901     IBError(ibxeCannotDelete, [nil]);
3902     finally
3903     FBase.RestoreCursor;
3904     end;
3905     end;
3906    
3907     procedure TIBCustomDataSet.InternalFirst;
3908     begin
3909     FCurrentRecord := -1;
3910     end;
3911    
3912     procedure TIBCustomDataSet.InternalGotoBookmark(Bookmark: Pointer);
3913     begin
3914     FCurrentRecord := PInteger(Bookmark)^;
3915     end;
3916    
3917     procedure TIBCustomDataSet.InternalHandleException;
3918     begin
3919     FBase.HandleException(Self)
3920     end;
3921    
3922     procedure TIBCustomDataSet.InternalInitFieldDefs;
3923     begin
3924     if not InternalPrepared then
3925     begin
3926     InternalPrepare;
3927     exit;
3928     end;
3929     FieldDefsFromQuery(FQSelect);
3930     end;
3931    
3932     procedure TIBCustomDataSet.FieldDefsFromQuery(SourceQuery: TIBSQL);
3933     const
3934     DefaultSQL = 'Select F.RDB$COMPUTED_BLR, ' + {do not localize}
3935     'F.RDB$DEFAULT_VALUE, R.RDB$FIELD_NAME ' + {do not localize}
3936     'from RDB$RELATION_FIELDS R, RDB$FIELDS F ' + {do not localize}
3937     'where R.RDB$RELATION_NAME = :RELATION ' + {do not localize}
3938     'and R.RDB$FIELD_SOURCE = F.RDB$FIELD_NAME '+ {do not localize}
3939     'and ((not F.RDB$COMPUTED_BLR is NULL) or ' + {do not localize}
3940     ' (not F.RDB$DEFAULT_VALUE is NULL)) '; {do not localize}
3941    
3942     DefaultSQLODS12 = 'Select F.RDB$COMPUTED_BLR, ' + {do not localize}
3943     'F.RDB$DEFAULT_VALUE, R.RDB$FIELD_NAME, R.RDB$IDENTITY_TYPE ' + {do not localize}
3944     'from RDB$RELATION_FIELDS R, RDB$FIELDS F ' + {do not localize}
3945     'where R.RDB$RELATION_NAME = :RELATION ' + {do not localize}
3946     'and R.RDB$FIELD_SOURCE = F.RDB$FIELD_NAME '+ {do not localize}
3947     'and ((not F.RDB$COMPUTED_BLR is NULL) or ' + {do not localize}
3948     ' (not F.RDB$DEFAULT_VALUE is NULL) or ' + {do not localize}
3949     ' ( not R.RDB$IDENTITY_TYPE is NULL))' ; {do not localize}
3950    
3951     var
3952     FieldType: TFieldType;
3953     FieldSize: Word;
3954     FieldDataSize: integer;
3955     CharSetSize: integer;
3956     CharSetName: RawByteString;
3957     FieldCodePage: TSystemCodePage;
3958     FieldNullable : Boolean;
3959     i, FieldPosition, FieldPrecision: Integer;
3960     FieldAliasName, DBAliasName: string;
3961     aRelationName, FieldName: string;
3962     Query : TIBSQL;
3963     FieldIndex: Integer;
3964     FRelationNodes : TRelationNode;
3965     aArrayDimensions: integer;
3966     aArrayBounds: TArrayBounds;
3967     ArrayMetaData: IArrayMetaData;
3968    
3969     function Add_Node(Relation, Field : String) : TRelationNode;
3970     var
3971     FField : TFieldNode;
3972     begin
3973     if FRelationNodes.RelationName = '' then
3974     Result := FRelationNodes
3975     else
3976     begin
3977     Result := TRelationNode.Create;
3978     Result.NextRelation := FRelationNodes;
3979     end;
3980     Result.RelationName := Relation;
3981     FRelationNodes := Result;
3982     Query.Params[0].AsString := Relation;
3983     Query.ExecQuery;
3984     while not Query.Eof do
3985     begin
3986     FField := TFieldNode.Create;
3987     FField.FieldName := Query.Fields[2].AsString;
3988     FField.DEFAULT_VALUE := not Query.Fields[1].IsNull;
3989     FField.COMPUTED_BLR := not Query.Fields[0].IsNull;
3990     FField.IDENTITY_COLUMN := (Query.FieldCount > 3) and not Query.Fields[3].IsNull;
3991     FField.NextField := Result.FieldNodes;
3992     Result.FieldNodes := FField;
3993     Query.Next;
3994     end;
3995     Query.Close;
3996     end;
3997    
3998     function Has_COMPUTED_BLR(Relation, Field : String) : Boolean;
3999     var
4000     FRelation : TRelationNode;
4001     FField : TFieldNode;
4002     begin
4003     FRelation := FRelationNodes;
4004     while Assigned(FRelation) and
4005     (FRelation.RelationName <> Relation) do
4006     FRelation := FRelation.NextRelation;
4007     if not Assigned(FRelation) then
4008     FRelation := Add_Node(Relation, Field);
4009     Result := false;
4010     FField := FRelation.FieldNodes;
4011     while Assigned(FField) do
4012     if FField.FieldName = Field then
4013     begin
4014     Result := Ffield.COMPUTED_BLR;
4015     Exit;
4016     end
4017     else
4018     FField := Ffield.NextField;
4019     end;
4020    
4021     function Has_DEFAULT_VALUE(Relation, Field : String) : Boolean;
4022     var
4023     FRelation : TRelationNode;
4024     FField : TFieldNode;
4025     begin
4026     FRelation := FRelationNodes;
4027     while Assigned(FRelation) and
4028     (FRelation.RelationName <> Relation) do
4029     FRelation := FRelation.NextRelation;
4030     if not Assigned(FRelation) then
4031     FRelation := Add_Node(Relation, Field);
4032     Result := false;
4033     FField := FRelation.FieldNodes;
4034     while Assigned(FField) do
4035     if FField.FieldName = Field then
4036     begin
4037     Result := Ffield.DEFAULT_VALUE;
4038     Exit;
4039     end
4040     else
4041     FField := Ffield.NextField;
4042     end;
4043    
4044     function Is_IDENTITY_COLUMN(Relation, Field : String) : Boolean;
4045     var
4046     FRelation : TRelationNode;
4047     FField : TFieldNode;
4048     begin
4049     FRelation := FRelationNodes;
4050     while Assigned(FRelation) and
4051     (FRelation.RelationName <> Relation) do
4052     FRelation := FRelation.NextRelation;
4053     if not Assigned(FRelation) then
4054     FRelation := Add_Node(Relation, Field);
4055     Result := false;
4056     FField := FRelation.FieldNodes;
4057     while Assigned(FField) do
4058     if FField.FieldName = Field then
4059     begin
4060     Result := Ffield.IDENTITY_COLUMN;
4061     Exit;
4062     end
4063     else
4064     FField := Ffield.NextField;
4065     end;
4066    
4067     Procedure FreeNodes;
4068     var
4069     FRelation : TRelationNode;
4070     FField : TFieldNode;
4071     begin
4072     while Assigned(FRelationNodes) do
4073     begin
4074     While Assigned(FRelationNodes.FieldNodes) do
4075     begin
4076     FField := FRelationNodes.FieldNodes.NextField;
4077     FRelationNodes.FieldNodes.Free;
4078     FRelationNodes.FieldNodes := FField;
4079     end;
4080     FRelation := FRelationNodes.NextRelation;
4081     FRelationNodes.Free;
4082     FRelationNodes := FRelation;
4083     end;
4084     end;
4085    
4086     begin
4087     FRelationNodes := TRelationNode.Create;
4088     FNeedsRefresh := False;
4089     if not Database.InternalTransaction.InTransaction then
4090     Database.InternalTransaction.StartTransaction;
4091     Query := TIBSQL.Create(self);
4092     try
4093     Query.Database := DataBase;
4094     Query.Transaction := Database.InternalTransaction;
4095     FieldDefs.BeginUpdate;
4096     FieldDefs.Clear;
4097     FieldIndex := 0;
4098     if (Length(FMappedFieldPosition) < SourceQuery.MetaData.Count) then
4099     SetLength(FMappedFieldPosition, SourceQuery.MetaData.Count);
4100     if FDatabaseInfo.ODSMajorVersion >= 12 then
4101     Query.SQL.Text := DefaultSQLODS12
4102     else
4103     Query.SQL.Text := DefaultSQL;
4104     Query.Prepare;
4105     SetLength(FAliasNameMap, SourceQuery.MetaData.Count);
4106     SetLength(FAliasNameList, SourceQuery.MetaData.Count);
4107     for i := 0 to SourceQuery.MetaData.GetCount - 1 do
4108     with SourceQuery.MetaData[i] do
4109     begin
4110     { Get the field name }
4111     FieldAliasName := GetName;
4112     DBAliasName := GetAliasname;
4113     aRelationName := getRelationName;
4114     FieldName := getSQLName;
4115     FAliasNameList[i] := DBAliasName;
4116     FieldSize := 0;
4117     FieldDataSize := GetSize;
4118     FieldPrecision := 0;
4119     FieldNullable := IsNullable;
4120     CharSetSize := 0;
4121     CharSetName := '';
4122     FieldCodePage := CP_NONE;
4123     aArrayDimensions := 0;
4124     SetLength(aArrayBounds,0);
4125     case SQLType of
4126     { All VARCHAR's must be converted to strings before recording
4127     their values }
4128     SQL_VARYING, SQL_TEXT:
4129     begin
4130     if not Database.Attachment.CharSetWidth(getCharSetID,CharSetSize) then
4131     CharSetSize := 1;
4132     CharSetName := Database.Attachment.GetCharsetName(getCharSetID);
4133     Database.Attachment.CharSetID2CodePage(getCharSetID,FieldCodePage);
4134     FieldSize := FieldDataSize div CharSetSize;
4135     FieldType := ftString;
4136     end;
4137     { All Doubles/Floats should be cast to doubles }
4138     SQL_DOUBLE, SQL_FLOAT:
4139     FieldType := ftFloat;
4140     SQL_SHORT:
4141     begin
4142     if (getScale = 0) then
4143     FieldType := ftSmallInt
4144     else begin
4145     FieldType := ftBCD;
4146     FieldPrecision := 4;
4147     FieldSize := -getScale;
4148     end;
4149     end;
4150     SQL_LONG:
4151     begin
4152     if (getScale = 0) then
4153     FieldType := ftInteger
4154     else if (getScale >= (-4)) then
4155     begin
4156     FieldType := ftBCD;
4157     FieldPrecision := 9;
4158     FieldSize := -getScale;
4159     end
4160     else
4161     if Database.SQLDialect = 1 then
4162     FieldType := ftFloat
4163     else
4164     if (FieldCount > i) and (Fields[i] is TFloatField) then
4165     FieldType := ftFloat
4166     else
4167     begin
4168     FieldType := ftFMTBCD;
4169     FieldPrecision := 9;
4170     FieldSize := -getScale;
4171     end;
4172     end;
4173    
4174     SQL_INT64:
4175     begin
4176     if (getScale = 0) then
4177     FieldType := ftLargeInt
4178     else if (getScale >= (-4)) then
4179     begin
4180     FieldType := ftBCD;
4181     FieldPrecision := 18;
4182     FieldSize := -getScale;
4183     end
4184     else
4185     FieldType := ftFloat;
4186     end;
4187     SQL_TIMESTAMP: FieldType := ftDateTime;
4188     SQL_TYPE_TIME: FieldType := ftTime;
4189     SQL_TYPE_DATE: FieldType := ftDate;
4190     SQL_BLOB:
4191     begin
4192     FieldSize := sizeof (TISC_QUAD);
4193     if (getSubtype = 1) then
4194     begin
4195     if not Database.Attachment.CharSetWidth(getCharSetID,CharSetSize) then
4196     CharSetSize := 1;
4197     CharSetName := Database.Attachment.GetCharsetName(getCharSetID);
4198     Database.Attachment.CharSetID2CodePage(getCharSetID,FieldCodePage);
4199     FieldType := ftMemo;
4200     end
4201     else
4202     FieldType := ftBlob;
4203     end;
4204     SQL_ARRAY:
4205     begin
4206     FieldSize := sizeof (TISC_QUAD);
4207     FieldType := ftArray;
4208     ArrayMetaData := GetArrayMetaData;
4209     if ArrayMetaData <> nil then
4210     begin
4211     aArrayDimensions := ArrayMetaData.GetDimensions;
4212     aArrayBounds := ArrayMetaData.GetBounds;
4213     end;
4214     end;
4215     SQL_BOOLEAN:
4216     FieldType:= ftBoolean;
4217     else
4218     FieldType := ftUnknown;
4219     end;
4220     FieldPosition := i + 1;
4221     if (FieldType <> ftUnknown) and (FieldAliasName <> 'IBX_INTERNAL_DBKEY') then {do not localize}
4222     begin
4223     FMappedFieldPosition[FieldIndex] := FieldPosition;
4224     Inc(FieldIndex);
4225     with TIBFieldDef.Create(FieldDefs,'',FieldType,0,False,FieldDefs.Count+1) do
4226     begin
4227     Name := FieldAliasName;
4228     FAliasNameMap[FieldNo-1] := DBAliasName;
4229     Size := FieldSize;
4230     DataSize := FieldDataSize;
4231     Precision := FieldPrecision;
4232     Required := not FieldNullable;
4233     RelationName := aRelationName;
4234     InternalCalcField := False;
4235     CharacterSetSize := CharSetSize;
4236     CharacterSetName := CharSetName;
4237     CodePage := FieldCodePage;
4238     ArrayDimensions := aArrayDimensions;
4239     ArrayBounds := aArrayBounds;
4240     if (FieldName <> '') and (RelationName <> '') then
4241     begin
4242     IdentityColumn := Is_IDENTITY_COLUMN(RelationName, FieldName);
4243     if Has_COMPUTED_BLR(RelationName, FieldName) then
4244     begin
4245     Attributes := [faReadOnly];
4246     InternalCalcField := True;
4247     FNeedsRefresh := True;
4248     end
4249     else
4250     begin
4251     if Has_DEFAULT_VALUE(RelationName, FieldName) then
4252     begin
4253     if not FieldNullable then
4254     Attributes := [faRequired];
4255     end
4256     else
4257     FNeedsRefresh := True;
4258     end;
4259     end;
4260     end;
4261     end;
4262     end;
4263     finally
4264     Query.free;
4265     FreeNodes;
4266     Database.InternalTransaction.Commit;
4267     FieldDefs.EndUpdate;
4268     FieldDefs.Updated := true;
4269     end;
4270     end;
4271    
4272     procedure TIBCustomDataSet.InternalInitRecord(Buffer: PChar);
4273     begin
4274     CopyRecordBuffer(FModelBuffer, Buffer);
4275     end;
4276    
4277     procedure TIBCustomDataSet.InternalLast;
4278     var
4279     Buffer: PChar;
4280     begin
4281     if (FQSelect.EOF) then
4282     FCurrentRecord := FRecordCount
4283     else begin
4284     Buffer := AllocRecordBuffer;
4285     try
4286     while FQSelect.Next do
4287     begin
4288     FetchCurrentRecordToBuffer(FQSelect, FRecordCount, Buffer);
4289     Inc(FRecordCount);
4290     end;
4291     FCurrentRecord := FRecordCount;
4292     finally
4293     FreeRecordBuffer(Buffer);
4294     end;
4295     end;
4296     end;
4297    
4298     procedure TIBCustomDataSet.InternalSetParamsFromCursor;
4299     var
4300     i: Integer;
4301     cur_param: ISQLParam;
4302     cur_field: TField;
4303     s: TStream;
4304     begin
4305     if FQSelect.SQL.Text = '' then
4306     IBError(ibxeEmptyQuery, [nil]);
4307     if not FInternalPrepared then
4308     InternalPrepare;
4309     if (SQLParams.GetCount > 0) and (DataSource <> nil) and (DataSource.DataSet <> nil) then
4310     begin
4311     for i := 0 to SQLParams.GetCount - 1 do
4312     begin
4313     cur_field := DataSource.DataSet.FindField(SQLParams[i].Name);
4314     if (cur_field <> nil) then
4315     begin
4316     cur_param := SQLParams[i];
4317     if (cur_field.IsNull) then
4318     cur_param.IsNull := True
4319     else
4320     case cur_field.DataType of
4321     ftString:
4322     cur_param.AsString := cur_field.AsString;
4323     ftBoolean:
4324     cur_param.AsBoolean := cur_field.AsBoolean;
4325     ftSmallint, ftWord:
4326     cur_param.AsShort := cur_field.AsInteger;
4327     ftInteger:
4328     cur_param.AsLong := cur_field.AsInteger;
4329     ftLargeInt:
4330     cur_param.AsInt64 := cur_field.AsLargeInt;
4331     ftFloat, ftCurrency:
4332     cur_param.AsDouble := cur_field.AsFloat;
4333     ftBCD:
4334     cur_param.AsCurrency := cur_field.AsCurrency;
4335     ftDate:
4336     cur_param.AsDate := cur_field.AsDateTime;
4337     ftTime:
4338     cur_param.AsTime := cur_field.AsDateTime;
4339     ftDateTime:
4340     cur_param.AsDateTime := cur_field.AsDateTime;
4341     ftBlob, ftMemo:
4342     begin
4343     s := nil;
4344     try
4345     s := DataSource.DataSet.
4346     CreateBlobStream(cur_field, bmRead);
4347     cur_param.AsBlob := TIBDSBlobStream(s).FBlobStream.Blob;
4348     finally
4349     s.free;
4350     end;
4351     end;
4352     ftArray:
4353     cur_param.AsArray := TIBArrayField(cur_field).ArrayIntf;
4354     else
4355     IBError(ibxeNotSupported, [nil]);
4356     end;
4357     end;
4358     end;
4359     end;
4360     end;
4361    
4362     procedure TIBCustomDataSet.ReQuery;
4363     begin
4364     FQSelect.Close;
4365     ClearBlobCache;
4366     FCurrentRecord := -1;
4367     FRecordCount := 0;
4368     FDeletedRecords := 0;
4369     FBPos := 0;
4370     FOBPos := 0;
4371     FBEnd := 0;
4372     FOBEnd := 0;
4373     FQSelect.Close;
4374     FQSelect.ExecQuery;
4375     FOpen := FQSelect.Open;
4376     First;
4377     end;
4378    
4379     procedure TIBCustomDataSet.InternalOpen;
4380    
4381     function RecordDataLength(n: Integer): Long;
4382     begin
4383     result := SizeOf(TRecordData) + ((n - 1) * SizeOf(TFieldData));
4384     end;
4385    
4386     begin
4387     FBase.SetCursor;
4388     try
4389     ActivateConnection;
4390     ActivateTransaction;
4391     if FQSelect.SQL.Text = '' then
4392     IBError(ibxeEmptyQuery, [nil]);
4393     if not FInternalPrepared then
4394     InternalPrepare;
4395     if FQSelect.Statement <> nil then
4396     FQSelect.Statement.EnableStatistics(FEnableStatistics);
4397     if FQSelect.SQLStatementType = SQLSelect then
4398     begin
4399     if DefaultFields then
4400     CreateFields;
4401     FArrayFieldCount := 0;
4402     BindFields(True);
4403     FCurrentRecord := -1;
4404     FQSelect.ExecQuery;
4405     FOpen := FQSelect.Open;
4406    
4407     { Initialize offsets, buffer sizes, etc...
4408     1. Initially FRecordSize is just the "RecordDataLength".
4409     2. Allocate a "model" buffer and do a dummy fetch
4410     3. After the dummy fetch, FRecordSize will be appropriately
4411     adjusted to reflect the additional "weight" of the field
4412     data.
4413     4. Set up the FCalcFieldsOffset, FBlobCacheOffset, FArrayCacheOffset and FRecordBufferSize.
4414     5. Now, with the BufferSize available, allocate memory for chunks of records
4415     6. Re-allocate the model buffer, accounting for the new
4416     FRecordBufferSize.
4417     7. Finally, calls to AllocRecordBuffer will work!.
4418     }
4419     {Step 1}
4420     FRecordSize := RecordDataLength(FQSelect.FieldCount);
4421     {Step 2, 3}
4422     GetMem(FFieldColumns,sizeof(TFieldColumns) * (FQSelect.FieldCount));
4423     IBAlloc(FModelBuffer, 0, FRecordSize);
4424     InitModelBuffer(FQSelect, FModelBuffer);
4425     {Step 4}
4426     FCalcFieldsOffset := FRecordSize;
4427     FBlobCacheOffset := FCalcFieldsOffset + CalcFieldsSize;
4428     FArrayCacheOffset := (FBlobCacheOffset + (BlobFieldCount * SizeOf(TIBBlobStream)));
4429     FRecordBufferSize := FArrayCacheOffset + (ArrayFieldCount * sizeof(IArray));
4430     {Step 5}
4431     if UniDirectional then
4432     FBufferChunkSize := FRecordBufferSize * UniCache
4433     else
4434     FBufferChunkSize := FRecordBufferSize * BufferChunks;
4435     IBAlloc(FBufferCache, FBufferChunkSize, FBufferChunkSize);
4436     if FCachedUpdates or (csReading in ComponentState) then
4437     IBAlloc(FOldBufferCache, FBufferChunkSize, FBufferChunkSize);
4438     FBPos := 0;
4439     FOBPos := 0;
4440     FBEnd := 0;
4441     FOBEnd := 0;
4442     FCacheSize := FBufferChunkSize;
4443     FOldCacheSize := FBufferChunkSize;
4444     {Step 6}
4445     IBAlloc(FModelBuffer, RecordDataLength(FQSelect.FieldCount),
4446     FRecordBufferSize);
4447     {Step 7}
4448     FOldBuffer := AllocRecordBuffer;
4449     end
4450     else
4451     FQSelect.ExecQuery;
4452     finally
4453     FBase.RestoreCursor;
4454     end;
4455     end;
4456    
4457     procedure TIBCustomDataSet.InternalPost;
4458     var
4459     Qry: TIBSQL;
4460     Buff: PChar;
4461     bInserting: Boolean;
4462     begin
4463     FBase.SetCursor;
4464     try
4465     Buff := GetActiveBuf;
4466     CheckEditState;
4467     AdjustRecordOnInsert(Buff);
4468     if (State = dsInsert) then
4469     begin
4470     bInserting := True;
4471     Qry := FQInsert;
4472     PRecordData(Buff)^.rdUpdateStatus := usInserted;
4473     PRecordData(Buff)^.rdCachedUpdateStatus := cusInserted;
4474     WriteRecordCache(FRecordCount, Buff);
4475     FCurrentRecord := FRecordCount;
4476     end
4477     else begin
4478     bInserting := False;
4479     Qry := FQModify;
4480     if PRecordData(Buff)^.rdCachedUpdateStatus = cusUnmodified then
4481     begin
4482     PRecordData(Buff)^.rdUpdateStatus := usModified;
4483     PRecordData(Buff)^.rdCachedUpdateStatus := cusModified;
4484     end
4485     else if PRecordData(Buff)^.
4486     rdCachedUpdateStatus = cusUninserted then
4487     begin
4488     PRecordData(Buff)^.rdCachedUpdateStatus := cusInserted;
4489     Dec(FDeletedRecords);
4490     end;
4491     end;
4492     if (not CachedUpdates) then
4493     InternalPostRecord(Qry, Buff)
4494     else begin
4495     WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Buff);
4496     FUpdatesPending := True;
4497     end;
4498     if bInserting then
4499     Inc(FRecordCount);
4500     finally
4501     FBase.RestoreCursor;
4502     end;
4503     end;
4504    
4505     procedure TIBCustomDataSet.InternalRefresh;
4506     begin
4507     inherited InternalRefresh;
4508     InternalRefreshRow;
4509     end;
4510    
4511     procedure TIBCustomDataSet.InternalSetToRecord(Buffer: PChar);
4512     begin
4513     InternalGotoBookmark(@(PRecordData(Buffer)^.rdRecordNumber));
4514     end;
4515    
4516     function TIBCustomDataSet.IsCursorOpen: Boolean;
4517     begin
4518     result := FOpen;
4519     end;
4520    
4521     procedure TIBCustomDataSet.Loaded;
4522     begin
4523     if assigned(FQSelect) then
4524     FBaseSQLSelect.assign(FQSelect.SQL);
4525     inherited Loaded;
4526     end;
4527    
4528     procedure TIBCustomDataSet.Post;
4529     var CancelPost: boolean;
4530     begin
4531     CancelPost := false;
4532     if assigned(FOnValidatePost) then
4533     OnValidatePost(self,CancelPost);
4534     if CancelPost then
4535     Cancel
4536     else
4537     inherited Post;
4538     end;
4539    
4540     function TIBCustomDataSet.Locate(const KeyFields: string; const KeyValues: Variant;
4541     Options: TLocateOptions): Boolean;
4542     var
4543     CurBookmark: TBookmark;
4544     begin
4545     DisableControls;
4546     try
4547     CurBookmark := Bookmark;
4548     First;
4549     result := InternalLocate(KeyFields, KeyValues, Options);
4550     if not result then
4551     Bookmark := CurBookmark;
4552     finally
4553     EnableControls;
4554     end;
4555     end;
4556    
4557     function TIBCustomDataSet.Lookup(const KeyFields: string; const KeyValues: Variant;
4558     const ResultFields: string): Variant;
4559     var
4560     fl: TList;
4561     CurBookmark: TBookmark;
4562     begin
4563     DisableControls;
4564     fl := TList.Create;
4565     CurBookmark := Bookmark;
4566     try
4567     First;
4568     if InternalLocate(KeyFields, KeyValues, []) then
4569     begin
4570     if (ResultFields <> '') then
4571     result := FieldValues[ResultFields]
4572     else
4573     result := NULL;
4574     end
4575     else
4576     result := Null;
4577     finally
4578     Bookmark := CurBookmark;
4579     fl.Free;
4580     EnableControls;
4581     end;
4582     end;
4583    
4584     procedure TIBCustomDataSet.SetBookmarkData(Buffer: PChar; Data: Pointer);
4585     begin
4586     PRecordData(Buffer)^.rdRecordNumber := PInteger(Data)^;
4587     end;
4588    
4589     procedure TIBCustomDataSet.SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag);
4590     begin
4591     PRecordData(Buffer)^.rdBookmarkFlag := Value;
4592     end;
4593    
4594     procedure TIBCustomDataSet.SetCachedUpdates(Value: Boolean);
4595     begin
4596     if not Value and FCachedUpdates then
4597     CancelUpdates;
4598     if (not (csReading in ComponentState)) and Value then
4599     CheckDatasetClosed;
4600     FCachedUpdates := Value;
4601     end;
4602    
4603     procedure TIBCustomDataSet.SetDataSource(Value: TDataSource);
4604     begin
4605     if IsLinkedTo(Value) then
4606     IBError(ibxeCircularReference, [nil]);
4607     if FDataLink <> nil then
4608     FDataLink.DataSource := Value;
4609     end;
4610    
4611     procedure TIBCustomDataSet.InternalSetFieldData(Field: TField; Buffer: Pointer);
4612     var
4613     Buff, TmpBuff: PChar;
4614     MappedFieldPos: integer;
4615     begin
4616     Buff := GetActiveBuf;
4617     if Field.FieldNo < 0 then
4618     begin
4619     TmpBuff := Buff + FRecordSize + Field.Offset;
4620     Boolean(TmpBuff[0]) := LongBool(Buffer);
4621     if Boolean(TmpBuff[0]) then
4622     Move(Buffer^, TmpBuff[1], Field.DataSize);
4623     WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Buff);
4624     end
4625     else begin
4626     CheckEditState;
4627     with PRecordData(Buff)^ do
4628     begin
4629     { If inserting, Adjust record position }
4630     AdjustRecordOnInsert(Buff);
4631     MappedFieldPos := FMappedFieldPosition[Field.FieldNo - 1];
4632     if (MappedFieldPos > 0) and
4633     (MappedFieldPos <= rdFieldCount) then
4634     with rdFields[MappedFieldPos], FFieldColumns^[MappedFieldPos] do
4635     begin
4636     Field.Validate(Buffer);
4637     if (Buffer = nil) or
4638     (Field is TIBStringField) and (PChar(Buffer)[0] = #0) then
4639     fdIsNull := True
4640     else
4641     begin
4642     Move(Buffer^, Buff[fdDataOfs],fdDataSize);
4643     if (fdDataType = SQL_TEXT) or (fdDataType = SQL_VARYING) then
4644     fdDataLength := StrLen(PChar(Buffer));
4645     fdIsNull := False;
4646     if rdUpdateStatus = usUnmodified then
4647     begin
4648     if CachedUpdates then
4649     begin
4650     FUpdatesPending := True;
4651     if State = dsInsert then
4652     rdCachedUpdateStatus := cusInserted
4653     else if State = dsEdit then
4654     rdCachedUpdateStatus := cusModified;
4655     end;
4656    
4657     if State = dsInsert then
4658     rdUpdateStatus := usInserted
4659     else
4660     rdUpdateStatus := usModified;
4661     end;
4662     WriteRecordCache(rdRecordNumber, Buff);
4663     SetModified(True);
4664     end;
4665     end;
4666     end;
4667     end;
4668     if not (State in [dsCalcFields, dsFilter, dsNewValue]) then
4669     DataEvent(deFieldChange, PtrInt(Field));
4670     end;
4671    
4672     procedure TIBCustomDataSet.SetRecNo(Value: Integer);
4673     begin
4674     CheckBrowseMode;
4675     if (Value < 1) then
4676     Value := 1
4677     else if Value > FRecordCount then
4678     begin
4679     InternalLast;
4680     Value := Min(FRecordCount, Value);
4681     end;
4682     if (Value <> RecNo) then
4683     begin
4684     DoBeforeScroll;
4685     FCurrentRecord := Value - 1;
4686     Resync([]);
4687     DoAfterScroll;
4688     end;
4689     end;
4690    
4691     procedure TIBCustomDataSet.Disconnect;
4692     begin
4693     Close;
4694     InternalUnPrepare;
4695     end;
4696    
4697     procedure TIBCustomDataSet.SetUpdateMode(const Value: TUpdateMode);
4698     begin
4699     if not CanModify then
4700     IBError(ibxeCannotUpdate, [nil])
4701     else
4702     FUpdateMode := Value;
4703     end;
4704    
4705    
4706     procedure TIBCustomDataSet.SetUpdateObject(Value: TIBDataSetUpdateObject);
4707     begin
4708     if Value <> FUpdateObject then
4709     begin
4710     if Assigned(FUpdateObject) and (FUpdateObject.DataSet = Self) then
4711     FUpdateObject.DataSet := nil;
4712     FUpdateObject := Value;
4713     if Assigned(FUpdateObject) then
4714     begin
4715     if Assigned(FUpdateObject.DataSet) and
4716     (FUpdateObject.DataSet <> Self) then
4717     FUpdateObject.DataSet.UpdateObject := nil;
4718     FUpdateObject.DataSet := Self;
4719     end;
4720     end;
4721     end;
4722    
4723     function TIBCustomDataSet.ConstraintsStored: Boolean;
4724     begin
4725     Result := Constraints.Count > 0;
4726     end;
4727    
4728     procedure TIBCustomDataSet.ClearCalcFields(Buffer: PChar);
4729     begin
4730     FillChar(Buffer[FRecordSize], CalcFieldsSize, 0);
4731     end;
4732    
4733     procedure TIBCustomDataSet.ClearIBLinks;
4734     var i: integer;
4735     begin
4736     for i := FIBLinks.Count - 1 downto 0 do
4737     TIBControlLink(FIBLinks[i]).IBDataSet := nil;
4738     end;
4739    
4740    
4741     procedure TIBCustomDataSet.InternalUnPrepare;
4742     begin
4743     if FInternalPrepared then
4744     begin
4745     CheckDatasetClosed;
4746     if FDidActivate then
4747     DeactivateTransaction;
4748     FieldDefs.Clear;
4749     FieldDefs.Updated := false;
4750     FInternalPrepared := False;
4751     Setlength(FAliasNameList,0);
4752     end;
4753     end;
4754    
4755     procedure TIBCustomDataSet.InternalExecQuery;
4756     var
4757     DidActivate: Boolean;
4758     begin
4759     DidActivate := False;
4760     FBase.SetCursor;
4761     try
4762     ActivateConnection;
4763     DidActivate := ActivateTransaction;
4764     if FQSelect.SQL.Text = '' then
4765     IBError(ibxeEmptyQuery, [nil]);
4766     if not FInternalPrepared then
4767     InternalPrepare;
4768     if FQSelect.SQLStatementType = SQLSelect then
4769     begin
4770     IBError(ibxeIsASelectStatement, [nil]);
4771     end
4772     else
4773     FQSelect.ExecQuery;
4774     finally
4775     if DidActivate then
4776     DeactivateTransaction;
4777     FBase.RestoreCursor;
4778     end;
4779     end;
4780    
4781     function TIBCustomDataSet.GetSelectStmtIntf: IStatement;
4782     begin
4783     Result := FQSelect.Statement;
4784     end;
4785    
4786 tony 270 procedure TIBCustomDataSet.SetCaseSensitiveParameterNames(AValue: boolean);
4787     begin
4788     if FCaseSensitiveParameterNames = AValue then Exit;
4789     FCaseSensitiveParameterNames := AValue;
4790     if assigned(FQSelect) then
4791     FQSelect.CaseSensitiveParameterNames := AValue;
4792     end;
4793    
4794 tony 209 procedure TIBCustomDataSet.SetMasterDetailDelay(AValue: integer);
4795     begin
4796     FDataLink.DelayTimerValue := AValue;
4797     end;
4798    
4799     function TIBCustomDataSet.GetParser: TSelectSQLParser;
4800     begin
4801     if not assigned(FParser) then
4802     FParser := CreateParser;
4803     Result := FParser
4804     end;
4805    
4806     procedure TIBCustomDataSet.ResetParser;
4807     begin
4808     if assigned(FParser) then
4809     begin
4810     FParser.Free;
4811     FParser := nil;
4812     FQSelect.OnSQLChanged := nil; {Do not react to change}
4813     try
4814     FQSelect.SQL.Assign(FBaseSQLSelect);
4815     finally
4816     FQSelect.OnSQLChanged := SQLChanged;
4817     end;
4818     end;
4819     end;
4820    
4821     function TIBCustomDataSet.HasParser: boolean;
4822     begin
4823     Result := not (csDesigning in ComponentState) and (FParser <> nil)
4824     end;
4825    
4826     procedure TIBCustomDataSet.SetGenerateParamNames(AValue: Boolean);
4827     begin
4828     if FGenerateParamNames = AValue then Exit;
4829     FGenerateParamNames := AValue;
4830     Disconnect
4831     end;
4832    
4833     procedure TIBCustomDataSet.InitRecord(Buffer: PChar);
4834     begin
4835     inherited InitRecord(Buffer);
4836     with PRecordData(Buffer)^ do
4837     begin
4838     rdUpdateStatus := TUpdateStatus(usInserted);
4839     rdBookMarkFlag := bfInserted;
4840     rdRecordNumber := -1;
4841     end;
4842     end;
4843    
4844     procedure TIBCustomDataSet.InternalInsert;
4845     begin
4846     CursorPosChanged;
4847     end;
4848    
4849     { TIBDataSet IProviderSupport }
4850    
4851     procedure TIBCustomDataSet.PSEndTransaction(Commit: Boolean);
4852     begin
4853     if Commit then
4854     Transaction.Commit else
4855     Transaction.Rollback;
4856     end;
4857    
4858     function TIBCustomDataSet.PSExecuteStatement(const ASQL: string; AParams: TParams;
4859     ResultSet: Pointer = nil): Integer;
4860     var
4861     FQuery: TIBQuery;
4862     begin
4863     if Assigned(ResultSet) then
4864     begin
4865     TDataSet(ResultSet^) := TIBQuery.Create(nil);
4866     with TIBQuery(ResultSet^) do
4867     begin
4868     SQL.Text := ASQL;
4869     Params.Assign(AParams);
4870     Open;
4871     Result := RowsAffected;
4872     end;
4873     end
4874     else
4875     begin
4876     FQuery := TIBQuery.Create(nil);
4877     try
4878     FQuery.Database := Database;
4879     FQuery.Transaction := Transaction;
4880     FQuery.GenerateParamNames := True;
4881     FQuery.SQL.Text := ASQL;
4882     FQuery.Params.Assign(AParams);
4883     FQuery.ExecSQL;
4884     Result := FQuery.RowsAffected;
4885     finally
4886     FQuery.Free;
4887     end;
4888     end;
4889     end;
4890    
4891     function TIBCustomDataSet.PSGetQuoteChar: string;
4892     begin
4893     if Database.SQLDialect = 3 then
4894     Result := '"' else
4895     Result := '';
4896     end;
4897    
4898     function TIBCustomDataSet.PSGetUpdateException(E: Exception; Prev: EUpdateError): EUpdateError;
4899     var
4900     PrevErr: Integer;
4901     begin
4902     if Prev <> nil then
4903     PrevErr := Prev.ErrorCode else
4904     PrevErr := 0;
4905     if E is EIBError then
4906     with EIBError(E) do
4907     Result := EUpdateError.Create(E.Message, '', SQLCode, PrevErr, E) else
4908     Result := inherited PSGetUpdateException(E, Prev);
4909     end;
4910    
4911     function TIBCustomDataSet.PSInTransaction: Boolean;
4912     begin
4913     Result := Transaction.InTransaction;
4914     end;
4915    
4916     function TIBCustomDataSet.PSIsSQLBased: Boolean;
4917     begin
4918     Result := True;
4919     end;
4920    
4921     function TIBCustomDataSet.PSIsSQLSupported: Boolean;
4922     begin
4923     Result := True;
4924     end;
4925    
4926     procedure TIBCustomDataSet.PSReset;
4927     begin
4928     inherited PSReset;
4929     if Active then
4930     begin
4931     Close;
4932     Open;
4933     end;
4934     end;
4935    
4936     function TIBCustomDataSet.PSUpdateRecord(UpdateKind: TUpdateKind; Delta: TDataSet): Boolean;
4937     var
4938     UpdateAction: TIBUpdateAction;
4939     SQL: string;
4940     Params: TParams;
4941    
4942     procedure AssignParams(DataSet: TDataSet; Params: TParams);
4943     var
4944     I: Integer;
4945     Old: Boolean;
4946     Param: TParam;
4947     PName: string;
4948     Field: TField;
4949     Value: Variant;
4950     begin
4951     for I := 0 to Params.Count - 1 do
4952     begin
4953     Param := Params[I];
4954     PName := Param.Name;
4955     Old := CompareText(Copy(PName, 1, 4), 'OLD_') = 0; {do not localize}
4956     if Old then System.Delete(PName, 1, 4);
4957     Field := DataSet.FindField(PName);
4958     if not Assigned(Field) then Continue;
4959     if Old then Param.AssignFieldValue(Field, Field.OldValue) else
4960     begin
4961     Value := Field.NewValue;
4962     if VarIsEmpty(Value) then Value := Field.OldValue;
4963     Param.AssignFieldValue(Field, Value);
4964     end;
4965     end;
4966     end;
4967    
4968     begin
4969     Result := False;
4970     if Assigned(OnUpdateRecord) then
4971     begin
4972     UpdateAction := uaFail;
4973     if Assigned(FOnUpdateRecord) then
4974     begin
4975     FOnUpdateRecord(Delta, UpdateKind, UpdateAction);
4976     Result := UpdateAction = uaApplied;
4977     end;
4978     end
4979     else if Assigned(FUpdateObject) then
4980     begin
4981     SQL := FUpdateObject.GetSQL(UpdateKind).Text;
4982     if SQL <> '' then
4983     begin
4984     Params := TParams.Create;
4985     try
4986     Params.ParseSQL(SQL, True);
4987     AssignParams(Delta, Params);
4988     if PSExecuteStatement(SQL, Params) = 0 then
4989     IBError(ibxeNoRecordsAffected, [nil]);
4990     Result := True;
4991     finally
4992     Params.Free;
4993     end;
4994     end;
4995     end;
4996     end;
4997    
4998     procedure TIBCustomDataSet.PSStartTransaction;
4999     begin
5000     ActivateConnection;
5001     Transaction.StartTransaction;
5002     end;
5003    
5004     function TIBCustomDataSet.PsGetTableName: string;
5005     begin
5006     // if not FInternalPrepared then
5007     // InternalPrepare;
5008     { It is possible for the FQSelectSQL to be unprepared
5009     with FInternalPreprepared being true (see DoBeforeTransactionEnd).
5010     So check the Prepared of the SelectSQL instead }
5011     if not FQSelect.Prepared then
5012     FQSelect.Prepare;
5013     Result := FQSelect.UniqueRelationName;
5014     end;
5015    
5016     procedure TIBDataSet.BatchInput(InputObject: TIBBatchInput);
5017     begin
5018     InternalBatchInput(InputObject);
5019     end;
5020    
5021     procedure TIBDataSet.BatchOutput(OutputObject: TIBBatchOutput);
5022     begin
5023     InternalBatchOutput(OutputObject);
5024     end;
5025    
5026     procedure TIBDataSet.ExecSQL;
5027     begin
5028     InternalExecQuery;
5029     end;
5030    
5031     procedure TIBDataSet.Prepare;
5032     begin
5033     InternalPrepare;
5034     end;
5035    
5036     procedure TIBDataSet.UnPrepare;
5037     begin
5038     InternalUnPrepare;
5039     end;
5040    
5041     function TIBDataSet.GetPrepared: Boolean;
5042     begin
5043     Result := InternalPrepared;
5044     end;
5045    
5046     procedure TIBDataSet.InternalOpen;
5047     begin
5048     ActivateConnection;
5049     ActivateTransaction;
5050     InternalSetParamsFromCursor;
5051     Inherited InternalOpen;
5052     end;
5053    
5054     procedure TIBDataSet.SetFiltered(Value: Boolean);
5055     begin
5056     if(Filtered <> Value) then
5057     begin
5058     inherited SetFiltered(value);
5059     if Active then
5060     begin
5061     Close;
5062     Open;
5063     end;
5064     end
5065     else
5066     inherited SetFiltered(value);
5067     end;
5068    
5069     function TIBCustomDataSet.BookmarkValid(Bookmark: TBookmark): Boolean;
5070     begin
5071     Result := false;
5072     if not Assigned(Bookmark) then
5073     exit;
5074     Result := PInteger(Bookmark)^ < FRecordCount;
5075     end;
5076    
5077     function TIBCustomDataSet.GetFieldData(Field: TField;
5078     Buffer: Pointer): Boolean;
5079     {$IFDEF TBCDFIELD_IS_BCD}
5080     var
5081     lTempCurr : System.Currency;
5082     begin
5083     if (Field.DataType = ftBCD) and (Buffer <> nil) then
5084     begin
5085     Result := InternalGetFieldData(Field, @lTempCurr);
5086     if Result then
5087     CurrToBCD(lTempCurr, TBCD(Buffer^), 32, Field.Size);
5088     end
5089     else
5090     {$ELSE}
5091     begin
5092     {$ENDIF}
5093     Result := InternalGetFieldData(Field, Buffer);
5094     end;
5095    
5096     function TIBCustomDataSet.GetFieldData(Field: TField; Buffer: Pointer;
5097     NativeFormat: Boolean): Boolean;
5098     begin
5099     {These datatypes use IBX conventions and not TDataset conventions}
5100     if (Field.DataType in [ftBCD,ftDateTime,ftDate,ftTime]) and not NativeFormat then
5101     Result := InternalGetFieldData(Field, Buffer)
5102     else
5103     Result := inherited GetFieldData(Field, Buffer, NativeFormat);
5104     end;
5105    
5106     procedure TIBCustomDataSet.SetFieldData(Field: TField; Buffer: Pointer);
5107     {$IFDEF TDBDFIELD_IS_BCD}
5108     var
5109     lTempCurr : System.Currency;
5110     begin
5111     if (Field.DataType = ftBCD) and (Buffer <> nil) then
5112     begin
5113     BCDToCurr(TBCD(Buffer^), lTempCurr);
5114     InternalSetFieldData(Field, @lTempCurr);
5115     end
5116     else
5117     {$ELSE}
5118     begin
5119     {$ENDIF}
5120     InternalSetFieldData(Field, Buffer);
5121     end;
5122    
5123     procedure TIBCustomDataSet.SetFieldData(Field: TField; Buffer: Pointer;
5124     NativeFormat: Boolean);
5125     begin
5126     {These datatypes use IBX conventions and not TDataset conventions}
5127     if (not NativeFormat) and (Field.DataType in [ftBCD,ftDateTime,ftDate,ftTime]) then
5128     InternalSetfieldData(Field, Buffer)
5129     else
5130     inherited SetFieldData(Field, buffer, NativeFormat);
5131     end;
5132    
5133     { TIBDataSetUpdateObject }
5134    
5135     constructor TIBDataSetUpdateObject.Create(AOwner: TComponent);
5136     begin
5137     inherited Create(AOwner);
5138     FRefreshSQL := TStringList.Create;
5139     end;
5140    
5141     destructor TIBDataSetUpdateObject.Destroy;
5142     begin
5143     FRefreshSQL.Free;
5144     inherited Destroy;
5145     end;
5146    
5147     function TIBDataSetUpdateObject.GetRowsAffected(
5148     var SelectCount, InsertCount, UpdateCount, DeleteCount: integer): boolean;
5149     begin
5150 tony 217 Result := true;
5151 tony 209 SelectCount := 0;
5152     InsertCount := 0;
5153     UpdateCount := 0;
5154     DeleteCount := 0;
5155     end;
5156    
5157     procedure TIBDataSetUpdateObject.SetRefreshSQL(value: TStrings);
5158     begin
5159     FRefreshSQL.Assign(Value);
5160     end;
5161    
5162     procedure TIBDataSetUpdateObject.InternalSetParams(Params: ISQLParams;
5163     buff: PChar);
5164     begin
5165     if not Assigned(DataSet) then Exit;
5166     DataSet.SetInternalSQLParams(Params, buff);
5167     end;
5168    
5169     procedure TIBDataSetUpdateObject.InternalSetParams(Query: TIBSQL; buff: PChar);
5170     begin
5171     InternalSetParams(Query.Params,buff);
5172     end;
5173    
5174     procedure TIBDataSetUpdateObject.UpdateRecordFromQuery(UpdateKind: TUpdateKind;
5175     QryResults: IResults; Buffer: PChar);
5176     begin
5177     if not Assigned(DataSet) then Exit;
5178     case UpdateKind of
5179     ukModify, ukInsert:
5180     DataSet.UpdateRecordFromQuery(QryResults, Buffer);
5181     ukDelete:
5182     DataSet.DoDeleteReturning(QryResults);
5183     end;
5184     end;
5185    
5186     function TIBDSBlobStream.GetSize: Int64;
5187     begin
5188     Result := FBlobStream.BlobSize;
5189     end;
5190    
5191     { TIBDSBlobStream }
5192     constructor TIBDSBlobStream.Create(AField: TField; ABlobStream: TIBBlobStream;
5193     Mode: TBlobStreamMode);
5194     begin
5195     FField := AField;
5196     FBlobStream := ABlobStream;
5197     FBlobStream.Seek(0, soFromBeginning);
5198     if (Mode = bmWrite) then
5199     begin
5200     FBlobStream.Truncate;
5201     TIBCustomDataSet(FField.DataSet).RecordModified(True);
5202     TBlobField(FField).Modified := true;
5203     FHasWritten := true;
5204     end;
5205     end;
5206    
5207     destructor TIBDSBlobStream.Destroy;
5208     begin
5209     if FHasWritten then
5210     TIBCustomDataSet(FField.DataSet).DataEvent(deFieldChange, PtrInt(FField));
5211     inherited Destroy;
5212     end;
5213    
5214     function TIBDSBlobStream.Read(var Buffer; Count: Longint): Longint;
5215     begin
5216     result := FBlobStream.Read(Buffer, Count);
5217     end;
5218    
5219     function TIBDSBlobStream.Seek(Offset: Longint; Origin: Word): Longint;
5220     begin
5221     result := FBlobStream.Seek(Offset, Origin);
5222     end;
5223    
5224     procedure TIBDSBlobStream.SetSize(NewSize: Longint);
5225     begin
5226     FBlobStream.SetSize(NewSize);
5227     end;
5228    
5229     function TIBDSBlobStream.Write(const Buffer; Count: Longint): Longint;
5230     begin
5231     if not (FField.DataSet.State in [dsEdit, dsInsert]) then
5232     IBError(ibxeNotEditing, [nil]);
5233     TIBCustomDataSet(FField.DataSet).RecordModified(True);
5234     TBlobField(FField).Modified := true;
5235     result := FBlobStream.Write(Buffer, Count);
5236     FHasWritten := true;
5237     { TIBCustomDataSet(FField.DataSet).DataEvent(deFieldChange, PtrInt(FField));
5238     Removed as this caused a seek to beginning of the blob stream thus corrupting
5239     the blob stream. Moved to the destructor i.e. called after blob written}
5240     end;
5241    
5242     { TIBGenerator }
5243    
5244     procedure TIBGenerator.SetIncrement(const AValue: integer);
5245     begin
5246     if FIncrement = AValue then Exit;
5247     if AValue < 0 then
5248     IBError(ibxeNegativeGenerator,[]);
5249     FIncrement := AValue;
5250     SetQuerySQL;
5251     end;
5252    
5253     procedure TIBGenerator.SetTransaction(AValue: TIBTransaction);
5254     begin
5255     FQuery.Transaction := AValue;
5256     end;
5257    
5258     procedure TIBGenerator.SetQuerySQL;
5259     begin
5260 tony 287 if Database <> nil then
5261     FQuery.SQL.Text := Format('Select Gen_ID(%s,%d) From RDB$Database',
5262     [QuoteIdentifierIfNeeded(Database.SQLDialect,FGeneratorName),Increment]);
5263 tony 209 end;
5264    
5265     function TIBGenerator.GetDatabase: TIBDatabase;
5266     begin
5267     Result := FQuery.Database;
5268     end;
5269    
5270     function TIBGenerator.GetTransaction: TIBTransaction;
5271     begin
5272     Result := FQuery.Transaction;
5273     end;
5274    
5275     procedure TIBGenerator.SetDatabase(AValue: TIBDatabase);
5276     begin
5277     FQuery.Database := AValue;
5278 tony 287 SetQuerySQL;
5279 tony 209 end;
5280    
5281     procedure TIBGenerator.SetGeneratorName(AValue: string);
5282     begin
5283     if FGeneratorName = AValue then Exit;
5284     FGeneratorName := AValue;
5285     SetQuerySQL;
5286     end;
5287    
5288     function TIBGenerator.GetNextValue: integer;
5289     begin
5290     with FQuery do
5291     begin
5292     Transaction.Active := true;
5293     ExecQuery;
5294     try
5295     Result := Fields[0].AsInteger
5296     finally
5297     Close
5298     end;
5299     end;
5300     end;
5301    
5302     constructor TIBGenerator.Create(Owner: TIBCustomDataSet);
5303     begin
5304     FOwner := Owner;
5305     FIncrement := 1;
5306     FQuery := TIBSQL.Create(nil);
5307     end;
5308    
5309     destructor TIBGenerator.Destroy;
5310     begin
5311     if assigned(FQuery) then FQuery.Free;
5312     inherited Destroy;
5313     end;
5314    
5315    
5316     procedure TIBGenerator.Apply;
5317     begin
5318     if assigned(Database) and assigned(Transaction) and
5319     (FGeneratorName <> '') and (FFieldName <> '') and Owner.FieldByName(FFieldName).IsNull then
5320     Owner.FieldByName(FFieldName).AsInteger := GetNextValue;
5321     end;
5322    
5323    
5324     end.