* removed duplicate EVariant class from varutils and incorporated

    its implementation details in the EVariant class of sysutils
  + added conversions of variant error codes to exception messages
   (together these fix tw4704)

git-svn-id: trunk@3026 -

.gitattributes

@@ -3861,6 +3861,7 @@ rtl/inc/threadh.inc svneol=native#text/plain
 rtl/inc/threadvr.inc svneol=native#text/plain
 rtl/inc/typefile.inc svneol=native#text/plain
 rtl/inc/ucomplex.pp svneol=native#text/plain
+rtl/inc/varerror.inc -text
 rtl/inc/variant.inc svneol=native#text/plain
 rtl/inc/varianth.inc svneol=native#text/plain
 rtl/inc/variants.pp svneol=native#text/plain
@@ -6750,6 +6751,7 @@ tests/webtbs/tw4640.pp svneol=native#text/plain
 tests/webtbs/tw4669.pp svneol=native#text/plain
 tests/webtbs/tw4675.pp svneol=native#text/plain
 tests/webtbs/tw4700.pp svneol=native#text/plain
+tests/webtbs/tw4707.pp -text
 tests/webtbs/tw4763.pp svneol=native#text/plain
 tests/webtbs/tw4768.pp -text
 tests/webtbs/tw4778.pp svneol=native#text/plain

rtl/inc/varerror.inc

@@ -0,0 +1,33 @@
+{
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2006 by the Free Pascal development team
+
+    This include file contains the implementation for variants
+    support in FPC as far as it is part of the system unit
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+
+ **********************************************************************}
+
+// Names match the ones in Borland varutils unit.
+
+const
+  VAR_OK            = HRESULT($00000000);
+  VAR_PARAMNOTFOUND = HRESULT($80020004);
+  VAR_TYPEMISMATCH  = HRESULT($80020005);
+  VAR_BADVARTYPE    = HRESULT($80020008);
+  VAR_EXCEPTION     = HRESULT($80020009);
+  VAR_OVERFLOW      = HRESULT($8002000A);
+  VAR_BADINDEX      = HRESULT($8002000B);
+  VAR_ARRAYISLOCKED = HRESULT($8002000D);
+  VAR_NOTIMPL       = HRESULT($80004001);
+  VAR_OUTOFMEMORY   = HRESULT($8007000E);
+  VAR_INVALIDARG    = HRESULT($80070057);
+  VAR_UNEXPECTED    = HRESULT($8000FFFF);
+

rtl/objpas/cvarutil.inc

@@ -30,12 +30,6 @@ begin
   Raise Exception.Create(SNoInterfaces);
 end;
 
-Constructor EVariantError.CreateCode (Code : longint);
-
-begin
-  ErrCode:=Code;
-end;
-
 Procedure VariantTypeMismatch;
 
 begin

rtl/objpas/sysutils/sysutilh.inc

@@ -118,7 +118,10 @@ type
    EInvalidPointer  = Class(EHeapMemoryError);
    EOutOfMemory     = Class(EHeapMemoryError);
    EInvalidCast = Class(Exception);
-   EVariantError = Class(Exception);
+   EVariantError = Class(Exception)
+     ErrCode : longint;
+     Constructor CreateCode(Code : Longint);
+   end;
 
    EAccessViolation = Class(EExternal);
    EBusError = Class(EAccessViolation);

rtl/objpas/sysutils/sysutils.inc

@@ -15,6 +15,9 @@
   { Read filename handling functions implementation }
   {$i fina.inc}
 
+  { variant error codes }
+  {$i varerror.inc}
+
     Function FileSearch (Const Name, DirList : String) : String;
     Var
       I : longint;
@@ -189,6 +192,39 @@
     end;
 
 
+    Constructor EVariantError.CreateCode (Code : longint);
+    begin
+       case Code of
+         VAR_OK:
+           Create(SNoError);
+         VAR_PARAMNOTFOUND:
+           Create(SVarParamNotFound);
+         VAR_TYPEMISMATCH:
+           Create(SInvalidVarCast);
+         VAR_BADVARTYPE:
+           Create(SVarBadType);
+         VAR_OVERFLOW:
+           Create(SVarOverflow);
+         VAR_BADINDEX:
+           Create(SVarArrayBounds);
+         VAR_ARRAYISLOCKED:
+           Create(SVarArrayLocked);
+         VAR_NOTIMPL:
+           Create(SVarNotImplemented);
+         VAR_OUTOFMEMORY:
+           Create(SVarOutOfMemory);
+         VAR_INVALIDARG:
+           Create(SVarInvalid);
+         VAR_UNEXPECTED,
+         VAR_EXCEPTION:
+           Create(SVarUnexpected);
+         else
+           CreateFmt(SUnknownErrorCode,[Code]);
+       end;
+       ErrCode:=Code;
+    end;
+
+
 {$ifopt S+}
 {$define STACKCHECK_WAS_ON}
 {$S-}

rtl/objpas/varutilh.inc

@@ -16,12 +16,6 @@
  **********************************************************************}
 
 
-Type
-  EVarianterror = Class(Exception)
-    ErrCode : longint;
-    Constructor CreateCode(Code : Longint);
-  end;
-
 { Variant functions }
 function VariantChangeTypeEx(var VargDest: TVarData; const VargSrc: TVarData; LCID: Integer; Flags: Word; VarType: Word): HRESULT; stdcall;
 function VariantClear(var Varg: TVarData): HRESULT; stdcall;
@@ -75,22 +69,9 @@ Procedure DumpVariant(Const VArgSrc : TVarData);
 Procedure DumpVariant(Var F : Text; Const VArgSrc : TVarData);
 
 
+{$i varerror.inc}
 // Names match the ones in Borland varutils unit.
-
 const
-  VAR_OK            = HRESULT($00000000);
-  VAR_PARAMNOTFOUND = HRESULT($80020004);
-  VAR_TYPEMISMATCH  = HRESULT($80020005);
-  VAR_BADVARTYPE    = HRESULT($80020008);
-  VAR_EXCEPTION     = HRESULT($80020009);
-  VAR_OVERFLOW      = HRESULT($8002000A);
-  VAR_BADINDEX      = HRESULT($8002000B);
-  VAR_ARRAYISLOCKED = HRESULT($8002000D);
-  VAR_NOTIMPL       = HRESULT($80004001);
-  VAR_OUTOFMEMORY   = HRESULT($8007000E);
-  VAR_INVALIDARG    = HRESULT($80070057);
-  VAR_UNEXPECTED    = HRESULT($8000FFFF);
-
   ARR_NONE          = $0000;
   ARR_FIXEDSIZE     = $0010;
   ARR_OLESTR        = $0100;

tests/webtbs/tw4707.pp

@@ -0,0 +1,43 @@
+{ %OPT=-S2 }
+{ Source provided for Free Pascal Bug Report 4704 }
+{ Submitted by "Phil H." on  2006-01-17 }
+{ e-mail: [email protected] }
+program TestExcep;
+
+uses
+  SysUtils,
+  Variants;
+
+var
+  AnInt : Integer;
+  AVar  : Variant;
+  
+begin
+  AVar := Null;
+  try
+    AnInt := AVar;
+    halt(1);
+    case AnInt of
+      1 : ;
+      end;
+    
+  except 
+    on E: EVariantError do
+      begin
+      WriteLn('Handled EVariantError');
+      WriteLn(E.ClassName);
+      WriteLn(E.Message);
+      if (E.Message = '') then
+        halt(3);
+      end;
+    on E: Exception do
+      begin
+      WriteLn('Handled Exception');
+      WriteLn(E.ClassName);
+      WriteLn(E.Message);
+      halt(2);
+      end;
+    end;
+  
+end.
+