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