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 15 by tony, Thu Feb 28 16:56:14 2013 UTC vs.
Revision 43 by tony, Thu Sep 22 17:10:15 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 91 | Line 98 | type
98		fdDataSize: Short;
99		fdDataLength: Short;
100		fdDataOfs: Integer;
101	+	{$IFDEF HAS_ANSISTRING_CODEPAGE}
102	+	fdCodePage: TSystemCodePage;
103	+	{$ENDIF}
104		end;
105		PFieldData = ^TFieldData;
106
#	Line 118 | Line 128 | type
128		{ TIBStringField allows us to have strings longer than 8196 }
129
130		TIBStringField = class(TStringField)
131	+	private
132	+	FCharacterSetName: RawByteString;
133	+	FCharacterSetSize: integer;
134	+	protected
135	+	function GetDefaultWidth: Longint; override;
136		public
137	<	constructor create(AOwner: TComponent); override;
137	>	constructor Create(aOwner: TComponent); override;
138		class procedure CheckTypeSize(Value: Integer); override;
139		function GetAsString: string; override;
140		function GetAsVariant: Variant; override;
141		function GetValue(var Value: string): Boolean;
142		procedure SetAsString(const Value: string); override;
143	+	property CharacterSetName: RawByteString read FCharacterSetName write FCharacterSetName;
144	+	property CharacterSetSize: integer read FCharacterSetSize write FCharacterSetSize;
145	+	{$IFDEF HAS_ANSISTRING_CODEPAGE}
146	+	private
147	+	FCodePage: TSystemCodePage;
148	+	public
149	+	property CodePage: TSystemCodePage read FCodePage write FCodePage;
150	+	{$ENDIF}
151		end;
152
153		{ TIBBCDField }
#	Line 147 | Line 170 | type
170		property Size default 8;
171		end;
172
173	+	{TIBMemoField}
174	+	{Allows us to show truncated text in DBGrids and anything else that uses
175	+	DisplayText}
176	+
177	+	TIBMemoField = class(TMemoField)
178	+	private
179	+	FCharacterSetName: RawByteString;
180	+	FCharacterSetSize: integer;
181	+	FDisplayTextAsClassName: boolean;
182	+	function GetTruncatedText: string;
183	+	protected
184	+	function GetAsString: string; override;
185	+	function GetDefaultWidth: Longint; override;
186	+	procedure GetText(var AText: string; ADisplayText: Boolean); override;
187	+	procedure SetAsString(const AValue: string); override;
188	+	public
189	+	constructor Create(AOwner: TComponent); override;
190	+	property CharacterSetName: RawByteString read FCharacterSetName write FCharacterSetName;
191	+	property CharacterSetSize: integer read FCharacterSetSize write FCharacterSetSize;
192	+	published
193	+	property DisplayTextAsClassName: boolean read FDisplayTextAsClassName
194	+	write FDisplayTextAsClassName;
195	+	{$IFDEF HAS_ANSISTRING_CODEPAGE}
196	+	private
197	+	FCodePage: TSystemCodePage;
198	+	FFCodePage: TSystemCodePage;
199	+	public
200	+	property CodePage: TSystemCodePage read FFCodePage write FFCodePage;
201	+	{$ENDIF}
202	+	end;
203	+
204		TIBDataLink = class(TDetailDataLink)
205		private
206		FDataSet: TIBCustomDataSet;
#	Line 185 | Line 239 | type
239		property ApplyOnEvent: TIBGeneratorApplyOnEvent read FApplyOnEvent write FApplyOnEvent;
240		end;
241
242	+	{TIBControlLink - Allows IB Aware controls to react to dataset state changes}
243	+
244	+	TIBControlLink = class
245	+	private
246	+	FTIBDataSet: TIBCustomDataSet;
247	+	procedure SetIBDataSet(AValue: TIBCustomDataSet);
248	+	protected
249	+	procedure UpdateSQL(Sender: TObject); virtual;
250	+	procedure UpdateParams(Sender: TObject); virtual;
251	+	public
252	+	destructor Destroy; override;
253	+	property IBDataSet: TIBCustomDataSet read FTIBDataSet write SetIBDataSet;
254	+	end;
255	+
256	+	TIBAutoCommit = (acDisabled, acCommitRetaining);
257	+
258		{ TIBCustomDataSet }
259		TIBUpdateAction = (uaFail, uaAbort, uaSkip, uaRetry, uaApply, uaApplied);
260
261		TIBUpdateErrorEvent = procedure(DataSet: TDataSet; E: EDatabaseError;
262	<	UpdateKind: TUpdateKind; var UpdateAction: TIBUpdateAction)
262	>	UpdateKind: TUpdateKind; var TheUpdateAction: TIBUpdateAction)
263		of object;
264		TIBUpdateRecordEvent = procedure(DataSet: TDataSet; UpdateKind: TUpdateKind;
265		var UpdateAction: TIBUpdateAction) of object;
266
267		TIBUpdateRecordTypes = set of TCachedUpdateStatus;
268
269	+	TDataSetCloseAction = (dcDiscardChanges, dcSaveChanges);
270	+
271	+	TOnValidatePost = procedure (Sender: TObject; var CancelPost: boolean) of object;
272	+
273		TIBCustomDataSet = class(TDataset)
274		private
275	+	FAutoCommit: TIBAutoCommit;
276	+	FGenerateParamNames: Boolean;
277		FGeneratorField: TIBGenerator;
278		FNeedsRefresh: Boolean;
279		FForcedRefresh: Boolean;
#	Line 223 | Line 299 | type
299		FDeletedRecords: Long;
300		FModelBuffer,
301		FOldBuffer: PChar;
302	+	FOnValidatePost: TOnValidatePost;
303		FOpen: Boolean;
304		FInternalPrepared: Boolean;
305		FQDelete,
#	Line 233 | Line 310 | type
310		FRecordBufferSize: Integer;
311		FRecordCount: Integer;
312		FRecordSize: Integer;
313	+	FDataSetCloseAction: TDataSetCloseAction;
314		FUniDirectional: Boolean;
315		FUpdateMode: TUpdateMode;
316		FUpdateObject: TIBDataSetUpdateObject;
#	Line 250 | Line 328 | type
328		FBeforeTransactionEnd,
329		FAfterTransactionEnd,
330		FTransactionFree: TNotifyEvent;
331	<
331	>	FAliasNameMap: array of string;
332	>	FAliasNameList: array of string;
333	>	FBaseSQLSelect: TStrings;
334	>	FParser: TSelectSQLParser;
335	>	FCloseAction: TTransactionAction;
336	>	FInTransactionEnd: boolean;
337	>	FIBLinks: TList;
338		function GetSelectStmtHandle: TISC_STMT_HANDLE;
339		procedure SetUpdateMode(const Value: TUpdateMode);
340		procedure SetUpdateObject(Value: TIBDataSetUpdateObject);
#	Line 263 | Line 347 | type
347		function CanRefresh: Boolean;
348		procedure CheckEditState;
349		procedure ClearBlobCache;
350	+	procedure ClearIBLinks;
351		procedure CopyRecordBuffer(Source, Dest: Pointer);
352		procedure DoBeforeDatabaseDisconnect(Sender: TObject);
353		procedure DoAfterDatabaseDisconnect(Sender: TObject);
354		procedure DoDatabaseFree(Sender: TObject);
355	<	procedure DoBeforeTransactionEnd(Sender: TObject);
355	>	procedure DoBeforeTransactionEnd(Sender: TObject; Action: TTransactionAction);
356		procedure DoAfterTransactionEnd(Sender: TObject);
357		procedure DoTransactionFree(Sender: TObject);
358		procedure FetchCurrentRecordToBuffer(Qry: TIBSQL; RecordNumber: Integer;
#	Line 283 | Line 368 | type
368		function GetModifySQL: TStrings;
369		function GetTransaction: TIBTransaction;
370		function GetTRHandle: PISC_TR_HANDLE;
371	+	function GetParser: TSelectSQLParser;
372		procedure InternalDeleteRecord(Qry: TIBSQL; Buff: Pointer); virtual;
373		function InternalLocate(const KeyFields: string; const KeyValues: Variant;
374		Options: TLocateOptions): Boolean; virtual;
375		procedure InternalPostRecord(Qry: TIBSQL; Buff: Pointer); virtual;
376		procedure InternalRevertRecord(RecordNumber: Integer); virtual;
377		function IsVisible(Buffer: PChar): Boolean;
378	+	procedure RegisterIBLink(Sender: TIBControlLink);
379	+	procedure UnRegisterIBLink(Sender: TIBControlLink);
380		procedure SaveOldBuffer(Buffer: PChar);
381		procedure SetBufferChunks(Value: Integer);
382		procedure SetDatabase(Value: TIBDatabase);
#	Line 302 | Line 390 | type
390		procedure SetUpdateRecordTypes(Value: TIBUpdateRecordTypes);
391		procedure SetUniDirectional(Value: Boolean);
392		procedure RefreshParams;
305	–	procedure SQLChanging(Sender: TObject); virtual;
393		function AdjustPosition(FCache: PChar; Offset: DWORD;
394		Origin: Integer): DWORD;
395		procedure ReadCache(FCache: PChar; Offset: DWORD; Origin: Integer;
#	Line 321 | Line 408 | type
408		procedure DeactivateTransaction;
409		procedure CheckDatasetClosed;
410		procedure CheckDatasetOpen;
411	+	function CreateParser: TSelectSQLParser; virtual;
412	+	procedure FieldDefsFromQuery(SourceQuery: TIBSQL);
413		function GetActiveBuf: PChar;
414		procedure InternalBatchInput(InputObject: TIBBatchInput); virtual;
415		procedure InternalBatchOutput(OutputObject: TIBBatchOutput); virtual;
#	Line 330 | Line 419 | type
419		procedure InternalRefreshRow; virtual;
420		procedure InternalSetParamsFromCursor; virtual;
421		procedure CheckNotUniDirectional;
422	+	procedure SQLChanging(Sender: TObject); virtual;
423	+	procedure SQLChanged(Sender: TObject); virtual;
424
425		(*    { IProviderSupport }
426		procedure PSEndTransaction(Commit: Boolean); override;
#	Line 353 | Line 444 | type
444		procedure ClearCalcFields(Buffer: PChar); override;
445		function AllocRecordBuffer: PChar; override;
446		procedure DoBeforeDelete; override;
447	+	procedure DoAfterDelete; override;
448		procedure DoBeforeEdit; override;
449	+	procedure DoAfterEdit; override;
450		procedure DoBeforeInsert; override;
451		procedure DoAfterInsert; override;
452	+	procedure DoBeforeClose; override;
453	+	procedure DoBeforeOpen; override;
454		procedure DoBeforePost; override;
455	+	procedure DoAfterPost; override;
456		procedure FreeRecordBuffer(var Buffer: PChar); override;
457		procedure GetBookmarkData(Buffer: PChar; Data: Pointer); override;
458		function GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; override;
459		function GetCanModify: Boolean; override;
460		function GetDataSource: TDataSource; override;
461	+	function GetDBAliasName(FieldNo: integer): string;
462	+	function GetFieldDefFromAlias(aliasName: string): TFieldDef;
463		function GetFieldClass(FieldType: TFieldType): TFieldClass; override;
464		function GetRecNo: Integer; override;
465		function GetRecord(Buffer: PChar; GetMode: TGetMode;
466		DoCheck: Boolean): TGetResult; override;
467		function GetRecordCount: Integer; override;
468		function GetRecordSize: Word; override;
469	+	procedure InternalAutoCommit;
470		procedure InternalAddRecord(Buffer: Pointer; Append: Boolean); override;
471		procedure InternalCancel; override;
472		procedure InternalClose; override;
#	Line 385 | Line 484 | type
484		procedure InternalSetFieldData(Field: TField; Buffer: Pointer); virtual;
485		procedure InternalSetToRecord(Buffer: PChar); override;
486		function IsCursorOpen: Boolean; override;
487	+	procedure Loaded; override;
488		procedure ReQuery;
489		procedure SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); override;
490		procedure SetBookmarkData(Buffer: PChar; Data: Pointer); override;
491		procedure SetCachedUpdates(Value: Boolean);
492		procedure SetDataSource(Value: TDataSource);
493	+	procedure SetGenerateParamNames(AValue: Boolean); virtual;
494		procedure SetFieldData(Field : TField; Buffer : Pointer); override;
495		procedure SetFieldData(Field : TField; Buffer : Pointer;
496		NativeFormat : Boolean); overload; override;
#	Line 397 | Line 498 | type
498
499		protected
500		{Likely to be made public by descendant classes}
501	+	property AutoCommit: TIBAutoCommit read FAutoCommit write FAutoCommit default acDisabled;
502		property SQLParams: TIBXSQLDA read GetSQLParams;
503		property Params: TIBXSQLDA read GetSQLParams;
504		property InternalPrepared: Boolean read FInternalPrepared;
#	Line 420 | Line 522 | type
522		property ModifySQL: TStrings read GetModifySQL write SetModifySQL;
523		property UpdateMode: TUpdateMode read FUpdateMode write SetUpdateMode default upWhereAll;
524		property ParamCheck: Boolean read FParamCheck write FParamCheck default True;
525	+	property Parser: TSelectSQLParser read GetParser;
526	+	property BaseSQLSelect: TStrings read FBaseSQLSelect;
527
528		property BeforeDatabaseDisconnect: TNotifyEvent read FBeforeDatabaseDisconnect
529		write FBeforeDatabaseDisconnect;
#	Line 433 | Line 537 | type
537		write FAfterTransactionEnd;
538		property TransactionFree: TNotifyEvent read FTransactionFree
539		write FTransactionFree;
540	+	property OnValidatePost: TOnValidatePost read FOnValidatePost write FOnValidatePost;
541
542		public
543		constructor Create(AOwner: TComponent); override;
#	Line 440 | Line 545 | type
545		procedure ApplyUpdates;
546		function CachedUpdateStatus: TCachedUpdateStatus;
547		procedure CancelUpdates;
548	+	function GetFieldPosition(AliasName: string): integer;
549		procedure FetchAll;
550		function LocateNext(const KeyFields: string; const KeyValues: Variant;
551		Options: TLocateOptions): Boolean;
552		procedure RecordModified(Value: Boolean);
553		procedure RevertRecord;
554		procedure Undelete;
555	+	procedure ResetParser; virtual;
556	+	function HasParser: boolean;
557
558		{ TDataSet support methods }
559		function BookmarkValid(Bookmark: TBookmark): Boolean; override;
#	Line 456 | Line 564 | type
564		function GetFieldData(FieldNo: Integer; Buffer: Pointer): Boolean; overload; (*override;*)
565		function GetFieldData(Field : TField; Buffer : Pointer;
566		NativeFormat : Boolean) : Boolean; overload; override;
567	+	property GenerateParamNames: Boolean read FGenerateParamNames write SetGenerateParamNames;
568		function Locate(const KeyFields: string; const KeyValues: Variant;
569		Options: TLocateOptions): Boolean; override;
570		function Lookup(const KeyFields: string; const KeyValues: Variant;
571		const ResultFields: string): Variant; override;
572		function UpdateStatus: TUpdateStatus; override;
573		function IsSequenced: Boolean; override;
574	+	procedure Post; override;
575		function ParamByName(ParamName: String): TIBXSQLVAR;
576		property DBHandle: PISC_DB_HANDLE read GetDBHandle;
577		property TRHandle: PISC_TR_HANDLE read GetTRHandle;
#	Line 469 | Line 579 | type
579		property UpdatesPending: Boolean read FUpdatesPending;
580		property UpdateRecordTypes: TIBUpdateRecordTypes read FUpdateRecordTypes
581		write SetUpdateRecordTypes;
582	+	property DataSetCloseAction: TDataSetCloseAction
583	+	read FDataSetCloseAction write FDataSetCloseAction;
584
585		published
586		property Database: TIBDatabase read GetDatabase write SetDatabase;
#	Line 507 | Line 619 | type
619		write FOnUpdateRecord;
620		end;
621
622	<	TIBDataSet = class(TIBCustomDataSet)
622	>	TIBParserDataSet = class(TIBCustomDataSet)
623	>	public
624	>	property Parser;
625	>	end;
626	>
627	>	TIBDataSet = class(TIBParserDataSet)
628		private
629		function GetPrepared: Boolean;
630
#	Line 532 | Line 649 | type
649		property QModify;
650		property StatementType;
651		property SelectStmtHandle;
652	+	property BaseSQLSelect;
653
654		published
655		{ TIBCustomDataSet }
656	+	property AutoCommit;
657		property BufferChunks;
658		property CachedUpdates;
659		property DeleteSQL;
#	Line 543 | Line 662 | type
662		property SelectSQL;
663		property ModifySQL;
664		property GeneratorField;
665	+	property GenerateParamNames;
666		property ParamCheck;
667		property UniDirectional;
668		property Filtered;
669	+	property DataSetCloseAction;
670
671		property BeforeDatabaseDisconnect;
672		property AfterDatabaseDisconnect;
#	Line 581 | Line 702 | type
702		property OnFilterRecord;
703		property OnNewRecord;
704		property OnPostError;
705	+	property OnValidatePost;
706		end;
707
708		{ TIBDSBlobStream }
709		TIBDSBlobStream = class(TStream)
710	+	private
711	+	FHasWritten: boolean;
712		protected
713		FField: TField;
714		FBlobStream: TIBBlobStream;
715	+	function  GetSize: Int64; override;
716		public
717		constructor Create(AField: TField; ABlobStream: TIBBlobStream;
718		Mode: TBlobStreamMode);
719	+	destructor Destroy; override;
720		function Read(var Buffer; Count: Longint): Longint; override;
721		function Seek(Offset: Longint; Origin: Word): Longint; override;
722		procedure SetSize(NewSize: Longint); override;
#	Line 615 | Line 741 | DefaultFieldClasses: array[TFieldType] o
741		TVarBytesField,     { ftVarBytes }
742		TAutoIncField,      { ftAutoInc }
743		TBlobField,         { ftBlob }
744	<	TMemoField,         { ftMemo }
744	>	TIBMemoField,       { ftMemo }
745		TGraphicField,      { ftGraphic }
746		TBlobField,         { ftFmtMemo }
747		TBlobField,         { ftParadoxOle }
#	Line 623 | Line 749 | DefaultFieldClasses: array[TFieldType] o
749		TBlobField,         { ftTypedBinary }
750		nil,                { ftCursor }
751		TStringField,       { ftFixedChar }
752	<	TWideStringField,    { ftWideString }
752	>	nil,    { ftWideString }
753		TLargeIntField,     { ftLargeInt }
754		nil,          { ftADT }
755		nil,        { ftArray }
#	Line 638 | Line 764 | DefaultFieldClasses: array[TFieldType] o
764		TDateTimeField,    {ftTimestamp}
765		TIBBCDField,       {ftFMTBcd}
766		nil,  {ftFixedWideChar}
767	<	TWideMemoField);   {ftWideMemo}
767	>	nil);   {ftWideMemo}
768		(*
769		TADTField,          { ftADT }
770		TArrayField,        { ftArray }
#	Line 655 | Line 781 | DefaultFieldClasses: array[TFieldType] o
781
782		implementation
783
784	<	uses IBIntf, Variants, FmtBCD;
784	>	uses IBIntf, Variants, FmtBCD, LazUTF8, IBCodePage;
785
786		const FILE_BEGIN = 0;
787		FILE_CURRENT = 1;
#	Line 678 | Line 804 | type
804		NextRelation : TRelationNode;
805		end;
806
807	+	{Extended Field Def for character set info}
808
809	<	{ TIBStringField}
809	>	{ TIBFieldDef }
810	>
811	>	TIBFieldDef = class(TFieldDef)
812	>	private
813	>	FCharacterSetName: RawByteString;
814	>	FCharacterSetSize: integer;
815	>	{$IFDEF HAS_ANSISTRING_CODEPAGE}
816	>	FCodePage: TSystemCodePage;
817	>	{$ENDIF}
818	>	published
819	>	property CharacterSetName: RawByteString read FCharacterSetName write FCharacterSetName;
820	>	property CharacterSetSize: integer read FCharacterSetSize write FCharacterSetSize;
821	>	{$IFDEF HAS_ANSISTRING_CODEPAGE}
822	>	property CodePage: TSystemCodePage read FCodePage write FCodePage;
823	>	{$ENDIF}
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	>	{ TIBMemoField }
869	>
870	>	function TIBMemoField.GetTruncatedText: string;
871	>	begin
872	>	Result := GetAsString;
873	>
874	>	if Result <> '' then
875	>	begin
876	>	case CharacterSetSize of
877	>	1:
878	>	if DisplayWidth = 0 then
879	>	Result := TextToSingleLine(Result)
880	>	else
881	>	if Length(Result) > DisplayWidth then {Show truncation with elipses}
882	>	Result := TextToSingleLine(system.copy(Result,1,DisplayWidth-3)) + '...';
883	>
884	>	{2: case 2 ignored. This should be handled by TIBWideMemo}
885	>
886	>	3, {Assume UNICODE_FSS is really UTF8}
887	>	4: {Include GB18030 - assuming UTF8 routine work for this codeset}
888	>	if DisplayWidth = 0 then
889	>	Result := ValidUTF8String(TextToSingleLine(Result))
890	>	else
891	>	if UTF8Length(Result) > DisplayWidth then {Show truncation with elipses}
892	>	Result := ValidUTF8String(TextToSingleLine(UTF8Copy(Result,1,DisplayWidth-3))) + '...';
893	>	end;
894	>	end
895	>	end;
896	>
897	>	function TIBMemoField.GetAsString: string;
898	>	var s: RawByteString;
899	>	begin
900	>	s := inherited GetAsString;
901	>	{$IFDEF HAS_ANSISTRING_CODEPAGE}
902	>	SetCodePage(s,CodePage,false);
903	>	if (CodePage <> CP_NONE) and (CodePage <> CP_UTF8) then
904	>	SetCodePage(s,CP_UTF8,true);  {LCL only accepts UTF8}
905	>	{$ENDIF}
906	>	Result := s;
907	>	end;
908	>
909	>	function TIBMemoField.GetDefaultWidth: Longint;
910	>	begin
911	>	if DisplayTextAsClassName then
912	>	Result := inherited
913	>	else
914	>	Result := 128;
915	>	end;
916	>
917	>	procedure TIBMemoField.GetText(var AText: string; ADisplayText: Boolean);
918	>	begin
919	>	if ADisplayText then
920	>	begin
921	>	if not DisplayTextAsClassName and (CharacterSetName <> '') then
922	>	AText := GetTruncatedText
923	>	else
924	>	inherited GetText(AText, ADisplayText);
925	>	end
926	>	else
927	>	AText := GetAsString;
928	>	end;
929	>
930	>	procedure TIBMemoField.SetAsString(const AValue: string);
931	>	var s: RawByteString;
932	>	begin
933	>	s := AValue;
934	>	{$IFDEF HAS_ANSISTRING_CODEPAGE}
935	>	if StringCodePage(Value) <> CodePage then
936	>	SetCodePage(s,CodePage,CodePage<>CP_NONE);
937	>	{$ENDIF}
938	>	inherited SetAsString(s);
939	>	end;
940
941	<	constructor TIBStringField.Create(AOwner: TComponent);
941	>	constructor TIBMemoField.Create(AOwner: TComponent);
942		begin
943		inherited Create(AOwner);
944	+	BlobType := ftMemo;
945	+	{$IFDEF HAS_ANSISTRING_CODEPAGE}
946	+	FCodePage := CP_NONE;
947	+	{$ENDIF}
948	+	end;
949	+
950	+	{ TIBControlLink }
951	+
952	+	destructor TIBControlLink.Destroy;
953	+	begin
954	+	IBDataSet := nil;
955	+	inherited Destroy;
956	+	end;
957	+
958	+	procedure TIBControlLink.UpdateParams(Sender: TObject);
959	+	begin
960	+
961	+	end;
962	+
963	+	procedure TIBControlLink.UpdateSQL(Sender: TObject);
964	+	begin
965	+
966	+	end;
967	+
968	+	procedure TIBControlLink.SetIBDataSet(AValue: TIBCustomDataSet);
969	+	begin
970	+	if FTIBDataSet = AValue then Exit;
971	+	if IBDataSet <> nil then
972	+	IBDataSet.UnRegisterIBLink(self);
973	+	FTIBDataSet := AValue;
974	+	if IBDataSet <> nil then
975	+	IBDataSet.RegisterIBLink(self);
976	+	end;
977	+
978	+
979	+	{ TIBStringField}
980	+
981	+	function TIBStringField.GetDefaultWidth: Longint;
982	+	begin
983	+	Result := Size div CharacterSetSize;
984	+	end;
985	+
986	+	constructor TIBStringField.Create(aOwner: TComponent);
987	+	begin
988	+	inherited Create(aOwner);
989	+	FCharacterSetSize := 1;
990	+	{$IFDEF HAS_ANSISTRING_CODEPAGE}
991	+	FCodePage := CP_NONE;
992	+	{$ENDIF}
993		end;
994
995		class procedure TIBStringField.CheckTypeSize(Value: Integer);
#	Line 706 | Line 1012 | end;
1012		function TIBStringField.GetValue(var Value: string): Boolean;
1013		var
1014		Buffer: PChar;
1015	+	s: RawByteString;
1016	+	//  i: integer;
1017		begin
1018		Buffer := nil;
1019		IBAlloc(Buffer, 0, Size + 1);
#	Line 713 | Line 1021 | begin
1021		Result := GetData(Buffer);
1022		if Result then
1023		begin
1024	+	{$IFDEF HAS_ANSISTRING_CODEPAGE}
1025	+	s := string(Buffer);
1026	+	SetCodePage(s,CodePage,false);
1027	+	if (CodePage <> CP_NONE) and (CodePage <> CP_UTF8) then
1028	+	SetCodePage(s,CP_UTF8,true);  {LCL only accepts UTF8}
1029	+	Value := s;
1030	+	(*      write(FieldName,': ', StringCodePage(Value),', ',Value,' ');
1031	+	for i := 1 to Length(Value) do
1032	+	write(Format('%x ',[byte(Value[i])]));
1033	+	writeln;*)
1034	+	{$ELSE}
1035		Value := string(Buffer);
1036	+	{$ENDIF}
1037		if Transliterate and (Value <> '') then
1038		DataSet.Translate(PChar(Value), PChar(Value), False);
1039		end
#	Line 725 | Line 1045 | end;
1045		procedure TIBStringField.SetAsString(const Value: string);
1046		var
1047		Buffer: PChar;
1048	+	s: RawByteString;
1049		begin
1050		Buffer := nil;
1051		IBAlloc(Buffer, 0, Size + 1);
1052		try
1053	<	StrLCopy(Buffer, PChar(Value), Size);
1053	>	s := Value;
1054	>	{$IFDEF HAS_ANSISTRING_CODEPAGE}
1055	>	if StringCodePage(s) <> CodePage then
1056	>	SetCodePage(s,CodePage,CodePage<>CP_NONE);
1057	>	{$ENDIF}
1058	>	StrLCopy(Buffer, PChar(s), Size);
1059		if Transliterate then
1060		DataSet.Translate(Buffer, Buffer, True);
1061		SetData(Buffer);
#	Line 738 | Line 1064 | begin
1064		end;
1065		end;
1066
1067	+
1068		{ TIBBCDField }
1069
1070		constructor TIBBCDField.Create(AOwner: TComponent);
#	Line 835 | Line 1162 | begin
1162		CheckIBLoaded;
1163		FIBLoaded := True;
1164		FBase := TIBBase.Create(Self);
1165	+	FIBLinks := TList.Create;
1166		FCurrentRecord := -1;
1167		FDeletedRecords := 0;
1168		FUniDirectional := False;
#	Line 853 | Line 1181 | begin
1181		FQRefresh.GoToFirstRecordOnExecute := False;
1182		FQSelect := TIBSQL.Create(Self);
1183		FQSelect.OnSQLChanging := SQLChanging;
1184	+	FQSelect.OnSQLChanged := SQLChanged;
1185		FQSelect.GoToFirstRecordOnExecute := False;
1186		FQModify := TIBSQL.Create(Self);
1187		FQModify.OnSQLChanging := SQLChanging;
1188		FQModify.GoToFirstRecordOnExecute := False;
1189		FUpdateRecordTypes := [cusUnmodified, cusModified, cusInserted];
1190		FParamCheck := True;
1191	+	FGenerateParamNames := False;
1192		FForcedRefresh := False;
1193	+	FAutoCommit:= acDisabled;
1194	+	FDataSetCloseAction := dcDiscardChanges;
1195		{Bookmark Size is Integer for IBX}
1196		BookmarkSize := SizeOf(Integer);
1197		FBase.BeforeDatabaseDisconnect := DoBeforeDatabaseDisconnect;
#	Line 873 | Line 1205 | begin
1205		else
1206		if AOwner is TIBTransaction then
1207		Transaction := TIBTransaction(AOwner);
1208	+	FBaseSQLSelect := TStringList.Create;
1209		end;
1210
1211		destructor TIBCustomDataSet.Destroy;
#	Line 884 | Line 1217 | begin
1217		FDataLink.Free;
1218		FBase.Free;
1219		ClearBlobCache;
1220	+	ClearIBLinks;
1221	+	FIBLinks.Free;
1222		FBlobStreamList.Free;
1223		FreeMem(FBufferCache);
1224		FBufferCache := nil;
#	Line 893 | Line 1228 | begin
1228		FOldCacheSize := 0;
1229		FMappedFieldPosition := nil;
1230		end;
1231	+	if assigned(FBaseSQLSelect) then FBaseSQLSelect.Free;
1232	+	if assigned(FParser) then FParser.Free;
1233		inherited Destroy;
1234		end;
1235
#	Line 934 | Line 1271 | end;
1271
1272		procedure TIBCustomDataSet.ApplyUpdates;
1273		var
1274	<	{$IF FPC_FULLVERSION > 20602 }
1274	>	{$IFDEF NEW_TBOOKMARK }
1275		CurBookmark: TBookmark;
1276		{$ELSE}
1277		CurBookmark: string;
#	Line 1136 | Line 1473 | begin
1473		end;
1474		end;
1475
1476	+	function TIBCustomDataSet.GetFieldPosition(AliasName: string): integer;
1477	+	var i: integer;
1478	+	Prepared: boolean;
1479	+	begin
1480	+	Result := 0;
1481	+	Prepared := FInternalPrepared;
1482	+	if not Prepared then
1483	+	InternalPrepare;
1484	+	try
1485	+	for i := 0 to Length(FAliasNameList) - 1 do
1486	+	if FAliasNameList[i] = AliasName then
1487	+	begin
1488	+	Result := i + 1;
1489	+	Exit
1490	+	end;
1491	+	finally
1492	+	if not Prepared then
1493	+	InternalUnPrepare;
1494	+	end;
1495	+	end;
1496	+
1497		procedure TIBCustomDataSet.ActivateConnection;
1498		begin
1499		if not Assigned(Database) then
#	Line 1196 | Line 1554 | begin
1554		IBError(ibxeDatasetClosed, [nil]);
1555		end;
1556
1557	+	function TIBCustomDataSet.CreateParser: TSelectSQLParser;
1558	+	begin
1559	+	Result := TSelectSQLParser.Create(self,FBaseSQLSelect);
1560	+	Result.OnSQLChanging := SQLChanging
1561	+	end;
1562	+
1563		procedure TIBCustomDataSet.CheckNotUniDirectional;
1564		begin
1565		if UniDirectional then
#	Line 1299 | Line 1663 | begin
1663		FDatabaseFree(Sender);
1664		end;
1665
1666	<	procedure TIBCustomDataSet.DoBeforeTransactionEnd(Sender: TObject);
1666	>	procedure TIBCustomDataSet.DoBeforeTransactionEnd(Sender: TObject;
1667	>	Action: TTransactionAction);
1668		begin
1669	<	if Active then
1670	<	Active := False;
1669	>	FCloseAction := Action;
1670	>	FInTransactionEnd := true;
1671	>	try
1672	>	if Active then
1673	>	Active := False;
1674	>	finally
1675	>	FInTransactionEnd := false;
1676	>	end;
1677		if FQSelect <> nil then
1678		FQSelect.FreeHandle;
1679		if FQDelete <> nil then
#	Line 1340 | Line 1711 | var
1711		LocalData: Pointer;
1712		LocalDate, LocalDouble: Double;
1713		LocalInt: Integer;
1714	+	LocalBool: wordBool;
1715		LocalInt64: Int64;
1716		LocalCurrency: Currency;
1717		FieldsLoaded: Integer;
1346	–	temp: TIBXSQLVAR;
1718		begin
1719		p := PRecordData(Buffer);
1720		{ Make sure blob cache is empty }
#	Line 1392 | Line 1763 | begin
1763		(Qry.Current[i].Data^.sqltype and 1 = 1);
1764		rdFields[j].fdIsNull :=
1765		(rdFields[j].fdNullable and (Qry.Current[i].Data^.sqlind^ = -1));
1766	+	{$IFDEF HAS_ANSISTRING_CODEPAGE}
1767	+	rdFields[j].fdCodePage := 0;
1768	+	{$ENDIF}
1769		LocalData := Qry.Current[i].Data^.sqldata;
1770		case rdFields[j].fdDataType of
1771		SQL_TIMESTAMP:
#	Line 1472 | Line 1846 | begin
1846		begin
1847		rdFields[j].fdDataSize := Qry.Current[i].Data^.sqllen;
1848		rdFields[j].fdDataLength := isc_vax_integer(Qry.Current[i].Data^.sqldata, 2);
1849	+	{$IFDEF HAS_ANSISTRING_CODEPAGE}
1850	+	TFirebirdCharacterSets.CharSetID2CodePage(Qry.Current[i].Data^.sqlsubtype and $FF,
1851	+	rdFields[j].fdCodePage);
1852	+	{$ENDIF}
1853		if RecordNumber >= 0 then
1854		begin
1855		if (rdFields[j].fdDataLength = 0) then
1856		LocalData := nil
1857		else
1858	<	begin
1481	<	temp :=  Qry.Current[i];
1482	<	LocalData := @temp.Data^.sqldata[2];
1483	<	(*              LocalData := @Qry.Current[i].Data^.sqldata[2];*)
1484	<	end;
1858	>	Inc(LocalData,2);
1859		end;
1860		end;
1861	<	else { SQL_TEXT, SQL_BLOB, SQL_ARRAY, SQL_QUAD }
1861	>	SQL_BOOLEAN:
1862	>	begin
1863	>	LocalBool:= false;
1864	>	rdFields[j].fdDataSize := SizeOf(wordBool);
1865	>	if RecordNumber >= 0 then
1866	>	LocalBool := Qry.Current[i].AsBoolean;
1867	>	LocalData := PChar(@LocalBool);
1868	>	end;
1869	>	SQL_TEXT:
1870	>	begin
1871	>	rdFields[j].fdDataSize := Qry.Current[i].Data^.sqllen;
1872	>	rdFields[j].fdDataLength := rdFields[j].fdDataSize;
1873	>	{$IFDEF HAS_ANSISTRING_CODEPAGE}
1874	>	TFirebirdCharacterSets.CharSetID2CodePage(Qry.Current[i].Data^.sqlsubtype and $FF,
1875	>	rdFields[j].fdCodePage);
1876	>	{$ENDIF}
1877	>	end;
1878	>	else {  SQL_BLOB, SQL_ARRAY, SQL_QUAD }
1879		begin
1880		rdFields[j].fdDataSize := Qry.Current[i].Data^.sqllen;
1490	–	if (rdFields[j].fdDataType = SQL_TEXT) then
1491	–	rdFields[j].fdDataLength := rdFields[j].fdDataSize;
1881		end;
1882		end;
1883		if RecordNumber < 0 then
#	Line 1626 | Line 2015 | function TIBCustomDataSet.InternalLocate
2015		const KeyValues: Variant; Options: TLocateOptions): Boolean;
2016		var
2017		keyFieldList: TList;
2018	<	{$IF FPC_FULLVERSION >  20602 }
2018	>	{$IFDEF NEW_TBOOKMARK }
2019		CurBookmark: TBookmark;
2020		{$ELSE}
2021		CurBookmark: string;
#	Line 1755 | Line 2144 | end;
2144		procedure TIBCustomDataSet.InternalRefreshRow;
2145		var
2146		Buff: PChar;
1758	–	SetCursor: Boolean;
2147		ofs: DWORD;
2148		Qry: TIBSQL;
2149		begin
2150	<	SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault);
1763	<	if SetCursor then
1764	<	Screen.Cursor := crHourGlass;
2150	>	FBase.SetCursor;
2151		try
2152		Buff := GetActiveBuf;
2153		if CanRefresh then
#	Line 1805 | Line 2191 | begin
2191		else
2192		IBError(ibxeCannotRefresh, [nil]);
2193		finally
2194	<	if SetCursor and (Screen.Cursor = crHourGlass) then
1809	<	Screen.Cursor := crDefault;
2194	>	FBase.RestoreCursor;
2195		end;
2196		end;
2197
#	Line 1877 | Line 2262 | end;
2262
2263		procedure TIBCustomDataSet.InternalPrepare;
2264		var
1880	–	SetCursor: Boolean;
2265		DidActivate: Boolean;
2266		begin
2267		if FInternalPrepared then
2268		Exit;
2269		DidActivate := False;
2270	<	SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault);
1887	<	if SetCursor then
1888	<	Screen.Cursor := crHourGlass;
2270	>	FBase.SetCursor;
2271		try
2272		ActivateConnection;
2273		DidActivate := ActivateTransaction;
2274		FBase.CheckDatabase;
2275		FBase.CheckTransaction;
2276	+	if HasParser and (FParser.SQLText <> FQSelect.SQL.Text) then
2277	+	begin
2278	+	FQSelect.OnSQLChanged := nil; {Do not react to change}
2279	+	try
2280	+	FQSelect.SQL.Text := FParser.SQLText;
2281	+	finally
2282	+	FQSelect.OnSQLChanged := SQLChanged;
2283	+	end;
2284	+	end;
2285	+	//   writeln( FQSelect.SQL.Text);
2286		if FQSelect.SQL.Text <> '' then
2287		begin
2288		if not FQSelect.Prepared then
2289		begin
2290	+	FQSelect.GenerateParamNames := FGenerateParamNames;
2291		FQSelect.ParamCheck := ParamCheck;
2292		FQSelect.Prepare;
2293		end;
2294	+	FQDelete.GenerateParamNames := FGenerateParamNames;
2295		if (Trim(FQDelete.SQL.Text) <> '') and (not FQDelete.Prepared) then
2296		FQDelete.Prepare;
2297	+	FQInsert.GenerateParamNames := FGenerateParamNames;
2298		if (Trim(FQInsert.SQL.Text) <> '') and (not FQInsert.Prepared) then
2299		FQInsert.Prepare;
2300	+	FQRefresh.GenerateParamNames := FGenerateParamNames;
2301		if (Trim(FQRefresh.SQL.Text) <> '') and (not FQRefresh.Prepared) then
2302		FQRefresh.Prepare;
2303	+	FQModify.GenerateParamNames := FGenerateParamNames;
2304		if (Trim(FQModify.SQL.Text) <> '') and (not FQModify.Prepared) then
2305		FQModify.Prepare;
2306		FInternalPrepared := True;
#	Line 1913 | Line 2310 | begin
2310		finally
2311		if DidActivate then
2312		DeactivateTransaction;
2313	<	if SetCursor and (Screen.Cursor = crHourGlass) then
1917	<	Screen.Cursor := crDefault;
2313	>	FBase.RestoreCursor;
2314		end;
2315		end;
2316
#	Line 2016 | Line 2412 | procedure TIBCustomDataSet.SetInternalSQ
2412		var
2413		i, j: Integer;
2414		cr, data: PChar;
2415	<	fn, st: string;
2415	>	fn: string;
2416	>	st: RawByteString;
2417		OldBuffer: Pointer;
2418		ts: TTimeStamp;
2419		begin
#	Line 2064 | Line 2461 | begin
2461		SQL_TEXT, SQL_VARYING:
2462		begin
2463		SetString(st, data, rdFields[j].fdDataLength);
2464	+	{$IFDEF HAS_ANSISTRING_CODEPAGE}
2465	+	SetCodePage(st,rdFields[j].fdCodePage,false);
2466	+	{$ENDIF}
2467		Qry.Params[i].AsString := st;
2468		end;
2469		SQL_FLOAT, SQL_DOUBLE, SQL_D_FLOAT:
#	Line 2105 | Line 2505 | begin
2505		SQL_TIMESTAMP:
2506		Qry.Params[i].AsDateTime :=
2507		TimeStampToDateTime(MSecsToTimeStamp(trunc(PDouble(data)^)));
2508	+	SQL_BOOLEAN:
2509	+	Qry.Params[i].AsBoolean := PWordBool(data)^;
2510		end;
2511		end;
2512		end;
#	Line 2190 | Line 2592 | begin
2592		end;
2593		end;
2594
2595	+	procedure TIBCustomDataSet.RegisterIBLink(Sender: TIBControlLink);
2596	+	begin
2597	+	if FIBLinks.IndexOf(Sender) = -1 then
2598	+	FIBLinks.Add(Sender);
2599	+	end;
2600	+
2601
2602		procedure TIBCustomDataSet.SQLChanging(Sender: TObject);
2603		begin
2604	<	if FOpen then
2605	<	InternalClose;
2604	>	Active := false;
2605	>	{  if FOpen then
2606	>	InternalClose;}
2607		if FInternalPrepared then
2608		InternalUnPrepare;
2609	+	FieldDefs.Clear;
2610	+	FieldDefs.Updated := false;
2611	+	end;
2612	+
2613	+	procedure TIBCustomDataSet.SQLChanged(Sender: TObject);
2614	+	begin
2615	+	FBaseSQLSelect.assign(FQSelect.SQL);
2616		end;
2617
2618		{ I can "undelete" uninserted records (make them "inserted" again).
#	Line 2225 | Line 2641 | begin
2641		end;
2642		end;
2643
2644	+	procedure TIBCustomDataSet.UnRegisterIBLink(Sender: TIBControlLink);
2645	+	begin
2646	+	FIBLinks.Remove(Sender);
2647	+	end;
2648	+
2649		function TIBCustomDataSet.UpdateStatus: TUpdateStatus;
2650		begin
2651		if Active then
#	Line 2454 | Line 2875 | begin
2875		inherited DoBeforeDelete;
2876		end;
2877
2878	+	procedure TIBCustomDataSet.DoAfterDelete;
2879	+	begin
2880	+	inherited DoAfterDelete;
2881	+	FBase.DoAfterDelete(self);
2882	+	InternalAutoCommit;
2883	+	end;
2884	+
2885		procedure TIBCustomDataSet.DoBeforeEdit;
2886		var
2887		Buff: PRecordData;
#	Line 2468 | Line 2896 | begin
2896		inherited DoBeforeEdit;
2897		end;
2898
2899	+	procedure TIBCustomDataSet.DoAfterEdit;
2900	+	begin
2901	+	inherited DoAfterEdit;
2902	+	FBase.DoAfterEdit(self);
2903	+	end;
2904	+
2905		procedure TIBCustomDataSet.DoBeforeInsert;
2906		begin
2907		if not CanInsert then
#	Line 2480 | Line 2914 | begin
2914		if GeneratorField.ApplyOnEvent = gaeOnNewRecord then
2915		GeneratorField.Apply;
2916		inherited DoAfterInsert;
2917	+	FBase.DoAfterInsert(self);
2918	+	end;
2919	+
2920	+	procedure TIBCustomDataSet.DoBeforeClose;
2921	+	begin
2922	+	inherited DoBeforeClose;
2923	+	if State in [dsInsert,dsEdit] then
2924	+	begin
2925	+	if FInTransactionEnd and (FCloseAction = TARollback) then
2926	+	Exit;
2927	+
2928	+	if DataSetCloseAction = dcSaveChanges then
2929	+	Post;
2930	+	{Note this can fail with an exception e.g. due to
2931	+	database validation error. In which case the dataset remains open }
2932	+	end;
2933	+	end;
2934	+
2935	+	procedure TIBCustomDataSet.DoBeforeOpen;
2936	+	var i: integer;
2937	+	begin
2938	+	if assigned(FParser) then
2939	+	FParser.Reset;
2940	+	for i := 0 to FIBLinks.Count - 1 do
2941	+	TIBControlLink(FIBLinks[i]).UpdateSQL(self);
2942	+	inherited DoBeforeOpen;
2943	+	for i := 0 to FIBLinks.Count - 1 do
2944	+	TIBControlLink(FIBLinks[i]).UpdateParams(self);
2945		end;
2946
2947		procedure TIBCustomDataSet.DoBeforePost;
#	Line 2490 | Line 2952 | begin
2952		GeneratorField.Apply
2953		end;
2954
2955	+	procedure TIBCustomDataSet.DoAfterPost;
2956	+	begin
2957	+	inherited DoAfterPost;
2958	+	FBase.DoAfterPost(self);
2959	+	InternalAutoCommit;
2960	+	end;
2961	+
2962		procedure TIBCustomDataSet.FetchAll;
2963		var
2964	<	SetCursor: Boolean;
2496	<	{$IF FPC_FULLVERSION >  20602 }
2964	>	{$IFDEF NEW_TBOOKMARK }
2965		CurBookmark: TBookmark;
2966		{$ELSE}
2967		CurBookmark: string;
2968		{$ENDIF}
2969		begin
2970	<	SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault);
2971	<	if SetCursor then
2504	<	Screen.Cursor := crHourGlass;
2505	<	try
2970	>	FBase.SetCursor;
2971	>	try
2972		if FQSelect.EOF or not FQSelect.Open then
2973		exit;
2974		DisableControls;
#	Line 2514 | Line 2980 | begin
2980		EnableControls;
2981		end;
2982		finally
2983	<	if SetCursor and (Screen.Cursor = crHourGlass) then
2518	<	Screen.Cursor := crDefault;
2983	>	FBase.RestoreCursor;
2984		end;
2985		end;
2986
#	Line 2563 | Line 3028 | begin
3028		result := FDataLink.DataSource;
3029		end;
3030
3031	+	function TIBCustomDataSet.GetDBAliasName(FieldNo: integer): string;
3032	+	begin
3033	+	Result := FAliasNameMap[FieldNo-1]
3034	+	end;
3035	+
3036	+	function TIBCustomDataSet.GetFieldDefFromAlias(aliasName: string): TFieldDef;
3037	+	var
3038	+	i: integer;
3039	+	begin
3040	+	Result := nil;
3041	+	for i := 0 to Length(FAliasNameMap) - 1 do
3042	+	if FAliasNameMap[i] = aliasName then
3043	+	begin
3044	+	Result := FieldDefs[i];
3045	+	Exit
3046	+	end;
3047	+	end;
3048	+
3049		function TIBCustomDataSet.GetFieldClass(FieldType: TFieldType): TFieldClass;
3050		begin
3051		Result := DefaultFieldClasses[FieldType];
#	Line 2603 | Line 3086 | begin
3086		Data := Buff + CurrentRecord^.rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataOfs;
3087		if (fdDataType = SQL_VARYING) or (fdDataType = SQL_TEXT) then
3088		begin
3089	<	if fdDataLength <= Field.Size then
3089	>	if fdDataLength < Field.DataSize then
3090		begin
3091		Move(Data^, Buffer^, fdDataLength);
3092		PChar(Buffer)[fdDataLength] := #0;
#	Line 2652 | Line 3135 | begin
3135		if not Accept and (GetMode = gmCurrent) then
3136		GetMode := gmPrior;
3137		except
3138	<	//        Application.HandleException(Self);
3138	>	//        FBase.HandleException(Self);
3139		end;
3140		end;
3141		RestoreState(SaveState);
#	Line 2746 | Line 3229 | begin
3229		result := FRecordBufferSize;
3230		end;
3231
3232	+	procedure TIBCustomDataSet.InternalAutoCommit;
3233	+	begin
3234	+	with Transaction do
3235	+	if InTransaction and (FAutoCommit = acCommitRetaining) then
3236	+	begin
3237	+	if CachedUpdates then ApplyUpdates;
3238	+	CommitRetaining;
3239	+	end;
3240	+	end;
3241	+
3242		procedure TIBCustomDataSet.InternalAddRecord(Buffer: Pointer; Append: Boolean);
3243		begin
3244		CheckEditState;
#	Line 2817 | Line 3310 | begin
3310		FreeMem(FOldBufferCache);
3311		FOldBufferCache := nil;
3312		BindFields(False);
3313	+	ResetParser;
3314		if DefaultFields then DestroyFields;
3315		end;
3316
3317		procedure TIBCustomDataSet.InternalDelete;
3318		var
3319		Buff: PChar;
2826	–	SetCursor: Boolean;
3320		begin
3321	<	SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault);
2829	<	if SetCursor then
2830	<	Screen.Cursor := crHourGlass;
3321	>	FBase.SetCursor;
3322		try
3323		Buff := GetActiveBuf;
3324		if CanDelete then
#	Line 2852 | Line 3343 | begin
3343		end else
3344		IBError(ibxeCannotDelete, [nil]);
3345		finally
3346	<	if SetCursor and (Screen.Cursor = crHourGlass) then
2856	<	Screen.Cursor := crDefault;
3346	>	FBase.RestoreCursor;
3347		end;
3348		end;
3349
#	Line 2869 | Line 3359 | end;
3359
3360		procedure TIBCustomDataSet.InternalHandleException;
3361		begin
3362	<	Application.HandleException(Self)
3362	>	FBase.HandleException(Self)
3363		end;
3364
3365		procedure TIBCustomDataSet.InternalInitFieldDefs;
3366	+	begin
3367	+	if not InternalPrepared then
3368	+	begin
3369	+	InternalPrepare;
3370	+	exit;
3371	+	end;
3372	+	FieldDefsFromQuery(FQSelect);
3373	+	end;
3374	+
3375	+	procedure TIBCustomDataSet.FieldDefsFromQuery(SourceQuery: TIBSQL);
3376		const
3377		DefaultSQL = 'Select F.RDB$COMPUTED_BLR, ' + {do not localize}
3378		'F.RDB$DEFAULT_VALUE, R.RDB$FIELD_NAME ' + {do not localize}
#	Line 2884 | Line 3384 | const
3384		var
3385		FieldType: TFieldType;
3386		FieldSize: Word;
3387	+	charSetID: integer;
3388	+	CharSetSize: integer;
3389	+	CharSetName: RawByteString;
3390	+	{$IFDEF HAS_ANSISTRING_CODEPAGE}
3391	+	FieldCodePage: TSystemCodePage;
3392	+	{$ENDIF}
3393		FieldNullable : Boolean;
3394		i, FieldPosition, FieldPrecision: Integer;
3395	<	FieldAliasName: string;
3395	>	FieldAliasName, DBAliasName: string;
3396		RelationName, FieldName: string;
3397		Query : TIBSQL;
3398		FieldIndex: Integer;
#	Line 2986 | Line 3492 | var
3492		end;
3493
3494		begin
2989	–	if not InternalPrepared then
2990	–	begin
2991	–	InternalPrepare;
2992	–	exit;
2993	–	end;
3495		FRelationNodes := TRelationNode.Create;
3496		FNeedsRefresh := False;
3497		Database.InternalTransaction.StartTransaction;
#	Line 3001 | Line 3502 | begin
3502		FieldDefs.BeginUpdate;
3503		FieldDefs.Clear;
3504		FieldIndex := 0;
3505	<	if (Length(FMappedFieldPosition) < FQSelect.Current.Count) then
3506	<	SetLength(FMappedFieldPosition, FQSelect.Current.Count);
3505	>	if (Length(FMappedFieldPosition) < SourceQuery.Current.Count) then
3506	>	SetLength(FMappedFieldPosition, SourceQuery.Current.Count);
3507		Query.SQL.Text := DefaultSQL;
3508		Query.Prepare;
3509	<	for i := 0 to FQSelect.Current.Count - 1 do
3510	<	with FQSelect.Current[i].Data^ do
3509	>	SetLength(FAliasNameMap, SourceQuery.Current.Count);
3510	>	SetLength(FAliasNameList, SourceQuery.Current.Count);
3511	>	for i := 0 to SourceQuery.Current.Count - 1 do
3512	>	with SourceQuery.Current[i].Data^ do
3513		begin
3514		{ Get the field name }
3515	<	SetString(FieldAliasName, aliasname, aliasname_length);
3515	>	FieldAliasName := SourceQuery.Current[i].Name;
3516	>	SetString(DBAliasName, aliasname, aliasname_length);
3517		SetString(RelationName, relname, relname_length);
3518		SetString(FieldName, sqlname, sqlname_length);
3519	+	FAliasNameList[i] := DBAliasName;
3520		FieldSize := 0;
3521		FieldPrecision := 0;
3522	<	FieldNullable := FQSelect.Current[i].IsNullable;
3522	>	FieldNullable := SourceQuery.Current[i].IsNullable;
3523	>	CharSetSize := 0;
3524	>	CharSetName := '';
3525	>	{$IFDEF HAS_ANSISTRING_CODEPAGE}
3526	>	FieldCodePage := CP_NONE;
3527	>	{$ENDIF}
3528		case sqltype and not 1 of
3529		{ All VARCHAR's must be converted to strings before recording
3530		their values }
3531		SQL_VARYING, SQL_TEXT:
3532		begin
3533	+	CharSetID := SourceQuery.Current[i].GetCharSetID;
3534	+	TFirebirdCharacterSets.CharSetWidth(CharSetID,CharSetSize);
3535	+	CharSetName := TFirebirdCharacterSets.GetCharsetName(CharSetID);
3536	+	{$IFDEF HAS_ANSISTRING_CODEPAGE}
3537	+	TFirebirdCharacterSets.CharSetID2CodePage(CharSetID,FieldCodePage);
3538	+	{$ENDIF}
3539		FieldSize := sqllen;
3540		FieldType := ftString;
3541		end;
#	Line 3080 | Line 3596 | begin
3596		begin
3597		FieldSize := sizeof (TISC_QUAD);
3598		if (sqlsubtype = 1) then
3599	<	FieldType := ftmemo
3599	>	begin
3600	>	CharSetID := SourceQuery.Current[i].GetCharSetID;
3601	>	TFirebirdCharacterSets.CharSetWidth(CharSetID,CharSetSize);
3602	>	CharSetName := TFirebirdCharacterSets.GetCharsetName(CharSetID);
3603	>	{$IFDEF HAS_ANSISTRING_CODEPAGE}
3604	>	TFirebirdCharacterSets.CharSetID2CodePage(CharSetID,FieldCodePage);
3605	>	{$ENDIF}
3606	>	FieldType := ftMemo;
3607	>	end
3608		else
3609		FieldType := ftBlob;
3610		end;
#	Line 3089 | Line 3613 | begin
3613		FieldSize := sizeof (TISC_QUAD);
3614		FieldType := ftUnknown;
3615		end;
3616	+	SQL_BOOLEAN:
3617	+	FieldType:= ftBoolean;
3618		else
3619		FieldType := ftUnknown;
3620		end;
#	Line 3097 | Line 3623 | begin
3623		begin
3624		FMappedFieldPosition[FieldIndex] := FieldPosition;
3625		Inc(FieldIndex);
3626	<	with FieldDefs.AddFieldDef do
3626	>	with TIBFieldDef.Create(FieldDefs,'',FieldType,0,False,FieldDefs.Count+1) do
3627		begin
3628		Name := FieldAliasName;
3629	<	(*           FieldNo := FieldPosition;*)
3104	<	DataType := FieldType;
3629	>	FAliasNameMap[FieldNo-1] := DBAliasName;
3630		Size := FieldSize;
3631		Precision := FieldPrecision;
3632		Required := not FieldNullable;
3633		InternalCalcField := False;
3634	+	CharacterSetSize := CharSetSize;
3635	+	CharacterSetName := CharSetName;
3636	+	{$IFDEF HAS_ANSISTRING_CODEPAGE}
3637	+	CodePage := FieldCodePage;
3638	+	{$ENDIF}
3639		if (FieldName <> '') and (RelationName <> '') then
3640		begin
3641		if Has_COMPUTED_BLR(RelationName, FieldName) then
#	Line 3185 | Line 3715 | begin
3715		else case cur_field.DataType of
3716		ftString:
3717		cur_param.AsString := cur_field.AsString;
3718	<	ftBoolean, ftSmallint, ftWord:
3718	>	ftBoolean:
3719	>	cur_param.AsBoolean := cur_field.AsBoolean;
3720	>	ftSmallint, ftWord:
3721		cur_param.AsShort := cur_field.AsInteger;
3722		ftInteger:
3723		cur_param.AsLong := cur_field.AsInteger;
#	Line 3238 | Line 3770 | begin
3770		end;
3771
3772		procedure TIBCustomDataSet.InternalOpen;
3241	–	var
3242	–	SetCursor: Boolean;
3773
3774		function RecordDataLength(n: Integer): Long;
3775		begin
3776		result := SizeOf(TRecordData) + ((n - 1) * SizeOf(TFieldData));
3777		end;
3778
3779	+	function GetFieldDef(aFieldNo: integer): TIBFieldDef;
3780	+	var i: integer;
3781	+	begin
3782	+	Result := nil;
3783	+	for i := 0 to FieldDefs.Count - 1 do
3784	+	if FieldDefs[i].FieldNo = aFieldNo then
3785	+	begin
3786	+	Result := TIBFieldDef(FieldDefs[i]);
3787	+	break;
3788	+	end;
3789	+	end;
3790	+
3791	+	procedure SetExtendedProperties;
3792	+	var i: integer;
3793	+	IBFieldDef: TIBFieldDef;
3794	+	begin
3795	+	for i := 0 to Fields.Count - 1 do
3796	+	if Fields[i].FieldNo > 0 then
3797	+	begin
3798	+	if(Fields[i] is TIBStringField) then
3799	+	with TIBStringField(Fields[i]) do
3800	+	begin
3801	+	IBFieldDef := GetFieldDef(FieldNo);
3802	+	if IBFieldDef <> nil then
3803	+	begin
3804	+	CharacterSetSize := IBFieldDef.CharacterSetSize;
3805	+	CharacterSetName := IBFieldDef.CharacterSetName;
3806	+	{$IFDEF HAS_ANSISTRING_CODEPAGE}
3807	+	CodePage := IBFieldDef.CodePage;
3808	+	{$ENDIF}
3809	+	end;
3810	+	end
3811	+	else
3812	+	if(Fields[i] is TIBMemoField) then
3813	+	with TIBMemoField(Fields[i]) do
3814	+	begin
3815	+	IBFieldDef := GetFieldDef(FieldNo);
3816	+	if IBFieldDef <> nil then
3817	+	begin
3818	+	CharacterSetSize := IBFieldDef.CharacterSetSize;
3819	+	CharacterSetName := IBFieldDef.CharacterSetName;
3820	+	{$IFDEF HAS_ANSISTRING_CODEPAGE}
3821	+	CodePage := IBFieldDef.CodePage;
3822	+	{$ENDIF}
3823	+	end;
3824	+	end
3825	+	end
3826	+	end;
3827	+
3828		begin
3829	<	SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault);
3251	<	if SetCursor then
3252	<	Screen.Cursor := crHourGlass;
3829	>	FBase.SetCursor;
3830		try
3831		ActivateConnection;
3832		ActivateTransaction;
#	Line 3262 | Line 3839 | begin
3839		if DefaultFields then
3840		CreateFields;
3841		BindFields(True);
3842	+	SetExtendedProperties;
3843		FCurrentRecord := -1;
3844		FQSelect.ExecQuery;
3845		FOpen := FQSelect.Open;
#	Line 3310 | Line 3888 | begin
3888		else
3889		FQSelect.ExecQuery;
3890		finally
3891	<	if SetCursor and (Screen.Cursor = crHourGlass) then
3314	<	Screen.Cursor := crDefault;
3891	>	FBase.RestoreCursor;
3892		end;
3893		end;
3894
#	Line 3319 | Line 3896 | procedure TIBCustomDataSet.InternalPost;
3896		var
3897		Qry: TIBSQL;
3898		Buff: PChar;
3322	–	SetCursor: Boolean;
3899		bInserting: Boolean;
3900		begin
3901	<	SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault);
3326	<	if SetCursor then
3327	<	Screen.Cursor := crHourGlass;
3901	>	FBase.SetCursor;
3902		try
3903		Buff := GetActiveBuf;
3904		CheckEditState;
#	Line 3362 | Line 3936 | begin
3936		if bInserting then
3937		Inc(FRecordCount);
3938		finally
3939	<	if SetCursor and (Screen.Cursor = crHourGlass) then
3366	<	Screen.Cursor := crDefault;
3939	>	FBase.RestoreCursor;
3940		end;
3941		end;
3942
#	Line 3383 | Line 3956 | begin
3956		result := FOpen;
3957		end;
3958
3959	+	procedure TIBCustomDataSet.Loaded;
3960	+	begin
3961	+	if assigned(FQSelect) then
3962	+	FBaseSQLSelect.assign(FQSelect.SQL);
3963	+	inherited Loaded;
3964	+	end;
3965	+
3966	+	procedure TIBCustomDataSet.Post;
3967	+	var CancelPost: boolean;
3968	+	begin
3969	+	CancelPost := false;
3970	+	if assigned(FOnValidatePost) then
3971	+	OnValidatePost(self,CancelPost);
3972	+	if CancelPost then
3973	+	Cancel
3974	+	else
3975	+	inherited Post;
3976	+	end;
3977	+
3978		function TIBCustomDataSet.Locate(const KeyFields: string; const KeyValues: Variant;
3979		Options: TLocateOptions): Boolean;
3980		var
3981	<	{$IF FPC_FULLVERSION >  20602 }
3981	>	{$IFDEF NEW_TBOOKMARK }
3982		CurBookmark: TBookmark;
3983		{$ELSE}
3984		CurBookmark: string;
#	Line 3408 | Line 4000 | function TIBCustomDataSet.Lookup(const K
4000		const ResultFields: string): Variant;
4001		var
4002		fl: TList;
4003	<	{$IF FPC_FULLVERSION >  20602 }
4003	>	{$IFDEF NEW_TBOOKMARK }
4004		CurBookmark: TBookmark;
4005		{$ELSE}
4006		CurBookmark: string;
#	Line 3465 | Line 4057 | end;
4057		procedure TIBCustomDataSet.InternalSetFieldData(Field: TField; Buffer: Pointer);
4058		var
4059		Buff, TmpBuff: PChar;
4060	+	MappedFieldPos: integer;
4061		begin
4062		Buff := GetActiveBuf;
4063		if Field.FieldNo < 0 then
#	Line 3481 | Line 4074 | begin
4074		begin
4075		{ If inserting, Adjust record position }
4076		AdjustRecordOnInsert(Buff);
4077	<	if (FMappedFieldPosition[Field.FieldNo - 1] > 0) and
4078	<	(FMappedFieldPosition[Field.FieldNo - 1] <= rdFieldCount) then
4077	>	MappedFieldPos := FMappedFieldPosition[Field.FieldNo - 1];
4078	>	if (MappedFieldPos > 0) and
4079	>	(MappedFieldPos <= rdFieldCount) then
4080		begin
4081		Field.Validate(Buffer);
4082		if (Buffer = nil) or
4083		(Field is TIBStringField) and (PChar(Buffer)[0] = #0) then
4084	<	rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdIsNull := True
4084	>	rdFields[MappedFieldPos].fdIsNull := True
4085		else begin
4086	<	Move(Buffer^, Buff[rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataOfs],
4087	<	rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataSize);
4088	<	if (rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataType = SQL_TEXT) or
4089	<	(rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataType = SQL_VARYING) then
4090	<	rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataLength := StrLen(PChar(Buffer));
4091	<	rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdIsNull := False;
4086	>	Move(Buffer^, Buff[rdFields[MappedFieldPos].fdDataOfs],
4087	>	rdFields[MappedFieldPos].fdDataSize);
4088	>	if (rdFields[MappedFieldPos].fdDataType = SQL_TEXT) or
4089	>	(rdFields[MappedFieldPos].fdDataType = SQL_VARYING) then
4090	>	rdFields[MappedFieldPos].fdDataLength := StrLen(PChar(Buffer));
4091	>	rdFields[MappedFieldPos].fdIsNull := False;
4092		if rdUpdateStatus = usUnmodified then
4093		begin
4094		if CachedUpdates then
#	Line 3582 | Line 4176 | begin
4176		FillChar(Buffer[FRecordSize], CalcFieldsSize, 0);
4177		end;
4178
4179	+	procedure TIBCustomDataSet.ClearIBLinks;
4180	+	var i: integer;
4181	+	begin
4182	+	for i := FIBLinks.Count - 1 downto 0 do
4183	+	TIBControlLink(FIBLinks[i]).IBDataSet := nil;
4184	+	end;
4185	+
4186
4187		procedure TIBCustomDataSet.InternalUnPrepare;
4188		begin
#	Line 3589 | Line 4190 | begin
4190		begin
4191		CheckDatasetClosed;
4192		FieldDefs.Clear;
4193	+	FieldDefs.Updated := false;
4194		FInternalPrepared := False;
4195	+	Setlength(FAliasNameList,0);
4196		end;
4197		end;
4198
4199		procedure TIBCustomDataSet.InternalExecQuery;
4200		var
4201		DidActivate: Boolean;
3599	–	SetCursor: Boolean;
4202		begin
4203		DidActivate := False;
4204	<	SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault);
3603	<	if SetCursor then
3604	<	Screen.Cursor := crHourGlass;
4204	>	FBase.SetCursor;
4205		try
4206		ActivateConnection;
4207		DidActivate := ActivateTransaction;
#	Line 3618 | Line 4218 | begin
4218		finally
4219		if DidActivate then
4220		DeactivateTransaction;
4221	<	if SetCursor and (Screen.Cursor = crHourGlass) then
3622	<	Screen.Cursor := crDefault;
4221	>	FBase.RestoreCursor;
4222		end;
4223		end;
4224
#	Line 3628 | Line 4227 | begin
4227		Result := FQSelect.Handle;
4228		end;
4229
4230	+	function TIBCustomDataSet.GetParser: TSelectSQLParser;
4231	+	begin
4232	+	if not assigned(FParser) then
4233	+	FParser := CreateParser;
4234	+	Result := FParser
4235	+	end;
4236	+
4237	+	procedure TIBCustomDataSet.ResetParser;
4238	+	begin
4239	+	if assigned(FParser) then
4240	+	begin
4241	+	FParser.Free;
4242	+	FParser := nil;
4243	+	FQSelect.OnSQLChanged := nil; {Do not react to change}
4244	+	try
4245	+	FQSelect.SQL.Assign(FBaseSQLSelect);
4246	+	finally
4247	+	FQSelect.OnSQLChanged := SQLChanged;
4248	+	end;
4249	+	end;
4250	+	end;
4251	+
4252	+	function TIBCustomDataSet.HasParser: boolean;
4253	+	begin
4254	+	Result := not (csDesigning in ComponentState) and (FParser <> nil)
4255	+	end;
4256	+
4257	+	procedure TIBCustomDataSet.SetGenerateParamNames(AValue: Boolean);
4258	+	begin
4259	+	if FGenerateParamNames = AValue then Exit;
4260	+	FGenerateParamNames := AValue;
4261	+	Disconnect
4262	+	end;
4263	+
4264		procedure TIBCustomDataSet.InitRecord(Buffer: PChar);
4265		begin
4266		inherited InitRecord(Buffer);
#	Line 3951 | Line 4584 | begin
4584		DataSet.SetInternalSQLParams(Query, buff);
4585		end;
4586
4587	+	function TIBDSBlobStream.GetSize: Int64;
4588	+	begin
4589	+	Result := FBlobStream.BlobSize;
4590	+	end;
4591	+
4592		{ TIBDSBlobStream }
4593		constructor TIBDSBlobStream.Create(AField: TField; ABlobStream: TIBBlobStream;
4594		Mode: TBlobStreamMode);
#	Line 3959 | Line 4597 | begin
4597		FBlobStream := ABlobStream;
4598		FBlobStream.Seek(0, soFromBeginning);
4599		if (Mode = bmWrite) then
4600	+	begin
4601		FBlobStream.Truncate;
4602	+	TIBCustomDataSet(FField.DataSet).RecordModified(True);
4603	+	TBlobField(FField).Modified := true;
4604	+	FHasWritten := true;
4605	+	end;
4606	+	end;
4607	+
4608	+	destructor TIBDSBlobStream.Destroy;
4609	+	begin
4610	+	if FHasWritten then
4611	+	TIBCustomDataSet(FField.DataSet).DataEvent(deFieldChange, PtrInt(FField));
4612	+	inherited Destroy;
4613		end;
4614
4615		function TIBDSBlobStream.Read(var Buffer; Count: Longint): Longint;
#	Line 3984 | Line 4634 | begin
4634		TIBCustomDataSet(FField.DataSet).RecordModified(True);
4635		TBlobField(FField).Modified := true;
4636		result := FBlobStream.Write(Buffer, Count);
4637	<	TIBCustomDataSet(FField.DataSet).DataEvent(deFieldChange, PtrInt(FField));
4637	>	FHasWritten := true;
4638	>	{  TIBCustomDataSet(FField.DataSet).DataEvent(deFieldChange, PtrInt(FField));
4639	>	Removed as this caused a seek to beginning of the blob stream thus corrupting
4640	>	the blob stream. Moved to the destructor i.e. called after blob written}
4641		end;
4642
4643		{ TIBGenerator }
#	Line 4035 | Line 4688 | begin
4688		Owner.FieldByName(FFieldName).AsInteger := GetNextValue(Owner.Database,Owner.Transaction);
4689		end;
4690
4691	+
4692		end.

Diff Legend

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