ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/IBCustomDataSet.pas
Revision: 1
Committed: Mon Jul 31 16:43:00 2000 UTC (24 years, 4 months ago) by tony
Content type: text/x-pascal
File size: 109527 byte(s)
Log Message:
Borland IBX Open Source Release

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