ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/IBCustomDataSet.pas
Revision: 7
Committed: Sun Aug 5 18:28:19 2012 UTC (11 years, 7 months ago) by tony
Content type: text/x-pascal
File size: 116749 byte(s)
Log Message:
Committing updates for Release R1-0-0

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 }
31 { }
32 {************************************************************************}
33
34 unit IBCustomDataSet;
35
36 {$Mode Delphi}
37
38 {$IFDEF DELPHI}
39 {$DEFINE TDBDFIELD_IS_BCD}
40 {$ENDIF}
41
42 interface
43
44 uses
45 {$IFDEF WINDOWS }
46 Windows,
47 {$ELSE}
48 unix,
49 {$ENDIF}
50 SysUtils, Classes, Forms, Controls, IBDatabase,
51 IBExternals, IB, IBHeader, IBSQL, Db,
52 IBUtils, IBBlob;
53
54 const
55 BufferCacheSize = 1000; { Allocate cache in this many record chunks}
56 UniCache = 2; { Uni-directional cache is 2 records big }
57
58 type
59 TIBCustomDataSet = class;
60 TIBDataSet = class;
61
62 { TIBDataSetUpdateObject }
63
64 TIBDataSetUpdateObject = class(TComponent)
65 private
66 FRefreshSQL: TStrings;
67 procedure SetRefreshSQL(value: TStrings);
68 protected
69 function GetDataSet: TIBCustomDataSet; virtual; abstract;
70 procedure SetDataSet(ADataSet: TIBCustomDataSet); virtual; abstract;
71 procedure Apply(UpdateKind: TUpdateKind; buff: PChar); virtual; abstract;
72 function GetSQL(UpdateKind: TUpdateKind): TStrings; virtual; abstract;
73 procedure InternalSetParams(Query: TIBSQL; buff: PChar);
74 property DataSet: TIBCustomDataSet read GetDataSet write SetDataSet;
75 public
76 constructor Create(AOwner: TComponent); override;
77 destructor Destroy; override;
78 published
79 property RefreshSQL: TStrings read FRefreshSQL write SetRefreshSQL;
80 end;
81
82 TBlobDataArray = array[0..0] of TIBBlobStream;
83 PBlobDataArray = ^TBlobDataArray;
84
85 { TIBCustomDataSet }
86 TFieldData = record
87 fdDataType: Short;
88 fdDataScale: Short;
89 fdNullable: Boolean;
90 fdIsNull: Boolean;
91 fdDataSize: Short;
92 fdDataLength: Short;
93 fdDataOfs: Integer;
94 end;
95 PFieldData = ^TFieldData;
96
97 TCachedUpdateStatus = (
98 cusUnmodified, cusModified, cusInserted,
99 cusDeleted, cusUninserted
100 );
101 TIBDBKey = record
102 DBKey: array[0..7] of Byte;
103 end;
104 PIBDBKey = ^TIBDBKey;
105
106 TRecordData = record
107 rdBookmarkFlag: TBookmarkFlag;
108 rdFieldCount: Short;
109 rdRecordNumber: Integer;
110 rdCachedUpdateStatus: TCachedUpdateStatus;
111 rdUpdateStatus: TUpdateStatus;
112 rdSavedOffset: DWORD;
113 rdDBKey: TIBDBKey;
114 rdFields: array[1..1] of TFieldData;
115 end;
116 PRecordData = ^TRecordData;
117
118 { TIBStringField allows us to have strings longer than 8196 }
119
120 TIBStringField = class(TStringField)
121 public
122 constructor create(AOwner: TComponent); override;
123 class procedure CheckTypeSize(Value: Integer); override;
124 function GetAsString: string; override;
125 function GetAsVariant: Variant; override;
126 function GetValue(var Value: string): Boolean;
127 procedure SetAsString(const Value: string); override;
128 end;
129
130 { TIBBCDField }
131 { Actually, there is no BCD involved in this type,
132 instead it deals with currency types.
133 In IB, this is an encapsulation of Numeric (x, y)
134 where x < 18 and y <= 4.
135 Note: y > 4 will default to Floats
136 }
137 TIBBCDField = class(TBCDField)
138 protected
139 class procedure CheckTypeSize(Value: Integer); override;
140 function GetAsCurrency: Currency; override;
141 function GetAsString: string; override;
142 function GetAsVariant: Variant; override;
143 function GetDataSize: Integer; override;
144 public
145 constructor Create(AOwner: TComponent); override;
146 published
147 property Size default 8;
148 end;
149
150 TIBDataLink = class(TDetailDataLink)
151 private
152 FDataSet: TIBCustomDataSet;
153 protected
154 procedure ActiveChanged; override;
155 procedure RecordChanged(Field: TField); override;
156 function GetDetailDataSet: TDataSet; override;
157 procedure CheckBrowseMode; override;
158 public
159 constructor Create(ADataSet: TIBCustomDataSet);
160 destructor Destroy; override;
161 end;
162
163 TIBGeneratorApplyOnEvent = (gaeOnNewRecord,gaeOnPostRecord);
164
165 { TIBGenerator }
166
167 TIBGenerator = class(TPersistent)
168 private
169 FOwner: TIBCustomDataSet;
170 FApplyOnEvent: TIBGeneratorApplyOnEvent;
171 FFieldName: string;
172 FGeneratorName: string;
173 FIncrement: integer;
174 procedure SetIncrement(const AValue: integer);
175 protected
176 function GetNextValue(ADatabase: TIBDatabase; ATransaction: TIBTransaction): integer;
177 public
178 constructor Create(Owner: TIBCustomDataSet);
179 procedure Apply;
180 property Owner: TIBCustomDataSet read FOwner;
181 published
182 property Generator: string read FGeneratorName write FGeneratorName;
183 property Field: string read FFieldName write FFieldName;
184 property Increment: integer read FIncrement write SetIncrement default 1;
185 property ApplyOnEvent: TIBGeneratorApplyOnEvent read FApplyOnEvent write FApplyOnEvent;
186 end;
187
188 { TIBCustomDataSet }
189 TIBUpdateAction = (uaFail, uaAbort, uaSkip, uaRetry, uaApply, uaApplied);
190
191 TIBUpdateErrorEvent = procedure(DataSet: TDataSet; E: EDatabaseError;
192 UpdateKind: TUpdateKind; var UpdateAction: TIBUpdateAction)
193 of object;
194 TIBUpdateRecordEvent = procedure(DataSet: TDataSet; UpdateKind: TUpdateKind;
195 var UpdateAction: TIBUpdateAction) of object;
196
197 TIBUpdateRecordTypes = set of TCachedUpdateStatus;
198
199 TIBCustomDataSet = class(TDataset)
200 private
201 FGeneratorField: TIBGenerator;
202 FNeedsRefresh: Boolean;
203 FForcedRefresh: Boolean;
204 FDidActivate: Boolean;
205 FIBLoaded: Boolean;
206 FBase: TIBBase;
207 FBlobCacheOffset: Integer;
208 FBlobStreamList: TList;
209 FBufferChunks: Integer;
210 FBufferCache,
211 FOldBufferCache: PChar;
212 FBufferChunkSize,
213 FCacheSize,
214 FOldCacheSize: Integer;
215 FFilterBuffer: PChar;
216 FBPos,
217 FOBPos,
218 FBEnd,
219 FOBEnd: DWord;
220 FCachedUpdates: Boolean;
221 FCalcFieldsOffset: Integer;
222 FCurrentRecord: Long;
223 FDeletedRecords: Long;
224 FModelBuffer,
225 FOldBuffer: PChar;
226 FOpen: Boolean;
227 FInternalPrepared: Boolean;
228 FQDelete,
229 FQInsert,
230 FQRefresh,
231 FQSelect,
232 FQModify: TIBSQL;
233 FRecordBufferSize: Integer;
234 FRecordCount: Integer;
235 FRecordSize: Integer;
236 FUniDirectional: Boolean;
237 FUpdateMode: TUpdateMode;
238 FUpdateObject: TIBDataSetUpdateObject;
239 FParamCheck: Boolean;
240 FUpdatesPending: Boolean;
241 FUpdateRecordTypes: TIBUpdateRecordTypes;
242 FMappedFieldPosition: array of Integer;
243 FDataLink: TIBDataLink;
244
245 FBeforeDatabaseDisconnect,
246 FAfterDatabaseDisconnect,
247 FDatabaseFree: TNotifyEvent;
248 FOnUpdateError: TIBUpdateErrorEvent;
249 FOnUpdateRecord: TIBUpdateRecordEvent;
250 FBeforeTransactionEnd,
251 FAfterTransactionEnd,
252 FTransactionFree: TNotifyEvent;
253
254 function GetSelectStmtHandle: TISC_STMT_HANDLE;
255 procedure SetUpdateMode(const Value: TUpdateMode);
256 procedure SetUpdateObject(Value: TIBDataSetUpdateObject);
257
258 function AdjustCurrentRecord(Buffer: Pointer; GetMode: TGetMode): TGetResult;
259 procedure AdjustRecordOnInsert(Buffer: Pointer);
260 function CanEdit: Boolean;
261 function CanInsert: Boolean;
262 function CanDelete: Boolean;
263 function CanRefresh: Boolean;
264 procedure CheckEditState;
265 procedure ClearBlobCache;
266 procedure CopyRecordBuffer(Source, Dest: Pointer);
267 procedure DoBeforeDatabaseDisconnect(Sender: TObject);
268 procedure DoAfterDatabaseDisconnect(Sender: TObject);
269 procedure DoDatabaseFree(Sender: TObject);
270 procedure DoBeforeTransactionEnd(Sender: TObject);
271 procedure DoAfterTransactionEnd(Sender: TObject);
272 procedure DoTransactionFree(Sender: TObject);
273 procedure FetchCurrentRecordToBuffer(Qry: TIBSQL; RecordNumber: Integer;
274 Buffer: PChar);
275 function GetDatabase: TIBDatabase;
276 function GetDBHandle: PISC_DB_HANDLE;
277 function GetDeleteSQL: TStrings;
278 function GetInsertSQL: TStrings;
279 function GetSQLParams: TIBXSQLDA;
280 function GetRefreshSQL: TStrings;
281 function GetSelectSQL: TStrings;
282 function GetStatementType: TIBSQLTypes;
283 function GetModifySQL: TStrings;
284 function GetTransaction: TIBTransaction;
285 function GetTRHandle: PISC_TR_HANDLE;
286 procedure InternalDeleteRecord(Qry: TIBSQL; Buff: Pointer); virtual;
287 function InternalLocate(const KeyFields: string; const KeyValues: Variant;
288 Options: TLocateOptions): Boolean; virtual;
289 procedure InternalPostRecord(Qry: TIBSQL; Buff: Pointer); virtual;
290 procedure InternalRevertRecord(RecordNumber: Integer); virtual;
291 function IsVisible(Buffer: PChar): Boolean;
292 procedure SaveOldBuffer(Buffer: PChar);
293 procedure SetBufferChunks(Value: Integer);
294 procedure SetDatabase(Value: TIBDatabase);
295 procedure SetDeleteSQL(Value: TStrings);
296 procedure SetInsertSQL(Value: TStrings);
297 procedure SetInternalSQLParams(Qry: TIBSQL; Buffer: Pointer);
298 procedure SetRefreshSQL(Value: TStrings);
299 procedure SetSelectSQL(Value: TStrings);
300 procedure SetModifySQL(Value: TStrings);
301 procedure SetTransaction(Value: TIBTransaction);
302 procedure SetUpdateRecordTypes(Value: TIBUpdateRecordTypes);
303 procedure SetUniDirectional(Value: Boolean);
304 procedure RefreshParams;
305 procedure SQLChanging(Sender: TObject); virtual;
306 function AdjustPosition(FCache: PChar; Offset: DWORD;
307 Origin: Integer): DWORD;
308 procedure ReadCache(FCache: PChar; Offset: DWORD; Origin: Integer;
309 Buffer: PChar);
310 procedure ReadRecordCache(RecordNumber: Integer; Buffer: PChar;
311 ReadOldBuffer: Boolean);
312 procedure WriteCache(FCache: PChar; Offset: DWORD; Origin: Integer;
313 Buffer: PChar);
314 procedure WriteRecordCache(RecordNumber: Integer; Buffer: PChar);
315 function InternalGetRecord(Buffer: PChar; GetMode: TGetMode;
316 DoCheck: Boolean): TGetResult; virtual;
317
318 protected
319 procedure ActivateConnection;
320 function ActivateTransaction: Boolean;
321 procedure DeactivateTransaction;
322 procedure CheckDatasetClosed;
323 procedure CheckDatasetOpen;
324 function GetActiveBuf: PChar;
325 procedure InternalBatchInput(InputObject: TIBBatchInput); virtual;
326 procedure InternalBatchOutput(OutputObject: TIBBatchOutput); virtual;
327 procedure InternalPrepare; virtual;
328 procedure InternalUnPrepare; virtual;
329 procedure InternalExecQuery; virtual;
330 procedure InternalRefreshRow; virtual;
331 procedure InternalSetParamsFromCursor; virtual;
332 procedure CheckNotUniDirectional;
333
334 (* { IProviderSupport }
335 procedure PSEndTransaction(Commit: Boolean); override;
336 function PSExecuteStatement(const ASQL: string; AParams: TParams;
337 ResultSet: Pointer = nil): Integer; override;
338 function PsGetTableName: string; override;
339 function PSGetQuoteChar: string; override;
340 function PSGetUpdateException(E: Exception; Prev: EUpdateError): EUpdateError; override;
341 function PSInTransaction: Boolean; override;
342 function PSIsSQLBased: Boolean; override;
343 function PSIsSQLSupported: Boolean; override;
344 procedure PSStartTransaction; override;
345 procedure PSReset; override;
346 function PSUpdateRecord(UpdateKind: TUpdateKind; Delta: TDataSet): Boolean; override;
347 *)
348 { TDataSet support }
349 procedure InternalInsert; override;
350 procedure InitRecord(Buffer: PChar); override;
351 procedure Disconnect; virtual;
352 function ConstraintsStored: Boolean;
353 procedure ClearCalcFields(Buffer: PChar); override;
354 function AllocRecordBuffer: PChar; override;
355 procedure DoBeforeDelete; override;
356 procedure DoBeforeEdit; override;
357 procedure DoBeforeInsert; override;
358 procedure DoAfterInsert; override;
359 procedure DoBeforePost; override;
360 procedure FreeRecordBuffer(var Buffer: PChar); override;
361 procedure GetBookmarkData(Buffer: PChar; Data: Pointer); override;
362 function GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; override;
363 function GetCanModify: Boolean; override;
364 function GetDataSource: TDataSource; override;
365 function GetFieldClass(FieldType: TFieldType): TFieldClass; override;
366 function GetRecNo: Integer; override;
367 function GetRecord(Buffer: PChar; GetMode: TGetMode;
368 DoCheck: Boolean): TGetResult; override;
369 function GetRecordCount: Integer; override;
370 function GetRecordSize: Word; override;
371 procedure InternalAddRecord(Buffer: Pointer; Append: Boolean); override;
372 procedure InternalCancel; override;
373 procedure InternalClose; override;
374 procedure InternalDelete; override;
375 procedure InternalFirst; override;
376 function InternalGetFieldData(Field: TField; Buffer: Pointer): Boolean; virtual;
377 procedure InternalGotoBookmark(Bookmark: Pointer); override;
378 procedure InternalHandleException; override;
379 procedure InternalInitFieldDefs; override;
380 procedure InternalInitRecord(Buffer: PChar); override;
381 procedure InternalLast; override;
382 procedure InternalOpen; override;
383 procedure InternalPost; override;
384 procedure InternalRefresh; override;
385 procedure InternalSetFieldData(Field: TField; Buffer: Pointer); virtual;
386 procedure InternalSetToRecord(Buffer: PChar); override;
387 function IsCursorOpen: Boolean; override;
388 procedure ReQuery;
389 procedure SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); override;
390 procedure SetBookmarkData(Buffer: PChar; Data: Pointer); override;
391 procedure SetCachedUpdates(Value: Boolean);
392 procedure SetDataSource(Value: TDataSource);
393 procedure SetFieldData(Field : TField; Buffer : Pointer); override;
394 procedure SetFieldData(Field : TField; Buffer : Pointer;
395 NativeFormat : Boolean); overload; override;
396 procedure SetRecNo(Value: Integer); override;
397
398 protected
399 {Likely to be made public by descendant classes}
400 property SQLParams: TIBXSQLDA read GetSQLParams;
401 property Params: TIBXSQLDA read GetSQLParams;
402 property InternalPrepared: Boolean read FInternalPrepared;
403 property QDelete: TIBSQL read FQDelete;
404 property QInsert: TIBSQL read FQInsert;
405 property QRefresh: TIBSQL read FQRefresh;
406 property QSelect: TIBSQL read FQSelect;
407 property QModify: TIBSQL read FQModify;
408 property StatementType: TIBSQLTypes read GetStatementType;
409 property SelectStmtHandle: TISC_STMT_HANDLE read GetSelectStmtHandle;
410
411 {Likely to be made published by descendant classes}
412 property BufferChunks: Integer read FBufferChunks write SetBufferChunks;
413 property CachedUpdates: Boolean read FCachedUpdates write SetCachedUpdates;
414 property UniDirectional: Boolean read FUniDirectional write SetUniDirectional default False;
415 property GeneratorField: TIBGenerator read FGeneratorField write FGeneratorField;
416 property DeleteSQL: TStrings read GetDeleteSQL write SetDeleteSQL;
417 property InsertSQL: TStrings read GetInsertSQL write SetInsertSQL;
418 property RefreshSQL: TStrings read GetRefreshSQL write SetRefreshSQL;
419 property SelectSQL: TStrings read GetSelectSQL write SetSelectSQL;
420 property ModifySQL: TStrings read GetModifySQL write SetModifySQL;
421 property UpdateMode: TUpdateMode read FUpdateMode write SetUpdateMode default upWhereAll;
422 property ParamCheck: Boolean read FParamCheck write FParamCheck default True;
423
424 property BeforeDatabaseDisconnect: TNotifyEvent read FBeforeDatabaseDisconnect
425 write FBeforeDatabaseDisconnect;
426 property AfterDatabaseDisconnect: TNotifyEvent read FAfterDatabaseDisconnect
427 write FAfterDatabaseDisconnect;
428 property DatabaseFree: TNotifyEvent read FDatabaseFree
429 write FDatabaseFree;
430 property BeforeTransactionEnd: TNotifyEvent read FBeforeTransactionEnd
431 write FBeforeTransactionEnd;
432 property AfterTransactionEnd: TNotifyEvent read FAfterTransactionEnd
433 write FAfterTransactionEnd;
434 property TransactionFree: TNotifyEvent read FTransactionFree
435 write FTransactionFree;
436
437 public
438 constructor Create(AOwner: TComponent); override;
439 destructor Destroy; override;
440 procedure ApplyUpdates;
441 function CachedUpdateStatus: TCachedUpdateStatus;
442 procedure CancelUpdates;
443 procedure FetchAll;
444 function LocateNext(const KeyFields: string; const KeyValues: Variant;
445 Options: TLocateOptions): Boolean;
446 procedure RecordModified(Value: Boolean);
447 procedure RevertRecord;
448 procedure Undelete;
449
450 { TDataSet support methods }
451 function BookmarkValid(Bookmark: TBookmark): Boolean; override;
452 function CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Integer; override;
453 function CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; override;
454 function GetCurrentRecord(Buffer: PChar): Boolean; override;
455 function GetFieldData(Field : TField; Buffer : Pointer) : Boolean; overload; override;
456 function GetFieldData(FieldNo: Integer; Buffer: Pointer): Boolean; overload; (*override;*)
457 function GetFieldData(Field : TField; Buffer : Pointer;
458 NativeFormat : Boolean) : Boolean; overload; override;
459 function Locate(const KeyFields: string; const KeyValues: Variant;
460 Options: TLocateOptions): Boolean; override;
461 function Lookup(const KeyFields: string; const KeyValues: Variant;
462 const ResultFields: string): Variant; override;
463 function UpdateStatus: TUpdateStatus; override;
464 function IsSequenced: Boolean; override;
465 function ParamByName(ParamName: String): TIBXSQLVAR;
466 property DBHandle: PISC_DB_HANDLE read GetDBHandle;
467 property TRHandle: PISC_TR_HANDLE read GetTRHandle;
468 property UpdateObject: TIBDataSetUpdateObject read FUpdateObject write SetUpdateObject;
469 property UpdatesPending: Boolean read FUpdatesPending;
470 property UpdateRecordTypes: TIBUpdateRecordTypes read FUpdateRecordTypes
471 write SetUpdateRecordTypes;
472
473 published
474 property Database: TIBDatabase read GetDatabase write SetDatabase;
475 property Transaction: TIBTransaction read GetTransaction
476 write SetTransaction;
477 property ForcedRefresh: Boolean read FForcedRefresh
478 write FForcedRefresh default False;
479 property AutoCalcFields;
480
481 property AfterCancel;
482 property AfterClose;
483 property AfterDelete;
484 property AfterEdit;
485 property AfterInsert;
486 property AfterOpen;
487 property AfterPost;
488 property AfterRefresh;
489 property AfterScroll;
490 property BeforeCancel;
491 property BeforeClose;
492 property BeforeDelete;
493 property BeforeEdit;
494 property BeforeInsert;
495 property BeforeOpen;
496 property BeforePost;
497 property BeforeRefresh;
498 property BeforeScroll;
499 property OnCalcFields;
500 property OnDeleteError;
501 property OnEditError;
502 property OnNewRecord;
503 property OnPostError;
504 property OnUpdateError: TIBUpdateErrorEvent read FOnUpdateError
505 write FOnUpdateError;
506 property OnUpdateRecord: TIBUpdateRecordEvent read FOnUpdateRecord
507 write FOnUpdateRecord;
508 end;
509
510 TIBDataSet = class(TIBCustomDataSet)
511 private
512 function GetPrepared: Boolean;
513
514 protected
515 procedure SetFiltered(Value: Boolean); override;
516 procedure InternalOpen; override;
517
518 public
519 procedure Prepare;
520 procedure UnPrepare;
521 procedure BatchInput(InputObject: TIBBatchInput);
522 procedure BatchOutput(OutputObject: TIBBatchOutput);
523 procedure ExecSQL;
524
525 public
526 property Params;
527 property Prepared : Boolean read GetPrepared;
528 property QDelete;
529 property QInsert;
530 property QRefresh;
531 property QSelect;
532 property QModify;
533 property StatementType;
534 property SelectStmtHandle;
535
536 published
537 { TIBCustomDataSet }
538 property BufferChunks;
539 property CachedUpdates;
540 property DeleteSQL;
541 property InsertSQL;
542 property RefreshSQL;
543 property SelectSQL;
544 property ModifySQL;
545 property GeneratorField;
546 property ParamCheck;
547 property UniDirectional;
548 property Filtered;
549
550 property BeforeDatabaseDisconnect;
551 property AfterDatabaseDisconnect;
552 property DatabaseFree;
553 property BeforeTransactionEnd;
554 property AfterTransactionEnd;
555 property TransactionFree;
556
557 { TIBDataSet }
558 property Active;
559 property AutoCalcFields;
560 property DataSource read GetDataSource write SetDataSource;
561
562 property AfterCancel;
563 property AfterClose;
564 property AfterDelete;
565 property AfterEdit;
566 property AfterInsert;
567 property AfterOpen;
568 property AfterPost;
569 property AfterScroll;
570 property BeforeCancel;
571 property BeforeClose;
572 property BeforeDelete;
573 property BeforeEdit;
574 property BeforeInsert;
575 property BeforeOpen;
576 property BeforePost;
577 property BeforeScroll;
578 property OnCalcFields;
579 property OnDeleteError;
580 property OnEditError;
581 property OnFilterRecord;
582 property OnNewRecord;
583 property OnPostError;
584 end;
585
586 { TIBDSBlobStream }
587 TIBDSBlobStream = class(TStream)
588 protected
589 FField: TField;
590 FBlobStream: TIBBlobStream;
591 public
592 constructor Create(AField: TField; ABlobStream: TIBBlobStream;
593 Mode: TBlobStreamMode);
594 function Read(var Buffer; Count: Longint): Longint; override;
595 function Seek(Offset: Longint; Origin: Word): Longint; override;
596 procedure SetSize(NewSize: Longint); override;
597 function Write(const Buffer; Count: Longint): Longint; override;
598 end;
599
600 const
601 DefaultFieldClasses: array[TFieldType] of TFieldClass = (
602 nil, { ftUnknown }
603 TIBStringField, { ftString }
604 TSmallintField, { ftSmallint }
605 TIntegerField, { ftInteger }
606 TWordField, { ftWord }
607 TBooleanField, { ftBoolean }
608 TFloatField, { ftFloat }
609 TCurrencyField, { ftCurrency }
610 TIBBCDField, { ftBCD }
611 TDateField, { ftDate }
612 TTimeField, { ftTime }
613 TDateTimeField, { ftDateTime }
614 TBytesField, { ftBytes }
615 TVarBytesField, { ftVarBytes }
616 TAutoIncField, { ftAutoInc }
617 TBlobField, { ftBlob }
618 TMemoField, { ftMemo }
619 TGraphicField, { ftGraphic }
620 TBlobField, { ftFmtMemo }
621 TBlobField, { ftParadoxOle }
622 TBlobField, { ftDBaseOle }
623 TBlobField, { ftTypedBinary }
624 nil, { ftCursor }
625 TStringField, { ftFixedChar }
626 TWideStringField, { ftWideString }
627 TLargeIntField, { ftLargeInt }
628 nil, { ftADT }
629 nil, { ftArray }
630 nil, { ftReference }
631 nil, { ftDataSet }
632 TBlobField, { ftOraBlob }
633 TMemoField, { ftOraClob }
634 TVariantField, { ftVariant }
635 nil, { ftInterface }
636 nil, { ftIDispatch }
637 TGuidField, { ftGuid }
638 TDateTimeField, {ftTimestamp}
639 TIBBCDField, {ftFMTBcd}
640 nil, {ftFixedWideChar}
641 TWideMemoField); {ftWideMemo}
642 (*
643 TADTField, { ftADT }
644 TArrayField, { ftArray }
645 TReferenceField, { ftReference }
646 TDataSetField, { ftDataSet }
647 TBlobField, { ftOraBlob }
648 TMemoField, { ftOraClob }
649 TVariantField, { ftVariant }
650 TInterfaceField, { ftInterface }
651 TIDispatchField, { ftIDispatch }
652 TGuidField); { ftGuid } *)
653 (*var
654 CreateProviderProc: function(DataSet: TIBCustomDataSet): IProvider = nil;*)
655
656 implementation
657
658 uses IBIntf, Variants, FmtBCD;
659
660 const FILE_BEGIN = 0;
661 FILE_CURRENT = 1;
662 FILE_END = 2;
663
664 type
665
666 TFieldNode = class(TObject)
667 protected
668 FieldName : String;
669 COMPUTED_BLR : Boolean;
670 DEFAULT_VALUE : boolean;
671 NextField : TFieldNode;
672 end;
673
674 TRelationNode = class(TObject)
675 protected
676 RelationName : String;
677 FieldNodes : TFieldNode;
678 NextRelation : TRelationNode;
679 end;
680
681
682 { TIBStringField}
683
684 constructor TIBStringField.Create(AOwner: TComponent);
685 begin
686 inherited Create(AOwner);
687 end;
688
689 class procedure TIBStringField.CheckTypeSize(Value: Integer);
690 begin
691 { don't check string size. all sizes valid }
692 end;
693
694 function TIBStringField.GetAsString: string;
695 begin
696 if not GetValue(Result) then Result := '';
697 end;
698
699 function TIBStringField.GetAsVariant: Variant;
700 var
701 S: string;
702 begin
703 if GetValue(S) then Result := S else Result := Null;
704 end;
705
706 function TIBStringField.GetValue(var Value: string): Boolean;
707 var
708 Buffer: PChar;
709 begin
710 Buffer := nil;
711 IBAlloc(Buffer, 0, Size + 1);
712 try
713 Result := GetData(Buffer);
714 if Result then
715 begin
716 Value := string(Buffer);
717 if Transliterate and (Value <> '') then
718 DataSet.Translate(PChar(Value), PChar(Value), False);
719 end
720 finally
721 FreeMem(Buffer);
722 end;
723 end;
724
725 procedure TIBStringField.SetAsString(const Value: string);
726 var
727 Buffer: PChar;
728 begin
729 Buffer := nil;
730 IBAlloc(Buffer, 0, Size + 1);
731 try
732 StrLCopy(Buffer, PChar(Value), Size);
733 if Transliterate then
734 DataSet.Translate(Buffer, Buffer, True);
735 SetData(Buffer);
736 finally
737 FreeMem(Buffer);
738 end;
739 end;
740
741 { TIBBCDField }
742
743 constructor TIBBCDField.Create(AOwner: TComponent);
744 begin
745 inherited Create(AOwner);
746 SetDataType(ftBCD);
747 Size := 8;
748 end;
749
750 class procedure TIBBCDField.CheckTypeSize(Value: Integer);
751 begin
752 { No need to check as the base type is currency, not BCD }
753 end;
754
755 function TIBBCDField.GetAsCurrency: Currency;
756 begin
757 if not GetValue(Result) then
758 Result := 0;
759 end;
760
761 function TIBBCDField.GetAsString: string;
762 var
763 C: System.Currency;
764 begin
765 if GetValue(C) then
766 Result := CurrToStr(C)
767 else
768 Result := '';
769 end;
770
771 function TIBBCDField.GetAsVariant: Variant;
772 var
773 C: System.Currency;
774 begin
775 if GetValue(C) then
776 Result := C
777 else
778 Result := Null;
779 end;
780
781 function TIBBCDField.GetDataSize: Integer;
782 begin
783 {$IFDEF TBCDFIELD_IS_BCD}
784 Result := 8;
785 {$ELSE}
786 Result := inherited GetDataSize
787 {$ENDIF}
788 end;
789
790 { TIBDataLink }
791
792 constructor TIBDataLink.Create(ADataSet: TIBCustomDataSet);
793 begin
794 inherited Create;
795 FDataSet := ADataSet;
796 end;
797
798 destructor TIBDataLink.Destroy;
799 begin
800 FDataSet.FDataLink := nil;
801 inherited Destroy;
802 end;
803
804
805 procedure TIBDataLink.ActiveChanged;
806 begin
807 if FDataSet.Active then
808 FDataSet.RefreshParams;
809 end;
810
811
812 function TIBDataLink.GetDetailDataSet: TDataSet;
813 begin
814 Result := FDataSet;
815 end;
816
817 procedure TIBDataLink.RecordChanged(Field: TField);
818 begin
819 if (Field = nil) and FDataSet.Active then
820 FDataSet.RefreshParams;
821 end;
822
823 procedure TIBDataLink.CheckBrowseMode;
824 begin
825 if FDataSet.Active then
826 FDataSet.CheckBrowseMode;
827 end;
828
829 { TIBCustomDataSet }
830
831 constructor TIBCustomDataSet.Create(AOwner: TComponent);
832 begin
833 inherited Create(AOwner);
834 FIBLoaded := False;
835 CheckIBLoaded;
836 FIBLoaded := True;
837 FBase := TIBBase.Create(Self);
838 FCurrentRecord := -1;
839 FDeletedRecords := 0;
840 FUniDirectional := False;
841 FBufferChunks := BufferCacheSize;
842 FBlobStreamList := TList.Create;
843 FGeneratorField := TIBGenerator.Create(self);
844 FDataLink := TIBDataLink.Create(Self);
845 FQDelete := TIBSQL.Create(Self);
846 FQDelete.OnSQLChanging := SQLChanging;
847 FQDelete.GoToFirstRecordOnExecute := False;
848 FQInsert := TIBSQL.Create(Self);
849 FQInsert.OnSQLChanging := SQLChanging;
850 FQInsert.GoToFirstRecordOnExecute := False;
851 FQRefresh := TIBSQL.Create(Self);
852 FQRefresh.OnSQLChanging := SQLChanging;
853 FQRefresh.GoToFirstRecordOnExecute := False;
854 FQSelect := TIBSQL.Create(Self);
855 FQSelect.OnSQLChanging := SQLChanging;
856 FQSelect.GoToFirstRecordOnExecute := False;
857 FQModify := TIBSQL.Create(Self);
858 FQModify.OnSQLChanging := SQLChanging;
859 FQModify.GoToFirstRecordOnExecute := False;
860 FUpdateRecordTypes := [cusUnmodified, cusModified, cusInserted];
861 FParamCheck := True;
862 FForcedRefresh := False;
863 {Bookmark Size is Integer for IBX}
864 BookmarkSize := SizeOf(Integer);
865 FBase.BeforeDatabaseDisconnect := DoBeforeDatabaseDisconnect;
866 FBase.AfterDatabaseDisconnect := DoAfterDatabaseDisconnect;
867 FBase.OnDatabaseFree := DoDatabaseFree;
868 FBase.BeforeTransactionEnd := DoBeforeTransactionEnd;
869 FBase.AfterTransactionEnd := DoAfterTransactionEnd;
870 FBase.OnTransactionFree := DoTransactionFree;
871 if AOwner is TIBDatabase then
872 Database := TIBDatabase(AOwner)
873 else
874 if AOwner is TIBTransaction then
875 Transaction := TIBTransaction(AOwner);
876 end;
877
878 destructor TIBCustomDataSet.Destroy;
879 begin
880 if Active then Active := false;
881 if FIBLoaded then
882 begin
883 if assigned(FGeneratorField) then FGeneratorField.Free;
884 FDataLink.Free;
885 FBase.Free;
886 ClearBlobCache;
887 FBlobStreamList.Free;
888 FreeMem(FBufferCache);
889 FBufferCache := nil;
890 FreeMem(FOldBufferCache);
891 FOldBufferCache := nil;
892 FCacheSize := 0;
893 FOldCacheSize := 0;
894 FMappedFieldPosition := nil;
895 end;
896 inherited Destroy;
897 end;
898
899 function TIBCustomDataSet.AdjustCurrentRecord(Buffer: Pointer; GetMode: TGetMode):
900 TGetResult;
901 begin
902 while not IsVisible(Buffer) do
903 begin
904 if GetMode = gmPrior then
905 begin
906 Dec(FCurrentRecord);
907 if FCurrentRecord = -1 then
908 begin
909 result := grBOF;
910 exit;
911 end;
912 ReadRecordCache(FCurrentRecord, Buffer, False);
913 end
914 else begin
915 Inc(FCurrentRecord);
916 if (FCurrentRecord = FRecordCount) then
917 begin
918 if (not FQSelect.EOF) and (FQSelect.Next <> nil) then
919 begin
920 FetchCurrentRecordToBuffer(FQSelect, FCurrentRecord, Buffer);
921 Inc(FRecordCount);
922 end
923 else begin
924 result := grEOF;
925 exit;
926 end;
927 end
928 else
929 ReadRecordCache(FCurrentRecord, Buffer, False);
930 end;
931 end;
932 result := grOK;
933 end;
934
935 procedure TIBCustomDataSet.ApplyUpdates;
936 var
937 {$IF FPC_FULLVERSION > 20600 }
938 CurBookmark: TBookmark;
939 {$ELSE}
940 CurBookmark: string;
941 {$ENDIF}
942 Buffer: PRecordData;
943 CurUpdateTypes: TIBUpdateRecordTypes;
944 UpdateAction: TIBUpdateAction;
945 UpdateKind: TUpdateKind;
946 bRecordsSkipped: Boolean;
947
948 procedure GetUpdateKind;
949 begin
950 case Buffer^.rdCachedUpdateStatus of
951 cusModified:
952 UpdateKind := ukModify;
953 cusInserted:
954 UpdateKind := ukInsert;
955 else
956 UpdateKind := ukDelete;
957 end;
958 end;
959
960 procedure ResetBufferUpdateStatus;
961 begin
962 case Buffer^.rdCachedUpdateStatus of
963 cusModified:
964 begin
965 PRecordData(Buffer)^.rdUpdateStatus := usUnmodified;
966 PRecordData(Buffer)^.rdCachedUpdateStatus := cusUnmodified;
967 end;
968 cusInserted:
969 begin
970 PRecordData(Buffer)^.rdUpdateStatus := usUnmodified;
971 PRecordData(Buffer)^.rdCachedUpdateStatus := cusUnmodified;
972 end;
973 cusDeleted:
974 begin
975 PRecordData(Buffer)^.rdUpdateStatus := usDeleted;
976 PRecordData(Buffer)^.rdCachedUpdateStatus := cusUnmodified;
977 end;
978 end;
979 WriteRecordCache(PRecordData(Buffer)^.rdRecordNumber, Pointer(Buffer));
980 end;
981
982 procedure UpdateUsingOnUpdateRecord;
983 begin
984 UpdateAction := uaFail;
985 try
986 FOnUpdateRecord(Self, UpdateKind, UpdateAction);
987 except
988 on E: Exception do
989 begin
990 if (E is EDatabaseError) and Assigned(FOnUpdateError) then
991 FOnUpdateError(Self, EIBError(E), UpdateKind, UpdateAction);
992 if UpdateAction = uaFail then
993 raise;
994 end;
995 end;
996 end;
997
998 procedure UpdateUsingUpdateObject;
999 begin
1000 try
1001 FUpdateObject.Apply(UpdateKind,PChar(Buffer));
1002 ResetBufferUpdateStatus;
1003 except
1004 on E: Exception do
1005 if (E is EDatabaseError) and Assigned(FOnUpdateError) then
1006 FOnUpdateError(Self, EIBError(E), UpdateKind, UpdateAction);
1007 end;
1008 end;
1009
1010 procedure UpdateUsingInternalquery;
1011 begin
1012 try
1013 case Buffer^.rdCachedUpdateStatus of
1014 cusModified:
1015 InternalPostRecord(FQModify, Buffer);
1016 cusInserted:
1017 InternalPostRecord(FQInsert, Buffer);
1018 cusDeleted:
1019 InternalDeleteRecord(FQDelete, Buffer);
1020 end;
1021 except
1022 on E: EIBError do begin
1023 UpdateAction := uaFail;
1024 if Assigned(FOnUpdateError) then
1025 FOnUpdateError(Self, E, UpdateKind, UpdateAction);
1026 case UpdateAction of
1027 uaFail: raise;
1028 uaAbort: SysUtils.Abort;
1029 uaSkip: bRecordsSkipped := True;
1030 end;
1031 end;
1032 end;
1033 end;
1034
1035 begin
1036 if State in [dsEdit, dsInsert] then
1037 Post;
1038 FBase.CheckDatabase;
1039 FBase.CheckTransaction;
1040 DisableControls;
1041 CurBookmark := Bookmark;
1042 CurUpdateTypes := FUpdateRecordTypes;
1043 FUpdateRecordTypes := [cusModified, cusInserted, cusDeleted];
1044 try
1045 First;
1046 bRecordsSkipped := False;
1047 while not EOF do
1048 begin
1049 Buffer := PRecordData(GetActiveBuf);
1050 GetUpdateKind;
1051 UpdateAction := uaApply;
1052 if Assigned(FUpdateObject) or Assigned(FOnUpdateRecord) then
1053 begin
1054 if (Assigned(FOnUpdateRecord)) then
1055 UpdateUsingOnUpdateRecord
1056 else
1057 if Assigned(FUpdateObject) then
1058 UpdateUsingUpdateObject;
1059 case UpdateAction of
1060 uaFail:
1061 IBError(ibxeUserAbort, [nil]);
1062 uaAbort:
1063 SysUtils.Abort;
1064 uaApplied:
1065 ResetBufferUpdateStatus;
1066 uaSkip:
1067 bRecordsSkipped := True;
1068 uaRetry:
1069 Continue;
1070 end;
1071 end;
1072 if (not Assigned(FUpdateObject)) and (UpdateAction = UaApply) then
1073 begin
1074 UpdateUsingInternalquery;
1075 UpdateAction := uaApplied;
1076 end;
1077 Next;
1078 end;
1079 FUpdatesPending := bRecordsSkipped;
1080 finally
1081 FUpdateRecordTypes := CurUpdateTypes;
1082 Bookmark := CurBookmark;
1083 EnableControls;
1084 end;
1085 end;
1086
1087 procedure TIBCustomDataSet.InternalBatchInput(InputObject: TIBBatchInput);
1088 begin
1089 FQSelect.BatchInput(InputObject);
1090 end;
1091
1092 procedure TIBCustomDataSet.InternalBatchOutput(OutputObject: TIBBatchOutput);
1093 var
1094 Qry: TIBSQL;
1095 begin
1096 Qry := TIBSQL.Create(Self);
1097 try
1098 Qry.Database := FBase.Database;
1099 Qry.Transaction := FBase.Transaction;
1100 Qry.SQL.Assign(FQSelect.SQL);
1101 Qry.BatchOutput(OutputObject);
1102 finally
1103 Qry.Free;
1104 end;
1105 end;
1106
1107 procedure TIBCustomDataSet.CancelUpdates;
1108 var
1109 CurUpdateTypes: TIBUpdateRecordTypes;
1110 begin
1111 if State in [dsEdit, dsInsert] then
1112 Post;
1113 if FCachedUpdates and FUpdatesPending then
1114 begin
1115 DisableControls;
1116 CurUpdateTypes := UpdateRecordTypes;
1117 UpdateRecordTypes := [cusModified, cusInserted, cusDeleted];
1118 try
1119 First;
1120 while not EOF do
1121 begin
1122 if UpdateStatus = usInserted then
1123 RevertRecord
1124 else
1125 begin
1126 RevertRecord;
1127 Next;
1128 end;
1129 end;
1130 finally
1131 UpdateRecordTypes := CurUpdateTypes;
1132 First;
1133 FUpdatesPending := False;
1134 EnableControls;
1135 end;
1136 end;
1137 end;
1138
1139 procedure TIBCustomDataSet.ActivateConnection;
1140 begin
1141 if not Assigned(Database) then
1142 IBError(ibxeDatabaseNotAssigned, [nil]);
1143 if not Assigned(Transaction) then
1144 IBError(ibxeTransactionNotAssigned, [nil]);
1145 if not Database.Connected then Database.Open;
1146 end;
1147
1148 function TIBCustomDataSet.ActivateTransaction: Boolean;
1149 begin
1150 Result := False;
1151 if not Assigned(Transaction) then
1152 IBError(ibxeTransactionNotAssigned, [nil]);
1153 if not Transaction.Active then
1154 begin
1155 Result := True;
1156 Transaction.StartTransaction;
1157 FDidActivate := True;
1158 end;
1159 end;
1160
1161 procedure TIBCustomDataSet.DeactivateTransaction;
1162 var
1163 i: Integer;
1164 begin
1165 if not Assigned(Transaction) then
1166 IBError(ibxeTransactionNotAssigned, [nil]);
1167 with Transaction do
1168 begin
1169 for i := 0 to SQLObjectCount - 1 do
1170 begin
1171 if (SQLObjects[i] <> nil) and ((SQLObjects[i]).owner is TDataSet) then
1172 begin
1173 if TDataSet(SQLObjects[i].owner).Active then
1174 begin
1175 FDidActivate := False;
1176 exit;
1177 end;
1178 end;
1179 end;
1180 end;
1181 FInternalPrepared := False;
1182 if Transaction.InTransaction then
1183 Transaction.Commit;
1184 FDidActivate := False;
1185 end;
1186
1187 procedure TIBCustomDataSet.CheckDatasetClosed;
1188 begin
1189 if FOpen then
1190 IBError(ibxeDatasetOpen, [nil]);
1191 end;
1192
1193 procedure TIBCustomDataSet.CheckDatasetOpen;
1194 begin
1195 if not FOpen then
1196 IBError(ibxeDatasetClosed, [nil]);
1197 end;
1198
1199 procedure TIBCustomDataSet.CheckNotUniDirectional;
1200 begin
1201 if UniDirectional then
1202 IBError(ibxeDataSetUniDirectional, [nil]);
1203 end;
1204
1205 procedure TIBCustomDataSet.AdjustRecordOnInsert(Buffer: Pointer);
1206 begin
1207 with PRecordData(Buffer)^ do
1208 if (State = dsInsert) and (not Modified) then
1209 begin
1210 rdRecordNumber := FRecordCount;
1211 FCurrentRecord := FRecordCount;
1212 end;
1213 end;
1214
1215 function TIBCustomDataSet.CanEdit: Boolean;
1216 var
1217 Buff: PRecordData;
1218 begin
1219 Buff := PRecordData(GetActiveBuf);
1220 result := (FQModify.SQL.Text <> '') or
1221 (Assigned(FUpdateObject) and (FUpdateObject.GetSQL(ukModify).Text <> '')) or
1222 ((Buff <> nil) and (Buff^.rdCachedUpdateStatus = cusInserted) and
1223 (FCachedUpdates));
1224 end;
1225
1226 function TIBCustomDataSet.CanInsert: Boolean;
1227 begin
1228 result := (FQInsert.SQL.Text <> '') or
1229 (Assigned(FUpdateObject) and (FUpdateObject.GetSQL(ukInsert).Text <> ''));
1230 end;
1231
1232 function TIBCustomDataSet.CanDelete: Boolean;
1233 begin
1234 if (FQDelete.SQL.Text <> '') or
1235 (Assigned(FUpdateObject) and (FUpdateObject.GetSQL(ukDelete).Text <> '')) then
1236 result := True
1237 else
1238 result := False;
1239 end;
1240
1241 function TIBCustomDataSet.CanRefresh: Boolean;
1242 begin
1243 result := (FQRefresh.SQL.Text <> '') or
1244 (Assigned(FUpdateObject) and (FUpdateObject.RefreshSQL.Text <> ''));
1245 end;
1246
1247 procedure TIBCustomDataSet.CheckEditState;
1248 begin
1249 case State of
1250 { Check all the wsEditMode types }
1251 dsEdit, dsInsert, dsSetKey, dsCalcFields, dsFilter,
1252 dsNewValue, dsInternalCalc :
1253 begin
1254 if (State in [dsEdit]) and (not CanEdit) then
1255 IBError(ibxeCannotUpdate, [nil]);
1256 if (State in [dsInsert]) and (not CanInsert) then
1257 IBError(ibxeCannotInsert, [nil]);
1258 end;
1259 else
1260 IBError(ibxeNotEditing, [])
1261 end;
1262 end;
1263
1264 procedure TIBCustomDataSet.ClearBlobCache;
1265 var
1266 i: Integer;
1267 begin
1268 for i := 0 to FBlobStreamList.Count - 1 do
1269 begin
1270 TIBBlobStream(FBlobStreamList[i]).Free;
1271 FBlobStreamList[i] := nil;
1272 end;
1273 FBlobStreamList.Pack;
1274 end;
1275
1276 procedure TIBCustomDataSet.CopyRecordBuffer(Source, Dest: Pointer);
1277 begin
1278 Move(Source^, Dest^, FRecordBufferSize);
1279 end;
1280
1281 procedure TIBCustomDataSet.DoBeforeDatabaseDisconnect(Sender: TObject);
1282 begin
1283 if Active then
1284 Active := False;
1285 FInternalPrepared := False;
1286 if Assigned(FBeforeDatabaseDisconnect) then
1287 FBeforeDatabaseDisconnect(Sender);
1288 end;
1289
1290 procedure TIBCustomDataSet.DoAfterDatabaseDisconnect(Sender: TObject);
1291 begin
1292 if Assigned(FAfterDatabaseDisconnect) then
1293 FAfterDatabaseDisconnect(Sender);
1294 end;
1295
1296 procedure TIBCustomDataSet.DoDatabaseFree(Sender: TObject);
1297 begin
1298 if Assigned(FDatabaseFree) then
1299 FDatabaseFree(Sender);
1300 end;
1301
1302 procedure TIBCustomDataSet.DoBeforeTransactionEnd(Sender: TObject);
1303 begin
1304 if Active then
1305 Active := False;
1306 if FQSelect <> nil then
1307 FQSelect.FreeHandle;
1308 if FQDelete <> nil then
1309 FQDelete.FreeHandle;
1310 if FQInsert <> nil then
1311 FQInsert.FreeHandle;
1312 if FQModify <> nil then
1313 FQModify.FreeHandle;
1314 if FQRefresh <> nil then
1315 FQRefresh.FreeHandle;
1316 if Assigned(FBeforeTransactionEnd) then
1317 FBeforeTransactionEnd(Sender);
1318 end;
1319
1320 procedure TIBCustomDataSet.DoAfterTransactionEnd(Sender: TObject);
1321 begin
1322 if Assigned(FAfterTransactionEnd) then
1323 FAfterTransactionEnd(Sender);
1324 end;
1325
1326 procedure TIBCustomDataSet.DoTransactionFree(Sender: TObject);
1327 begin
1328 if Assigned(FTransactionFree) then
1329 FTransactionFree(Sender);
1330 end;
1331
1332 { Read the record from FQSelect.Current into the record buffer
1333 Then write the buffer to in memory cache }
1334 procedure TIBCustomDataSet.FetchCurrentRecordToBuffer(Qry: TIBSQL;
1335 RecordNumber: Integer; Buffer: PChar);
1336 var
1337 p: PRecordData;
1338 pbd: PBlobDataArray;
1339 i, j: Integer;
1340 LocalData: Pointer;
1341 LocalDate, LocalDouble: Double;
1342 LocalInt: Integer;
1343 LocalInt64: Int64;
1344 LocalCurrency: Currency;
1345 FieldsLoaded: Integer;
1346 temp: TIBXSQLVAR;
1347 begin
1348 p := PRecordData(Buffer);
1349 { Make sure blob cache is empty }
1350 pbd := PBlobDataArray(Buffer + FBlobCacheOffset);
1351 if RecordNumber > -1 then
1352 for i := 0 to BlobFieldCount - 1 do
1353 pbd^[i] := nil;
1354 { Get record information }
1355 p^.rdBookmarkFlag := bfCurrent;
1356 p^.rdFieldCount := Qry.Current.Count;
1357 p^.rdRecordNumber := RecordNumber;
1358 p^.rdUpdateStatus := usUnmodified;
1359 p^.rdCachedUpdateStatus := cusUnmodified;
1360 p^.rdSavedOffset := $FFFFFFFF;
1361
1362 { Load up the fields }
1363 FieldsLoaded := FQSelect.Current.Count;
1364 j := 1;
1365 for i := 0 to Qry.Current.Count - 1 do
1366 begin
1367 if (Qry = FQSelect) then
1368 j := i + 1
1369 else begin
1370 if FieldsLoaded = 0 then
1371 break;
1372 j := FQSelect.FieldIndex[Qry.Current[i].Name] + 1;
1373 if j < 1 then
1374 continue
1375 else
1376 Dec(FieldsLoaded);
1377 end;
1378 with FQSelect.Current[j - 1].Data^ do
1379 if aliasname = 'IBX_INTERNAL_DBKEY' then {do not localize}
1380 begin
1381 if sqllen <= 8 then
1382 p^.rdDBKey := PIBDBKEY(Qry.Current[i].AsPointer)^;
1383 continue;
1384 end;
1385 if j > 0 then with p^ do
1386 begin
1387 rdFields[j].fdDataType :=
1388 Qry.Current[i].Data^.sqltype and (not 1);
1389 rdFields[j].fdDataScale :=
1390 Qry.Current[i].Data^.sqlscale;
1391 rdFields[j].fdNullable :=
1392 (Qry.Current[i].Data^.sqltype and 1 = 1);
1393 rdFields[j].fdIsNull :=
1394 (rdFields[j].fdNullable and (Qry.Current[i].Data^.sqlind^ = -1));
1395 LocalData := Qry.Current[i].Data^.sqldata;
1396 case rdFields[j].fdDataType of
1397 SQL_TIMESTAMP:
1398 begin
1399 rdFields[j].fdDataSize := SizeOf(TDateTime);
1400 if RecordNumber >= 0 then
1401 LocalDate := TimeStampToMSecs(DateTimeToTimeStamp(Qry.Current[i].AsDateTime));
1402 LocalData := PChar(@LocalDate);
1403 end;
1404 SQL_TYPE_DATE:
1405 begin
1406 rdFields[j].fdDataSize := SizeOf(TDateTime);
1407 if RecordNumber >= 0 then
1408 LocalInt := DateTimeToTimeStamp(Qry.Current[i].AsDateTime).Date;
1409 LocalData := PChar(@LocalInt);
1410 end;
1411 SQL_TYPE_TIME:
1412 begin
1413 rdFields[j].fdDataSize := SizeOf(TDateTime);
1414 if RecordNumber >= 0 then
1415 LocalInt := DateTimeToTimeStamp(Qry.Current[i].AsDateTime).Time;
1416 LocalData := PChar(@LocalInt);
1417 end;
1418 SQL_SHORT, SQL_LONG:
1419 begin
1420 if (rdFields[j].fdDataScale = 0) then
1421 begin
1422 rdFields[j].fdDataSize := SizeOf(Integer);
1423 if RecordNumber >= 0 then
1424 LocalInt := Qry.Current[i].AsLong;
1425 LocalData := PChar(@LocalInt);
1426 end
1427 else if (rdFields[j].fdDataScale >= (-4)) then
1428 begin
1429 rdFields[j].fdDataSize := SizeOf(Currency);
1430 if RecordNumber >= 0 then
1431 LocalCurrency := Qry.Current[i].AsCurrency;
1432 LocalData := PChar(@LocalCurrency);
1433 end
1434 else begin
1435 rdFields[j].fdDataSize := SizeOf(Double);
1436 if RecordNumber >= 0 then
1437 LocalDouble := Qry.Current[i].AsDouble;
1438 LocalData := PChar(@LocalDouble);
1439 end;
1440 end;
1441 SQL_INT64:
1442 begin
1443 if (rdFields[j].fdDataScale = 0) then
1444 begin
1445 rdFields[j].fdDataSize := SizeOf(Int64);
1446 if RecordNumber >= 0 then
1447 LocalInt64 := Qry.Current[i].AsInt64;
1448 LocalData := PChar(@LocalInt64);
1449 end
1450 else if (rdFields[j].fdDataScale >= (-4)) then
1451 begin
1452 rdFields[j].fdDataSize := SizeOf(Currency);
1453 if RecordNumber >= 0 then
1454 LocalCurrency := Qry.Current[i].AsCurrency;
1455 LocalData := PChar(@LocalCurrency);
1456 end
1457 else begin
1458 rdFields[j].fdDataSize := SizeOf(Double);
1459 if RecordNumber >= 0 then
1460 LocalDouble := Qry.Current[i].AsDouble;
1461 LocalData := PChar(@LocalDouble);
1462 end
1463 end;
1464 SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT:
1465 begin
1466 rdFields[j].fdDataSize := SizeOf(Double);
1467 if RecordNumber >= 0 then
1468 LocalDouble := Qry.Current[i].AsDouble;
1469 LocalData := PChar(@LocalDouble);
1470 end;
1471 SQL_VARYING:
1472 begin
1473 rdFields[j].fdDataSize := Qry.Current[i].Data^.sqllen;
1474 rdFields[j].fdDataLength := isc_vax_integer(Qry.Current[i].Data^.sqldata, 2);
1475 if RecordNumber >= 0 then
1476 begin
1477 if (rdFields[j].fdDataLength = 0) then
1478 LocalData := nil
1479 else
1480 begin
1481 temp := Qry.Current[i];
1482 LocalData := @temp.Data^.sqldata[2];
1483 (* LocalData := @Qry.Current[i].Data^.sqldata[2];*)
1484 end;
1485 end;
1486 end;
1487 else { SQL_TEXT, SQL_BLOB, SQL_ARRAY, SQL_QUAD }
1488 begin
1489 rdFields[j].fdDataSize := Qry.Current[i].Data^.sqllen;
1490 if (rdFields[j].fdDataType = SQL_TEXT) then
1491 rdFields[j].fdDataLength := rdFields[j].fdDataSize;
1492 end;
1493 end;
1494 if RecordNumber < 0 then
1495 begin
1496 rdFields[j].fdIsNull := True;
1497 rdFields[j].fdDataOfs := FRecordSize;
1498 Inc(FRecordSize, rdFields[j].fdDataSize);
1499 end
1500 else begin
1501 if rdFields[j].fdDataType = SQL_VARYING then
1502 begin
1503 if LocalData <> nil then
1504 Move(LocalData^, Buffer[rdFields[j].fdDataOfs], rdFields[j].fdDataLength)
1505 end
1506 else
1507 Move(LocalData^, Buffer[rdFields[j].fdDataOfs], rdFields[j].fdDataSize)
1508 end;
1509 end;
1510 end;
1511 WriteRecordCache(RecordNumber, PChar(p));
1512 end;
1513
1514 function TIBCustomDataSet.GetActiveBuf: PChar;
1515 begin
1516 case State of
1517 dsBrowse:
1518 if IsEmpty then
1519 result := nil
1520 else
1521 result := ActiveBuffer;
1522 dsEdit, dsInsert:
1523 result := ActiveBuffer;
1524 dsCalcFields:
1525 result := CalcBuffer;
1526 dsFilter:
1527 result := FFilterBuffer;
1528 dsNewValue:
1529 result := ActiveBuffer;
1530 dsOldValue:
1531 if (PRecordData(ActiveBuffer)^.rdRecordNumber =
1532 PRecordData(FOldBuffer)^.rdRecordNumber) then
1533 result := FOldBuffer
1534 else
1535 result := ActiveBuffer;
1536 else if not FOpen then
1537 result := nil
1538 else
1539 result := ActiveBuffer;
1540 end;
1541 end;
1542
1543 function TIBCustomDataSet.CachedUpdateStatus: TCachedUpdateStatus;
1544 begin
1545 if Active then
1546 result := PRecordData(GetActiveBuf)^.rdCachedUpdateStatus
1547 else
1548 result := cusUnmodified;
1549 end;
1550
1551 function TIBCustomDataSet.GetDatabase: TIBDatabase;
1552 begin
1553 result := FBase.Database;
1554 end;
1555
1556 function TIBCustomDataSet.GetDBHandle: PISC_DB_HANDLE;
1557 begin
1558 result := FBase.DBHandle;
1559 end;
1560
1561 function TIBCustomDataSet.GetDeleteSQL: TStrings;
1562 begin
1563 result := FQDelete.SQL;
1564 end;
1565
1566 function TIBCustomDataSet.GetInsertSQL: TStrings;
1567 begin
1568 result := FQInsert.SQL;
1569 end;
1570
1571 function TIBCustomDataSet.GetSQLParams: TIBXSQLDA;
1572 begin
1573 if not FInternalPrepared then
1574 InternalPrepare;
1575 result := FQSelect.Params;
1576 end;
1577
1578 function TIBCustomDataSet.GetRefreshSQL: TStrings;
1579 begin
1580 result := FQRefresh.SQL;
1581 end;
1582
1583 function TIBCustomDataSet.GetSelectSQL: TStrings;
1584 begin
1585 result := FQSelect.SQL;
1586 end;
1587
1588 function TIBCustomDataSet.GetStatementType: TIBSQLTypes;
1589 begin
1590 result := FQSelect.SQLType;
1591 end;
1592
1593 function TIBCustomDataSet.GetModifySQL: TStrings;
1594 begin
1595 result := FQModify.SQL;
1596 end;
1597
1598 function TIBCustomDataSet.GetTransaction: TIBTransaction;
1599 begin
1600 result := FBase.Transaction;
1601 end;
1602
1603 function TIBCustomDataSet.GetTRHandle: PISC_TR_HANDLE;
1604 begin
1605 result := FBase.TRHandle;
1606 end;
1607
1608 procedure TIBCustomDataSet.InternalDeleteRecord(Qry: TIBSQL; Buff: Pointer);
1609 begin
1610 if (Assigned(FUpdateObject) and (FUpdateObject.GetSQL(ukDelete).Text <> '')) then
1611 FUpdateObject.Apply(ukDelete,Buff)
1612 else
1613 begin
1614 SetInternalSQLParams(FQDelete, Buff);
1615 FQDelete.ExecQuery;
1616 end;
1617 with PRecordData(Buff)^ do
1618 begin
1619 rdUpdateStatus := usDeleted;
1620 rdCachedUpdateStatus := cusUnmodified;
1621 end;
1622 WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Buff);
1623 end;
1624
1625 function TIBCustomDataSet.InternalLocate(const KeyFields: string;
1626 const KeyValues: Variant; Options: TLocateOptions): Boolean;
1627 var
1628 keyFieldList: TList;
1629 {$IF FPC_FULLVERSION > 20600 }
1630 CurBookmark: TBookmark;
1631 {$ELSE}
1632 CurBookmark: string;
1633 {$ENDIF}
1634 fieldValue: Variant;
1635 lookupValues: array of variant;
1636 i, fieldCount: Integer;
1637 fieldValueAsString: string;
1638 lookupValueAsString: string;
1639 begin
1640 keyFieldList := TList.Create;
1641 try
1642 GetFieldList(keyFieldList, KeyFields);
1643 fieldCount := keyFieldList.Count;
1644 CurBookmark := Bookmark;
1645 result := false;
1646 SetLength(lookupValues, fieldCount);
1647 if not EOF then
1648 begin
1649 for i := 0 to fieldCount - 1 do {expand key values into lookupValues array}
1650 begin
1651 if VarIsArray(KeyValues) then
1652 lookupValues[i] := KeyValues[i]
1653 else
1654 if i > 0 then
1655 lookupValues[i] := NULL
1656 else
1657 lookupValues[0] := KeyValues;
1658
1659 {convert to upper case is case insensitive search}
1660 if (TField(keyFieldList[i]).DataType = ftString) and
1661 not VarIsNull(lookupValues[i]) and (loCaseInsensitive in Options) then
1662 lookupValues[i] := UpperCase(lookupValues[i]);
1663 end;
1664 end;
1665 while not result and not EOF do {search for a matching record}
1666 begin
1667 i := 0;
1668 result := true;
1669 while result and (i < fieldCount) do
1670 {see if all of the key fields matches}
1671 begin
1672 fieldValue := TField(keyFieldList[i]).Value;
1673 result := not (VarIsNull(fieldValue) xor VarIsNull(lookupValues[i]));
1674 if result and not VarIsNull(fieldValue) then
1675 begin
1676 try
1677 if TField(keyFieldList[i]).DataType = ftString then
1678 begin
1679 {strings need special handling because of the locate options that
1680 apply to them}
1681 fieldValueAsString := TField(keyFieldList[i]).AsString;
1682 lookupValueAsString := lookupValues[i];
1683 if (loCaseInsensitive in Options) then
1684 fieldValueAsString := UpperCase(fieldValueAsString);
1685
1686 if (loPartialKey in Options) then
1687 result := result and (Pos(lookupValueAsString, fieldValueAsString) = 1)
1688 else
1689 result := result and (fieldValueAsString = lookupValueAsString);
1690 end
1691 else
1692 result := result and (lookupValues[i] =
1693 VarAsType(fieldValue, VarType(lookupValues[i])));
1694 except on EVariantError do
1695 result := False;
1696 end;
1697 end;
1698 Inc(i);
1699 end;
1700 if not result then
1701 Next;
1702 end;
1703 if not result then
1704 Bookmark := CurBookmark
1705 else
1706 CursorPosChanged;
1707 finally
1708 keyFieldList.Free;
1709 SetLength(lookupValues,0)
1710 end;
1711 end;
1712
1713 procedure TIBCustomDataSet.InternalPostRecord(Qry: TIBSQL; Buff: Pointer);
1714 var
1715 i, j, k: Integer;
1716 pbd: PBlobDataArray;
1717 begin
1718 pbd := PBlobDataArray(PChar(Buff) + FBlobCacheOffset);
1719 j := 0;
1720 for i := 0 to FieldCount - 1 do
1721 if Fields[i].IsBlob then
1722 begin
1723 k := FMappedFieldPosition[Fields[i].FieldNo -1];
1724 if pbd^[j] <> nil then
1725 begin
1726 pbd^[j].Finalize;
1727 PISC_QUAD(
1728 PChar(Buff) + PRecordData(Buff)^.rdFields[k].fdDataOfs)^ :=
1729 pbd^[j].BlobID;
1730 PRecordData(Buff)^.rdFields[k].fdIsNull := pbd^[j].Size = 0;
1731 end;
1732 Inc(j);
1733 end;
1734 if Assigned(FUpdateObject) then
1735 begin
1736 if (Qry = FQDelete) then
1737 FUpdateObject.Apply(ukDelete,Buff)
1738 else if (Qry = FQInsert) then
1739 FUpdateObject.Apply(ukInsert,Buff)
1740 else
1741 FUpdateObject.Apply(ukModify,Buff);
1742 end
1743 else begin
1744 SetInternalSQLParams(Qry, Buff);
1745 Qry.ExecQuery;
1746 end;
1747 PRecordData(Buff)^.rdUpdateStatus := usUnmodified;
1748 PRecordData(Buff)^.rdCachedUpdateStatus := cusUnmodified;
1749 SetModified(False);
1750 WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Buff);
1751 if (FForcedRefresh or FNeedsRefresh) and CanRefresh then
1752 InternalRefreshRow;
1753 end;
1754
1755 procedure TIBCustomDataSet.InternalRefreshRow;
1756 var
1757 Buff: PChar;
1758 SetCursor: Boolean;
1759 ofs: DWORD;
1760 Qry: TIBSQL;
1761 begin
1762 SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault);
1763 if SetCursor then
1764 Screen.Cursor := crHourGlass;
1765 try
1766 Buff := GetActiveBuf;
1767 if CanRefresh then
1768 begin
1769 if Buff <> nil then
1770 begin
1771 if (Assigned(FUpdateObject) and (FUpdateObject.RefreshSQL.Text <> '')) then
1772 begin
1773 Qry := TIBSQL.Create(self);
1774 Qry.Database := Database;
1775 Qry.Transaction := Transaction;
1776 Qry.GoToFirstRecordOnExecute := False;
1777 Qry.SQL.Text := FUpdateObject.RefreshSQL.Text;
1778 end
1779 else
1780 Qry := FQRefresh;
1781 SetInternalSQLParams(Qry, Buff);
1782 Qry.ExecQuery;
1783 try
1784 if (Qry.SQLType = SQLExecProcedure) or
1785 (Qry.Next <> nil) then
1786 begin
1787 ofs := PRecordData(Buff)^.rdSavedOffset;
1788 FetchCurrentRecordToBuffer(Qry,
1789 PRecordData(Buff)^.rdRecordNumber,
1790 Buff);
1791 if FCachedUpdates and (ofs <> $FFFFFFFF) then
1792 begin
1793 PRecordData(Buff)^.rdSavedOffset := ofs;
1794 WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Buff);
1795 SaveOldBuffer(Buff);
1796 end;
1797 end;
1798 finally
1799 Qry.Close;
1800 end;
1801 if Qry <> FQRefresh then
1802 Qry.Free;
1803 end
1804 end
1805 else
1806 IBError(ibxeCannotRefresh, [nil]);
1807 finally
1808 if SetCursor and (Screen.Cursor = crHourGlass) then
1809 Screen.Cursor := crDefault;
1810 end;
1811 end;
1812
1813 procedure TIBCustomDataSet.InternalRevertRecord(RecordNumber: Integer);
1814 var
1815 NewBuffer, OldBuffer: PRecordData;
1816
1817 begin
1818 NewBuffer := nil;
1819 OldBuffer := nil;
1820 NewBuffer := PRecordData(AllocRecordBuffer);
1821 OldBuffer := PRecordData(AllocRecordBuffer);
1822 try
1823 ReadRecordCache(RecordNumber, PChar(NewBuffer), False);
1824 ReadRecordCache(RecordNumber, PChar(OldBuffer), True);
1825 case NewBuffer^.rdCachedUpdateStatus of
1826 cusInserted:
1827 begin
1828 NewBuffer^.rdCachedUpdateStatus := cusUninserted;
1829 Inc(FDeletedRecords);
1830 end;
1831 cusModified,
1832 cusDeleted:
1833 begin
1834 if (NewBuffer^.rdCachedUpdateStatus = cusDeleted) then
1835 Dec(FDeletedRecords);
1836 CopyRecordBuffer(OldBuffer, NewBuffer);
1837 end;
1838 end;
1839
1840 if State in dsEditModes then
1841 Cancel;
1842
1843 WriteRecordCache(RecordNumber, PChar(NewBuffer));
1844
1845 if (NewBuffer^.rdCachedUpdateStatus = cusUninserted ) then
1846 ReSync([]);
1847 finally
1848 FreeRecordBuffer(PChar(NewBuffer));
1849 FreeRecordBuffer(PChar(OldBuffer));
1850 end;
1851 end;
1852
1853 { A visible record is one that is not truly deleted,
1854 and it is also listed in the FUpdateRecordTypes set }
1855
1856 function TIBCustomDataSet.IsVisible(Buffer: PChar): Boolean;
1857 begin
1858 result := True;
1859 if not (State = dsOldValue) then
1860 result :=
1861 (PRecordData(Buffer)^.rdCachedUpdateStatus in FUpdateRecordTypes) and
1862 (not ((PRecordData(Buffer)^.rdCachedUpdateStatus = cusUnmodified) and
1863 (PRecordData(Buffer)^.rdUpdateStatus = usDeleted)));
1864 end;
1865
1866
1867 function TIBCustomDataSet.LocateNext(const KeyFields: string;
1868 const KeyValues: Variant; Options: TLocateOptions): Boolean;
1869 begin
1870 DisableControls;
1871 try
1872 result := InternalLocate(KeyFields, KeyValues, Options);
1873 finally
1874 EnableControls;
1875 end;
1876 end;
1877
1878 procedure TIBCustomDataSet.InternalPrepare;
1879 var
1880 SetCursor: Boolean;
1881 DidActivate: Boolean;
1882 begin
1883 if FInternalPrepared then
1884 Exit;
1885 DidActivate := False;
1886 SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault);
1887 if SetCursor then
1888 Screen.Cursor := crHourGlass;
1889 try
1890 ActivateConnection;
1891 DidActivate := ActivateTransaction;
1892 FBase.CheckDatabase;
1893 FBase.CheckTransaction;
1894 if FQSelect.SQL.Text <> '' then
1895 begin
1896 if not FQSelect.Prepared then
1897 begin
1898 FQSelect.ParamCheck := ParamCheck;
1899 FQSelect.Prepare;
1900 end;
1901 if (Trim(FQDelete.SQL.Text) <> '') and (not FQDelete.Prepared) then
1902 FQDelete.Prepare;
1903 if (Trim(FQInsert.SQL.Text) <> '') and (not FQInsert.Prepared) then
1904 FQInsert.Prepare;
1905 if (Trim(FQRefresh.SQL.Text) <> '') and (not FQRefresh.Prepared) then
1906 FQRefresh.Prepare;
1907 if (Trim(FQModify.SQL.Text) <> '') and (not FQModify.Prepared) then
1908 FQModify.Prepare;
1909 FInternalPrepared := True;
1910 InternalInitFieldDefs;
1911 end else
1912 IBError(ibxeEmptyQuery, [nil]);
1913 finally
1914 if DidActivate then
1915 DeactivateTransaction;
1916 if SetCursor and (Screen.Cursor = crHourGlass) then
1917 Screen.Cursor := crDefault;
1918 end;
1919 end;
1920
1921 procedure TIBCustomDataSet.RecordModified(Value: Boolean);
1922 begin
1923 SetModified(Value);
1924 end;
1925
1926 procedure TIBCustomDataSet.RevertRecord;
1927 var
1928 Buff: PRecordData;
1929 begin
1930 if FCachedUpdates and FUpdatesPending then
1931 begin
1932 Buff := PRecordData(GetActiveBuf);
1933 InternalRevertRecord(Buff^.rdRecordNumber);
1934 ReadRecordCache(Buff^.rdRecordNumber, PChar(Buff), False);
1935 DataEvent(deRecordChange, 0);
1936 end;
1937 end;
1938
1939 procedure TIBCustomDataSet.SaveOldBuffer(Buffer: PChar);
1940 var
1941 OldBuffer: Pointer;
1942 procedure CopyOldBuffer;
1943 begin
1944 CopyRecordBuffer(Buffer, OldBuffer);
1945 if BlobFieldCount > 0 then
1946 FillChar(PChar(OldBuffer)[FBlobCacheOffset], BlobFieldCount * SizeOf(TIBBlobStream),
1947 0);
1948 end;
1949
1950 begin
1951 if (Buffer <> nil) and (PRecordData(Buffer)^.rdRecordNumber >= 0) then
1952 begin
1953 OldBuffer := AllocRecordBuffer;
1954 try
1955 if (PRecordData(Buffer)^.rdSavedOffset = $FFFFFFFF) then
1956 begin
1957 PRecordData(Buffer)^.rdSavedOffset := AdjustPosition(FOldBufferCache, 0,
1958 FILE_END);
1959 CopyOldBuffer;
1960 WriteCache(FOldBufferCache, 0, FILE_CURRENT, OldBuffer);
1961 WriteCache(FBufferCache, PRecordData(Buffer)^.rdRecordNumber * FRecordBufferSize,
1962 FILE_BEGIN, Buffer);
1963 end
1964 else begin
1965 CopyOldBuffer;
1966 WriteCache(FOldBufferCache, PRecordData(Buffer)^.rdSavedOffset, FILE_BEGIN,
1967 OldBuffer);
1968 end;
1969 finally
1970 FreeRecordBuffer(PChar(OldBuffer));
1971 end;
1972 end;
1973 end;
1974
1975 procedure TIBCustomDataSet.SetBufferChunks(Value: Integer);
1976 begin
1977 if (Value <= 0) then
1978 FBufferChunks := BufferCacheSize
1979 else
1980 FBufferChunks := Value;
1981 end;
1982
1983 procedure TIBCustomDataSet.SetDatabase(Value: TIBDatabase);
1984 begin
1985 if (FBase.Database <> Value) then
1986 begin
1987 CheckDatasetClosed;
1988 FBase.Database := Value;
1989 FQDelete.Database := Value;
1990 FQInsert.Database := Value;
1991 FQRefresh.Database := Value;
1992 FQSelect.Database := Value;
1993 FQModify.Database := Value;
1994 end;
1995 end;
1996
1997 procedure TIBCustomDataSet.SetDeleteSQL(Value: TStrings);
1998 begin
1999 if FQDelete.SQL.Text <> Value.Text then
2000 begin
2001 Disconnect;
2002 FQDelete.SQL.Assign(Value);
2003 end;
2004 end;
2005
2006 procedure TIBCustomDataSet.SetInsertSQL(Value: TStrings);
2007 begin
2008 if FQInsert.SQL.Text <> Value.Text then
2009 begin
2010 Disconnect;
2011 FQInsert.SQL.Assign(Value);
2012 end;
2013 end;
2014
2015 procedure TIBCustomDataSet.SetInternalSQLParams(Qry: TIBSQL; Buffer: Pointer);
2016 var
2017 i, j: Integer;
2018 cr, data: PChar;
2019 fn, st: string;
2020 OldBuffer: Pointer;
2021 ts: TTimeStamp;
2022 begin
2023 if (Buffer = nil) then
2024 IBError(ibxeBufferNotSet, [nil]);
2025 if (not FInternalPrepared) then
2026 InternalPrepare;
2027 OldBuffer := nil;
2028 try
2029 for i := 0 to Qry.Params.Count - 1 do
2030 begin
2031 fn := Qry.Params[i].Name;
2032 if (Pos('OLD_', fn) = 1) then {mbcs ok}
2033 begin
2034 fn := Copy(fn, 5, Length(fn));
2035 if not Assigned(OldBuffer) then
2036 begin
2037 OldBuffer := AllocRecordBuffer;
2038 ReadRecordCache(PRecordData(Buffer)^.rdRecordNumber, OldBuffer, True);
2039 end;
2040 cr := OldBuffer;
2041 end
2042 else if (Pos('NEW_', fn) = 1) then {mbcs ok}
2043 begin
2044 fn := Copy(fn, 5, Length(fn));
2045 cr := Buffer;
2046 end
2047 else
2048 cr := Buffer;
2049 j := FQSelect.FieldIndex[fn] + 1;
2050 if (j > 0) then
2051 with PRecordData(cr)^ do
2052 begin
2053 if Qry.Params[i].name = 'IBX_INTERNAL_DBKEY' then {do not localize}
2054 begin
2055 PIBDBKey(Qry.Params[i].AsPointer)^ := rdDBKey;
2056 continue;
2057 end;
2058 if rdFields[j].fdIsNull then
2059 Qry.Params[i].IsNull := True
2060 else begin
2061 Qry.Params[i].IsNull := False;
2062 data := cr + rdFields[j].fdDataOfs;
2063 case rdFields[j].fdDataType of
2064 SQL_TEXT, SQL_VARYING:
2065 begin
2066 SetString(st, data, rdFields[j].fdDataLength);
2067 Qry.Params[i].AsString := st;
2068 end;
2069 SQL_FLOAT, SQL_DOUBLE, SQL_D_FLOAT:
2070 Qry.Params[i].AsDouble := PDouble(data)^;
2071 SQL_SHORT, SQL_LONG:
2072 begin
2073 if rdFields[j].fdDataScale = 0 then
2074 Qry.Params[i].AsLong := PLong(data)^
2075 else if rdFields[j].fdDataScale >= (-4) then
2076 Qry.Params[i].AsCurrency := PCurrency(data)^
2077 else
2078 Qry.Params[i].AsDouble := PDouble(data)^;
2079 end;
2080 SQL_INT64:
2081 begin
2082 if rdFields[j].fdDataScale = 0 then
2083 Qry.Params[i].AsInt64 := PInt64(data)^
2084 else if rdFields[j].fdDataScale >= (-4) then
2085 Qry.Params[i].AsCurrency := PCurrency(data)^
2086 else
2087 Qry.Params[i].AsDouble := PDouble(data)^;
2088 end;
2089 SQL_BLOB, SQL_ARRAY, SQL_QUAD:
2090 Qry.Params[i].AsQuad := PISC_QUAD(data)^;
2091 SQL_TYPE_DATE:
2092 begin
2093 ts.Date := PInt(data)^;
2094 ts.Time := 0;
2095 Qry.Params[i].AsDate :=
2096 TimeStampToDateTime(ts);
2097 end;
2098 SQL_TYPE_TIME:
2099 begin
2100 ts.Date := 0;
2101 ts.Time := PInt(data)^;
2102 Qry.Params[i].AsTime :=
2103 TimeStampToDateTime(ts);
2104 end;
2105 SQL_TIMESTAMP:
2106 Qry.Params[i].AsDateTime :=
2107 TimeStampToDateTime(MSecsToTimeStamp(trunc(PDouble(data)^)));
2108 end;
2109 end;
2110 end;
2111 end;
2112 finally
2113 if (OldBuffer <> nil) then
2114 FreeRecordBuffer(PChar(OldBuffer));
2115 end;
2116 end;
2117
2118 procedure TIBCustomDataSet.SetRefreshSQL(Value: TStrings);
2119 begin
2120 if FQRefresh.SQL.Text <> Value.Text then
2121 begin
2122 Disconnect;
2123 FQRefresh.SQL.Assign(Value);
2124 end;
2125 end;
2126
2127 procedure TIBCustomDataSet.SetSelectSQL(Value: TStrings);
2128 begin
2129 if FQSelect.SQL.Text <> Value.Text then
2130 begin
2131 Disconnect;
2132 FQSelect.SQL.Assign(Value);
2133 end;
2134 end;
2135
2136 procedure TIBCustomDataSet.SetModifySQL(Value: TStrings);
2137 begin
2138 if FQModify.SQL.Text <> Value.Text then
2139 begin
2140 Disconnect;
2141 FQModify.SQL.Assign(Value);
2142 end;
2143 end;
2144
2145 procedure TIBCustomDataSet.SetTransaction(Value: TIBTransaction);
2146 begin
2147 if (FBase.Transaction <> Value) then
2148 begin
2149 CheckDatasetClosed;
2150 FBase.Transaction := Value;
2151 FQDelete.Transaction := Value;
2152 FQInsert.Transaction := Value;
2153 FQRefresh.Transaction := Value;
2154 FQSelect.Transaction := Value;
2155 FQModify.Transaction := Value;
2156 end;
2157 end;
2158
2159 procedure TIBCustomDataSet.SetUniDirectional(Value: Boolean);
2160 begin
2161 CheckDatasetClosed;
2162 FUniDirectional := Value;
2163 end;
2164
2165 procedure TIBCustomDataSet.SetUpdateRecordTypes(Value: TIBUpdateRecordTypes);
2166 begin
2167 FUpdateRecordTypes := Value;
2168 if Active then
2169 First;
2170 end;
2171
2172 procedure TIBCustomDataSet.RefreshParams;
2173 var
2174 DataSet: TDataSet;
2175 begin
2176 DisableControls;
2177 try
2178 if FDataLink.DataSource <> nil then
2179 begin
2180 DataSet := FDataLink.DataSource.DataSet;
2181 if DataSet <> nil then
2182 if DataSet.Active and (DataSet.State <> dsSetKey) then
2183 begin
2184 Close;
2185 Open;
2186 end;
2187 end;
2188 finally
2189 EnableControls;
2190 end;
2191 end;
2192
2193
2194 procedure TIBCustomDataSet.SQLChanging(Sender: TObject);
2195 begin
2196 if FOpen then
2197 InternalClose;
2198 if FInternalPrepared then
2199 InternalUnPrepare;
2200 end;
2201
2202 { I can "undelete" uninserted records (make them "inserted" again).
2203 I can "undelete" cached deleted (the deletion hasn't yet occurred) }
2204 procedure TIBCustomDataSet.Undelete;
2205 var
2206 Buff: PRecordData;
2207 begin
2208 CheckActive;
2209 Buff := PRecordData(GetActiveBuf);
2210 with Buff^ do
2211 begin
2212 if rdCachedUpdateStatus = cusUninserted then
2213 begin
2214 rdCachedUpdateStatus := cusInserted;
2215 Dec(FDeletedRecords);
2216 end
2217 else if (rdUpdateStatus = usDeleted) and
2218 (rdCachedUpdateStatus = cusDeleted) then
2219 begin
2220 rdCachedUpdateStatus := cusUnmodified;
2221 rdUpdateStatus := usUnmodified;
2222 Dec(FDeletedRecords);
2223 end;
2224 WriteRecordCache(rdRecordNumber, PChar(Buff));
2225 end;
2226 end;
2227
2228 function TIBCustomDataSet.UpdateStatus: TUpdateStatus;
2229 begin
2230 if Active then
2231 if GetActiveBuf <> nil then
2232 result := PRecordData(GetActiveBuf)^.rdUpdateStatus
2233 else
2234 result := usUnmodified
2235 else
2236 result := usUnmodified;
2237 end;
2238
2239 function TIBCustomDataSet.IsSequenced: Boolean;
2240 begin
2241 Result := Assigned( FQSelect ) and FQSelect.EOF;
2242 end;
2243
2244 function TIBCustomDataSet.ParamByName(ParamName: String): TIBXSQLVAR;
2245 begin
2246 ActivateConnection;
2247 ActivateTransaction;
2248 if not FInternalPrepared then
2249 InternalPrepare;
2250 Result := Params.ByName(ParamName);
2251 end;
2252
2253 {Beware: the parameter FCache is used as an identifier to determine which
2254 cache is being operated on and is not referenced in the computation.
2255 The result is an adjusted offset into the identified cache, either the
2256 Buffer Cache or the old Buffer Cache.}
2257
2258 function TIBCustomDataSet.AdjustPosition(FCache: PChar; Offset: DWORD;
2259 Origin: Integer): DWORD;
2260 var
2261 OldCacheSize: Integer;
2262 begin
2263 if (FCache = FBufferCache) then
2264 begin
2265 case Origin of
2266 FILE_BEGIN: FBPos := Offset;
2267 FILE_CURRENT: FBPos := FBPos + Offset;
2268 FILE_END: FBPos := DWORD(FBEnd) + Offset;
2269 end;
2270 OldCacheSize := FCacheSize;
2271 while (FBPos >= DWORD(FCacheSize)) do
2272 Inc(FCacheSize, FBufferChunkSize);
2273 if FCacheSize > OldCacheSize then
2274 IBAlloc(FBufferCache, FCacheSize, FCacheSize);
2275 result := FBPos;
2276 end
2277 else begin
2278 case Origin of
2279 FILE_BEGIN: FOBPos := Offset;
2280 FILE_CURRENT: FOBPos := FOBPos + Offset;
2281 FILE_END: FOBPos := DWORD(FOBEnd) + Offset;
2282 end;
2283 OldCacheSize := FOldCacheSize;
2284 while (FBPos >= DWORD(FOldCacheSize)) do
2285 Inc(FOldCacheSize, FBufferChunkSize);
2286 if FOldCacheSize > OldCacheSize then
2287 IBAlloc(FOldBufferCache, FOldCacheSize, FOldCacheSize);
2288 result := FOBPos;
2289 end;
2290 end;
2291
2292 procedure TIBCustomDataSet.ReadCache(FCache: PChar; Offset: DWORD; Origin: Integer;
2293 Buffer: PChar);
2294 var
2295 pCache: PChar;
2296 AdjustedOffset: DWORD;
2297 bOld: Boolean;
2298 begin
2299 bOld := (FCache = FOldBufferCache);
2300 AdjustedOffset := AdjustPosition(FCache, Offset, Origin);
2301 if not bOld then
2302 pCache := FBufferCache + AdjustedOffset
2303 else
2304 pCache := FOldBufferCache + AdjustedOffset;
2305 Move(pCache^, Buffer^, DWORD(FRecordBufferSize));
2306 AdjustPosition(FCache, FRecordBufferSize, FILE_CURRENT);
2307 end;
2308
2309 procedure TIBCustomDataSet.ReadRecordCache(RecordNumber: Integer; Buffer: PChar;
2310 ReadOldBuffer: Boolean);
2311 begin
2312 if FUniDirectional then
2313 RecordNumber := RecordNumber mod UniCache;
2314 if (ReadOldBuffer) then
2315 begin
2316 ReadRecordCache(RecordNumber, Buffer, False);
2317 if FCachedUpdates and
2318 (PRecordData(Buffer)^.rdSavedOffset <> $FFFFFFFF) then
2319 ReadCache(FOldBufferCache, PRecordData(Buffer)^.rdSavedOffset, FILE_BEGIN,
2320 Buffer)
2321 else
2322 if ReadOldBuffer and
2323 (PRecordData(FOldBuffer)^.rdRecordNumber = RecordNumber) then
2324 CopyRecordBuffer( FOldBuffer, Buffer )
2325 end
2326 else
2327 ReadCache(FBufferCache, RecordNumber * FRecordBufferSize, FILE_BEGIN, Buffer);
2328 end;
2329
2330 procedure TIBCustomDataSet.WriteCache(FCache: PChar; Offset: DWORD; Origin: Integer;
2331 Buffer: PChar);
2332 var
2333 pCache: PChar;
2334 AdjustedOffset: DWORD;
2335 bOld: Boolean;
2336 dwEnd: DWORD;
2337 begin
2338 bOld := (FCache = FOldBufferCache);
2339 AdjustedOffset := AdjustPosition(FCache, Offset, Origin);
2340 if not bOld then
2341 pCache := FBufferCache + AdjustedOffset
2342 else
2343 pCache := FOldBufferCache + AdjustedOffset;
2344 Move(Buffer^, pCache^, FRecordBufferSize);
2345 dwEnd := AdjustPosition(FCache, FRecordBufferSize, FILE_CURRENT);
2346 if not bOld then
2347 begin
2348 if (dwEnd > FBEnd) then
2349 FBEnd := dwEnd;
2350 end
2351 else begin
2352 if (dwEnd > FOBEnd) then
2353 FOBEnd := dwEnd;
2354 end;
2355 end;
2356
2357 procedure TIBCustomDataSet.WriteRecordCache(RecordNumber: Integer; Buffer: PChar);
2358 begin
2359 if RecordNumber >= 0 then
2360 begin
2361 if FUniDirectional then
2362 RecordNumber := RecordNumber mod UniCache;
2363 WriteCache(FBufferCache, RecordNumber * FRecordBufferSize, FILE_BEGIN, Buffer);
2364 end;
2365 end;
2366
2367 function TIBCustomDataSet.AllocRecordBuffer: PChar;
2368 begin
2369 result := nil;
2370 IBAlloc(result, FRecordBufferSize, FRecordBufferSize);
2371 Move(FModelBuffer^, result^, FRecordBufferSize);
2372 end;
2373
2374 function TIBCustomDataSet.CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream;
2375 var
2376 pb: PBlobDataArray;
2377 fs: TIBBlobStream;
2378 Buff: PChar;
2379 bTr, bDB: Boolean;
2380 begin
2381 Buff := GetActiveBuf;
2382 if Buff = nil then
2383 begin
2384 fs := TIBBlobStream.Create;
2385 fs.Mode := bmReadWrite;
2386 FBlobStreamList.Add(Pointer(fs));
2387 result := TIBDSBlobStream.Create(Field, fs, Mode);
2388 exit;
2389 end;
2390 pb := PBlobDataArray(Buff + FBlobCacheOffset);
2391 if pb^[Field.Offset] = nil then
2392 begin
2393 AdjustRecordOnInsert(Buff);
2394 pb^[Field.Offset] := TIBBlobStream.Create;
2395 fs := pb^[Field.Offset];
2396 FBlobStreamList.Add(Pointer(fs));
2397 fs.Mode := bmReadWrite;
2398 fs.Database := Database;
2399 fs.Transaction := Transaction;
2400 fs.BlobID :=
2401 PISC_QUAD(@Buff[PRecordData(Buff)^.rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataOfs])^;
2402 if (CachedUpdates) then
2403 begin
2404 bTr := not Transaction.InTransaction;
2405 bDB := not Database.Connected;
2406 if bDB then
2407 Database.Open;
2408 if bTr then
2409 Transaction.StartTransaction;
2410 fs.Seek(0, soFromBeginning);
2411 if bTr then
2412 Transaction.Commit;
2413 if bDB then
2414 Database.Close;
2415 end;
2416 WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Pointer(Buff));
2417 end else
2418 fs := pb^[Field.Offset];
2419 result := TIBDSBlobStream.Create(Field, fs, Mode);
2420 end;
2421
2422 function TIBCustomDataSet.CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Integer;
2423 const
2424 CMPLess = -1;
2425 CMPEql = 0;
2426 CMPGtr = 1;
2427 RetCodes: array[Boolean, Boolean] of ShortInt = ((2, CMPLess),
2428 (CMPGtr, CMPEql));
2429 begin
2430 result := RetCodes[Bookmark1 = nil, Bookmark2 = nil];
2431
2432 if Result = 2 then
2433 begin
2434 if PInteger(Bookmark1)^ < PInteger(Bookmark2)^ then
2435 Result := CMPLess
2436 else
2437 if PInteger(Bookmark1)^ > PInteger(Bookmark2)^ then
2438 Result := CMPGtr
2439 else
2440 Result := CMPEql;
2441 end;
2442 end;
2443
2444 procedure TIBCustomDataSet.DoBeforeDelete;
2445 var
2446 Buff: PRecordData;
2447 begin
2448 if not CanDelete then
2449 IBError(ibxeCannotDelete, [nil]);
2450 Buff := PRecordData(GetActiveBuf);
2451 if FCachedUpdates and
2452 (Buff^.rdCachedUpdateStatus in [cusUnmodified]) then
2453 SaveOldBuffer(PChar(Buff));
2454 inherited DoBeforeDelete;
2455 end;
2456
2457 procedure TIBCustomDataSet.DoBeforeEdit;
2458 var
2459 Buff: PRecordData;
2460 begin
2461 Buff := PRecordData(GetActiveBuf);
2462 if not(CanEdit or (FQModify.SQL.Count <> 0) or
2463 (FCachedUpdates and Assigned(FOnUpdateRecord))) then
2464 IBError(ibxeCannotUpdate, [nil]);
2465 if FCachedUpdates and (Buff^.rdCachedUpdateStatus in [cusUnmodified, cusInserted]) then
2466 SaveOldBuffer(PChar(Buff));
2467 CopyRecordBuffer(GetActiveBuf, FOldBuffer);
2468 inherited DoBeforeEdit;
2469 end;
2470
2471 procedure TIBCustomDataSet.DoBeforeInsert;
2472 begin
2473 if not CanInsert then
2474 IBError(ibxeCannotInsert, [nil]);
2475 inherited DoBeforeInsert;
2476 end;
2477
2478 procedure TIBCustomDataSet.DoAfterInsert;
2479 begin
2480 if GeneratorField.ApplyOnEvent = gaeOnNewRecord then
2481 GeneratorField.Apply;
2482 inherited DoAfterInsert;
2483 end;
2484
2485 procedure TIBCustomDataSet.DoBeforePost;
2486 begin
2487 inherited DoBeforePost;
2488 if (State = dsInsert) and
2489 (GeneratorField.ApplyOnEvent = gaeOnPostRecord) then
2490 GeneratorField.Apply
2491 end;
2492
2493 procedure TIBCustomDataSet.FetchAll;
2494 var
2495 SetCursor: Boolean;
2496 {$IF FPC_FULLVERSION > 20600 }
2497 CurBookmark: TBookmark;
2498 {$ELSE}
2499 CurBookmark: string;
2500 {$ENDIF}
2501 begin
2502 SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault);
2503 if SetCursor then
2504 Screen.Cursor := crHourGlass;
2505 try
2506 if FQSelect.EOF or not FQSelect.Open then
2507 exit;
2508 DisableControls;
2509 try
2510 CurBookmark := Bookmark;
2511 Last;
2512 Bookmark := CurBookmark;
2513 finally
2514 EnableControls;
2515 end;
2516 finally
2517 if SetCursor and (Screen.Cursor = crHourGlass) then
2518 Screen.Cursor := crDefault;
2519 end;
2520 end;
2521
2522 procedure TIBCustomDataSet.FreeRecordBuffer(var Buffer: PChar);
2523 begin
2524 FreeMem(Buffer);
2525 Buffer := nil;
2526 end;
2527
2528 procedure TIBCustomDataSet.GetBookmarkData(Buffer: PChar; Data: Pointer);
2529 begin
2530 Move(PRecordData(Buffer)^.rdRecordNumber, Data^, BookmarkSize);
2531 end;
2532
2533 function TIBCustomDataSet.GetBookmarkFlag(Buffer: PChar): TBookmarkFlag;
2534 begin
2535 result := PRecordData(Buffer)^.rdBookmarkFlag;
2536 end;
2537
2538 function TIBCustomDataSet.GetCanModify: Boolean;
2539 begin
2540 result := (FQInsert.SQL.Text <> '') or
2541 (FQModify.SQL.Text <> '') or
2542 (FQDelete.SQL.Text <> '') or
2543 (Assigned(FUpdateObject));
2544 end;
2545
2546 function TIBCustomDataSet.GetCurrentRecord(Buffer: PChar): Boolean;
2547 begin
2548 if not IsEmpty and (GetBookmarkFlag(ActiveBuffer) = bfCurrent) then
2549 begin
2550 UpdateCursorPos;
2551 ReadRecordCache(PRecordData(ActiveBuffer)^.rdRecordNumber, Buffer, False);
2552 result := True;
2553 end
2554 else
2555 result := False;
2556 end;
2557
2558 function TIBCustomDataSet.GetDataSource: TDataSource;
2559 begin
2560 if FDataLink = nil then
2561 result := nil
2562 else
2563 result := FDataLink.DataSource;
2564 end;
2565
2566 function TIBCustomDataSet.GetFieldClass(FieldType: TFieldType): TFieldClass;
2567 begin
2568 Result := DefaultFieldClasses[FieldType];
2569 end;
2570
2571 function TIBCustomDataSet.GetFieldData(FieldNo: Integer; Buffer: Pointer): Boolean;
2572 begin
2573 result := GetFieldData(FieldByNumber(FieldNo), buffer);
2574 end;
2575
2576 function TIBCustomDataSet.InternalGetFieldData(Field: TField; Buffer: Pointer): Boolean;
2577 var
2578 Buff, Data: PChar;
2579 CurrentRecord: PRecordData;
2580 begin
2581 result := False;
2582 Buff := GetActiveBuf;
2583 if (Buff = nil) or
2584 (not IsVisible(Buff)) or not assigned(Field.DataSet) then
2585 exit;
2586 { The intention here is to stuff the buffer with the data for the
2587 referenced field for the current record }
2588 CurrentRecord := PRecordData(Buff);
2589 if (Field.FieldNo < 0) then
2590 begin
2591 Inc(Buff, FRecordSize + Field.Offset);
2592 result := Boolean(Buff[0]);
2593 if result and (Buffer <> nil) then
2594 Move(Buff[1], Buffer^, Field.DataSize);
2595 end
2596 else if (FMappedFieldPosition[Field.FieldNo - 1] > 0) and
2597 (FMappedFieldPosition[Field.FieldNo - 1] <= CurrentRecord^.rdFieldCount) then
2598 begin
2599 result := not CurrentRecord^.rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdIsNull;
2600 if result and (Buffer <> nil) then
2601 with CurrentRecord^.rdFields[FMappedFieldPosition[Field.FieldNo - 1]] do
2602 begin
2603 Data := Buff + CurrentRecord^.rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataOfs;
2604 if (fdDataType = SQL_VARYING) or (fdDataType = SQL_TEXT) then
2605 begin
2606 if fdDataLength <= Field.Size then
2607 begin
2608 Move(Data^, Buffer^, fdDataLength);
2609 PChar(Buffer)[fdDataLength] := #0;
2610 end
2611 else
2612 IBError(ibxeFieldSizeError,[Field.FieldName])
2613 end
2614 else
2615 Move(Data^, Buffer^, Field.DataSize);
2616 end;
2617 end;
2618 end;
2619
2620 { GetRecNo and SetRecNo both operate off of 1-based indexes as
2621 opposed to 0-based indexes.
2622 This is because we want LastRecordNumber/RecordCount = 1 }
2623
2624 function TIBCustomDataSet.GetRecNo: Integer;
2625 begin
2626 if GetActiveBuf = nil then
2627 result := 0
2628 else
2629 result := PRecordData(GetActiveBuf)^.rdRecordNumber + 1;
2630 end;
2631
2632 function TIBCustomDataSet.GetRecord(Buffer: PChar; GetMode: TGetMode;
2633 DoCheck: Boolean): TGetResult;
2634 var
2635 Accept: Boolean;
2636 SaveState: TDataSetState;
2637 begin
2638 Result := grOK;
2639 if Filtered and Assigned(OnFilterRecord) then
2640 begin
2641 Accept := False;
2642 SaveState := SetTempState(dsFilter);
2643 while not Accept do
2644 begin
2645 Result := InternalGetRecord(Buffer, GetMode, DoCheck);
2646 if Result <> grOK then
2647 break;
2648 FFilterBuffer := Buffer;
2649 try
2650 Accept := True;
2651 OnFilterRecord(Self, Accept);
2652 if not Accept and (GetMode = gmCurrent) then
2653 GetMode := gmPrior;
2654 except
2655 // Application.HandleException(Self);
2656 end;
2657 end;
2658 RestoreState(SaveState);
2659 end
2660 else
2661 Result := InternalGetRecord(Buffer, GetMode, DoCheck);
2662 end;
2663
2664 function TIBCustomDataSet.InternalGetRecord(Buffer: PChar; GetMode: TGetMode;
2665 DoCheck: Boolean): TGetResult;
2666 begin
2667 result := grError;
2668 case GetMode of
2669 gmCurrent: begin
2670 if (FCurrentRecord >= 0) then begin
2671 if FCurrentRecord < FRecordCount then
2672 ReadRecordCache(FCurrentRecord, Buffer, False)
2673 else begin
2674 while (not FQSelect.EOF) and
2675 (FQSelect.Next <> nil) and
2676 (FCurrentRecord >= FRecordCount) do begin
2677 FetchCurrentRecordToBuffer(FQSelect, FRecordCount, Buffer);
2678 Inc(FRecordCount);
2679 end;
2680 FCurrentRecord := FRecordCount - 1;
2681 if (FCurrentRecord >= 0) then
2682 ReadRecordCache(FCurrentRecord, Buffer, False);
2683 end;
2684 result := grOk;
2685 end else
2686 result := grBOF;
2687 end;
2688 gmNext: begin
2689 result := grOk;
2690 if FCurrentRecord = FRecordCount then
2691 result := grEOF
2692 else if FCurrentRecord = FRecordCount - 1 then begin
2693 if (not FQSelect.EOF) then begin
2694 FQSelect.Next;
2695 Inc(FCurrentRecord);
2696 end;
2697 if (FQSelect.EOF) then begin
2698 result := grEOF;
2699 end else begin
2700 Inc(FRecordCount);
2701 FetchCurrentRecordToBuffer(FQSelect, FCurrentRecord, Buffer);
2702 end;
2703 end else if (FCurrentRecord < FRecordCount) then begin
2704 Inc(FCurrentRecord);
2705 ReadRecordCache(FCurrentRecord, Buffer, False);
2706 end;
2707 end;
2708 else { gmPrior }
2709 begin
2710 if (FCurrentRecord = 0) then begin
2711 Dec(FCurrentRecord);
2712 result := grBOF;
2713 end else if (FCurrentRecord > 0) and
2714 (FCurrentRecord <= FRecordCount) then begin
2715 Dec(FCurrentRecord);
2716 ReadRecordCache(FCurrentRecord, Buffer, False);
2717 result := grOk;
2718 end else if (FCurrentRecord = -1) then
2719 result := grBOF;
2720 end;
2721 end;
2722 if result = grOk then
2723 result := AdjustCurrentRecord(Buffer, GetMode);
2724 if result = grOk then with PRecordData(Buffer)^ do begin
2725 rdBookmarkFlag := bfCurrent;
2726 GetCalcFields(Buffer);
2727 end else if (result = grEOF) then begin
2728 CopyRecordBuffer(FModelBuffer, Buffer);
2729 PRecordData(Buffer)^.rdBookmarkFlag := bfEOF;
2730 end else if (result = grBOF) then begin
2731 CopyRecordBuffer(FModelBuffer, Buffer);
2732 PRecordData(Buffer)^.rdBookmarkFlag := bfBOF;
2733 end else if (result = grError) then begin
2734 CopyRecordBuffer(FModelBuffer, Buffer);
2735 PRecordData(Buffer)^.rdBookmarkFlag := bfEOF;
2736 end;;
2737 end;
2738
2739 function TIBCustomDataSet.GetRecordCount: Integer;
2740 begin
2741 result := FRecordCount - FDeletedRecords;
2742 end;
2743
2744 function TIBCustomDataSet.GetRecordSize: Word;
2745 begin
2746 result := FRecordBufferSize;
2747 end;
2748
2749 procedure TIBCustomDataSet.InternalAddRecord(Buffer: Pointer; Append: Boolean);
2750 begin
2751 CheckEditState;
2752 begin
2753 { When adding records, we *always* append.
2754 Insertion is just too costly }
2755 AdjustRecordOnInsert(Buffer);
2756 with PRecordData(Buffer)^ do
2757 begin
2758 rdUpdateStatus := usInserted;
2759 rdCachedUpdateStatus := cusInserted;
2760 end;
2761 if not CachedUpdates then
2762 InternalPostRecord(FQInsert, Buffer)
2763 else begin
2764 WriteRecordCache(FCurrentRecord, Buffer);
2765 FUpdatesPending := True;
2766 end;
2767 Inc(FRecordCount);
2768 InternalSetToRecord(Buffer);
2769 end
2770 end;
2771
2772 procedure TIBCustomDataSet.InternalCancel;
2773 var
2774 Buff: PChar;
2775 CurRec: Integer;
2776 begin
2777 inherited InternalCancel;
2778 Buff := GetActiveBuf;
2779 if Buff <> nil then begin
2780 CurRec := FCurrentRecord;
2781 AdjustRecordOnInsert(Buff);
2782 if (State = dsEdit) then begin
2783 CopyRecordBuffer(FOldBuffer, Buff);
2784 WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Buff);
2785 end else begin
2786 CopyRecordBuffer(FModelBuffer, Buff);
2787 PRecordData(Buff)^.rdUpdateStatus := usDeleted;
2788 PRecordData(Buff)^.rdCachedUpdateStatus := cusUnmodified;
2789 PRecordData(Buff)^.rdBookmarkFlag := bfEOF;
2790 FCurrentRecord := CurRec;
2791 end;
2792 end;
2793 end;
2794
2795
2796 procedure TIBCustomDataSet.InternalClose;
2797 begin
2798 if FDidActivate then
2799 DeactivateTransaction;
2800 FQSelect.Close;
2801 ClearBlobCache;
2802 FreeRecordBuffer(FModelBuffer);
2803 FreeRecordBuffer(FOldBuffer);
2804 FCurrentRecord := -1;
2805 FOpen := False;
2806 FRecordCount := 0;
2807 FDeletedRecords := 0;
2808 FRecordSize := 0;
2809 FBPos := 0;
2810 FOBPos := 0;
2811 FCacheSize := 0;
2812 FOldCacheSize := 0;
2813 FBEnd := 0;
2814 FOBEnd := 0;
2815 FreeMem(FBufferCache);
2816 FBufferCache := nil;
2817 FreeMem(FOldBufferCache);
2818 FOldBufferCache := nil;
2819 BindFields(False);
2820 if DefaultFields then DestroyFields;
2821 end;
2822
2823 procedure TIBCustomDataSet.InternalDelete;
2824 var
2825 Buff: PChar;
2826 SetCursor: Boolean;
2827 begin
2828 SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault);
2829 if SetCursor then
2830 Screen.Cursor := crHourGlass;
2831 try
2832 Buff := GetActiveBuf;
2833 if CanDelete then
2834 begin
2835 if not CachedUpdates then
2836 InternalDeleteRecord(FQDelete, Buff)
2837 else
2838 begin
2839 with PRecordData(Buff)^ do
2840 begin
2841 if rdCachedUpdateStatus = cusInserted then
2842 rdCachedUpdateStatus := cusUninserted
2843 else begin
2844 rdUpdateStatus := usDeleted;
2845 rdCachedUpdateStatus := cusDeleted;
2846 end;
2847 end;
2848 WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Buff);
2849 end;
2850 Inc(FDeletedRecords);
2851 FUpdatesPending := True;
2852 end else
2853 IBError(ibxeCannotDelete, [nil]);
2854 finally
2855 if SetCursor and (Screen.Cursor = crHourGlass) then
2856 Screen.Cursor := crDefault;
2857 end;
2858 end;
2859
2860 procedure TIBCustomDataSet.InternalFirst;
2861 begin
2862 FCurrentRecord := -1;
2863 end;
2864
2865 procedure TIBCustomDataSet.InternalGotoBookmark(Bookmark: Pointer);
2866 begin
2867 FCurrentRecord := PInteger(Bookmark)^;
2868 end;
2869
2870 procedure TIBCustomDataSet.InternalHandleException;
2871 begin
2872 Application.HandleException(Self)
2873 end;
2874
2875 procedure TIBCustomDataSet.InternalInitFieldDefs;
2876 const
2877 DefaultSQL = 'Select F.RDB$COMPUTED_BLR, ' + {do not localize}
2878 'F.RDB$DEFAULT_VALUE, R.RDB$FIELD_NAME ' + {do not localize}
2879 'from RDB$RELATION_FIELDS R, RDB$FIELDS F ' + {do not localize}
2880 'where R.RDB$RELATION_NAME = :RELATION ' + {do not localize}
2881 'and R.RDB$FIELD_SOURCE = F.RDB$FIELD_NAME '+ {do not localize}
2882 'and ((not F.RDB$COMPUTED_BLR is NULL) or ' + {do not localize}
2883 ' (not F.RDB$DEFAULT_VALUE is NULL)) '; {do not localize}
2884 var
2885 FieldType: TFieldType;
2886 FieldSize: Word;
2887 FieldNullable : Boolean;
2888 i, FieldPosition, FieldPrecision: Integer;
2889 FieldAliasName: string;
2890 RelationName, FieldName: string;
2891 Query : TIBSQL;
2892 FieldIndex: Integer;
2893 FRelationNodes : TRelationNode;
2894
2895 function Add_Node(Relation, Field : String) : TRelationNode;
2896 var
2897 FField : TFieldNode;
2898 begin
2899 if FRelationNodes.RelationName = '' then
2900 Result := FRelationNodes
2901 else
2902 begin
2903 Result := TRelationNode.Create;
2904 Result.NextRelation := FRelationNodes;
2905 end;
2906 Result.RelationName := Relation;
2907 FRelationNodes := Result;
2908 Query.Params[0].AsString := Relation;
2909 Query.ExecQuery;
2910 while not Query.Eof do
2911 begin
2912 FField := TFieldNode.Create;
2913 FField.FieldName := Query.Fields[2].AsString;
2914 FField.DEFAULT_VALUE := not Query.Fields[1].IsNull;
2915 FField.COMPUTED_BLR := not Query.Fields[0].IsNull;
2916 FField.NextField := Result.FieldNodes;
2917 Result.FieldNodes := FField;
2918 Query.Next;
2919 end;
2920 Query.Close;
2921 end;
2922
2923 function Has_COMPUTED_BLR(Relation, Field : String) : Boolean;
2924 var
2925 FRelation : TRelationNode;
2926 FField : TFieldNode;
2927 begin
2928 FRelation := FRelationNodes;
2929 while Assigned(FRelation) and
2930 (FRelation.RelationName <> Relation) do
2931 FRelation := FRelation.NextRelation;
2932 if not Assigned(FRelation) then
2933 FRelation := Add_Node(Relation, Field);
2934 Result := false;
2935 FField := FRelation.FieldNodes;
2936 while Assigned(FField) do
2937 if FField.FieldName = Field then
2938 begin
2939 Result := Ffield.COMPUTED_BLR;
2940 Exit;
2941 end
2942 else
2943 FField := Ffield.NextField;
2944 end;
2945
2946 function Has_DEFAULT_VALUE(Relation, Field : String) : Boolean;
2947 var
2948 FRelation : TRelationNode;
2949 FField : TFieldNode;
2950 begin
2951 FRelation := FRelationNodes;
2952 while Assigned(FRelation) and
2953 (FRelation.RelationName <> Relation) do
2954 FRelation := FRelation.NextRelation;
2955 if not Assigned(FRelation) then
2956 FRelation := Add_Node(Relation, Field);
2957 Result := false;
2958 FField := FRelation.FieldNodes;
2959 while Assigned(FField) do
2960 if FField.FieldName = Field then
2961 begin
2962 Result := Ffield.DEFAULT_VALUE;
2963 Exit;
2964 end
2965 else
2966 FField := Ffield.NextField;
2967 end;
2968
2969 Procedure FreeNodes;
2970 var
2971 FRelation : TRelationNode;
2972 FField : TFieldNode;
2973 begin
2974 while Assigned(FRelationNodes) do
2975 begin
2976 While Assigned(FRelationNodes.FieldNodes) do
2977 begin
2978 FField := FRelationNodes.FieldNodes.NextField;
2979 FRelationNodes.FieldNodes.Free;
2980 FRelationNodes.FieldNodes := FField;
2981 end;
2982 FRelation := FRelationNodes.NextRelation;
2983 FRelationNodes.Free;
2984 FRelationNodes := FRelation;
2985 end;
2986 end;
2987
2988 begin
2989 if not InternalPrepared then
2990 begin
2991 InternalPrepare;
2992 exit;
2993 end;
2994 FRelationNodes := TRelationNode.Create;
2995 FNeedsRefresh := False;
2996 Database.InternalTransaction.StartTransaction;
2997 Query := TIBSQL.Create(self);
2998 try
2999 Query.Database := DataBase;
3000 Query.Transaction := Database.InternalTransaction;
3001 FieldDefs.BeginUpdate;
3002 FieldDefs.Clear;
3003 FieldIndex := 0;
3004 if (Length(FMappedFieldPosition) < FQSelect.Current.Count) then
3005 SetLength(FMappedFieldPosition, FQSelect.Current.Count);
3006 Query.SQL.Text := DefaultSQL;
3007 Query.Prepare;
3008 for i := 0 to FQSelect.Current.Count - 1 do
3009 with FQSelect.Current[i].Data^ do
3010 begin
3011 { Get the field name }
3012 SetString(FieldAliasName, aliasname, aliasname_length);
3013 SetString(RelationName, relname, relname_length);
3014 SetString(FieldName, sqlname, sqlname_length);
3015 FieldSize := 0;
3016 FieldPrecision := 0;
3017 FieldNullable := FQSelect.Current[i].IsNullable;
3018 case sqltype and not 1 of
3019 { All VARCHAR's must be converted to strings before recording
3020 their values }
3021 SQL_VARYING, SQL_TEXT:
3022 begin
3023 FieldSize := sqllen;
3024 FieldType := ftString;
3025 end;
3026 { All Doubles/Floats should be cast to doubles }
3027 SQL_DOUBLE, SQL_FLOAT:
3028 FieldType := ftFloat;
3029 SQL_SHORT:
3030 begin
3031 if (sqlscale = 0) then
3032 FieldType := ftSmallInt
3033 else begin
3034 FieldType := ftBCD;
3035 FieldPrecision := 4;
3036 FieldSize := -sqlscale;
3037 end;
3038 end;
3039 SQL_LONG:
3040 begin
3041 if (sqlscale = 0) then
3042 FieldType := ftInteger
3043 else if (sqlscale >= (-4)) then
3044 begin
3045 FieldType := ftBCD;
3046 FieldPrecision := 9;
3047 FieldSize := -sqlscale;
3048 end
3049 else
3050 if Database.SQLDialect = 1 then
3051 FieldType := ftFloat
3052 else
3053 if (FieldCount > i) and (Fields[i] is TFloatField) then
3054 FieldType := ftFloat
3055 else
3056 begin
3057 FieldType := ftFMTBCD;
3058 FieldPrecision := 9;
3059 FieldSize := -sqlscale;
3060 end;
3061 end;
3062
3063 SQL_INT64:
3064 begin
3065 if (sqlscale = 0) then
3066 FieldType := ftLargeInt
3067 else if (sqlscale >= (-4)) then
3068 begin
3069 FieldType := ftBCD;
3070 FieldPrecision := 18;
3071 FieldSize := -sqlscale;
3072 end
3073 else
3074 FieldType := ftFloat
3075 end;
3076 SQL_TIMESTAMP: FieldType := ftDateTime;
3077 SQL_TYPE_TIME: FieldType := ftTime;
3078 SQL_TYPE_DATE: FieldType := ftDate;
3079 SQL_BLOB:
3080 begin
3081 FieldSize := sizeof (TISC_QUAD);
3082 if (sqlsubtype = 1) then
3083 FieldType := ftmemo
3084 else
3085 FieldType := ftBlob;
3086 end;
3087 SQL_ARRAY:
3088 begin
3089 FieldSize := sizeof (TISC_QUAD);
3090 FieldType := ftUnknown;
3091 end;
3092 else
3093 FieldType := ftUnknown;
3094 end;
3095 FieldPosition := i + 1;
3096 if (FieldType <> ftUnknown) and (FieldAliasName <> 'IBX_INTERNAL_DBKEY') then {do not localize}
3097 begin
3098 FMappedFieldPosition[FieldIndex] := FieldPosition;
3099 Inc(FieldIndex);
3100 with FieldDefs.AddFieldDef do
3101 begin
3102 Name := FieldAliasName;
3103 (* FieldNo := FieldPosition;*)
3104 DataType := FieldType;
3105 Size := FieldSize;
3106 Precision := FieldPrecision;
3107 Required := not FieldNullable;
3108 InternalCalcField := False;
3109 if (FieldName <> '') and (RelationName <> '') then
3110 begin
3111 if Has_COMPUTED_BLR(RelationName, FieldName) then
3112 begin
3113 Attributes := [faReadOnly];
3114 InternalCalcField := True;
3115 FNeedsRefresh := True;
3116 end
3117 else
3118 begin
3119 if Has_DEFAULT_VALUE(RelationName, FieldName) then
3120 begin
3121 if not FieldNullable then
3122 Attributes := [faRequired];
3123 end
3124 else
3125 FNeedsRefresh := True;
3126 end;
3127 end;
3128 end;
3129 end;
3130 end;
3131 finally
3132 Query.free;
3133 FreeNodes;
3134 Database.InternalTransaction.Commit;
3135 FieldDefs.EndUpdate;
3136 end;
3137 end;
3138
3139 procedure TIBCustomDataSet.InternalInitRecord(Buffer: PChar);
3140 begin
3141 CopyRecordBuffer(FModelBuffer, Buffer);
3142 end;
3143
3144 procedure TIBCustomDataSet.InternalLast;
3145 var
3146 Buffer: PChar;
3147 begin
3148 if (FQSelect.EOF) then
3149 FCurrentRecord := FRecordCount
3150 else begin
3151 Buffer := AllocRecordBuffer;
3152 try
3153 while FQSelect.Next <> nil do
3154 begin
3155 FetchCurrentRecordToBuffer(FQSelect, FRecordCount, Buffer);
3156 Inc(FRecordCount);
3157 end;
3158 FCurrentRecord := FRecordCount;
3159 finally
3160 FreeRecordBuffer(Buffer);
3161 end;
3162 end;
3163 end;
3164
3165 procedure TIBCustomDataSet.InternalSetParamsFromCursor;
3166 var
3167 i: Integer;
3168 cur_param: TIBXSQLVAR;
3169 cur_field: TField;
3170 s: TStream;
3171 begin
3172 if FQSelect.SQL.Text = '' then
3173 IBError(ibxeEmptyQuery, [nil]);
3174 if not FInternalPrepared then
3175 InternalPrepare;
3176 if (SQLParams.Count > 0) and (DataSource <> nil) and (DataSource.DataSet <> nil) then
3177 begin
3178 for i := 0 to SQLParams.Count - 1 do
3179 begin
3180 cur_field := DataSource.DataSet.FindField(SQLParams[i].Name);
3181 cur_param := SQLParams[i];
3182 if (cur_field <> nil) then begin
3183 if (cur_field.IsNull) then
3184 cur_param.IsNull := True
3185 else case cur_field.DataType of
3186 ftString:
3187 cur_param.AsString := cur_field.AsString;
3188 ftBoolean, ftSmallint, ftWord:
3189 cur_param.AsShort := cur_field.AsInteger;
3190 ftInteger:
3191 cur_param.AsLong := cur_field.AsInteger;
3192 ftLargeInt:
3193 cur_param.AsInt64 := TLargeIntField(cur_field).AsLargeInt;
3194 ftFloat, ftCurrency:
3195 cur_param.AsDouble := cur_field.AsFloat;
3196 ftBCD:
3197 cur_param.AsCurrency := cur_field.AsCurrency;
3198 ftDate:
3199 cur_param.AsDate := cur_field.AsDateTime;
3200 ftTime:
3201 cur_param.AsTime := cur_field.AsDateTime;
3202 ftDateTime:
3203 cur_param.AsDateTime := cur_field.AsDateTime;
3204 ftBlob, ftMemo:
3205 begin
3206 s := nil;
3207 try
3208 s := DataSource.DataSet.
3209 CreateBlobStream(cur_field, bmRead);
3210 cur_param.LoadFromStream(s);
3211 finally
3212 s.free;
3213 end;
3214 end;
3215 else
3216 IBError(ibxeNotSupported, [nil]);
3217 end;
3218 end;
3219 end;
3220 end;
3221 end;
3222
3223 procedure TIBCustomDataSet.ReQuery;
3224 begin
3225 FQSelect.Close;
3226 ClearBlobCache;
3227 FCurrentRecord := -1;
3228 FRecordCount := 0;
3229 FDeletedRecords := 0;
3230 FBPos := 0;
3231 FOBPos := 0;
3232 FBEnd := 0;
3233 FOBEnd := 0;
3234 FQSelect.Close;
3235 FQSelect.ExecQuery;
3236 FOpen := FQSelect.Open;
3237 First;
3238 end;
3239
3240 procedure TIBCustomDataSet.InternalOpen;
3241 var
3242 SetCursor: Boolean;
3243
3244 function RecordDataLength(n: Integer): Long;
3245 begin
3246 result := SizeOf(TRecordData) + ((n - 1) * SizeOf(TFieldData));
3247 end;
3248
3249 begin
3250 SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault);
3251 if SetCursor then
3252 Screen.Cursor := crHourGlass;
3253 try
3254 ActivateConnection;
3255 ActivateTransaction;
3256 if FQSelect.SQL.Text = '' then
3257 IBError(ibxeEmptyQuery, [nil]);
3258 if not FInternalPrepared then
3259 InternalPrepare;
3260 if FQSelect.SQLType = SQLSelect then
3261 begin
3262 if DefaultFields then
3263 CreateFields;
3264 BindFields(True);
3265 FCurrentRecord := -1;
3266 FQSelect.ExecQuery;
3267 FOpen := FQSelect.Open;
3268
3269 { Initialize offsets, buffer sizes, etc...
3270 1. Initially FRecordSize is just the "RecordDataLength".
3271 2. Allocate a "model" buffer and do a dummy fetch
3272 3. After the dummy fetch, FRecordSize will be appropriately
3273 adjusted to reflect the additional "weight" of the field
3274 data.
3275 4. Set up the FCalcFieldsOffset, FBlobCacheOffset and FRecordBufferSize.
3276 5. Now, with the BufferSize available, allocate memory for chunks of records
3277 6. Re-allocate the model buffer, accounting for the new
3278 FRecordBufferSize.
3279 7. Finally, calls to AllocRecordBuffer will work!.
3280 }
3281 {Step 1}
3282 FRecordSize := RecordDataLength(FQSelect.Current.Count);
3283 {Step 2, 3}
3284 IBAlloc(FModelBuffer, 0, FRecordSize);
3285 FetchCurrentRecordToBuffer(FQSelect, -1, FModelBuffer);
3286 {Step 4}
3287 FCalcFieldsOffset := FRecordSize;
3288 FBlobCacheOffset := FCalcFieldsOffset + CalcFieldsSize;
3289 FRecordBufferSize := (FBlobCacheOffset + (BlobFieldCount * SizeOf(TIBBlobStream)));
3290 {Step 5}
3291 if UniDirectional then
3292 FBufferChunkSize := FRecordBufferSize * UniCache
3293 else
3294 FBufferChunkSize := FRecordBufferSize * BufferChunks;
3295 IBAlloc(FBufferCache, FBufferChunkSize, FBufferChunkSize);
3296 if FCachedUpdates or (csReading in ComponentState) then
3297 IBAlloc(FOldBufferCache, FBufferChunkSize, FBufferChunkSize);
3298 FBPos := 0;
3299 FOBPos := 0;
3300 FBEnd := 0;
3301 FOBEnd := 0;
3302 FCacheSize := FBufferChunkSize;
3303 FOldCacheSize := FBufferChunkSize;
3304 {Step 6}
3305 IBAlloc(FModelBuffer, RecordDataLength(FQSelect.Current.Count),
3306 FRecordBufferSize);
3307 {Step 7}
3308 FOldBuffer := AllocRecordBuffer;
3309 end
3310 else
3311 FQSelect.ExecQuery;
3312 finally
3313 if SetCursor and (Screen.Cursor = crHourGlass) then
3314 Screen.Cursor := crDefault;
3315 end;
3316 end;
3317
3318 procedure TIBCustomDataSet.InternalPost;
3319 var
3320 Qry: TIBSQL;
3321 Buff: PChar;
3322 SetCursor: Boolean;
3323 bInserting: Boolean;
3324 begin
3325 SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault);
3326 if SetCursor then
3327 Screen.Cursor := crHourGlass;
3328 try
3329 Buff := GetActiveBuf;
3330 CheckEditState;
3331 AdjustRecordOnInsert(Buff);
3332 if (State = dsInsert) then
3333 begin
3334 bInserting := True;
3335 Qry := FQInsert;
3336 PRecordData(Buff)^.rdUpdateStatus := usInserted;
3337 PRecordData(Buff)^.rdCachedUpdateStatus := cusInserted;
3338 WriteRecordCache(FRecordCount, Buff);
3339 FCurrentRecord := FRecordCount;
3340 end
3341 else begin
3342 bInserting := False;
3343 Qry := FQModify;
3344 if PRecordData(Buff)^.rdCachedUpdateStatus = cusUnmodified then
3345 begin
3346 PRecordData(Buff)^.rdUpdateStatus := usModified;
3347 PRecordData(Buff)^.rdCachedUpdateStatus := cusModified;
3348 end
3349 else if PRecordData(Buff)^.
3350 rdCachedUpdateStatus = cusUninserted then
3351 begin
3352 PRecordData(Buff)^.rdCachedUpdateStatus := cusInserted;
3353 Dec(FDeletedRecords);
3354 end;
3355 end;
3356 if (not CachedUpdates) then
3357 InternalPostRecord(Qry, Buff)
3358 else begin
3359 WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Buff);
3360 FUpdatesPending := True;
3361 end;
3362 if bInserting then
3363 Inc(FRecordCount);
3364 finally
3365 if SetCursor and (Screen.Cursor = crHourGlass) then
3366 Screen.Cursor := crDefault;
3367 end;
3368 end;
3369
3370 procedure TIBCustomDataSet.InternalRefresh;
3371 begin
3372 inherited InternalRefresh;
3373 InternalRefreshRow;
3374 end;
3375
3376 procedure TIBCustomDataSet.InternalSetToRecord(Buffer: PChar);
3377 begin
3378 InternalGotoBookmark(@(PRecordData(Buffer)^.rdRecordNumber));
3379 end;
3380
3381 function TIBCustomDataSet.IsCursorOpen: Boolean;
3382 begin
3383 result := FOpen;
3384 end;
3385
3386 function TIBCustomDataSet.Locate(const KeyFields: string; const KeyValues: Variant;
3387 Options: TLocateOptions): Boolean;
3388 var
3389 {$IF FPC_FULLVERSION > 20600 }
3390 CurBookmark: TBookmark;
3391 {$ELSE}
3392 CurBookmark: string;
3393 {$ENDIF}
3394 begin
3395 DisableControls;
3396 try
3397 CurBookmark := Bookmark;
3398 First;
3399 result := InternalLocate(KeyFields, KeyValues, Options);
3400 if not result then
3401 Bookmark := CurBookmark;
3402 finally
3403 EnableControls;
3404 end;
3405 end;
3406
3407 function TIBCustomDataSet.Lookup(const KeyFields: string; const KeyValues: Variant;
3408 const ResultFields: string): Variant;
3409 var
3410 fl: TList;
3411 {$IF FPC_FULLVERSION > 20600 }
3412 CurBookmark: TBookmark;
3413 {$ELSE}
3414 CurBookmark: string;
3415 {$ENDIF}
3416 begin
3417 DisableControls;
3418 fl := TList.Create;
3419 CurBookmark := Bookmark;
3420 try
3421 First;
3422 if InternalLocate(KeyFields, KeyValues, []) then
3423 begin
3424 if (ResultFields <> '') then
3425 result := FieldValues[ResultFields]
3426 else
3427 result := NULL;
3428 end
3429 else
3430 result := Null;
3431 finally
3432 Bookmark := CurBookmark;
3433 fl.Free;
3434 EnableControls;
3435 end;
3436 end;
3437
3438 procedure TIBCustomDataSet.SetBookmarkData(Buffer: PChar; Data: Pointer);
3439 begin
3440 PRecordData(Buffer)^.rdRecordNumber := PInteger(Data)^;
3441 end;
3442
3443 procedure TIBCustomDataSet.SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag);
3444 begin
3445 PRecordData(Buffer)^.rdBookmarkFlag := Value;
3446 end;
3447
3448 procedure TIBCustomDataSet.SetCachedUpdates(Value: Boolean);
3449 begin
3450 if not Value and FCachedUpdates then
3451 CancelUpdates;
3452 if (not (csReading in ComponentState)) and Value then
3453 CheckDatasetClosed;
3454 FCachedUpdates := Value;
3455 end;
3456
3457 procedure TIBCustomDataSet.SetDataSource(Value: TDataSource);
3458 begin
3459 if IsLinkedTo(Value) then
3460 IBError(ibxeCircularReference, [nil]);
3461 if FDataLink <> nil then
3462 FDataLink.DataSource := Value;
3463 end;
3464
3465 procedure TIBCustomDataSet.InternalSetFieldData(Field: TField; Buffer: Pointer);
3466 var
3467 Buff, TmpBuff: PChar;
3468 begin
3469 Buff := GetActiveBuf;
3470 if Field.FieldNo < 0 then
3471 begin
3472 TmpBuff := Buff + FRecordSize + Field.Offset;
3473 Boolean(TmpBuff[0]) := LongBool(Buffer);
3474 if Boolean(TmpBuff[0]) then
3475 Move(Buffer^, TmpBuff[1], Field.DataSize);
3476 WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Buff);
3477 end
3478 else begin
3479 CheckEditState;
3480 with PRecordData(Buff)^ do
3481 begin
3482 { If inserting, Adjust record position }
3483 AdjustRecordOnInsert(Buff);
3484 if (FMappedFieldPosition[Field.FieldNo - 1] > 0) and
3485 (FMappedFieldPosition[Field.FieldNo - 1] <= rdFieldCount) then
3486 begin
3487 Field.Validate(Buffer);
3488 if (Buffer = nil) or
3489 (Field is TIBStringField) and (PChar(Buffer)[0] = #0) then
3490 rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdIsNull := True
3491 else begin
3492 Move(Buffer^, Buff[rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataOfs],
3493 rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataSize);
3494 if (rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataType = SQL_TEXT) or
3495 (rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataType = SQL_VARYING) then
3496 rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataLength := StrLen(PChar(Buffer));
3497 rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdIsNull := False;
3498 if rdUpdateStatus = usUnmodified then
3499 begin
3500 if CachedUpdates then
3501 begin
3502 FUpdatesPending := True;
3503 if State = dsInsert then
3504 rdCachedUpdateStatus := cusInserted
3505 else if State = dsEdit then
3506 rdCachedUpdateStatus := cusModified;
3507 end;
3508
3509 if State = dsInsert then
3510 rdUpdateStatus := usInserted
3511 else
3512 rdUpdateStatus := usModified;
3513 end;
3514 WriteRecordCache(rdRecordNumber, Buff);
3515 SetModified(True);
3516 end;
3517 end;
3518 end;
3519 end;
3520 if not (State in [dsCalcFields, dsFilter, dsNewValue]) then
3521 DataEvent(deFieldChange, PtrInt(Field));
3522 end;
3523
3524 procedure TIBCustomDataSet.SetRecNo(Value: Integer);
3525 begin
3526 CheckBrowseMode;
3527 if (Value < 1) then
3528 Value := 1
3529 else if Value > FRecordCount then
3530 begin
3531 InternalLast;
3532 Value := Min(FRecordCount, Value);
3533 end;
3534 if (Value <> RecNo) then
3535 begin
3536 DoBeforeScroll;
3537 FCurrentRecord := Value - 1;
3538 Resync([]);
3539 DoAfterScroll;
3540 end;
3541 end;
3542
3543 procedure TIBCustomDataSet.Disconnect;
3544 begin
3545 Close;
3546 InternalUnPrepare;
3547 end;
3548
3549 procedure TIBCustomDataSet.SetUpdateMode(const Value: TUpdateMode);
3550 begin
3551 if not CanModify then
3552 IBError(ibxeCannotUpdate, [nil])
3553 else
3554 FUpdateMode := Value;
3555 end;
3556
3557
3558 procedure TIBCustomDataSet.SetUpdateObject(Value: TIBDataSetUpdateObject);
3559 begin
3560 if Value <> FUpdateObject then
3561 begin
3562 if Assigned(FUpdateObject) and (FUpdateObject.DataSet = Self) then
3563 FUpdateObject.DataSet := nil;
3564 FUpdateObject := Value;
3565 if Assigned(FUpdateObject) then
3566 begin
3567 if Assigned(FUpdateObject.DataSet) and
3568 (FUpdateObject.DataSet <> Self) then
3569 FUpdateObject.DataSet.UpdateObject := nil;
3570 FUpdateObject.DataSet := Self;
3571 end;
3572 end;
3573 end;
3574
3575 function TIBCustomDataSet.ConstraintsStored: Boolean;
3576 begin
3577 Result := Constraints.Count > 0;
3578 end;
3579
3580 procedure TIBCustomDataSet.ClearCalcFields(Buffer: PChar);
3581 begin
3582 FillChar(Buffer[FRecordSize], CalcFieldsSize, 0);
3583 end;
3584
3585
3586 procedure TIBCustomDataSet.InternalUnPrepare;
3587 begin
3588 if FInternalPrepared then
3589 begin
3590 CheckDatasetClosed;
3591 FieldDefs.Clear;
3592 FInternalPrepared := False;
3593 end;
3594 end;
3595
3596 procedure TIBCustomDataSet.InternalExecQuery;
3597 var
3598 DidActivate: Boolean;
3599 SetCursor: Boolean;
3600 begin
3601 DidActivate := False;
3602 SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault);
3603 if SetCursor then
3604 Screen.Cursor := crHourGlass;
3605 try
3606 ActivateConnection;
3607 DidActivate := ActivateTransaction;
3608 if FQSelect.SQL.Text = '' then
3609 IBError(ibxeEmptyQuery, [nil]);
3610 if not FInternalPrepared then
3611 InternalPrepare;
3612 if FQSelect.SQLType = SQLSelect then
3613 begin
3614 IBError(ibxeIsASelectStatement, [nil]);
3615 end
3616 else
3617 FQSelect.ExecQuery;
3618 finally
3619 if DidActivate then
3620 DeactivateTransaction;
3621 if SetCursor and (Screen.Cursor = crHourGlass) then
3622 Screen.Cursor := crDefault;
3623 end;
3624 end;
3625
3626 function TIBCustomDataSet.GetSelectStmtHandle: TISC_STMT_HANDLE;
3627 begin
3628 Result := FQSelect.Handle;
3629 end;
3630
3631 procedure TIBCustomDataSet.InitRecord(Buffer: PChar);
3632 begin
3633 inherited InitRecord(Buffer);
3634 with PRecordData(Buffer)^ do
3635 begin
3636 rdUpdateStatus := TUpdateStatus(usInserted);
3637 rdBookMarkFlag := bfInserted;
3638 rdRecordNumber := -1;
3639 end;
3640 end;
3641
3642 procedure TIBCustomDataSet.InternalInsert;
3643 begin
3644 CursorPosChanged;
3645 end;
3646
3647 { TIBDataSet IProviderSupport }
3648
3649 (*procedure TIBCustomDataSet.PSEndTransaction(Commit: Boolean);
3650 begin
3651 if Commit then
3652 Transaction.Commit else
3653 Transaction.Rollback;
3654 end;
3655
3656 function TIBCustomDataSet.PSExecuteStatement(const ASQL: string; AParams: TParams;
3657 ResultSet: Pointer = nil): Integer;
3658 var
3659 FQuery: TIBQuery;
3660 begin
3661 if Assigned(ResultSet) then
3662 begin
3663 TDataSet(ResultSet^) := TIBQuery.Create(nil);
3664 with TIBQuery(ResultSet^) do
3665 begin
3666 SQL.Text := ASQL;
3667 Params.Assign(AParams);
3668 Open;
3669 Result := RowsAffected;
3670 end;
3671 end
3672 else
3673 begin
3674 FQuery := TIBQuery.Create(nil);
3675 try
3676 FQuery.Database := Database;
3677 FQuery.Transaction := Transaction;
3678 FQuery.GenerateParamNames := True;
3679 FQuery.SQL.Text := ASQL;
3680 FQuery.Params.Assign(AParams);
3681 FQuery.ExecSQL;
3682 Result := FQuery.RowsAffected;
3683 finally
3684 FQuery.Free;
3685 end;
3686 end;
3687 end;
3688
3689 function TIBCustomDataSet.PSGetQuoteChar: string;
3690 begin
3691 if Database.SQLDialect = 3 then
3692 Result := '"' else
3693 Result := '';
3694 end;
3695
3696 function TIBCustomDataSet.PSGetUpdateException(E: Exception; Prev: EUpdateError): EUpdateError;
3697 var
3698 PrevErr: Integer;
3699 begin
3700 if Prev <> nil then
3701 PrevErr := Prev.ErrorCode else
3702 PrevErr := 0;
3703 if E is EIBError then
3704 with EIBError(E) do
3705 Result := EUpdateError.Create(E.Message, '', SQLCode, PrevErr, E) else
3706 Result := inherited PSGetUpdateException(E, Prev);
3707 end;
3708
3709 function TIBCustomDataSet.PSInTransaction: Boolean;
3710 begin
3711 Result := Transaction.InTransaction;
3712 end;
3713
3714 function TIBCustomDataSet.PSIsSQLBased: Boolean;
3715 begin
3716 Result := True;
3717 end;
3718
3719 function TIBCustomDataSet.PSIsSQLSupported: Boolean;
3720 begin
3721 Result := True;
3722 end;
3723
3724 procedure TIBCustomDataSet.PSReset;
3725 begin
3726 inherited PSReset;
3727 if Active then
3728 begin
3729 Close;
3730 Open;
3731 end;
3732 end;
3733
3734 function TIBCustomDataSet.PSUpdateRecord(UpdateKind: TUpdateKind; Delta: TDataSet): Boolean;
3735 var
3736 UpdateAction: TIBUpdateAction;
3737 SQL: string;
3738 Params: TParams;
3739
3740 procedure AssignParams(DataSet: TDataSet; Params: TParams);
3741 var
3742 I: Integer;
3743 Old: Boolean;
3744 Param: TParam;
3745 PName: string;
3746 Field: TField;
3747 Value: Variant;
3748 begin
3749 for I := 0 to Params.Count - 1 do
3750 begin
3751 Param := Params[I];
3752 PName := Param.Name;
3753 Old := CompareText(Copy(PName, 1, 4), 'OLD_') = 0; {do not localize}
3754 if Old then System.Delete(PName, 1, 4);
3755 Field := DataSet.FindField(PName);
3756 if not Assigned(Field) then Continue;
3757 if Old then Param.AssignFieldValue(Field, Field.OldValue) else
3758 begin
3759 Value := Field.NewValue;
3760 if VarIsEmpty(Value) then Value := Field.OldValue;
3761 Param.AssignFieldValue(Field, Value);
3762 end;
3763 end;
3764 end;
3765
3766 begin
3767 Result := False;
3768 if Assigned(OnUpdateRecord) then
3769 begin
3770 UpdateAction := uaFail;
3771 if Assigned(FOnUpdateRecord) then
3772 begin
3773 FOnUpdateRecord(Delta, UpdateKind, UpdateAction);
3774 Result := UpdateAction = uaApplied;
3775 end;
3776 end
3777 else if Assigned(FUpdateObject) then
3778 begin
3779 SQL := FUpdateObject.GetSQL(UpdateKind).Text;
3780 if SQL <> '' then
3781 begin
3782 Params := TParams.Create;
3783 try
3784 Params.ParseSQL(SQL, True);
3785 AssignParams(Delta, Params);
3786 if PSExecuteStatement(SQL, Params) = 0 then
3787 IBError(ibxeNoRecordsAffected, [nil]);
3788 Result := True;
3789 finally
3790 Params.Free;
3791 end;
3792 end;
3793 end;
3794 end;
3795
3796 procedure TIBCustomDataSet.PSStartTransaction;
3797 begin
3798 ActivateConnection;
3799 Transaction.StartTransaction;
3800 end;
3801
3802 function TIBCustomDataSet.PSGetTableName: string;
3803 begin
3804 // if not FInternalPrepared then
3805 // InternalPrepare;
3806 { It is possible for the FQSelectSQL to be unprepared
3807 with FInternalPreprepared being true (see DoBeforeTransactionEnd).
3808 So check the Prepared of the SelectSQL instead }
3809 if not FQSelect.Prepared then
3810 FQSelect.Prepare;
3811 Result := FQSelect.UniqueRelationName;
3812 end;*)
3813
3814 procedure TIBDataSet.BatchInput(InputObject: TIBBatchInput);
3815 begin
3816 InternalBatchInput(InputObject);
3817 end;
3818
3819 procedure TIBDataSet.BatchOutput(OutputObject: TIBBatchOutput);
3820 begin
3821 InternalBatchOutput(OutputObject);
3822 end;
3823
3824 procedure TIBDataSet.ExecSQL;
3825 begin
3826 InternalExecQuery;
3827 end;
3828
3829 procedure TIBDataSet.Prepare;
3830 begin
3831 InternalPrepare;
3832 end;
3833
3834 procedure TIBDataSet.UnPrepare;
3835 begin
3836 InternalUnPrepare;
3837 end;
3838
3839 function TIBDataSet.GetPrepared: Boolean;
3840 begin
3841 Result := InternalPrepared;
3842 end;
3843
3844 procedure TIBDataSet.InternalOpen;
3845 begin
3846 ActivateConnection;
3847 ActivateTransaction;
3848 InternalSetParamsFromCursor;
3849 Inherited InternalOpen;
3850 end;
3851
3852 procedure TIBDataSet.SetFiltered(Value: Boolean);
3853 begin
3854 if(Filtered <> Value) then
3855 begin
3856 inherited SetFiltered(value);
3857 if Active then
3858 begin
3859 Close;
3860 Open;
3861 end;
3862 end
3863 else
3864 inherited SetFiltered(value);
3865 end;
3866
3867 function TIBCustomDataSet.BookmarkValid(Bookmark: TBookmark): Boolean;
3868 begin
3869 Result := false;
3870 if not Assigned(Bookmark) then
3871 exit;
3872 Result := PInteger(Bookmark)^ < FRecordCount;
3873 end;
3874
3875 function TIBCustomDataSet.GetFieldData(Field: TField;
3876 Buffer: Pointer): Boolean;
3877 {$IFDEF TBCDFIELD_IS_BCD}
3878 var
3879 lTempCurr : System.Currency;
3880 begin
3881 if (Field.DataType = ftBCD) and (Buffer <> nil) then
3882 begin
3883 Result := InternalGetFieldData(Field, @lTempCurr);
3884 if Result then
3885 CurrToBCD(lTempCurr, TBCD(Buffer^), 32, Field.Size);
3886 end
3887 else
3888 {$ELSE}
3889 begin
3890 {$ENDIF}
3891 Result := InternalGetFieldData(Field, Buffer);
3892 end;
3893
3894 function TIBCustomDataSet.GetFieldData(Field: TField; Buffer: Pointer;
3895 NativeFormat: Boolean): Boolean;
3896 begin
3897 if (Field.DataType = ftBCD) and not NativeFormat then
3898 Result := InternalGetFieldData(Field, Buffer)
3899 else
3900 Result := inherited GetFieldData(Field, Buffer, NativeFormat);
3901 end;
3902
3903 procedure TIBCustomDataSet.SetFieldData(Field: TField; Buffer: Pointer);
3904 {$IFDEF TDBDFIELD_IS_BCD}
3905 var
3906 lTempCurr : System.Currency;
3907 begin
3908 if (Field.DataType = ftBCD) and (Buffer <> nil) then
3909 begin
3910 BCDToCurr(TBCD(Buffer^), lTempCurr);
3911 InternalSetFieldData(Field, @lTempCurr);
3912 end
3913 else
3914 {$ELSE}
3915 begin
3916 {$ENDIF}
3917 InternalSetFieldData(Field, Buffer);
3918 end;
3919
3920 procedure TIBCustomDataSet.SetFieldData(Field: TField; Buffer: Pointer;
3921 NativeFormat: Boolean);
3922 begin
3923 if (not NativeFormat) and (Field.DataType = ftBCD) then
3924 InternalSetfieldData(Field, Buffer)
3925 else
3926 inherited SetFieldData(Field, buffer, NativeFormat);
3927 end;
3928
3929 { TIBDataSetUpdateObject }
3930
3931 constructor TIBDataSetUpdateObject.Create(AOwner: TComponent);
3932 begin
3933 inherited Create(AOwner);
3934 FRefreshSQL := TStringList.Create;
3935 end;
3936
3937 destructor TIBDataSetUpdateObject.Destroy;
3938 begin
3939 FRefreshSQL.Free;
3940 inherited Destroy;
3941 end;
3942
3943 procedure TIBDataSetUpdateObject.SetRefreshSQL(Value: TStrings);
3944 begin
3945 FRefreshSQL.Assign(Value);
3946 end;
3947
3948 procedure TIBDataSetUpdateObject.InternalSetParams(Query: TIBSQL; buff: PChar);
3949 begin
3950 if not Assigned(DataSet) then Exit;
3951 DataSet.SetInternalSQLParams(Query, buff);
3952 end;
3953
3954 { TIBDSBlobStream }
3955 constructor TIBDSBlobStream.Create(AField: TField; ABlobStream: TIBBlobStream;
3956 Mode: TBlobStreamMode);
3957 begin
3958 FField := AField;
3959 FBlobStream := ABlobStream;
3960 FBlobStream.Seek(0, soFromBeginning);
3961 if (Mode = bmWrite) then
3962 FBlobStream.Truncate;
3963 end;
3964
3965 function TIBDSBlobStream.Read(var Buffer; Count: Longint): Longint;
3966 begin
3967 result := FBlobStream.Read(Buffer, Count);
3968 end;
3969
3970 function TIBDSBlobStream.Seek(Offset: Longint; Origin: Word): Longint;
3971 begin
3972 result := FBlobStream.Seek(Offset, Origin);
3973 end;
3974
3975 procedure TIBDSBlobStream.SetSize(NewSize: Longint);
3976 begin
3977 FBlobStream.SetSize(NewSize);
3978 end;
3979
3980 function TIBDSBlobStream.Write(const Buffer; Count: Longint): Longint;
3981 begin
3982 if not (FField.DataSet.State in [dsEdit, dsInsert]) then
3983 IBError(ibxeNotEditing, [nil]);
3984 TIBCustomDataSet(FField.DataSet).RecordModified(True);
3985 TBlobField(FField).Modified := true;
3986 result := FBlobStream.Write(Buffer, Count);
3987 TIBCustomDataSet(FField.DataSet).DataEvent(deFieldChange, PtrInt(FField));
3988 end;
3989
3990 { TIBGenerator }
3991
3992 procedure TIBGenerator.SetIncrement(const AValue: integer);
3993 begin
3994 if AValue < 0 then
3995 raise Exception.Create('A Generator Increment cannot be negative');
3996 FIncrement := AValue
3997 end;
3998
3999 function TIBGenerator.GetNextValue(ADatabase: TIBDatabase;
4000 ATransaction: TIBTransaction): integer;
4001 begin
4002 with TIBSQL.Create(nil) do
4003 try
4004 Database := ADatabase;
4005 Transaction := ATransaction;
4006 if not assigned(Database) then
4007 IBError(ibxeCannotSetDatabase,[]);
4008 if not assigned(Transaction) then
4009 IBError(ibxeCannotSetTransaction,[]);
4010 with Transaction do
4011 if not InTransaction then StartTransaction;
4012 SQL.Text := Format('Select Gen_ID(%s,%d) as ID From RDB$Database',[FGeneratorName,Increment]);
4013 Prepare;
4014 ExecQuery;
4015 try
4016 Result := FieldByName('ID').AsInteger
4017 finally
4018 Close
4019 end;
4020 finally
4021 Free
4022 end;
4023 end;
4024
4025 constructor TIBGenerator.Create(Owner: TIBCustomDataSet);
4026 begin
4027 FOwner := Owner;
4028 FIncrement := 1;
4029 end;
4030
4031
4032 procedure TIBGenerator.Apply;
4033 begin
4034 if (FGeneratorName <> '') and (FFieldName <> '') then
4035 Owner.FieldByName(FFieldName).AsInteger := GetNextValue(Owner.Database,Owner.Transaction);
4036 end;
4037
4038 end.