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