ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/nongui/IBCustomDataSet.pas
Revision: 209
Committed: Wed Mar 14 12:48:51 2018 UTC (6 years ago) by tony
Content type: text/x-pascal
File size: 150462 byte(s)
Log Message:
Fixes Merged

File Contents

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