ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/nongui/IBCustomDataSet.pas
Revision: 216
Committed: Thu Mar 15 17:21:13 2018 UTC (6 years ago) by tony
Content type: text/x-pascal
File size: 150906 byte(s)
Log Message:
Fixes Merged

File Contents

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