ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/IBCustomDataSet.pas
Revision: 50
Committed: Thu Feb 23 15:22:18 2017 UTC (7 years, 1 month ago) by tony
Content type: text/x-pascal
File size: 140737 byte(s)
Log Message:
Committing updates for Trunk

File Contents

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