ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/IBCustomDataSet.pas
Revision: 80
Committed: Mon Jan 1 11:31:07 2018 UTC (6 years, 2 months ago) by tony
Content type: text/x-pascal
File size: 141392 byte(s)
Log Message:
Fixes merged into public release

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