mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-10-31 07:31:49 +01:00
1604 lines
55 KiB
PHP
1604 lines
55 KiB
PHP
{
|
|
This file is part of the Free Pascal run time library.
|
|
Copyright (c) 2000,2001 by the Free Pascal development team
|
|
|
|
Interface and OS-dependent part of variant support
|
|
|
|
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.
|
|
|
|
**********************************************************************}
|
|
|
|
Procedure VariantTypeMismatch; overload;
|
|
begin
|
|
Raise EVariantError.CreateCode(VAR_TYPEMISMATCH);
|
|
end;
|
|
|
|
Procedure VariantTypeMismatch(const SourceType, DestType: TVarType);
|
|
begin
|
|
{ ignore the types for now ... }
|
|
Raise EVariantError.CreateCode(VAR_TYPEMISMATCH);
|
|
end;
|
|
|
|
|
|
Function ExceptionToVariantError (E : Exception): HResult;
|
|
|
|
begin
|
|
If E is EoutOfMemory then
|
|
Result:=VAR_OUTOFMEMORY
|
|
else
|
|
Result:=VAR_EXCEPTION;
|
|
end;
|
|
|
|
{ ---------------------------------------------------------------------
|
|
OS-independent functions not present in Windows
|
|
---------------------------------------------------------------------}
|
|
|
|
{--- SmallInt ---}
|
|
|
|
Function WStrToSmallInt(p: Pointer) : SmallInt;
|
|
var
|
|
Error : Word;
|
|
begin
|
|
Val(WideString(p), Result, Error);
|
|
if Error <> 0 then
|
|
VariantTypeMismatch(varOleStr, varSmallInt);
|
|
end;
|
|
|
|
Function LStrToSmallInt(p: Pointer) : SmallInt;
|
|
var
|
|
Error : Word;
|
|
begin
|
|
Val(AnsiString(p), Result, Error);
|
|
if Error <> 0 then
|
|
VariantTypeMismatch(varString, varSmallInt);
|
|
end;
|
|
|
|
function UStrToSmallInt(p: Pointer): SmallInt;
|
|
var
|
|
Error: Word;
|
|
begin
|
|
Val(UnicodeString(p), Result, Error);
|
|
if Error <> 0 then
|
|
VariantTypeMismatch(varUString, varSmallInt);
|
|
end;
|
|
|
|
Function VariantToSmallInt(const VargSrc : TVarData) : SmallInt;
|
|
begin
|
|
{$IFDEF DEBUG_VARUTILS} if __DEBUG_VARUTILS then begin
|
|
DumpVariant('VariantToSmallInt', VargSrc);
|
|
end; {$ENDIF}
|
|
|
|
with VargSrc do
|
|
case vType and not varTypeMask of
|
|
0: case vType of
|
|
varEmpty : Result := 0;
|
|
varSmallInt : Result := vSmallInt;
|
|
varShortInt : Result := vShortInt;
|
|
varInteger : Result := smallint(vInteger);
|
|
{$ifndef FPUNONE}
|
|
varSingle : Result := smallint(Round(vSingle));
|
|
varDouble : Result := smallint(Round(vDouble));
|
|
varDate : Result := smallint(Round(vDate));
|
|
{$endif}
|
|
varCurrency : Result := smallint(Round(vCurrency));
|
|
varBoolean : Result := smallint(SmallInt(vBoolean));
|
|
varVariant : Result := VariantToSmallInt(PVarData(vPointer)^);
|
|
varByte : Result := vByte;
|
|
varWord : Result := smallint(vWord);
|
|
varLongWord : Result := smallint(vLongWord);
|
|
varInt64 : Result := smallint(vInt64);
|
|
varQword : Result := smallint(vQWord);
|
|
varOleStr : Result := WStrToSmallInt(vOleStr);
|
|
varString : Result := LStrToSmallInt(vString);
|
|
varUString : Result := UStrToSmallInt(vString);
|
|
else
|
|
VariantTypeMismatch(vType, varSmallInt);
|
|
end;
|
|
varByRef: if Assigned(vPointer) then case vType and varTypeMask of
|
|
varSmallInt : Result := PSmallInt(vPointer)^;
|
|
varShortInt : Result := PShortInt(vPointer)^;
|
|
varInteger : Result := smallint(PInteger(vPointer)^);
|
|
{$ifndef FPUNONE}
|
|
varSingle : Result := smallint(Round(PSingle(vPointer)^));
|
|
varDouble : Result := smallint(Round(PDouble(vPointer)^));
|
|
varDate : Result := smallint(Round(PDate(vPointer)^));
|
|
{$endif}
|
|
varCurrency : Result := smallint(Round(PCurrency(vPointer)^));
|
|
varBoolean : Result := SmallInt(PWordBool(vPointer)^);
|
|
varVariant : Result := VariantToSmallInt(PVarData(vPointer)^);
|
|
varByte : Result := PByte(vPointer)^;
|
|
varWord : Result := smallint(PWord(vPointer)^);
|
|
varLongWord : Result := smallint(PLongWord(vPointer)^);
|
|
varInt64 : Result := smallint(PInt64(vPointer)^);
|
|
varQword : Result := smallint(PQWord(vPointer)^);
|
|
varOleStr : Result := WStrToSmallInt(PPointer(vPointer)^);
|
|
varString : Result := LStrToSmallInt(PPointer(vPointer)^);
|
|
varUString : Result := UStrToSmallInt(PPointer(vPointer)^);
|
|
else { other vtype }
|
|
VariantTypeMismatch(vType, varSmallInt);
|
|
end else { pointer is nil }
|
|
VariantTypeMismatch(vType, varSmallInt);
|
|
else { array or something like that }
|
|
VariantTypeMismatch(vType, varSmallInt);
|
|
end;
|
|
|
|
{$IFDEF DEBUG_VARUTILS} if __DEBUG_VARUTILS then begin
|
|
WriteLn('VariantToSmallInt -> ', Result);
|
|
end; {$ENDIF}
|
|
end;
|
|
|
|
{--- ShortInt ---}
|
|
|
|
Function WStrToShortInt(p: Pointer) : ShortInt;
|
|
var
|
|
Error : Word;
|
|
begin
|
|
Val(WideString(p), Result, Error);
|
|
if Error <> 0 then
|
|
VariantTypeMismatch(varOleStr, varShortInt);
|
|
end;
|
|
|
|
Function LStrToShortInt(p: Pointer) : ShortInt;
|
|
var
|
|
Error : Word;
|
|
begin
|
|
Val(AnsiString(p), Result, Error);
|
|
if Error <> 0 then
|
|
VariantTypeMismatch(varString, varShortInt);
|
|
end;
|
|
|
|
Function UStrToShortInt(p: Pointer) : ShortInt;
|
|
var
|
|
Error : Word;
|
|
begin
|
|
Val(UnicodeString(p), Result, Error);
|
|
if Error <> 0 then
|
|
VariantTypeMismatch(varUString, varShortInt);
|
|
end;
|
|
|
|
Function VariantToShortInt(const VargSrc : TVarData) : ShortInt;
|
|
begin
|
|
{$IFDEF DEBUG_VARUTILS} if __DEBUG_VARUTILS then begin
|
|
DumpVariant('VariantToShortInt', VargSrc);
|
|
end; {$ENDIF}
|
|
|
|
with VargSrc do
|
|
case vType and not varTypeMask of
|
|
0: case vType of
|
|
varEmpty : Result := 0;
|
|
varSmallInt : Result := shortint(vSmallInt);
|
|
varShortInt : Result := vShortInt;
|
|
varInteger : Result := shortint(vInteger);
|
|
{$ifndef FPUNONE}
|
|
varSingle : Result := shortint(Round(vSingle));
|
|
varDouble : Result := shortint(Round(vDouble));
|
|
varDate : Result := shortint(Round(vDate));
|
|
{$endif}
|
|
varCurrency : Result := shortint(Round(vCurrency));
|
|
varBoolean : Result := shortint(vBoolean);
|
|
varVariant : Result := VariantToShortInt(PVarData(vPointer)^);
|
|
varByte : Result := shortint(vByte);
|
|
varWord : Result := shortint(vWord);
|
|
varLongWord : Result := shortint(vLongWord);
|
|
varInt64 : Result := shortint(vInt64);
|
|
varQword : Result := shortint(vQWord);
|
|
varOleStr : Result := WStrToShortInt(vOleStr);
|
|
varString : Result := LStrToShortInt(vString);
|
|
varUString : Result := UStrToShortInt(vString);
|
|
else
|
|
VariantTypeMismatch(vType, varShortInt);
|
|
end;
|
|
varByRef: if Assigned(vPointer) then case vType and varTypeMask of
|
|
varSmallInt : Result := shortint(PSmallInt(vPointer)^);
|
|
varShortInt : Result := PShortInt(vPointer)^;
|
|
varInteger : Result := shortint(PInteger(vPointer)^);
|
|
{$ifndef FPUNONE}
|
|
varSingle : Result := shortint(Round(PSingle(vPointer)^));
|
|
varDouble : Result := shortint(Round(PDouble(vPointer)^));
|
|
varDate : Result := shortint(Round(PDate(vPointer)^));
|
|
{$endif}
|
|
varCurrency : Result := shortint(Round(PCurrency(vPointer)^));
|
|
varBoolean : Result := SmallInt(PWordBool(vPointer)^);
|
|
varVariant : Result := VariantToShortInt(PVarData(vPointer)^);
|
|
varByte : Result := shortint(PByte(vPointer)^);
|
|
varWord : Result := shortint(PWord(vPointer)^);
|
|
varLongWord : Result := shortint(PLongWord(vPointer)^);
|
|
varInt64 : Result := shortint(PInt64(vPointer)^);
|
|
varQword : Result := shortint(PQWord(vPointer)^);
|
|
varOleStr : Result := WStrToShortInt(PPointer(vPointer)^);
|
|
varString : Result := LStrToShortInt(PPointer(vPointer)^);
|
|
varUString : Result := UStrToShortInt(PPointer(vPointer)^);
|
|
else { other vtype }
|
|
VariantTypeMismatch(vType, varShortInt);
|
|
end else { pointer is nil }
|
|
VariantTypeMismatch(vType, varShortInt);
|
|
else { array or something like that }
|
|
VariantTypeMismatch(vType, varShortInt);
|
|
end;
|
|
|
|
{$IFDEF DEBUG_VARUTILS} if __DEBUG_VARUTILS then begin
|
|
WriteLn('VariantToShortInt -> ', Result);
|
|
end; {$ENDIF}
|
|
end;
|
|
|
|
{--- LongInt ---}
|
|
|
|
Function WStrToLongInt(p: Pointer) : LongInt;
|
|
var
|
|
Error : Word;
|
|
begin
|
|
Val(WideString(p), Result, Error);
|
|
if Error <> 0 then
|
|
VariantTypeMismatch(varOleStr, varInteger);
|
|
end;
|
|
|
|
Function LStrToLongInt(p: Pointer) : LongInt;
|
|
var
|
|
Error : Word;
|
|
begin
|
|
Val(AnsiString(p), Result, Error);
|
|
if Error <> 0 then
|
|
VariantTypeMismatch(varString, varInteger);
|
|
end;
|
|
|
|
Function UStrToLongInt(p: Pointer) : LongInt;
|
|
var
|
|
Error : Word;
|
|
begin
|
|
Val(UnicodeString(p), Result, Error);
|
|
if Error <> 0 then
|
|
VariantTypeMismatch(varUString, varInteger);
|
|
end;
|
|
|
|
Function VariantToLongInt(const VargSrc : TVarData) : LongInt;
|
|
begin
|
|
{$IFDEF DEBUG_VARUTILS} if __DEBUG_VARUTILS then begin
|
|
DumpVariant('VariantToLongInt', VargSrc);
|
|
end; {$ENDIF}
|
|
|
|
with VargSrc do
|
|
case vType and not varTypeMask of
|
|
0: case vType of
|
|
varEmpty : Result := 0;
|
|
varSmallInt : Result := vSmallInt;
|
|
varShortInt : Result := vShortInt;
|
|
varInteger : Result := vInteger;
|
|
{$ifndef FPUNONE}
|
|
varSingle : Result := longint(Round(vSingle));
|
|
varDouble : Result := longint(Round(vDouble));
|
|
varDate : Result := longint(Round(vDate));
|
|
{$endif}
|
|
varCurrency : Result := longint(Round(vCurrency));
|
|
varBoolean : Result := SmallInt(vBoolean);
|
|
varVariant : Result := VariantToLongInt(PVarData(vPointer)^);
|
|
varByte : Result := vByte;
|
|
varWord : Result := vWord;
|
|
varLongWord : Result := longint(vLongWord);
|
|
varInt64 : Result := longint(vInt64);
|
|
varQword : Result := longint(vQWord);
|
|
varOleStr : Result := WStrToLongInt(vOleStr);
|
|
varString : Result := LStrToLongInt(vString);
|
|
varUString : Result := UStrToLongInt(vString);
|
|
else
|
|
VariantTypeMismatch(vType, varInteger);
|
|
end;
|
|
varByRef: if Assigned(vPointer) then case vType and varTypeMask of
|
|
varSmallInt : Result := PSmallInt(vPointer)^;
|
|
varShortInt : Result := PShortInt(vPointer)^;
|
|
varInteger : Result := PInteger(vPointer)^;
|
|
{$ifndef FPUNONE}
|
|
varSingle : Result := longint(Round(PSingle(vPointer)^));
|
|
varDouble : Result := longint(Round(PDouble(vPointer)^));
|
|
varDate : Result := longint(Round(PDate(vPointer)^));
|
|
{$endif}
|
|
varCurrency : Result := longint(Round(PCurrency(vPointer)^));
|
|
varBoolean : Result := SmallInt(PWordBool(vPointer)^);
|
|
varVariant : Result := VariantToLongInt(PVarData(vPointer)^);
|
|
varByte : Result := PByte(vPointer)^;
|
|
varWord : Result := PWord(vPointer)^;
|
|
varLongWord : Result := longint(PLongWord(vPointer)^);
|
|
varInt64 : Result := longint(PInt64(vPointer)^);
|
|
varQword : Result := longint(PQWord(vPointer)^);
|
|
varOleStr : Result := WStrToLongInt(PPointer(vPointer)^);
|
|
varString : Result := LStrToLongInt(PPointer(vPointer)^);
|
|
varUString : Result := UStrToLongInt(PPointer(vPointer)^);
|
|
else { other vtype }
|
|
VariantTypeMismatch(vType, varInteger);
|
|
end else { pointer is nil }
|
|
VariantTypeMismatch(vType, varInteger);
|
|
else { array or something like that }
|
|
VariantTypeMismatch(vType, varInteger);
|
|
end;
|
|
|
|
{$IFDEF DEBUG_VARUTILS} if __DEBUG_VARUTILS then begin
|
|
WriteLn('VariantToLongInt -> ', Result);
|
|
end; {$ENDIF}
|
|
end;
|
|
|
|
{--- Cardinal ---}
|
|
|
|
Function WStrToCardinal(p: Pointer) : Cardinal;
|
|
var
|
|
Error : Word;
|
|
begin
|
|
Val(WideString(p), Result, Error);
|
|
if Error <> 0 then
|
|
VariantTypeMismatch(varOleStr, varLongWord);
|
|
end;
|
|
|
|
Function LStrToCardinal(p: Pointer) : Cardinal;
|
|
var
|
|
Error : Word;
|
|
begin
|
|
Val(AnsiString(p), Result, Error);
|
|
if Error <> 0 then
|
|
VariantTypeMismatch(varString, varLongWord);
|
|
end;
|
|
|
|
Function UStrToCardinal(p: Pointer) : Cardinal;
|
|
var
|
|
Error : Word;
|
|
begin
|
|
Val(UnicodeString(p), Result, Error);
|
|
if Error <> 0 then
|
|
VariantTypeMismatch(varUString, varLongWord);
|
|
end;
|
|
|
|
Function VariantToCardinal(const VargSrc : TVarData) : Cardinal;
|
|
begin
|
|
{$IFDEF DEBUG_VARUTILS} if __DEBUG_VARUTILS then begin
|
|
DumpVariant('VariantToCardinal', VargSrc);
|
|
end; {$ENDIF}
|
|
|
|
with VargSrc do
|
|
case vType and not varTypeMask of
|
|
0: case vType of
|
|
varEmpty : Result := 0;
|
|
varSmallInt : Result := vSmallInt;
|
|
varShortInt : Result := vShortInt;
|
|
varInteger : Result := cardinal(vInteger);
|
|
{$ifndef FPUNONE}
|
|
varSingle : Result := cardinal(Round(vSingle));
|
|
varDouble : Result := cardinal(Round(vDouble));
|
|
varDate : Result := cardinal(Round(vDate));
|
|
{$endif}
|
|
varCurrency : Result := cardinal(Round(vCurrency));
|
|
varBoolean : Result := cardinal(SmallInt(vBoolean));
|
|
varVariant : Result := VariantToCardinal(PVarData(vPointer)^);
|
|
varByte : Result := vByte;
|
|
varWord : Result := vWord;
|
|
varLongWord : Result := vLongWord;
|
|
varInt64 : Result := cardinal(vInt64);
|
|
varQword : Result := cardinal(vQWord);
|
|
varOleStr : Result := WStrToCardinal(vOleStr);
|
|
varString : Result := LStrToCardinal(vString);
|
|
varUString : Result := UStrToCardinal(vString);
|
|
else
|
|
VariantTypeMismatch(vType, varLongWord);
|
|
end;
|
|
varByRef: if Assigned(vPointer) then case vType and varTypeMask of
|
|
varSmallInt : Result := cardinal(PSmallInt(vPointer)^);
|
|
varShortInt : Result := cardinal(PShortInt(vPointer)^);
|
|
varInteger : Result := cardinal(PInteger(vPointer)^);
|
|
{$ifndef FPUNONE}
|
|
varSingle : Result := cardinal(Round(PSingle(vPointer)^));
|
|
varDouble : Result := cardinal(Round(PDouble(vPointer)^));
|
|
varDate : Result := cardinal(Round(PDate(vPointer)^));
|
|
{$endif}
|
|
varCurrency : Result := cardinal(Round(PCurrency(vPointer)^));
|
|
varBoolean : Result := cardinal(SmallInt(PWordBool(vPointer)^));
|
|
varVariant : Result := VariantToCardinal(PVarData(vPointer)^);
|
|
varByte : Result := PByte(vPointer)^;
|
|
varWord : Result := PWord(vPointer)^;
|
|
varLongWord : Result := PLongWord(vPointer)^;
|
|
varInt64 : Result := cardinal(PInt64(vPointer)^);
|
|
varQword : Result := cardinal(PQWord(vPointer)^);
|
|
varOleStr : Result := WStrToCardinal(PPointer(vPointer)^);
|
|
varString : Result := LStrToCardinal(PPointer(vPointer)^);
|
|
varUString : Result := UStrToCardinal(PPointer(vPointer)^);
|
|
else { other vtype }
|
|
VariantTypeMismatch(vType, varLongWord);
|
|
end else { pointer is nil }
|
|
VariantTypeMismatch(vType, varLongWord);
|
|
else { array or something like that }
|
|
VariantTypeMismatch(vType, varLongWord);
|
|
end;
|
|
|
|
{$IFDEF DEBUG_VARUTILS} if __DEBUG_VARUTILS then begin
|
|
WriteLn('VariantToCardinal -> ', Result);
|
|
end; {$ENDIF}
|
|
end;
|
|
|
|
procedure PrepareFloatStr(var s: ShortString);
|
|
var
|
|
i, j : Byte;
|
|
begin
|
|
j := 1;
|
|
for i := 1 to Length(s) do
|
|
if s[i] <> DefaultFormatSettings.ThousandSeparator then begin
|
|
if s[i] = DefaultFormatSettings.DecimalSeparator then
|
|
s[j] := '.'
|
|
else
|
|
s[j] := s[i];
|
|
Inc(j);
|
|
end;
|
|
SetLength(s, Pred(j));
|
|
end;
|
|
|
|
{--- Single ---}
|
|
|
|
{$ifndef FPUNONE}
|
|
|
|
Function WStrToSingle(p: Pointer) : Single;
|
|
var
|
|
s : ShortString;
|
|
Error : Word;
|
|
begin
|
|
if Length(WideString(p)) > 255 then
|
|
VariantTypeMismatch(varOleStr, varSingle);
|
|
|
|
s := WideString(p);
|
|
PrepareFloatStr(s);
|
|
|
|
Val(s, Result, Error);
|
|
if Error <> 0 then
|
|
VariantTypeMismatch(varOleStr, varSingle);
|
|
end;
|
|
|
|
Function LStrToSingle(p: Pointer) : Single;
|
|
var
|
|
s : ShortString;
|
|
Error : Word;
|
|
begin
|
|
if Length(AnsiString(p)) > 255 then
|
|
VariantTypeMismatch(varString, varSingle);
|
|
|
|
s := AnsiString(p);
|
|
PrepareFloatStr(s);
|
|
|
|
Val(s, Result, Error);
|
|
if Error <> 0 then
|
|
VariantTypeMismatch(varString, varSingle);
|
|
end;
|
|
|
|
Function UStrToSingle(p: Pointer) : Single;
|
|
var
|
|
s : ShortString;
|
|
Error : Word;
|
|
begin
|
|
if Length(UnicodeString(p)) > 255 then
|
|
VariantTypeMismatch(varUString, varSingle);
|
|
|
|
s := UnicodeString(p);
|
|
PrepareFloatStr(s);
|
|
|
|
Val(s, Result, Error);
|
|
if Error <> 0 then
|
|
VariantTypeMismatch(varUString, varSingle);
|
|
end;
|
|
|
|
|
|
Function VariantToSingle(const VargSrc : TVarData) : Single;
|
|
begin
|
|
{$IFDEF DEBUG_VARUTILS} if __DEBUG_VARUTILS then begin
|
|
DumpVariant('VariantToSingle', VargSrc);
|
|
end; {$ENDIF}
|
|
|
|
with VargSrc do
|
|
case vType and not varTypeMask of
|
|
0: case vType of
|
|
varEmpty : Result := 0;
|
|
varSmallInt : Result := vSmallInt;
|
|
varShortInt : Result := vShortInt;
|
|
varInteger : Result := vInteger;
|
|
varSingle : Result := vSingle;
|
|
varDouble : Result := vDouble;
|
|
varCurrency : Result := vCurrency;
|
|
varDate : Result := vDate;
|
|
varBoolean : Result := SmallInt(vBoolean);
|
|
varVariant : Result := VariantToSingle(PVarData(vPointer)^);
|
|
varByte : Result := vByte;
|
|
varWord : Result := vWord;
|
|
varLongWord : Result := vLongWord;
|
|
varInt64 : Result := vInt64;
|
|
varQword : Result := vQWord;
|
|
varOleStr : Result := WStrToSingle(vOleStr);
|
|
varString : Result := LStrToSingle(vString);
|
|
varUString : Result := UStrToSingle(vString);
|
|
else
|
|
VariantTypeMismatch(vType, varSingle);
|
|
end;
|
|
varByRef: if Assigned(vPointer) then case vType and varTypeMask of
|
|
varSmallInt : Result := PSmallInt(vPointer)^;
|
|
varShortInt : Result := PShortInt(vPointer)^;
|
|
varInteger : Result := PInteger(vPointer)^;
|
|
varSingle : Result := PSingle(vPointer)^;
|
|
varDouble : Result := PDouble(vPointer)^;
|
|
varCurrency : Result := PCurrency(vPointer)^;
|
|
varDate : Result := PDate(vPointer)^;
|
|
varBoolean : Result := SmallInt(PWordBool(vPointer)^);
|
|
varVariant : Result := VariantToSingle(PVarData(vPointer)^);
|
|
varByte : Result := PByte(vPointer)^;
|
|
varWord : Result := PWord(vPointer)^;
|
|
varLongWord : Result := PLongWord(vPointer)^;
|
|
varInt64 : Result := PInt64(vPointer)^;
|
|
varQword : Result := PQWord(vPointer)^;
|
|
varOleStr : Result := WStrToSingle(PPointer(vPointer)^);
|
|
varString : Result := LStrToSingle(PPointer(vPointer)^);
|
|
varUString : Result := UStrToSingle(PPointer(vPointer)^);
|
|
else { other vtype }
|
|
VariantTypeMismatch(vType, varSingle);
|
|
end else { pointer is nil }
|
|
VariantTypeMismatch(vType, varSingle);
|
|
else { array or something like that }
|
|
VariantTypeMismatch(vType, varSingle);
|
|
end;
|
|
|
|
{$IFDEF DEBUG_VARUTILS} if __DEBUG_VARUTILS then begin
|
|
WriteLn('VariantToSingle -> ', Result);
|
|
end; {$ENDIF}
|
|
end;
|
|
|
|
{--- Double ---}
|
|
|
|
Function WStrToDouble(p: Pointer) : Double;
|
|
var
|
|
s : ShortString;
|
|
Error : Word;
|
|
begin
|
|
if Length(WideString(p)) > 255 then
|
|
VariantTypeMismatch(varOleStr, varDouble);
|
|
|
|
s := WideString(p);
|
|
PrepareFloatStr(s);
|
|
|
|
Val(s, Result, Error);
|
|
if Error <> 0 then
|
|
VariantTypeMismatch(varOleStr, varDouble);
|
|
end;
|
|
|
|
Function LStrToDouble(p: Pointer) : Double;
|
|
var
|
|
s : ShortString;
|
|
Error : Word;
|
|
begin
|
|
if Length(AnsiString(p)) > 255 then
|
|
VariantTypeMismatch(varString, varDouble);
|
|
|
|
s := AnsiString(p);
|
|
PrepareFloatStr(s);
|
|
|
|
Val(s, Result, Error);
|
|
if Error <> 0 then
|
|
VariantTypeMismatch(varString, varDouble);
|
|
end;
|
|
|
|
Function UStrToDouble(p: Pointer) : Double;
|
|
var
|
|
s : ShortString;
|
|
Error : Word;
|
|
begin
|
|
if Length(UnicodeString(p)) > 255 then
|
|
VariantTypeMismatch(varUString, varDouble);
|
|
|
|
s := UnicodeString(p);
|
|
PrepareFloatStr(s);
|
|
|
|
Val(s, Result, Error);
|
|
if Error <> 0 then
|
|
VariantTypeMismatch(varUString, varDouble);
|
|
end;
|
|
|
|
Function VariantToDouble(const VargSrc : TVarData) : Double;
|
|
begin
|
|
{$IFDEF DEBUG_VARUTILS} if __DEBUG_VARUTILS then begin
|
|
DumpVariant('VariantToDouble', VargSrc);
|
|
end; {$ENDIF}
|
|
|
|
with VargSrc do
|
|
case vType and not varTypeMask of
|
|
0: case vType of
|
|
varEmpty : Result := 0;
|
|
varSmallInt : Result := vSmallInt;
|
|
varShortInt : Result := vShortInt;
|
|
varInteger : Result := vInteger;
|
|
varSingle : Result := vSingle;
|
|
varDouble : Result := vDouble;
|
|
varCurrency : Result := vCurrency;
|
|
varDate : Result := vDate;
|
|
varBoolean : Result := SmallInt(vBoolean);
|
|
varVariant : Result := VariantToDouble(PVarData(vPointer)^);
|
|
varByte : Result := vByte;
|
|
varWord : Result := vWord;
|
|
varLongWord : Result := vLongWord;
|
|
varInt64 : Result := vInt64;
|
|
varQword : Result := vQWord;
|
|
varOleStr : Result := WStrToDouble(vOleStr);
|
|
varString : Result := LStrToDouble(vString);
|
|
varUString : Result := UStrToDouble(vString);
|
|
else
|
|
VariantTypeMismatch(vType, varDouble);
|
|
end;
|
|
varByRef: if Assigned(vPointer) then case vType and varTypeMask of
|
|
varSmallInt : Result := PSmallInt(vPointer)^;
|
|
varShortInt : Result := PShortInt(vPointer)^;
|
|
varInteger : Result := PInteger(vPointer)^;
|
|
varSingle : Result := PSingle(vPointer)^;
|
|
varDouble : Result := PDouble(vPointer)^;
|
|
varCurrency : Result := PCurrency(vPointer)^;
|
|
varDate : Result := PDate(vPointer)^;
|
|
varBoolean : Result := SmallInt(PWordBool(vPointer)^);
|
|
varVariant : Result := VariantToDouble(PVarData(vPointer)^);
|
|
varByte : Result := PByte(vPointer)^;
|
|
varWord : Result := PWord(vPointer)^;
|
|
varLongWord : Result := PLongWord(vPointer)^;
|
|
varInt64 : Result := PInt64(vPointer)^;
|
|
varQword : Result := PQWord(vPointer)^;
|
|
varOleStr : Result := WStrToDouble(PPointer(vPointer)^);
|
|
varString : Result := LStrToDouble(PPointer(vPointer)^);
|
|
varUString : Result := UStrToDouble(PPointer(vPointer)^);
|
|
else { other vtype }
|
|
VariantTypeMismatch(vType, varDouble);
|
|
end else { pointer is nil }
|
|
VariantTypeMismatch(vType, varDouble);
|
|
else { array or something like that }
|
|
VariantTypeMismatch(vType, varDouble);
|
|
end;
|
|
|
|
{$IFDEF DEBUG_VARUTILS} if __DEBUG_VARUTILS then begin
|
|
WriteLn('VariantToDouble -> ', Result);
|
|
end; {$ENDIF}
|
|
end;
|
|
|
|
{$endif FPUNONE}
|
|
|
|
{--- Currency ---}
|
|
|
|
Function WStrToCurrency(p: Pointer) : Currency;
|
|
var
|
|
s : ShortString;
|
|
Error : Word;
|
|
{$IFNDEF FPC_HAS_STR_CURRENCY}
|
|
Temp : Extended;
|
|
{$ENDIF FPC_HAS_STR_CURRENCY}
|
|
begin
|
|
if Length(WideString(p)) > 255 then
|
|
VariantTypeMismatch(varOleStr, varCurrency);
|
|
|
|
s := WideString(p);
|
|
PrepareFloatStr(s);
|
|
|
|
{$IFDEF FPC_HAS_STR_CURRENCY}
|
|
Val(s, Result, Error);
|
|
{$ELSE FPC_HAS_STR_CURRENCY} { needed for platforms where Currency = Int64 }
|
|
Val(s, Temp, Error);
|
|
Result := Temp;
|
|
{$ENDIF FPC_HAS_STR_CURRENCY}
|
|
|
|
if Error <> 0 then
|
|
VariantTypeMismatch(varOleStr, varCurrency);
|
|
end;
|
|
|
|
Function LStrToCurrency(p: Pointer) : Currency;
|
|
var
|
|
s : ShortString;
|
|
Error : Word;
|
|
{$IFNDEF FPC_HAS_STR_CURRENCY}
|
|
Temp : Extended;
|
|
{$ENDIF FPC_HAS_STR_CURRENCY}
|
|
begin
|
|
if Length(AnsiString(p)) > 255 then
|
|
VariantTypeMismatch(varString, varCurrency);
|
|
|
|
s := AnsiString(p);
|
|
PrepareFloatStr(s);
|
|
|
|
{$IFDEF FPC_HAS_STR_CURRENCY}
|
|
Val(s, Result, Error);
|
|
{$ELSE FPC_HAS_STR_CURRENCY} { needed for platforms where Currency = Int64 }
|
|
Val(s, Temp, Error);
|
|
Result := Temp;
|
|
{$ENDIF FPC_HAS_STR_CURRENCY}
|
|
|
|
if Error <> 0 then
|
|
VariantTypeMismatch(varString, varCurrency);
|
|
end;
|
|
|
|
Function UStrToCurrency(p: Pointer) : Currency;
|
|
var
|
|
s : ShortString;
|
|
Error : Word;
|
|
{$IFNDEF FPC_HAS_STR_CURRENCY}
|
|
Temp : Extended;
|
|
{$ENDIF FPC_HAS_STR_CURRENCY}
|
|
begin
|
|
if Length(UnicodeString(p)) > 255 then
|
|
VariantTypeMismatch(varUString, varCurrency);
|
|
|
|
s := UnicodeString(p);
|
|
PrepareFloatStr(s);
|
|
|
|
{$IFDEF FPC_HAS_STR_CURRENCY}
|
|
Val(s, Result, Error);
|
|
{$ELSE FPC_HAS_STR_CURRENCY} { needed for platforms where Currency = Int64 }
|
|
Val(s, Temp, Error);
|
|
Result := Temp;
|
|
{$ENDIF FPC_HAS_STR_CURRENCY}
|
|
|
|
if Error <> 0 then
|
|
VariantTypeMismatch(varUString, varCurrency);
|
|
end;
|
|
|
|
Function VariantToCurrency(const VargSrc : TVarData) : Currency;
|
|
begin
|
|
{$IFDEF DEBUG_VARUTILS} if __DEBUG_VARUTILS then begin
|
|
DumpVariant('VariantToCurrency', VargSrc);
|
|
end; {$ENDIF}
|
|
|
|
with VargSrc do
|
|
case vType and not varTypeMask of
|
|
0: case vType of
|
|
varEmpty : Result := 0;
|
|
varSmallInt : Result := vSmallInt;
|
|
varShortInt : Result := vShortInt;
|
|
varInteger : Result := vInteger;
|
|
{$ifndef FPUNONE}
|
|
varSingle : begin
|
|
if (vSingle > MaxCurrency) or (vSingle < MinCurrency) then
|
|
VariantTypeMismatch(vType, varCurrency);
|
|
Result := vSingle;
|
|
end;
|
|
varDouble : begin
|
|
if (vDouble > MaxCurrency) or (vDouble < MinCurrency) then
|
|
VariantTypeMismatch(vType, varCurrency);
|
|
Result := vDouble;
|
|
end;
|
|
varDate : begin
|
|
if (vDate > MaxCurrency) or (vDate < MinCurrency) then
|
|
VariantTypeMismatch(vType, varCurrency);
|
|
Result := vDate;
|
|
end;
|
|
{$endif}
|
|
varCurrency : Result := vCurrency;
|
|
varBoolean : Result := SmallInt(vBoolean);
|
|
varVariant : Result := VariantToCurrency(PVarData(vPointer)^);
|
|
varByte : Result := vByte;
|
|
varWord : Result := vWord;
|
|
varLongWord : Result := vLongWord;
|
|
varInt64 : Result := vInt64;
|
|
varQword : Result := currency(vQWord);
|
|
varOleStr : Result := WStrToCurrency(vOleStr);
|
|
varString : Result := LStrToCurrency(vString);
|
|
varUString : Result := UStrToCurrency(vString);
|
|
else
|
|
VariantTypeMismatch(vType, varCurrency);
|
|
end;
|
|
varByRef: if Assigned(vPointer) then case vType and varTypeMask of
|
|
varSmallInt : Result := PSmallInt(vPointer)^;
|
|
varShortInt : Result := PShortInt(vPointer)^;
|
|
varInteger : Result := PInteger(vPointer)^;
|
|
{$ifndef FPUNONE}
|
|
varSingle : begin
|
|
if (PSingle(vPointer)^ > MaxCurrency) or (PSingle(vPointer)^ < MinCurrency) then
|
|
VariantTypeMismatch(vType, varCurrency);
|
|
Result := PSingle(vPointer)^;
|
|
end;
|
|
varDouble : begin
|
|
if (PDouble(vPointer)^ > MaxCurrency) or (PDouble(vPointer)^ < MinCurrency) then
|
|
VariantTypeMismatch(vType, varCurrency);
|
|
Result := PDouble(vPointer)^;
|
|
end;
|
|
varDate : begin
|
|
if (PDate(vPointer)^ > MaxCurrency) or (PDate(vPointer)^ < MinCurrency) then
|
|
VariantTypeMismatch(vType, varCurrency);
|
|
Result := PDate(vPointer)^;
|
|
end;
|
|
{$endif}
|
|
varCurrency : Result := PCurrency(vPointer)^;
|
|
varBoolean : Result := SmallInt(PWordBool(vPointer)^);
|
|
varVariant : Result := VariantToCurrency(PVarData(vPointer)^);
|
|
varByte : Result := PByte(vPointer)^;
|
|
varWord : Result := PWord(vPointer)^;
|
|
varLongWord : Result := PLongWord(vPointer)^;
|
|
varInt64 : Result := PInt64(vPointer)^;
|
|
varQword : Result := currency(PQWord(vPointer)^);
|
|
varOleStr : Result := WStrToCurrency(PPointer(vPointer)^);
|
|
varString : Result := LStrToCurrency(PPointer(vPointer)^);
|
|
varUString : Result := UStrToCurrency(PPointer(vPointer)^);
|
|
else { other vtype }
|
|
VariantTypeMismatch(vType, varCurrency);
|
|
end else { pointer is nil }
|
|
VariantTypeMismatch(vType, varCurrency);
|
|
else { array or something like that }
|
|
VariantTypeMismatch(vType, varCurrency);
|
|
end;
|
|
|
|
{$IFDEF DEBUG_VARUTILS} if __DEBUG_VARUTILS then begin
|
|
WriteLn('VariantToCurrency -> ', Result);
|
|
end; {$ENDIF}
|
|
end;
|
|
|
|
{--- Date ---}
|
|
|
|
{$ifndef FPUNONE}
|
|
|
|
Function WStrToDate(p: Pointer) : TDateTime;
|
|
var
|
|
s: string;
|
|
begin
|
|
s := WideString(p);
|
|
|
|
if not TryStrToDateTime(s, Result) then
|
|
VariantTypeMismatch(varOleStr, varDate);
|
|
end;
|
|
|
|
Function LStrToDate(p: Pointer) : TDateTime;
|
|
begin
|
|
if not TryStrToDateTime(AnsiString(p), Result) then
|
|
VariantTypeMismatch(varString, varDate);
|
|
end;
|
|
|
|
Function UStrToDate(p: Pointer) : TDateTime;
|
|
begin
|
|
if not TryStrToDateTime(UnicodeString(p), Result) then
|
|
VariantTypeMismatch(varUString, varDate);
|
|
end;
|
|
|
|
Function VariantToDate(const VargSrc : TVarData) : TDateTime;
|
|
begin
|
|
{$IFDEF DEBUG_VARUTILS} if __DEBUG_VARUTILS then begin
|
|
DumpVariant('VariantToDate', VargSrc);
|
|
end; {$ENDIF}
|
|
|
|
with VargSrc do
|
|
case vType and not varTypeMask of
|
|
0: case vType of
|
|
varEmpty : Result := 0;
|
|
varSmallInt : Result := vSmallInt;
|
|
varShortInt : Result := vShortInt;
|
|
varInteger : Result := vInteger;
|
|
varSingle : Result := vSingle;
|
|
varDouble : Result := vDouble;
|
|
varCurrency : Result := vCurrency;
|
|
varDate : Result := vDate;
|
|
varBoolean : Result := SmallInt(vBoolean);
|
|
varVariant : Result := VariantToDate(PVarData(vPointer)^);
|
|
varByte : Result := vByte;
|
|
varWord : Result := vWord;
|
|
varLongWord : Result := vLongWord;
|
|
varInt64 : Result := vInt64;
|
|
varQword : Result := vQWord;
|
|
varOleStr : Result := WStrToDate(vOleStr);
|
|
varString : Result := LStrToDate(vString);
|
|
varUString : Result := UStrToDate(vString);
|
|
else
|
|
VariantTypeMismatch(vType, varDate);
|
|
end;
|
|
varByRef: if Assigned(vPointer) then case vType and varTypeMask of
|
|
varSmallInt : Result := PSmallInt(vPointer)^;
|
|
varShortInt : Result := PShortInt(vPointer)^;
|
|
varInteger : Result := PInteger(vPointer)^;
|
|
varSingle : Result := PSingle(vPointer)^;
|
|
varDouble : Result := PDouble(vPointer)^;
|
|
varCurrency : Result := PCurrency(vPointer)^;
|
|
varDate : Result := PDate(vPointer)^;
|
|
varBoolean : Result := SmallInt(PWordBool(vPointer)^);
|
|
varVariant : Result := VariantToDate(PVarData(vPointer)^);
|
|
varByte : Result := PByte(vPointer)^;
|
|
varWord : Result := PWord(vPointer)^;
|
|
varLongWord : Result := PLongWord(vPointer)^;
|
|
varInt64 : Result := PInt64(vPointer)^;
|
|
varQword : Result := PQWord(vPointer)^;
|
|
varOleStr : Result := WStrToDate(PPointer(vPointer)^);
|
|
varString : Result := LStrToDate(PPointer(vPointer)^);
|
|
varUString : Result := UStrToDate(PPointer(vPointer)^);
|
|
else { other vtype }
|
|
VariantTypeMismatch(vType, varDate);
|
|
end else { pointer is nil }
|
|
VariantTypeMismatch(vType, varDate);
|
|
else { array or something like that }
|
|
VariantTypeMismatch(vType, varDate);
|
|
end;
|
|
if (Result < MinDateTime) or (Result > MaxDateTime) then
|
|
VariantTypeMismatch(VargSrc.vType, varDate);
|
|
|
|
{$IFDEF DEBUG_VARUTILS} if __DEBUG_VARUTILS then begin
|
|
WriteLn('VariantToDate -> ', Result);
|
|
end; {$ENDIF}
|
|
end;
|
|
|
|
{$endif}
|
|
|
|
{--- Boolean ---}
|
|
|
|
Function WStrToBoolean(p: Pointer) : Boolean;
|
|
begin
|
|
if not TryStrToBool(WideString(p), Result) then
|
|
VariantTypeMismatch(varOleStr, varBoolean);
|
|
end;
|
|
|
|
Function LStrToBoolean(p: Pointer) : Boolean;
|
|
begin
|
|
if not TryStrToBool(AnsiString(p), Result) then
|
|
VariantTypeMismatch(varString, varBoolean);
|
|
end;
|
|
|
|
Function UStrToBoolean(p: Pointer) : Boolean;
|
|
begin
|
|
if not TryStrToBool(UnicodeString(p), Result) then
|
|
VariantTypeMismatch(varUString, varBoolean);
|
|
end;
|
|
|
|
Function VariantToBoolean(const VargSrc : TVarData) : Boolean;
|
|
begin
|
|
{$IFDEF DEBUG_VARUTILS} if __DEBUG_VARUTILS then begin
|
|
DumpVariant('VariantToBoolean', VargSrc);
|
|
end; {$ENDIF}
|
|
|
|
with VargSrc do
|
|
case vType and not varTypeMask of
|
|
0: case vType of
|
|
varEmpty : Result := False;
|
|
varSmallInt : Result := vSmallInt <> 0;
|
|
varShortInt : Result := vShortInt <> 0;
|
|
varInteger : Result := vInteger <> 0;
|
|
{$ifndef FPUNONE}
|
|
varSingle : Result := vSingle <> 0;
|
|
varDouble : Result := vDouble <> 0;
|
|
varCurrency : Result := vCurrency <> 0;
|
|
varDate : Result := vDate <> 0;
|
|
{$endif}
|
|
varBoolean : Result := vBoolean;
|
|
varVariant : Result := VariantToBoolean(PVarData(vPointer)^);
|
|
varByte : Result := vByte <> 0;
|
|
varWord : Result := vWord <> 0;
|
|
varLongWord : Result := vLongWord <> 0;
|
|
varInt64 : Result := vInt64 <> 0;
|
|
varQword : Result := vQWord <> 0;
|
|
varOleStr : Result := WStrToBoolean(vOleStr);
|
|
varString : Result := LStrToBoolean(vString);
|
|
varUString : Result := UStrToBoolean(vString);
|
|
else
|
|
VariantTypeMismatch(vType, varBoolean);
|
|
end;
|
|
varByRef: if Assigned(vPointer) then case vType and varTypeMask of
|
|
varSmallInt : Result := PSmallInt(vPointer)^ <> 0;
|
|
varShortInt : Result := PShortInt(vPointer)^ <> 0;
|
|
varInteger : Result := PInteger(vPointer)^ <> 0;
|
|
{$ifndef FPUNONE}
|
|
varSingle : Result := PSingle(vPointer)^ <> 0;
|
|
varDouble : Result := PDouble(vPointer)^ <> 0;
|
|
varCurrency : Result := PCurrency(vPointer)^ <> 0;
|
|
varDate : Result := PDate(vPointer)^ <> 0;
|
|
{$endif}
|
|
varBoolean : Result := SmallInt(PWordBool(vPointer)^) <> 0;
|
|
varVariant : Result := VariantToBoolean(PVarData(vPointer)^);
|
|
varByte : Result := PByte(vPointer)^ <> 0;
|
|
varWord : Result := PWord(vPointer)^ <> 0;
|
|
varLongWord : Result := PLongWord(vPointer)^ <> 0;
|
|
varInt64 : Result := PInt64(vPointer)^ <> 0;
|
|
varQword : Result := PQWord(vPointer)^ <> 0;
|
|
varOleStr : Result := WStrToBoolean(PPointer(vPointer)^);
|
|
varString : Result := LStrToBoolean(PPointer(vPointer)^);
|
|
varUString : Result := UStrToBoolean(PPointer(vPointer)^);
|
|
else { other vtype }
|
|
VariantTypeMismatch(vType, varBoolean);
|
|
end else { pointer is nil }
|
|
Result := False;
|
|
else { array or something like that }
|
|
VariantTypeMismatch(vType, varBoolean);
|
|
end;
|
|
|
|
{$IFDEF DEBUG_VARUTILS} if __DEBUG_VARUTILS then begin
|
|
WriteLn('VariantToBoolean -> ', Result);
|
|
end; {$ENDIF}
|
|
end;
|
|
|
|
{--- Byte ---}
|
|
|
|
Function WStrToByte(p: Pointer) : Byte;
|
|
var
|
|
Error : Word;
|
|
begin
|
|
Val(WideString(p), Result, Error);
|
|
if Error <> 0 then
|
|
VariantTypeMismatch(varOleStr, varByte);
|
|
end;
|
|
|
|
Function LStrToByte(p: Pointer) : Byte;
|
|
var
|
|
Error : Word;
|
|
begin
|
|
Val(AnsiString(p), Result, Error);
|
|
if Error <> 0 then
|
|
VariantTypeMismatch(varString, varByte);
|
|
end;
|
|
|
|
Function UStrToByte(p: Pointer) : Byte;
|
|
var
|
|
Error : Word;
|
|
begin
|
|
Val(UnicodeString(p), Result, Error);
|
|
if Error <> 0 then
|
|
VariantTypeMismatch(varUString, varByte);
|
|
end;
|
|
|
|
Function VariantToByte(const VargSrc : TVarData) : Byte;
|
|
begin
|
|
{$IFDEF DEBUG_VARUTILS} if __DEBUG_VARUTILS then begin
|
|
DumpVariant('VariantToByte', VargSrc);
|
|
end; {$ENDIF}
|
|
|
|
with VargSrc do
|
|
case vType and not varTypeMask of
|
|
0: case vType of
|
|
varEmpty : Result := 0;
|
|
varSmallInt : Result := byte(vSmallInt);
|
|
varShortInt : Result := byte(vShortInt);
|
|
varInteger : Result := byte(vInteger);
|
|
{$ifndef FPUNONE}
|
|
varSingle : Result := byte(Round(vSingle));
|
|
varDouble : Result := byte(Round(vDouble));
|
|
varCurrency : Result := byte(Round(vCurrency));
|
|
varDate : Result := byte(Round(vDate));
|
|
{$endif}
|
|
varBoolean : Result := byte(SmallInt(vBoolean));
|
|
varVariant : Result := VariantToByte(PVarData(vPointer)^);
|
|
varByte : Result := vByte;
|
|
varWord : Result := byte(vWord);
|
|
varLongWord : Result := byte(vLongWord);
|
|
varInt64 : Result := byte(vInt64);
|
|
varQword : Result := byte(vQWord);
|
|
varOleStr : Result := WStrToByte(vOleStr);
|
|
varString : Result := LStrToByte(vString);
|
|
varUString : Result := UStrToByte(vString);
|
|
else
|
|
VariantTypeMismatch(vType, varByte);
|
|
end;
|
|
varByRef: if Assigned(vPointer) then case vType and varTypeMask of
|
|
varSmallInt : Result := byte(PSmallInt(vPointer)^);
|
|
varShortInt : Result := byte(PShortInt(vPointer)^);
|
|
varInteger : Result := byte(PInteger(vPointer)^);
|
|
{$ifndef FPUNONE}
|
|
varSingle : Result := byte(Round(PSingle(vPointer)^));
|
|
varDouble : Result := byte(Round(PDouble(vPointer)^));
|
|
varCurrency : Result := byte(Round(PCurrency(vPointer)^));
|
|
varDate : Result := byte(Round(PDate(vPointer)^));
|
|
{$endif}
|
|
varBoolean : Result := byte(SmallInt(PWordBool(vPointer)^));
|
|
varVariant : Result := byte(VariantToByte(PVarData(vPointer)^));
|
|
varByte : Result := PByte(vPointer)^;
|
|
varWord : Result := byte(PWord(vPointer)^);
|
|
varLongWord : Result := byte(PLongWord(vPointer)^);
|
|
varInt64 : Result := byte(PInt64(vPointer)^);
|
|
varQword : Result := byte(PQWord(vPointer)^);
|
|
varOleStr : Result := WStrToByte(PPointer(vPointer)^);
|
|
varString : Result := LStrToByte(PPointer(vPointer)^);
|
|
varUString : Result := UStrToByte(PPointer(vPointer)^);
|
|
else { other vtype }
|
|
VariantTypeMismatch(vType, varByte);
|
|
end else { pointer is nil }
|
|
VariantTypeMismatch(vType, varByte);
|
|
else { array or something like that }
|
|
VariantTypeMismatch(vType, varByte);
|
|
end;
|
|
|
|
{$IFDEF DEBUG_VARUTILS} if __DEBUG_VARUTILS then begin
|
|
WriteLn('VariantToByte -> ', Result);
|
|
end; {$ENDIF}
|
|
end;
|
|
|
|
{--- Int64 ---}
|
|
|
|
Function WStrToInt64(p: Pointer) : Int64;
|
|
var
|
|
Error : Word;
|
|
begin
|
|
Val(WideString(p), Result, Error);
|
|
if Error <> 0 then
|
|
VariantTypeMismatch(varOleStr, varInt64);
|
|
end;
|
|
|
|
Function LStrToInt64(p: Pointer) : Int64;
|
|
var
|
|
Error : Word;
|
|
begin
|
|
Val(AnsiString(p), Result, Error);
|
|
if Error <> 0 then
|
|
VariantTypeMismatch(varString, varInt64);
|
|
end;
|
|
|
|
Function UStrToInt64(p: Pointer) : Int64;
|
|
var
|
|
Error : Word;
|
|
begin
|
|
Val(UnicodeString(p), Result, Error);
|
|
if Error <> 0 then
|
|
VariantTypeMismatch(varUString, varInt64);
|
|
end;
|
|
|
|
Function VariantToInt64(const VargSrc : TVarData) : Int64;
|
|
begin
|
|
{$IFDEF DEBUG_VARUTILS} if __DEBUG_VARUTILS then begin
|
|
DumpVariant('VariantToInt64', VargSrc);
|
|
end; {$ENDIF}
|
|
|
|
with VargSrc do
|
|
case vType and not varTypeMask of
|
|
0: case vType of
|
|
varEmpty : Result := 0;
|
|
varSmallInt : Result := vSmallInt;
|
|
varShortInt : Result := vShortInt;
|
|
varInteger : Result := vInteger;
|
|
{$ifndef FPUNONE}
|
|
varSingle : Result := Round(vSingle);
|
|
varDouble : Result := Round(vDouble);
|
|
varCurrency : Result := Round(vCurrency);
|
|
varDate : Result := Round(vDate);
|
|
{$endif}
|
|
varBoolean : Result := SmallInt(vBoolean);
|
|
varVariant : Result := VariantToInt64(PVarData(vPointer)^);
|
|
varByte : Result := vByte;
|
|
varWord : Result := vWord;
|
|
varLongWord : Result := vLongWord;
|
|
varInt64 : Result := vInt64;
|
|
varQword : Result := int64(vQWord);
|
|
varOleStr : Result := WStrToInt64(vOleStr);
|
|
varString : Result := LStrToInt64(vString);
|
|
varUString : Result := UStrToInt64(vString);
|
|
else
|
|
VariantTypeMismatch(vType, varInt64);
|
|
end;
|
|
varByRef: if Assigned(vPointer) then case vType and varTypeMask of
|
|
varSmallInt : Result := PSmallInt(vPointer)^;
|
|
varShortInt : Result := PShortInt(vPointer)^;
|
|
varInteger : Result := PInteger(vPointer)^;
|
|
{$ifndef FPUNONE}
|
|
varSingle : Result := Round(PSingle(vPointer)^);
|
|
varDouble : Result := Round(PDouble(vPointer)^);
|
|
varCurrency : Result := Round(PCurrency(vPointer)^);
|
|
varDate : Result := Round(PDate(vPointer)^);
|
|
{$endif}
|
|
varBoolean : Result := SmallInt(PWordBool(vPointer)^);
|
|
varVariant : Result := VariantToInt64(PVarData(vPointer)^);
|
|
varByte : Result := PByte(vPointer)^;
|
|
varWord : Result := PWord(vPointer)^;
|
|
varLongWord : Result := PLongWord(vPointer)^;
|
|
varInt64 : Result := PInt64(vPointer)^;
|
|
varQword : Result := PQWord(vPointer)^;
|
|
varOleStr : Result := WStrToInt64(PPointer(vPointer)^);
|
|
varString : Result := LStrToInt64(PPointer(vPointer)^);
|
|
varUString : Result := UStrToInt64(PPointer(vPointer)^);
|
|
else { other vtype }
|
|
VariantTypeMismatch(vType, varInt64);
|
|
end else { pointer is nil }
|
|
VariantTypeMismatch(vType, varInt64);
|
|
else { array or something like that }
|
|
VariantTypeMismatch(vType, varInt64);
|
|
end;
|
|
|
|
{$IFDEF DEBUG_VARUTILS} if __DEBUG_VARUTILS then begin
|
|
WriteLn('VariantToInt64 -> ', Result);
|
|
end; {$ENDIF}
|
|
end;
|
|
|
|
{--- QWord ---}
|
|
|
|
Function WStrToQWord(p: Pointer) : QWord;
|
|
var
|
|
Error : Word;
|
|
begin
|
|
Val(WideString(p), Result, Error);
|
|
if Error <> 0 then
|
|
VariantTypeMismatch(varOleStr, varQWord);
|
|
end;
|
|
|
|
Function LStrToQWord(p: Pointer) : QWord;
|
|
var
|
|
Error : Word;
|
|
begin
|
|
Val(AnsiString(p), Result, Error);
|
|
if Error <> 0 then
|
|
VariantTypeMismatch(varString, varQWord);
|
|
end;
|
|
|
|
Function UStrToQWord(p: Pointer) : QWord;
|
|
var
|
|
Error : Word;
|
|
begin
|
|
Val(UnicodeString(p), Result, Error);
|
|
if Error <> 0 then
|
|
VariantTypeMismatch(varUString, varQWord);
|
|
end;
|
|
|
|
Function VariantToQWord(const VargSrc : TVarData) : QWord;
|
|
begin
|
|
{$IFDEF DEBUG_VARUTILS} if __DEBUG_VARUTILS then begin
|
|
DumpVariant('VariantToQWord', VargSrc);
|
|
end; {$ENDIF}
|
|
|
|
with VargSrc do
|
|
case vType and not varTypeMask of
|
|
0: case vType of
|
|
varEmpty : Result := 0;
|
|
varSmallInt : Result := qword(vSmallInt);
|
|
varShortInt : Result := qword(vShortInt);
|
|
varInteger : Result := qword(vInteger);
|
|
{$ifndef FPUNONE}
|
|
varSingle : Result := qword(Round(vSingle));
|
|
varDouble : Result := qword(Round(vDouble));
|
|
varCurrency : Result := qword(Round(vCurrency));
|
|
varDate : Result := qword(Round(vDate));
|
|
{$endif}
|
|
varBoolean : Result := qword(SmallInt(vBoolean));
|
|
varVariant : Result := VariantToQWord(PVarData(vPointer)^);
|
|
varByte : Result := vByte;
|
|
varWord : Result := vWord;
|
|
varLongWord : Result := vLongWord;
|
|
varInt64 : Result := qword(vInt64);
|
|
varQword : Result := vQWord;
|
|
varOleStr : Result := WStrToQWord(vOleStr);
|
|
varString : Result := LStrToQWord(vString);
|
|
varUString : Result := UStrToQWord(vString);
|
|
else
|
|
VariantTypeMismatch(vType, varQWord);
|
|
end;
|
|
varByRef: if Assigned(vPointer) then case vType and varTypeMask of
|
|
varSmallInt : Result := qword(PSmallInt(vPointer)^);
|
|
varShortInt : Result := qword(PShortInt(vPointer)^);
|
|
varInteger : Result := qword(PInteger(vPointer)^);
|
|
{$ifndef FPUNONE}
|
|
varSingle : Result := qword(Round(PSingle(vPointer)^));
|
|
varDouble : Result := qword(Round(PDouble(vPointer)^));
|
|
varCurrency : Result := qword(Round(PCurrency(vPointer)^));
|
|
varDate : Result := qword(Round(PDate(vPointer)^));
|
|
{$endif}
|
|
varBoolean : Result := qword(SmallInt(PWordBool(vPointer)^));
|
|
varVariant : Result := VariantToQWord(PVarData(vPointer)^);
|
|
varByte : Result := PByte(vPointer)^;
|
|
varWord : Result := PWord(vPointer)^;
|
|
varLongWord : Result := PLongWord(vPointer)^;
|
|
varInt64 : Result := qword(PInt64(vPointer)^);
|
|
varQword : Result := PQWord(vPointer)^;
|
|
varOleStr : Result := WStrToQWord(PPointer(vPointer)^);
|
|
varString : Result := LStrToQWord(PPointer(vPointer)^);
|
|
varUString : Result := UStrToQWord(PPointer(vPointer)^);
|
|
else { other vtype }
|
|
VariantTypeMismatch(vType, varQWord);
|
|
end else { pointer is nil }
|
|
VariantTypeMismatch(vType, varQWord);
|
|
else { array or something like that }
|
|
VariantTypeMismatch(vType, varQWord);
|
|
end;
|
|
|
|
{$IFDEF DEBUG_VARUTILS} if __DEBUG_VARUTILS then begin
|
|
WriteLn('VariantToQWord -> ', Result);
|
|
end; {$ENDIF}
|
|
end;
|
|
|
|
function VarDateToString(DT: TDateTime): AnsiString;
|
|
begin
|
|
if Trunc(DT) = 0 then
|
|
Result := TimeToStr(DT)
|
|
else
|
|
Result := DateTimeToStr(DT);
|
|
end;
|
|
|
|
{--- WideString ---}
|
|
|
|
Function VariantToWideString(const VargSrc : TVarData) : WideString;
|
|
begin
|
|
{$IFDEF DEBUG_VARUTILS} if __DEBUG_VARUTILS then begin
|
|
DumpVariant('VariantToWideString', VargSrc);
|
|
end; {$ENDIF}
|
|
|
|
with VargSrc do
|
|
case vType and not varTypeMask of
|
|
0: case vType of
|
|
varEmpty : Result := '';
|
|
varSmallInt : Result := IntToStr(vSmallInt);
|
|
varShortInt : Result := IntToStr(vShortInt);
|
|
varInteger : Result := IntToStr(vInteger);
|
|
{$ifndef FPUNONE}
|
|
varSingle : Result := FloatToStr(vSingle);
|
|
varDouble : Result := FloatToStr(vDouble);
|
|
varCurrency : Result := FloatToStr(vCurrency);
|
|
varDate : Result := VarDateToString(vDate);
|
|
{$endif}
|
|
varBoolean : Result := BoolToStr(vBoolean, True);
|
|
varVariant : Result := VariantToWideString(PVarData(vPointer)^);
|
|
varByte : Result := IntToStr(vByte);
|
|
varWord : Result := IntToStr(vWord);
|
|
varLongWord : Result := IntToStr(vLongWord);
|
|
varInt64 : Result := IntToStr(vInt64);
|
|
varQword : Result := IntToStr(vQWord);
|
|
varOleStr : Result := WideString(Pointer(vOleStr));
|
|
varString : Result := AnsiString(vString);
|
|
varUString : Result := UnicodeString(vString);
|
|
else
|
|
VariantTypeMismatch(vType, varOleStr);
|
|
end;
|
|
varByRef: if Assigned(vPointer) then case vType and varTypeMask of
|
|
varSmallInt : Result := IntToStr(PSmallInt(vPointer)^);
|
|
varShortInt : Result := IntToStr(PShortInt(vPointer)^);
|
|
varInteger : Result := IntToStr(PInteger(vPointer)^);
|
|
{$ifndef FPUNONE}
|
|
varSingle : Result := FloatToStr(PSingle(vPointer)^);
|
|
varDouble : Result := FloatToStr(PDouble(vPointer)^);
|
|
varCurrency : Result := FloatToStr(PCurrency(vPointer)^);
|
|
varDate : Result := VarDateToString(PDate(vPointer)^);
|
|
{$endif}
|
|
varBoolean : Result := BoolToStr(PWordBool(vPointer)^, True);
|
|
varVariant : Result := VariantToWideString(PVarData(vPointer)^);
|
|
varByte : Result := IntToStr(PByte(vPointer)^);
|
|
varWord : Result := IntToStr(PWord(vPointer)^);
|
|
varLongWord : Result := IntToStr(PLongWord(vPointer)^);
|
|
varInt64 : Result := IntToStr(PInt64(vPointer)^);
|
|
varQword : Result := IntToStr(PQWord(vPointer)^);
|
|
varOleStr : Result := WideString(PPointer(vPointer)^);
|
|
varString : Result := AnsiString(PPointer(vPointer)^);
|
|
varUString : Result := UnicodeString(PPointer(vPointer)^);
|
|
else { other vtype }
|
|
VariantTypeMismatch(vType, varOleStr);
|
|
end else { pointer is nil }
|
|
VariantTypeMismatch(vType, varOleStr);
|
|
else { array or something like that }
|
|
VariantTypeMismatch(vType, varOleStr);
|
|
end;
|
|
|
|
{$IFDEF DEBUG_VARUTILS} if __DEBUG_VARUTILS then begin
|
|
WriteLn('VariantToWideString -> ', Result);
|
|
end; {$ENDIF}
|
|
end;
|
|
|
|
{--- AnsiString ---}
|
|
|
|
Function VariantToAnsiString(const VargSrc : TVarData) : AnsiString;
|
|
begin
|
|
{$IFDEF DEBUG_VARUTILS} if __DEBUG_VARUTILS then begin
|
|
DumpVariant('VariantToAnsiString', VargSrc);
|
|
end; {$ENDIF}
|
|
|
|
with VargSrc do
|
|
case vType and not varTypeMask of
|
|
0: case vType of
|
|
varEmpty : Result := '';
|
|
varSmallInt : Result := IntToStr(vSmallInt);
|
|
varShortInt : Result := IntToStr(vShortInt);
|
|
varInteger : Result := IntToStr(vInteger);
|
|
{$ifndef FPUNONE}
|
|
varSingle : Result := FloatToStr(vSingle);
|
|
varDouble : Result := FloatToStr(vDouble);
|
|
varCurrency : Result := FloatToStr(vCurrency);
|
|
varDate : Result := VarDateToString(vDate);
|
|
{$endif}
|
|
varBoolean : Result := BoolToStr(vBoolean, True);
|
|
varVariant : Result := VariantToAnsiString(PVarData(vPointer)^);
|
|
varByte : Result := IntToStr(vByte);
|
|
varWord : Result := IntToStr(vWord);
|
|
varLongWord : Result := IntToStr(vLongWord);
|
|
varInt64 : Result := IntToStr(vInt64);
|
|
varQword : Result := IntToStr(vQWord);
|
|
varOleStr : Result := WideString(Pointer(vOleStr));
|
|
varString : Result := AnsiString(vString);
|
|
varUString : Result := UnicodeString(vString);
|
|
else
|
|
VariantTypeMismatch(vType, varString);
|
|
end;
|
|
varByRef: if Assigned(vPointer) then case vType and varTypeMask of
|
|
varSmallInt : Result := IntToStr(PSmallInt(vPointer)^);
|
|
varShortInt : Result := IntToStr(PShortInt(vPointer)^);
|
|
varInteger : Result := IntToStr(PInteger(vPointer)^);
|
|
{$ifndef FPUNONE}
|
|
varSingle : Result := FloatToStr(PSingle(vPointer)^);
|
|
varDouble : Result := FloatToStr(PDouble(vPointer)^);
|
|
varCurrency : Result := FloatToStr(PCurrency(vPointer)^);
|
|
varDate : Result := VarDateToString(PDate(vPointer)^);
|
|
{$endif}
|
|
varBoolean : Result := BoolToStr(PWordBool(vPointer)^, True);
|
|
varVariant : Result := VariantToAnsiString(PVarData(vPointer)^);
|
|
varByte : Result := IntToStr(PByte(vPointer)^);
|
|
varWord : Result := IntToStr(PWord(vPointer)^);
|
|
varLongWord : Result := IntToStr(PLongWord(vPointer)^);
|
|
varInt64 : Result := IntToStr(PInt64(vPointer)^);
|
|
varQword : Result := IntToStr(PQWord(vPointer)^);
|
|
varOleStr : Result := WideString(PPointer(vPointer)^);
|
|
varString : Result := AnsiString(PPointer(vPointer)^);
|
|
varUString : Result := UnicodeString(PPointer(vPointer)^);
|
|
else { other vtype }
|
|
VariantTypeMismatch(vType, varString);
|
|
end else { pointer is nil }
|
|
VariantTypeMismatch(vType, varString);
|
|
else { array or something like that }
|
|
VariantTypeMismatch(vType, varString);
|
|
end;
|
|
|
|
{$IFDEF DEBUG_VARUTILS} if __DEBUG_VARUTILS then begin
|
|
WriteLn('VariantToAnsiString -> ', Result);
|
|
end; {$ENDIF}
|
|
end;
|
|
|
|
|
|
Function VariantToShortString(const VargSrc : TVarData) : ShortString;
|
|
begin
|
|
Result:=VariantToAnsiString(VargSrc);
|
|
end;
|
|
|
|
{ ---------------------------------------------------------------------
|
|
Some debug routines
|
|
---------------------------------------------------------------------}
|
|
|
|
|
|
Procedure DumpVariant(const VSrc : Variant);
|
|
begin
|
|
DumpVariant(Output, '', TVarData(VSrc));
|
|
end;
|
|
|
|
Procedure DumpVariant(const aName: string; const VSrc : Variant);
|
|
begin
|
|
DumpVariant(Output, aName, TVarData(VSrc));
|
|
end;
|
|
|
|
Procedure DumpVariant(Var F : Text; const VSrc : Variant);
|
|
begin
|
|
DumpVariant(F, '', TVarData(VSrc));
|
|
end;
|
|
|
|
procedure DumpVariant(var F : Text; const aName: string; const VSrc : Variant);
|
|
begin
|
|
DumpVariant(F, aName, TVarData(VSrc));
|
|
end;
|
|
|
|
Procedure DumpVariant(const VargSrc : TVarData);
|
|
begin
|
|
DumpVariant(Output, '', VargSrc);
|
|
end;
|
|
|
|
Procedure DumpVariant(const aName: string; const VargSrc : TVarData);
|
|
begin
|
|
DumpVariant(Output, aName, VargSrc);
|
|
end;
|
|
|
|
Procedure DumpVariant(Var F : Text; const VargSrc : TVarData);
|
|
begin
|
|
DumpVariant(F, '', VargSrc);
|
|
end;
|
|
|
|
const
|
|
VarTypeStrings : array [varEmpty..varQword] of string = (
|
|
'empty', { varempty = 0 }
|
|
'null', { varnull = 1 }
|
|
'smallint', { varsmallint = 2 }
|
|
'integer', { varinteger = 3 }
|
|
'single', { varsingle = 4 }
|
|
'double', { vardouble = 5 }
|
|
'currency', { varcurrency = 6 }
|
|
'date', { vardate = 7 }
|
|
'olestr', { varolestr = 8 }
|
|
'dispatch', { vardispatch = 9 }
|
|
'error', { varerror = 10 }
|
|
'boolean', { varboolean = 11 }
|
|
'variant', { varvariant = 12 }
|
|
'unknown', { varunknown = 13 }
|
|
'decimal', { vardecimal = 14 }
|
|
'undefined',
|
|
'shortint', { varshortint = 16 }
|
|
'byte', { varbyte = 17 }
|
|
'word', { varword = 18 }
|
|
'longword', { varlongword = 19 }
|
|
'int64', { varint64 = 20 }
|
|
'qword'); { varqword = 21 }
|
|
|
|
Procedure DumpVariant(Var F : Text; const aName: string; const VargSrc : TVarData);
|
|
|
|
Var
|
|
i: Integer;
|
|
|
|
begin
|
|
Writeln(F,'---> ', aName, ' at $', HexStr(@VargSrc), ' <----------------');
|
|
with VargSrc do begin
|
|
|
|
if vType and varByRef = varByRef then
|
|
Writeln(F,'Variant is by reference.');
|
|
|
|
if vType and varArray = varArray then
|
|
Writeln(F,'Variant is an array.');
|
|
|
|
if vType and not (varTypeMask or varArray or varByRef) <> 0 then
|
|
Writeln(F,'Variant has unknown flags set in type: $', IntToHex(vType, 4));
|
|
|
|
|
|
If (vType and varTypeMask) in [varEmpty..varQword] then
|
|
Writeln(F,'Variant has type : ', VarTypeStrings[vType and varTypeMask])
|
|
else If (vType and varTypeMask) = varString then
|
|
Writeln(F,'Variant has type : string')
|
|
else if (vType and varTypeMask) = varUString then
|
|
Writeln(F,'Variant has type : UnicodeString')
|
|
else
|
|
Writeln(F,'Variant has unknown type : $', IntToHex(vType and varTypeMask, 4));
|
|
|
|
Write('Bytes :');
|
|
for i := 0 to 13 do
|
|
Write(IntToHex(VBytes[i], 2),' ');
|
|
WriteLn;
|
|
|
|
if vType and varArray = varArray then begin
|
|
Writeln(F,'---< ', aName, ' at $', HexStr(@VargSrc), ' >----------------');
|
|
Writeln(F);
|
|
Exit;
|
|
end;
|
|
|
|
If vType <> varEmpty then begin
|
|
Write(F,'Value is: [');
|
|
|
|
if (vType and varByRef = varByRef) or (vType and varTypeMask = varVariant) then
|
|
if not Assigned(vPointer) then begin
|
|
WriteLn(F, 'nil]');
|
|
Writeln(F,'---< ', aName, ' at $', HexStr(@VargSrc), ' >----------------');
|
|
Writeln(F);
|
|
Exit;
|
|
end;
|
|
|
|
case vType of
|
|
varNull : Write(F, 'Null');
|
|
varSmallInt : Write(F, vSmallInt);
|
|
varInteger : Write(F, vInteger);
|
|
{$ifndef FPUNONE}
|
|
varSingle : Write(F, vSingle);
|
|
varDouble : Write(F, vDouble);
|
|
varCurrency : Write(F, vCurrency);
|
|
varDate : Write(F, vDate);
|
|
{$endif}
|
|
varOleStr : Write(F, WideString(Pointer(vOleStr)));
|
|
varError : Write(F, IntToHex(Cardinal(vError), 8));
|
|
varBoolean : Write(F, vBoolean);
|
|
varVariant, varVariant or varByRef : begin
|
|
WriteLn(' dereferencing -> ]');
|
|
DumpVariant(F, aName+'^', PVarData(vPointer)^);
|
|
Exit;
|
|
end;
|
|
varShortInt : Write(F, vShortInt);
|
|
varByte : Write(F, vByte);
|
|
varWord : Write(F, vWord);
|
|
varLongWord : Write(F, vLongWord);
|
|
varInt64 : Write(F, vInt64);
|
|
varQword : Write(F, vQWord);
|
|
varString : Write(F, AnsiString(vString));
|
|
varNull or varByRef : Write(F, 'Null');
|
|
varSmallInt or varByRef : Write(F, PSmallInt(vPointer)^);
|
|
varInteger or varByRef : Write(F, PInteger(vPointer)^);
|
|
{$ifndef FPUNONE}
|
|
varSingle or varByRef : Write(F, PSingle(vPointer)^);
|
|
varDouble or varByRef : Write(F, PDouble(vPointer)^);
|
|
varCurrency or varByRef : Write(F, PCurrency(vPointer)^);
|
|
varDate or varByRef : Write(F, PDate(vPointer)^);
|
|
{$endif}
|
|
varOleStr or varByRef : Write(F, WideString(PPointer(vPointer)^));
|
|
varError or varByRef : Write(F, IntToHex(Cardinal(PLongWord(vPointer)^), 8));
|
|
varBoolean or varByRef : Write(F, PWordBool(vPointer)^);
|
|
varShortInt or varByRef : Write(F, PShortInt(vPointer)^);
|
|
varByte or varByRef : Write(F, PByte(vPointer)^);
|
|
varWord or varByRef : Write(F, PWord(vPointer)^);
|
|
varLongWord or varByRef : Write(F, PLongWord(vPointer)^);
|
|
varInt64 or varByRef : Write(F, PInt64(vPointer)^);
|
|
varQword or varByRef : Write(F, PQWord(vPointer)^);
|
|
varString or varByRef : Write(F, AnsiString(PPointer(vPointer)^));
|
|
else
|
|
Write(F, 'Unsupported');
|
|
end;
|
|
WriteLn(F, ']');
|
|
end;
|
|
end;
|
|
|
|
Writeln(F,'---< ', aName, ' at $', HexStr(@VargSrc), ' >----------------');
|
|
Writeln(F);
|
|
end;
|
|
|
|
|
|
|