ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/IBCustomDataSet.pas
Revision: 21
Committed: Thu Feb 26 10:33:34 2015 UTC (9 years, 1 month ago) by tony
Content type: text/x-pascal
File size: 125110 byte(s)
Log Message:
Committing updates for Release R1-2-0

File Contents

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