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

File Contents

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