ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/journaling/runtime/nongui/IBCustomDataSet.pas
Revision: 312
Committed: Tue Aug 25 15:40:58 2020 UTC (3 years, 7 months ago) by tony
Content type: text/x-pascal
Original Path: ibx/trunk/runtime/nongui/IBCustomDataSet.pas
File size: 154682 byte(s)
Log Message:
Fixes Merged

File Contents

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