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