+ added support for streaming basic variant types (boolean, integer types,

floating point types, currency and string types), based on description
    by Anton Kavalenka at
    http://wiki.freepascal.org/FPC_Cleanroom#Variant_streaming_implementation
    and based on his test program (mantis #10482)

git-svn-id: trunk@12781 -

.gitattributes

@@ -8607,6 +8607,7 @@ tests/webtbs/tw10425.pp svneol=native#text/plain
 tests/webtbs/tw1044.pp svneol=native#text/plain
 tests/webtbs/tw10454.pp svneol=native#text/plain
 tests/webtbs/tw1046.pp svneol=native#text/plain
+tests/webtbs/tw10482.pp svneol=native#text/plain
 tests/webtbs/tw10489.pp svneol=native#text/plain
 tests/webtbs/tw10492.pp svneol=native#text/plain
 tests/webtbs/tw10493.pp svneol=native#text/plain

rtl/objpas/classes/classesh.inc

@@ -902,7 +902,7 @@ type
   TValueType = (vaNull, vaList, vaInt8, vaInt16, vaInt32, vaExtended,
     vaString, vaIdent, vaFalse, vaTrue, vaBinary, vaSet, vaLString,
     vaNil, vaCollection, vaSingle, vaCurrency, vaDate, vaWString, vaInt64,
-    vaUTF8String, vaUString);
+    vaUTF8String, vaUString, vaVariant);
 
   TFilerFlag = (ffInherited, ffChildPos, ffInline);
   TFilerFlags = set of TFilerFlag;
@@ -1123,6 +1123,7 @@ type
     procedure ReadListBegin;
     procedure ReadListEnd;
     function ReadRootComponent(ARoot: TComponent): TComponent;
+    function ReadVariant: tvardata;
     function ReadString: string;
     function ReadWideString: WideString;
     function ReadUnicodeString: UnicodeString;
@@ -1299,6 +1300,7 @@ type
     procedure WriteString(const Value: string);
     procedure WriteWideString(const Value: WideString);
     procedure WriteUnicodeString(const Value: UnicodeString);
+    procedure WriteVariant(const VarValue: tvardata);
     property RootAncestor: TComponent read FRootAncestor write FRootAncestor;
     property OnFindAncestor: TFindAncestorEvent read FOnFindAncestor write FOnFindAncestor;
     property OnWriteMethodProperty: TWriteMethodPropertyEvent read FOnWriteMethodProperty write FOnWriteMethodProperty;

rtl/objpas/classes/reader.inc

@@ -307,10 +307,10 @@ var
   i: Integer;
 begin
   case StringType of
-   vaLString,vaUTF8String:
-     i:=ReadDWord;
-  else
-  //vaString:
+    vaLString, vaUTF8String:
+      i:=ReadDWord;
+    else
+    //vaString:
       begin
         Read(b, 1);
         i := b;
@@ -1075,6 +1075,76 @@ begin
   CheckValue(vaNull);
 end;
 
+function TReader.ReadVariant: tvardata;
+type
+  tcurrec = record
+    i: int64;
+  end;
+begin
+  if not Assigned(VarClearProc) then
+    raise EReadError.Create(SErrNoVariantSupport);
+
+  VarClearProc(Result);
+  Read(Result.vtype,sizeof(Result.vtype));
+
+  case Result.vtype of
+    varEmpty,
+    varNull:
+      ;
+    { all integer sizes must be split for big endian systems }
+    varShortInt:
+      begin
+        Result.vShortInt:=ReadInteger;
+      end;
+    varSmallInt:
+      begin
+        Result.vSmallInt:=ReadInteger;
+      end;
+    varInteger:
+      begin
+        Result.vInteger:=ReadInteger;
+      end;
+    varInt64,varQWord:
+      begin
+        Result.vInt64:=ReadInt64;
+      end;
+    varBoolean:
+      begin
+        Result.vBoolean:=ReadBoolean;
+      end;
+    varCurrency:
+      begin
+        { avoid implicit value conversion by the compiler }
+        Result.vCurrency:=Currency(tcurrec(ReadInt64));
+      end;
+{$ifndef fpunone}
+    varSingle:
+      begin
+        Result.vSingle:=ReadSingle;
+      end;
+    varDouble:
+      begin
+        Result.vDouble:=ReadFloat;
+      end;
+    varDate:
+      begin
+        Result.vDate:=ReadFloat;
+      end;
+{$endif fpunone}
+    varOlestr:
+      begin
+        WideString(Pointer(Result.volestr)):=ReadWideString;
+      end;
+    varString:
+      begin
+        Ansistring(Result.vstring):=ReadWideString;
+      end;
+    else
+      raise EReadError.CreateFmt(SUnsupportedPropertyVariantType, [Ord(Result.vtype)]);
+  end;
+end;
+
+
 procedure TReader.ReadProperty(AInstance: TPersistent);
 var
   Path: String;
@@ -1191,6 +1261,7 @@ var
   Method: TMethod;
   Handled: Boolean;
   TmpStr: String;
+  VarTemp: tvardata;
 begin
   if not Assigned(PPropInfo(PropInfo)^.SetProc) then
     raise EReadError.Create(SReadOnlyProperty);
@@ -1260,7 +1331,12 @@ begin
       SetUnicodeStrProp(Instance,PropInfo,ReadUnicodeString);
     tkWString:
       SetWideStrProp(Instance,PropInfo,ReadWideString);
-    {!!!: tkVariant}
+    tkVariant:
+      begin
+        { can't use variant() typecast, pulls in variant unit }
+        VarTemp:=ReadVariant;
+        SetVariantProp(Instance,PropInfo,PVariant(@VarTemp)^);
+      end;
     tkClass:
       case FDriver.NextValue of
         vaNil:
@@ -1400,9 +1476,9 @@ begin
   StringType := FDriver.ReadValue;
   if StringType in [vaString, vaLString,vaUTF8String] then
     begin
-    Result := FDriver.ReadString(StringType);
-    if (StringType=vaUTF8String) then
-      Result:=utf8Decode(Result);
+      Result := FDriver.ReadString(StringType);
+      if (StringType=vaUTF8String) then
+        Result:=utf8Decode(Result);
     end
   else if StringType in [vaWString] then
     Result:= FDriver.ReadWidestring

rtl/objpas/classes/writer.inc

@@ -720,6 +720,75 @@ begin
   Driver.WriteInteger(Value);
 end;
 
+procedure TWriter.WriteVariant(const VarValue: tvardata);
+type
+  tcurrec = record
+    i: int64;
+  end;
+var
+  vtype: tvartype;
+begin
+  vtype:=VarValue.vtype;
+  Write(ord(vtype),sizeof(vtype));
+  case vtype of
+    varEmpty,
+    varNull:
+      ;
+    { all integer sizes must be split for big endian systems }
+    varShortInt:
+      begin
+        WriteInteger(VarValue.vshortint);
+      end;
+    varSmallInt:
+      begin
+        WriteInteger(VarValue.vsmallint);
+      end;
+    varInteger:
+      begin
+        WriteInteger(VarValue.vinteger);
+      end;
+    varInt64,varQWord:
+      begin
+        WriteInteger(int64(VarValue.vint64));
+      end;
+    varBoolean:
+      begin
+        WriteBoolean(VarValue.vboolean);
+      end;
+    varCurrency:
+      begin
+        { write as int64, because on non-x86 a floating point register does
+          not have enough precision to hold the entire range of currency
+        }
+        WriteInteger(tcurrec(VarValue.vcurrency).i);
+      end;
+{$ifndef fpunone}
+    varSingle:
+      begin
+        WriteSingle(VarValue.vsingle);
+      end;
+    varDouble:
+      begin
+        WriteFloat(VarValue.vdouble);
+      end;
+    varDate:
+      begin
+        WriteFloat(VarValue.vdate);
+      end;
+{$endif fpunone}
+    varOleStr:
+      begin
+        WriteWideString(widestring(pointer(VarValue.volestr)));
+      end;
+    varString:
+      begin
+        WriteWideString(AnsiString(VarValue.vstring));
+      end;
+    else
+      raise EWriteError.CreateFmt(SUnsupportedPropertyVariantType, [Ord(VarValue.vtype)]);
+  end;
+end;
+
 procedure TWriter.WriteListBegin;
 begin
   Driver.BeginList;
@@ -746,6 +815,7 @@ begin
   Instance.DefineProperties(Self);
 end;
 
+
 procedure TWriter.WriteProperty(Instance: TPersistent; PropInfo: Pointer);
 var
   HasAncestor: Boolean;
@@ -767,6 +837,7 @@ var
   SavedAncestor: TPersistent;
   SavedPropPath, Name: String;
   Int64Value, DefInt64Value: Int64;
+  VarValue, DefVarValue : tvardata;
   BoolValue, DefBoolValue: boolean;
   Handled: Boolean;
 
@@ -918,7 +989,24 @@ begin
           Driver.EndProperty;
         end;
       end;
-  {!!!: tkVariant:}
+    tkVariant:
+      begin
+        if not assigned(VarClearProc) then
+          raise EWriteError.Create(SErrNoVariantSupport);
+
+        VarValue := tvardata(GetVariantProp(Instance, PropInfo));
+        if HasAncestor then
+          DefVarValue := tvardata(GetVariantProp(Ancestor, PropInfo))
+        else
+          VarClearProc(DefVarValue);
+
+        if (CompareByte(VarValue,DefVarValue,sizeof(VarValue)) <> 0) then
+          begin
+            Driver.BeginProperty(FPropPath + PPropInfo(PropInfo)^.Name);
+            WriteVariant(VarValue);
+            Driver.EndProperty;
+          end;
+      end;
     tkClass:
       begin
         ObjValue := TObject(GetObjectProp(Instance, PropInfo));

tests/webtbs/tw10482.pp

@@ -0,0 +1,100 @@
+program fpctest4;
+{$ifdef fpc}
+{$mode delphi}
+{$endif fpc}
+uses
+{$ifdef unix}
+  cwstring,
+{$endif}
+  Classes,sysutils,variants,typinfo;
+
+type
+   TTestClass=class(TComponent)
+   private
+     fV1,fV2,fV3:variant;
+     procedure SetV2(const v:variant);
+   published
+     property V1:Variant read fV1 write fV1;
+     property V2:Variant read fV2 write SetV2;
+     property V3:Variant read fV3 write fV3;
+   end;
+	
+const
+   {$ifdef fpc}
+   ws:WideString=#$43f#$440#$438#$432#$435#$442', '#$43f#$440#$44B#$432#$456#$442#$430#$43d#$44c#$43d#$435' - pr'#$fc'fung spa'#$df' gut';
+   {$else}
+   ws:WideString='ÔË‚ÂÚ, Ô˚‚≥ڇ̸Ì - prufung spa'#$df' gut';
+   {$endif}
+
+procedure TTestClass.SetV2(const v:variant);
+begin
+  fV2:=v;
+  writeln('Set V2');
+end;
+
+var tc:TTestClass;
+    f:TStream;
+    vv:variant;
+    ff : TFileStream;
+begin
+
+   RegisterClasses([TTestClass]);
+
+
+   tc:=TTestClass.Create(nil);
+   tc.v1:=123.45;
+   tc.v2:='Hello world';
+   tc.v3:=ws;
+
+   vv:=GetVariantProp(tc,'V2');
+   if vv<>Null then
+     begin
+       if (vv<>'Hello world') then
+         halt(1);
+       writeln('got=',vv);
+     end
+   else
+     halt(2);
+
+
+   SetVariantProp(tc,'V1',333.333);
+
+   vv:=GetVariantProp(tc,'V1');
+   if vv<>Null then
+     begin
+       if (vv<>333.333) then
+         halt(3);
+       writeln('got=',vv);
+     end
+   else
+     halt(4);
+
+   f:=TMemoryStream.Create;
+   f.WriteComponent(tc); // store it
+
+   ff:=TFileStream.Create('tw19482.str',fmCreate);
+   ff.WriteComponent(tc); // store it
+   ff.Free;
+
+   tc.Free; // kill it
+
+   f.free;
+
+   f:=TFileStream.Create('tw19482.str',fmOpenRead);
+
+   tc:=TTestClass(f.ReadComponent(nil));
+
+   writeln('v1=',tc.v1);
+   writeln('v2=',tc.v2);
+   writeln('v3=',tc.v3);
+   if (tc.v1<>333.333) then
+     halt(5);
+   if (tc.v2<>'Hello world') then
+     halt(6);
+   if (tc.v3<>ws) then
+     halt(7);
+
+   f.Free;
+
+   DeleteFile('tw19482.str')
+end.