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 35 by tony, Tue Jan 26 14:38:47 2016 UTC vs.
Revision 39 by tony, Tue May 17 08:14:52 2016 UTC

#	Line 33 | Line 33
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}
#	Line 120 | Line 126 | type
126
127		TIBStringField = class(TStringField)
128		private
129	<	FCharacterSetName: string;
129	>	FCharacterSetName: RawByteString;
130		FCharacterSetSize: integer;
131		protected
132		function GetDefaultWidth: Longint; override;
#	Line 131 | Line 137 | type
137		function GetAsVariant: Variant; override;
138		function GetValue(var Value: string): Boolean;
139		procedure SetAsString(const Value: string); override;
140	<	property CharacterSetName: string read FCharacterSetName write FCharacterSetName;
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: string;
154	>	FCharacterSetName: RawByteString;
155		FCharacterSetSize: integer;
156		public
157	<	property CharacterSetName: string read FCharacterSetName write FCharacterSetName;
157	>	property CharacterSetName: RawByteString read FCharacterSetName write FCharacterSetName;
158		property CharacterSetSize: integer read FCharacterSetSize write FCharacterSetSize;
159		end;
160
#	Line 172 | Line 184 | type
184
185		TIBMemoField = class(TMemoField)
186		private
187	<	FCharacterSetName: string;
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: string read FCharacterSetName write FCharacterSetName;
198	>	property CharacterSetName: RawByteString read FCharacterSetName write FCharacterSetName;
199		property CharacterSetSize: integer read FCharacterSetSize write FCharacterSetSize;
200	<	published
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: string;
216	>	FCharacterSetName: RawByteString;
217		FCharacterSetSize: integer;
218		FDisplayTextAsClassName: boolean;
219		function GetTruncatedText: string;
#	Line 201 | Line 222 | type
222		procedure GetText(var AText: string; ADisplayText: Boolean); override;
223		public
224		constructor Create(AOwner: TComponent); override;
225	<	property CharacterSetName: string read FCharacterSetName write FCharacterSetName;
225	>	property CharacterSetName: RawByteString read FCharacterSetName write FCharacterSetName;
226		property CharacterSetSize: integer read FCharacterSetSize write FCharacterSetSize;
227		published
228		property DisplayTextAsClassName: boolean read FDisplayTextAsClassName
#	Line 787 | Line 808 | DefaultFieldClasses: array[TFieldType] o
808
809		implementation
810
811	<	uses IBIntf, Variants, FmtBCD, LCLProc, LazUTF8;
811	>	uses IBIntf, Variants, FmtBCD, LazUTF8;
812
813		const FILE_BEGIN = 0;
814		FILE_CURRENT = 1;
#	Line 816 | Line 837 | type
837
838		TIBFieldDef = class(TFieldDef)
839		private
840	<	FCharacterSetName: string;
840	>	FCharacterSetName: RawByteString;
841		FCharacterSetSize: integer;
842	+	{$IFDEF HAS_ANSISTRING_CODEPAGE}
843	+	FCodePage: TSystemCodePage;
844	+	{$ENDIF}
845		published
846	<	property CharacterSetName: string read FCharacterSetName write FCharacterSetName;
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	+
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 }
#	Line 846 | Line 915 | procedure TIBWideMemoField.GetText(var A
915		begin
916		if ADisplayText then
917		begin
918	<	if not DisplayTextAsClassName then
918	>	if not DisplayTextAsClassName and (CharacterSetName<> '') then
919		AText := GetTruncatedText
920		else
921		inherited GetText(AText, ADisplayText);
#	Line 890 | Line 959 | begin
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	<	Result := 128;
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 then
984	>	if not DisplayTextAsClassName and (CharacterSetName <> '') then
985		AText := GetTruncatedText
986		else
987		inherited GetText(AText, ADisplayText);
#	Line 908 | Line 990 | begin
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 }
#	Line 954 | Line 1050 | constructor TIBStringField.Create(aOwner
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 976 | 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 983 | 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 995 | 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 1215 | Line 1328 | end;
1328
1329		procedure TIBCustomDataSet.ApplyUpdates;
1330		var
1331	<	{$IF FPC_FULLVERSION >= 20700 }
1331	>	{$IFDEF NEW_TBOOKMARK }
1332		CurBookmark: TBookmark;
1333		{$ELSE}
1334		CurBookmark: string;
#	Line 1950 | Line 2063 | function TIBCustomDataSet.InternalLocate
2063		const KeyValues: Variant; Options: TLocateOptions): Boolean;
2064		var
2065		keyFieldList: TList;
2066	<	{$IF FPC_FULLVERSION >= 20700 }
2066	>	{$IFDEF NEW_TBOOKMARK }
2067		CurBookmark: TBookmark;
2068		{$ELSE}
2069		CurBookmark: string;
#	Line 2892 | Line 3005 | end;
3005
3006		procedure TIBCustomDataSet.FetchAll;
3007		var
3008	<	{$IF FPC_FULLVERSION >= 20700 }
3008	>	{$IFDEF NEW_TBOOKMARK }
3009		CurBookmark: TBookmark;
3010		{$ELSE}
3011		CurBookmark: string;
#	Line 3317 | Line 3430 | var
3430		FieldSize: Word;
3431		charSetID: short;
3432		CharSetSize: integer;
3433	<	CharSetName: string;
3433	>	CharSetName: RawByteString;
3434	>	{$IFDEF HAS_ANSISTRING_CODEPAGE}
3435	>	FieldCodePage: TSystemCodePage;
3436	>	{$ENDIF}
3437		FieldNullable : Boolean;
3438		i, FieldPosition, FieldPrecision: Integer;
3439		FieldAliasName, DBAliasName: string;
#	Line 3450 | Line 3566 | begin
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 }
#	Line 3457 | Line 3576 | begin
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		if CharSetSize = 2 then
#	Line 3522 | Line 3644 | begin
3644		FieldSize := sizeof (TISC_QUAD);
3645		if (sqlsubtype = 1) then
3646		begin
3647	<	if strpas(sqlname) = '' then {Complex SQL with no identifiable column - use connection default}
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
#	Line 3567 | Line 3704 | begin
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 3734 | Line 3874 | procedure TIBCustomDataSet.InternalOpen;
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
#	Line 3756 | Line 3899 | procedure TIBCustomDataSet.InternalOpen;
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
#	Line 3925 | Line 4071 | end;
4071		function TIBCustomDataSet.Locate(const KeyFields: string; const KeyValues: Variant;
4072		Options: TLocateOptions): Boolean;
4073		var
4074	<	{$IF FPC_FULLVERSION >= 20700 }
4074	>	{$IFDEF NEW_TBOOKMARK }
4075		CurBookmark: TBookmark;
4076		{$ELSE}
4077		CurBookmark: string;
#	Line 3947 | Line 4093 | function TIBCustomDataSet.Lookup(const K
4093		const ResultFields: string): Variant;
4094		var
4095		fl: TList;
4096	<	{$IF FPC_FULLVERSION >= 20700 }
4096	>	{$IFDEF NEW_TBOOKMARK }
4097		CurBookmark: TBookmark;
4098		{$ELSE}
4099		CurBookmark: string;

Diff Legend

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