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 33 by tony, Sat Jul 18 12:30:52 2015 UTC vs.
Revision 37 by tony, Mon Feb 15 14:44:25 2016 UTC

#	Line 120 | Line 120 | type
120
121		TIBStringField = class(TStringField)
122		private
123	<	FInitialised: boolean;
123	>	FCharacterSetName: string;
124	>	FCharacterSetSize: integer;
125		protected
126	<	procedure SetSize(AValue: Integer); override;
126	>	function GetDefaultWidth: Longint; override;
127		public
128	<	constructor create(AOwner: TComponent); override;
128	>	constructor Create(aOwner: TComponent); override;
129		class procedure CheckTypeSize(Value: Integer); override;
130		function GetAsString: string; override;
131		function GetAsVariant: Variant; override;
132		function GetValue(var Value: string): Boolean;
133		procedure SetAsString(const Value: string); override;
134	+	property CharacterSetName: string read FCharacterSetName write FCharacterSetName;
135	+	property CharacterSetSize: integer read FCharacterSetSize write FCharacterSetSize;
136	+	end;
137	+
138	+	{ TIBWideStringField }
139	+
140	+	TIBWideStringField = class(TWideStringField)
141	+	private
142	+	FCharacterSetName: string;
143	+	FCharacterSetSize: integer;
144	+	public
145	+	property CharacterSetName: string read FCharacterSetName write FCharacterSetName;
146	+	property CharacterSetSize: integer read FCharacterSetSize write FCharacterSetSize;
147		end;
148
149		{ TIBBCDField }
#	Line 152 | Line 166 | type
166		property Size default 8;
167		end;
168
169	+	{TIBMemoField}
170	+	{Allows us to show truncated text in DBGrids and anything else that uses
171	+	DisplayText}
172	+
173	+	TIBMemoField = class(TMemoField)
174	+	private
175	+	FCharacterSetName: string;
176	+	FCharacterSetSize: integer;
177	+	FDisplayTextAsClassName: boolean;
178	+	function GetTruncatedText: string;
179	+	protected
180	+	function GetDefaultWidth: Longint; override;
181	+	procedure GetText(var AText: string; ADisplayText: Boolean); override;
182	+	public
183	+	constructor Create(AOwner: TComponent); override;
184	+	property CharacterSetName: string read FCharacterSetName write FCharacterSetName;
185	+	property CharacterSetSize: integer read FCharacterSetSize write FCharacterSetSize;
186	+	published
187	+	property DisplayTextAsClassName: boolean read FDisplayTextAsClassName
188	+	write FDisplayTextAsClassName;
189	+	end;
190	+
191	+	{ TIBWideMemoField }
192	+
193	+	TIBWideMemoField = class(TWideMemoField)
194	+	private
195	+	FCharacterSetName: string;
196	+	FCharacterSetSize: integer;
197	+	FDisplayTextAsClassName: boolean;
198	+	function GetTruncatedText: string;
199	+	protected
200	+	function GetDefaultWidth: Longint; override;
201	+	procedure GetText(var AText: string; ADisplayText: Boolean); override;
202	+	public
203	+	constructor Create(AOwner: TComponent); override;
204	+	property CharacterSetName: string read FCharacterSetName write FCharacterSetName;
205	+	property CharacterSetSize: integer read FCharacterSetSize write FCharacterSetSize;
206	+	published
207	+	property DisplayTextAsClassName: boolean read FDisplayTextAsClassName
208	+	write FDisplayTextAsClassName;
209	+	end;
210	+
211		TIBDataLink = class(TDetailDataLink)
212		private
213		FDataSet: TIBCustomDataSet;
#	Line 341 | Line 397 | type
397		procedure SetUpdateRecordTypes(Value: TIBUpdateRecordTypes);
398		procedure SetUniDirectional(Value: Boolean);
399		procedure RefreshParams;
344	–	procedure SQLChanging(Sender: TObject); virtual;
400		function AdjustPosition(FCache: PChar; Offset: DWORD;
401		Origin: Integer): DWORD;
402		procedure ReadCache(FCache: PChar; Offset: DWORD; Origin: Integer;
#	Line 371 | Line 426 | type
426		procedure InternalRefreshRow; virtual;
427		procedure InternalSetParamsFromCursor; virtual;
428		procedure CheckNotUniDirectional;
429	+	procedure SQLChanging(Sender: TObject); virtual;
430	+	procedure SQLChanged(Sender: TObject); virtual;
431
432		(*    { IProviderSupport }
433		procedure PSEndTransaction(Commit: Boolean); override;
#	Line 502 | Line 559 | type
559		procedure RecordModified(Value: Boolean);
560		procedure RevertRecord;
561		procedure Undelete;
562	<	procedure ResetParser;
562	>	procedure ResetParser; virtual;
563		function HasParser: boolean;
564
565		{ TDataSet support methods }
#	Line 690 | Line 747 | DefaultFieldClasses: array[TFieldType] o
747		TVarBytesField,     { ftVarBytes }
748		TAutoIncField,      { ftAutoInc }
749		TBlobField,         { ftBlob }
750	<	TMemoField,         { ftMemo }
750	>	TIBMemoField,       { ftMemo }
751		TGraphicField,      { ftGraphic }
752		TBlobField,         { ftFmtMemo }
753		TBlobField,         { ftParadoxOle }
#	Line 698 | Line 755 | DefaultFieldClasses: array[TFieldType] o
755		TBlobField,         { ftTypedBinary }
756		nil,                { ftCursor }
757		TStringField,       { ftFixedChar }
758	<	TWideStringField,    { ftWideString }
758	>	TIBWideStringField,    { ftWideString }
759		TLargeIntField,     { ftLargeInt }
760		nil,          { ftADT }
761		nil,        { ftArray }
#	Line 713 | Line 770 | DefaultFieldClasses: array[TFieldType] o
770		TDateTimeField,    {ftTimestamp}
771		TIBBCDField,       {ftFMTBcd}
772		nil,  {ftFixedWideChar}
773	<	TWideMemoField);   {ftWideMemo}
773	>	TIBWideMemoField);   {ftWideMemo}
774		(*
775		TADTField,          { ftADT }
776		TArrayField,        { ftArray }
#	Line 730 | Line 787 | DefaultFieldClasses: array[TFieldType] o
787
788		implementation
789
790	<	uses IBIntf, Variants, FmtBCD;
790	>	uses IBIntf, Variants, FmtBCD, LazUTF8;
791
792		const FILE_BEGIN = 0;
793		FILE_CURRENT = 1;
#	Line 753 | Line 810 | type
810		NextRelation : TRelationNode;
811		end;
812
813	+	{Extended Field Def for character set info}
814	+
815	+	{ TIBFieldDef }
816	+
817	+	TIBFieldDef = class(TFieldDef)
818	+	private
819	+	FCharacterSetName: string;
820	+	FCharacterSetSize: integer;
821	+	published
822	+	property CharacterSetName: string read FCharacterSetName write FCharacterSetName;
823	+	property CharacterSetSize: integer read FCharacterSetSize write FCharacterSetSize;
824	+	end;
825	+
826	+
827	+	{  Copied from LCLProc in order to avoid LCL dependency
828	+
829	+	Ensures the covenient look of multiline string
830	+	when displaying it in the single line
831	+	* Replaces CR and LF with spaces
832	+	* Removes duplicate spaces
833	+	}
834	+	function TextToSingleLine(const AText: string): string;
835	+	var
836	+	str: string;
837	+	i, wstart, wlen: Integer;
838	+	begin
839	+	str := Trim(AText);
840	+	wstart := 0;
841	+	wlen := 0;
842	+	i := 1;
843	+	while i < Length(str) - 1 do
844	+	begin
845	+	if (str[i] in [' ', #13, #10]) then
846	+	begin
847	+	if (wstart = 0) then
848	+	begin
849	+	wstart := i;
850	+	wlen := 1;
851	+	end else
852	+	Inc(wlen);
853	+	end else
854	+	begin
855	+	if wstart > 0 then
856	+	begin
857	+	str[wstart] := ' ';
858	+	Delete(str, wstart+1, wlen-1);
859	+	Dec(i, wlen-1);
860	+	wstart := 0;
861	+	end;
862	+	end;
863	+	Inc(i);
864	+	end;
865	+	Result := str;
866	+	end;
867	+
868	+	{ TIBWideMemoField }
869	+
870	+	function TIBWideMemoField.GetTruncatedText: string;
871	+	begin
872	+	Result := GetAsString;
873	+
874	+	if Result <> '' then
875	+	if DisplayWidth = 0 then
876	+	Result := TextToSingleLine(Result)
877	+	else
878	+	if Length(Result) > DisplayWidth then {Show truncation with elipses}
879	+	Result := TextToSingleLine(system.copy(Result,1,DisplayWidth-3)) + '...';
880	+	end;
881	+
882	+	function TIBWideMemoField.GetDefaultWidth: Longint;
883	+	begin
884	+	Result := 128;
885	+	end;
886	+
887	+	procedure TIBWideMemoField.GetText(var AText: string; ADisplayText: Boolean);
888	+	begin
889	+	if ADisplayText then
890	+	begin
891	+	if not DisplayTextAsClassName then
892	+	AText := GetTruncatedText
893	+	else
894	+	inherited GetText(AText, ADisplayText);
895	+	end
896	+	else
897	+	AText := GetAsString;
898	+	end;
899	+
900	+	constructor TIBWideMemoField.Create(AOwner: TComponent);
901	+	begin
902	+	inherited Create(AOwner);
903	+	BlobType := ftWideMemo;
904	+	end;
905	+
906	+	{ TIBMemoField }
907	+
908	+	function TIBMemoField.GetTruncatedText: string;
909	+	begin
910	+	Result := GetAsString;
911	+
912	+	if Result <> '' then
913	+	begin
914	+	case CharacterSetSize of
915	+	1:
916	+	if DisplayWidth = 0 then
917	+	Result := TextToSingleLine(Result)
918	+	else
919	+	if Length(Result) > DisplayWidth then {Show truncation with elipses}
920	+	Result := TextToSingleLine(system.copy(Result,1,DisplayWidth-3)) + '...';
921	+
922	+	{2: case 2 ignored. This should be handled by TIBWideMemo}
923	+
924	+	3, {Assume UNICODE_FSS is really UTF8}
925	+	4: {Include GB18030 - assuming UTF8 routine work for this codeset}
926	+	if DisplayWidth = 0 then
927	+	Result := ValidUTF8String(TextToSingleLine(Result))
928	+	else
929	+	if UTF8Length(Result) > DisplayWidth then {Show truncation with elipses}
930	+	Result := ValidUTF8String(TextToSingleLine(UTF8Copy(Result,1,DisplayWidth-3))) + '...';
931	+	end;
932	+	end
933	+	end;
934	+
935	+	function TIBMemoField.GetDefaultWidth: Longint;
936	+	begin
937	+	if DisplayTextAsClassName then
938	+	Result := inherited
939	+	else
940	+	Result := 128;
941	+	end;
942	+
943	+	procedure TIBMemoField.GetText(var AText: string; ADisplayText: Boolean);
944	+	begin
945	+	if ADisplayText then
946	+	begin
947	+	if not DisplayTextAsClassName then
948	+	AText := GetTruncatedText
949	+	else
950	+	inherited GetText(AText, ADisplayText);
951	+	end
952	+	else
953	+	AText := GetAsString;
954	+	end;
955	+
956	+	constructor TIBMemoField.Create(AOwner: TComponent);
957	+	begin
958	+	inherited Create(AOwner);
959	+	BlobType := ftMemo;
960	+	end;
961	+
962		{ TIBControlLink }
963
964		destructor TIBControlLink.Destroy;
#	Line 784 | Line 990 | end;
990
991		{ TIBStringField}
992
993	<	constructor TIBStringField.create(AOwner: TComponent);
993	>	function TIBStringField.GetDefaultWidth: Longint;
994		begin
995	<	inherited Create(AOwner);
995	>	Result := Size div CharacterSetSize;
996	>	end;
997	>
998	>	constructor TIBStringField.Create(aOwner: TComponent);
999	>	begin
1000	>	inherited Create(aOwner);
1001	>	FCharacterSetSize := 1;
1002		end;
1003
1004		class procedure TIBStringField.CheckTypeSize(Value: Integer);
#	Line 841 | Line 1053 | begin
1053		end;
1054		end;
1055
844	–	procedure TIBStringField.SetSize(AValue: Integer);
845	–	var FieldSize: integer;
846	–	begin
847	–	if csLoading in ComponentState then
848	–	FInitialised := true;
849	–	if FInitialised then
850	–	inherited SetSize(AValue)
851	–	else
852	–	begin
853	–	{IBCustomDataSet encodes the CharWidth size in the size}
854	–	FieldSize := AValue div 4;
855	–	inherited SetSize(FieldSize);
856	–	DisplayWidth := FieldSize div ((AValue mod 4) + 1);
857	–	FInitialised := true;
858	–	end;
859	–	end;
1056
1057		{ TIBBCDField }
1058
#	Line 974 | Line 1170 | begin
1170		FQRefresh.GoToFirstRecordOnExecute := False;
1171		FQSelect := TIBSQL.Create(Self);
1172		FQSelect.OnSQLChanging := SQLChanging;
1173	+	FQSelect.OnSQLChanged := SQLChanged;
1174		FQSelect.GoToFirstRecordOnExecute := False;
1175		FQModify := TIBSQL.Create(Self);
1176		FQModify.OnSQLChanging := SQLChanging;
#	Line 2057 | Line 2254 | begin
2254		FBase.CheckDatabase;
2255		FBase.CheckTransaction;
2256		if HasParser and (FParser.SQLText <> FQSelect.SQL.Text) then
2257	<	FQSelect.SQL.Text := FParser.SQLText;
2257	>	begin
2258	>	FQSelect.OnSQLChanged := nil; {Do not react to change}
2259	>	try
2260	>	FQSelect.SQL.Text := FParser.SQLText;
2261	>	finally
2262	>	FQSelect.OnSQLChanged := SQLChanged;
2263	>	end;
2264	>	end;
2265		//   writeln( FQSelect.SQL.Text);
2266		if FQSelect.SQL.Text <> '' then
2267		begin
#	Line 2304 | Line 2508 | begin
2508		begin
2509		Disconnect;
2510		FQSelect.SQL.Assign(Value);
2307	–	FBaseSQLSelect.assign(Value);
2511		end;
2512		end;
2513
#	Line 2383 | Line 2586 | begin
2586		FieldDefs.Updated := false;
2587		end;
2588
2589	+	procedure TIBCustomDataSet.SQLChanged(Sender: TObject);
2590	+	begin
2591	+	FBaseSQLSelect.assign(FQSelect.SQL);
2592	+	end;
2593	+
2594		{ I can "undelete" uninserted records (make them "inserted" again).
2595		I can "undelete" cached deleted (the deletion hasn't yet occurred) }
2596		procedure TIBCustomDataSet.Undelete;
#	Line 3078 | Line 3286 | begin
3286		FreeMem(FOldBufferCache);
3287		FOldBufferCache := nil;
3288		BindFields(False);
3289	+	ResetParser;
3290		if DefaultFields then DestroyFields;
3291		end;
3292
#	Line 3151 | Line 3360 | const
3360		var
3361		FieldType: TFieldType;
3362		FieldSize: Word;
3363	+	charSetID: short;
3364		CharSetSize: integer;
3365	+	CharSetName: string;
3366		FieldNullable : Boolean;
3367		i, FieldPosition, FieldPrecision: Integer;
3368		FieldAliasName, DBAliasName: string;
#	Line 3282 | Line 3493 | begin
3493		FieldSize := 0;
3494		FieldPrecision := 0;
3495		FieldNullable := SourceQuery.Current[i].IsNullable;
3496	+	CharSetSize := 0;
3497	+	CharSetName := '';
3498		case sqltype and not 1 of
3499		{ All VARCHAR's must be converted to strings before recording
3500		their values }
3501		SQL_VARYING, SQL_TEXT:
3502		begin
3503		CharSetSize := FBase.GetCharSetSize(sqlsubtype and $FF);
3504	+	CharSetName := FBase.GetCharSetName(sqlsubtype and $FF);
3505		{FieldSize is encoded for strings - see TIBStringField.SetSize for decode}
3506	<	FieldSize := sqllen * 4 + (CharSetSize - 1);
3507	<	FieldType := ftString;
3506	>	FieldSize := sqllen;
3507	>	if CharSetSize = 2 then
3508	>	FieldType := ftWideString
3509	>	else
3510	>	FieldType := ftString;
3511		end;
3512		{ All Doubles/Floats should be cast to doubles }
3513		SQL_DOUBLE, SQL_FLOAT:
#	Line 3349 | Line 3566 | begin
3566		begin
3567		FieldSize := sizeof (TISC_QUAD);
3568		if (sqlsubtype = 1) then
3569	<	FieldType := ftmemo
3569	>	begin
3570	>	if strpas(sqlname) = '' then {Complex SQL with no identifiable column - use connection default}
3571	>	begin
3572	>	CharSetSize := FBase.GetDefaultCharSetSize;
3573	>	CharSetName := FBase.GetDefaultCharSetName;
3574	>	end
3575	>	else
3576	>	begin
3577	>	charSetID := GetBlobCharSetID(Database.Handle,Database.InternalTransaction.Handle,
3578	>	@relname,@sqlname);
3579	>	CharSetSize := FBase.GetCharSetSize(charSetID);
3580	>	CharSetName := FBase.GetCharSetName(charSetID);
3581	>	end;
3582	>	if CharSetSize = 2 then
3583	>	FieldType := ftWideMemo
3584	>	else
3585	>	FieldType := ftMemo;
3586	>	end
3587		else
3588		FieldType := ftBlob;
3589		end;
#	Line 3368 | Line 3602 | begin
3602		begin
3603		FMappedFieldPosition[FieldIndex] := FieldPosition;
3604		Inc(FieldIndex);
3605	<	with FieldDefs.AddFieldDef do
3605	>	with TIBFieldDef.Create(FieldDefs,'',FieldType,0,False,FieldDefs.Count+1) do
3606		begin
3607		Name := FieldAliasName;
3608		FAliasNameMap[FieldNo-1] := DBAliasName;
3375	–	DataType := FieldType;
3609		Size := FieldSize;
3610		Precision := FieldPrecision;
3611		Required := not FieldNullable;
3612		InternalCalcField := False;
3613	+	CharacterSetSize := CharSetSize;
3614	+	CharacterSetName := CharSetName;
3615		if (FieldName <> '') and (RelationName <> '') then
3616		begin
3617		if Has_COMPUTED_BLR(RelationName, FieldName) then
#	Line 3517 | Line 3752 | procedure TIBCustomDataSet.InternalOpen;
3752		result := SizeOf(TRecordData) + ((n - 1) * SizeOf(TFieldData));
3753		end;
3754
3755	+	function GetFieldDef(aFieldNo: integer): TIBFieldDef;
3756	+	var i: integer;
3757	+	begin
3758	+	Result := nil;
3759	+	for i := 0 to FieldDefs.Count - 1 do
3760	+	if FieldDefs[i].FieldNo = aFieldNo then
3761	+	begin
3762	+	Result := TIBFieldDef(FieldDefs[i]);
3763	+	break;
3764	+	end;
3765	+	end;
3766	+
3767	+	procedure SetExtendedProperties;
3768	+	var i: integer;
3769	+	IBFieldDef: TIBFieldDef;
3770	+	begin
3771	+	for i := 0 to Fields.Count - 1 do
3772	+	if Fields[i].FieldNo > 0 then
3773	+	begin
3774	+	if(Fields[i] is TIBStringField) then
3775	+	with TIBStringField(Fields[i]) do
3776	+	begin
3777	+	IBFieldDef := GetFieldDef(FieldNo);
3778	+	if IBFieldDef <> nil then
3779	+	begin
3780	+	CharacterSetSize := IBFieldDef.CharacterSetSize;
3781	+	CharacterSetName := IBFieldDef.CharacterSetName;
3782	+	end;
3783	+	end
3784	+	else
3785	+	if(Fields[i] is TIBWideStringField) then
3786	+	with TIBWideStringField(Fields[i]) do
3787	+	begin
3788	+	IBFieldDef := GetFieldDef(FieldNo);
3789	+	if IBFieldDef <> nil then
3790	+	begin
3791	+	CharacterSetSize := IBFieldDef.CharacterSetSize;
3792	+	CharacterSetName := IBFieldDef.CharacterSetName;
3793	+	end;
3794	+	end
3795	+	else
3796	+	if(Fields[i] is TIBMemoField) then
3797	+	with TIBMemoField(Fields[i]) do
3798	+	begin
3799	+	IBFieldDef := GetFieldDef(FieldNo);
3800	+	if IBFieldDef <> nil then
3801	+	begin
3802	+	CharacterSetSize := IBFieldDef.CharacterSetSize;
3803	+	CharacterSetName := IBFieldDef.CharacterSetName;
3804	+	end;
3805	+	end
3806	+	else
3807	+	if(Fields[i] is TIBWideMemoField) then
3808	+	with TIBWideMemoField(Fields[i]) do
3809	+	begin
3810	+	IBFieldDef := GetFieldDef(FieldNo);
3811	+	if IBFieldDef <> nil then
3812	+	begin
3813	+	CharacterSetSize := IBFieldDef.CharacterSetSize;
3814	+	CharacterSetName := IBFieldDef.CharacterSetName;
3815	+	end;
3816	+	end
3817	+	end
3818	+	end;
3819	+
3820		begin
3821		FBase.SetCursor;
3822		try
#	Line 3531 | Line 3831 | begin
3831		if DefaultFields then
3832		CreateFields;
3833		BindFields(True);
3834	+	SetExtendedProperties;
3835		FCurrentRecord := -1;
3836		FQSelect.ExecQuery;
3837		FOpen := FQSelect.Open;
#	Line 3931 | Line 4232 | begin
4232		begin
4233		FParser.Free;
4234		FParser := nil;
4235	<	SQLChanging(nil)
4235	>	FQSelect.OnSQLChanged := nil; {Do not react to change}
4236	>	try
4237	>	FQSelect.SQL.Assign(FBaseSQLSelect);
4238	>	finally
4239	>	FQSelect.OnSQLChanged := SQLChanged;
4240	>	end;
4241		end;
4242		end;
4243
#	Line 4364 | Line 4670 | begin
4670		Owner.FieldByName(FFieldName).AsInteger := GetNextValue(Owner.Database,Owner.Transaction);
4671		end;
4672
4673	+
4674		end.

Diff Legend

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