ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/IBCustomDataSet.pas
Revision: 41
Committed: Sat Jul 16 12:25:48 2016 UTC (7 years, 8 months ago) by tony
Content type: text/x-pascal
File size: 137556 byte(s)
Log Message:
Committing updates for Release R1-4-2

File Contents

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