ViewVC Help

View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing

root/public/ibx/trunk/runtime/IBCustomDataSet.pas

Comparing ibx/trunk/runtime/IBCustomDataSet.pas (file contents):
Revision 1 by tony, Mon Jul 31 16:43:00 2000 UTC vs.
Revision 37 by tony, Mon Feb 15 14:44:25 2016 UTC

#	Line 24 | Line 24
24		{       Corporation. All Rights Reserved.                                }
25		{    Contributor(s): Jeff Overcash                                       }
26		{                                                                        }
27	+	{    IBX For Lazarus (Firebird Express)                                  }
28	+	{    Contributor: Tony Whyman, MWA Software http://www.mwasoftware.co.uk }
29	+	{    Portions created by MWA Software are copyright McCallum Whyman      }
30	+	{    Associates Ltd 2011 - 2015                                                }
31	+	{                                                                        }
32		{************************************************************************}
33
34		unit IBCustomDataSet;
35
36	+	{$R-}
37	+
38	+	{$Mode Delphi}
39	+
40	+	{$IFDEF DELPHI}
41	+	{$DEFINE TDBDFIELD_IS_BCD}
42	+	{$ENDIF}
43	+
44		interface
45
46		uses
47	<	Windows, SysUtils, Classes, Forms, Controls, StdVCL,
48	<	IBExternals, IB, IBHeader, IBDatabase, IBSQL, Db,
49	<	IBUtils, IBBlob;
47	>	{$IFDEF WINDOWS }
48	>	Windows,
49	>	{$ELSE}
50	>	unix,
51	>	{$ENDIF}
52	>	SysUtils, Classes, IBDatabase, IBExternals, IB, IBHeader,  IBSQL, Db,
53	>	IBUtils, IBBlob, IBSQLParser;
54
55		const
56		BufferCacheSize    =  1000;  { Allocate cache in this many record chunks}
#	Line 43 | Line 60 | type
60		TIBCustomDataSet = class;
61		TIBDataSet = class;
62
63	+	{ TIBDataSetUpdateObject }
64	+
65		TIBDataSetUpdateObject = class(TComponent)
66		private
67		FRefreshSQL: TStrings;
#	Line 50 | Line 69 | type
69		protected
70		function GetDataSet: TIBCustomDataSet; virtual; abstract;
71		procedure SetDataSet(ADataSet: TIBCustomDataSet); virtual; abstract;
72	<	procedure Apply(UpdateKind: TUpdateKind); virtual; abstract;
72	>	procedure Apply(UpdateKind: TUpdateKind; buff: PChar); virtual; abstract;
73		function GetSQL(UpdateKind: TUpdateKind): TStrings; virtual; abstract;
74	+	procedure InternalSetParams(Query: TIBSQL; buff: PChar);
75		property DataSet: TIBCustomDataSet read GetDataSet write SetDataSet;
76		public
77		constructor Create(AOwner: TComponent); override;
#	Line 60 | Line 80 | type
80		property RefreshSQL: TStrings read FRefreshSQL write SetRefreshSQL;
81		end;
82
63	–	PDateTime = ^TDateTime;
83		TBlobDataArray = array[0..0] of TIBBlobStream;
84		PBlobDataArray = ^TBlobDataArray;
85
#	Line 88 | Line 107 | type
107		TRecordData = record
108		rdBookmarkFlag: TBookmarkFlag;
109		rdFieldCount: Short;
110	<	rdRecordNumber: Long;
110	>	rdRecordNumber: Integer;
111		rdCachedUpdateStatus: TCachedUpdateStatus;
112		rdUpdateStatus: TUpdateStatus;
113		rdSavedOffset: DWORD;
#	Line 100 | Line 119 | type
119		{ TIBStringField allows us to have strings longer than 8196 }
120
121		TIBStringField = class(TStringField)
122	+	private
123	+	FCharacterSetName: string;
124	+	FCharacterSetSize: integer;
125	+	protected
126	+	function GetDefaultWidth: Longint; override;
127		public
128	<	constructor create(AOwner: TComponent); override;
128	>	constructor Create(aOwner: TComponent); override;
129		class procedure CheckTypeSize(Value: Integer); override;
130		function GetAsString: string; override;
131		function GetAsVariant: Variant; override;
132		function GetValue(var Value: string): Boolean;
133		procedure SetAsString(const Value: string); override;
134	+	property CharacterSetName: string read FCharacterSetName write FCharacterSetName;
135	+	property CharacterSetSize: integer read FCharacterSetSize write FCharacterSetSize;
136	+	end;
137	+
138	+	{ TIBWideStringField }
139	+
140	+	TIBWideStringField = class(TWideStringField)
141	+	private
142	+	FCharacterSetName: string;
143	+	FCharacterSetSize: integer;
144	+	public
145	+	property CharacterSetName: string read FCharacterSetName write FCharacterSetName;
146	+	property CharacterSetSize: integer read FCharacterSetSize write FCharacterSetSize;
147		end;
148
149		{ TIBBCDField }
#	Line 129 | Line 166 | type
166		property Size default 8;
167		end;
168
169	+	{TIBMemoField}
170	+	{Allows us to show truncated text in DBGrids and anything else that uses
171	+	DisplayText}
172	+
173	+	TIBMemoField = class(TMemoField)
174	+	private
175	+	FCharacterSetName: string;
176	+	FCharacterSetSize: integer;
177	+	FDisplayTextAsClassName: boolean;
178	+	function GetTruncatedText: string;
179	+	protected
180	+	function GetDefaultWidth: Longint; override;
181	+	procedure GetText(var AText: string; ADisplayText: Boolean); override;
182	+	public
183	+	constructor Create(AOwner: TComponent); override;
184	+	property CharacterSetName: string read FCharacterSetName write FCharacterSetName;
185	+	property CharacterSetSize: integer read FCharacterSetSize write FCharacterSetSize;
186	+	published
187	+	property DisplayTextAsClassName: boolean read FDisplayTextAsClassName
188	+	write FDisplayTextAsClassName;
189	+	end;
190	+
191	+	{ TIBWideMemoField }
192	+
193	+	TIBWideMemoField = class(TWideMemoField)
194	+	private
195	+	FCharacterSetName: string;
196	+	FCharacterSetSize: integer;
197	+	FDisplayTextAsClassName: boolean;
198	+	function GetTruncatedText: string;
199	+	protected
200	+	function GetDefaultWidth: Longint; override;
201	+	procedure GetText(var AText: string; ADisplayText: Boolean); override;
202	+	public
203	+	constructor Create(AOwner: TComponent); override;
204	+	property CharacterSetName: string read FCharacterSetName write FCharacterSetName;
205	+	property CharacterSetSize: integer read FCharacterSetSize write FCharacterSetSize;
206	+	published
207	+	property DisplayTextAsClassName: boolean read FDisplayTextAsClassName
208	+	write FDisplayTextAsClassName;
209	+	end;
210	+
211		TIBDataLink = class(TDetailDataLink)
212		private
213		FDataSet: TIBCustomDataSet;
#	Line 142 | Line 221 | type
221		destructor Destroy; override;
222		end;
223
224	+	TIBGeneratorApplyOnEvent = (gaeOnNewRecord,gaeOnPostRecord);
225	+
226	+	{ TIBGenerator }
227	+
228	+	TIBGenerator = class(TPersistent)
229	+	private
230	+	FOwner: TIBCustomDataSet;
231	+	FApplyOnEvent: TIBGeneratorApplyOnEvent;
232	+	FFieldName: string;
233	+	FGeneratorName: string;
234	+	FIncrement: integer;
235	+	procedure SetIncrement(const AValue: integer);
236	+	protected
237	+	function GetNextValue(ADatabase: TIBDatabase; ATransaction: TIBTransaction): integer;
238	+	public
239	+	constructor Create(Owner: TIBCustomDataSet);
240	+	procedure Apply;
241	+	property Owner: TIBCustomDataSet read FOwner;
242	+	published
243	+	property Generator: string read FGeneratorName write FGeneratorName;
244	+	property Field: string read FFieldName write FFieldName;
245	+	property Increment: integer read FIncrement write SetIncrement default 1;
246	+	property ApplyOnEvent: TIBGeneratorApplyOnEvent read FApplyOnEvent write FApplyOnEvent;
247	+	end;
248	+
249	+	{TIBControlLink - Allows IB Aware controls to react to dataset state changes}
250	+
251	+	TIBControlLink = class
252	+	private
253	+	FTIBDataSet: TIBCustomDataSet;
254	+	procedure SetIBDataSet(AValue: TIBCustomDataSet);
255	+	protected
256	+	procedure UpdateSQL(Sender: TObject); virtual;
257	+	procedure UpdateParams(Sender: TObject); virtual;
258	+	public
259	+	destructor Destroy; override;
260	+	property IBDataSet: TIBCustomDataSet read FTIBDataSet write SetIBDataSet;
261	+	end;
262	+
263	+	TIBAutoCommit = (acDisabled, acCommitRetaining);
264	+
265		{ TIBCustomDataSet }
266		TIBUpdateAction = (uaFail, uaAbort, uaSkip, uaRetry, uaApply, uaApplied);
267
268		TIBUpdateErrorEvent = procedure(DataSet: TDataSet; E: EDatabaseError;
269	<	UpdateKind: TUpdateKind; var UpdateAction: TIBUpdateAction)
269	>	UpdateKind: TUpdateKind; var TheUpdateAction: TIBUpdateAction)
270		of object;
271		TIBUpdateRecordEvent = procedure(DataSet: TDataSet; UpdateKind: TUpdateKind;
272		var UpdateAction: TIBUpdateAction) of object;
273
274		TIBUpdateRecordTypes = set of TCachedUpdateStatus;
275
276	+	TDataSetCloseAction = (dcDiscardChanges, dcSaveChanges);
277	+
278	+	TOnValidatePost = procedure (Sender: TObject; var CancelPost: boolean) of object;
279	+
280		TIBCustomDataSet = class(TDataset)
281		private
282	+	FAutoCommit: TIBAutoCommit;
283	+	FGenerateParamNames: Boolean;
284	+	FGeneratorField: TIBGenerator;
285		FNeedsRefresh: Boolean;
286		FForcedRefresh: Boolean;
287		FDidActivate: Boolean;
#	Line 179 | Line 306 | type
306		FDeletedRecords: Long;
307		FModelBuffer,
308		FOldBuffer: PChar;
309	+	FOnValidatePost: TOnValidatePost;
310		FOpen: Boolean;
311		FInternalPrepared: Boolean;
312		FQDelete,
#	Line 189 | Line 317 | type
317		FRecordBufferSize: Integer;
318		FRecordCount: Integer;
319		FRecordSize: Integer;
320	+	FDataSetCloseAction: TDataSetCloseAction;
321		FUniDirectional: Boolean;
322		FUpdateMode: TUpdateMode;
323		FUpdateObject: TIBDataSetUpdateObject;
#	Line 206 | Line 335 | type
335		FBeforeTransactionEnd,
336		FAfterTransactionEnd,
337		FTransactionFree: TNotifyEvent;
338	<
338	>	FAliasNameMap: array of string;
339	>	FAliasNameList: array of string;
340	>	FBaseSQLSelect: TStrings;
341	>	FParser: TSelectSQLParser;
342	>	FCloseAction: TTransactionAction;
343	>	FInTransactionEnd: boolean;
344	>	FIBLinks: TList;
345		function GetSelectStmtHandle: TISC_STMT_HANDLE;
346		procedure SetUpdateMode(const Value: TUpdateMode);
347		procedure SetUpdateObject(Value: TIBDataSetUpdateObject);
#	Line 219 | Line 354 | type
354		function CanRefresh: Boolean;
355		procedure CheckEditState;
356		procedure ClearBlobCache;
357	+	procedure ClearIBLinks;
358		procedure CopyRecordBuffer(Source, Dest: Pointer);
359		procedure DoBeforeDatabaseDisconnect(Sender: TObject);
360		procedure DoAfterDatabaseDisconnect(Sender: TObject);
361		procedure DoDatabaseFree(Sender: TObject);
362	<	procedure DoBeforeTransactionEnd(Sender: TObject);
362	>	procedure DoBeforeTransactionEnd(Sender: TObject; Action: TTransactionAction);
363		procedure DoAfterTransactionEnd(Sender: TObject);
364		procedure DoTransactionFree(Sender: TObject);
365		procedure FetchCurrentRecordToBuffer(Qry: TIBSQL; RecordNumber: Integer;
#	Line 239 | Line 375 | type
375		function GetModifySQL: TStrings;
376		function GetTransaction: TIBTransaction;
377		function GetTRHandle: PISC_TR_HANDLE;
378	<	procedure InternalDeleteRecord(Qry: TIBSQL; Buff: Pointer);
378	>	function GetParser: TSelectSQLParser;
379	>	procedure InternalDeleteRecord(Qry: TIBSQL; Buff: Pointer); virtual;
380		function InternalLocate(const KeyFields: string; const KeyValues: Variant;
381		Options: TLocateOptions): Boolean; virtual;
382	<	procedure InternalPostRecord(Qry: TIBSQL; Buff: Pointer);
383	<	procedure InternalRevertRecord(RecordNumber: Integer);
382	>	procedure InternalPostRecord(Qry: TIBSQL; Buff: Pointer); virtual;
383	>	procedure InternalRevertRecord(RecordNumber: Integer); virtual;
384		function IsVisible(Buffer: PChar): Boolean;
385	+	procedure RegisterIBLink(Sender: TIBControlLink);
386	+	procedure UnRegisterIBLink(Sender: TIBControlLink);
387		procedure SaveOldBuffer(Buffer: PChar);
388		procedure SetBufferChunks(Value: Integer);
389		procedure SetDatabase(Value: TIBDatabase);
#	Line 258 | Line 397 | type
397		procedure SetUpdateRecordTypes(Value: TIBUpdateRecordTypes);
398		procedure SetUniDirectional(Value: Boolean);
399		procedure RefreshParams;
261	–	procedure SQLChanging(Sender: TObject); virtual;
400		function AdjustPosition(FCache: PChar; Offset: DWORD;
401	<	Origin: Integer): Integer;
401	>	Origin: Integer): DWORD;
402		procedure ReadCache(FCache: PChar; Offset: DWORD; Origin: Integer;
403		Buffer: PChar);
404		procedure ReadRecordCache(RecordNumber: Integer; Buffer: PChar;
#	Line 269 | Line 407 | type
407		Buffer: PChar);
408		procedure WriteRecordCache(RecordNumber: Integer; Buffer: PChar);
409		function InternalGetRecord(Buffer: PChar; GetMode: TGetMode;
410	<	DoCheck: Boolean): TGetResult;
410	>	DoCheck: Boolean): TGetResult; virtual;
411
412		protected
413		procedure ActivateConnection;
#	Line 277 | Line 415 | type
415		procedure DeactivateTransaction;
416		procedure CheckDatasetClosed;
417		procedure CheckDatasetOpen;
418	+	function CreateParser: TSelectSQLParser; virtual;
419	+	procedure FieldDefsFromQuery(SourceQuery: TIBSQL);
420		function GetActiveBuf: PChar;
421	<	procedure InternalBatchInput(InputObject: TIBBatchInput);
422	<	procedure InternalBatchOutput(OutputObject: TIBBatchOutput);
421	>	procedure InternalBatchInput(InputObject: TIBBatchInput); virtual;
422	>	procedure InternalBatchOutput(OutputObject: TIBBatchOutput); virtual;
423		procedure InternalPrepare; virtual;
424		procedure InternalUnPrepare; virtual;
425		procedure InternalExecQuery; virtual;
426		procedure InternalRefreshRow; virtual;
427	<	procedure InternalSetParamsFromCursor;
427	>	procedure InternalSetParamsFromCursor; virtual;
428		procedure CheckNotUniDirectional;
429	+	procedure SQLChanging(Sender: TObject); virtual;
430	+	procedure SQLChanged(Sender: TObject); virtual;
431
432	<	{ IProviderSupport }
432	>	(*    { IProviderSupport }
433		procedure PSEndTransaction(Commit: Boolean); override;
434		function PSExecuteStatement(const ASQL: string; AParams: TParams;
435		ResultSet: Pointer = nil): Integer; override;
#	Line 300 | Line 442 | type
442		procedure PSStartTransaction; override;
443		procedure PSReset; override;
444		function PSUpdateRecord(UpdateKind: TUpdateKind; Delta: TDataSet): Boolean; override;
445	<
445	>	*)
446		{ TDataSet support }
447		procedure InternalInsert; override;
448		procedure InitRecord(Buffer: PChar); override;
#	Line 309 | Line 451 | type
451		procedure ClearCalcFields(Buffer: PChar); override;
452		function AllocRecordBuffer: PChar; override;
453		procedure DoBeforeDelete; override;
454	+	procedure DoAfterDelete; override;
455		procedure DoBeforeEdit; override;
456	+	procedure DoAfterEdit; override;
457		procedure DoBeforeInsert; override;
458	+	procedure DoAfterInsert; override;
459	+	procedure DoBeforeClose; override;
460	+	procedure DoBeforeOpen; override;
461	+	procedure DoBeforePost; override;
462	+	procedure DoAfterPost; override;
463		procedure FreeRecordBuffer(var Buffer: PChar); override;
464		procedure GetBookmarkData(Buffer: PChar; Data: Pointer); override;
465		function GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; override;
466		function GetCanModify: Boolean; override;
467		function GetDataSource: TDataSource; override;
468	+	function GetDBAliasName(FieldNo: integer): string;
469	+	function GetFieldDefFromAlias(aliasName: string): TFieldDef;
470		function GetFieldClass(FieldType: TFieldType): TFieldClass; override;
471		function GetRecNo: Integer; override;
472		function GetRecord(Buffer: PChar; GetMode: TGetMode;
473		DoCheck: Boolean): TGetResult; override;
474		function GetRecordCount: Integer; override;
475		function GetRecordSize: Word; override;
476	+	procedure InternalAutoCommit;
477		procedure InternalAddRecord(Buffer: Pointer; Append: Boolean); override;
478		procedure InternalCancel; override;
479		procedure InternalClose; override;
480		procedure InternalDelete; override;
481		procedure InternalFirst; override;
482	<	function InternalGetFieldData(Field: TField; Buffer: Pointer): Boolean;
482	>	function InternalGetFieldData(Field: TField; Buffer: Pointer): Boolean; virtual;
483		procedure InternalGotoBookmark(Bookmark: Pointer); override;
484		procedure InternalHandleException; override;
485		procedure InternalInitFieldDefs; override;
#	Line 336 | Line 488 | type
488		procedure InternalOpen; override;
489		procedure InternalPost; override;
490		procedure InternalRefresh; override;
491	<	procedure InternalSetFieldData(Field: TField; Buffer: Pointer);
491	>	procedure InternalSetFieldData(Field: TField; Buffer: Pointer); virtual;
492		procedure InternalSetToRecord(Buffer: PChar); override;
493		function IsCursorOpen: Boolean; override;
494	+	procedure Loaded; override;
495		procedure ReQuery;
496		procedure SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); override;
497		procedure SetBookmarkData(Buffer: PChar; Data: Pointer); override;
498		procedure SetCachedUpdates(Value: Boolean);
499		procedure SetDataSource(Value: TDataSource);
500	+	procedure SetGenerateParamNames(AValue: Boolean); virtual;
501		procedure SetFieldData(Field : TField; Buffer : Pointer); override;
502		procedure SetFieldData(Field : TField; Buffer : Pointer;
503		NativeFormat : Boolean); overload; override;
#	Line 351 | Line 505 | type
505
506		protected
507		{Likely to be made public by descendant classes}
508	+	property AutoCommit: TIBAutoCommit read FAutoCommit write FAutoCommit default acDisabled;
509		property SQLParams: TIBXSQLDA read GetSQLParams;
510		property Params: TIBXSQLDA read GetSQLParams;
511		property InternalPrepared: Boolean read FInternalPrepared;
#	Line 366 | Line 521 | type
521		property BufferChunks: Integer read FBufferChunks write SetBufferChunks;
522		property CachedUpdates: Boolean read FCachedUpdates write SetCachedUpdates;
523		property UniDirectional: Boolean read FUniDirectional write SetUniDirectional default False;
524	+	property GeneratorField: TIBGenerator read FGeneratorField write FGeneratorField;
525		property DeleteSQL: TStrings read GetDeleteSQL write SetDeleteSQL;
526		property InsertSQL: TStrings read GetInsertSQL write SetInsertSQL;
527		property RefreshSQL: TStrings read GetRefreshSQL write SetRefreshSQL;
#	Line 373 | Line 529 | type
529		property ModifySQL: TStrings read GetModifySQL write SetModifySQL;
530		property UpdateMode: TUpdateMode read FUpdateMode write SetUpdateMode default upWhereAll;
531		property ParamCheck: Boolean read FParamCheck write FParamCheck default True;
532	+	property Parser: TSelectSQLParser read GetParser;
533	+	property BaseSQLSelect: TStrings read FBaseSQLSelect;
534
535		property BeforeDatabaseDisconnect: TNotifyEvent read FBeforeDatabaseDisconnect
536		write FBeforeDatabaseDisconnect;
#	Line 386 | Line 544 | type
544		write FAfterTransactionEnd;
545		property TransactionFree: TNotifyEvent read FTransactionFree
546		write FTransactionFree;
547	+	property OnValidatePost: TOnValidatePost read FOnValidatePost write FOnValidatePost;
548
549		public
550		constructor Create(AOwner: TComponent); override;
#	Line 393 | Line 552 | type
552		procedure ApplyUpdates;
553		function CachedUpdateStatus: TCachedUpdateStatus;
554		procedure CancelUpdates;
555	+	function GetFieldPosition(AliasName: string): integer;
556		procedure FetchAll;
557		function LocateNext(const KeyFields: string; const KeyValues: Variant;
558		Options: TLocateOptions): Boolean;
559		procedure RecordModified(Value: Boolean);
560		procedure RevertRecord;
561		procedure Undelete;
562	+	procedure ResetParser; virtual;
563	+	function HasParser: boolean;
564
565		{ TDataSet support methods }
566		function BookmarkValid(Bookmark: TBookmark): Boolean; override;
#	Line 406 | Line 568 | type
568		function CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; override;
569		function GetCurrentRecord(Buffer: PChar): Boolean; override;
570		function GetFieldData(Field : TField; Buffer : Pointer) : Boolean; overload; override;
571	<	function GetFieldData(FieldNo: Integer; Buffer: Pointer): Boolean; overload; override;
571	>	function GetFieldData(FieldNo: Integer; Buffer: Pointer): Boolean; overload; (*override;*)
572		function GetFieldData(Field : TField; Buffer : Pointer;
573		NativeFormat : Boolean) : Boolean; overload; override;
574	+	property GenerateParamNames: Boolean read FGenerateParamNames write SetGenerateParamNames;
575		function Locate(const KeyFields: string; const KeyValues: Variant;
576		Options: TLocateOptions): Boolean; override;
577		function Lookup(const KeyFields: string; const KeyValues: Variant;
578		const ResultFields: string): Variant; override;
579		function UpdateStatus: TUpdateStatus; override;
580		function IsSequenced: Boolean; override;
581	<
581	>	procedure Post; override;
582	>	function ParamByName(ParamName: String): TIBXSQLVAR;
583		property DBHandle: PISC_DB_HANDLE read GetDBHandle;
584		property TRHandle: PISC_TR_HANDLE read GetTRHandle;
585		property UpdateObject: TIBDataSetUpdateObject read FUpdateObject write SetUpdateObject;
586		property UpdatesPending: Boolean read FUpdatesPending;
587		property UpdateRecordTypes: TIBUpdateRecordTypes read FUpdateRecordTypes
588		write SetUpdateRecordTypes;
589	+	property DataSetCloseAction: TDataSetCloseAction
590	+	read FDataSetCloseAction write FDataSetCloseAction;
591
592		published
593		property Database: TIBDatabase read GetDatabase write SetDatabase;
#	Line 430 | Line 596 | type
596		property ForcedRefresh: Boolean read FForcedRefresh
597		write FForcedRefresh default False;
598		property AutoCalcFields;
433	–	property ObjectView default False;
599
600		property AfterCancel;
601		property AfterClose;
#	Line 461 | Line 626 | type
626		write FOnUpdateRecord;
627		end;
628
629	<	TIBDataSet = class(TIBCustomDataSet)
629	>	TIBParserDataSet = class(TIBCustomDataSet)
630	>	public
631	>	property Parser;
632	>	end;
633	>
634	>	TIBDataSet = class(TIBParserDataSet)
635		private
636		function GetPrepared: Boolean;
637
#	Line 486 | Line 656 | type
656		property QModify;
657		property StatementType;
658		property SelectStmtHandle;
659	+	property BaseSQLSelect;
660
661		published
662		{ TIBCustomDataSet }
663	+	property AutoCommit;
664		property BufferChunks;
665		property CachedUpdates;
666		property DeleteSQL;
#	Line 496 | Line 668 | type
668		property RefreshSQL;
669		property SelectSQL;
670		property ModifySQL;
671	+	property GeneratorField;
672	+	property GenerateParamNames;
673		property ParamCheck;
674		property UniDirectional;
675		property Filtered;
676	+	property DataSetCloseAction;
677
678		property BeforeDatabaseDisconnect;
679		property AfterDatabaseDisconnect;
#	Line 534 | Line 709 | type
709		property OnFilterRecord;
710		property OnNewRecord;
711		property OnPostError;
712	+	property OnValidatePost;
713		end;
714
715		{ TIBDSBlobStream }
716		TIBDSBlobStream = class(TStream)
717	+	private
718	+	FHasWritten: boolean;
719		protected
720		FField: TField;
721		FBlobStream: TIBBlobStream;
722		public
723		constructor Create(AField: TField; ABlobStream: TIBBlobStream;
724		Mode: TBlobStreamMode);
725	+	destructor Destroy; override;
726		function Read(var Buffer; Count: Longint): Longint; override;
727		function Seek(Offset: Longint; Origin: Word): Longint; override;
728		procedure SetSize(NewSize: Longint); override;
#	Line 568 | Line 747 | DefaultFieldClasses: array[TFieldType] o
747		TVarBytesField,     { ftVarBytes }
748		TAutoIncField,      { ftAutoInc }
749		TBlobField,         { ftBlob }
750	<	TMemoField,         { ftMemo }
750	>	TIBMemoField,       { ftMemo }
751		TGraphicField,      { ftGraphic }
752		TBlobField,         { ftFmtMemo }
753		TBlobField,         { ftParadoxOle }
#	Line 576 | Line 755 | DefaultFieldClasses: array[TFieldType] o
755		TBlobField,         { ftTypedBinary }
756		nil,                { ftCursor }
757		TStringField,       { ftFixedChar }
758	<	nil, {TWideStringField } { ftWideString }
758	>	TIBWideStringField,    { ftWideString }
759		TLargeIntField,     { ftLargeInt }
760	+	nil,          { ftADT }
761	+	nil,        { ftArray }
762	+	nil,    { ftReference }
763	+	nil,     { ftDataSet }
764	+	TBlobField,         { ftOraBlob }
765	+	TMemoField,         { ftOraClob }
766	+	TVariantField,      { ftVariant }
767	+	nil,    { ftInterface }
768	+	nil,     { ftIDispatch }
769	+	TGuidField,        { ftGuid }
770	+	TDateTimeField,    {ftTimestamp}
771	+	TIBBCDField,       {ftFMTBcd}
772	+	nil,  {ftFixedWideChar}
773	+	TIBWideMemoField);   {ftWideMemo}
774	+	(*
775		TADTField,          { ftADT }
776		TArrayField,        { ftArray }
777		TReferenceField,    { ftReference }
#	Line 587 | Line 781 | DefaultFieldClasses: array[TFieldType] o
781		TVariantField,      { ftVariant }
782		TInterfaceField,    { ftInterface }
783		TIDispatchField,     { ftIDispatch }
784	<	TGuidField);        { ftGuid }
785	<	var
786	<	CreateProviderProc: function(DataSet: TIBCustomDataSet): IProvider = nil;
784	>	TGuidField);        { ftGuid } *)
785	>	(*var
786	>	CreateProviderProc: function(DataSet: TIBCustomDataSet): IProvider = nil;*)
787
788		implementation
789
790	<	uses IBIntf, IBQuery;
790	>	uses IBIntf, Variants, FmtBCD, LazUTF8;
791	>
792	>	const FILE_BEGIN = 0;
793	>	FILE_CURRENT = 1;
794	>	FILE_END = 2;
795
796		type
797
#	Line 612 | Line 810 | type
810		NextRelation : TRelationNode;
811		end;
812
813	+	{Extended Field Def for character set info}
814	+
815	+	{ TIBFieldDef }
816	+
817	+	TIBFieldDef = class(TFieldDef)
818	+	private
819	+	FCharacterSetName: string;
820	+	FCharacterSetSize: integer;
821	+	published
822	+	property CharacterSetName: string read FCharacterSetName write FCharacterSetName;
823	+	property CharacterSetSize: integer read FCharacterSetSize write FCharacterSetSize;
824	+	end;
825	+
826	+
827	+	{  Copied from LCLProc in order to avoid LCL dependency
828	+
829	+	Ensures the covenient look of multiline string
830	+	when displaying it in the single line
831	+	* Replaces CR and LF with spaces
832	+	* Removes duplicate spaces
833	+	}
834	+	function TextToSingleLine(const AText: string): string;
835	+	var
836	+	str: string;
837	+	i, wstart, wlen: Integer;
838	+	begin
839	+	str := Trim(AText);
840	+	wstart := 0;
841	+	wlen := 0;
842	+	i := 1;
843	+	while i < Length(str) - 1 do
844	+	begin
845	+	if (str[i] in [' ', #13, #10]) then
846	+	begin
847	+	if (wstart = 0) then
848	+	begin
849	+	wstart := i;
850	+	wlen := 1;
851	+	end else
852	+	Inc(wlen);
853	+	end else
854	+	begin
855	+	if wstart > 0 then
856	+	begin
857	+	str[wstart] := ' ';
858	+	Delete(str, wstart+1, wlen-1);
859	+	Dec(i, wlen-1);
860	+	wstart := 0;
861	+	end;
862	+	end;
863	+	Inc(i);
864	+	end;
865	+	Result := str;
866	+	end;
867	+
868	+	{ TIBWideMemoField }
869	+
870	+	function TIBWideMemoField.GetTruncatedText: string;
871	+	begin
872	+	Result := GetAsString;
873	+
874	+	if Result <> '' then
875	+	if DisplayWidth = 0 then
876	+	Result := TextToSingleLine(Result)
877	+	else
878	+	if Length(Result) > DisplayWidth then {Show truncation with elipses}
879	+	Result := TextToSingleLine(system.copy(Result,1,DisplayWidth-3)) + '...';
880	+	end;
881	+
882	+	function TIBWideMemoField.GetDefaultWidth: Longint;
883	+	begin
884	+	Result := 128;
885	+	end;
886	+
887	+	procedure TIBWideMemoField.GetText(var AText: string; ADisplayText: Boolean);
888	+	begin
889	+	if ADisplayText then
890	+	begin
891	+	if not DisplayTextAsClassName then
892	+	AText := GetTruncatedText
893	+	else
894	+	inherited GetText(AText, ADisplayText);
895	+	end
896	+	else
897	+	AText := GetAsString;
898	+	end;
899	+
900	+	constructor TIBWideMemoField.Create(AOwner: TComponent);
901	+	begin
902	+	inherited Create(AOwner);
903	+	BlobType := ftWideMemo;
904	+	end;
905	+
906	+	{ TIBMemoField }
907	+
908	+	function TIBMemoField.GetTruncatedText: string;
909	+	begin
910	+	Result := GetAsString;
911	+
912	+	if Result <> '' then
913	+	begin
914	+	case CharacterSetSize of
915	+	1:
916	+	if DisplayWidth = 0 then
917	+	Result := TextToSingleLine(Result)
918	+	else
919	+	if Length(Result) > DisplayWidth then {Show truncation with elipses}
920	+	Result := TextToSingleLine(system.copy(Result,1,DisplayWidth-3)) + '...';
921	+
922	+	{2: case 2 ignored. This should be handled by TIBWideMemo}
923	+
924	+	3, {Assume UNICODE_FSS is really UTF8}
925	+	4: {Include GB18030 - assuming UTF8 routine work for this codeset}
926	+	if DisplayWidth = 0 then
927	+	Result := ValidUTF8String(TextToSingleLine(Result))
928	+	else
929	+	if UTF8Length(Result) > DisplayWidth then {Show truncation with elipses}
930	+	Result := ValidUTF8String(TextToSingleLine(UTF8Copy(Result,1,DisplayWidth-3))) + '...';
931	+	end;
932	+	end
933	+	end;
934	+
935	+	function TIBMemoField.GetDefaultWidth: Longint;
936	+	begin
937	+	if DisplayTextAsClassName then
938	+	Result := inherited
939	+	else
940	+	Result := 128;
941	+	end;
942	+
943	+	procedure TIBMemoField.GetText(var AText: string; ADisplayText: Boolean);
944	+	begin
945	+	if ADisplayText then
946	+	begin
947	+	if not DisplayTextAsClassName then
948	+	AText := GetTruncatedText
949	+	else
950	+	inherited GetText(AText, ADisplayText);
951	+	end
952	+	else
953	+	AText := GetAsString;
954	+	end;
955	+
956	+	constructor TIBMemoField.Create(AOwner: TComponent);
957	+	begin
958	+	inherited Create(AOwner);
959	+	BlobType := ftMemo;
960	+	end;
961	+
962	+	{ TIBControlLink }
963	+
964	+	destructor TIBControlLink.Destroy;
965	+	begin
966	+	IBDataSet := nil;
967	+	inherited Destroy;
968	+	end;
969	+
970	+	procedure TIBControlLink.UpdateParams(Sender: TObject);
971	+	begin
972	+
973	+	end;
974	+
975	+	procedure TIBControlLink.UpdateSQL(Sender: TObject);
976	+	begin
977	+
978	+	end;
979	+
980	+	procedure TIBControlLink.SetIBDataSet(AValue: TIBCustomDataSet);
981	+	begin
982	+	if FTIBDataSet = AValue then Exit;
983	+	if IBDataSet <> nil then
984	+	IBDataSet.UnRegisterIBLink(self);
985	+	FTIBDataSet := AValue;
986	+	if IBDataSet <> nil then
987	+	IBDataSet.RegisterIBLink(self);
988	+	end;
989	+
990
991		{ TIBStringField}
992
993	<	constructor TIBStringField.Create(AOwner: TComponent);
993	>	function TIBStringField.GetDefaultWidth: Longint;
994		begin
995	<	inherited;
995	>	Result := Size div CharacterSetSize;
996	>	end;
997	>
998	>	constructor TIBStringField.Create(aOwner: TComponent);
999	>	begin
1000	>	inherited Create(aOwner);
1001	>	FCharacterSetSize := 1;
1002		end;
1003
1004		class procedure TIBStringField.CheckTypeSize(Value: Integer);
#	Line 672 | Line 1053 | begin
1053		end;
1054		end;
1055
1056	+
1057		{ TIBBCDField }
1058
1059		constructor TIBBCDField.Create(AOwner: TComponent);
#	Line 714 | Line 1096 | end;
1096
1097		function TIBBCDField.GetDataSize: Integer;
1098		begin
1099	+	{$IFDEF TBCDFIELD_IS_BCD}
1100		Result := 8;
1101	+	{$ELSE}
1102	+	Result := inherited GetDataSize
1103	+	{$ENDIF}
1104		end;
1105
1106		{ TIBDataLink }
#	Line 728 | Line 1114 | end;
1114		destructor TIBDataLink.Destroy;
1115		begin
1116		FDataSet.FDataLink := nil;
1117	<	inherited;
1117	>	inherited Destroy;
1118		end;
1119
1120
#	Line 760 | Line 1146 | end;
1146
1147		constructor TIBCustomDataSet.Create(AOwner: TComponent);
1148		begin
1149	<	inherited;
1149	>	inherited Create(AOwner);
1150		FIBLoaded := False;
1151		CheckIBLoaded;
1152		FIBLoaded := True;
1153		FBase := TIBBase.Create(Self);
1154	+	FIBLinks := TList.Create;
1155		FCurrentRecord := -1;
1156		FDeletedRecords := 0;
1157		FUniDirectional := False;
1158		FBufferChunks := BufferCacheSize;
1159		FBlobStreamList := TList.Create;
1160	+	FGeneratorField := TIBGenerator.Create(self);
1161		FDataLink := TIBDataLink.Create(Self);
1162		FQDelete := TIBSQL.Create(Self);
1163		FQDelete.OnSQLChanging := SQLChanging;
#	Line 782 | Line 1170 | begin
1170		FQRefresh.GoToFirstRecordOnExecute := False;
1171		FQSelect := TIBSQL.Create(Self);
1172		FQSelect.OnSQLChanging := SQLChanging;
1173	+	FQSelect.OnSQLChanged := SQLChanged;
1174		FQSelect.GoToFirstRecordOnExecute := False;
1175		FQModify := TIBSQL.Create(Self);
1176		FQModify.OnSQLChanging := SQLChanging;
1177		FQModify.GoToFirstRecordOnExecute := False;
1178		FUpdateRecordTypes := [cusUnmodified, cusModified, cusInserted];
1179		FParamCheck := True;
1180	+	FGenerateParamNames := False;
1181		FForcedRefresh := False;
1182	+	FAutoCommit:= acDisabled;
1183	+	FDataSetCloseAction := dcDiscardChanges;
1184		{Bookmark Size is Integer for IBX}
1185		BookmarkSize := SizeOf(Integer);
1186		FBase.BeforeDatabaseDisconnect := DoBeforeDatabaseDisconnect;
#	Line 802 | Line 1194 | begin
1194		else
1195		if AOwner is TIBTransaction then
1196		Transaction := TIBTransaction(AOwner);
1197	+	FBaseSQLSelect := TStringList.Create;
1198		end;
1199
1200		destructor TIBCustomDataSet.Destroy;
1201		begin
1202	<	inherited;
1202	>	if Active then Active := false;
1203		if FIBLoaded then
1204		begin
1205	+	if assigned(FGeneratorField) then FGeneratorField.Free;
1206		FDataLink.Free;
1207		FBase.Free;
1208		ClearBlobCache;
1209	+	ClearIBLinks;
1210	+	FIBLinks.Free;
1211		FBlobStreamList.Free;
1212		FreeMem(FBufferCache);
1213		FBufferCache := nil;
#	Line 821 | Line 1217 | begin
1217		FOldCacheSize := 0;
1218		FMappedFieldPosition := nil;
1219		end;
1220	+	if assigned(FBaseSQLSelect) then FBaseSQLSelect.Free;
1221	+	if assigned(FParser) then FParser.Free;
1222	+	inherited Destroy;
1223		end;
1224
1225		function TIBCustomDataSet.AdjustCurrentRecord(Buffer: Pointer; GetMode: TGetMode):
#	Line 861 | Line 1260 | end;
1260
1261		procedure TIBCustomDataSet.ApplyUpdates;
1262		var
1263	+	{$IF FPC_FULLVERSION >= 20700 }
1264	+	CurBookmark: TBookmark;
1265	+	{$ELSE}
1266		CurBookmark: string;
1267	+	{$ENDIF}
1268		Buffer: PRecordData;
1269		CurUpdateTypes: TIBUpdateRecordTypes;
1270		UpdateAction: TIBUpdateAction;
#	Line 921 | Line 1324 | var
1324		procedure UpdateUsingUpdateObject;
1325		begin
1326		try
1327	<	FUpdateObject.Apply(UpdateKind);
1327	>	FUpdateObject.Apply(UpdateKind,PChar(Buffer));
1328		ResetBufferUpdateStatus;
1329		except
1330		on E: Exception do
#	Line 1059 | Line 1462 | begin
1462		end;
1463		end;
1464
1465	+	function TIBCustomDataSet.GetFieldPosition(AliasName: string): integer;
1466	+	var i: integer;
1467	+	Prepared: boolean;
1468	+	begin
1469	+	Result := 0;
1470	+	Prepared := FInternalPrepared;
1471	+	if not Prepared then
1472	+	InternalPrepare;
1473	+	try
1474	+	for i := 0 to Length(FAliasNameList) - 1 do
1475	+	if FAliasNameList[i] = AliasName then
1476	+	begin
1477	+	Result := i + 1;
1478	+	Exit
1479	+	end;
1480	+	finally
1481	+	if not Prepared then
1482	+	InternalUnPrepare;
1483	+	end;
1484	+	end;
1485	+
1486		procedure TIBCustomDataSet.ActivateConnection;
1487		begin
1488		if not Assigned(Database) then
#	Line 1119 | Line 1543 | begin
1543		IBError(ibxeDatasetClosed, [nil]);
1544		end;
1545
1546	+	function TIBCustomDataSet.CreateParser: TSelectSQLParser;
1547	+	begin
1548	+	Result := TSelectSQLParser.Create(self,FBaseSQLSelect);
1549	+	Result.OnSQLChanging := SQLChanging
1550	+	end;
1551	+
1552		procedure TIBCustomDataSet.CheckNotUniDirectional;
1553		begin
1554		if UniDirectional then
#	Line 1222 | Line 1652 | begin
1652		FDatabaseFree(Sender);
1653		end;
1654
1655	<	procedure TIBCustomDataSet.DoBeforeTransactionEnd(Sender: TObject);
1655	>	procedure TIBCustomDataSet.DoBeforeTransactionEnd(Sender: TObject;
1656	>	Action: TTransactionAction);
1657		begin
1658	<	if Active then
1659	<	Active := False;
1658	>	FCloseAction := Action;
1659	>	FInTransactionEnd := true;
1660	>	try
1661	>	if Active then
1662	>	Active := False;
1663	>	finally
1664	>	FInTransactionEnd := false;
1665	>	end;
1666		if FQSelect <> nil then
1667		FQSelect.FreeHandle;
1668		if FQDelete <> nil then
#	Line 1263 | Line 1700 | var
1700		LocalData: Pointer;
1701		LocalDate, LocalDouble: Double;
1702		LocalInt: Integer;
1703	+	LocalBool: wordBool;
1704		LocalInt64: Int64;
1705		LocalCurrency: Currency;
1706		FieldsLoaded: Integer;
1707	+	temp: TIBXSQLVAR;
1708		begin
1709		p := PRecordData(Buffer);
1710		{ Make sure blob cache is empty }
#	Line 1399 | Line 1838 | begin
1838		if (rdFields[j].fdDataLength = 0) then
1839		LocalData := nil
1840		else
1841	<	LocalData := @Qry.Current[i].Data^.sqldata[2];
1841	>	begin
1842	>	temp :=  Qry.Current[i];
1843	>	LocalData := @temp.Data^.sqldata[2];
1844	>	(*              LocalData := @Qry.Current[i].Data^.sqldata[2];*)
1845	>	end;
1846		end;
1847		end;
1848	+	SQL_BOOLEAN:
1849	+	begin
1850	+	LocalBool:= false;
1851	+	rdFields[j].fdDataSize := SizeOf(wordBool);
1852	+	if RecordNumber >= 0 then
1853	+	LocalBool := Qry.Current[i].AsBoolean;
1854	+	LocalData := PChar(@LocalBool);
1855	+	end;
1856		else { SQL_TEXT, SQL_BLOB, SQL_ARRAY, SQL_QUAD }
1857		begin
1858		rdFields[j].fdDataSize := Qry.Current[i].Data^.sqllen;
#	Line 1526 | Line 1977 | end;
1977		procedure TIBCustomDataSet.InternalDeleteRecord(Qry: TIBSQL; Buff: Pointer);
1978		begin
1979		if (Assigned(FUpdateObject) and (FUpdateObject.GetSQL(ukDelete).Text <> '')) then
1980	<	FUpdateObject.Apply(ukDelete)
1980	>	FUpdateObject.Apply(ukDelete,Buff)
1981		else
1982		begin
1983		SetInternalSQLParams(FQDelete, Buff);
#	Line 1543 | Line 1994 | end;
1994		function TIBCustomDataSet.InternalLocate(const KeyFields: string;
1995		const KeyValues: Variant; Options: TLocateOptions): Boolean;
1996		var
1997	<	fl: TList;
1997	>	keyFieldList: TList;
1998	>	{$IF FPC_FULLVERSION >= 20700 }
1999	>	CurBookmark: TBookmark;
2000	>	{$ELSE}
2001		CurBookmark: string;
2002	<	fld, val: Variant;
2003	<	i, fld_cnt: Integer;
2002	>	{$ENDIF}
2003	>	fieldValue: Variant;
2004	>	lookupValues: array of variant;
2005	>	i, fieldCount: Integer;
2006	>	fieldValueAsString: string;
2007	>	lookupValueAsString: string;
2008		begin
2009	<	fl := TList.Create;
2009	>	keyFieldList := TList.Create;
2010		try
2011	<	GetFieldList(fl, KeyFields);
2012	<	fld_cnt := fl.Count;
2011	>	GetFieldList(keyFieldList, KeyFields);
2012	>	fieldCount := keyFieldList.Count;
2013		CurBookmark := Bookmark;
2014	<	result := False;
2015	<	while ((not result) and (not EOF)) do
2014	>	result := false;
2015	>	SetLength(lookupValues, fieldCount);
2016	>	if not EOF then
2017		begin
2018	<	i := 0;
1560	<	result := True;
1561	<	while (result and (i < fld_cnt)) do
2018	>	for i := 0 to fieldCount - 1 do  {expand key values into lookupValues array}
2019		begin
2020	<	if fld_cnt > 1 then
2021	<	val := KeyValues[i]
2020	>	if VarIsArray(KeyValues) then
2021	>	lookupValues[i] := KeyValues[i]
2022	>	else
2023	>	if i > 0 then
2024	>	lookupValues[i] := NULL
2025		else
2026	<	val := KeyValues;
2027	<	fld := TField(fl[i]).Value;
2028	<	result := not (VarIsNull(val) xor VarIsNull(fld));
2029	<	if result and not VarIsNull(val) then
2026	>	lookupValues[0] := KeyValues;
2027	>
2028	>	{convert to upper case is case insensitive search}
2029	>	if (TField(keyFieldList[i]).DataType = ftString) and
2030	>	not VarIsNull(lookupValues[i]) and (loCaseInsensitive in Options) then
2031	>	lookupValues[i] := UpperCase(lookupValues[i]);
2032	>	end;
2033	>	end;
2034	>	while not result and not EOF do   {search for a matching record}
2035	>	begin
2036	>	i := 0;
2037	>	result := true;
2038	>	while result and (i < fieldCount) do
2039	>	{see if all of the key fields matches}
2040	>	begin
2041	>	fieldValue := TField(keyFieldList[i]).Value;
2042	>	result := not (VarIsNull(fieldValue) xor VarIsNull(lookupValues[i]));
2043	>	if result and not VarIsNull(fieldValue) then
2044		begin
2045		try
2046	<	fld := VarAsType(fld, VarType(val));
1573	<	except
1574	<	on E: EVariantError do result := False;
1575	<	end;
1576	<	if Result then
1577	<	if TField(fl[i]).DataType = ftString then
2046	>	if TField(keyFieldList[i]).DataType = ftString then
2047		begin
2048	+	{strings need special handling because of the locate options that
2049	+	apply to them}
2050	+	fieldValueAsString := TField(keyFieldList[i]).AsString;
2051	+	lookupValueAsString := lookupValues[i];
2052		if (loCaseInsensitive in Options) then
2053	<	begin
2054	<	fld := AnsiUpperCase(fld);
1582	<	val := AnsiUpperCase(val);
1583	<	end;
1584	<	fld := TrimRight(fld);
1585	<	val := TrimRight(val);
2053	>	fieldValueAsString := UpperCase(fieldValueAsString);
2054	>
2055		if (loPartialKey in Options) then
2056	<	result := result and (AnsiPos(val, fld) = 1)
2056	>	result := result and (Pos(lookupValueAsString, fieldValueAsString) = 1)
2057		else
2058	<	result := result and (val = fld);
2059	<	end else
2060	<	result := result and (val = fld);
2058	>	result := result and (fieldValueAsString = lookupValueAsString);
2059	>	end
2060	>	else
2061	>	result := result and (lookupValues[i] =
2062	>	VarAsType(fieldValue, VarType(lookupValues[i])));
2063	>	except on EVariantError do
2064	>	result := False;
2065	>	end;
2066		end;
2067		Inc(i);
2068		end;
2069		if not result then
2070	<	Next;
2070	>	Next;
2071		end;
2072		if not result then
2073		Bookmark := CurBookmark
2074		else
2075		CursorPosChanged;
2076		finally
2077	<	fl.Free;
2077	>	keyFieldList.Free;
2078	>	SetLength(lookupValues,0)
2079		end;
2080		end;
2081
#	Line 1628 | Line 2103 | begin
2103		if Assigned(FUpdateObject) then
2104		begin
2105		if (Qry = FQDelete) then
2106	<	FUpdateObject.Apply(ukDelete)
2106	>	FUpdateObject.Apply(ukDelete,Buff)
2107		else if (Qry = FQInsert) then
2108	<	FUpdateObject.Apply(ukInsert)
2108	>	FUpdateObject.Apply(ukInsert,Buff)
2109		else
2110	<	FUpdateObject.Apply(ukModify);
2110	>	FUpdateObject.Apply(ukModify,Buff);
2111		end
2112		else begin
2113		SetInternalSQLParams(Qry, Buff);
#	Line 1649 | Line 2124 | end;
2124		procedure TIBCustomDataSet.InternalRefreshRow;
2125		var
2126		Buff: PChar;
1652	–	SetCursor: Boolean;
2127		ofs: DWORD;
2128		Qry: TIBSQL;
2129		begin
2130	<	SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault);
1657	<	if SetCursor then
1658	<	Screen.Cursor := crHourGlass;
2130	>	FBase.SetCursor;
2131		try
2132		Buff := GetActiveBuf;
2133		if CanRefresh then
#	Line 1699 | Line 2171 | begin
2171		else
2172		IBError(ibxeCannotRefresh, [nil]);
2173		finally
2174	<	if SetCursor and (Screen.Cursor = crHourGlass) then
1703	<	Screen.Cursor := crDefault;
2174	>	FBase.RestoreCursor;
2175		end;
2176		end;
2177
#	Line 1771 | Line 2242 | end;
2242
2243		procedure TIBCustomDataSet.InternalPrepare;
2244		var
1774	–	SetCursor: Boolean;
2245		DidActivate: Boolean;
2246		begin
2247		if FInternalPrepared then
2248		Exit;
2249		DidActivate := False;
2250	<	SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault);
1781	<	if SetCursor then
1782	<	Screen.Cursor := crHourGlass;
2250	>	FBase.SetCursor;
2251		try
2252		ActivateConnection;
2253		DidActivate := ActivateTransaction;
2254		FBase.CheckDatabase;
2255		FBase.CheckTransaction;
2256	+	if HasParser and (FParser.SQLText <> FQSelect.SQL.Text) then
2257	+	begin
2258	+	FQSelect.OnSQLChanged := nil; {Do not react to change}
2259	+	try
2260	+	FQSelect.SQL.Text := FParser.SQLText;
2261	+	finally
2262	+	FQSelect.OnSQLChanged := SQLChanged;
2263	+	end;
2264	+	end;
2265	+	//   writeln( FQSelect.SQL.Text);
2266		if FQSelect.SQL.Text <> '' then
2267		begin
2268		if not FQSelect.Prepared then
2269		begin
2270	+	FQSelect.GenerateParamNames := FGenerateParamNames;
2271		FQSelect.ParamCheck := ParamCheck;
2272		FQSelect.Prepare;
2273		end;
2274	<	if (FQDelete.SQL.Text <> '') and (not FQDelete.Prepared) then
2274	>	FQDelete.GenerateParamNames := FGenerateParamNames;
2275	>	if (Trim(FQDelete.SQL.Text) <> '') and (not FQDelete.Prepared) then
2276		FQDelete.Prepare;
2277	<	if (FQInsert.SQL.Text <> '') and (not FQInsert.Prepared) then
2277	>	FQInsert.GenerateParamNames := FGenerateParamNames;
2278	>	if (Trim(FQInsert.SQL.Text) <> '') and (not FQInsert.Prepared) then
2279		FQInsert.Prepare;
2280	<	if (FQRefresh.SQL.Text <> '') and (not FQRefresh.Prepared) then
2280	>	FQRefresh.GenerateParamNames := FGenerateParamNames;
2281	>	if (Trim(FQRefresh.SQL.Text) <> '') and (not FQRefresh.Prepared) then
2282		FQRefresh.Prepare;
2283	<	if (FQModify.SQL.Text <> '') and (not FQModify.Prepared) then
2283	>	FQModify.GenerateParamNames := FGenerateParamNames;
2284	>	if (Trim(FQModify.SQL.Text) <> '') and (not FQModify.Prepared) then
2285		FQModify.Prepare;
2286		FInternalPrepared := True;
2287		InternalInitFieldDefs;
#	Line 1807 | Line 2290 | begin
2290		finally
2291		if DidActivate then
2292		DeactivateTransaction;
2293	<	if SetCursor and (Screen.Cursor = crHourGlass) then
1811	<	Screen.Cursor := crDefault;
2293	>	FBase.RestoreCursor;
2294		end;
2295		end;
2296
#	Line 1998 | Line 2480 | begin
2480		end;
2481		SQL_TIMESTAMP:
2482		Qry.Params[i].AsDateTime :=
2483	<	TimeStampToDateTime(
2484	<	MSecsToTimeStamp(PDouble(data)^));
2483	>	TimeStampToDateTime(MSecsToTimeStamp(trunc(PDouble(data)^)));
2484	>	SQL_BOOLEAN:
2485	>	Qry.Params[i].AsBoolean := PWordBool(data)^;
2486		end;
2487		end;
2488		end;
#	Line 2085 | Line 2568 | begin
2568		end;
2569		end;
2570
2571	+	procedure TIBCustomDataSet.RegisterIBLink(Sender: TIBControlLink);
2572	+	begin
2573	+	if FIBLinks.IndexOf(Sender) = -1 then
2574	+	FIBLinks.Add(Sender);
2575	+	end;
2576	+
2577
2578		procedure TIBCustomDataSet.SQLChanging(Sender: TObject);
2579		begin
2580	<	if FOpen then
2581	<	InternalClose;
2580	>	Active := false;
2581	>	{  if FOpen then
2582	>	InternalClose;}
2583		if FInternalPrepared then
2584		InternalUnPrepare;
2585	+	FieldDefs.Clear;
2586	+	FieldDefs.Updated := false;
2587	+	end;
2588	+
2589	+	procedure TIBCustomDataSet.SQLChanged(Sender: TObject);
2590	+	begin
2591	+	FBaseSQLSelect.assign(FQSelect.SQL);
2592		end;
2593
2594		{ I can "undelete" uninserted records (make them "inserted" again).
#	Line 2120 | Line 2617 | begin
2617		end;
2618		end;
2619
2620	+	procedure TIBCustomDataSet.UnRegisterIBLink(Sender: TIBControlLink);
2621	+	begin
2622	+	FIBLinks.Remove(Sender);
2623	+	end;
2624	+
2625		function TIBCustomDataSet.UpdateStatus: TUpdateStatus;
2626		begin
2627		if Active then
#	Line 2136 | Line 2638 | begin
2638		Result := Assigned( FQSelect ) and FQSelect.EOF;
2639		end;
2640
2641	+	function TIBCustomDataSet.ParamByName(ParamName: String): TIBXSQLVAR;
2642	+	begin
2643	+	ActivateConnection;
2644	+	ActivateTransaction;
2645	+	if not FInternalPrepared then
2646	+	InternalPrepare;
2647	+	Result := Params.ByName(ParamName);
2648	+	end;
2649	+
2650	+	{Beware: the parameter FCache is used as an identifier to determine which
2651	+	cache is being operated on and is not referenced in the computation.
2652	+	The result is an adjusted offset into the identified cache, either the
2653	+	Buffer Cache or the old Buffer Cache.}
2654	+
2655		function TIBCustomDataSet.AdjustPosition(FCache: PChar; Offset: DWORD;
2656	<	Origin: Integer): Integer;
2656	>	Origin: Integer): DWORD;
2657		var
2658		OldCacheSize: Integer;
2659		begin
#	Line 2174 | Line 2690 | procedure TIBCustomDataSet.ReadCache(FCa
2690		Buffer: PChar);
2691		var
2692		pCache: PChar;
2693	+	AdjustedOffset: DWORD;
2694		bOld: Boolean;
2695		begin
2696		bOld := (FCache = FOldBufferCache);
2697	<	pCache := PChar(AdjustPosition(FCache, Offset, Origin));
2697	>	AdjustedOffset := AdjustPosition(FCache, Offset, Origin);
2698		if not bOld then
2699	<	pCache := FBufferCache + Integer(pCache)
2699	>	pCache := FBufferCache + AdjustedOffset
2700		else
2701	<	pCache := FOldBufferCache + Integer(pCache);
2701	>	pCache := FOldBufferCache + AdjustedOffset;
2702		Move(pCache^, Buffer^, DWORD(FRecordBufferSize));
2703		AdjustPosition(FCache, FRecordBufferSize, FILE_CURRENT);
2704		end;
#	Line 2211 | Line 2728 | procedure TIBCustomDataSet.WriteCache(FC
2728		Buffer: PChar);
2729		var
2730		pCache: PChar;
2731	+	AdjustedOffset: DWORD;
2732		bOld: Boolean;
2733		dwEnd: DWORD;
2734		begin
2735		bOld := (FCache = FOldBufferCache);
2736	<	pCache := PChar(AdjustPosition(FCache, Offset, Origin));
2736	>	AdjustedOffset := AdjustPosition(FCache, Offset, Origin);
2737		if not bOld then
2738	<	pCache := FBufferCache + Integer(pCache)
2738	>	pCache := FBufferCache + AdjustedOffset
2739		else
2740	<	pCache := FOldBufferCache + Integer(pCache);
2740	>	pCache := FOldBufferCache + AdjustedOffset;
2741		Move(Buffer^, pCache^, FRecordBufferSize);
2742		dwEnd := AdjustPosition(FCache, FRecordBufferSize, FILE_CURRENT);
2743		if not bOld then
#	Line 2330 | Line 2848 | begin
2848		if FCachedUpdates and
2849		(Buff^.rdCachedUpdateStatus in [cusUnmodified]) then
2850		SaveOldBuffer(PChar(Buff));
2851	<	inherited;
2851	>	inherited DoBeforeDelete;
2852	>	end;
2853	>
2854	>	procedure TIBCustomDataSet.DoAfterDelete;
2855	>	begin
2856	>	inherited DoAfterDelete;
2857	>	FBase.DoAfterDelete(self);
2858	>	InternalAutoCommit;
2859		end;
2860
2861		procedure TIBCustomDataSet.DoBeforeEdit;
#	Line 2344 | Line 2869 | begin
2869		if FCachedUpdates and (Buff^.rdCachedUpdateStatus in [cusUnmodified, cusInserted]) then
2870		SaveOldBuffer(PChar(Buff));
2871		CopyRecordBuffer(GetActiveBuf, FOldBuffer);
2872	<	inherited;
2872	>	inherited DoBeforeEdit;
2873	>	end;
2874	>
2875	>	procedure TIBCustomDataSet.DoAfterEdit;
2876	>	begin
2877	>	inherited DoAfterEdit;
2878	>	FBase.DoAfterEdit(self);
2879		end;
2880
2881		procedure TIBCustomDataSet.DoBeforeInsert;
2882		begin
2883		if not CanInsert then
2884		IBError(ibxeCannotInsert, [nil]);
2885	<	inherited;
2885	>	inherited DoBeforeInsert;
2886	>	end;
2887	>
2888	>	procedure TIBCustomDataSet.DoAfterInsert;
2889	>	begin
2890	>	if GeneratorField.ApplyOnEvent = gaeOnNewRecord then
2891	>	GeneratorField.Apply;
2892	>	inherited DoAfterInsert;
2893	>	FBase.DoAfterInsert(self);
2894	>	end;
2895	>
2896	>	procedure TIBCustomDataSet.DoBeforeClose;
2897	>	begin
2898	>	inherited DoBeforeClose;
2899	>	if State in [dsInsert,dsEdit] then
2900	>	begin
2901	>	if FInTransactionEnd and (FCloseAction = TARollback) then
2902	>	Exit;
2903	>
2904	>	if DataSetCloseAction = dcSaveChanges then
2905	>	Post;
2906	>	{Note this can fail with an exception e.g. due to
2907	>	database validation error. In which case the dataset remains open }
2908	>	end;
2909	>	end;
2910	>
2911	>	procedure TIBCustomDataSet.DoBeforeOpen;
2912	>	var i: integer;
2913	>	begin
2914	>	if assigned(FParser) then
2915	>	FParser.Reset;
2916	>	for i := 0 to FIBLinks.Count - 1 do
2917	>	TIBControlLink(FIBLinks[i]).UpdateSQL(self);
2918	>	inherited DoBeforeOpen;
2919	>	for i := 0 to FIBLinks.Count - 1 do
2920	>	TIBControlLink(FIBLinks[i]).UpdateParams(self);
2921	>	end;
2922	>
2923	>	procedure TIBCustomDataSet.DoBeforePost;
2924	>	begin
2925	>	inherited DoBeforePost;
2926	>	if (State = dsInsert) and
2927	>	(GeneratorField.ApplyOnEvent = gaeOnPostRecord) then
2928	>	GeneratorField.Apply
2929	>	end;
2930	>
2931	>	procedure TIBCustomDataSet.DoAfterPost;
2932	>	begin
2933	>	inherited DoAfterPost;
2934	>	FBase.DoAfterPost(self);
2935	>	InternalAutoCommit;
2936		end;
2937
2938		procedure TIBCustomDataSet.FetchAll;
2939		var
2940	<	SetCursor: Boolean;
2940	>	{$IF FPC_FULLVERSION >= 20700 }
2941	>	CurBookmark: TBookmark;
2942	>	{$ELSE}
2943		CurBookmark: string;
2944	+	{$ENDIF}
2945		begin
2946	<	SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault);
2947	<	if SetCursor then
2364	<	Screen.Cursor := crHourGlass;
2365	<	try
2946	>	FBase.SetCursor;
2947	>	try
2948		if FQSelect.EOF or not FQSelect.Open then
2949		exit;
2950		DisableControls;
#	Line 2374 | Line 2956 | begin
2956		EnableControls;
2957		end;
2958		finally
2959	<	if SetCursor and (Screen.Cursor = crHourGlass) then
2378	<	Screen.Cursor := crDefault;
2959	>	FBase.RestoreCursor;
2960		end;
2961		end;
2962
#	Line 2423 | Line 3004 | begin
3004		result := FDataLink.DataSource;
3005		end;
3006
3007	+	function TIBCustomDataSet.GetDBAliasName(FieldNo: integer): string;
3008	+	begin
3009	+	Result := FAliasNameMap[FieldNo-1]
3010	+	end;
3011	+
3012	+	function TIBCustomDataSet.GetFieldDefFromAlias(aliasName: string): TFieldDef;
3013	+	var
3014	+	i: integer;
3015	+	begin
3016	+	Result := nil;
3017	+	for i := 0 to Length(FAliasNameMap) - 1 do
3018	+	if FAliasNameMap[i] = aliasName then
3019	+	begin
3020	+	Result := FieldDefs[i];
3021	+	Exit
3022	+	end;
3023	+	end;
3024	+
3025		function TIBCustomDataSet.GetFieldClass(FieldType: TFieldType): TFieldClass;
3026		begin
3027		Result := DefaultFieldClasses[FieldType];
#	Line 2441 | Line 3040 | begin
3040		result := False;
3041		Buff := GetActiveBuf;
3042		if (Buff = nil) or
3043	<	(not IsVisible(Buff)) then
3043	>	(not IsVisible(Buff)) or not assigned(Field.DataSet) then
3044		exit;
3045		{ The intention here is to stuff the buffer with the data for the
3046		referenced field for the current record }
#	Line 2463 | Line 3062 | begin
3062		Data := Buff + CurrentRecord^.rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataOfs;
3063		if (fdDataType = SQL_VARYING) or (fdDataType = SQL_TEXT) then
3064		begin
3065	<	Move(Data^, Buffer^, fdDataLength);
3066	<	PChar(Buffer)[fdDataLength] := #0;
3065	>	if fdDataLength < Field.DataSize then
3066	>	begin
3067	>	Move(Data^, Buffer^, fdDataLength);
3068	>	PChar(Buffer)[fdDataLength] := #0;
3069	>	end
3070	>	else
3071	>	IBError(ibxeFieldSizeError,[Field.FieldName])
3072		end
3073		else
3074		Move(Data^, Buffer^, Field.DataSize);
#	Line 2507 | Line 3111 | begin
3111		if not Accept and (GetMode = gmCurrent) then
3112		GetMode := gmPrior;
3113		except
3114	<	//        Application.HandleException(Self);
3114	>	//        FBase.HandleException(Self);
3115		end;
3116		end;
3117		RestoreState(SaveState);
#	Line 2601 | Line 3205 | begin
3205		result := FRecordBufferSize;
3206		end;
3207
3208	+	procedure TIBCustomDataSet.InternalAutoCommit;
3209	+	begin
3210	+	with Transaction do
3211	+	if InTransaction and (FAutoCommit = acCommitRetaining) then
3212	+	begin
3213	+	if CachedUpdates then ApplyUpdates;
3214	+	CommitRetaining;
3215	+	end;
3216	+	end;
3217	+
3218		procedure TIBCustomDataSet.InternalAddRecord(Buffer: Pointer; Append: Boolean);
3219		begin
3220		CheckEditState;
#	Line 2629 | Line 3243 | var
3243		Buff: PChar;
3244		CurRec: Integer;
3245		begin
3246	<	inherited;
3246	>	inherited InternalCancel;
3247		Buff := GetActiveBuf;
3248		if Buff <> nil then begin
3249		CurRec := FCurrentRecord;
#	Line 2672 | Line 3286 | begin
3286		FreeMem(FOldBufferCache);
3287		FOldBufferCache := nil;
3288		BindFields(False);
3289	+	ResetParser;
3290		if DefaultFields then DestroyFields;
3291		end;
3292
3293		procedure TIBCustomDataSet.InternalDelete;
3294		var
3295		Buff: PChar;
2681	–	SetCursor: Boolean;
3296		begin
3297	<	SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault);
2684	<	if SetCursor then
2685	<	Screen.Cursor := crHourGlass;
3297	>	FBase.SetCursor;
3298		try
3299		Buff := GetActiveBuf;
3300		if CanDelete then
#	Line 2707 | Line 3319 | begin
3319		end else
3320		IBError(ibxeCannotDelete, [nil]);
3321		finally
3322	<	if SetCursor and (Screen.Cursor = crHourGlass) then
2711	<	Screen.Cursor := crDefault;
3322	>	FBase.RestoreCursor;
3323		end;
3324		end;
3325
#	Line 2724 | Line 3335 | end;
3335
3336		procedure TIBCustomDataSet.InternalHandleException;
3337		begin
3338	<	Application.HandleException(Self)
3338	>	FBase.HandleException(Self)
3339		end;
3340
3341		procedure TIBCustomDataSet.InternalInitFieldDefs;
3342	+	begin
3343	+	if not InternalPrepared then
3344	+	begin
3345	+	InternalPrepare;
3346	+	exit;
3347	+	end;
3348	+	FieldDefsFromQuery(FQSelect);
3349	+	end;
3350	+
3351	+	procedure TIBCustomDataSet.FieldDefsFromQuery(SourceQuery: TIBSQL);
3352		const
3353		DefaultSQL = 'Select F.RDB$COMPUTED_BLR, ' + {do not localize}
3354		'F.RDB$DEFAULT_VALUE, R.RDB$FIELD_NAME ' + {do not localize}
#	Line 2739 | Line 3360 | const
3360		var
3361		FieldType: TFieldType;
3362		FieldSize: Word;
3363	+	charSetID: short;
3364	+	CharSetSize: integer;
3365	+	CharSetName: string;
3366		FieldNullable : Boolean;
3367		i, FieldPosition, FieldPrecision: Integer;
3368	<	FieldAliasName: string;
3368	>	FieldAliasName, DBAliasName: string;
3369		RelationName, FieldName: string;
3370		Query : TIBSQL;
3371		FieldIndex: Integer;
#	Line 2841 | Line 3465 | var
3465		end;
3466
3467		begin
2844	–	if not InternalPrepared then
2845	–	begin
2846	–	InternalPrepare;
2847	–	exit;
2848	–	end;
3468		FRelationNodes := TRelationNode.Create;
3469		FNeedsRefresh := False;
3470		Database.InternalTransaction.StartTransaction;
#	Line 2856 | Line 3475 | begin
3475		FieldDefs.BeginUpdate;
3476		FieldDefs.Clear;
3477		FieldIndex := 0;
3478	<	if (Length(FMappedFieldPosition) < FQSelect.Current.Count) then
3479	<	SetLength(FMappedFieldPosition, FQSelect.Current.Count);
3478	>	if (Length(FMappedFieldPosition) < SourceQuery.Current.Count) then
3479	>	SetLength(FMappedFieldPosition, SourceQuery.Current.Count);
3480		Query.SQL.Text := DefaultSQL;
3481		Query.Prepare;
3482	<	for i := 0 to FQSelect.Current.Count - 1 do
3483	<	with FQSelect.Current[i].Data^ do
3482	>	SetLength(FAliasNameMap, SourceQuery.Current.Count);
3483	>	SetLength(FAliasNameList, SourceQuery.Current.Count);
3484	>	for i := 0 to SourceQuery.Current.Count - 1 do
3485	>	with SourceQuery.Current[i].Data^ do
3486		begin
3487		{ Get the field name }
3488	<	SetString(FieldAliasName, aliasname, aliasname_length);
3488	>	FieldAliasName := SourceQuery.Current[i].Name;
3489	>	SetString(DBAliasName, aliasname, aliasname_length);
3490		SetString(RelationName, relname, relname_length);
3491		SetString(FieldName, sqlname, sqlname_length);
3492	+	FAliasNameList[i] := DBAliasName;
3493		FieldSize := 0;
3494		FieldPrecision := 0;
3495	<	FieldNullable := FQSelect.Current[i].IsNullable;
3495	>	FieldNullable := SourceQuery.Current[i].IsNullable;
3496	>	CharSetSize := 0;
3497	>	CharSetName := '';
3498		case sqltype and not 1 of
3499		{ All VARCHAR's must be converted to strings before recording
3500		their values }
3501		SQL_VARYING, SQL_TEXT:
3502		begin
3503	+	CharSetSize := FBase.GetCharSetSize(sqlsubtype and $FF);
3504	+	CharSetName := FBase.GetCharSetName(sqlsubtype and $FF);
3505	+	{FieldSize is encoded for strings - see TIBStringField.SetSize for decode}
3506		FieldSize := sqllen;
3507	<	FieldType := ftString;
3507	>	if CharSetSize = 2 then
3508	>	FieldType := ftWideString
3509	>	else
3510	>	FieldType := ftString;
3511		end;
3512		{ All Doubles/Floats should be cast to doubles }
3513		SQL_DOUBLE, SQL_FLOAT:
#	Line 2902 | Line 3533 | begin
3533		FieldSize := -sqlscale;
3534		end
3535		else
3536	<	FieldType := ftFloat;
3536	>	if Database.SQLDialect = 1 then
3537	>	FieldType := ftFloat
3538	>	else
3539	>	if (FieldCount > i) and (Fields[i] is TFloatField) then
3540	>	FieldType := ftFloat
3541	>	else
3542	>	begin
3543	>	FieldType := ftFMTBCD;
3544	>	FieldPrecision := 9;
3545	>	FieldSize := -sqlscale;
3546		end;
3547	+	end;
3548	+
3549		SQL_INT64:
3550		begin
3551		if (sqlscale = 0) then
#	Line 2915 | Line 3557 | begin
3557		FieldSize := -sqlscale;
3558		end
3559		else
3560	<	FieldType := ftFloat;
3561	<	end;
3560	>	FieldType := ftFloat
3561	>	end;
3562		SQL_TIMESTAMP: FieldType := ftDateTime;
3563		SQL_TYPE_TIME: FieldType := ftTime;
3564		SQL_TYPE_DATE: FieldType := ftDate;
#	Line 2924 | Line 3566 | begin
3566		begin
3567		FieldSize := sizeof (TISC_QUAD);
3568		if (sqlsubtype = 1) then
3569	<	FieldType := ftmemo
3569	>	begin
3570	>	if strpas(sqlname) = '' then {Complex SQL with no identifiable column - use connection default}
3571	>	begin
3572	>	CharSetSize := FBase.GetDefaultCharSetSize;
3573	>	CharSetName := FBase.GetDefaultCharSetName;
3574	>	end
3575	>	else
3576	>	begin
3577	>	charSetID := GetBlobCharSetID(Database.Handle,Database.InternalTransaction.Handle,
3578	>	@relname,@sqlname);
3579	>	CharSetSize := FBase.GetCharSetSize(charSetID);
3580	>	CharSetName := FBase.GetCharSetName(charSetID);
3581	>	end;
3582	>	if CharSetSize = 2 then
3583	>	FieldType := ftWideMemo
3584	>	else
3585	>	FieldType := ftMemo;
3586	>	end
3587		else
3588		FieldType := ftBlob;
3589		end;
#	Line 2933 | Line 3592 | begin
3592		FieldSize := sizeof (TISC_QUAD);
3593		FieldType := ftUnknown;
3594		end;
3595	+	SQL_BOOLEAN:
3596	+	FieldType:= ftBoolean;
3597		else
3598		FieldType := ftUnknown;
3599		end;
#	Line 2941 | Line 3602 | begin
3602		begin
3603		FMappedFieldPosition[FieldIndex] := FieldPosition;
3604		Inc(FieldIndex);
3605	<	with FieldDefs.AddFieldDef do
3605	>	with TIBFieldDef.Create(FieldDefs,'',FieldType,0,False,FieldDefs.Count+1) do
3606		begin
3607	<	Name := string( FieldAliasName );
3608	<	FieldNo := FieldPosition;
2948	<	DataType := FieldType;
3607	>	Name := FieldAliasName;
3608	>	FAliasNameMap[FieldNo-1] := DBAliasName;
3609		Size := FieldSize;
3610		Precision := FieldPrecision;
3611	<	Required := False;
3611	>	Required := not FieldNullable;
3612		InternalCalcField := False;
3613	+	CharacterSetSize := CharSetSize;
3614	+	CharacterSetName := CharSetName;
3615		if (FieldName <> '') and (RelationName <> '') then
3616		begin
3617		if Has_COMPUTED_BLR(RelationName, FieldName) then
#	Line 3029 | Line 3691 | begin
3691		else case cur_field.DataType of
3692		ftString:
3693		cur_param.AsString := cur_field.AsString;
3694	<	ftBoolean, ftSmallint, ftWord:
3694	>	ftBoolean:
3695	>	cur_param.AsBoolean := cur_field.AsBoolean;
3696	>	ftSmallint, ftWord:
3697		cur_param.AsShort := cur_field.AsInteger;
3698		ftInteger:
3699		cur_param.AsLong := cur_field.AsInteger;
#	Line 3082 | Line 3746 | begin
3746		end;
3747
3748		procedure TIBCustomDataSet.InternalOpen;
3085	–	var
3086	–	SetCursor: Boolean;
3749
3750		function RecordDataLength(n: Integer): Long;
3751		begin
3752		result := SizeOf(TRecordData) + ((n - 1) * SizeOf(TFieldData));
3753		end;
3754
3755	+	function GetFieldDef(aFieldNo: integer): TIBFieldDef;
3756	+	var i: integer;
3757	+	begin
3758	+	Result := nil;
3759	+	for i := 0 to FieldDefs.Count - 1 do
3760	+	if FieldDefs[i].FieldNo = aFieldNo then
3761	+	begin
3762	+	Result := TIBFieldDef(FieldDefs[i]);
3763	+	break;
3764	+	end;
3765	+	end;
3766	+
3767	+	procedure SetExtendedProperties;
3768	+	var i: integer;
3769	+	IBFieldDef: TIBFieldDef;
3770	+	begin
3771	+	for i := 0 to Fields.Count - 1 do
3772	+	if Fields[i].FieldNo > 0 then
3773	+	begin
3774	+	if(Fields[i] is TIBStringField) then
3775	+	with TIBStringField(Fields[i]) do
3776	+	begin
3777	+	IBFieldDef := GetFieldDef(FieldNo);
3778	+	if IBFieldDef <> nil then
3779	+	begin
3780	+	CharacterSetSize := IBFieldDef.CharacterSetSize;
3781	+	CharacterSetName := IBFieldDef.CharacterSetName;
3782	+	end;
3783	+	end
3784	+	else
3785	+	if(Fields[i] is TIBWideStringField) then
3786	+	with TIBWideStringField(Fields[i]) do
3787	+	begin
3788	+	IBFieldDef := GetFieldDef(FieldNo);
3789	+	if IBFieldDef <> nil then
3790	+	begin
3791	+	CharacterSetSize := IBFieldDef.CharacterSetSize;
3792	+	CharacterSetName := IBFieldDef.CharacterSetName;
3793	+	end;
3794	+	end
3795	+	else
3796	+	if(Fields[i] is TIBMemoField) then
3797	+	with TIBMemoField(Fields[i]) do
3798	+	begin
3799	+	IBFieldDef := GetFieldDef(FieldNo);
3800	+	if IBFieldDef <> nil then
3801	+	begin
3802	+	CharacterSetSize := IBFieldDef.CharacterSetSize;
3803	+	CharacterSetName := IBFieldDef.CharacterSetName;
3804	+	end;
3805	+	end
3806	+	else
3807	+	if(Fields[i] is TIBWideMemoField) then
3808	+	with TIBWideMemoField(Fields[i]) do
3809	+	begin
3810	+	IBFieldDef := GetFieldDef(FieldNo);
3811	+	if IBFieldDef <> nil then
3812	+	begin
3813	+	CharacterSetSize := IBFieldDef.CharacterSetSize;
3814	+	CharacterSetName := IBFieldDef.CharacterSetName;
3815	+	end;
3816	+	end
3817	+	end
3818	+	end;
3819	+
3820		begin
3821	<	SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault);
3095	<	if SetCursor then
3096	<	Screen.Cursor := crHourGlass;
3821	>	FBase.SetCursor;
3822		try
3823		ActivateConnection;
3824		ActivateTransaction;
#	Line 3106 | Line 3831 | begin
3831		if DefaultFields then
3832		CreateFields;
3833		BindFields(True);
3834	+	SetExtendedProperties;
3835		FCurrentRecord := -1;
3836		FQSelect.ExecQuery;
3837		FOpen := FQSelect.Open;
#	Line 3154 | Line 3880 | begin
3880		else
3881		FQSelect.ExecQuery;
3882		finally
3883	<	if SetCursor and (Screen.Cursor = crHourGlass) then
3158	<	Screen.Cursor := crDefault;
3883	>	FBase.RestoreCursor;
3884		end;
3885		end;
3886
#	Line 3163 | Line 3888 | procedure TIBCustomDataSet.InternalPost;
3888		var
3889		Qry: TIBSQL;
3890		Buff: PChar;
3166	–	SetCursor: Boolean;
3891		bInserting: Boolean;
3892		begin
3893	<	SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault);
3170	<	if SetCursor then
3171	<	Screen.Cursor := crHourGlass;
3893	>	FBase.SetCursor;
3894		try
3895		Buff := GetActiveBuf;
3896		CheckEditState;
#	Line 3206 | Line 3928 | begin
3928		if bInserting then
3929		Inc(FRecordCount);
3930		finally
3931	<	if SetCursor and (Screen.Cursor = crHourGlass) then
3210	<	Screen.Cursor := crDefault;
3931	>	FBase.RestoreCursor;
3932		end;
3933		end;
3934
3935		procedure TIBCustomDataSet.InternalRefresh;
3936		begin
3937	<	inherited;
3937	>	inherited InternalRefresh;
3938		InternalRefreshRow;
3939		end;
3940
#	Line 3227 | Line 3948 | begin
3948		result := FOpen;
3949		end;
3950
3951	+	procedure TIBCustomDataSet.Loaded;
3952	+	begin
3953	+	if assigned(FQSelect) then
3954	+	FBaseSQLSelect.assign(FQSelect.SQL);
3955	+	inherited Loaded;
3956	+	end;
3957	+
3958	+	procedure TIBCustomDataSet.Post;
3959	+	var CancelPost: boolean;
3960	+	begin
3961	+	CancelPost := false;
3962	+	if assigned(FOnValidatePost) then
3963	+	OnValidatePost(self,CancelPost);
3964	+	if CancelPost then
3965	+	Cancel
3966	+	else
3967	+	inherited Post;
3968	+	end;
3969	+
3970		function TIBCustomDataSet.Locate(const KeyFields: string; const KeyValues: Variant;
3971		Options: TLocateOptions): Boolean;
3972		var
3973	+	{$IF FPC_FULLVERSION >= 20700 }
3974	+	CurBookmark: TBookmark;
3975	+	{$ELSE}
3976		CurBookmark: string;
3977	+	{$ENDIF}
3978		begin
3979		DisableControls;
3980		try
#	Line 3248 | Line 3992 | function TIBCustomDataSet.Lookup(const K
3992		const ResultFields: string): Variant;
3993		var
3994		fl: TList;
3995	+	{$IF FPC_FULLVERSION >= 20700 }
3996	+	CurBookmark: TBookmark;
3997	+	{$ELSE}
3998		CurBookmark: string;
3999	+	{$ENDIF}
4000		begin
4001		DisableControls;
4002		fl := TList.Create;
#	Line 3301 | Line 4049 | end;
4049		procedure TIBCustomDataSet.InternalSetFieldData(Field: TField; Buffer: Pointer);
4050		var
4051		Buff, TmpBuff: PChar;
4052	+	MappedFieldPos: integer;
4053		begin
4054		Buff := GetActiveBuf;
4055		if Field.FieldNo < 0 then
#	Line 3317 | Line 4066 | begin
4066		begin
4067		{ If inserting, Adjust record position }
4068		AdjustRecordOnInsert(Buff);
4069	<	if (FMappedFieldPosition[Field.FieldNo - 1] > 0) and
4070	<	(FMappedFieldPosition[Field.FieldNo - 1] <= rdFieldCount) then
4069	>	MappedFieldPos := FMappedFieldPosition[Field.FieldNo - 1];
4070	>	if (MappedFieldPos > 0) and
4071	>	(MappedFieldPos <= rdFieldCount) then
4072		begin
4073		Field.Validate(Buffer);
4074		if (Buffer = nil) or
4075		(Field is TIBStringField) and (PChar(Buffer)[0] = #0) then
4076	<	rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdIsNull := True
4076	>	rdFields[MappedFieldPos].fdIsNull := True
4077		else begin
4078	<	Move(Buffer^, Buff[rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataOfs],
4079	<	rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataSize);
4080	<	if (rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataType = SQL_TEXT) or
4081	<	(rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataType = SQL_VARYING) then
4082	<	rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataLength := StrLen(PChar(Buffer));
4083	<	rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdIsNull := False;
4078	>	Move(Buffer^, Buff[rdFields[MappedFieldPos].fdDataOfs],
4079	>	rdFields[MappedFieldPos].fdDataSize);
4080	>	if (rdFields[MappedFieldPos].fdDataType = SQL_TEXT) or
4081	>	(rdFields[MappedFieldPos].fdDataType = SQL_VARYING) then
4082	>	rdFields[MappedFieldPos].fdDataLength := StrLen(PChar(Buffer));
4083	>	rdFields[MappedFieldPos].fdIsNull := False;
4084		if rdUpdateStatus = usUnmodified then
4085		begin
4086		if CachedUpdates then
#	Line 3354 | Line 4104 | begin
4104		end;
4105		end;
4106		if not (State in [dsCalcFields, dsFilter, dsNewValue]) then
4107	<	DataEvent(deFieldChange, Longint(Field));
4107	>	DataEvent(deFieldChange, PtrInt(Field));
4108		end;
4109
4110		procedure TIBCustomDataSet.SetRecNo(Value: Integer);
#	Line 3418 | Line 4168 | begin
4168		FillChar(Buffer[FRecordSize], CalcFieldsSize, 0);
4169		end;
4170
4171	+	procedure TIBCustomDataSet.ClearIBLinks;
4172	+	var i: integer;
4173	+	begin
4174	+	for i := FIBLinks.Count - 1 downto 0 do
4175	+	TIBControlLink(FIBLinks[i]).IBDataSet := nil;
4176	+	end;
4177	+
4178
4179		procedure TIBCustomDataSet.InternalUnPrepare;
4180		begin
#	Line 3425 | Line 4182 | begin
4182		begin
4183		CheckDatasetClosed;
4184		FieldDefs.Clear;
4185	+	FieldDefs.Updated := false;
4186		FInternalPrepared := False;
4187	+	Setlength(FAliasNameList,0);
4188		end;
4189		end;
4190
4191		procedure TIBCustomDataSet.InternalExecQuery;
4192		var
4193		DidActivate: Boolean;
3435	–	SetCursor: Boolean;
4194		begin
4195		DidActivate := False;
4196	<	SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault);
3439	<	if SetCursor then
3440	<	Screen.Cursor := crHourGlass;
4196	>	FBase.SetCursor;
4197		try
4198		ActivateConnection;
4199		DidActivate := ActivateTransaction;
#	Line 3454 | Line 4210 | begin
4210		finally
4211		if DidActivate then
4212		DeactivateTransaction;
4213	<	if SetCursor and (Screen.Cursor = crHourGlass) then
3458	<	Screen.Cursor := crDefault;
4213	>	FBase.RestoreCursor;
4214		end;
4215		end;
4216
#	Line 3464 | Line 4219 | begin
4219		Result := FQSelect.Handle;
4220		end;
4221
4222	+	function TIBCustomDataSet.GetParser: TSelectSQLParser;
4223	+	begin
4224	+	if not assigned(FParser) then
4225	+	FParser := CreateParser;
4226	+	Result := FParser
4227	+	end;
4228	+
4229	+	procedure TIBCustomDataSet.ResetParser;
4230	+	begin
4231	+	if assigned(FParser) then
4232	+	begin
4233	+	FParser.Free;
4234	+	FParser := nil;
4235	+	FQSelect.OnSQLChanged := nil; {Do not react to change}
4236	+	try
4237	+	FQSelect.SQL.Assign(FBaseSQLSelect);
4238	+	finally
4239	+	FQSelect.OnSQLChanged := SQLChanged;
4240	+	end;
4241	+	end;
4242	+	end;
4243	+
4244	+	function TIBCustomDataSet.HasParser: boolean;
4245	+	begin
4246	+	Result := not (csDesigning in ComponentState) and (FParser <> nil)
4247	+	end;
4248	+
4249	+	procedure TIBCustomDataSet.SetGenerateParamNames(AValue: Boolean);
4250	+	begin
4251	+	if FGenerateParamNames = AValue then Exit;
4252	+	FGenerateParamNames := AValue;
4253	+	Disconnect
4254	+	end;
4255	+
4256		procedure TIBCustomDataSet.InitRecord(Buffer: PChar);
4257		begin
4258		inherited InitRecord(Buffer);
#	Line 3482 | Line 4271 | end;
4271
4272		{ TIBDataSet IProviderSupport }
4273
4274	<	procedure TIBCustomDataSet.PSEndTransaction(Commit: Boolean);
4274	>	(*procedure TIBCustomDataSet.PSEndTransaction(Commit: Boolean);
4275		begin
4276		if Commit then
4277		Transaction.Commit else
#	Line 3645 | Line 4434 | begin
4434		if not FQSelect.Prepared then
4435		FQSelect.Prepare;
4436		Result := FQSelect.UniqueRelationName;
4437	<	end;
4437	>	end;*)
4438
4439		procedure TIBDataSet.BatchInput(InputObject: TIBBatchInput);
4440		begin
#	Line 3682 | Line 4471 | begin
4471		ActivateConnection;
4472		ActivateTransaction;
4473		InternalSetParamsFromCursor;
4474	<	Inherited;
4474	>	Inherited InternalOpen;
4475		end;
4476
4477		procedure TIBDataSet.SetFiltered(Value: Boolean);
#	Line 3710 | Line 4499 | end;
4499
4500		function TIBCustomDataSet.GetFieldData(Field: TField;
4501		Buffer: Pointer): Boolean;
4502	+	{$IFDEF TBCDFIELD_IS_BCD}
4503		var
4504		lTempCurr : System.Currency;
4505		begin
#	Line 3720 | Line 4510 | begin
4510		CurrToBCD(lTempCurr, TBCD(Buffer^), 32, Field.Size);
4511		end
4512		else
4513	+	{$ELSE}
4514	+	begin
4515	+	{$ENDIF}
4516		Result := InternalGetFieldData(Field, Buffer);
4517		end;
4518
#	Line 3733 | Line 4526 | begin
4526		end;
4527
4528		procedure TIBCustomDataSet.SetFieldData(Field: TField; Buffer: Pointer);
4529	+	{$IFDEF TDBDFIELD_IS_BCD}
4530		var
4531		lTempCurr : System.Currency;
4532		begin
4533	<	if Field.DataType = ftBCD then
4533	>	if (Field.DataType = ftBCD) and (Buffer <> nil) then
4534		begin
4535		BCDToCurr(TBCD(Buffer^), lTempCurr);
4536		InternalSetFieldData(Field, @lTempCurr);
4537		end
4538		else
4539	+	{$ELSE}
4540	+	begin
4541	+	{$ENDIF}
4542		InternalSetFieldData(Field, Buffer);
4543		end;
4544
#	Line 3765 | Line 4562 | end;
4562		destructor TIBDataSetUpdateObject.Destroy;
4563		begin
4564		FRefreshSQL.Free;
4565	<	inherited destroy;
4565	>	inherited Destroy;
4566		end;
4567
4568		procedure TIBDataSetUpdateObject.SetRefreshSQL(Value: TStrings);
#	Line 3773 | Line 4570 | begin
4570		FRefreshSQL.Assign(Value);
4571		end;
4572
4573	+	procedure TIBDataSetUpdateObject.InternalSetParams(Query: TIBSQL; buff: PChar);
4574	+	begin
4575	+	if not Assigned(DataSet) then Exit;
4576	+	DataSet.SetInternalSQLParams(Query, buff);
4577	+	end;
4578	+
4579		{ TIBDSBlobStream }
4580		constructor TIBDSBlobStream.Create(AField: TField; ABlobStream: TIBBlobStream;
4581		Mode: TBlobStreamMode);
#	Line 3784 | Line 4587 | begin
4587		FBlobStream.Truncate;
4588		end;
4589
4590	+	destructor TIBDSBlobStream.Destroy;
4591	+	begin
4592	+	if FHasWritten then
4593	+	TIBCustomDataSet(FField.DataSet).DataEvent(deFieldChange, PtrInt(FField));
4594	+	inherited Destroy;
4595	+	end;
4596	+
4597		function TIBDSBlobStream.Read(var Buffer; Count: Longint): Longint;
4598		begin
4599		result := FBlobStream.Read(Buffer, Count);
#	Line 3804 | Line 4614 | begin
4614		if not (FField.DataSet.State in [dsEdit, dsInsert]) then
4615		IBError(ibxeNotEditing, [nil]);
4616		TIBCustomDataSet(FField.DataSet).RecordModified(True);
4617	+	TBlobField(FField).Modified := true;
4618		result := FBlobStream.Write(Buffer, Count);
4619	<	TIBCustomDataSet(FField.DataSet).DataEvent(deFieldChange, Longint(FField));
4619	>	FHasWritten := true;
4620	>	{  TIBCustomDataSet(FField.DataSet).DataEvent(deFieldChange, PtrInt(FField));
4621	>	Removed as this caused a seek to beginning of the blob stream thus corrupting
4622	>	the blob stream. Moved to the destructor i.e. called after blob written}
4623	>	end;
4624	>
4625	>	{ TIBGenerator }
4626	>
4627	>	procedure TIBGenerator.SetIncrement(const AValue: integer);
4628	>	begin
4629	>	if AValue < 0 then
4630	>	raise Exception.Create('A Generator Increment cannot be negative');
4631	>	FIncrement := AValue
4632	>	end;
4633	>
4634	>	function TIBGenerator.GetNextValue(ADatabase: TIBDatabase;
4635	>	ATransaction: TIBTransaction): integer;
4636	>	begin
4637	>	with TIBSQL.Create(nil) do
4638	>	try
4639	>	Database := ADatabase;
4640	>	Transaction := ATransaction;
4641	>	if not assigned(Database) then
4642	>	IBError(ibxeCannotSetDatabase,[]);
4643	>	if not assigned(Transaction) then
4644	>	IBError(ibxeCannotSetTransaction,[]);
4645	>	with Transaction do
4646	>	if not InTransaction then StartTransaction;
4647	>	SQL.Text := Format('Select Gen_ID(%s,%d) as ID From RDB$Database',[FGeneratorName,Increment]);
4648	>	Prepare;
4649	>	ExecQuery;
4650	>	try
4651	>	Result := FieldByName('ID').AsInteger
4652	>	finally
4653	>	Close
4654	>	end;
4655	>	finally
4656	>	Free
4657	>	end;
4658	>	end;
4659	>
4660	>	constructor TIBGenerator.Create(Owner: TIBCustomDataSet);
4661	>	begin
4662	>	FOwner := Owner;
4663	>	FIncrement := 1;
4664		end;
4665
4666	+
4667	+	procedure TIBGenerator.Apply;
4668	+	begin
4669	+	if (FGeneratorName <> '') and (FFieldName <> '') and Owner.FieldByName(FFieldName).IsNull then
4670	+	Owner.FieldByName(FFieldName).AsInteger := GetNextValue(Owner.Database,Owner.Transaction);
4671	+	end;
4672	+
4673	+
4674		end.

Diff Legend

–	Removed lines
+	Added lines
<	Changed lines
>	Changed lines