Commit 1236d8fb authored by Juha Manninen's avatar Juha Manninen
Browse files

LCL: Implement WriteVariant for TLRSObjectWriter. Fix variant property editor....

LCL: Implement WriteVariant for TLRSObjectWriter. Fix variant property editor. Issue #28040, patch from Michal Gawrycki.

git-svn-id: trunk@52328 -
parent c5dce4c9
......@@ -1406,7 +1406,10 @@ procedure TOICustomPropertyGrid.SetRowValue(CheckFocus: boolean);
tkSet:
Result := Editor.GetSetValueAt(Index,true);
tkVariant:
Result := Editor.GetVarValueAt(Index);
if Editor.GetVarValueAt(Index) <> Null then
Result := Editor.GetVarValueAt(Index)
else
Result := '(Null)';
end;
end;
......
......@@ -23,7 +23,7 @@ interface
uses
// RTL / FCL
Classes, TypInfo, SysUtils, types, RtlConsts,
Classes, TypInfo, SysUtils, types, RtlConsts, variants,
// LCL
LCLType, LCLIntf, LCLProc, Forms, Controls, GraphType, ButtonPanel, Graphics,
StdCtrls, Buttons, Menus, ExtCtrls, ComCtrls, Dialogs, EditBtn, Grids, ValEdit,
......@@ -2915,7 +2915,8 @@ begin
Changed:=false;
for I:=0 to FPropCount-1 do
with FPropList^[I] do
Changed:=Changed or (GetVariantProp(Instance,PropInfo)<>NewValue);
Changed:=Changed or (GetVariantProp(Instance,PropInfo)<>NewValue)
or (VarType(GetVariantProp(Instance,PropInfo))<>VarType(NewValue));
if Changed then
for I:=0 to FPropCount-1 do
with FPropList^[I] do begin
......@@ -4980,6 +4981,111 @@ begin
SetFloatValue(DT);
end;
const
VarTypeStr: array[0..16] of record
VarType: Word;
Name: String;
end = (
(VarType: varempty; Name: 'Unassigned'),
(VarType: varnull; Name: 'Null'),
(VarType: varsmallint; Name: 'SmallInt'),
(VarType: varinteger; Name: 'Integer'),
(VarType: varsingle; Name: 'Single'),
(VarType: vardouble; Name: 'Double'),
(VarType: varcurrency; Name: 'Currency'),
(VarType: vardate; Name: 'Date'),
(VarType: varolestr; Name: 'OleStr'),
(VarType: varboolean; Name: 'Boolean'),
(VarType: varshortint; Name: 'ShortInt'),
(VarType: varbyte; Name: 'Byte'),
(VarType: varword; Name: 'Word'),
(VarType: varlongword; Name: 'LongWord'),
(VarType: varint64; Name: 'Int64'),
(VarType: varqword; Name: 'QWord'),
(VarType: varstring; Name: 'String')
);
function GetVarTypeName(AVarType: tvartype): String;
var
I: Integer;
begin
Result := '';
for I := Low(VarTypeStr) to High(VarTypeStr) do
if VarTypeStr[I].VarType = AVarType then
Exit(VarTypeStr[I].Name);
end;
function GetVarTypeByName(AName: String): tvartype;
var
I: Integer;
begin
Result := varempty;
for I := Low(VarTypeStr) to High(VarTypeStr) do
if UpperCase(VarTypeStr[I].Name) = UpperCase(AName) then
Exit(VarTypeStr[I].VarType);
end;
type
{ TVarTypeProperty }
TVarTypeProperty = class(TNestedProperty)
function GetName: shortstring; override;
function GetAttributes: TPropertyAttributes; override;
procedure GetValues(Proc: TGetStrProc); override;
function GetValue: ansistring; override;
procedure SetValue(const NewValue: ansistring); override;
end;
{ TVarTypeProperty }
function TVarTypeProperty.GetName: shortstring;
begin
Result := 'Type';
end;
function TVarTypeProperty.GetAttributes: TPropertyAttributes;
begin
Result := [paValueList];
end;
procedure TVarTypeProperty.GetValues(Proc: TGetStrProc);
var
I: Integer;
begin
for I := Low(VarTypeStr) to High(VarTypeStr) do
Proc(VarTypeStr[I].Name);
end;
function TVarTypeProperty.GetValue: ansistring;
begin
Result := GetVarTypeName(VarType(GetVarValue));
if Result = '' then
Result := 'Unknown'; // Is there resourcestring for that?
end;
procedure TVarTypeProperty.SetValue(const NewValue: ansistring);
var
V: Variant;
VT: tvartype;
begin
V := GetVarValue;
VT := GetVarTypeByName(NewValue);
case VT of
varempty:
VarClear(V);
varnull:
V := Null;
else
try
VarCast(V, V, VT);
except
VarClear(V);
end;
end;
SetVarValue(V);
end;
{ TVariantPropertyEditor }
function TVariantPropertyEditor.GetAttributes: TPropertyAttributes;
......@@ -4989,16 +5095,27 @@ end;
procedure TVariantPropertyEditor.GetProperties(Proc:TGetPropEditProc);
begin
Proc(TVarTypeProperty.Create(Self));
end;
function TVariantPropertyEditor.GetValue: string;
begin
Result:='';
if VarType(GetVarValue) <> varnull then
Result := VarToStrDef(GetVarValue, 'Unknown') // Is there resourcestring for that?
else
Result := '(Null)';
end;
procedure TVariantPropertyEditor.SetValue(const Value: string);
var
V: Variant;
begin
try
VarCast(V, Value, VarType(GetVarValue));
except
V := Value;
end;
SetVarValue(V);
end;
......@@ -7443,6 +7560,8 @@ begin
RegisterPropertyEditor(TypeInfo(QWordBool), nil, '', TBoolPropertyEditor);
RegisterPropertyEditor(TypeInfo(IInterface), nil, '', TInterfacePropertyEditor);
RegisterPropertyEditor(TypeInfo(Variant), nil, '', TVariantPropertyEditor);
end;
procedure FinalPropEdits;
......
......@@ -33,8 +33,9 @@ uses
{$IFDEF Windows}
Windows,
{$ENDIF}
Classes, SysUtils, Types, RtlConsts, FPCAdds, TypInfo, FileUtil, DynQueue,
LCLProc, LCLStrConsts, LazConfigStorage, LazUTF8, LazUTF8Classes;
Classes, SysUtils, Types, RtlConsts, TypInfo, variants,
DynQueue, LCLProc, LCLStrConsts,
LazConfigStorage, FPCAdds, LazUTF8, LazUTF8Classes;
{$DEFINE UseLRS}
{$DEFINE UseRES}
......@@ -295,6 +296,7 @@ type
procedure WriteString(const Value: String); override;
procedure WriteWideString(const Value: WideString); override;
procedure WriteUnicodeString(const Value: UnicodeString); override;
procedure WriteVariant(const Value: Variant); override;
property WriteEmptyInheritedChilds: boolean read FWriteEmptyInheritedChilds write FWriteEmptyInheritedChilds;
property Writer: TWriter read FWriter write FWriter;
......@@ -2496,15 +2498,15 @@ procedure LRSObjectBinaryToText(Input, Output: TStream);
end;
vaSingle: begin
ASingle:=ReadLRSSingle(Input);
OutLn(FloatToStr(ASingle));
OutLn(FloatToStr(ASingle) + 's');
end;
vaDate: begin
ADate:=TDateTime(ReadLRSDouble(Input));
OutLn(FloatToStr(ADate));
OutLn(FloatToStr(ADate) + 'd');
end;
vaCurrency: begin
ACurrency:=ReadLRSCurrency(Input);
OutLn(FloatToStr(ACurrency));
OutLn(FloatToStr(ACurrency * 10000) + 'c');
end;
vaWString,vaUString: begin
AWideString:=ReadLRSWideString(Input);
......@@ -2804,9 +2806,26 @@ var
end;
toFloat:
begin
Output.WriteByte(Ord(vaExtended));
flt := Parser.TokenFloat;
WriteLRSExtended(Output,flt);
case parser.FloatType of
's': begin
Output.WriteByte(Ord(vaSingle));
WriteLRSSingle(Output,flt);
end;
'd': begin
Output.WriteByte(Ord(vaDate));
WriteLRSDouble(Output,flt);
end;
'c': begin
Output.WriteByte(Ord(vaCurrency));
WriteLRSCurrency(Output,flt/10000);
end;
else
begin
Output.WriteByte(Ord(vaExtended));
WriteLRSExtended(Output,flt);
end;
end;
ParserNextToken;
end;
toString:
......@@ -4977,6 +4996,30 @@ begin
WriteWideStringContent(Value);
end;
procedure TLRSObjectWriter.WriteVariant(const Value: Variant);
begin
case VarType(Value) of
varnull:
WriteValue(vaNull);
varsmallint, varinteger, varshortint, varint64, varbyte, varword, varlongword, varqword:
WriteInteger(Value);
varsingle:
WriteSingle(Value);
vardouble:
WriteFloat(Value);
vardate:
WriteDate(Value);
varcurrency:
WriteCurrency(Value);
varolestr, varstring:
WriteString(Value);
varboolean:
WriteBoolean(Value);
else
WriteValue(vaNil);
end;
end;
{ TLRPositionLinks }
function TLRPositionLinks.GetLFM(Index: integer): Int64;
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment