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