* 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: trunk@48477 -

.gitattributes

@@ -18656,6 +18656,7 @@ tests/webtbs/tw3840.pp svneol=native#text/plain
 tests/webtbs/tw3841.pp svneol=native#text/plain
 tests/webtbs/tw38412.pp svneol=native#text/pascal
 tests/webtbs/tw38413.pp svneol=native#text/pascal
+tests/webtbs/tw38429.pp svneol=native#text/pascal
 tests/webtbs/tw3863.pp svneol=native#text/plain
 tests/webtbs/tw3864.pp svneol=native#text/plain
 tests/webtbs/tw3865.pp svneol=native#text/plain
@@ -19193,6 +19194,7 @@ tests/webtbs/uw38069.pp svneol=native#text/pascal
 tests/webtbs/uw38385a.pp svneol=native#text/pascal
 tests/webtbs/uw38385b.pp svneol=native#text/pascal
 tests/webtbs/uw38385c.pp svneol=native#text/pascal
+tests/webtbs/uw38429.pp svneol=native#text/pascal
 tests/webtbs/uw3968.pp svneol=native#text/plain
 tests/webtbs/uw4056.pp svneol=native#text/plain
 tests/webtbs/uw4140.pp svneol=native#text/plain

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);

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.
+

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.
+