ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/IBCustomDataSet.pas
Revision: 101
Committed: Thu Jan 18 14:37:18 2018 UTC (6 years, 2 months ago) by tony
Content type: text/x-pascal
File size: 146027 byte(s)
Log Message:
Fixes merged for support of Identity Columns

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