* fixed VarAsType with varSingle, fixes bg 4634

git-svn-id: trunk@2159 -

.gitattributes

@@ -6664,6 +6664,7 @@ tests/webtbs/tw4613.pp -text svneol=unset#text/plain
 tests/webtbs/tw4616.pp svneol=native#text/plain
 tests/webtbs/tw4632.pp svneol=native#text/plain
 tests/webtbs/tw4633.pp svneol=native#text/plain
+tests/webtbs/tw4634.pp -text
 tests/webtbs/tw4635.pp svneol=native#text/plain
 tests/webtbs/tw4640.pp svneol=native#text/plain
 tests/webtbs/ub1873.pp svneol=native#text/plain

tests/webtbs/tw4634.pp

@@ -0,0 +1,89 @@
+{ Source provided for Free Pascal Bug Report 4634 }
+{ Submitted by "Graeme Geldenhuys" on  2005-12-23 }
+{ e-mail: [email protected] }
+program Project1;
+{$ifdef fpc}
+{$mode objfpc}
+{$endif fpc}
+{$H+}
+uses
+  Classes, SysUtils, Variants;
+
+function IsVariantOfType( pVariant : Variant ; pVarType : TVarType ) : boolean ;
+var
+  xVT : TVarType;
+  xVTHigh : TVarType;
+begin
+//  result := ( varType( pVariant ) and pVarType ) = pVarType ;
+// Contr: VarType is varDate = 0007, pVarType is varInteger=0003.
+// 0007 and 0003 = 0003. WRONG!
+
+  xVT := VarType(pVariant);
+  xVTHigh := xVT and (not varTypeMask);
+
+{  in true pVarType can be and OR of two types: varArray and varString (or others)
+   we have to recognize it.
+   there shouldn't be xVTLow because when we have array of string (normal) then
+   xVT=$2008 = $2000 (var Array) or $0008 (var String)
+   then when we asked:
+     is $2000 (varArray)? we should receive TRUE (xVTHigh=pVarType)
+     is $2008 (varArray of varString)? we should receive TRUE (xVT=pVarType)
+     is $0008 (varString)? we should receive FALSE
+}
+  Result := (xVT=pVarType) or ((xVTHigh=pVarType) and (xVTHigh<>varEmpty));
+end ;
+
+procedure TestIsVariantOfType ;
+
+  procedure _tiIsVariantOfType(xVar : variant; xExpected : TVarType; xMsg : string);
+
+    procedure __tiIsVariantOfType(xxCheck : TVarType; xxMsg : string);
+    begin
+      if xxCheck=xExpected then
+      begin
+        If not IsVariantOfType( xVar, xxCheck ) then
+          Writeln(xMsg);
+      end
+      else
+      begin
+        If IsVariantOfType( xVar, xxCheck ) then
+          Writeln(xMsg + ' - ' + xxMsg);
+      end;
+    end;
+
+  begin
+    __tiIsVariantOfType(varEmpty,'varEmpty');
+    __tiIsVariantOfType(varNull,'varNull');
+    __tiIsVariantOfType(varSmallint,'varSmallInt');
+    __tiIsVariantOfType(varInteger,'varInteger');
+    __tiIsVariantOfType(varSingle,'varSingle');
+    __tiIsVariantOfType(varDouble,'varDouble');
+    __tiIsVariantOfType(varDate,'varDate');
+    __tiIsVariantOfType(varBoolean,'varBoolean');
+    __tiIsVariantOfType(varOleStr,'varOleStr');
+  end;
+var
+  lVar : Variant ;
+  lSmallInt : Smallint;
+  lInteger : Integer;
+  lDouble : Double;
+  lDateTimeNow : TDateTime;
+  lDateTimeDate : TDateTime;
+  lOleString : WideString;
+  lString : string;
+  lBoolean : boolean;
+  lCurrency : Currency;
+begin
+  lDouble := 123.45678901234567890;
+
+// Can't make this one work
+  lVar:=VarAsType(123.456,varSingle);
+  _tiIsVariantOfType(lVar,varSingle,'Failed with VarSingle');
+
+  lVar:=lDouble;
+  _tiIsVariantOfType(lVar,varDouble,'Failed with VarDouble');
+end;
+
+begin
+  TestIsVariantOfType;
+end.