Merged revision(s) 48477 from trunk:

* fix for Mantis #38249: apply adjusted patch by avk to implemnt CastTo handling when the source variant is a custom variant, but the destination type is not
+ added test (includes test for #20849)
........


git-svn-id: https://svn.freepascal.org/svn/fpc/branches/fixes_3_2@48494 3ad0048d-3df7-0310-abae-a5850022a9f2

3 files changed, 153 insertions, 0 deletions

diff --git a/packages/rtl-objpas/src/inc/variants.pp b/packages/rtl-objpas/src/inc/variants.pp
index 4682f3bfae..7e306f6aca 100644
--- a/packages/rtl-objpas/src/inc/variants.pp
+++ b/packages/rtl-objpas/src/inc/variants.pp
@@ -2351,10 +2351,14 @@ begin
 end;
 
 procedure DoVarCast(var aDest : TVarData; const aSource : TVarData; aVarType : LongInt);
+var
+  Handler: TCustomVariantType;
 begin
   with aSource do
     if vType = aVarType then
       DoVarCopy(aDest, aSource)
+    else if FindCustomVariantType(vType, Handler) then
+      Handler.CastTo(aDest, aSource, aVarType)
     else begin
       if (vType = varNull) and NullStrictConvert then
         VarCastError(varNull, aVarType);
diff --git a/tests/webtbs/tw38429.pp b/tests/webtbs/tw38429.pp
new file mode 100644
index 0000000000..87e9c9913e
--- /dev/null
+++ b/tests/webtbs/tw38429.pp
@@ -0,0 +1,61 @@
+program tw38429;
+
+{$mode objfpc}{$h+}
+
+uses
+  SysUtils, Variants, uw38429;
+
+var
+  v, d: Variant;
+  I: Integer = 42;
+begin
+  Writeln('Test VarAsType');
+  d := I;
+  try
+    v := VarAsType(d, varMyVar);
+  except
+    on e: exception do begin
+      WriteLn('cast ', VarTypeAsText(VarType(d)), ' to ',VarTypeAsText(varMyVar),
+              ' raises ', e.ClassName, ' with message: ', e.Message);
+      Halt(1);
+    end;
+  end;
+  WriteLn('now v is ', VarTypeAsText(VarType(v)));
+  VarClear(d);
+  try
+    d := VarAsType(v, varInteger);
+  except
+    on e: exception do begin
+      WriteLn('cast ', VarTypeAsText(VarType(v)), ' to ',VarTypeAsText(varInteger),
+              ' raises ', e.ClassName, ' with message: ', e.Message);
+      Halt(2);
+    end;
+  end;
+  WriteLn('now d is ', VarTypeAsText(VarType(d)));
+
+  { also test VarCast from #20849 }
+  Writeln('Test VarCast');
+  d := I;
+  try
+    VarCast(v, d, varMyVar);
+  except
+    on e: exception do begin
+      WriteLn('cast ', VarTypeAsText(VarType(d)), ' to ',VarTypeAsText(varMyVar),
+              ' raises ', e.ClassName, ' with message: ', e.Message);
+      Halt(3);
+    end;
+  end;
+  WriteLn('now v is ', VarTypeAsText(VarType(v)));
+  VarClear(d);
+  try
+    VarCast(d, v, varInteger);
+  except
+    on e: exception do begin
+      WriteLn('cast ', VarTypeAsText(VarType(v)), ' to ',VarTypeAsText(varInteger),
+              ' raises ', e.ClassName, ' with message: ', e.Message);
+      Halt(4);
+    end;
+  end;
+  WriteLn('now d is ', VarTypeAsText(VarType(d)));
+end.
+
diff --git a/tests/webtbs/uw38429.pp b/tests/webtbs/uw38429.pp
new file mode 100644
index 0000000000..f59f91c329
--- /dev/null
+++ b/tests/webtbs/uw38429.pp
@@ -0,0 +1,88 @@
+unit uw38429;
+
+{$mode objfpc}{$H+}
+{$modeswitch advancedrecords}
+
+interface
+
+uses
+  SysUtils, Variants;
+
+type
+  TMyVar = packed record
+    VType: TVarType;
+    Dummy1: array[0..Pred(SizeOf(Pointer) - 2)] of Byte;
+    Dummy2,
+    Dummy3: Pointer;
+    procedure Init;
+  end;
+
+  { TMyVariant }
+
+  TMyVariant = class(TInvokeableVariantType)
+    procedure Copy(var Dest: TVarData; const Source: TVarData; const Indirect: Boolean); override;
+    procedure Clear(var V: TVarData); override;
+    procedure Cast(var Dest: TVarData; const Source: TVarData); override;
+    procedure CastTo(var Dest: TVarData; const Source: TVarData; const aVarType: TVarType); override;
+  end;
+
+  function MyVarCreate: Variant;
+
+  function varMyVar: TVarType;
+
+implementation
+
+var
+  MyVariant: TMyVariant;
+
+function MyVarCreate: Variant;
+begin
+  VarClear(Result);
+  TMyVar(Result).Init;
+end;
+
+function VarMyVar: TVarType;
+begin
+  Result := MyVariant.VarType;
+end;
+
+{ TMyVar }
+
+procedure TMyVar.Init;
+begin
+  VType := VarMyVar;
+end;
+
+{ TMyVariant }
+
+procedure TMyVariant.Copy(var Dest: TVarData; const Source: TVarData;
+  const Indirect: Boolean);
+begin
+  Dest := Source;
+end;
+
+procedure TMyVariant.Clear(var V: TVarData);
+begin
+  TMyVar(v).VType := varEmpty;
+end;
+
+procedure TMyVariant.Cast(var Dest: TVarData; const Source: TVarData);
+begin
+  WriteLn('TMyVariant.Cast');
+  VarClear(Variant(Dest));
+  TMyVar(Dest).Init;
+end;
+
+procedure TMyVariant.CastTo(var Dest: TVarData; const Source: TVarData; const aVarType: TVarType);
+begin
+  WriteLn('TMyVariant.CastTo');
+  VarClear(Variant(Dest));
+  TVarData(Dest).VType := aVarType;
+end;
+
+initialization
+  MyVariant := TMyVariant.Create;
+finalization
+  MyVariant.Free;
+end.
+