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 7 by tony, Sun Aug 5 18:28:19 2012 UTC vs.
Revision 39 by tony, Tue May 17 08:14:52 2016 UTC

#	Line 27 | Line 27
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                                                 }
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}
#	Line 47 | Line 55 | uses
55		{$ELSE}
56		unix,
57		{$ENDIF}
58	<	SysUtils, Classes, Forms, Controls, IBDatabase,
59	<	IBExternals, IB, IBHeader,  IBSQL, Db,
52	<	IBUtils, IBBlob;
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}
#	Line 118 | Line 125 | type
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;
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 }
#	Line 147 | Line 178 | type
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;
#	Line 185 | Line 267 | type
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 UpdateAction: TIBUpdateAction)
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;
#	Line 223 | Line 327 | type
327		FDeletedRecords: Long;
328		FModelBuffer,
329		FOldBuffer: PChar;
330	+	FOnValidatePost: TOnValidatePost;
331		FOpen: Boolean;
332		FInternalPrepared: Boolean;
333		FQDelete,
#	Line 233 | Line 338 | type
338		FRecordBufferSize: Integer;
339		FRecordCount: Integer;
340		FRecordSize: Integer;
341	+	FDataSetCloseAction: TDataSetCloseAction;
342		FUniDirectional: Boolean;
343		FUpdateMode: TUpdateMode;
344		FUpdateObject: TIBDataSetUpdateObject;
#	Line 250 | Line 356 | type
356		FBeforeTransactionEnd,
357		FAfterTransactionEnd,
358		FTransactionFree: TNotifyEvent;
359	<
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);
#	Line 263 | Line 375 | type
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);
383	>	procedure DoBeforeTransactionEnd(Sender: TObject; Action: TTransactionAction);
384		procedure DoAfterTransactionEnd(Sender: TObject);
385		procedure DoTransactionFree(Sender: TObject);
386		procedure FetchCurrentRecordToBuffer(Qry: TIBSQL; RecordNumber: Integer;
#	Line 283 | Line 396 | type
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);
#	Line 302 | Line 418 | type
418		procedure SetUpdateRecordTypes(Value: TIBUpdateRecordTypes);
419		procedure SetUniDirectional(Value: Boolean);
420		procedure RefreshParams;
305	–	procedure SQLChanging(Sender: TObject); virtual;
421		function AdjustPosition(FCache: PChar; Offset: DWORD;
422		Origin: Integer): DWORD;
423		procedure ReadCache(FCache: PChar; Offset: DWORD; Origin: Integer;
#	Line 321 | Line 436 | type
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;
#	Line 330 | Line 447 | type
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;
#	Line 353 | Line 472 | type
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;
#	Line 385 | Line 512 | type
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;
#	Line 397 | Line 526 | type
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;
#	Line 420 | Line 550 | type
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;
#	Line 433 | Line 565 | type
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;
#	Line 440 | Line 573 | type
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;
#	Line 456 | Line 592 | type
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;
#	Line 469 | Line 607 | type
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;
#	Line 507 | Line 647 | type
647		write FOnUpdateRecord;
648		end;
649
650	<	TIBDataSet = class(TIBCustomDataSet)
650	>	TIBParserDataSet = class(TIBCustomDataSet)
651	>	public
652	>	property Parser;
653	>	end;
654	>
655	>	TIBDataSet = class(TIBParserDataSet)
656		private
657		function GetPrepared: Boolean;
658
#	Line 532 | Line 677 | type
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;
#	Line 543 | Line 690 | type
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;
#	Line 581 | Line 730 | type
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		public
744		constructor Create(AField: TField; ABlobStream: TIBBlobStream;
745		Mode: TBlobStreamMode);
746	+	destructor Destroy; override;
747		function Read(var Buffer; Count: Longint): Longint; override;
748		function Seek(Offset: Longint; Origin: Word): Longint; override;
749		procedure SetSize(NewSize: Longint); override;
#	Line 615 | Line 768 | DefaultFieldClasses: array[TFieldType] o
768		TVarBytesField,     { ftVarBytes }
769		TAutoIncField,      { ftAutoInc }
770		TBlobField,         { ftBlob }
771	<	TMemoField,         { ftMemo }
771	>	TIBMemoField,       { ftMemo }
772		TGraphicField,      { ftGraphic }
773		TBlobField,         { ftFmtMemo }
774		TBlobField,         { ftParadoxOle }
#	Line 623 | Line 776 | DefaultFieldClasses: array[TFieldType] o
776		TBlobField,         { ftTypedBinary }
777		nil,                { ftCursor }
778		TStringField,       { ftFixedChar }
779	<	TWideStringField,    { ftWideString }
779	>	TIBWideStringField,    { ftWideString }
780		TLargeIntField,     { ftLargeInt }
781		nil,          { ftADT }
782		nil,        { ftArray }
#	Line 638 | Line 791 | DefaultFieldClasses: array[TFieldType] o
791		TDateTimeField,    {ftTimestamp}
792		TIBBCDField,       {ftFMTBcd}
793		nil,  {ftFixedWideChar}
794	<	TWideMemoField);   {ftWideMemo}
794	>	TIBWideMemoField);   {ftWideMemo}
795		(*
796		TADTField,          { ftADT }
797		TArrayField,        { ftArray }
#	Line 655 | Line 808 | DefaultFieldClasses: array[TFieldType] o
808
809		implementation
810
811	<	uses IBIntf, Variants, FmtBCD;
811	>	uses IBIntf, Variants, FmtBCD, LazUTF8;
812
813		const FILE_BEGIN = 0;
814		FILE_CURRENT = 1;
#	Line 678 | Line 831 | type
831		NextRelation : TRelationNode;
832		end;
833
834	+	{Extended Field Def for character set info}
835
836	<	{ TIBStringField}
836	>	{ TIBFieldDef }
837	>
838	>	TIBFieldDef = class(TFieldDef)
839	>	private
840	>	FCharacterSetName: RawByteString;
841	>	FCharacterSetSize: integer;
842	>	{$IFDEF HAS_ANSISTRING_CODEPAGE}
843	>	FCodePage: TSystemCodePage;
844	>	{$ENDIF}
845	>	published
846	>	property CharacterSetName: RawByteString read FCharacterSetName write FCharacterSetName;
847	>	property CharacterSetSize: integer read FCharacterSetSize write FCharacterSetSize;
848	>	{$IFDEF HAS_ANSISTRING_CODEPAGE}
849	>	property CodePage: TSystemCodePage read FCodePage write FCodePage;
850	>	{$ENDIF}
851	>	end;
852
853	<	constructor TIBStringField.Create(AOwner: TComponent);
853	>
854	>	{  Copied from LCLProc in order to avoid LCL dependency
855	>
856	>	Ensures the covenient look of multiline string
857	>	when displaying it in the single line
858	>	* Replaces CR and LF with spaces
859	>	* Removes duplicate spaces
860	>	}
861	>	function TextToSingleLine(const AText: string): string;
862	>	var
863	>	str: string;
864	>	i, wstart, wlen: Integer;
865	>	begin
866	>	str := Trim(AText);
867	>	wstart := 0;
868	>	wlen := 0;
869	>	i := 1;
870	>	while i < Length(str) - 1 do
871	>	begin
872	>	if (str[i] in [' ', #13, #10]) then
873	>	begin
874	>	if (wstart = 0) then
875	>	begin
876	>	wstart := i;
877	>	wlen := 1;
878	>	end else
879	>	Inc(wlen);
880	>	end else
881	>	begin
882	>	if wstart > 0 then
883	>	begin
884	>	str[wstart] := ' ';
885	>	Delete(str, wstart+1, wlen-1);
886	>	Dec(i, wlen-1);
887	>	wstart := 0;
888	>	end;
889	>	end;
890	>	Inc(i);
891	>	end;
892	>	Result := str;
893	>	end;
894	>
895	>	{ TIBWideMemoField }
896	>
897	>	function TIBWideMemoField.GetTruncatedText: string;
898	>	begin
899	>	Result := GetAsString;
900	>
901	>	if Result <> '' then
902	>	if DisplayWidth = 0 then
903	>	Result := TextToSingleLine(Result)
904	>	else
905	>	if Length(Result) > DisplayWidth then {Show truncation with elipses}
906	>	Result := TextToSingleLine(system.copy(Result,1,DisplayWidth-3)) + '...';
907	>	end;
908	>
909	>	function TIBWideMemoField.GetDefaultWidth: Longint;
910	>	begin
911	>	Result := 128;
912	>	end;
913	>
914	>	procedure TIBWideMemoField.GetText(var AText: string; ADisplayText: Boolean);
915	>	begin
916	>	if ADisplayText then
917	>	begin
918	>	if not DisplayTextAsClassName and (CharacterSetName<> '') then
919	>	AText := GetTruncatedText
920	>	else
921	>	inherited GetText(AText, ADisplayText);
922	>	end
923	>	else
924	>	AText := GetAsString;
925	>	end;
926	>
927	>	constructor TIBWideMemoField.Create(AOwner: TComponent);
928		begin
929		inherited Create(AOwner);
930	+	BlobType := ftWideMemo;
931	+	end;
932	+
933	+	{ TIBMemoField }
934	+
935	+	function TIBMemoField.GetTruncatedText: string;
936	+	begin
937	+	Result := GetAsString;
938	+
939	+	if Result <> '' then
940	+	begin
941	+	case CharacterSetSize of
942	+	1:
943	+	if DisplayWidth = 0 then
944	+	Result := TextToSingleLine(Result)
945	+	else
946	+	if Length(Result) > DisplayWidth then {Show truncation with elipses}
947	+	Result := TextToSingleLine(system.copy(Result,1,DisplayWidth-3)) + '...';
948	+
949	+	{2: case 2 ignored. This should be handled by TIBWideMemo}
950	+
951	+	3, {Assume UNICODE_FSS is really UTF8}
952	+	4: {Include GB18030 - assuming UTF8 routine work for this codeset}
953	+	if DisplayWidth = 0 then
954	+	Result := ValidUTF8String(TextToSingleLine(Result))
955	+	else
956	+	if UTF8Length(Result) > DisplayWidth then {Show truncation with elipses}
957	+	Result := ValidUTF8String(TextToSingleLine(UTF8Copy(Result,1,DisplayWidth-3))) + '...';
958	+	end;
959	+	end
960	+	end;
961	+
962	+	function TIBMemoField.GetAsString: string;
963	+	var s: RawByteString;
964	+	begin
965	+	s := inherited GetAsString;
966	+	{$IFDEF HAS_ANSISTRING_CODEPAGE}
967	+	SetCodePage(s,CodePage,false);
968	+	{$ENDIF}
969	+	Result := s;
970	+	end;
971	+
972	+	function TIBMemoField.GetDefaultWidth: Longint;
973	+	begin
974	+	if DisplayTextAsClassName then
975	+	Result := inherited
976	+	else
977	+	Result := 128;
978	+	end;
979	+
980	+	procedure TIBMemoField.GetText(var AText: string; ADisplayText: Boolean);
981	+	begin
982	+	if ADisplayText then
983	+	begin
984	+	if not DisplayTextAsClassName and (CharacterSetName <> '') then
985	+	AText := GetTruncatedText
986	+	else
987	+	inherited GetText(AText, ADisplayText);
988	+	end
989	+	else
990	+	AText := GetAsString;
991	+	end;
992	+
993	+	procedure TIBMemoField.SetAsString(const AValue: string);
994	+	var s: RawByteString;
995	+	begin
996	+	s := AValue;
997	+	{$IFDEF HAS_ANSISTRING_CODEPAGE}
998	+	if StringCodePage(Value) <> CodePage then
999	+	SetCodePage(s,CodePage,true);
1000	+	{$ENDIF}
1001	+	inherited SetAsString(s);
1002	+	end;
1003	+
1004	+	constructor TIBMemoField.Create(AOwner: TComponent);
1005	+	begin
1006	+	inherited Create(AOwner);
1007	+	BlobType := ftMemo;
1008	+	{$IFDEF HAS_ANSISTRING_CODEPAGE}
1009	+	FCodePage := CP_NONE;
1010	+	{$ENDIF}
1011	+	end;
1012	+
1013	+	{ TIBControlLink }
1014	+
1015	+	destructor TIBControlLink.Destroy;
1016	+	begin
1017	+	IBDataSet := nil;
1018	+	inherited Destroy;
1019	+	end;
1020	+
1021	+	procedure TIBControlLink.UpdateParams(Sender: TObject);
1022	+	begin
1023	+
1024	+	end;
1025	+
1026	+	procedure TIBControlLink.UpdateSQL(Sender: TObject);
1027	+	begin
1028	+
1029	+	end;
1030	+
1031	+	procedure TIBControlLink.SetIBDataSet(AValue: TIBCustomDataSet);
1032	+	begin
1033	+	if FTIBDataSet = AValue then Exit;
1034	+	if IBDataSet <> nil then
1035	+	IBDataSet.UnRegisterIBLink(self);
1036	+	FTIBDataSet := AValue;
1037	+	if IBDataSet <> nil then
1038	+	IBDataSet.RegisterIBLink(self);
1039	+	end;
1040	+
1041	+
1042	+	{ TIBStringField}
1043	+
1044	+	function TIBStringField.GetDefaultWidth: Longint;
1045	+	begin
1046	+	Result := Size div CharacterSetSize;
1047	+	end;
1048	+
1049	+	constructor TIBStringField.Create(aOwner: TComponent);
1050	+	begin
1051	+	inherited Create(aOwner);
1052	+	FCharacterSetSize := 1;
1053	+	{$IFDEF HAS_ANSISTRING_CODEPAGE}
1054	+	FCodePage := CP_NONE;
1055	+	{$ENDIF}
1056		end;
1057
1058		class procedure TIBStringField.CheckTypeSize(Value: Integer);
#	Line 706 | Line 1075 | end;
1075		function TIBStringField.GetValue(var Value: string): Boolean;
1076		var
1077		Buffer: PChar;
1078	+	s: RawByteString;
1079		begin
1080		Buffer := nil;
1081		IBAlloc(Buffer, 0, Size + 1);
#	Line 713 | Line 1083 | begin
1083		Result := GetData(Buffer);
1084		if Result then
1085		begin
1086	+	{$IFDEF HAS_ANSISTRING_CODEPAGE}
1087	+	s := string(Buffer);
1088	+	SetCodePage(s,CodePage,false);
1089	+	Value := s;
1090	+	//      writeln(FieldName,': ', StringCodePage(Value),', ',Value);
1091	+	{$ELSE}
1092		Value := string(Buffer);
1093	+	{$ENDIF}
1094		if Transliterate and (Value <> '') then
1095		DataSet.Translate(PChar(Value), PChar(Value), False);
1096		end
#	Line 725 | Line 1102 | end;
1102		procedure TIBStringField.SetAsString(const Value: string);
1103		var
1104		Buffer: PChar;
1105	+	s: RawByteString;
1106		begin
1107		Buffer := nil;
1108		IBAlloc(Buffer, 0, Size + 1);
1109		try
1110	<	StrLCopy(Buffer, PChar(Value), Size);
1110	>	s := Value;
1111	>	{$IFDEF HAS_ANSISTRING_CODEPAGE}
1112	>	if StringCodePage(s) <> CodePage then
1113	>	SetCodePage(s,CodePage,true);
1114	>	{$ENDIF}
1115	>	StrLCopy(Buffer, PChar(s), Size);
1116		if Transliterate then
1117		DataSet.Translate(Buffer, Buffer, True);
1118		SetData(Buffer);
#	Line 738 | Line 1121 | begin
1121		end;
1122		end;
1123
1124	+
1125		{ TIBBCDField }
1126
1127		constructor TIBBCDField.Create(AOwner: TComponent);
#	Line 835 | Line 1219 | begin
1219		CheckIBLoaded;
1220		FIBLoaded := True;
1221		FBase := TIBBase.Create(Self);
1222	+	FIBLinks := TList.Create;
1223		FCurrentRecord := -1;
1224		FDeletedRecords := 0;
1225		FUniDirectional := False;
#	Line 853 | Line 1238 | begin
1238		FQRefresh.GoToFirstRecordOnExecute := False;
1239		FQSelect := TIBSQL.Create(Self);
1240		FQSelect.OnSQLChanging := SQLChanging;
1241	+	FQSelect.OnSQLChanged := SQLChanged;
1242		FQSelect.GoToFirstRecordOnExecute := False;
1243		FQModify := TIBSQL.Create(Self);
1244		FQModify.OnSQLChanging := SQLChanging;
1245		FQModify.GoToFirstRecordOnExecute := False;
1246		FUpdateRecordTypes := [cusUnmodified, cusModified, cusInserted];
1247		FParamCheck := True;
1248	+	FGenerateParamNames := False;
1249		FForcedRefresh := False;
1250	+	FAutoCommit:= acDisabled;
1251	+	FDataSetCloseAction := dcDiscardChanges;
1252		{Bookmark Size is Integer for IBX}
1253		BookmarkSize := SizeOf(Integer);
1254		FBase.BeforeDatabaseDisconnect := DoBeforeDatabaseDisconnect;
#	Line 873 | Line 1262 | begin
1262		else
1263		if AOwner is TIBTransaction then
1264		Transaction := TIBTransaction(AOwner);
1265	+	FBaseSQLSelect := TStringList.Create;
1266		end;
1267
1268		destructor TIBCustomDataSet.Destroy;
#	Line 884 | Line 1274 | begin
1274		FDataLink.Free;
1275		FBase.Free;
1276		ClearBlobCache;
1277	+	ClearIBLinks;
1278	+	FIBLinks.Free;
1279		FBlobStreamList.Free;
1280		FreeMem(FBufferCache);
1281		FBufferCache := nil;
#	Line 893 | Line 1285 | begin
1285		FOldCacheSize := 0;
1286		FMappedFieldPosition := nil;
1287		end;
1288	+	if assigned(FBaseSQLSelect) then FBaseSQLSelect.Free;
1289	+	if assigned(FParser) then FParser.Free;
1290		inherited Destroy;
1291		end;
1292
#	Line 934 | Line 1328 | end;
1328
1329		procedure TIBCustomDataSet.ApplyUpdates;
1330		var
1331	<	{$IF FPC_FULLVERSION > 20600 }
1331	>	{$IFDEF NEW_TBOOKMARK }
1332		CurBookmark: TBookmark;
1333		{$ELSE}
1334		CurBookmark: string;
#	Line 1136 | Line 1530 | begin
1530		end;
1531		end;
1532
1533	+	function TIBCustomDataSet.GetFieldPosition(AliasName: string): integer;
1534	+	var i: integer;
1535	+	Prepared: boolean;
1536	+	begin
1537	+	Result := 0;
1538	+	Prepared := FInternalPrepared;
1539	+	if not Prepared then
1540	+	InternalPrepare;
1541	+	try
1542	+	for i := 0 to Length(FAliasNameList) - 1 do
1543	+	if FAliasNameList[i] = AliasName then
1544	+	begin
1545	+	Result := i + 1;
1546	+	Exit
1547	+	end;
1548	+	finally
1549	+	if not Prepared then
1550	+	InternalUnPrepare;
1551	+	end;
1552	+	end;
1553	+
1554		procedure TIBCustomDataSet.ActivateConnection;
1555		begin
1556		if not Assigned(Database) then
#	Line 1196 | Line 1611 | begin
1611		IBError(ibxeDatasetClosed, [nil]);
1612		end;
1613
1614	+	function TIBCustomDataSet.CreateParser: TSelectSQLParser;
1615	+	begin
1616	+	Result := TSelectSQLParser.Create(self,FBaseSQLSelect);
1617	+	Result.OnSQLChanging := SQLChanging
1618	+	end;
1619	+
1620		procedure TIBCustomDataSet.CheckNotUniDirectional;
1621		begin
1622		if UniDirectional then
#	Line 1299 | Line 1720 | begin
1720		FDatabaseFree(Sender);
1721		end;
1722
1723	<	procedure TIBCustomDataSet.DoBeforeTransactionEnd(Sender: TObject);
1723	>	procedure TIBCustomDataSet.DoBeforeTransactionEnd(Sender: TObject;
1724	>	Action: TTransactionAction);
1725		begin
1726	<	if Active then
1727	<	Active := False;
1726	>	FCloseAction := Action;
1727	>	FInTransactionEnd := true;
1728	>	try
1729	>	if Active then
1730	>	Active := False;
1731	>	finally
1732	>	FInTransactionEnd := false;
1733	>	end;
1734		if FQSelect <> nil then
1735		FQSelect.FreeHandle;
1736		if FQDelete <> nil then
#	Line 1340 | Line 1768 | var
1768		LocalData: Pointer;
1769		LocalDate, LocalDouble: Double;
1770		LocalInt: Integer;
1771	+	LocalBool: wordBool;
1772		LocalInt64: Int64;
1773		LocalCurrency: Currency;
1774		FieldsLoaded: Integer;
#	Line 1484 | Line 1913 | begin
1913		end;
1914		end;
1915		end;
1916	+	SQL_BOOLEAN:
1917	+	begin
1918	+	LocalBool:= false;
1919	+	rdFields[j].fdDataSize := SizeOf(wordBool);
1920	+	if RecordNumber >= 0 then
1921	+	LocalBool := Qry.Current[i].AsBoolean;
1922	+	LocalData := PChar(@LocalBool);
1923	+	end;
1924		else { SQL_TEXT, SQL_BLOB, SQL_ARRAY, SQL_QUAD }
1925		begin
1926		rdFields[j].fdDataSize := Qry.Current[i].Data^.sqllen;
#	Line 1626 | Line 2063 | function TIBCustomDataSet.InternalLocate
2063		const KeyValues: Variant; Options: TLocateOptions): Boolean;
2064		var
2065		keyFieldList: TList;
2066	<	{$IF FPC_FULLVERSION > 20600 }
2066	>	{$IFDEF NEW_TBOOKMARK }
2067		CurBookmark: TBookmark;
2068		{$ELSE}
2069		CurBookmark: string;
#	Line 1755 | Line 2192 | end;
2192		procedure TIBCustomDataSet.InternalRefreshRow;
2193		var
2194		Buff: PChar;
1758	–	SetCursor: Boolean;
2195		ofs: DWORD;
2196		Qry: TIBSQL;
2197		begin
2198	<	SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault);
1763	<	if SetCursor then
1764	<	Screen.Cursor := crHourGlass;
2198	>	FBase.SetCursor;
2199		try
2200		Buff := GetActiveBuf;
2201		if CanRefresh then
#	Line 1805 | Line 2239 | begin
2239		else
2240		IBError(ibxeCannotRefresh, [nil]);
2241		finally
2242	<	if SetCursor and (Screen.Cursor = crHourGlass) then
1809	<	Screen.Cursor := crDefault;
2242	>	FBase.RestoreCursor;
2243		end;
2244		end;
2245
#	Line 1877 | Line 2310 | end;
2310
2311		procedure TIBCustomDataSet.InternalPrepare;
2312		var
1880	–	SetCursor: Boolean;
2313		DidActivate: Boolean;
2314		begin
2315		if FInternalPrepared then
2316		Exit;
2317		DidActivate := False;
2318	<	SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault);
1887	<	if SetCursor then
1888	<	Screen.Cursor := crHourGlass;
2318	>	FBase.SetCursor;
2319		try
2320		ActivateConnection;
2321		DidActivate := ActivateTransaction;
2322		FBase.CheckDatabase;
2323		FBase.CheckTransaction;
2324	+	if HasParser and (FParser.SQLText <> FQSelect.SQL.Text) then
2325	+	begin
2326	+	FQSelect.OnSQLChanged := nil; {Do not react to change}
2327	+	try
2328	+	FQSelect.SQL.Text := FParser.SQLText;
2329	+	finally
2330	+	FQSelect.OnSQLChanged := SQLChanged;
2331	+	end;
2332	+	end;
2333	+	//   writeln( FQSelect.SQL.Text);
2334		if FQSelect.SQL.Text <> '' then
2335		begin
2336		if not FQSelect.Prepared then
2337		begin
2338	+	FQSelect.GenerateParamNames := FGenerateParamNames;
2339		FQSelect.ParamCheck := ParamCheck;
2340		FQSelect.Prepare;
2341		end;
2342	+	FQDelete.GenerateParamNames := FGenerateParamNames;
2343		if (Trim(FQDelete.SQL.Text) <> '') and (not FQDelete.Prepared) then
2344		FQDelete.Prepare;
2345	+	FQInsert.GenerateParamNames := FGenerateParamNames;
2346		if (Trim(FQInsert.SQL.Text) <> '') and (not FQInsert.Prepared) then
2347		FQInsert.Prepare;
2348	+	FQRefresh.GenerateParamNames := FGenerateParamNames;
2349		if (Trim(FQRefresh.SQL.Text) <> '') and (not FQRefresh.Prepared) then
2350		FQRefresh.Prepare;
2351	+	FQModify.GenerateParamNames := FGenerateParamNames;
2352		if (Trim(FQModify.SQL.Text) <> '') and (not FQModify.Prepared) then
2353		FQModify.Prepare;
2354		FInternalPrepared := True;
#	Line 1913 | Line 2358 | begin
2358		finally
2359		if DidActivate then
2360		DeactivateTransaction;
2361	<	if SetCursor and (Screen.Cursor = crHourGlass) then
1917	<	Screen.Cursor := crDefault;
2361	>	FBase.RestoreCursor;
2362		end;
2363		end;
2364
#	Line 2105 | Line 2549 | begin
2549		SQL_TIMESTAMP:
2550		Qry.Params[i].AsDateTime :=
2551		TimeStampToDateTime(MSecsToTimeStamp(trunc(PDouble(data)^)));
2552	+	SQL_BOOLEAN:
2553	+	Qry.Params[i].AsBoolean := PWordBool(data)^;
2554		end;
2555		end;
2556		end;
#	Line 2190 | Line 2636 | begin
2636		end;
2637		end;
2638
2639	+	procedure TIBCustomDataSet.RegisterIBLink(Sender: TIBControlLink);
2640	+	begin
2641	+	if FIBLinks.IndexOf(Sender) = -1 then
2642	+	FIBLinks.Add(Sender);
2643	+	end;
2644	+
2645
2646		procedure TIBCustomDataSet.SQLChanging(Sender: TObject);
2647		begin
2648	<	if FOpen then
2649	<	InternalClose;
2648	>	Active := false;
2649	>	{  if FOpen then
2650	>	InternalClose;}
2651		if FInternalPrepared then
2652		InternalUnPrepare;
2653	+	FieldDefs.Clear;
2654	+	FieldDefs.Updated := false;
2655	+	end;
2656	+
2657	+	procedure TIBCustomDataSet.SQLChanged(Sender: TObject);
2658	+	begin
2659	+	FBaseSQLSelect.assign(FQSelect.SQL);
2660		end;
2661
2662		{ I can "undelete" uninserted records (make them "inserted" again).
#	Line 2225 | Line 2685 | begin
2685		end;
2686		end;
2687
2688	+	procedure TIBCustomDataSet.UnRegisterIBLink(Sender: TIBControlLink);
2689	+	begin
2690	+	FIBLinks.Remove(Sender);
2691	+	end;
2692	+
2693		function TIBCustomDataSet.UpdateStatus: TUpdateStatus;
2694		begin
2695		if Active then
#	Line 2454 | Line 2919 | begin
2919		inherited DoBeforeDelete;
2920		end;
2921
2922	+	procedure TIBCustomDataSet.DoAfterDelete;
2923	+	begin
2924	+	inherited DoAfterDelete;
2925	+	FBase.DoAfterDelete(self);
2926	+	InternalAutoCommit;
2927	+	end;
2928	+
2929		procedure TIBCustomDataSet.DoBeforeEdit;
2930		var
2931		Buff: PRecordData;
#	Line 2468 | Line 2940 | begin
2940		inherited DoBeforeEdit;
2941		end;
2942
2943	+	procedure TIBCustomDataSet.DoAfterEdit;
2944	+	begin
2945	+	inherited DoAfterEdit;
2946	+	FBase.DoAfterEdit(self);
2947	+	end;
2948	+
2949		procedure TIBCustomDataSet.DoBeforeInsert;
2950		begin
2951		if not CanInsert then
#	Line 2480 | Line 2958 | begin
2958		if GeneratorField.ApplyOnEvent = gaeOnNewRecord then
2959		GeneratorField.Apply;
2960		inherited DoAfterInsert;
2961	+	FBase.DoAfterInsert(self);
2962	+	end;
2963	+
2964	+	procedure TIBCustomDataSet.DoBeforeClose;
2965	+	begin
2966	+	inherited DoBeforeClose;
2967	+	if State in [dsInsert,dsEdit] then
2968	+	begin
2969	+	if FInTransactionEnd and (FCloseAction = TARollback) then
2970	+	Exit;
2971	+
2972	+	if DataSetCloseAction = dcSaveChanges then
2973	+	Post;
2974	+	{Note this can fail with an exception e.g. due to
2975	+	database validation error. In which case the dataset remains open }
2976	+	end;
2977	+	end;
2978	+
2979	+	procedure TIBCustomDataSet.DoBeforeOpen;
2980	+	var i: integer;
2981	+	begin
2982	+	if assigned(FParser) then
2983	+	FParser.Reset;
2984	+	for i := 0 to FIBLinks.Count - 1 do
2985	+	TIBControlLink(FIBLinks[i]).UpdateSQL(self);
2986	+	inherited DoBeforeOpen;
2987	+	for i := 0 to FIBLinks.Count - 1 do
2988	+	TIBControlLink(FIBLinks[i]).UpdateParams(self);
2989		end;
2990
2991		procedure TIBCustomDataSet.DoBeforePost;
#	Line 2490 | Line 2996 | begin
2996		GeneratorField.Apply
2997		end;
2998
2999	+	procedure TIBCustomDataSet.DoAfterPost;
3000	+	begin
3001	+	inherited DoAfterPost;
3002	+	FBase.DoAfterPost(self);
3003	+	InternalAutoCommit;
3004	+	end;
3005	+
3006		procedure TIBCustomDataSet.FetchAll;
3007		var
3008	<	SetCursor: Boolean;
2496	<	{$IF FPC_FULLVERSION > 20600 }
3008	>	{$IFDEF NEW_TBOOKMARK }
3009		CurBookmark: TBookmark;
3010		{$ELSE}
3011		CurBookmark: string;
3012		{$ENDIF}
3013		begin
3014	<	SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault);
3015	<	if SetCursor then
2504	<	Screen.Cursor := crHourGlass;
2505	<	try
3014	>	FBase.SetCursor;
3015	>	try
3016		if FQSelect.EOF or not FQSelect.Open then
3017		exit;
3018		DisableControls;
#	Line 2514 | Line 3024 | begin
3024		EnableControls;
3025		end;
3026		finally
3027	<	if SetCursor and (Screen.Cursor = crHourGlass) then
2518	<	Screen.Cursor := crDefault;
3027	>	FBase.RestoreCursor;
3028		end;
3029		end;
3030
#	Line 2563 | Line 3072 | begin
3072		result := FDataLink.DataSource;
3073		end;
3074
3075	+	function TIBCustomDataSet.GetDBAliasName(FieldNo: integer): string;
3076	+	begin
3077	+	Result := FAliasNameMap[FieldNo-1]
3078	+	end;
3079	+
3080	+	function TIBCustomDataSet.GetFieldDefFromAlias(aliasName: string): TFieldDef;
3081	+	var
3082	+	i: integer;
3083	+	begin
3084	+	Result := nil;
3085	+	for i := 0 to Length(FAliasNameMap) - 1 do
3086	+	if FAliasNameMap[i] = aliasName then
3087	+	begin
3088	+	Result := FieldDefs[i];
3089	+	Exit
3090	+	end;
3091	+	end;
3092	+
3093		function TIBCustomDataSet.GetFieldClass(FieldType: TFieldType): TFieldClass;
3094		begin
3095		Result := DefaultFieldClasses[FieldType];
#	Line 2603 | Line 3130 | begin
3130		Data := Buff + CurrentRecord^.rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataOfs;
3131		if (fdDataType = SQL_VARYING) or (fdDataType = SQL_TEXT) then
3132		begin
3133	<	if fdDataLength <= Field.Size then
3133	>	if fdDataLength < Field.DataSize then
3134		begin
3135		Move(Data^, Buffer^, fdDataLength);
3136		PChar(Buffer)[fdDataLength] := #0;
#	Line 2652 | Line 3179 | begin
3179		if not Accept and (GetMode = gmCurrent) then
3180		GetMode := gmPrior;
3181		except
3182	<	//        Application.HandleException(Self);
3182	>	//        FBase.HandleException(Self);
3183		end;
3184		end;
3185		RestoreState(SaveState);
#	Line 2746 | Line 3273 | begin
3273		result := FRecordBufferSize;
3274		end;
3275
3276	+	procedure TIBCustomDataSet.InternalAutoCommit;
3277	+	begin
3278	+	with Transaction do
3279	+	if InTransaction and (FAutoCommit = acCommitRetaining) then
3280	+	begin
3281	+	if CachedUpdates then ApplyUpdates;
3282	+	CommitRetaining;
3283	+	end;
3284	+	end;
3285	+
3286		procedure TIBCustomDataSet.InternalAddRecord(Buffer: Pointer; Append: Boolean);
3287		begin
3288		CheckEditState;
#	Line 2817 | Line 3354 | begin
3354		FreeMem(FOldBufferCache);
3355		FOldBufferCache := nil;
3356		BindFields(False);
3357	+	ResetParser;
3358		if DefaultFields then DestroyFields;
3359		end;
3360
3361		procedure TIBCustomDataSet.InternalDelete;
3362		var
3363		Buff: PChar;
2826	–	SetCursor: Boolean;
3364		begin
3365	<	SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault);
2829	<	if SetCursor then
2830	<	Screen.Cursor := crHourGlass;
3365	>	FBase.SetCursor;
3366		try
3367		Buff := GetActiveBuf;
3368		if CanDelete then
#	Line 2852 | Line 3387 | begin
3387		end else
3388		IBError(ibxeCannotDelete, [nil]);
3389		finally
3390	<	if SetCursor and (Screen.Cursor = crHourGlass) then
2856	<	Screen.Cursor := crDefault;
3390	>	FBase.RestoreCursor;
3391		end;
3392		end;
3393
#	Line 2869 | Line 3403 | end;
3403
3404		procedure TIBCustomDataSet.InternalHandleException;
3405		begin
3406	<	Application.HandleException(Self)
3406	>	FBase.HandleException(Self)
3407		end;
3408
3409		procedure TIBCustomDataSet.InternalInitFieldDefs;
3410	+	begin
3411	+	if not InternalPrepared then
3412	+	begin
3413	+	InternalPrepare;
3414	+	exit;
3415	+	end;
3416	+	FieldDefsFromQuery(FQSelect);
3417	+	end;
3418	+
3419	+	procedure TIBCustomDataSet.FieldDefsFromQuery(SourceQuery: TIBSQL);
3420		const
3421		DefaultSQL = 'Select F.RDB$COMPUTED_BLR, ' + {do not localize}
3422		'F.RDB$DEFAULT_VALUE, R.RDB$FIELD_NAME ' + {do not localize}
#	Line 2884 | Line 3428 | const
3428		var
3429		FieldType: TFieldType;
3430		FieldSize: Word;
3431	+	charSetID: short;
3432	+	CharSetSize: integer;
3433	+	CharSetName: RawByteString;
3434	+	{$IFDEF HAS_ANSISTRING_CODEPAGE}
3435	+	FieldCodePage: TSystemCodePage;
3436	+	{$ENDIF}
3437		FieldNullable : Boolean;
3438		i, FieldPosition, FieldPrecision: Integer;
3439	<	FieldAliasName: string;
3439	>	FieldAliasName, DBAliasName: string;
3440		RelationName, FieldName: string;
3441		Query : TIBSQL;
3442		FieldIndex: Integer;
#	Line 2986 | Line 3536 | var
3536		end;
3537
3538		begin
2989	–	if not InternalPrepared then
2990	–	begin
2991	–	InternalPrepare;
2992	–	exit;
2993	–	end;
3539		FRelationNodes := TRelationNode.Create;
3540		FNeedsRefresh := False;
3541		Database.InternalTransaction.StartTransaction;
#	Line 3001 | Line 3546 | begin
3546		FieldDefs.BeginUpdate;
3547		FieldDefs.Clear;
3548		FieldIndex := 0;
3549	<	if (Length(FMappedFieldPosition) < FQSelect.Current.Count) then
3550	<	SetLength(FMappedFieldPosition, FQSelect.Current.Count);
3549	>	if (Length(FMappedFieldPosition) < SourceQuery.Current.Count) then
3550	>	SetLength(FMappedFieldPosition, SourceQuery.Current.Count);
3551		Query.SQL.Text := DefaultSQL;
3552		Query.Prepare;
3553	<	for i := 0 to FQSelect.Current.Count - 1 do
3554	<	with FQSelect.Current[i].Data^ do
3553	>	SetLength(FAliasNameMap, SourceQuery.Current.Count);
3554	>	SetLength(FAliasNameList, SourceQuery.Current.Count);
3555	>	for i := 0 to SourceQuery.Current.Count - 1 do
3556	>	with SourceQuery.Current[i].Data^ do
3557		begin
3558		{ Get the field name }
3559	<	SetString(FieldAliasName, aliasname, aliasname_length);
3559	>	FieldAliasName := SourceQuery.Current[i].Name;
3560	>	SetString(DBAliasName, aliasname, aliasname_length);
3561		SetString(RelationName, relname, relname_length);
3562		SetString(FieldName, sqlname, sqlname_length);
3563	+	FAliasNameList[i] := DBAliasName;
3564		FieldSize := 0;
3565		FieldPrecision := 0;
3566	<	FieldNullable := FQSelect.Current[i].IsNullable;
3566	>	FieldNullable := SourceQuery.Current[i].IsNullable;
3567	>	CharSetSize := 0;
3568	>	CharSetName := '';
3569	>	{$IFDEF HAS_ANSISTRING_CODEPAGE}
3570	>	FieldCodePage := CP_NONE;
3571	>	{$ENDIF}
3572		case sqltype and not 1 of
3573		{ All VARCHAR's must be converted to strings before recording
3574		their values }
3575		SQL_VARYING, SQL_TEXT:
3576		begin
3577	+	CharSetSize := FBase.GetCharSetSize(sqlsubtype and $FF);
3578	+	CharSetName := FBase.GetCharSetName(sqlsubtype and $FF);
3579	+	{$IFDEF HAS_ANSISTRING_CODEPAGE}
3580	+	FieldCodePage := FBase.GetCodePage(sqlsubtype and $FF);
3581	+	{$ENDIF}
3582	+	{FieldSize is encoded for strings - see TIBStringField.SetSize for decode}
3583		FieldSize := sqllen;
3584	<	FieldType := ftString;
3584	>	if CharSetSize = 2 then
3585	>	FieldType := ftWideString
3586	>	else
3587	>	FieldType := ftString;
3588		end;
3589		{ All Doubles/Floats should be cast to doubles }
3590		SQL_DOUBLE, SQL_FLOAT:
#	Line 3080 | Line 3643 | begin
3643		begin
3644		FieldSize := sizeof (TISC_QUAD);
3645		if (sqlsubtype = 1) then
3646	<	FieldType := ftmemo
3646	>	begin
3647	>	if FBase.GetDefaultCharSetName <> '' then
3648	>	begin
3649	>	CharSetSize := FBase.GetDefaultCharSetSize;
3650	>	CharSetName := FBase.GetDefaultCharSetName;
3651	>	{$IFDEF HAS_ANSISTRING_CODEPAGE}
3652	>	FieldCodePage := FBase.GetDefaultCodePage;
3653	>	{$ENDIF}
3654	>	end
3655	>	else
3656	>	if strpas(sqlname) <> '' then
3657	>	begin
3658	>	charSetID := GetBlobCharSetID(Database.Handle,Database.InternalTransaction.Handle,
3659	>	@relname,@sqlname);
3660	>	CharSetSize := FBase.GetCharSetSize(charSetID);
3661	>	CharSetName := FBase.GetCharSetName(charSetID);
3662	>	{$IFDEF HAS_ANSISTRING_CODEPAGE}
3663	>	FieldCodePage := FBase.GetCodePage(charSetID);
3664	>	{$ENDIF}
3665	>	end
3666	>	else  {Complex SQL with no identifiable column and no connection default}
3667	>	begin
3668	>	CharSetName := '';
3669	>	CharSetSize := 1;
3670	>	{$IFDEF HAS_ANSISTRING_CODEPAGE}
3671	>	FieldCodePage := CP_NONE;
3672	>	{$ENDIF}
3673	>	end;
3674	>	if CharSetSize = 2 then
3675	>	FieldType := ftWideMemo
3676	>	else
3677	>	FieldType := ftMemo;
3678	>	end
3679		else
3680		FieldType := ftBlob;
3681		end;
#	Line 3089 | Line 3684 | begin
3684		FieldSize := sizeof (TISC_QUAD);
3685		FieldType := ftUnknown;
3686		end;
3687	+	SQL_BOOLEAN:
3688	+	FieldType:= ftBoolean;
3689		else
3690		FieldType := ftUnknown;
3691		end;
#	Line 3097 | Line 3694 | begin
3694		begin
3695		FMappedFieldPosition[FieldIndex] := FieldPosition;
3696		Inc(FieldIndex);
3697	<	with FieldDefs.AddFieldDef do
3697	>	with TIBFieldDef.Create(FieldDefs,'',FieldType,0,False,FieldDefs.Count+1) do
3698		begin
3699		Name := FieldAliasName;
3700	<	(*           FieldNo := FieldPosition;*)
3104	<	DataType := FieldType;
3700	>	FAliasNameMap[FieldNo-1] := DBAliasName;
3701		Size := FieldSize;
3702		Precision := FieldPrecision;
3703		Required := not FieldNullable;
3704		InternalCalcField := False;
3705	+	CharacterSetSize := CharSetSize;
3706	+	CharacterSetName := CharSetName;
3707	+	{$IFDEF HAS_ANSISTRING_CODEPAGE}
3708	+	CodePage := FieldCodePage;
3709	+	{$ENDIF}
3710		if (FieldName <> '') and (RelationName <> '') then
3711		begin
3712		if Has_COMPUTED_BLR(RelationName, FieldName) then
#	Line 3185 | Line 3786 | begin
3786		else case cur_field.DataType of
3787		ftString:
3788		cur_param.AsString := cur_field.AsString;
3789	<	ftBoolean, ftSmallint, ftWord:
3789	>	ftBoolean:
3790	>	cur_param.AsBoolean := cur_field.AsBoolean;
3791	>	ftSmallint, ftWord:
3792		cur_param.AsShort := cur_field.AsInteger;
3793		ftInteger:
3794		cur_param.AsLong := cur_field.AsInteger;
#	Line 3238 | Line 3841 | begin
3841		end;
3842
3843		procedure TIBCustomDataSet.InternalOpen;
3241	–	var
3242	–	SetCursor: Boolean;
3844
3845		function RecordDataLength(n: Integer): Long;
3846		begin
3847		result := SizeOf(TRecordData) + ((n - 1) * SizeOf(TFieldData));
3848		end;
3849
3850	+	function GetFieldDef(aFieldNo: integer): TIBFieldDef;
3851	+	var i: integer;
3852	+	begin
3853	+	Result := nil;
3854	+	for i := 0 to FieldDefs.Count - 1 do
3855	+	if FieldDefs[i].FieldNo = aFieldNo then
3856	+	begin
3857	+	Result := TIBFieldDef(FieldDefs[i]);
3858	+	break;
3859	+	end;
3860	+	end;
3861	+
3862	+	procedure SetExtendedProperties;
3863	+	var i: integer;
3864	+	IBFieldDef: TIBFieldDef;
3865	+	begin
3866	+	for i := 0 to Fields.Count - 1 do
3867	+	if Fields[i].FieldNo > 0 then
3868	+	begin
3869	+	if(Fields[i] is TIBStringField) then
3870	+	with TIBStringField(Fields[i]) do
3871	+	begin
3872	+	IBFieldDef := GetFieldDef(FieldNo);
3873	+	if IBFieldDef <> nil then
3874	+	begin
3875	+	CharacterSetSize := IBFieldDef.CharacterSetSize;
3876	+	CharacterSetName := IBFieldDef.CharacterSetName;
3877	+	{$IFDEF HAS_ANSISTRING_CODEPAGE}
3878	+	CodePage := IBFieldDef.CodePage;
3879	+	{$ENDIF}
3880	+	end;
3881	+	end
3882	+	else
3883	+	if(Fields[i] is TIBWideStringField) then
3884	+	with TIBWideStringField(Fields[i]) do
3885	+	begin
3886	+	IBFieldDef := GetFieldDef(FieldNo);
3887	+	if IBFieldDef <> nil then
3888	+	begin
3889	+	CharacterSetSize := IBFieldDef.CharacterSetSize;
3890	+	CharacterSetName := IBFieldDef.CharacterSetName;
3891	+	end;
3892	+	end
3893	+	else
3894	+	if(Fields[i] is TIBMemoField) then
3895	+	with TIBMemoField(Fields[i]) do
3896	+	begin
3897	+	IBFieldDef := GetFieldDef(FieldNo);
3898	+	if IBFieldDef <> nil then
3899	+	begin
3900	+	CharacterSetSize := IBFieldDef.CharacterSetSize;
3901	+	CharacterSetName := IBFieldDef.CharacterSetName;
3902	+	{$IFDEF HAS_ANSISTRING_CODEPAGE}
3903	+	CodePage := IBFieldDef.CodePage;
3904	+	{$ENDIF}
3905	+	end;
3906	+	end
3907	+	else
3908	+	if(Fields[i] is TIBWideMemoField) then
3909	+	with TIBWideMemoField(Fields[i]) do
3910	+	begin
3911	+	IBFieldDef := GetFieldDef(FieldNo);
3912	+	if IBFieldDef <> nil then
3913	+	begin
3914	+	CharacterSetSize := IBFieldDef.CharacterSetSize;
3915	+	CharacterSetName := IBFieldDef.CharacterSetName;
3916	+	end;
3917	+	end
3918	+	end
3919	+	end;
3920	+
3921		begin
3922	<	SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault);
3251	<	if SetCursor then
3252	<	Screen.Cursor := crHourGlass;
3922	>	FBase.SetCursor;
3923		try
3924		ActivateConnection;
3925		ActivateTransaction;
#	Line 3262 | Line 3932 | begin
3932		if DefaultFields then
3933		CreateFields;
3934		BindFields(True);
3935	+	SetExtendedProperties;
3936		FCurrentRecord := -1;
3937		FQSelect.ExecQuery;
3938		FOpen := FQSelect.Open;
#	Line 3310 | Line 3981 | begin
3981		else
3982		FQSelect.ExecQuery;
3983		finally
3984	<	if SetCursor and (Screen.Cursor = crHourGlass) then
3314	<	Screen.Cursor := crDefault;
3984	>	FBase.RestoreCursor;
3985		end;
3986		end;
3987
#	Line 3319 | Line 3989 | procedure TIBCustomDataSet.InternalPost;
3989		var
3990		Qry: TIBSQL;
3991		Buff: PChar;
3322	–	SetCursor: Boolean;
3992		bInserting: Boolean;
3993		begin
3994	<	SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault);
3326	<	if SetCursor then
3327	<	Screen.Cursor := crHourGlass;
3994	>	FBase.SetCursor;
3995		try
3996		Buff := GetActiveBuf;
3997		CheckEditState;
#	Line 3362 | Line 4029 | begin
4029		if bInserting then
4030		Inc(FRecordCount);
4031		finally
4032	<	if SetCursor and (Screen.Cursor = crHourGlass) then
3366	<	Screen.Cursor := crDefault;
4032	>	FBase.RestoreCursor;
4033		end;
4034		end;
4035
#	Line 3383 | Line 4049 | begin
4049		result := FOpen;
4050		end;
4051
4052	+	procedure TIBCustomDataSet.Loaded;
4053	+	begin
4054	+	if assigned(FQSelect) then
4055	+	FBaseSQLSelect.assign(FQSelect.SQL);
4056	+	inherited Loaded;
4057	+	end;
4058	+
4059	+	procedure TIBCustomDataSet.Post;
4060	+	var CancelPost: boolean;
4061	+	begin
4062	+	CancelPost := false;
4063	+	if assigned(FOnValidatePost) then
4064	+	OnValidatePost(self,CancelPost);
4065	+	if CancelPost then
4066	+	Cancel
4067	+	else
4068	+	inherited Post;
4069	+	end;
4070	+
4071		function TIBCustomDataSet.Locate(const KeyFields: string; const KeyValues: Variant;
4072		Options: TLocateOptions): Boolean;
4073		var
4074	<	{$IF FPC_FULLVERSION > 20600 }
4074	>	{$IFDEF NEW_TBOOKMARK }
4075		CurBookmark: TBookmark;
4076		{$ELSE}
4077		CurBookmark: string;
#	Line 3408 | Line 4093 | function TIBCustomDataSet.Lookup(const K
4093		const ResultFields: string): Variant;
4094		var
4095		fl: TList;
4096	<	{$IF FPC_FULLVERSION > 20600 }
4096	>	{$IFDEF NEW_TBOOKMARK }
4097		CurBookmark: TBookmark;
4098		{$ELSE}
4099		CurBookmark: string;
#	Line 3465 | Line 4150 | end;
4150		procedure TIBCustomDataSet.InternalSetFieldData(Field: TField; Buffer: Pointer);
4151		var
4152		Buff, TmpBuff: PChar;
4153	+	MappedFieldPos: integer;
4154		begin
4155		Buff := GetActiveBuf;
4156		if Field.FieldNo < 0 then
#	Line 3481 | Line 4167 | begin
4167		begin
4168		{ If inserting, Adjust record position }
4169		AdjustRecordOnInsert(Buff);
4170	<	if (FMappedFieldPosition[Field.FieldNo - 1] > 0) and
4171	<	(FMappedFieldPosition[Field.FieldNo - 1] <= rdFieldCount) then
4170	>	MappedFieldPos := FMappedFieldPosition[Field.FieldNo - 1];
4171	>	if (MappedFieldPos > 0) and
4172	>	(MappedFieldPos <= rdFieldCount) then
4173		begin
4174		Field.Validate(Buffer);
4175		if (Buffer = nil) or
4176		(Field is TIBStringField) and (PChar(Buffer)[0] = #0) then
4177	<	rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdIsNull := True
4177	>	rdFields[MappedFieldPos].fdIsNull := True
4178		else begin
4179	<	Move(Buffer^, Buff[rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataOfs],
4180	<	rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataSize);
4181	<	if (rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataType = SQL_TEXT) or
4182	<	(rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataType = SQL_VARYING) then
4183	<	rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataLength := StrLen(PChar(Buffer));
4184	<	rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdIsNull := False;
4179	>	Move(Buffer^, Buff[rdFields[MappedFieldPos].fdDataOfs],
4180	>	rdFields[MappedFieldPos].fdDataSize);
4181	>	if (rdFields[MappedFieldPos].fdDataType = SQL_TEXT) or
4182	>	(rdFields[MappedFieldPos].fdDataType = SQL_VARYING) then
4183	>	rdFields[MappedFieldPos].fdDataLength := StrLen(PChar(Buffer));
4184	>	rdFields[MappedFieldPos].fdIsNull := False;
4185		if rdUpdateStatus = usUnmodified then
4186		begin
4187		if CachedUpdates then
#	Line 3582 | Line 4269 | begin
4269		FillChar(Buffer[FRecordSize], CalcFieldsSize, 0);
4270		end;
4271
4272	+	procedure TIBCustomDataSet.ClearIBLinks;
4273	+	var i: integer;
4274	+	begin
4275	+	for i := FIBLinks.Count - 1 downto 0 do
4276	+	TIBControlLink(FIBLinks[i]).IBDataSet := nil;
4277	+	end;
4278	+
4279
4280		procedure TIBCustomDataSet.InternalUnPrepare;
4281		begin
#	Line 3589 | Line 4283 | begin
4283		begin
4284		CheckDatasetClosed;
4285		FieldDefs.Clear;
4286	+	FieldDefs.Updated := false;
4287		FInternalPrepared := False;
4288	+	Setlength(FAliasNameList,0);
4289		end;
4290		end;
4291
4292		procedure TIBCustomDataSet.InternalExecQuery;
4293		var
4294		DidActivate: Boolean;
3599	–	SetCursor: Boolean;
4295		begin
4296		DidActivate := False;
4297	<	SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault);
3603	<	if SetCursor then
3604	<	Screen.Cursor := crHourGlass;
4297	>	FBase.SetCursor;
4298		try
4299		ActivateConnection;
4300		DidActivate := ActivateTransaction;
#	Line 3618 | Line 4311 | begin
4311		finally
4312		if DidActivate then
4313		DeactivateTransaction;
4314	<	if SetCursor and (Screen.Cursor = crHourGlass) then
3622	<	Screen.Cursor := crDefault;
4314	>	FBase.RestoreCursor;
4315		end;
4316		end;
4317
#	Line 3628 | Line 4320 | begin
4320		Result := FQSelect.Handle;
4321		end;
4322
4323	+	function TIBCustomDataSet.GetParser: TSelectSQLParser;
4324	+	begin
4325	+	if not assigned(FParser) then
4326	+	FParser := CreateParser;
4327	+	Result := FParser
4328	+	end;
4329	+
4330	+	procedure TIBCustomDataSet.ResetParser;
4331	+	begin
4332	+	if assigned(FParser) then
4333	+	begin
4334	+	FParser.Free;
4335	+	FParser := nil;
4336	+	FQSelect.OnSQLChanged := nil; {Do not react to change}
4337	+	try
4338	+	FQSelect.SQL.Assign(FBaseSQLSelect);
4339	+	finally
4340	+	FQSelect.OnSQLChanged := SQLChanged;
4341	+	end;
4342	+	end;
4343	+	end;
4344	+
4345	+	function TIBCustomDataSet.HasParser: boolean;
4346	+	begin
4347	+	Result := not (csDesigning in ComponentState) and (FParser <> nil)
4348	+	end;
4349	+
4350	+	procedure TIBCustomDataSet.SetGenerateParamNames(AValue: Boolean);
4351	+	begin
4352	+	if FGenerateParamNames = AValue then Exit;
4353	+	FGenerateParamNames := AValue;
4354	+	Disconnect
4355	+	end;
4356	+
4357		procedure TIBCustomDataSet.InitRecord(Buffer: PChar);
4358		begin
4359		inherited InitRecord(Buffer);
#	Line 3962 | Line 4688 | begin
4688		FBlobStream.Truncate;
4689		end;
4690
4691	+	destructor TIBDSBlobStream.Destroy;
4692	+	begin
4693	+	if FHasWritten then
4694	+	TIBCustomDataSet(FField.DataSet).DataEvent(deFieldChange, PtrInt(FField));
4695	+	inherited Destroy;
4696	+	end;
4697	+
4698		function TIBDSBlobStream.Read(var Buffer; Count: Longint): Longint;
4699		begin
4700		result := FBlobStream.Read(Buffer, Count);
#	Line 3984 | Line 4717 | begin
4717		TIBCustomDataSet(FField.DataSet).RecordModified(True);
4718		TBlobField(FField).Modified := true;
4719		result := FBlobStream.Write(Buffer, Count);
4720	<	TIBCustomDataSet(FField.DataSet).DataEvent(deFieldChange, PtrInt(FField));
4720	>	FHasWritten := true;
4721	>	{  TIBCustomDataSet(FField.DataSet).DataEvent(deFieldChange, PtrInt(FField));
4722	>	Removed as this caused a seek to beginning of the blob stream thus corrupting
4723	>	the blob stream. Moved to the destructor i.e. called after blob written}
4724		end;
4725
4726		{ TIBGenerator }
#	Line 4031 | Line 4767 | end;
4767
4768		procedure TIBGenerator.Apply;
4769		begin
4770	<	if (FGeneratorName <> '') and (FFieldName <> '')  then
4770	>	if (FGeneratorName <> '') and (FFieldName <> '') and Owner.FieldByName(FFieldName).IsNull then
4771		Owner.FieldByName(FFieldName).AsInteger := GetNextValue(Owner.Database,Owner.Transaction);
4772		end;
4773
4774	+
4775		end.

Diff Legend

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