Hi,
Below is a program showing that the varSingle is not handled correctly.
It actually get assigned varDouble. The program below tests a whole
bunch of other variant types as well.
-----------------------------------------------------
program Project1;
{$mode objfpc}{$H+}
uses
Classes, SysUtils, Variants;
function IsVariantOfType( pVariant : Variant ; pVarType : TVarType ) :
boolean ;
var
xVT : TVarType;
xVTHigh : TVarType;
// xVTLow : 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);
// xVTLow:=xVT and varTypeMask;
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
lSmallInt := 123;
lInteger := High(Integer);
lDouble := 123.45678901234567890;
lDateTimeNow := Now;
lDateTimeDate := Date;
lOleString := 'OLE STRING TEST';
lString := 'STRING TEST';
lBoolean := true;
lCurrency := 12345678.9876;
lVar := Unassigned;
_tiIsVariantOfType(lVar,varEmpty,'Failed with varEmpty');
lVar := Null ;
_tiIsVariantOfType(lVar,varNull,'Failed with varNull');
// There is no other way to receive variant of type small int...
lVar:=VarAsType(lSmallInt,varSmallint);
_tiIsVariantOfType(lVar,varSmallInt,'Failed with VarSmallint');
lVar:=lInteger;
_tiIsVariantOfType(lVar,varInteger,'Failed with Integer');
// 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');
lVar:=lDateTimeDate;
_tiIsVariantOfType(lVar,varDate,'Failed with varDate - DATE');
lVar:=lDateTimeNow;
_tiIsVariantOfType(lVar,varDate,'Failed with varDate - NOW');
lVar:=lBoolean;
_tiIsVariantOfType(lVar,varBoolean,'Failed with varBoolean');
lVar:=lOleString;
_tiIsVariantOfType(lVar,varOLEStr,'Failed with varOLEStr');
lVar := lString;
_tiIsVariantOfType(lVar, varString, 'Failed with varString');
lVar:=lCurrency;
_tiIsVariantOfType(lVar,varCurrency,'Failed with varCurrency');
// These ones have not been tested
// varCurrency Currency floating-point value (type Currency).
// varDispatch Reference to an Automation object (an IDispatch interface
pointer).
// varError Operating system error code.
// varUnknown Reference to an unknown COM object (an IUnknown interface
pointer).
// varByte 8-bit unsigned integer (type Byte).
// varTypeMask Bit mask for extracting type code.
// varArray Bit indicating variant array.
// varByRef Bit indicating variant contains a reference (rather than a
value).
end;
begin
TestIsVariantOfType;
end.
-----------------------------------------------------
Regards,
- Graeme -
_______________________________________________
fpc-devel maillist - [email protected]
http://lists.freepascal.org/mailman/listinfo/fpc-devel
