ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/IBCustomDataSet.pas
Revision: 37
Committed: Mon Feb 15 14:44:25 2016 UTC (8 years, 9 months ago) by tony
Content type: text/x-pascal
File size: 134179 byte(s)
Log Message:
Committing updates for Release R1-4-0

File Contents

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