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