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