ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/IBCustomDataSet.pas
Revision: 1
Committed: Mon Jul 31 16:43:00 2000 UTC (23 years, 9 months ago) by tony
Content type: text/x-pascal
File size: 109527 byte(s)
Log Message:
Borland IBX Open Source Release

File Contents

# User Rev Content
1 tony 1 {************************************************************************}
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     {************************************************************************}
28    
29     unit IBCustomDataSet;
30    
31     interface
32    
33     uses
34     Windows, SysUtils, Classes, Forms, Controls, StdVCL,
35     IBExternals, IB, IBHeader, IBDatabase, IBSQL, Db,
36     IBUtils, IBBlob;
37    
38     const
39     BufferCacheSize = 1000; { Allocate cache in this many record chunks}
40     UniCache = 2; { Uni-directional cache is 2 records big }
41    
42     type
43     TIBCustomDataSet = class;
44     TIBDataSet = class;
45    
46     TIBDataSetUpdateObject = class(TComponent)
47     private
48     FRefreshSQL: TStrings;
49     procedure SetRefreshSQL(value: TStrings);
50     protected
51     function GetDataSet: TIBCustomDataSet; virtual; abstract;
52     procedure SetDataSet(ADataSet: TIBCustomDataSet); virtual; abstract;
53     procedure Apply(UpdateKind: TUpdateKind); virtual; abstract;
54     function GetSQL(UpdateKind: TUpdateKind): TStrings; virtual; abstract;
55     property DataSet: TIBCustomDataSet read GetDataSet write SetDataSet;
56     public
57     constructor Create(AOwner: TComponent); override;
58     destructor Destroy; override;
59     published
60     property RefreshSQL: TStrings read FRefreshSQL write SetRefreshSQL;
61     end;
62    
63     PDateTime = ^TDateTime;
64     TBlobDataArray = array[0..0] of TIBBlobStream;
65     PBlobDataArray = ^TBlobDataArray;
66    
67     { TIBCustomDataSet }
68     TFieldData = record
69     fdDataType: Short;
70     fdDataScale: Short;
71     fdNullable: Boolean;
72     fdIsNull: Boolean;
73     fdDataSize: Short;
74     fdDataLength: Short;
75     fdDataOfs: Integer;
76     end;
77     PFieldData = ^TFieldData;
78    
79     TCachedUpdateStatus = (
80     cusUnmodified, cusModified, cusInserted,
81     cusDeleted, cusUninserted
82     );
83     TIBDBKey = record
84     DBKey: array[0..7] of Byte;
85     end;
86     PIBDBKey = ^TIBDBKey;
87    
88     TRecordData = record
89     rdBookmarkFlag: TBookmarkFlag;
90     rdFieldCount: Short;
91     rdRecordNumber: Long;
92     rdCachedUpdateStatus: TCachedUpdateStatus;
93     rdUpdateStatus: TUpdateStatus;
94     rdSavedOffset: DWORD;
95     rdDBKey: TIBDBKey;
96     rdFields: array[1..1] of TFieldData;
97     end;
98     PRecordData = ^TRecordData;
99    
100     { TIBStringField allows us to have strings longer than 8196 }
101    
102     TIBStringField = class(TStringField)
103     public
104     constructor create(AOwner: TComponent); override;
105     class procedure CheckTypeSize(Value: Integer); override;
106     function GetAsString: string; override;
107     function GetAsVariant: Variant; override;
108     function GetValue(var Value: string): Boolean;
109     procedure SetAsString(const Value: string); override;
110     end;
111    
112     { TIBBCDField }
113     { Actually, there is no BCD involved in this type,
114     instead it deals with currency types.
115     In IB, this is an encapsulation of Numeric (x, y)
116     where x < 18 and y <= 4.
117     Note: y > 4 will default to Floats
118     }
119     TIBBCDField = class(TBCDField)
120     protected
121     class procedure CheckTypeSize(Value: Integer); override;
122     function GetAsCurrency: Currency; override;
123     function GetAsString: string; override;
124     function GetAsVariant: Variant; override;
125     function GetDataSize: Integer; override;
126     public
127     constructor Create(AOwner: TComponent); override;
128     published
129     property Size default 8;
130     end;
131    
132     TIBDataLink = class(TDetailDataLink)
133     private
134     FDataSet: TIBCustomDataSet;
135     protected
136     procedure ActiveChanged; override;
137     procedure RecordChanged(Field: TField); override;
138     function GetDetailDataSet: TDataSet; override;
139     procedure CheckBrowseMode; override;
140     public
141     constructor Create(ADataSet: TIBCustomDataSet);
142     destructor Destroy; override;
143     end;
144    
145     { TIBCustomDataSet }
146     TIBUpdateAction = (uaFail, uaAbort, uaSkip, uaRetry, uaApply, uaApplied);
147    
148     TIBUpdateErrorEvent = procedure(DataSet: TDataSet; E: EDatabaseError;
149     UpdateKind: TUpdateKind; var UpdateAction: TIBUpdateAction)
150     of object;
151     TIBUpdateRecordEvent = procedure(DataSet: TDataSet; UpdateKind: TUpdateKind;
152     var UpdateAction: TIBUpdateAction) of object;
153    
154     TIBUpdateRecordTypes = set of TCachedUpdateStatus;
155    
156     TIBCustomDataSet = class(TDataset)
157     private
158     FNeedsRefresh: Boolean;
159     FForcedRefresh: Boolean;
160     FDidActivate: Boolean;
161     FIBLoaded: Boolean;
162     FBase: TIBBase;
163     FBlobCacheOffset: Integer;
164     FBlobStreamList: TList;
165     FBufferChunks: Integer;
166     FBufferCache,
167     FOldBufferCache: PChar;
168     FBufferChunkSize,
169     FCacheSize,
170     FOldCacheSize: Integer;
171     FFilterBuffer: PChar;
172     FBPos,
173     FOBPos,
174     FBEnd,
175     FOBEnd: DWord;
176     FCachedUpdates: Boolean;
177     FCalcFieldsOffset: Integer;
178     FCurrentRecord: Long;
179     FDeletedRecords: Long;
180     FModelBuffer,
181     FOldBuffer: PChar;
182     FOpen: Boolean;
183     FInternalPrepared: Boolean;
184     FQDelete,
185     FQInsert,
186     FQRefresh,
187     FQSelect,
188     FQModify: TIBSQL;
189     FRecordBufferSize: Integer;
190     FRecordCount: Integer;
191     FRecordSize: Integer;
192     FUniDirectional: Boolean;
193     FUpdateMode: TUpdateMode;
194     FUpdateObject: TIBDataSetUpdateObject;
195     FParamCheck: Boolean;
196     FUpdatesPending: Boolean;
197     FUpdateRecordTypes: TIBUpdateRecordTypes;
198     FMappedFieldPosition: array of Integer;
199     FDataLink: TIBDataLink;
200    
201     FBeforeDatabaseDisconnect,
202     FAfterDatabaseDisconnect,
203     FDatabaseFree: TNotifyEvent;
204     FOnUpdateError: TIBUpdateErrorEvent;
205     FOnUpdateRecord: TIBUpdateRecordEvent;
206     FBeforeTransactionEnd,
207     FAfterTransactionEnd,
208     FTransactionFree: TNotifyEvent;
209    
210     function GetSelectStmtHandle: TISC_STMT_HANDLE;
211     procedure SetUpdateMode(const Value: TUpdateMode);
212     procedure SetUpdateObject(Value: TIBDataSetUpdateObject);
213    
214     function AdjustCurrentRecord(Buffer: Pointer; GetMode: TGetMode): TGetResult;
215     procedure AdjustRecordOnInsert(Buffer: Pointer);
216     function CanEdit: Boolean;
217     function CanInsert: Boolean;
218     function CanDelete: Boolean;
219     function CanRefresh: Boolean;
220     procedure CheckEditState;
221     procedure ClearBlobCache;
222     procedure CopyRecordBuffer(Source, Dest: Pointer);
223     procedure DoBeforeDatabaseDisconnect(Sender: TObject);
224     procedure DoAfterDatabaseDisconnect(Sender: TObject);
225     procedure DoDatabaseFree(Sender: TObject);
226     procedure DoBeforeTransactionEnd(Sender: TObject);
227     procedure DoAfterTransactionEnd(Sender: TObject);
228     procedure DoTransactionFree(Sender: TObject);
229     procedure FetchCurrentRecordToBuffer(Qry: TIBSQL; RecordNumber: Integer;
230     Buffer: PChar);
231     function GetDatabase: TIBDatabase;
232     function GetDBHandle: PISC_DB_HANDLE;
233     function GetDeleteSQL: TStrings;
234     function GetInsertSQL: TStrings;
235     function GetSQLParams: TIBXSQLDA;
236     function GetRefreshSQL: TStrings;
237     function GetSelectSQL: TStrings;
238     function GetStatementType: TIBSQLTypes;
239     function GetModifySQL: TStrings;
240     function GetTransaction: TIBTransaction;
241     function GetTRHandle: PISC_TR_HANDLE;
242     procedure InternalDeleteRecord(Qry: TIBSQL; Buff: Pointer);
243     function InternalLocate(const KeyFields: string; const KeyValues: Variant;
244     Options: TLocateOptions): Boolean; virtual;
245     procedure InternalPostRecord(Qry: TIBSQL; Buff: Pointer);
246     procedure InternalRevertRecord(RecordNumber: Integer);
247     function IsVisible(Buffer: PChar): Boolean;
248     procedure SaveOldBuffer(Buffer: PChar);
249     procedure SetBufferChunks(Value: Integer);
250     procedure SetDatabase(Value: TIBDatabase);
251     procedure SetDeleteSQL(Value: TStrings);
252     procedure SetInsertSQL(Value: TStrings);
253     procedure SetInternalSQLParams(Qry: TIBSQL; Buffer: Pointer);
254     procedure SetRefreshSQL(Value: TStrings);
255     procedure SetSelectSQL(Value: TStrings);
256     procedure SetModifySQL(Value: TStrings);
257     procedure SetTransaction(Value: TIBTransaction);
258     procedure SetUpdateRecordTypes(Value: TIBUpdateRecordTypes);
259     procedure SetUniDirectional(Value: Boolean);
260     procedure RefreshParams;
261     procedure SQLChanging(Sender: TObject); virtual;
262     function AdjustPosition(FCache: PChar; Offset: DWORD;
263     Origin: Integer): Integer;
264     procedure ReadCache(FCache: PChar; Offset: DWORD; Origin: Integer;
265     Buffer: PChar);
266     procedure ReadRecordCache(RecordNumber: Integer; Buffer: PChar;
267     ReadOldBuffer: Boolean);
268     procedure WriteCache(FCache: PChar; Offset: DWORD; Origin: Integer;
269     Buffer: PChar);
270     procedure WriteRecordCache(RecordNumber: Integer; Buffer: PChar);
271     function InternalGetRecord(Buffer: PChar; GetMode: TGetMode;
272     DoCheck: Boolean): TGetResult;
273    
274     protected
275     procedure ActivateConnection;
276     function ActivateTransaction: Boolean;
277     procedure DeactivateTransaction;
278     procedure CheckDatasetClosed;
279     procedure CheckDatasetOpen;
280     function GetActiveBuf: PChar;
281     procedure InternalBatchInput(InputObject: TIBBatchInput);
282     procedure InternalBatchOutput(OutputObject: TIBBatchOutput);
283     procedure InternalPrepare; virtual;
284     procedure InternalUnPrepare; virtual;
285     procedure InternalExecQuery; virtual;
286     procedure InternalRefreshRow; virtual;
287     procedure InternalSetParamsFromCursor;
288     procedure CheckNotUniDirectional;
289    
290     { IProviderSupport }
291     procedure PSEndTransaction(Commit: Boolean); override;
292     function PSExecuteStatement(const ASQL: string; AParams: TParams;
293     ResultSet: Pointer = nil): Integer; override;
294     function PsGetTableName: string; override;
295     function PSGetQuoteChar: string; override;
296     function PSGetUpdateException(E: Exception; Prev: EUpdateError): EUpdateError; override;
297     function PSInTransaction: Boolean; override;
298     function PSIsSQLBased: Boolean; override;
299     function PSIsSQLSupported: Boolean; override;
300     procedure PSStartTransaction; override;
301     procedure PSReset; override;
302     function PSUpdateRecord(UpdateKind: TUpdateKind; Delta: TDataSet): Boolean; override;
303    
304     { TDataSet support }
305     procedure InternalInsert; override;
306     procedure InitRecord(Buffer: PChar); override;
307     procedure Disconnect; virtual;
308     function ConstraintsStored: Boolean;
309     procedure ClearCalcFields(Buffer: PChar); override;
310     function AllocRecordBuffer: PChar; override;
311     procedure DoBeforeDelete; override;
312     procedure DoBeforeEdit; override;
313     procedure DoBeforeInsert; override;
314     procedure FreeRecordBuffer(var Buffer: PChar); override;
315     procedure GetBookmarkData(Buffer: PChar; Data: Pointer); override;
316     function GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; override;
317     function GetCanModify: Boolean; override;
318     function GetDataSource: TDataSource; override;
319     function GetFieldClass(FieldType: TFieldType): TFieldClass; override;
320     function GetRecNo: Integer; override;
321     function GetRecord(Buffer: PChar; GetMode: TGetMode;
322     DoCheck: Boolean): TGetResult; override;
323     function GetRecordCount: Integer; override;
324     function GetRecordSize: Word; override;
325     procedure InternalAddRecord(Buffer: Pointer; Append: Boolean); override;
326     procedure InternalCancel; override;
327     procedure InternalClose; override;
328     procedure InternalDelete; override;
329     procedure InternalFirst; override;
330     function InternalGetFieldData(Field: TField; Buffer: Pointer): Boolean;
331     procedure InternalGotoBookmark(Bookmark: Pointer); override;
332     procedure InternalHandleException; override;
333     procedure InternalInitFieldDefs; override;
334     procedure InternalInitRecord(Buffer: PChar); override;
335     procedure InternalLast; override;
336     procedure InternalOpen; override;
337     procedure InternalPost; override;
338     procedure InternalRefresh; override;
339     procedure InternalSetFieldData(Field: TField; Buffer: Pointer);
340     procedure InternalSetToRecord(Buffer: PChar); override;
341     function IsCursorOpen: Boolean; override;
342     procedure ReQuery;
343     procedure SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); override;
344     procedure SetBookmarkData(Buffer: PChar; Data: Pointer); override;
345     procedure SetCachedUpdates(Value: Boolean);
346     procedure SetDataSource(Value: TDataSource);
347     procedure SetFieldData(Field : TField; Buffer : Pointer); override;
348     procedure SetFieldData(Field : TField; Buffer : Pointer;
349     NativeFormat : Boolean); overload; override;
350     procedure SetRecNo(Value: Integer); override;
351    
352     protected
353     {Likely to be made public by descendant classes}
354     property SQLParams: TIBXSQLDA read GetSQLParams;
355     property Params: TIBXSQLDA read GetSQLParams;
356     property InternalPrepared: Boolean read FInternalPrepared;
357     property QDelete: TIBSQL read FQDelete;
358     property QInsert: TIBSQL read FQInsert;
359     property QRefresh: TIBSQL read FQRefresh;
360     property QSelect: TIBSQL read FQSelect;
361     property QModify: TIBSQL read FQModify;
362     property StatementType: TIBSQLTypes read GetStatementType;
363     property SelectStmtHandle: TISC_STMT_HANDLE read GetSelectStmtHandle;
364    
365     {Likely to be made published by descendant classes}
366     property BufferChunks: Integer read FBufferChunks write SetBufferChunks;
367     property CachedUpdates: Boolean read FCachedUpdates write SetCachedUpdates;
368     property UniDirectional: Boolean read FUniDirectional write SetUniDirectional default False;
369     property DeleteSQL: TStrings read GetDeleteSQL write SetDeleteSQL;
370     property InsertSQL: TStrings read GetInsertSQL write SetInsertSQL;
371     property RefreshSQL: TStrings read GetRefreshSQL write SetRefreshSQL;
372     property SelectSQL: TStrings read GetSelectSQL write SetSelectSQL;
373     property ModifySQL: TStrings read GetModifySQL write SetModifySQL;
374     property UpdateMode: TUpdateMode read FUpdateMode write SetUpdateMode default upWhereAll;
375     property ParamCheck: Boolean read FParamCheck write FParamCheck default True;
376    
377     property BeforeDatabaseDisconnect: TNotifyEvent read FBeforeDatabaseDisconnect
378     write FBeforeDatabaseDisconnect;
379     property AfterDatabaseDisconnect: TNotifyEvent read FAfterDatabaseDisconnect
380     write FAfterDatabaseDisconnect;
381     property DatabaseFree: TNotifyEvent read FDatabaseFree
382     write FDatabaseFree;
383     property BeforeTransactionEnd: TNotifyEvent read FBeforeTransactionEnd
384     write FBeforeTransactionEnd;
385     property AfterTransactionEnd: TNotifyEvent read FAfterTransactionEnd
386     write FAfterTransactionEnd;
387     property TransactionFree: TNotifyEvent read FTransactionFree
388     write FTransactionFree;
389    
390     public
391     constructor Create(AOwner: TComponent); override;
392     destructor Destroy; override;
393     procedure ApplyUpdates;
394     function CachedUpdateStatus: TCachedUpdateStatus;
395     procedure CancelUpdates;
396     procedure FetchAll;
397     function LocateNext(const KeyFields: string; const KeyValues: Variant;
398     Options: TLocateOptions): Boolean;
399     procedure RecordModified(Value: Boolean);
400     procedure RevertRecord;
401     procedure Undelete;
402    
403     { TDataSet support methods }
404     function BookmarkValid(Bookmark: TBookmark): Boolean; override;
405     function CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Integer; override;
406     function CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; override;
407     function GetCurrentRecord(Buffer: PChar): Boolean; override;
408     function GetFieldData(Field : TField; Buffer : Pointer) : Boolean; overload; override;
409     function GetFieldData(FieldNo: Integer; Buffer: Pointer): Boolean; overload; override;
410     function GetFieldData(Field : TField; Buffer : Pointer;
411     NativeFormat : Boolean) : Boolean; overload; override;
412     function Locate(const KeyFields: string; const KeyValues: Variant;
413     Options: TLocateOptions): Boolean; override;
414     function Lookup(const KeyFields: string; const KeyValues: Variant;
415     const ResultFields: string): Variant; override;
416     function UpdateStatus: TUpdateStatus; override;
417     function IsSequenced: Boolean; override;
418    
419     property DBHandle: PISC_DB_HANDLE read GetDBHandle;
420     property TRHandle: PISC_TR_HANDLE read GetTRHandle;
421     property UpdateObject: TIBDataSetUpdateObject read FUpdateObject write SetUpdateObject;
422     property UpdatesPending: Boolean read FUpdatesPending;
423     property UpdateRecordTypes: TIBUpdateRecordTypes read FUpdateRecordTypes
424     write SetUpdateRecordTypes;
425    
426     published
427     property Database: TIBDatabase read GetDatabase write SetDatabase;
428     property Transaction: TIBTransaction read GetTransaction
429     write SetTransaction;
430     property ForcedRefresh: Boolean read FForcedRefresh
431     write FForcedRefresh default False;
432     property AutoCalcFields;
433     property ObjectView default False;
434    
435     property AfterCancel;
436     property AfterClose;
437     property AfterDelete;
438     property AfterEdit;
439     property AfterInsert;
440     property AfterOpen;
441     property AfterPost;
442     property AfterRefresh;
443     property AfterScroll;
444     property BeforeCancel;
445     property BeforeClose;
446     property BeforeDelete;
447     property BeforeEdit;
448     property BeforeInsert;
449     property BeforeOpen;
450     property BeforePost;
451     property BeforeRefresh;
452     property BeforeScroll;
453     property OnCalcFields;
454     property OnDeleteError;
455     property OnEditError;
456     property OnNewRecord;
457     property OnPostError;
458     property OnUpdateError: TIBUpdateErrorEvent read FOnUpdateError
459     write FOnUpdateError;
460     property OnUpdateRecord: TIBUpdateRecordEvent read FOnUpdateRecord
461     write FOnUpdateRecord;
462     end;
463    
464     TIBDataSet = class(TIBCustomDataSet)
465     private
466     function GetPrepared: Boolean;
467    
468     protected
469     procedure SetFiltered(Value: Boolean); override;
470     procedure InternalOpen; override;
471    
472     public
473     procedure Prepare;
474     procedure UnPrepare;
475     procedure BatchInput(InputObject: TIBBatchInput);
476     procedure BatchOutput(OutputObject: TIBBatchOutput);
477     procedure ExecSQL;
478    
479     public
480     property Params;
481     property Prepared : Boolean read GetPrepared;
482     property QDelete;
483     property QInsert;
484     property QRefresh;
485     property QSelect;
486     property QModify;
487     property StatementType;
488     property SelectStmtHandle;
489    
490     published
491     { TIBCustomDataSet }
492     property BufferChunks;
493     property CachedUpdates;
494     property DeleteSQL;
495     property InsertSQL;
496     property RefreshSQL;
497     property SelectSQL;
498     property ModifySQL;
499     property ParamCheck;
500     property UniDirectional;
501     property Filtered;
502    
503     property BeforeDatabaseDisconnect;
504     property AfterDatabaseDisconnect;
505     property DatabaseFree;
506     property BeforeTransactionEnd;
507     property AfterTransactionEnd;
508     property TransactionFree;
509    
510     { TIBDataSet }
511     property Active;
512     property AutoCalcFields;
513     property DataSource read GetDataSource write SetDataSource;
514    
515     property AfterCancel;
516     property AfterClose;
517     property AfterDelete;
518     property AfterEdit;
519     property AfterInsert;
520     property AfterOpen;
521     property AfterPost;
522     property AfterScroll;
523     property BeforeCancel;
524     property BeforeClose;
525     property BeforeDelete;
526     property BeforeEdit;
527     property BeforeInsert;
528     property BeforeOpen;
529     property BeforePost;
530     property BeforeScroll;
531     property OnCalcFields;
532     property OnDeleteError;
533     property OnEditError;
534     property OnFilterRecord;
535     property OnNewRecord;
536     property OnPostError;
537     end;
538    
539     { TIBDSBlobStream }
540     TIBDSBlobStream = class(TStream)
541     protected
542     FField: TField;
543     FBlobStream: TIBBlobStream;
544     public
545     constructor Create(AField: TField; ABlobStream: TIBBlobStream;
546     Mode: TBlobStreamMode);
547     function Read(var Buffer; Count: Longint): Longint; override;
548     function Seek(Offset: Longint; Origin: Word): Longint; override;
549     procedure SetSize(NewSize: Longint); override;
550     function Write(const Buffer; Count: Longint): Longint; override;
551     end;
552    
553     const
554     DefaultFieldClasses: array[TFieldType] of TFieldClass = (
555     nil, { ftUnknown }
556     TIBStringField, { ftString }
557     TSmallintField, { ftSmallint }
558     TIntegerField, { ftInteger }
559     TWordField, { ftWord }
560     TBooleanField, { ftBoolean }
561     TFloatField, { ftFloat }
562     TCurrencyField, { ftCurrency }
563     TIBBCDField, { ftBCD }
564     TDateField, { ftDate }
565     TTimeField, { ftTime }
566     TDateTimeField, { ftDateTime }
567     TBytesField, { ftBytes }
568     TVarBytesField, { ftVarBytes }
569     TAutoIncField, { ftAutoInc }
570     TBlobField, { ftBlob }
571     TMemoField, { ftMemo }
572     TGraphicField, { ftGraphic }
573     TBlobField, { ftFmtMemo }
574     TBlobField, { ftParadoxOle }
575     TBlobField, { ftDBaseOle }
576     TBlobField, { ftTypedBinary }
577     nil, { ftCursor }
578     TStringField, { ftFixedChar }
579     nil, {TWideStringField } { ftWideString }
580     TLargeIntField, { ftLargeInt }
581     TADTField, { ftADT }
582     TArrayField, { ftArray }
583     TReferenceField, { ftReference }
584     TDataSetField, { ftDataSet }
585     TBlobField, { ftOraBlob }
586     TMemoField, { ftOraClob }
587     TVariantField, { ftVariant }
588     TInterfaceField, { ftInterface }
589     TIDispatchField, { ftIDispatch }
590     TGuidField); { ftGuid }
591     var
592     CreateProviderProc: function(DataSet: TIBCustomDataSet): IProvider = nil;
593    
594     implementation
595    
596     uses IBIntf, IBQuery;
597    
598     type
599    
600     TFieldNode = class(TObject)
601     protected
602     FieldName : String;
603     COMPUTED_BLR : Boolean;
604     DEFAULT_VALUE : boolean;
605     NextField : TFieldNode;
606     end;
607    
608     TRelationNode = class(TObject)
609     protected
610     RelationName : String;
611     FieldNodes : TFieldNode;
612     NextRelation : TRelationNode;
613     end;
614    
615    
616     { TIBStringField}
617    
618     constructor TIBStringField.Create(AOwner: TComponent);
619     begin
620     inherited;
621     end;
622    
623     class procedure TIBStringField.CheckTypeSize(Value: Integer);
624     begin
625     { don't check string size. all sizes valid }
626     end;
627    
628     function TIBStringField.GetAsString: string;
629     begin
630     if not GetValue(Result) then Result := '';
631     end;
632    
633     function TIBStringField.GetAsVariant: Variant;
634     var
635     S: string;
636     begin
637     if GetValue(S) then Result := S else Result := Null;
638     end;
639    
640     function TIBStringField.GetValue(var Value: string): Boolean;
641     var
642     Buffer: PChar;
643     begin
644     Buffer := nil;
645     IBAlloc(Buffer, 0, Size + 1);
646     try
647     Result := GetData(Buffer);
648     if Result then
649     begin
650     Value := string(Buffer);
651     if Transliterate and (Value <> '') then
652     DataSet.Translate(PChar(Value), PChar(Value), False);
653     end
654     finally
655     FreeMem(Buffer);
656     end;
657     end;
658    
659     procedure TIBStringField.SetAsString(const Value: string);
660     var
661     Buffer: PChar;
662     begin
663     Buffer := nil;
664     IBAlloc(Buffer, 0, Size + 1);
665     try
666     StrLCopy(Buffer, PChar(Value), Size);
667     if Transliterate then
668     DataSet.Translate(Buffer, Buffer, True);
669     SetData(Buffer);
670     finally
671     FreeMem(Buffer);
672     end;
673     end;
674    
675     { TIBBCDField }
676    
677     constructor TIBBCDField.Create(AOwner: TComponent);
678     begin
679     inherited Create(AOwner);
680     SetDataType(ftBCD);
681     Size := 8;
682     end;
683    
684     class procedure TIBBCDField.CheckTypeSize(Value: Integer);
685     begin
686     { No need to check as the base type is currency, not BCD }
687     end;
688    
689     function TIBBCDField.GetAsCurrency: Currency;
690     begin
691     if not GetValue(Result) then
692     Result := 0;
693     end;
694    
695     function TIBBCDField.GetAsString: string;
696     var
697     C: System.Currency;
698     begin
699     if GetValue(C) then
700     Result := CurrToStr(C)
701     else
702     Result := '';
703     end;
704    
705     function TIBBCDField.GetAsVariant: Variant;
706     var
707     C: System.Currency;
708     begin
709     if GetValue(C) then
710     Result := C
711     else
712     Result := Null;
713     end;
714    
715     function TIBBCDField.GetDataSize: Integer;
716     begin
717     Result := 8;
718     end;
719    
720     { TIBDataLink }
721    
722     constructor TIBDataLink.Create(ADataSet: TIBCustomDataSet);
723     begin
724     inherited Create;
725     FDataSet := ADataSet;
726     end;
727    
728     destructor TIBDataLink.Destroy;
729     begin
730     FDataSet.FDataLink := nil;
731     inherited;
732     end;
733    
734    
735     procedure TIBDataLink.ActiveChanged;
736     begin
737     if FDataSet.Active then
738     FDataSet.RefreshParams;
739     end;
740    
741    
742     function TIBDataLink.GetDetailDataSet: TDataSet;
743     begin
744     Result := FDataSet;
745     end;
746    
747     procedure TIBDataLink.RecordChanged(Field: TField);
748     begin
749     if (Field = nil) and FDataSet.Active then
750     FDataSet.RefreshParams;
751     end;
752    
753     procedure TIBDataLink.CheckBrowseMode;
754     begin
755     if FDataSet.Active then
756     FDataSet.CheckBrowseMode;
757     end;
758    
759     { TIBCustomDataSet }
760    
761     constructor TIBCustomDataSet.Create(AOwner: TComponent);
762     begin
763     inherited;
764     FIBLoaded := False;
765     CheckIBLoaded;
766     FIBLoaded := True;
767     FBase := TIBBase.Create(Self);
768     FCurrentRecord := -1;
769     FDeletedRecords := 0;
770     FUniDirectional := False;
771     FBufferChunks := BufferCacheSize;
772     FBlobStreamList := TList.Create;
773     FDataLink := TIBDataLink.Create(Self);
774     FQDelete := TIBSQL.Create(Self);
775     FQDelete.OnSQLChanging := SQLChanging;
776     FQDelete.GoToFirstRecordOnExecute := False;
777     FQInsert := TIBSQL.Create(Self);
778     FQInsert.OnSQLChanging := SQLChanging;
779     FQInsert.GoToFirstRecordOnExecute := False;
780     FQRefresh := TIBSQL.Create(Self);
781     FQRefresh.OnSQLChanging := SQLChanging;
782     FQRefresh.GoToFirstRecordOnExecute := False;
783     FQSelect := TIBSQL.Create(Self);
784     FQSelect.OnSQLChanging := SQLChanging;
785     FQSelect.GoToFirstRecordOnExecute := False;
786     FQModify := TIBSQL.Create(Self);
787     FQModify.OnSQLChanging := SQLChanging;
788     FQModify.GoToFirstRecordOnExecute := False;
789     FUpdateRecordTypes := [cusUnmodified, cusModified, cusInserted];
790     FParamCheck := True;
791     FForcedRefresh := False;
792     {Bookmark Size is Integer for IBX}
793     BookmarkSize := SizeOf(Integer);
794     FBase.BeforeDatabaseDisconnect := DoBeforeDatabaseDisconnect;
795     FBase.AfterDatabaseDisconnect := DoAfterDatabaseDisconnect;
796     FBase.OnDatabaseFree := DoDatabaseFree;
797     FBase.BeforeTransactionEnd := DoBeforeTransactionEnd;
798     FBase.AfterTransactionEnd := DoAfterTransactionEnd;
799     FBase.OnTransactionFree := DoTransactionFree;
800     if AOwner is TIBDatabase then
801     Database := TIBDatabase(AOwner)
802     else
803     if AOwner is TIBTransaction then
804     Transaction := TIBTransaction(AOwner);
805     end;
806    
807     destructor TIBCustomDataSet.Destroy;
808     begin
809     inherited;
810     if FIBLoaded then
811     begin
812     FDataLink.Free;
813     FBase.Free;
814     ClearBlobCache;
815     FBlobStreamList.Free;
816     FreeMem(FBufferCache);
817     FBufferCache := nil;
818     FreeMem(FOldBufferCache);
819     FOldBufferCache := nil;
820     FCacheSize := 0;
821     FOldCacheSize := 0;
822     FMappedFieldPosition := nil;
823     end;
824     end;
825    
826     function TIBCustomDataSet.AdjustCurrentRecord(Buffer: Pointer; GetMode: TGetMode):
827     TGetResult;
828     begin
829     while not IsVisible(Buffer) do
830     begin
831     if GetMode = gmPrior then
832     begin
833     Dec(FCurrentRecord);
834     if FCurrentRecord = -1 then
835     begin
836     result := grBOF;
837     exit;
838     end;
839     ReadRecordCache(FCurrentRecord, Buffer, False);
840     end
841     else begin
842     Inc(FCurrentRecord);
843     if (FCurrentRecord = FRecordCount) then
844     begin
845     if (not FQSelect.EOF) and (FQSelect.Next <> nil) then
846     begin
847     FetchCurrentRecordToBuffer(FQSelect, FCurrentRecord, Buffer);
848     Inc(FRecordCount);
849     end
850     else begin
851     result := grEOF;
852     exit;
853     end;
854     end
855     else
856     ReadRecordCache(FCurrentRecord, Buffer, False);
857     end;
858     end;
859     result := grOK;
860     end;
861    
862     procedure TIBCustomDataSet.ApplyUpdates;
863     var
864     CurBookmark: string;
865     Buffer: PRecordData;
866     CurUpdateTypes: TIBUpdateRecordTypes;
867     UpdateAction: TIBUpdateAction;
868     UpdateKind: TUpdateKind;
869     bRecordsSkipped: Boolean;
870    
871     procedure GetUpdateKind;
872     begin
873     case Buffer^.rdCachedUpdateStatus of
874     cusModified:
875     UpdateKind := ukModify;
876     cusInserted:
877     UpdateKind := ukInsert;
878     else
879     UpdateKind := ukDelete;
880     end;
881     end;
882    
883     procedure ResetBufferUpdateStatus;
884     begin
885     case Buffer^.rdCachedUpdateStatus of
886     cusModified:
887     begin
888     PRecordData(Buffer)^.rdUpdateStatus := usUnmodified;
889     PRecordData(Buffer)^.rdCachedUpdateStatus := cusUnmodified;
890     end;
891     cusInserted:
892     begin
893     PRecordData(Buffer)^.rdUpdateStatus := usUnmodified;
894     PRecordData(Buffer)^.rdCachedUpdateStatus := cusUnmodified;
895     end;
896     cusDeleted:
897     begin
898     PRecordData(Buffer)^.rdUpdateStatus := usDeleted;
899     PRecordData(Buffer)^.rdCachedUpdateStatus := cusUnmodified;
900     end;
901     end;
902     WriteRecordCache(PRecordData(Buffer)^.rdRecordNumber, Pointer(Buffer));
903     end;
904    
905     procedure UpdateUsingOnUpdateRecord;
906     begin
907     UpdateAction := uaFail;
908     try
909     FOnUpdateRecord(Self, UpdateKind, UpdateAction);
910     except
911     on E: Exception do
912     begin
913     if (E is EDatabaseError) and Assigned(FOnUpdateError) then
914     FOnUpdateError(Self, EIBError(E), UpdateKind, UpdateAction);
915     if UpdateAction = uaFail then
916     raise;
917     end;
918     end;
919     end;
920    
921     procedure UpdateUsingUpdateObject;
922     begin
923     try
924     FUpdateObject.Apply(UpdateKind);
925     ResetBufferUpdateStatus;
926     except
927     on E: Exception do
928     if (E is EDatabaseError) and Assigned(FOnUpdateError) then
929     FOnUpdateError(Self, EIBError(E), UpdateKind, UpdateAction);
930     end;
931     end;
932    
933     procedure UpdateUsingInternalquery;
934     begin
935     try
936     case Buffer^.rdCachedUpdateStatus of
937     cusModified:
938     InternalPostRecord(FQModify, Buffer);
939     cusInserted:
940     InternalPostRecord(FQInsert, Buffer);
941     cusDeleted:
942     InternalDeleteRecord(FQDelete, Buffer);
943     end;
944     except
945     on E: EIBError do begin
946     UpdateAction := uaFail;
947     if Assigned(FOnUpdateError) then
948     FOnUpdateError(Self, E, UpdateKind, UpdateAction);
949     case UpdateAction of
950     uaFail: raise;
951     uaAbort: SysUtils.Abort;
952     uaSkip: bRecordsSkipped := True;
953     end;
954     end;
955     end;
956     end;
957    
958     begin
959     if State in [dsEdit, dsInsert] then
960     Post;
961     FBase.CheckDatabase;
962     FBase.CheckTransaction;
963     DisableControls;
964     CurBookmark := Bookmark;
965     CurUpdateTypes := FUpdateRecordTypes;
966     FUpdateRecordTypes := [cusModified, cusInserted, cusDeleted];
967     try
968     First;
969     bRecordsSkipped := False;
970     while not EOF do
971     begin
972     Buffer := PRecordData(GetActiveBuf);
973     GetUpdateKind;
974     UpdateAction := uaApply;
975     if Assigned(FUpdateObject) or Assigned(FOnUpdateRecord) then
976     begin
977     if (Assigned(FOnUpdateRecord)) then
978     UpdateUsingOnUpdateRecord
979     else
980     if Assigned(FUpdateObject) then
981     UpdateUsingUpdateObject;
982     case UpdateAction of
983     uaFail:
984     IBError(ibxeUserAbort, [nil]);
985     uaAbort:
986     SysUtils.Abort;
987     uaApplied:
988     ResetBufferUpdateStatus;
989     uaSkip:
990     bRecordsSkipped := True;
991     uaRetry:
992     Continue;
993     end;
994     end;
995     if (not Assigned(FUpdateObject)) and (UpdateAction = UaApply) then
996     begin
997     UpdateUsingInternalquery;
998     UpdateAction := uaApplied;
999     end;
1000     Next;
1001     end;
1002     FUpdatesPending := bRecordsSkipped;
1003     finally
1004     FUpdateRecordTypes := CurUpdateTypes;
1005     Bookmark := CurBookmark;
1006     EnableControls;
1007     end;
1008     end;
1009    
1010     procedure TIBCustomDataSet.InternalBatchInput(InputObject: TIBBatchInput);
1011     begin
1012     FQSelect.BatchInput(InputObject);
1013     end;
1014    
1015     procedure TIBCustomDataSet.InternalBatchOutput(OutputObject: TIBBatchOutput);
1016     var
1017     Qry: TIBSQL;
1018     begin
1019     Qry := TIBSQL.Create(Self);
1020     try
1021     Qry.Database := FBase.Database;
1022     Qry.Transaction := FBase.Transaction;
1023     Qry.SQL.Assign(FQSelect.SQL);
1024     Qry.BatchOutput(OutputObject);
1025     finally
1026     Qry.Free;
1027     end;
1028     end;
1029    
1030     procedure TIBCustomDataSet.CancelUpdates;
1031     var
1032     CurUpdateTypes: TIBUpdateRecordTypes;
1033     begin
1034     if State in [dsEdit, dsInsert] then
1035     Post;
1036     if FCachedUpdates and FUpdatesPending then
1037     begin
1038     DisableControls;
1039     CurUpdateTypes := UpdateRecordTypes;
1040     UpdateRecordTypes := [cusModified, cusInserted, cusDeleted];
1041     try
1042     First;
1043     while not EOF do
1044     begin
1045     if UpdateStatus = usInserted then
1046     RevertRecord
1047     else
1048     begin
1049     RevertRecord;
1050     Next;
1051     end;
1052     end;
1053     finally
1054     UpdateRecordTypes := CurUpdateTypes;
1055     First;
1056     FUpdatesPending := False;
1057     EnableControls;
1058     end;
1059     end;
1060     end;
1061    
1062     procedure TIBCustomDataSet.ActivateConnection;
1063     begin
1064     if not Assigned(Database) then
1065     IBError(ibxeDatabaseNotAssigned, [nil]);
1066     if not Assigned(Transaction) then
1067     IBError(ibxeTransactionNotAssigned, [nil]);
1068     if not Database.Connected then Database.Open;
1069     end;
1070    
1071     function TIBCustomDataSet.ActivateTransaction: Boolean;
1072     begin
1073     Result := False;
1074     if not Assigned(Transaction) then
1075     IBError(ibxeTransactionNotAssigned, [nil]);
1076     if not Transaction.Active then
1077     begin
1078     Result := True;
1079     Transaction.StartTransaction;
1080     FDidActivate := True;
1081     end;
1082     end;
1083    
1084     procedure TIBCustomDataSet.DeactivateTransaction;
1085     var
1086     i: Integer;
1087     begin
1088     if not Assigned(Transaction) then
1089     IBError(ibxeTransactionNotAssigned, [nil]);
1090     with Transaction do
1091     begin
1092     for i := 0 to SQLObjectCount - 1 do
1093     begin
1094     if (SQLObjects[i] <> nil) and ((SQLObjects[i]).owner is TDataSet) then
1095     begin
1096     if TDataSet(SQLObjects[i].owner).Active then
1097     begin
1098     FDidActivate := False;
1099     exit;
1100     end;
1101     end;
1102     end;
1103     end;
1104     FInternalPrepared := False;
1105     if Transaction.InTransaction then
1106     Transaction.Commit;
1107     FDidActivate := False;
1108     end;
1109    
1110     procedure TIBCustomDataSet.CheckDatasetClosed;
1111     begin
1112     if FOpen then
1113     IBError(ibxeDatasetOpen, [nil]);
1114     end;
1115    
1116     procedure TIBCustomDataSet.CheckDatasetOpen;
1117     begin
1118     if not FOpen then
1119     IBError(ibxeDatasetClosed, [nil]);
1120     end;
1121    
1122     procedure TIBCustomDataSet.CheckNotUniDirectional;
1123     begin
1124     if UniDirectional then
1125     IBError(ibxeDataSetUniDirectional, [nil]);
1126     end;
1127    
1128     procedure TIBCustomDataSet.AdjustRecordOnInsert(Buffer: Pointer);
1129     begin
1130     with PRecordData(Buffer)^ do
1131     if (State = dsInsert) and (not Modified) then
1132     begin
1133     rdRecordNumber := FRecordCount;
1134     FCurrentRecord := FRecordCount;
1135     end;
1136     end;
1137    
1138     function TIBCustomDataSet.CanEdit: Boolean;
1139     var
1140     Buff: PRecordData;
1141     begin
1142     Buff := PRecordData(GetActiveBuf);
1143     result := (FQModify.SQL.Text <> '') or
1144     (Assigned(FUpdateObject) and (FUpdateObject.GetSQL(ukModify).Text <> '')) or
1145     ((Buff <> nil) and (Buff^.rdCachedUpdateStatus = cusInserted) and
1146     (FCachedUpdates));
1147     end;
1148    
1149     function TIBCustomDataSet.CanInsert: Boolean;
1150     begin
1151     result := (FQInsert.SQL.Text <> '') or
1152     (Assigned(FUpdateObject) and (FUpdateObject.GetSQL(ukInsert).Text <> ''));
1153     end;
1154    
1155     function TIBCustomDataSet.CanDelete: Boolean;
1156     begin
1157     if (FQDelete.SQL.Text <> '') or
1158     (Assigned(FUpdateObject) and (FUpdateObject.GetSQL(ukDelete).Text <> '')) then
1159     result := True
1160     else
1161     result := False;
1162     end;
1163    
1164     function TIBCustomDataSet.CanRefresh: Boolean;
1165     begin
1166     result := (FQRefresh.SQL.Text <> '') or
1167     (Assigned(FUpdateObject) and (FUpdateObject.RefreshSQL.Text <> ''));
1168     end;
1169    
1170     procedure TIBCustomDataSet.CheckEditState;
1171     begin
1172     case State of
1173     { Check all the wsEditMode types }
1174     dsEdit, dsInsert, dsSetKey, dsCalcFields, dsFilter,
1175     dsNewValue, dsInternalCalc :
1176     begin
1177     if (State in [dsEdit]) and (not CanEdit) then
1178     IBError(ibxeCannotUpdate, [nil]);
1179     if (State in [dsInsert]) and (not CanInsert) then
1180     IBError(ibxeCannotInsert, [nil]);
1181     end;
1182     else
1183     IBError(ibxeNotEditing, [])
1184     end;
1185     end;
1186    
1187     procedure TIBCustomDataSet.ClearBlobCache;
1188     var
1189     i: Integer;
1190     begin
1191     for i := 0 to FBlobStreamList.Count - 1 do
1192     begin
1193     TIBBlobStream(FBlobStreamList[i]).Free;
1194     FBlobStreamList[i] := nil;
1195     end;
1196     FBlobStreamList.Pack;
1197     end;
1198    
1199     procedure TIBCustomDataSet.CopyRecordBuffer(Source, Dest: Pointer);
1200     begin
1201     Move(Source^, Dest^, FRecordBufferSize);
1202     end;
1203    
1204     procedure TIBCustomDataSet.DoBeforeDatabaseDisconnect(Sender: TObject);
1205     begin
1206     if Active then
1207     Active := False;
1208     FInternalPrepared := False;
1209     if Assigned(FBeforeDatabaseDisconnect) then
1210     FBeforeDatabaseDisconnect(Sender);
1211     end;
1212    
1213     procedure TIBCustomDataSet.DoAfterDatabaseDisconnect(Sender: TObject);
1214     begin
1215     if Assigned(FAfterDatabaseDisconnect) then
1216     FAfterDatabaseDisconnect(Sender);
1217     end;
1218    
1219     procedure TIBCustomDataSet.DoDatabaseFree(Sender: TObject);
1220     begin
1221     if Assigned(FDatabaseFree) then
1222     FDatabaseFree(Sender);
1223     end;
1224    
1225     procedure TIBCustomDataSet.DoBeforeTransactionEnd(Sender: TObject);
1226     begin
1227     if Active then
1228     Active := False;
1229     if FQSelect <> nil then
1230     FQSelect.FreeHandle;
1231     if FQDelete <> nil then
1232     FQDelete.FreeHandle;
1233     if FQInsert <> nil then
1234     FQInsert.FreeHandle;
1235     if FQModify <> nil then
1236     FQModify.FreeHandle;
1237     if FQRefresh <> nil then
1238     FQRefresh.FreeHandle;
1239     if Assigned(FBeforeTransactionEnd) then
1240     FBeforeTransactionEnd(Sender);
1241     end;
1242    
1243     procedure TIBCustomDataSet.DoAfterTransactionEnd(Sender: TObject);
1244     begin
1245     if Assigned(FAfterTransactionEnd) then
1246     FAfterTransactionEnd(Sender);
1247     end;
1248    
1249     procedure TIBCustomDataSet.DoTransactionFree(Sender: TObject);
1250     begin
1251     if Assigned(FTransactionFree) then
1252     FTransactionFree(Sender);
1253     end;
1254    
1255     { Read the record from FQSelect.Current into the record buffer
1256     Then write the buffer to in memory cache }
1257     procedure TIBCustomDataSet.FetchCurrentRecordToBuffer(Qry: TIBSQL;
1258     RecordNumber: Integer; Buffer: PChar);
1259     var
1260     p: PRecordData;
1261     pbd: PBlobDataArray;
1262     i, j: Integer;
1263     LocalData: Pointer;
1264     LocalDate, LocalDouble: Double;
1265     LocalInt: Integer;
1266     LocalInt64: Int64;
1267     LocalCurrency: Currency;
1268     FieldsLoaded: Integer;
1269     begin
1270     p := PRecordData(Buffer);
1271     { Make sure blob cache is empty }
1272     pbd := PBlobDataArray(Buffer + FBlobCacheOffset);
1273     if RecordNumber > -1 then
1274     for i := 0 to BlobFieldCount - 1 do
1275     pbd^[i] := nil;
1276     { Get record information }
1277     p^.rdBookmarkFlag := bfCurrent;
1278     p^.rdFieldCount := Qry.Current.Count;
1279     p^.rdRecordNumber := RecordNumber;
1280     p^.rdUpdateStatus := usUnmodified;
1281     p^.rdCachedUpdateStatus := cusUnmodified;
1282     p^.rdSavedOffset := $FFFFFFFF;
1283    
1284     { Load up the fields }
1285     FieldsLoaded := FQSelect.Current.Count;
1286     j := 1;
1287     for i := 0 to Qry.Current.Count - 1 do
1288     begin
1289     if (Qry = FQSelect) then
1290     j := i + 1
1291     else begin
1292     if FieldsLoaded = 0 then
1293     break;
1294     j := FQSelect.FieldIndex[Qry.Current[i].Name] + 1;
1295     if j < 1 then
1296     continue
1297     else
1298     Dec(FieldsLoaded);
1299     end;
1300     with FQSelect.Current[j - 1].Data^ do
1301     if aliasname = 'IBX_INTERNAL_DBKEY' then {do not localize}
1302     begin
1303     if sqllen <= 8 then
1304     p^.rdDBKey := PIBDBKEY(Qry.Current[i].AsPointer)^;
1305     continue;
1306     end;
1307     if j > 0 then with p^ do
1308     begin
1309     rdFields[j].fdDataType :=
1310     Qry.Current[i].Data^.sqltype and (not 1);
1311     rdFields[j].fdDataScale :=
1312     Qry.Current[i].Data^.sqlscale;
1313     rdFields[j].fdNullable :=
1314     (Qry.Current[i].Data^.sqltype and 1 = 1);
1315     rdFields[j].fdIsNull :=
1316     (rdFields[j].fdNullable and (Qry.Current[i].Data^.sqlind^ = -1));
1317     LocalData := Qry.Current[i].Data^.sqldata;
1318     case rdFields[j].fdDataType of
1319     SQL_TIMESTAMP:
1320     begin
1321     rdFields[j].fdDataSize := SizeOf(TDateTime);
1322     if RecordNumber >= 0 then
1323     LocalDate := TimeStampToMSecs(DateTimeToTimeStamp(Qry.Current[i].AsDateTime));
1324     LocalData := PChar(@LocalDate);
1325     end;
1326     SQL_TYPE_DATE:
1327     begin
1328     rdFields[j].fdDataSize := SizeOf(TDateTime);
1329     if RecordNumber >= 0 then
1330     LocalInt := DateTimeToTimeStamp(Qry.Current[i].AsDateTime).Date;
1331     LocalData := PChar(@LocalInt);
1332     end;
1333     SQL_TYPE_TIME:
1334     begin
1335     rdFields[j].fdDataSize := SizeOf(TDateTime);
1336     if RecordNumber >= 0 then
1337     LocalInt := DateTimeToTimeStamp(Qry.Current[i].AsDateTime).Time;
1338     LocalData := PChar(@LocalInt);
1339     end;
1340     SQL_SHORT, SQL_LONG:
1341     begin
1342     if (rdFields[j].fdDataScale = 0) then
1343     begin
1344     rdFields[j].fdDataSize := SizeOf(Integer);
1345     if RecordNumber >= 0 then
1346     LocalInt := Qry.Current[i].AsLong;
1347     LocalData := PChar(@LocalInt);
1348     end
1349     else if (rdFields[j].fdDataScale >= (-4)) then
1350     begin
1351     rdFields[j].fdDataSize := SizeOf(Currency);
1352     if RecordNumber >= 0 then
1353     LocalCurrency := Qry.Current[i].AsCurrency;
1354     LocalData := PChar(@LocalCurrency);
1355     end
1356     else begin
1357     rdFields[j].fdDataSize := SizeOf(Double);
1358     if RecordNumber >= 0 then
1359     LocalDouble := Qry.Current[i].AsDouble;
1360     LocalData := PChar(@LocalDouble);
1361     end;
1362     end;
1363     SQL_INT64:
1364     begin
1365     if (rdFields[j].fdDataScale = 0) then
1366     begin
1367     rdFields[j].fdDataSize := SizeOf(Int64);
1368     if RecordNumber >= 0 then
1369     LocalInt64 := Qry.Current[i].AsInt64;
1370     LocalData := PChar(@LocalInt64);
1371     end
1372     else if (rdFields[j].fdDataScale >= (-4)) then
1373     begin
1374     rdFields[j].fdDataSize := SizeOf(Currency);
1375     if RecordNumber >= 0 then
1376     LocalCurrency := Qry.Current[i].AsCurrency;
1377     LocalData := PChar(@LocalCurrency);
1378     end
1379     else begin
1380     rdFields[j].fdDataSize := SizeOf(Double);
1381     if RecordNumber >= 0 then
1382     LocalDouble := Qry.Current[i].AsDouble;
1383     LocalData := PChar(@LocalDouble);
1384     end
1385     end;
1386     SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT:
1387     begin
1388     rdFields[j].fdDataSize := SizeOf(Double);
1389     if RecordNumber >= 0 then
1390     LocalDouble := Qry.Current[i].AsDouble;
1391     LocalData := PChar(@LocalDouble);
1392     end;
1393     SQL_VARYING:
1394     begin
1395     rdFields[j].fdDataSize := Qry.Current[i].Data^.sqllen;
1396     rdFields[j].fdDataLength := isc_vax_integer(Qry.Current[i].Data^.sqldata, 2);
1397     if RecordNumber >= 0 then
1398     begin
1399     if (rdFields[j].fdDataLength = 0) then
1400     LocalData := nil
1401     else
1402     LocalData := @Qry.Current[i].Data^.sqldata[2];
1403     end;
1404     end;
1405     else { SQL_TEXT, SQL_BLOB, SQL_ARRAY, SQL_QUAD }
1406     begin
1407     rdFields[j].fdDataSize := Qry.Current[i].Data^.sqllen;
1408     if (rdFields[j].fdDataType = SQL_TEXT) then
1409     rdFields[j].fdDataLength := rdFields[j].fdDataSize;
1410     end;
1411     end;
1412     if RecordNumber < 0 then
1413     begin
1414     rdFields[j].fdIsNull := True;
1415     rdFields[j].fdDataOfs := FRecordSize;
1416     Inc(FRecordSize, rdFields[j].fdDataSize);
1417     end
1418     else begin
1419     if rdFields[j].fdDataType = SQL_VARYING then
1420     begin
1421     if LocalData <> nil then
1422     Move(LocalData^, Buffer[rdFields[j].fdDataOfs], rdFields[j].fdDataLength)
1423     end
1424     else
1425     Move(LocalData^, Buffer[rdFields[j].fdDataOfs], rdFields[j].fdDataSize)
1426     end;
1427     end;
1428     end;
1429     WriteRecordCache(RecordNumber, PChar(p));
1430     end;
1431    
1432     function TIBCustomDataSet.GetActiveBuf: PChar;
1433     begin
1434     case State of
1435     dsBrowse:
1436     if IsEmpty then
1437     result := nil
1438     else
1439     result := ActiveBuffer;
1440     dsEdit, dsInsert:
1441     result := ActiveBuffer;
1442     dsCalcFields:
1443     result := CalcBuffer;
1444     dsFilter:
1445     result := FFilterBuffer;
1446     dsNewValue:
1447     result := ActiveBuffer;
1448     dsOldValue:
1449     if (PRecordData(ActiveBuffer)^.rdRecordNumber =
1450     PRecordData(FOldBuffer)^.rdRecordNumber) then
1451     result := FOldBuffer
1452     else
1453     result := ActiveBuffer;
1454     else if not FOpen then
1455     result := nil
1456     else
1457     result := ActiveBuffer;
1458     end;
1459     end;
1460    
1461     function TIBCustomDataSet.CachedUpdateStatus: TCachedUpdateStatus;
1462     begin
1463     if Active then
1464     result := PRecordData(GetActiveBuf)^.rdCachedUpdateStatus
1465     else
1466     result := cusUnmodified;
1467     end;
1468    
1469     function TIBCustomDataSet.GetDatabase: TIBDatabase;
1470     begin
1471     result := FBase.Database;
1472     end;
1473    
1474     function TIBCustomDataSet.GetDBHandle: PISC_DB_HANDLE;
1475     begin
1476     result := FBase.DBHandle;
1477     end;
1478    
1479     function TIBCustomDataSet.GetDeleteSQL: TStrings;
1480     begin
1481     result := FQDelete.SQL;
1482     end;
1483    
1484     function TIBCustomDataSet.GetInsertSQL: TStrings;
1485     begin
1486     result := FQInsert.SQL;
1487     end;
1488    
1489     function TIBCustomDataSet.GetSQLParams: TIBXSQLDA;
1490     begin
1491     if not FInternalPrepared then
1492     InternalPrepare;
1493     result := FQSelect.Params;
1494     end;
1495    
1496     function TIBCustomDataSet.GetRefreshSQL: TStrings;
1497     begin
1498     result := FQRefresh.SQL;
1499     end;
1500    
1501     function TIBCustomDataSet.GetSelectSQL: TStrings;
1502     begin
1503     result := FQSelect.SQL;
1504     end;
1505    
1506     function TIBCustomDataSet.GetStatementType: TIBSQLTypes;
1507     begin
1508     result := FQSelect.SQLType;
1509     end;
1510    
1511     function TIBCustomDataSet.GetModifySQL: TStrings;
1512     begin
1513     result := FQModify.SQL;
1514     end;
1515    
1516     function TIBCustomDataSet.GetTransaction: TIBTransaction;
1517     begin
1518     result := FBase.Transaction;
1519     end;
1520    
1521     function TIBCustomDataSet.GetTRHandle: PISC_TR_HANDLE;
1522     begin
1523     result := FBase.TRHandle;
1524     end;
1525    
1526     procedure TIBCustomDataSet.InternalDeleteRecord(Qry: TIBSQL; Buff: Pointer);
1527     begin
1528     if (Assigned(FUpdateObject) and (FUpdateObject.GetSQL(ukDelete).Text <> '')) then
1529     FUpdateObject.Apply(ukDelete)
1530     else
1531     begin
1532     SetInternalSQLParams(FQDelete, Buff);
1533     FQDelete.ExecQuery;
1534     end;
1535     with PRecordData(Buff)^ do
1536     begin
1537     rdUpdateStatus := usDeleted;
1538     rdCachedUpdateStatus := cusUnmodified;
1539     end;
1540     WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Buff);
1541     end;
1542    
1543     function TIBCustomDataSet.InternalLocate(const KeyFields: string;
1544     const KeyValues: Variant; Options: TLocateOptions): Boolean;
1545     var
1546     fl: TList;
1547     CurBookmark: string;
1548     fld, val: Variant;
1549     i, fld_cnt: Integer;
1550     begin
1551     fl := TList.Create;
1552     try
1553     GetFieldList(fl, KeyFields);
1554     fld_cnt := fl.Count;
1555     CurBookmark := Bookmark;
1556     result := False;
1557     while ((not result) and (not EOF)) do
1558     begin
1559     i := 0;
1560     result := True;
1561     while (result and (i < fld_cnt)) do
1562     begin
1563     if fld_cnt > 1 then
1564     val := KeyValues[i]
1565     else
1566     val := KeyValues;
1567     fld := TField(fl[i]).Value;
1568     result := not (VarIsNull(val) xor VarIsNull(fld));
1569     if result and not VarIsNull(val) then
1570     begin
1571     try
1572     fld := VarAsType(fld, VarType(val));
1573     except
1574     on E: EVariantError do result := False;
1575     end;
1576     if Result then
1577     if TField(fl[i]).DataType = ftString then
1578     begin
1579     if (loCaseInsensitive in Options) then
1580     begin
1581     fld := AnsiUpperCase(fld);
1582     val := AnsiUpperCase(val);
1583     end;
1584     fld := TrimRight(fld);
1585     val := TrimRight(val);
1586     if (loPartialKey in Options) then
1587     result := result and (AnsiPos(val, fld) = 1)
1588     else
1589     result := result and (val = fld);
1590     end else
1591     result := result and (val = fld);
1592     end;
1593     Inc(i);
1594     end;
1595     if not result then
1596     Next;
1597     end;
1598     if not result then
1599     Bookmark := CurBookmark
1600     else
1601     CursorPosChanged;
1602     finally
1603     fl.Free;
1604     end;
1605     end;
1606    
1607     procedure TIBCustomDataSet.InternalPostRecord(Qry: TIBSQL; Buff: Pointer);
1608     var
1609     i, j, k: Integer;
1610     pbd: PBlobDataArray;
1611     begin
1612     pbd := PBlobDataArray(PChar(Buff) + FBlobCacheOffset);
1613     j := 0;
1614     for i := 0 to FieldCount - 1 do
1615     if Fields[i].IsBlob then
1616     begin
1617     k := FMappedFieldPosition[Fields[i].FieldNo -1];
1618     if pbd^[j] <> nil then
1619     begin
1620     pbd^[j].Finalize;
1621     PISC_QUAD(
1622     PChar(Buff) + PRecordData(Buff)^.rdFields[k].fdDataOfs)^ :=
1623     pbd^[j].BlobID;
1624     PRecordData(Buff)^.rdFields[k].fdIsNull := pbd^[j].Size = 0;
1625     end;
1626     Inc(j);
1627     end;
1628     if Assigned(FUpdateObject) then
1629     begin
1630     if (Qry = FQDelete) then
1631     FUpdateObject.Apply(ukDelete)
1632     else if (Qry = FQInsert) then
1633     FUpdateObject.Apply(ukInsert)
1634     else
1635     FUpdateObject.Apply(ukModify);
1636     end
1637     else begin
1638     SetInternalSQLParams(Qry, Buff);
1639     Qry.ExecQuery;
1640     end;
1641     PRecordData(Buff)^.rdUpdateStatus := usUnmodified;
1642     PRecordData(Buff)^.rdCachedUpdateStatus := cusUnmodified;
1643     SetModified(False);
1644     WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Buff);
1645     if (FForcedRefresh or FNeedsRefresh) and CanRefresh then
1646     InternalRefreshRow;
1647     end;
1648    
1649     procedure TIBCustomDataSet.InternalRefreshRow;
1650     var
1651     Buff: PChar;
1652     SetCursor: Boolean;
1653     ofs: DWORD;
1654     Qry: TIBSQL;
1655     begin
1656     SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault);
1657     if SetCursor then
1658     Screen.Cursor := crHourGlass;
1659     try
1660     Buff := GetActiveBuf;
1661     if CanRefresh then
1662     begin
1663     if Buff <> nil then
1664     begin
1665     if (Assigned(FUpdateObject) and (FUpdateObject.RefreshSQL.Text <> '')) then
1666     begin
1667     Qry := TIBSQL.Create(self);
1668     Qry.Database := Database;
1669     Qry.Transaction := Transaction;
1670     Qry.GoToFirstRecordOnExecute := False;
1671     Qry.SQL.Text := FUpdateObject.RefreshSQL.Text;
1672     end
1673     else
1674     Qry := FQRefresh;
1675     SetInternalSQLParams(Qry, Buff);
1676     Qry.ExecQuery;
1677     try
1678     if (Qry.SQLType = SQLExecProcedure) or
1679     (Qry.Next <> nil) then
1680     begin
1681     ofs := PRecordData(Buff)^.rdSavedOffset;
1682     FetchCurrentRecordToBuffer(Qry,
1683     PRecordData(Buff)^.rdRecordNumber,
1684     Buff);
1685     if FCachedUpdates and (ofs <> $FFFFFFFF) then
1686     begin
1687     PRecordData(Buff)^.rdSavedOffset := ofs;
1688     WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Buff);
1689     SaveOldBuffer(Buff);
1690     end;
1691     end;
1692     finally
1693     Qry.Close;
1694     end;
1695     if Qry <> FQRefresh then
1696     Qry.Free;
1697     end
1698     end
1699     else
1700     IBError(ibxeCannotRefresh, [nil]);
1701     finally
1702     if SetCursor and (Screen.Cursor = crHourGlass) then
1703     Screen.Cursor := crDefault;
1704     end;
1705     end;
1706    
1707     procedure TIBCustomDataSet.InternalRevertRecord(RecordNumber: Integer);
1708     var
1709     NewBuffer, OldBuffer: PRecordData;
1710    
1711     begin
1712     NewBuffer := nil;
1713     OldBuffer := nil;
1714     NewBuffer := PRecordData(AllocRecordBuffer);
1715     OldBuffer := PRecordData(AllocRecordBuffer);
1716     try
1717     ReadRecordCache(RecordNumber, PChar(NewBuffer), False);
1718     ReadRecordCache(RecordNumber, PChar(OldBuffer), True);
1719     case NewBuffer^.rdCachedUpdateStatus of
1720     cusInserted:
1721     begin
1722     NewBuffer^.rdCachedUpdateStatus := cusUninserted;
1723     Inc(FDeletedRecords);
1724     end;
1725     cusModified,
1726     cusDeleted:
1727     begin
1728     if (NewBuffer^.rdCachedUpdateStatus = cusDeleted) then
1729     Dec(FDeletedRecords);
1730     CopyRecordBuffer(OldBuffer, NewBuffer);
1731     end;
1732     end;
1733    
1734     if State in dsEditModes then
1735     Cancel;
1736    
1737     WriteRecordCache(RecordNumber, PChar(NewBuffer));
1738    
1739     if (NewBuffer^.rdCachedUpdateStatus = cusUninserted ) then
1740     ReSync([]);
1741     finally
1742     FreeRecordBuffer(PChar(NewBuffer));
1743     FreeRecordBuffer(PChar(OldBuffer));
1744     end;
1745     end;
1746    
1747     { A visible record is one that is not truly deleted,
1748     and it is also listed in the FUpdateRecordTypes set }
1749    
1750     function TIBCustomDataSet.IsVisible(Buffer: PChar): Boolean;
1751     begin
1752     result := True;
1753     if not (State = dsOldValue) then
1754     result :=
1755     (PRecordData(Buffer)^.rdCachedUpdateStatus in FUpdateRecordTypes) and
1756     (not ((PRecordData(Buffer)^.rdCachedUpdateStatus = cusUnmodified) and
1757     (PRecordData(Buffer)^.rdUpdateStatus = usDeleted)));
1758     end;
1759    
1760    
1761     function TIBCustomDataSet.LocateNext(const KeyFields: string;
1762     const KeyValues: Variant; Options: TLocateOptions): Boolean;
1763     begin
1764     DisableControls;
1765     try
1766     result := InternalLocate(KeyFields, KeyValues, Options);
1767     finally
1768     EnableControls;
1769     end;
1770     end;
1771    
1772     procedure TIBCustomDataSet.InternalPrepare;
1773     var
1774     SetCursor: Boolean;
1775     DidActivate: Boolean;
1776     begin
1777     if FInternalPrepared then
1778     Exit;
1779     DidActivate := False;
1780     SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault);
1781     if SetCursor then
1782     Screen.Cursor := crHourGlass;
1783     try
1784     ActivateConnection;
1785     DidActivate := ActivateTransaction;
1786     FBase.CheckDatabase;
1787     FBase.CheckTransaction;
1788     if FQSelect.SQL.Text <> '' then
1789     begin
1790     if not FQSelect.Prepared then
1791     begin
1792     FQSelect.ParamCheck := ParamCheck;
1793     FQSelect.Prepare;
1794     end;
1795     if (FQDelete.SQL.Text <> '') and (not FQDelete.Prepared) then
1796     FQDelete.Prepare;
1797     if (FQInsert.SQL.Text <> '') and (not FQInsert.Prepared) then
1798     FQInsert.Prepare;
1799     if (FQRefresh.SQL.Text <> '') and (not FQRefresh.Prepared) then
1800     FQRefresh.Prepare;
1801     if (FQModify.SQL.Text <> '') and (not FQModify.Prepared) then
1802     FQModify.Prepare;
1803     FInternalPrepared := True;
1804     InternalInitFieldDefs;
1805     end else
1806     IBError(ibxeEmptyQuery, [nil]);
1807     finally
1808     if DidActivate then
1809     DeactivateTransaction;
1810     if SetCursor and (Screen.Cursor = crHourGlass) then
1811     Screen.Cursor := crDefault;
1812     end;
1813     end;
1814    
1815     procedure TIBCustomDataSet.RecordModified(Value: Boolean);
1816     begin
1817     SetModified(Value);
1818     end;
1819    
1820     procedure TIBCustomDataSet.RevertRecord;
1821     var
1822     Buff: PRecordData;
1823     begin
1824     if FCachedUpdates and FUpdatesPending then
1825     begin
1826     Buff := PRecordData(GetActiveBuf);
1827     InternalRevertRecord(Buff^.rdRecordNumber);
1828     ReadRecordCache(Buff^.rdRecordNumber, PChar(Buff), False);
1829     DataEvent(deRecordChange, 0);
1830     end;
1831     end;
1832    
1833     procedure TIBCustomDataSet.SaveOldBuffer(Buffer: PChar);
1834     var
1835     OldBuffer: Pointer;
1836     procedure CopyOldBuffer;
1837     begin
1838     CopyRecordBuffer(Buffer, OldBuffer);
1839     if BlobFieldCount > 0 then
1840     FillChar(PChar(OldBuffer)[FBlobCacheOffset], BlobFieldCount * SizeOf(TIBBlobStream),
1841     0);
1842     end;
1843    
1844     begin
1845     if (Buffer <> nil) and (PRecordData(Buffer)^.rdRecordNumber >= 0) then
1846     begin
1847     OldBuffer := AllocRecordBuffer;
1848     try
1849     if (PRecordData(Buffer)^.rdSavedOffset = $FFFFFFFF) then
1850     begin
1851     PRecordData(Buffer)^.rdSavedOffset := AdjustPosition(FOldBufferCache, 0,
1852     FILE_END);
1853     CopyOldBuffer;
1854     WriteCache(FOldBufferCache, 0, FILE_CURRENT, OldBuffer);
1855     WriteCache(FBufferCache, PRecordData(Buffer)^.rdRecordNumber * FRecordBufferSize,
1856     FILE_BEGIN, Buffer);
1857     end
1858     else begin
1859     CopyOldBuffer;
1860     WriteCache(FOldBufferCache, PRecordData(Buffer)^.rdSavedOffset, FILE_BEGIN,
1861     OldBuffer);
1862     end;
1863     finally
1864     FreeRecordBuffer(PChar(OldBuffer));
1865     end;
1866     end;
1867     end;
1868    
1869     procedure TIBCustomDataSet.SetBufferChunks(Value: Integer);
1870     begin
1871     if (Value <= 0) then
1872     FBufferChunks := BufferCacheSize
1873     else
1874     FBufferChunks := Value;
1875     end;
1876    
1877     procedure TIBCustomDataSet.SetDatabase(Value: TIBDatabase);
1878     begin
1879     if (FBase.Database <> Value) then
1880     begin
1881     CheckDatasetClosed;
1882     FBase.Database := Value;
1883     FQDelete.Database := Value;
1884     FQInsert.Database := Value;
1885     FQRefresh.Database := Value;
1886     FQSelect.Database := Value;
1887     FQModify.Database := Value;
1888     end;
1889     end;
1890    
1891     procedure TIBCustomDataSet.SetDeleteSQL(Value: TStrings);
1892     begin
1893     if FQDelete.SQL.Text <> Value.Text then
1894     begin
1895     Disconnect;
1896     FQDelete.SQL.Assign(Value);
1897     end;
1898     end;
1899    
1900     procedure TIBCustomDataSet.SetInsertSQL(Value: TStrings);
1901     begin
1902     if FQInsert.SQL.Text <> Value.Text then
1903     begin
1904     Disconnect;
1905     FQInsert.SQL.Assign(Value);
1906     end;
1907     end;
1908    
1909     procedure TIBCustomDataSet.SetInternalSQLParams(Qry: TIBSQL; Buffer: Pointer);
1910     var
1911     i, j: Integer;
1912     cr, data: PChar;
1913     fn, st: string;
1914     OldBuffer: Pointer;
1915     ts: TTimeStamp;
1916     begin
1917     if (Buffer = nil) then
1918     IBError(ibxeBufferNotSet, [nil]);
1919     if (not FInternalPrepared) then
1920     InternalPrepare;
1921     OldBuffer := nil;
1922     try
1923     for i := 0 to Qry.Params.Count - 1 do
1924     begin
1925     fn := Qry.Params[i].Name;
1926     if (Pos('OLD_', fn) = 1) then {mbcs ok}
1927     begin
1928     fn := Copy(fn, 5, Length(fn));
1929     if not Assigned(OldBuffer) then
1930     begin
1931     OldBuffer := AllocRecordBuffer;
1932     ReadRecordCache(PRecordData(Buffer)^.rdRecordNumber, OldBuffer, True);
1933     end;
1934     cr := OldBuffer;
1935     end
1936     else if (Pos('NEW_', fn) = 1) then {mbcs ok}
1937     begin
1938     fn := Copy(fn, 5, Length(fn));
1939     cr := Buffer;
1940     end
1941     else
1942     cr := Buffer;
1943     j := FQSelect.FieldIndex[fn] + 1;
1944     if (j > 0) then
1945     with PRecordData(cr)^ do
1946     begin
1947     if Qry.Params[i].name = 'IBX_INTERNAL_DBKEY' then {do not localize}
1948     begin
1949     PIBDBKey(Qry.Params[i].AsPointer)^ := rdDBKey;
1950     continue;
1951     end;
1952     if rdFields[j].fdIsNull then
1953     Qry.Params[i].IsNull := True
1954     else begin
1955     Qry.Params[i].IsNull := False;
1956     data := cr + rdFields[j].fdDataOfs;
1957     case rdFields[j].fdDataType of
1958     SQL_TEXT, SQL_VARYING:
1959     begin
1960     SetString(st, data, rdFields[j].fdDataLength);
1961     Qry.Params[i].AsString := st;
1962     end;
1963     SQL_FLOAT, SQL_DOUBLE, SQL_D_FLOAT:
1964     Qry.Params[i].AsDouble := PDouble(data)^;
1965     SQL_SHORT, SQL_LONG:
1966     begin
1967     if rdFields[j].fdDataScale = 0 then
1968     Qry.Params[i].AsLong := PLong(data)^
1969     else if rdFields[j].fdDataScale >= (-4) then
1970     Qry.Params[i].AsCurrency := PCurrency(data)^
1971     else
1972     Qry.Params[i].AsDouble := PDouble(data)^;
1973     end;
1974     SQL_INT64:
1975     begin
1976     if rdFields[j].fdDataScale = 0 then
1977     Qry.Params[i].AsInt64 := PInt64(data)^
1978     else if rdFields[j].fdDataScale >= (-4) then
1979     Qry.Params[i].AsCurrency := PCurrency(data)^
1980     else
1981     Qry.Params[i].AsDouble := PDouble(data)^;
1982     end;
1983     SQL_BLOB, SQL_ARRAY, SQL_QUAD:
1984     Qry.Params[i].AsQuad := PISC_QUAD(data)^;
1985     SQL_TYPE_DATE:
1986     begin
1987     ts.Date := PInt(data)^;
1988     ts.Time := 0;
1989     Qry.Params[i].AsDate :=
1990     TimeStampToDateTime(ts);
1991     end;
1992     SQL_TYPE_TIME:
1993     begin
1994     ts.Date := 0;
1995     ts.Time := PInt(data)^;
1996     Qry.Params[i].AsTime :=
1997     TimeStampToDateTime(ts);
1998     end;
1999     SQL_TIMESTAMP:
2000     Qry.Params[i].AsDateTime :=
2001     TimeStampToDateTime(
2002     MSecsToTimeStamp(PDouble(data)^));
2003     end;
2004     end;
2005     end;
2006     end;
2007     finally
2008     if (OldBuffer <> nil) then
2009     FreeRecordBuffer(PChar(OldBuffer));
2010     end;
2011     end;
2012    
2013     procedure TIBCustomDataSet.SetRefreshSQL(Value: TStrings);
2014     begin
2015     if FQRefresh.SQL.Text <> Value.Text then
2016     begin
2017     Disconnect;
2018     FQRefresh.SQL.Assign(Value);
2019     end;
2020     end;
2021    
2022     procedure TIBCustomDataSet.SetSelectSQL(Value: TStrings);
2023     begin
2024     if FQSelect.SQL.Text <> Value.Text then
2025     begin
2026     Disconnect;
2027     FQSelect.SQL.Assign(Value);
2028     end;
2029     end;
2030    
2031     procedure TIBCustomDataSet.SetModifySQL(Value: TStrings);
2032     begin
2033     if FQModify.SQL.Text <> Value.Text then
2034     begin
2035     Disconnect;
2036     FQModify.SQL.Assign(Value);
2037     end;
2038     end;
2039    
2040     procedure TIBCustomDataSet.SetTransaction(Value: TIBTransaction);
2041     begin
2042     if (FBase.Transaction <> Value) then
2043     begin
2044     CheckDatasetClosed;
2045     FBase.Transaction := Value;
2046     FQDelete.Transaction := Value;
2047     FQInsert.Transaction := Value;
2048     FQRefresh.Transaction := Value;
2049     FQSelect.Transaction := Value;
2050     FQModify.Transaction := Value;
2051     end;
2052     end;
2053    
2054     procedure TIBCustomDataSet.SetUniDirectional(Value: Boolean);
2055     begin
2056     CheckDatasetClosed;
2057     FUniDirectional := Value;
2058     end;
2059    
2060     procedure TIBCustomDataSet.SetUpdateRecordTypes(Value: TIBUpdateRecordTypes);
2061     begin
2062     FUpdateRecordTypes := Value;
2063     if Active then
2064     First;
2065     end;
2066    
2067     procedure TIBCustomDataSet.RefreshParams;
2068     var
2069     DataSet: TDataSet;
2070     begin
2071     DisableControls;
2072     try
2073     if FDataLink.DataSource <> nil then
2074     begin
2075     DataSet := FDataLink.DataSource.DataSet;
2076     if DataSet <> nil then
2077     if DataSet.Active and (DataSet.State <> dsSetKey) then
2078     begin
2079     Close;
2080     Open;
2081     end;
2082     end;
2083     finally
2084     EnableControls;
2085     end;
2086     end;
2087    
2088    
2089     procedure TIBCustomDataSet.SQLChanging(Sender: TObject);
2090     begin
2091     if FOpen then
2092     InternalClose;
2093     if FInternalPrepared then
2094     InternalUnPrepare;
2095     end;
2096    
2097     { I can "undelete" uninserted records (make them "inserted" again).
2098     I can "undelete" cached deleted (the deletion hasn't yet occurred) }
2099     procedure TIBCustomDataSet.Undelete;
2100     var
2101     Buff: PRecordData;
2102     begin
2103     CheckActive;
2104     Buff := PRecordData(GetActiveBuf);
2105     with Buff^ do
2106     begin
2107     if rdCachedUpdateStatus = cusUninserted then
2108     begin
2109     rdCachedUpdateStatus := cusInserted;
2110     Dec(FDeletedRecords);
2111     end
2112     else if (rdUpdateStatus = usDeleted) and
2113     (rdCachedUpdateStatus = cusDeleted) then
2114     begin
2115     rdCachedUpdateStatus := cusUnmodified;
2116     rdUpdateStatus := usUnmodified;
2117     Dec(FDeletedRecords);
2118     end;
2119     WriteRecordCache(rdRecordNumber, PChar(Buff));
2120     end;
2121     end;
2122    
2123     function TIBCustomDataSet.UpdateStatus: TUpdateStatus;
2124     begin
2125     if Active then
2126     if GetActiveBuf <> nil then
2127     result := PRecordData(GetActiveBuf)^.rdUpdateStatus
2128     else
2129     result := usUnmodified
2130     else
2131     result := usUnmodified;
2132     end;
2133    
2134     function TIBCustomDataSet.IsSequenced: Boolean;
2135     begin
2136     Result := Assigned( FQSelect ) and FQSelect.EOF;
2137     end;
2138    
2139     function TIBCustomDataSet.AdjustPosition(FCache: PChar; Offset: DWORD;
2140     Origin: Integer): Integer;
2141     var
2142     OldCacheSize: Integer;
2143     begin
2144     if (FCache = FBufferCache) then
2145     begin
2146     case Origin of
2147     FILE_BEGIN: FBPos := Offset;
2148     FILE_CURRENT: FBPos := FBPos + Offset;
2149     FILE_END: FBPos := DWORD(FBEnd) + Offset;
2150     end;
2151     OldCacheSize := FCacheSize;
2152     while (FBPos >= DWORD(FCacheSize)) do
2153     Inc(FCacheSize, FBufferChunkSize);
2154     if FCacheSize > OldCacheSize then
2155     IBAlloc(FBufferCache, FCacheSize, FCacheSize);
2156     result := FBPos;
2157     end
2158     else begin
2159     case Origin of
2160     FILE_BEGIN: FOBPos := Offset;
2161     FILE_CURRENT: FOBPos := FOBPos + Offset;
2162     FILE_END: FOBPos := DWORD(FOBEnd) + Offset;
2163     end;
2164     OldCacheSize := FOldCacheSize;
2165     while (FBPos >= DWORD(FOldCacheSize)) do
2166     Inc(FOldCacheSize, FBufferChunkSize);
2167     if FOldCacheSize > OldCacheSize then
2168     IBAlloc(FOldBufferCache, FOldCacheSize, FOldCacheSize);
2169     result := FOBPos;
2170     end;
2171     end;
2172    
2173     procedure TIBCustomDataSet.ReadCache(FCache: PChar; Offset: DWORD; Origin: Integer;
2174     Buffer: PChar);
2175     var
2176     pCache: PChar;
2177     bOld: Boolean;
2178     begin
2179     bOld := (FCache = FOldBufferCache);
2180     pCache := PChar(AdjustPosition(FCache, Offset, Origin));
2181     if not bOld then
2182     pCache := FBufferCache + Integer(pCache)
2183     else
2184     pCache := FOldBufferCache + Integer(pCache);
2185     Move(pCache^, Buffer^, DWORD(FRecordBufferSize));
2186     AdjustPosition(FCache, FRecordBufferSize, FILE_CURRENT);
2187     end;
2188    
2189     procedure TIBCustomDataSet.ReadRecordCache(RecordNumber: Integer; Buffer: PChar;
2190     ReadOldBuffer: Boolean);
2191     begin
2192     if FUniDirectional then
2193     RecordNumber := RecordNumber mod UniCache;
2194     if (ReadOldBuffer) then
2195     begin
2196     ReadRecordCache(RecordNumber, Buffer, False);
2197     if FCachedUpdates and
2198     (PRecordData(Buffer)^.rdSavedOffset <> $FFFFFFFF) then
2199     ReadCache(FOldBufferCache, PRecordData(Buffer)^.rdSavedOffset, FILE_BEGIN,
2200     Buffer)
2201     else
2202     if ReadOldBuffer and
2203     (PRecordData(FOldBuffer)^.rdRecordNumber = RecordNumber) then
2204     CopyRecordBuffer( FOldBuffer, Buffer )
2205     end
2206     else
2207     ReadCache(FBufferCache, RecordNumber * FRecordBufferSize, FILE_BEGIN, Buffer);
2208     end;
2209    
2210     procedure TIBCustomDataSet.WriteCache(FCache: PChar; Offset: DWORD; Origin: Integer;
2211     Buffer: PChar);
2212     var
2213     pCache: PChar;
2214     bOld: Boolean;
2215     dwEnd: DWORD;
2216     begin
2217     bOld := (FCache = FOldBufferCache);
2218     pCache := PChar(AdjustPosition(FCache, Offset, Origin));
2219     if not bOld then
2220     pCache := FBufferCache + Integer(pCache)
2221     else
2222     pCache := FOldBufferCache + Integer(pCache);
2223     Move(Buffer^, pCache^, FRecordBufferSize);
2224     dwEnd := AdjustPosition(FCache, FRecordBufferSize, FILE_CURRENT);
2225     if not bOld then
2226     begin
2227     if (dwEnd > FBEnd) then
2228     FBEnd := dwEnd;
2229     end
2230     else begin
2231     if (dwEnd > FOBEnd) then
2232     FOBEnd := dwEnd;
2233     end;
2234     end;
2235    
2236     procedure TIBCustomDataSet.WriteRecordCache(RecordNumber: Integer; Buffer: PChar);
2237     begin
2238     if RecordNumber >= 0 then
2239     begin
2240     if FUniDirectional then
2241     RecordNumber := RecordNumber mod UniCache;
2242     WriteCache(FBufferCache, RecordNumber * FRecordBufferSize, FILE_BEGIN, Buffer);
2243     end;
2244     end;
2245    
2246     function TIBCustomDataSet.AllocRecordBuffer: PChar;
2247     begin
2248     result := nil;
2249     IBAlloc(result, FRecordBufferSize, FRecordBufferSize);
2250     Move(FModelBuffer^, result^, FRecordBufferSize);
2251     end;
2252    
2253     function TIBCustomDataSet.CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream;
2254     var
2255     pb: PBlobDataArray;
2256     fs: TIBBlobStream;
2257     Buff: PChar;
2258     bTr, bDB: Boolean;
2259     begin
2260     Buff := GetActiveBuf;
2261     if Buff = nil then
2262     begin
2263     fs := TIBBlobStream.Create;
2264     fs.Mode := bmReadWrite;
2265     FBlobStreamList.Add(Pointer(fs));
2266     result := TIBDSBlobStream.Create(Field, fs, Mode);
2267     exit;
2268     end;
2269     pb := PBlobDataArray(Buff + FBlobCacheOffset);
2270     if pb^[Field.Offset] = nil then
2271     begin
2272     AdjustRecordOnInsert(Buff);
2273     pb^[Field.Offset] := TIBBlobStream.Create;
2274     fs := pb^[Field.Offset];
2275     FBlobStreamList.Add(Pointer(fs));
2276     fs.Mode := bmReadWrite;
2277     fs.Database := Database;
2278     fs.Transaction := Transaction;
2279     fs.BlobID :=
2280     PISC_QUAD(@Buff[PRecordData(Buff)^.rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataOfs])^;
2281     if (CachedUpdates) then
2282     begin
2283     bTr := not Transaction.InTransaction;
2284     bDB := not Database.Connected;
2285     if bDB then
2286     Database.Open;
2287     if bTr then
2288     Transaction.StartTransaction;
2289     fs.Seek(0, soFromBeginning);
2290     if bTr then
2291     Transaction.Commit;
2292     if bDB then
2293     Database.Close;
2294     end;
2295     WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Pointer(Buff));
2296     end else
2297     fs := pb^[Field.Offset];
2298     result := TIBDSBlobStream.Create(Field, fs, Mode);
2299     end;
2300    
2301     function TIBCustomDataSet.CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Integer;
2302     const
2303     CMPLess = -1;
2304     CMPEql = 0;
2305     CMPGtr = 1;
2306     RetCodes: array[Boolean, Boolean] of ShortInt = ((2, CMPLess),
2307     (CMPGtr, CMPEql));
2308     begin
2309     result := RetCodes[Bookmark1 = nil, Bookmark2 = nil];
2310    
2311     if Result = 2 then
2312     begin
2313     if PInteger(Bookmark1)^ < PInteger(Bookmark2)^ then
2314     Result := CMPLess
2315     else
2316     if PInteger(Bookmark1)^ > PInteger(Bookmark2)^ then
2317     Result := CMPGtr
2318     else
2319     Result := CMPEql;
2320     end;
2321     end;
2322    
2323     procedure TIBCustomDataSet.DoBeforeDelete;
2324     var
2325     Buff: PRecordData;
2326     begin
2327     if not CanDelete then
2328     IBError(ibxeCannotDelete, [nil]);
2329     Buff := PRecordData(GetActiveBuf);
2330     if FCachedUpdates and
2331     (Buff^.rdCachedUpdateStatus in [cusUnmodified]) then
2332     SaveOldBuffer(PChar(Buff));
2333     inherited;
2334     end;
2335    
2336     procedure TIBCustomDataSet.DoBeforeEdit;
2337     var
2338     Buff: PRecordData;
2339     begin
2340     Buff := PRecordData(GetActiveBuf);
2341     if not(CanEdit or (FQModify.SQL.Count <> 0) or
2342     (FCachedUpdates and Assigned(FOnUpdateRecord))) then
2343     IBError(ibxeCannotUpdate, [nil]);
2344     if FCachedUpdates and (Buff^.rdCachedUpdateStatus in [cusUnmodified, cusInserted]) then
2345     SaveOldBuffer(PChar(Buff));
2346     CopyRecordBuffer(GetActiveBuf, FOldBuffer);
2347     inherited;
2348     end;
2349    
2350     procedure TIBCustomDataSet.DoBeforeInsert;
2351     begin
2352     if not CanInsert then
2353     IBError(ibxeCannotInsert, [nil]);
2354     inherited;
2355     end;
2356    
2357     procedure TIBCustomDataSet.FetchAll;
2358     var
2359     SetCursor: Boolean;
2360     CurBookmark: string;
2361     begin
2362     SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault);
2363     if SetCursor then
2364     Screen.Cursor := crHourGlass;
2365     try
2366     if FQSelect.EOF or not FQSelect.Open then
2367     exit;
2368     DisableControls;
2369     try
2370     CurBookmark := Bookmark;
2371     Last;
2372     Bookmark := CurBookmark;
2373     finally
2374     EnableControls;
2375     end;
2376     finally
2377     if SetCursor and (Screen.Cursor = crHourGlass) then
2378     Screen.Cursor := crDefault;
2379     end;
2380     end;
2381    
2382     procedure TIBCustomDataSet.FreeRecordBuffer(var Buffer: PChar);
2383     begin
2384     FreeMem(Buffer);
2385     Buffer := nil;
2386     end;
2387    
2388     procedure TIBCustomDataSet.GetBookmarkData(Buffer: PChar; Data: Pointer);
2389     begin
2390     Move(PRecordData(Buffer)^.rdRecordNumber, Data^, BookmarkSize);
2391     end;
2392    
2393     function TIBCustomDataSet.GetBookmarkFlag(Buffer: PChar): TBookmarkFlag;
2394     begin
2395     result := PRecordData(Buffer)^.rdBookmarkFlag;
2396     end;
2397    
2398     function TIBCustomDataSet.GetCanModify: Boolean;
2399     begin
2400     result := (FQInsert.SQL.Text <> '') or
2401     (FQModify.SQL.Text <> '') or
2402     (FQDelete.SQL.Text <> '') or
2403     (Assigned(FUpdateObject));
2404     end;
2405    
2406     function TIBCustomDataSet.GetCurrentRecord(Buffer: PChar): Boolean;
2407     begin
2408     if not IsEmpty and (GetBookmarkFlag(ActiveBuffer) = bfCurrent) then
2409     begin
2410     UpdateCursorPos;
2411     ReadRecordCache(PRecordData(ActiveBuffer)^.rdRecordNumber, Buffer, False);
2412     result := True;
2413     end
2414     else
2415     result := False;
2416     end;
2417    
2418     function TIBCustomDataSet.GetDataSource: TDataSource;
2419     begin
2420     if FDataLink = nil then
2421     result := nil
2422     else
2423     result := FDataLink.DataSource;
2424     end;
2425    
2426     function TIBCustomDataSet.GetFieldClass(FieldType: TFieldType): TFieldClass;
2427     begin
2428     Result := DefaultFieldClasses[FieldType];
2429     end;
2430    
2431     function TIBCustomDataSet.GetFieldData(FieldNo: Integer; Buffer: Pointer): Boolean;
2432     begin
2433     result := GetFieldData(FieldByNumber(FieldNo), buffer);
2434     end;
2435    
2436     function TIBCustomDataSet.InternalGetFieldData(Field: TField; Buffer: Pointer): Boolean;
2437     var
2438     Buff, Data: PChar;
2439     CurrentRecord: PRecordData;
2440     begin
2441     result := False;
2442     Buff := GetActiveBuf;
2443     if (Buff = nil) or
2444     (not IsVisible(Buff)) then
2445     exit;
2446     { The intention here is to stuff the buffer with the data for the
2447     referenced field for the current record }
2448     CurrentRecord := PRecordData(Buff);
2449     if (Field.FieldNo < 0) then
2450     begin
2451     Inc(Buff, FRecordSize + Field.Offset);
2452     result := Boolean(Buff[0]);
2453     if result and (Buffer <> nil) then
2454     Move(Buff[1], Buffer^, Field.DataSize);
2455     end
2456     else if (FMappedFieldPosition[Field.FieldNo - 1] > 0) and
2457     (FMappedFieldPosition[Field.FieldNo - 1] <= CurrentRecord^.rdFieldCount) then
2458     begin
2459     result := not CurrentRecord^.rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdIsNull;
2460     if result and (Buffer <> nil) then
2461     with CurrentRecord^.rdFields[FMappedFieldPosition[Field.FieldNo - 1]] do
2462     begin
2463     Data := Buff + CurrentRecord^.rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataOfs;
2464     if (fdDataType = SQL_VARYING) or (fdDataType = SQL_TEXT) then
2465     begin
2466     Move(Data^, Buffer^, fdDataLength);
2467     PChar(Buffer)[fdDataLength] := #0;
2468     end
2469     else
2470     Move(Data^, Buffer^, Field.DataSize);
2471     end;
2472     end;
2473     end;
2474    
2475     { GetRecNo and SetRecNo both operate off of 1-based indexes as
2476     opposed to 0-based indexes.
2477     This is because we want LastRecordNumber/RecordCount = 1 }
2478    
2479     function TIBCustomDataSet.GetRecNo: Integer;
2480     begin
2481     if GetActiveBuf = nil then
2482     result := 0
2483     else
2484     result := PRecordData(GetActiveBuf)^.rdRecordNumber + 1;
2485     end;
2486    
2487     function TIBCustomDataSet.GetRecord(Buffer: PChar; GetMode: TGetMode;
2488     DoCheck: Boolean): TGetResult;
2489     var
2490     Accept: Boolean;
2491     SaveState: TDataSetState;
2492     begin
2493     Result := grOK;
2494     if Filtered and Assigned(OnFilterRecord) then
2495     begin
2496     Accept := False;
2497     SaveState := SetTempState(dsFilter);
2498     while not Accept do
2499     begin
2500     Result := InternalGetRecord(Buffer, GetMode, DoCheck);
2501     if Result <> grOK then
2502     break;
2503     FFilterBuffer := Buffer;
2504     try
2505     Accept := True;
2506     OnFilterRecord(Self, Accept);
2507     if not Accept and (GetMode = gmCurrent) then
2508     GetMode := gmPrior;
2509     except
2510     // Application.HandleException(Self);
2511     end;
2512     end;
2513     RestoreState(SaveState);
2514     end
2515     else
2516     Result := InternalGetRecord(Buffer, GetMode, DoCheck);
2517     end;
2518    
2519     function TIBCustomDataSet.InternalGetRecord(Buffer: PChar; GetMode: TGetMode;
2520     DoCheck: Boolean): TGetResult;
2521     begin
2522     result := grError;
2523     case GetMode of
2524     gmCurrent: begin
2525     if (FCurrentRecord >= 0) then begin
2526     if FCurrentRecord < FRecordCount then
2527     ReadRecordCache(FCurrentRecord, Buffer, False)
2528     else begin
2529     while (not FQSelect.EOF) and
2530     (FQSelect.Next <> nil) and
2531     (FCurrentRecord >= FRecordCount) do begin
2532     FetchCurrentRecordToBuffer(FQSelect, FRecordCount, Buffer);
2533     Inc(FRecordCount);
2534     end;
2535     FCurrentRecord := FRecordCount - 1;
2536     if (FCurrentRecord >= 0) then
2537     ReadRecordCache(FCurrentRecord, Buffer, False);
2538     end;
2539     result := grOk;
2540     end else
2541     result := grBOF;
2542     end;
2543     gmNext: begin
2544     result := grOk;
2545     if FCurrentRecord = FRecordCount then
2546     result := grEOF
2547     else if FCurrentRecord = FRecordCount - 1 then begin
2548     if (not FQSelect.EOF) then begin
2549     FQSelect.Next;
2550     Inc(FCurrentRecord);
2551     end;
2552     if (FQSelect.EOF) then begin
2553     result := grEOF;
2554     end else begin
2555     Inc(FRecordCount);
2556     FetchCurrentRecordToBuffer(FQSelect, FCurrentRecord, Buffer);
2557     end;
2558     end else if (FCurrentRecord < FRecordCount) then begin
2559     Inc(FCurrentRecord);
2560     ReadRecordCache(FCurrentRecord, Buffer, False);
2561     end;
2562     end;
2563     else { gmPrior }
2564     begin
2565     if (FCurrentRecord = 0) then begin
2566     Dec(FCurrentRecord);
2567     result := grBOF;
2568     end else if (FCurrentRecord > 0) and
2569     (FCurrentRecord <= FRecordCount) then begin
2570     Dec(FCurrentRecord);
2571     ReadRecordCache(FCurrentRecord, Buffer, False);
2572     result := grOk;
2573     end else if (FCurrentRecord = -1) then
2574     result := grBOF;
2575     end;
2576     end;
2577     if result = grOk then
2578     result := AdjustCurrentRecord(Buffer, GetMode);
2579     if result = grOk then with PRecordData(Buffer)^ do begin
2580     rdBookmarkFlag := bfCurrent;
2581     GetCalcFields(Buffer);
2582     end else if (result = grEOF) then begin
2583     CopyRecordBuffer(FModelBuffer, Buffer);
2584     PRecordData(Buffer)^.rdBookmarkFlag := bfEOF;
2585     end else if (result = grBOF) then begin
2586     CopyRecordBuffer(FModelBuffer, Buffer);
2587     PRecordData(Buffer)^.rdBookmarkFlag := bfBOF;
2588     end else if (result = grError) then begin
2589     CopyRecordBuffer(FModelBuffer, Buffer);
2590     PRecordData(Buffer)^.rdBookmarkFlag := bfEOF;
2591     end;;
2592     end;
2593    
2594     function TIBCustomDataSet.GetRecordCount: Integer;
2595     begin
2596     result := FRecordCount - FDeletedRecords;
2597     end;
2598    
2599     function TIBCustomDataSet.GetRecordSize: Word;
2600     begin
2601     result := FRecordBufferSize;
2602     end;
2603    
2604     procedure TIBCustomDataSet.InternalAddRecord(Buffer: Pointer; Append: Boolean);
2605     begin
2606     CheckEditState;
2607     begin
2608     { When adding records, we *always* append.
2609     Insertion is just too costly }
2610     AdjustRecordOnInsert(Buffer);
2611     with PRecordData(Buffer)^ do
2612     begin
2613     rdUpdateStatus := usInserted;
2614     rdCachedUpdateStatus := cusInserted;
2615     end;
2616     if not CachedUpdates then
2617     InternalPostRecord(FQInsert, Buffer)
2618     else begin
2619     WriteRecordCache(FCurrentRecord, Buffer);
2620     FUpdatesPending := True;
2621     end;
2622     Inc(FRecordCount);
2623     InternalSetToRecord(Buffer);
2624     end
2625     end;
2626    
2627     procedure TIBCustomDataSet.InternalCancel;
2628     var
2629     Buff: PChar;
2630     CurRec: Integer;
2631     begin
2632     inherited;
2633     Buff := GetActiveBuf;
2634     if Buff <> nil then begin
2635     CurRec := FCurrentRecord;
2636     AdjustRecordOnInsert(Buff);
2637     if (State = dsEdit) then begin
2638     CopyRecordBuffer(FOldBuffer, Buff);
2639     WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Buff);
2640     end else begin
2641     CopyRecordBuffer(FModelBuffer, Buff);
2642     PRecordData(Buff)^.rdUpdateStatus := usDeleted;
2643     PRecordData(Buff)^.rdCachedUpdateStatus := cusUnmodified;
2644     PRecordData(Buff)^.rdBookmarkFlag := bfEOF;
2645     FCurrentRecord := CurRec;
2646     end;
2647     end;
2648     end;
2649    
2650    
2651     procedure TIBCustomDataSet.InternalClose;
2652     begin
2653     if FDidActivate then
2654     DeactivateTransaction;
2655     FQSelect.Close;
2656     ClearBlobCache;
2657     FreeRecordBuffer(FModelBuffer);
2658     FreeRecordBuffer(FOldBuffer);
2659     FCurrentRecord := -1;
2660     FOpen := False;
2661     FRecordCount := 0;
2662     FDeletedRecords := 0;
2663     FRecordSize := 0;
2664     FBPos := 0;
2665     FOBPos := 0;
2666     FCacheSize := 0;
2667     FOldCacheSize := 0;
2668     FBEnd := 0;
2669     FOBEnd := 0;
2670     FreeMem(FBufferCache);
2671     FBufferCache := nil;
2672     FreeMem(FOldBufferCache);
2673     FOldBufferCache := nil;
2674     BindFields(False);
2675     if DefaultFields then DestroyFields;
2676     end;
2677    
2678     procedure TIBCustomDataSet.InternalDelete;
2679     var
2680     Buff: PChar;
2681     SetCursor: Boolean;
2682     begin
2683     SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault);
2684     if SetCursor then
2685     Screen.Cursor := crHourGlass;
2686     try
2687     Buff := GetActiveBuf;
2688     if CanDelete then
2689     begin
2690     if not CachedUpdates then
2691     InternalDeleteRecord(FQDelete, Buff)
2692     else
2693     begin
2694     with PRecordData(Buff)^ do
2695     begin
2696     if rdCachedUpdateStatus = cusInserted then
2697     rdCachedUpdateStatus := cusUninserted
2698     else begin
2699     rdUpdateStatus := usDeleted;
2700     rdCachedUpdateStatus := cusDeleted;
2701     end;
2702     end;
2703     WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Buff);
2704     end;
2705     Inc(FDeletedRecords);
2706     FUpdatesPending := True;
2707     end else
2708     IBError(ibxeCannotDelete, [nil]);
2709     finally
2710     if SetCursor and (Screen.Cursor = crHourGlass) then
2711     Screen.Cursor := crDefault;
2712     end;
2713     end;
2714    
2715     procedure TIBCustomDataSet.InternalFirst;
2716     begin
2717     FCurrentRecord := -1;
2718     end;
2719    
2720     procedure TIBCustomDataSet.InternalGotoBookmark(Bookmark: Pointer);
2721     begin
2722     FCurrentRecord := PInteger(Bookmark)^;
2723     end;
2724    
2725     procedure TIBCustomDataSet.InternalHandleException;
2726     begin
2727     Application.HandleException(Self)
2728     end;
2729    
2730     procedure TIBCustomDataSet.InternalInitFieldDefs;
2731     const
2732     DefaultSQL = 'Select F.RDB$COMPUTED_BLR, ' + {do not localize}
2733     'F.RDB$DEFAULT_VALUE, R.RDB$FIELD_NAME ' + {do not localize}
2734     'from RDB$RELATION_FIELDS R, RDB$FIELDS F ' + {do not localize}
2735     'where R.RDB$RELATION_NAME = :RELATION ' + {do not localize}
2736     'and R.RDB$FIELD_SOURCE = F.RDB$FIELD_NAME '+ {do not localize}
2737     'and ((not F.RDB$COMPUTED_BLR is NULL) or ' + {do not localize}
2738     ' (not F.RDB$DEFAULT_VALUE is NULL)) '; {do not localize}
2739     var
2740     FieldType: TFieldType;
2741     FieldSize: Word;
2742     FieldNullable : Boolean;
2743     i, FieldPosition, FieldPrecision: Integer;
2744     FieldAliasName: string;
2745     RelationName, FieldName: string;
2746     Query : TIBSQL;
2747     FieldIndex: Integer;
2748     FRelationNodes : TRelationNode;
2749    
2750     function Add_Node(Relation, Field : String) : TRelationNode;
2751     var
2752     FField : TFieldNode;
2753     begin
2754     if FRelationNodes.RelationName = '' then
2755     Result := FRelationNodes
2756     else
2757     begin
2758     Result := TRelationNode.Create;
2759     Result.NextRelation := FRelationNodes;
2760     end;
2761     Result.RelationName := Relation;
2762     FRelationNodes := Result;
2763     Query.Params[0].AsString := Relation;
2764     Query.ExecQuery;
2765     while not Query.Eof do
2766     begin
2767     FField := TFieldNode.Create;
2768     FField.FieldName := Query.Fields[2].AsString;
2769     FField.DEFAULT_VALUE := not Query.Fields[1].IsNull;
2770     FField.COMPUTED_BLR := not Query.Fields[0].IsNull;
2771     FField.NextField := Result.FieldNodes;
2772     Result.FieldNodes := FField;
2773     Query.Next;
2774     end;
2775     Query.Close;
2776     end;
2777    
2778     function Has_COMPUTED_BLR(Relation, Field : String) : Boolean;
2779     var
2780     FRelation : TRelationNode;
2781     FField : TFieldNode;
2782     begin
2783     FRelation := FRelationNodes;
2784     while Assigned(FRelation) and
2785     (FRelation.RelationName <> Relation) do
2786     FRelation := FRelation.NextRelation;
2787     if not Assigned(FRelation) then
2788     FRelation := Add_Node(Relation, Field);
2789     Result := false;
2790     FField := FRelation.FieldNodes;
2791     while Assigned(FField) do
2792     if FField.FieldName = Field then
2793     begin
2794     Result := Ffield.COMPUTED_BLR;
2795     Exit;
2796     end
2797     else
2798     FField := Ffield.NextField;
2799     end;
2800    
2801     function Has_DEFAULT_VALUE(Relation, Field : String) : Boolean;
2802     var
2803     FRelation : TRelationNode;
2804     FField : TFieldNode;
2805     begin
2806     FRelation := FRelationNodes;
2807     while Assigned(FRelation) and
2808     (FRelation.RelationName <> Relation) do
2809     FRelation := FRelation.NextRelation;
2810     if not Assigned(FRelation) then
2811     FRelation := Add_Node(Relation, Field);
2812     Result := false;
2813     FField := FRelation.FieldNodes;
2814     while Assigned(FField) do
2815     if FField.FieldName = Field then
2816     begin
2817     Result := Ffield.DEFAULT_VALUE;
2818     Exit;
2819     end
2820     else
2821     FField := Ffield.NextField;
2822     end;
2823    
2824     Procedure FreeNodes;
2825     var
2826     FRelation : TRelationNode;
2827     FField : TFieldNode;
2828     begin
2829     while Assigned(FRelationNodes) do
2830     begin
2831     While Assigned(FRelationNodes.FieldNodes) do
2832     begin
2833     FField := FRelationNodes.FieldNodes.NextField;
2834     FRelationNodes.FieldNodes.Free;
2835     FRelationNodes.FieldNodes := FField;
2836     end;
2837     FRelation := FRelationNodes.NextRelation;
2838     FRelationNodes.Free;
2839     FRelationNodes := FRelation;
2840     end;
2841     end;
2842    
2843     begin
2844     if not InternalPrepared then
2845     begin
2846     InternalPrepare;
2847     exit;
2848     end;
2849     FRelationNodes := TRelationNode.Create;
2850     FNeedsRefresh := False;
2851     Database.InternalTransaction.StartTransaction;
2852     Query := TIBSQL.Create(self);
2853     try
2854     Query.Database := DataBase;
2855     Query.Transaction := Database.InternalTransaction;
2856     FieldDefs.BeginUpdate;
2857     FieldDefs.Clear;
2858     FieldIndex := 0;
2859     if (Length(FMappedFieldPosition) < FQSelect.Current.Count) then
2860     SetLength(FMappedFieldPosition, FQSelect.Current.Count);
2861     Query.SQL.Text := DefaultSQL;
2862     Query.Prepare;
2863     for i := 0 to FQSelect.Current.Count - 1 do
2864     with FQSelect.Current[i].Data^ do
2865     begin
2866     { Get the field name }
2867     SetString(FieldAliasName, aliasname, aliasname_length);
2868     SetString(RelationName, relname, relname_length);
2869     SetString(FieldName, sqlname, sqlname_length);
2870     FieldSize := 0;
2871     FieldPrecision := 0;
2872     FieldNullable := FQSelect.Current[i].IsNullable;
2873     case sqltype and not 1 of
2874     { All VARCHAR's must be converted to strings before recording
2875     their values }
2876     SQL_VARYING, SQL_TEXT:
2877     begin
2878     FieldSize := sqllen;
2879     FieldType := ftString;
2880     end;
2881     { All Doubles/Floats should be cast to doubles }
2882     SQL_DOUBLE, SQL_FLOAT:
2883     FieldType := ftFloat;
2884     SQL_SHORT:
2885     begin
2886     if (sqlscale = 0) then
2887     FieldType := ftSmallInt
2888     else begin
2889     FieldType := ftBCD;
2890     FieldPrecision := 4;
2891     FieldSize := -sqlscale;
2892     end;
2893     end;
2894     SQL_LONG:
2895     begin
2896     if (sqlscale = 0) then
2897     FieldType := ftInteger
2898     else if (sqlscale >= (-4)) then
2899     begin
2900     FieldType := ftBCD;
2901     FieldPrecision := 9;
2902     FieldSize := -sqlscale;
2903     end
2904     else
2905     FieldType := ftFloat;
2906     end;
2907     SQL_INT64:
2908     begin
2909     if (sqlscale = 0) then
2910     FieldType := ftLargeInt
2911     else if (sqlscale >= (-4)) then
2912     begin
2913     FieldType := ftBCD;
2914     FieldPrecision := 18;
2915     FieldSize := -sqlscale;
2916     end
2917     else
2918     FieldType := ftFloat;
2919     end;
2920     SQL_TIMESTAMP: FieldType := ftDateTime;
2921     SQL_TYPE_TIME: FieldType := ftTime;
2922     SQL_TYPE_DATE: FieldType := ftDate;
2923     SQL_BLOB:
2924     begin
2925     FieldSize := sizeof (TISC_QUAD);
2926     if (sqlsubtype = 1) then
2927     FieldType := ftmemo
2928     else
2929     FieldType := ftBlob;
2930     end;
2931     SQL_ARRAY:
2932     begin
2933     FieldSize := sizeof (TISC_QUAD);
2934     FieldType := ftUnknown;
2935     end;
2936     else
2937     FieldType := ftUnknown;
2938     end;
2939     FieldPosition := i + 1;
2940     if (FieldType <> ftUnknown) and (FieldAliasName <> 'IBX_INTERNAL_DBKEY') then {do not localize}
2941     begin
2942     FMappedFieldPosition[FieldIndex] := FieldPosition;
2943     Inc(FieldIndex);
2944     with FieldDefs.AddFieldDef do
2945     begin
2946     Name := string( FieldAliasName );
2947     FieldNo := FieldPosition;
2948     DataType := FieldType;
2949     Size := FieldSize;
2950     Precision := FieldPrecision;
2951     Required := False;
2952     InternalCalcField := False;
2953     if (FieldName <> '') and (RelationName <> '') then
2954     begin
2955     if Has_COMPUTED_BLR(RelationName, FieldName) then
2956     begin
2957     Attributes := [faReadOnly];
2958     InternalCalcField := True;
2959     FNeedsRefresh := True;
2960     end
2961     else
2962     begin
2963     if Has_DEFAULT_VALUE(RelationName, FieldName) then
2964     begin
2965     if not FieldNullable then
2966     Attributes := [faRequired];
2967     end
2968     else
2969     FNeedsRefresh := True;
2970     end;
2971     end;
2972     end;
2973     end;
2974     end;
2975     finally
2976     Query.free;
2977     FreeNodes;
2978     Database.InternalTransaction.Commit;
2979     FieldDefs.EndUpdate;
2980     end;
2981     end;
2982    
2983     procedure TIBCustomDataSet.InternalInitRecord(Buffer: PChar);
2984     begin
2985     CopyRecordBuffer(FModelBuffer, Buffer);
2986     end;
2987    
2988     procedure TIBCustomDataSet.InternalLast;
2989     var
2990     Buffer: PChar;
2991     begin
2992     if (FQSelect.EOF) then
2993     FCurrentRecord := FRecordCount
2994     else begin
2995     Buffer := AllocRecordBuffer;
2996     try
2997     while FQSelect.Next <> nil do
2998     begin
2999     FetchCurrentRecordToBuffer(FQSelect, FRecordCount, Buffer);
3000     Inc(FRecordCount);
3001     end;
3002     FCurrentRecord := FRecordCount;
3003     finally
3004     FreeRecordBuffer(Buffer);
3005     end;
3006     end;
3007     end;
3008    
3009     procedure TIBCustomDataSet.InternalSetParamsFromCursor;
3010     var
3011     i: Integer;
3012     cur_param: TIBXSQLVAR;
3013     cur_field: TField;
3014     s: TStream;
3015     begin
3016     if FQSelect.SQL.Text = '' then
3017     IBError(ibxeEmptyQuery, [nil]);
3018     if not FInternalPrepared then
3019     InternalPrepare;
3020     if (SQLParams.Count > 0) and (DataSource <> nil) and (DataSource.DataSet <> nil) then
3021     begin
3022     for i := 0 to SQLParams.Count - 1 do
3023     begin
3024     cur_field := DataSource.DataSet.FindField(SQLParams[i].Name);
3025     cur_param := SQLParams[i];
3026     if (cur_field <> nil) then begin
3027     if (cur_field.IsNull) then
3028     cur_param.IsNull := True
3029     else case cur_field.DataType of
3030     ftString:
3031     cur_param.AsString := cur_field.AsString;
3032     ftBoolean, ftSmallint, ftWord:
3033     cur_param.AsShort := cur_field.AsInteger;
3034     ftInteger:
3035     cur_param.AsLong := cur_field.AsInteger;
3036     ftLargeInt:
3037     cur_param.AsInt64 := TLargeIntField(cur_field).AsLargeInt;
3038     ftFloat, ftCurrency:
3039     cur_param.AsDouble := cur_field.AsFloat;
3040     ftBCD:
3041     cur_param.AsCurrency := cur_field.AsCurrency;
3042     ftDate:
3043     cur_param.AsDate := cur_field.AsDateTime;
3044     ftTime:
3045     cur_param.AsTime := cur_field.AsDateTime;
3046     ftDateTime:
3047     cur_param.AsDateTime := cur_field.AsDateTime;
3048     ftBlob, ftMemo:
3049     begin
3050     s := nil;
3051     try
3052     s := DataSource.DataSet.
3053     CreateBlobStream(cur_field, bmRead);
3054     cur_param.LoadFromStream(s);
3055     finally
3056     s.free;
3057     end;
3058     end;
3059     else
3060     IBError(ibxeNotSupported, [nil]);
3061     end;
3062     end;
3063     end;
3064     end;
3065     end;
3066    
3067     procedure TIBCustomDataSet.ReQuery;
3068     begin
3069     FQSelect.Close;
3070     ClearBlobCache;
3071     FCurrentRecord := -1;
3072     FRecordCount := 0;
3073     FDeletedRecords := 0;
3074     FBPos := 0;
3075     FOBPos := 0;
3076     FBEnd := 0;
3077     FOBEnd := 0;
3078     FQSelect.Close;
3079     FQSelect.ExecQuery;
3080     FOpen := FQSelect.Open;
3081     First;
3082     end;
3083    
3084     procedure TIBCustomDataSet.InternalOpen;
3085     var
3086     SetCursor: Boolean;
3087    
3088     function RecordDataLength(n: Integer): Long;
3089     begin
3090     result := SizeOf(TRecordData) + ((n - 1) * SizeOf(TFieldData));
3091     end;
3092    
3093     begin
3094     SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault);
3095     if SetCursor then
3096     Screen.Cursor := crHourGlass;
3097     try
3098     ActivateConnection;
3099     ActivateTransaction;
3100     if FQSelect.SQL.Text = '' then
3101     IBError(ibxeEmptyQuery, [nil]);
3102     if not FInternalPrepared then
3103     InternalPrepare;
3104     if FQSelect.SQLType = SQLSelect then
3105     begin
3106     if DefaultFields then
3107     CreateFields;
3108     BindFields(True);
3109     FCurrentRecord := -1;
3110     FQSelect.ExecQuery;
3111     FOpen := FQSelect.Open;
3112    
3113     { Initialize offsets, buffer sizes, etc...
3114     1. Initially FRecordSize is just the "RecordDataLength".
3115     2. Allocate a "model" buffer and do a dummy fetch
3116     3. After the dummy fetch, FRecordSize will be appropriately
3117     adjusted to reflect the additional "weight" of the field
3118     data.
3119     4. Set up the FCalcFieldsOffset, FBlobCacheOffset and FRecordBufferSize.
3120     5. Now, with the BufferSize available, allocate memory for chunks of records
3121     6. Re-allocate the model buffer, accounting for the new
3122     FRecordBufferSize.
3123     7. Finally, calls to AllocRecordBuffer will work!.
3124     }
3125     {Step 1}
3126     FRecordSize := RecordDataLength(FQSelect.Current.Count);
3127     {Step 2, 3}
3128     IBAlloc(FModelBuffer, 0, FRecordSize);
3129     FetchCurrentRecordToBuffer(FQSelect, -1, FModelBuffer);
3130     {Step 4}
3131     FCalcFieldsOffset := FRecordSize;
3132     FBlobCacheOffset := FCalcFieldsOffset + CalcFieldsSize;
3133     FRecordBufferSize := (FBlobCacheOffset + (BlobFieldCount * SizeOf(TIBBlobStream)));
3134     {Step 5}
3135     if UniDirectional then
3136     FBufferChunkSize := FRecordBufferSize * UniCache
3137     else
3138     FBufferChunkSize := FRecordBufferSize * BufferChunks;
3139     IBAlloc(FBufferCache, FBufferChunkSize, FBufferChunkSize);
3140     if FCachedUpdates or (csReading in ComponentState) then
3141     IBAlloc(FOldBufferCache, FBufferChunkSize, FBufferChunkSize);
3142     FBPos := 0;
3143     FOBPos := 0;
3144     FBEnd := 0;
3145     FOBEnd := 0;
3146     FCacheSize := FBufferChunkSize;
3147     FOldCacheSize := FBufferChunkSize;
3148     {Step 6}
3149     IBAlloc(FModelBuffer, RecordDataLength(FQSelect.Current.Count),
3150     FRecordBufferSize);
3151     {Step 7}
3152     FOldBuffer := AllocRecordBuffer;
3153     end
3154     else
3155     FQSelect.ExecQuery;
3156     finally
3157     if SetCursor and (Screen.Cursor = crHourGlass) then
3158     Screen.Cursor := crDefault;
3159     end;
3160     end;
3161    
3162     procedure TIBCustomDataSet.InternalPost;
3163     var
3164     Qry: TIBSQL;
3165     Buff: PChar;
3166     SetCursor: Boolean;
3167     bInserting: Boolean;
3168     begin
3169     SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault);
3170     if SetCursor then
3171     Screen.Cursor := crHourGlass;
3172     try
3173     Buff := GetActiveBuf;
3174     CheckEditState;
3175     AdjustRecordOnInsert(Buff);
3176     if (State = dsInsert) then
3177     begin
3178     bInserting := True;
3179     Qry := FQInsert;
3180     PRecordData(Buff)^.rdUpdateStatus := usInserted;
3181     PRecordData(Buff)^.rdCachedUpdateStatus := cusInserted;
3182     WriteRecordCache(FRecordCount, Buff);
3183     FCurrentRecord := FRecordCount;
3184     end
3185     else begin
3186     bInserting := False;
3187     Qry := FQModify;
3188     if PRecordData(Buff)^.rdCachedUpdateStatus = cusUnmodified then
3189     begin
3190     PRecordData(Buff)^.rdUpdateStatus := usModified;
3191     PRecordData(Buff)^.rdCachedUpdateStatus := cusModified;
3192     end
3193     else if PRecordData(Buff)^.
3194     rdCachedUpdateStatus = cusUninserted then
3195     begin
3196     PRecordData(Buff)^.rdCachedUpdateStatus := cusInserted;
3197     Dec(FDeletedRecords);
3198     end;
3199     end;
3200     if (not CachedUpdates) then
3201     InternalPostRecord(Qry, Buff)
3202     else begin
3203     WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Buff);
3204     FUpdatesPending := True;
3205     end;
3206     if bInserting then
3207     Inc(FRecordCount);
3208     finally
3209     if SetCursor and (Screen.Cursor = crHourGlass) then
3210     Screen.Cursor := crDefault;
3211     end;
3212     end;
3213    
3214     procedure TIBCustomDataSet.InternalRefresh;
3215     begin
3216     inherited;
3217     InternalRefreshRow;
3218     end;
3219    
3220     procedure TIBCustomDataSet.InternalSetToRecord(Buffer: PChar);
3221     begin
3222     InternalGotoBookmark(@(PRecordData(Buffer)^.rdRecordNumber));
3223     end;
3224    
3225     function TIBCustomDataSet.IsCursorOpen: Boolean;
3226     begin
3227     result := FOpen;
3228     end;
3229    
3230     function TIBCustomDataSet.Locate(const KeyFields: string; const KeyValues: Variant;
3231     Options: TLocateOptions): Boolean;
3232     var
3233     CurBookmark: string;
3234     begin
3235     DisableControls;
3236     try
3237     CurBookmark := Bookmark;
3238     First;
3239     result := InternalLocate(KeyFields, KeyValues, Options);
3240     if not result then
3241     Bookmark := CurBookmark;
3242     finally
3243     EnableControls;
3244     end;
3245     end;
3246    
3247     function TIBCustomDataSet.Lookup(const KeyFields: string; const KeyValues: Variant;
3248     const ResultFields: string): Variant;
3249     var
3250     fl: TList;
3251     CurBookmark: string;
3252     begin
3253     DisableControls;
3254     fl := TList.Create;
3255     CurBookmark := Bookmark;
3256     try
3257     First;
3258     if InternalLocate(KeyFields, KeyValues, []) then
3259     begin
3260     if (ResultFields <> '') then
3261     result := FieldValues[ResultFields]
3262     else
3263     result := NULL;
3264     end
3265     else
3266     result := Null;
3267     finally
3268     Bookmark := CurBookmark;
3269     fl.Free;
3270     EnableControls;
3271     end;
3272     end;
3273    
3274     procedure TIBCustomDataSet.SetBookmarkData(Buffer: PChar; Data: Pointer);
3275     begin
3276     PRecordData(Buffer)^.rdRecordNumber := PInteger(Data)^;
3277     end;
3278    
3279     procedure TIBCustomDataSet.SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag);
3280     begin
3281     PRecordData(Buffer)^.rdBookmarkFlag := Value;
3282     end;
3283    
3284     procedure TIBCustomDataSet.SetCachedUpdates(Value: Boolean);
3285     begin
3286     if not Value and FCachedUpdates then
3287     CancelUpdates;
3288     if (not (csReading in ComponentState)) and Value then
3289     CheckDatasetClosed;
3290     FCachedUpdates := Value;
3291     end;
3292    
3293     procedure TIBCustomDataSet.SetDataSource(Value: TDataSource);
3294     begin
3295     if IsLinkedTo(Value) then
3296     IBError(ibxeCircularReference, [nil]);
3297     if FDataLink <> nil then
3298     FDataLink.DataSource := Value;
3299     end;
3300    
3301     procedure TIBCustomDataSet.InternalSetFieldData(Field: TField; Buffer: Pointer);
3302     var
3303     Buff, TmpBuff: PChar;
3304     begin
3305     Buff := GetActiveBuf;
3306     if Field.FieldNo < 0 then
3307     begin
3308     TmpBuff := Buff + FRecordSize + Field.Offset;
3309     Boolean(TmpBuff[0]) := LongBool(Buffer);
3310     if Boolean(TmpBuff[0]) then
3311     Move(Buffer^, TmpBuff[1], Field.DataSize);
3312     WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Buff);
3313     end
3314     else begin
3315     CheckEditState;
3316     with PRecordData(Buff)^ do
3317     begin
3318     { If inserting, Adjust record position }
3319     AdjustRecordOnInsert(Buff);
3320     if (FMappedFieldPosition[Field.FieldNo - 1] > 0) and
3321     (FMappedFieldPosition[Field.FieldNo - 1] <= rdFieldCount) then
3322     begin
3323     Field.Validate(Buffer);
3324     if (Buffer = nil) or
3325     (Field is TIBStringField) and (PChar(Buffer)[0] = #0) then
3326     rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdIsNull := True
3327     else begin
3328     Move(Buffer^, Buff[rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataOfs],
3329     rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataSize);
3330     if (rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataType = SQL_TEXT) or
3331     (rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataType = SQL_VARYING) then
3332     rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataLength := StrLen(PChar(Buffer));
3333     rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdIsNull := False;
3334     if rdUpdateStatus = usUnmodified then
3335     begin
3336     if CachedUpdates then
3337     begin
3338     FUpdatesPending := True;
3339     if State = dsInsert then
3340     rdCachedUpdateStatus := cusInserted
3341     else if State = dsEdit then
3342     rdCachedUpdateStatus := cusModified;
3343     end;
3344    
3345     if State = dsInsert then
3346     rdUpdateStatus := usInserted
3347     else
3348     rdUpdateStatus := usModified;
3349     end;
3350     WriteRecordCache(rdRecordNumber, Buff);
3351     SetModified(True);
3352     end;
3353     end;
3354     end;
3355     end;
3356     if not (State in [dsCalcFields, dsFilter, dsNewValue]) then
3357     DataEvent(deFieldChange, Longint(Field));
3358     end;
3359    
3360     procedure TIBCustomDataSet.SetRecNo(Value: Integer);
3361     begin
3362     CheckBrowseMode;
3363     if (Value < 1) then
3364     Value := 1
3365     else if Value > FRecordCount then
3366     begin
3367     InternalLast;
3368     Value := Min(FRecordCount, Value);
3369     end;
3370     if (Value <> RecNo) then
3371     begin
3372     DoBeforeScroll;
3373     FCurrentRecord := Value - 1;
3374     Resync([]);
3375     DoAfterScroll;
3376     end;
3377     end;
3378    
3379     procedure TIBCustomDataSet.Disconnect;
3380     begin
3381     Close;
3382     InternalUnPrepare;
3383     end;
3384    
3385     procedure TIBCustomDataSet.SetUpdateMode(const Value: TUpdateMode);
3386     begin
3387     if not CanModify then
3388     IBError(ibxeCannotUpdate, [nil])
3389     else
3390     FUpdateMode := Value;
3391     end;
3392    
3393    
3394     procedure TIBCustomDataSet.SetUpdateObject(Value: TIBDataSetUpdateObject);
3395     begin
3396     if Value <> FUpdateObject then
3397     begin
3398     if Assigned(FUpdateObject) and (FUpdateObject.DataSet = Self) then
3399     FUpdateObject.DataSet := nil;
3400     FUpdateObject := Value;
3401     if Assigned(FUpdateObject) then
3402     begin
3403     if Assigned(FUpdateObject.DataSet) and
3404     (FUpdateObject.DataSet <> Self) then
3405     FUpdateObject.DataSet.UpdateObject := nil;
3406     FUpdateObject.DataSet := Self;
3407     end;
3408     end;
3409     end;
3410    
3411     function TIBCustomDataSet.ConstraintsStored: Boolean;
3412     begin
3413     Result := Constraints.Count > 0;
3414     end;
3415    
3416     procedure TIBCustomDataSet.ClearCalcFields(Buffer: PChar);
3417     begin
3418     FillChar(Buffer[FRecordSize], CalcFieldsSize, 0);
3419     end;
3420    
3421    
3422     procedure TIBCustomDataSet.InternalUnPrepare;
3423     begin
3424     if FInternalPrepared then
3425     begin
3426     CheckDatasetClosed;
3427     FieldDefs.Clear;
3428     FInternalPrepared := False;
3429     end;
3430     end;
3431    
3432     procedure TIBCustomDataSet.InternalExecQuery;
3433     var
3434     DidActivate: Boolean;
3435     SetCursor: Boolean;
3436     begin
3437     DidActivate := False;
3438     SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault);
3439     if SetCursor then
3440     Screen.Cursor := crHourGlass;
3441     try
3442     ActivateConnection;
3443     DidActivate := ActivateTransaction;
3444     if FQSelect.SQL.Text = '' then
3445     IBError(ibxeEmptyQuery, [nil]);
3446     if not FInternalPrepared then
3447     InternalPrepare;
3448     if FQSelect.SQLType = SQLSelect then
3449     begin
3450     IBError(ibxeIsASelectStatement, [nil]);
3451     end
3452     else
3453     FQSelect.ExecQuery;
3454     finally
3455     if DidActivate then
3456     DeactivateTransaction;
3457     if SetCursor and (Screen.Cursor = crHourGlass) then
3458     Screen.Cursor := crDefault;
3459     end;
3460     end;
3461    
3462     function TIBCustomDataSet.GetSelectStmtHandle: TISC_STMT_HANDLE;
3463     begin
3464     Result := FQSelect.Handle;
3465     end;
3466    
3467     procedure TIBCustomDataSet.InitRecord(Buffer: PChar);
3468     begin
3469     inherited InitRecord(Buffer);
3470     with PRecordData(Buffer)^ do
3471     begin
3472     rdUpdateStatus := TUpdateStatus(usInserted);
3473     rdBookMarkFlag := bfInserted;
3474     rdRecordNumber := -1;
3475     end;
3476     end;
3477    
3478     procedure TIBCustomDataSet.InternalInsert;
3479     begin
3480     CursorPosChanged;
3481     end;
3482    
3483     { TIBDataSet IProviderSupport }
3484    
3485     procedure TIBCustomDataSet.PSEndTransaction(Commit: Boolean);
3486     begin
3487     if Commit then
3488     Transaction.Commit else
3489     Transaction.Rollback;
3490     end;
3491    
3492     function TIBCustomDataSet.PSExecuteStatement(const ASQL: string; AParams: TParams;
3493     ResultSet: Pointer = nil): Integer;
3494     var
3495     FQuery: TIBQuery;
3496     begin
3497     if Assigned(ResultSet) then
3498     begin
3499     TDataSet(ResultSet^) := TIBQuery.Create(nil);
3500     with TIBQuery(ResultSet^) do
3501     begin
3502     SQL.Text := ASQL;
3503     Params.Assign(AParams);
3504     Open;
3505     Result := RowsAffected;
3506     end;
3507     end
3508     else
3509     begin
3510     FQuery := TIBQuery.Create(nil);
3511     try
3512     FQuery.Database := Database;
3513     FQuery.Transaction := Transaction;
3514     FQuery.GenerateParamNames := True;
3515     FQuery.SQL.Text := ASQL;
3516     FQuery.Params.Assign(AParams);
3517     FQuery.ExecSQL;
3518     Result := FQuery.RowsAffected;
3519     finally
3520     FQuery.Free;
3521     end;
3522     end;
3523     end;
3524    
3525     function TIBCustomDataSet.PSGetQuoteChar: string;
3526     begin
3527     if Database.SQLDialect = 3 then
3528     Result := '"' else
3529     Result := '';
3530     end;
3531    
3532     function TIBCustomDataSet.PSGetUpdateException(E: Exception; Prev: EUpdateError): EUpdateError;
3533     var
3534     PrevErr: Integer;
3535     begin
3536     if Prev <> nil then
3537     PrevErr := Prev.ErrorCode else
3538     PrevErr := 0;
3539     if E is EIBError then
3540     with EIBError(E) do
3541     Result := EUpdateError.Create(E.Message, '', SQLCode, PrevErr, E) else
3542     Result := inherited PSGetUpdateException(E, Prev);
3543     end;
3544    
3545     function TIBCustomDataSet.PSInTransaction: Boolean;
3546     begin
3547     Result := Transaction.InTransaction;
3548     end;
3549    
3550     function TIBCustomDataSet.PSIsSQLBased: Boolean;
3551     begin
3552     Result := True;
3553     end;
3554    
3555     function TIBCustomDataSet.PSIsSQLSupported: Boolean;
3556     begin
3557     Result := True;
3558     end;
3559    
3560     procedure TIBCustomDataSet.PSReset;
3561     begin
3562     inherited PSReset;
3563     if Active then
3564     begin
3565     Close;
3566     Open;
3567     end;
3568     end;
3569    
3570     function TIBCustomDataSet.PSUpdateRecord(UpdateKind: TUpdateKind; Delta: TDataSet): Boolean;
3571     var
3572     UpdateAction: TIBUpdateAction;
3573     SQL: string;
3574     Params: TParams;
3575    
3576     procedure AssignParams(DataSet: TDataSet; Params: TParams);
3577     var
3578     I: Integer;
3579     Old: Boolean;
3580     Param: TParam;
3581     PName: string;
3582     Field: TField;
3583     Value: Variant;
3584     begin
3585     for I := 0 to Params.Count - 1 do
3586     begin
3587     Param := Params[I];
3588     PName := Param.Name;
3589     Old := CompareText(Copy(PName, 1, 4), 'OLD_') = 0; {do not localize}
3590     if Old then System.Delete(PName, 1, 4);
3591     Field := DataSet.FindField(PName);
3592     if not Assigned(Field) then Continue;
3593     if Old then Param.AssignFieldValue(Field, Field.OldValue) else
3594     begin
3595     Value := Field.NewValue;
3596     if VarIsEmpty(Value) then Value := Field.OldValue;
3597     Param.AssignFieldValue(Field, Value);
3598     end;
3599     end;
3600     end;
3601    
3602     begin
3603     Result := False;
3604     if Assigned(OnUpdateRecord) then
3605     begin
3606     UpdateAction := uaFail;
3607     if Assigned(FOnUpdateRecord) then
3608     begin
3609     FOnUpdateRecord(Delta, UpdateKind, UpdateAction);
3610     Result := UpdateAction = uaApplied;
3611     end;
3612     end
3613     else if Assigned(FUpdateObject) then
3614     begin
3615     SQL := FUpdateObject.GetSQL(UpdateKind).Text;
3616     if SQL <> '' then
3617     begin
3618     Params := TParams.Create;
3619     try
3620     Params.ParseSQL(SQL, True);
3621     AssignParams(Delta, Params);
3622     if PSExecuteStatement(SQL, Params) = 0 then
3623     IBError(ibxeNoRecordsAffected, [nil]);
3624     Result := True;
3625     finally
3626     Params.Free;
3627     end;
3628     end;
3629     end;
3630     end;
3631    
3632     procedure TIBCustomDataSet.PSStartTransaction;
3633     begin
3634     ActivateConnection;
3635     Transaction.StartTransaction;
3636     end;
3637    
3638     function TIBCustomDataSet.PSGetTableName: string;
3639     begin
3640     // if not FInternalPrepared then
3641     // InternalPrepare;
3642     { It is possible for the FQSelectSQL to be unprepared
3643     with FInternalPreprepared being true (see DoBeforeTransactionEnd).
3644     So check the Prepared of the SelectSQL instead }
3645     if not FQSelect.Prepared then
3646     FQSelect.Prepare;
3647     Result := FQSelect.UniqueRelationName;
3648     end;
3649    
3650     procedure TIBDataSet.BatchInput(InputObject: TIBBatchInput);
3651     begin
3652     InternalBatchInput(InputObject);
3653     end;
3654    
3655     procedure TIBDataSet.BatchOutput(OutputObject: TIBBatchOutput);
3656     begin
3657     InternalBatchOutput(OutputObject);
3658     end;
3659    
3660     procedure TIBDataSet.ExecSQL;
3661     begin
3662     InternalExecQuery;
3663     end;
3664    
3665     procedure TIBDataSet.Prepare;
3666     begin
3667     InternalPrepare;
3668     end;
3669    
3670     procedure TIBDataSet.UnPrepare;
3671     begin
3672     InternalUnPrepare;
3673     end;
3674    
3675     function TIBDataSet.GetPrepared: Boolean;
3676     begin
3677     Result := InternalPrepared;
3678     end;
3679    
3680     procedure TIBDataSet.InternalOpen;
3681     begin
3682     ActivateConnection;
3683     ActivateTransaction;
3684     InternalSetParamsFromCursor;
3685     Inherited;
3686     end;
3687    
3688     procedure TIBDataSet.SetFiltered(Value: Boolean);
3689     begin
3690     if(Filtered <> Value) then
3691     begin
3692     inherited SetFiltered(value);
3693     if Active then
3694     begin
3695     Close;
3696     Open;
3697     end;
3698     end
3699     else
3700     inherited SetFiltered(value);
3701     end;
3702    
3703     function TIBCustomDataSet.BookmarkValid(Bookmark: TBookmark): Boolean;
3704     begin
3705     Result := false;
3706     if not Assigned(Bookmark) then
3707     exit;
3708     Result := PInteger(Bookmark)^ < FRecordCount;
3709     end;
3710    
3711     function TIBCustomDataSet.GetFieldData(Field: TField;
3712     Buffer: Pointer): Boolean;
3713     var
3714     lTempCurr : System.Currency;
3715     begin
3716     if (Field.DataType = ftBCD) and (Buffer <> nil) then
3717     begin
3718     Result := InternalGetFieldData(Field, @lTempCurr);
3719     if Result then
3720     CurrToBCD(lTempCurr, TBCD(Buffer^), 32, Field.Size);
3721     end
3722     else
3723     Result := InternalGetFieldData(Field, Buffer);
3724     end;
3725    
3726     function TIBCustomDataSet.GetFieldData(Field: TField; Buffer: Pointer;
3727     NativeFormat: Boolean): Boolean;
3728     begin
3729     if (Field.DataType = ftBCD) and not NativeFormat then
3730     Result := InternalGetFieldData(Field, Buffer)
3731     else
3732     Result := inherited GetFieldData(Field, Buffer, NativeFormat);
3733     end;
3734    
3735     procedure TIBCustomDataSet.SetFieldData(Field: TField; Buffer: Pointer);
3736     var
3737     lTempCurr : System.Currency;
3738     begin
3739     if Field.DataType = ftBCD then
3740     begin
3741     BCDToCurr(TBCD(Buffer^), lTempCurr);
3742     InternalSetFieldData(Field, @lTempCurr);
3743     end
3744     else
3745     InternalSetFieldData(Field, Buffer);
3746     end;
3747    
3748     procedure TIBCustomDataSet.SetFieldData(Field: TField; Buffer: Pointer;
3749     NativeFormat: Boolean);
3750     begin
3751     if (not NativeFormat) and (Field.DataType = ftBCD) then
3752     InternalSetfieldData(Field, Buffer)
3753     else
3754     inherited SetFieldData(Field, buffer, NativeFormat);
3755     end;
3756    
3757     { TIBDataSetUpdateObject }
3758    
3759     constructor TIBDataSetUpdateObject.Create(AOwner: TComponent);
3760     begin
3761     inherited Create(AOwner);
3762     FRefreshSQL := TStringList.Create;
3763     end;
3764    
3765     destructor TIBDataSetUpdateObject.Destroy;
3766     begin
3767     FRefreshSQL.Free;
3768     inherited destroy;
3769     end;
3770    
3771     procedure TIBDataSetUpdateObject.SetRefreshSQL(Value: TStrings);
3772     begin
3773     FRefreshSQL.Assign(Value);
3774     end;
3775    
3776     { TIBDSBlobStream }
3777     constructor TIBDSBlobStream.Create(AField: TField; ABlobStream: TIBBlobStream;
3778     Mode: TBlobStreamMode);
3779     begin
3780     FField := AField;
3781     FBlobStream := ABlobStream;
3782     FBlobStream.Seek(0, soFromBeginning);
3783     if (Mode = bmWrite) then
3784     FBlobStream.Truncate;
3785     end;
3786    
3787     function TIBDSBlobStream.Read(var Buffer; Count: Longint): Longint;
3788     begin
3789     result := FBlobStream.Read(Buffer, Count);
3790     end;
3791    
3792     function TIBDSBlobStream.Seek(Offset: Longint; Origin: Word): Longint;
3793     begin
3794     result := FBlobStream.Seek(Offset, Origin);
3795     end;
3796    
3797     procedure TIBDSBlobStream.SetSize(NewSize: Longint);
3798     begin
3799     FBlobStream.SetSize(NewSize);
3800     end;
3801    
3802     function TIBDSBlobStream.Write(const Buffer; Count: Longint): Longint;
3803     begin
3804     if not (FField.DataSet.State in [dsEdit, dsInsert]) then
3805     IBError(ibxeNotEditing, [nil]);
3806     TIBCustomDataSet(FField.DataSet).RecordModified(True);
3807     result := FBlobStream.Write(Buffer, Count);
3808     TIBCustomDataSet(FField.DataSet).DataEvent(deFieldChange, Longint(FField));
3809     end;
3810    
3811     end.