ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/journaling/runtime/nongui/IBCustomDataSet.pas
Revision: 359
Committed: Tue Dec 7 09:37:32 2021 UTC (2 years, 3 months ago) by tony
Content type: text/x-pascal
Original Path: ibx/trunk/runtime/nongui/IBCustomDataSet.pas
File size: 167702 byte(s)
Log Message:
Fixes Merged

File Contents

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