mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-05-16 15:42:34 +02:00
606 lines
17 KiB
PHP
606 lines
17 KiB
PHP
{
|
|
$Id$
|
|
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.
|
|
|
|
**********************************************************************}
|
|
{$ifdef HASVARIANT}
|
|
|
|
Resourcestring
|
|
|
|
SNoWidestrings = 'No widestrings supported';
|
|
SNoInterfaces = 'No interfaces supported';
|
|
|
|
Procedure NoWidestrings;
|
|
|
|
begin
|
|
Raise Exception.Create(SNoWideStrings);
|
|
end;
|
|
|
|
Procedure NoInterfaces;
|
|
|
|
begin
|
|
Raise Exception.Create(SNoInterfaces);
|
|
end;
|
|
|
|
Constructor EVariantError.CreateCode (Code : longint);
|
|
|
|
begin
|
|
ErrCode:=Code;
|
|
end;
|
|
|
|
Procedure VariantTypeMismatch;
|
|
|
|
begin
|
|
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
|
|
---------------------------------------------------------------------}
|
|
|
|
Function VariantToSmallInt(Const VargSrc : TVarData) : SmallInt;
|
|
|
|
begin
|
|
With VargSrc do
|
|
Case (VType and VarTypeMask) of
|
|
VarSmallInt: Result:=VSmallInt;
|
|
VarShortInt: Result:=VShortInt;
|
|
VarInteger : Result:=VInteger;
|
|
VarSingle : Result:=Round(VSingle);
|
|
VarDouble : Result:=Round(VDouble);
|
|
VarCurrency: Result:=Round(VCurrency);
|
|
VarDate : Result:=Round(VDate);
|
|
VarOleStr : Result:=StrToInt(WideCharToString(vOleStr));
|
|
VarBoolean : Result:=SmallInt(VBoolean);
|
|
VarByte : Result:=VByte;
|
|
VarWord : Result:=VWord;
|
|
VarLongWord : Result:=VLongWord;
|
|
VarInt64 : Result:=VInt64;
|
|
VarQword : Result:=VQWord;
|
|
else
|
|
VariantTypeMismatch;
|
|
end;
|
|
end;
|
|
|
|
Function VariantToShortInt(Const VargSrc : TVarData) : ShortInt;
|
|
|
|
begin
|
|
With VargSrc do
|
|
Case (VType and VarTypeMask) of
|
|
VarSmallInt: Result:=VSmallInt;
|
|
VarShortInt: Result:=VShortInt;
|
|
VarInteger : Result:=VInteger;
|
|
VarSingle : Result:=Round(VSingle);
|
|
VarDouble : Result:=Round(VDouble);
|
|
VarCurrency: Result:=Round(VCurrency);
|
|
VarDate : Result:=Round(VDate);
|
|
VarOleStr : Result:=StrToInt(WideCharToString(vOleStr));
|
|
VarBoolean : Result:=SmallInt(VBoolean);
|
|
VarByte : Result:=VByte;
|
|
VarWord : Result:=VWord;
|
|
VarLongWord : Result:=VLongWord;
|
|
VarInt64 : Result:=VInt64;
|
|
VarQword : Result:=VQWord;
|
|
else
|
|
VariantTypeMismatch;
|
|
end;
|
|
end;
|
|
|
|
Function VariantToLongint(Const VargSrc : TVarData) : Longint;
|
|
|
|
begin
|
|
With VargSrc do
|
|
Case (VType and VarTypeMask) of
|
|
VarSmallInt: Result:=VSmallInt;
|
|
VarShortInt: Result:=VShortInt;
|
|
VarInteger : Result:=VInteger;
|
|
VarSingle : Result:=Round(VSingle);
|
|
VarDouble : Result:=Round(VDouble);
|
|
VarCurrency: Result:=Round(VCurrency);
|
|
VarDate : Result:=Round(VDate);
|
|
VarOleStr : Result:=StrToInt(WideCharToString(vOleStr));
|
|
VarBoolean : Result:=Longint(VBoolean);
|
|
VarByte : Result:=VByte;
|
|
VarWord : Result:=VWord;
|
|
VarLongWord : Result:=VLongWord;
|
|
VarInt64 : Result:=VInt64;
|
|
VarQword : Result:=VQWord;
|
|
else
|
|
VariantTypeMismatch;
|
|
end;
|
|
end;
|
|
|
|
Function VariantToCardinal(Const VargSrc : TVarData) : Cardinal;
|
|
|
|
begin
|
|
With VargSrc do
|
|
Case (VType and VarTypeMask) of
|
|
VarSmallInt: Result:=VSmallInt;
|
|
VarShortInt: Result:=VShortInt;
|
|
VarInteger : Result:=VInteger;
|
|
VarSingle : Result:=Round(VSingle);
|
|
VarDouble : Result:=Round(VDouble);
|
|
VarCurrency: Result:=Round(VCurrency);
|
|
VarDate : Result:=Round(VDate);
|
|
VarOleStr : Result:=StrToInt(WideCharToString(vOleStr));
|
|
VarBoolean : Result:=Longint(VBoolean);
|
|
VarByte : Result:=VByte;
|
|
VarWord : Result:=VWord;
|
|
VarLongWord : Result:=VLongWord;
|
|
VarInt64 : Result:=VInt64;
|
|
VarQword : Result:=VQWord;
|
|
else
|
|
VariantTypeMismatch;
|
|
end;
|
|
end;
|
|
|
|
Function VariantToSingle(Const VargSrc : TVarData) : Single;
|
|
|
|
begin
|
|
With VargSrc do
|
|
Case (VType and VarTypeMask) of
|
|
VarSmallInt: Result:=VSmallInt;
|
|
VarShortInt: Result:=VShortInt;
|
|
VarInteger : Result:=VInteger;
|
|
VarSingle : Result:=VSingle;
|
|
VarDouble : Result:=VDouble;
|
|
VarCurrency: Result:=VCurrency;
|
|
VarDate : Result:=VDate;
|
|
VarOleStr : NoWideStrings;
|
|
VarBoolean : Result:=Longint(VBoolean);
|
|
VarByte : Result:=VByte;
|
|
VarWord : Result:=VWord;
|
|
VarLongWord : Result:=VLongWord;
|
|
VarInt64 : Result:=VInt64;
|
|
VarQword : Result:=VQWord;
|
|
else
|
|
VariantTypeMismatch;
|
|
end;
|
|
end;
|
|
|
|
Function VariantToDouble(Const VargSrc : TVarData) : Double;
|
|
|
|
begin
|
|
With VargSrc do
|
|
Case (VType and VarTypeMask) of
|
|
VarSmallInt: Result:=VSmallInt;
|
|
VarShortInt: Result:=VShortInt;
|
|
VarInteger : Result:=VInteger;
|
|
VarSingle : Result:=VSingle;
|
|
VarDouble : Result:=VDouble;
|
|
VarCurrency: Result:=VCurrency;
|
|
VarDate : Result:=VDate;
|
|
VarOleStr : NoWideStrings;
|
|
VarBoolean : Result:=Longint(VBoolean);
|
|
VarByte : Result:=VByte;
|
|
VarWord : Result:=VWord;
|
|
VarLongWord : Result:=VLongWord;
|
|
VarInt64 : Result:=VInt64;
|
|
VarQword : Result:=VQWord;
|
|
else
|
|
VariantTypeMismatch;
|
|
end;
|
|
end;
|
|
|
|
Function VariantToCurrency(Const VargSrc : TVarData) : Currency;
|
|
|
|
begin
|
|
Try
|
|
With VargSrc do
|
|
Case (VType and VarTypeMask) of
|
|
VarSmallInt: Result:=VSmallInt;
|
|
VarShortInt: Result:=VShortInt;
|
|
VarInteger : Result:=VInteger;
|
|
VarSingle : Result:=FloatToCurr(VSingle);
|
|
VarDouble : Result:=FloatToCurr(VDouble);
|
|
VarCurrency: Result:=VCurrency;
|
|
VarDate : Result:=FloatToCurr(VDate);
|
|
VarOleStr : NoWideStrings;
|
|
VarBoolean : Result:=Longint(VBoolean);
|
|
VarByte : Result:=VByte;
|
|
VarWord : Result:=VWord;
|
|
VarLongWord : Result:=VLongWord;
|
|
VarInt64 : Result:=VInt64;
|
|
VarQword : Result:=VQWord;
|
|
else
|
|
VariantTypeMismatch;
|
|
end;
|
|
except
|
|
On EConvertError do
|
|
VariantTypeMismatch;
|
|
else
|
|
Raise;
|
|
end;
|
|
end;
|
|
|
|
|
|
Function VariantToDate(Const VargSrc : TVarData) : TDateTime;
|
|
|
|
begin
|
|
Try
|
|
With VargSrc do
|
|
Case (VType and VarTypeMask) of
|
|
VarSmallInt: Result:=FloatToDateTime(VSmallInt);
|
|
VarShortInt: Result:=FloatToDateTime(VShortInt);
|
|
VarInteger : Result:=FloatToDateTime(VInteger);
|
|
VarSingle : Result:=FloatToDateTime(VSingle);
|
|
VarDouble : Result:=FloatToDateTime(VDouble);
|
|
VarCurrency: Result:=FloatToDateTime(VCurrency);
|
|
VarDate : Result:=VDate;
|
|
VarOleStr : NoWideStrings;
|
|
VarBoolean : Result:=FloatToDateTime(Longint(VBoolean));
|
|
VarByte : Result:=FloatToDateTime(VByte);
|
|
VarWord : Result:=FloatToDateTime(VWord);
|
|
VarLongWord : Result:=FloatToDateTime(VLongWord);
|
|
VarInt64 : Result:=FloatToDateTime(VInt64);
|
|
VarQWord : Result:=FloatToDateTime(VQword);
|
|
else
|
|
VariantTypeMismatch;
|
|
end;
|
|
except
|
|
On EConvertError do
|
|
VariantTypeMismatch;
|
|
else
|
|
Raise;
|
|
end;
|
|
end;
|
|
|
|
Function VariantToBoolean(Const VargSrc : TVarData) : Boolean;
|
|
|
|
begin
|
|
With VargSrc do
|
|
Case (VType and VarTypeMask) of
|
|
VarSmallInt: Result:=VSmallInt<>0;
|
|
VarShortInt: Result:=VShortInt<>0;
|
|
VarInteger : Result:=VInteger<>0;
|
|
VarSingle : Result:=VSingle<>0;
|
|
VarDouble : Result:=VDouble<>0;
|
|
VarCurrency: Result:=VCurrency<>0;
|
|
VarDate : Result:=VDate<>0;
|
|
VarOleStr : NoWideStrings;
|
|
VarBoolean : Result:=VBoolean;
|
|
VarByte : Result:=VByte<>0;
|
|
VarWord : Result:=VWord<>0;
|
|
VarLongWord : Result:=VLongWord<>0;
|
|
VarInt64 : Result:=Vint64<>0;
|
|
VarQword : Result:=VQWord<>0;
|
|
else
|
|
VariantTypeMismatch;
|
|
end;
|
|
end;
|
|
|
|
Function VariantToByte(Const VargSrc : TVarData) : Byte;
|
|
|
|
begin
|
|
Try
|
|
With VargSrc do
|
|
Case (VType and VarTypeMask) of
|
|
VarSmallInt: Result:=VSmallInt;
|
|
VarShortInt: Result:=VShortInt;
|
|
VarInteger : Result:=VInteger;
|
|
VarSingle : Result:=Round(VSingle);
|
|
VarDouble : Result:=Round(VDouble);
|
|
VarCurrency: Result:=Round(VCurrency);
|
|
VarDate : Result:=Round(VDate);
|
|
VarOleStr : NoWideStrings;
|
|
VarBoolean : Result:=Longint(VBoolean);
|
|
VarByte : Result:=VByte;
|
|
VarWord : Result:=VWord;
|
|
VarLongWord : Result:=VLongWord;
|
|
VarInt64 : Result:=Vint64;
|
|
VarQword : Result:=VQWord;
|
|
else
|
|
VariantTypeMismatch;
|
|
end;
|
|
except
|
|
On EConvertError do
|
|
VariantTypeMismatch;
|
|
else
|
|
Raise;
|
|
end;
|
|
end;
|
|
|
|
Function VariantToInt64(Const VargSrc : TVarData) : Int64;
|
|
|
|
begin
|
|
Try
|
|
With VargSrc do
|
|
Case (VType and VarTypeMask) of
|
|
VarSmallInt: Result:=VSmallInt;
|
|
VarShortInt: Result:=VShortInt;
|
|
VarInteger : Result:=VInteger;
|
|
VarSingle : Result:=Trunc(VSingle);
|
|
VarDouble : Result:=Trunc(VDouble);
|
|
{$ifdef HASCURRENCY}
|
|
VarCurrency: Result:=Trunc(VCurrency);
|
|
{$else}
|
|
VarCurrency: Result:=VCurrency;
|
|
{$endif}
|
|
VarDate : Result:=Trunc(VDate);
|
|
VarOleStr : NoWideStrings;
|
|
VarBoolean : Result:=Longint(VBoolean);
|
|
VarByte : Result:=VByte;
|
|
VarWord : Result:=VWord;
|
|
VarLongWord : Result:=VLongWord;
|
|
VarInt64 : Result:=VInt64;
|
|
VarQword : Result:=VQWord;
|
|
else
|
|
VariantTypeMismatch;
|
|
end;
|
|
except
|
|
On EConvertError do
|
|
VariantTypeMismatch;
|
|
else
|
|
Raise;
|
|
end;
|
|
end;
|
|
|
|
Function VariantToQWord(Const VargSrc : TVarData) : QWord;
|
|
|
|
begin
|
|
Try
|
|
With VargSrc do
|
|
Case (VType and VarTypeMask) of
|
|
VarSmallInt: Result:=VSmallint;
|
|
VarShortInt: Result:=VShortInt;
|
|
VarInteger : Result:=VInteger;
|
|
VarSingle : Result:=Trunc(VSingle);
|
|
VarDouble : Result:=Trunc(VDouble);
|
|
{$ifdef HASCURRENCY}
|
|
VarCurrency: Result:=Trunc(VCurrency);
|
|
{$else}
|
|
VarCurrency: Result:=VCurrency;
|
|
{$endif}
|
|
VarDate : Result:=Trunc(VDate);
|
|
VarOleStr : NoWideStrings;
|
|
VarBoolean : Result:=Longint(VBoolean);
|
|
VarByte : Result:=VByte;
|
|
VarWord : Result:=VWord;
|
|
VarLongWord : Result:=VLongWord;
|
|
VarInt64 : Result:=VInt64;
|
|
VarQword : Result:=VQWord;
|
|
else
|
|
VariantTypeMismatch;
|
|
end;
|
|
except
|
|
On EConvertError do
|
|
VariantTypeMismatch;
|
|
else
|
|
Raise;
|
|
end;
|
|
end;
|
|
|
|
Function VariantToWideString(Const VargSrc : TVarData) : WideString;
|
|
|
|
Const
|
|
BS : Array[Boolean] of WideString = ('False','True');
|
|
|
|
begin
|
|
Try
|
|
With VargSrc do
|
|
Case (VType and VarTypeMask) of
|
|
VarSmallInt : Result:=IntTostr(VSmallint);
|
|
VarShortInt : Result:=IntToStr(VShortInt);
|
|
VarInteger : Result:=IntToStr(VInteger);
|
|
VarSingle : Result:=FloatToStr(VSingle);
|
|
VarDouble : Result:=FloatToStr(VDouble);
|
|
VarCurrency : Result:=FloatToStr(VCurrency);
|
|
VarDate : Result:=DateTimeToStr(VDate);
|
|
VarOleStr : Result:=WideString(Pointer(VOleStr));
|
|
VarBoolean : Result:=BS[VBoolean];
|
|
VarByte : Result:=IntToStr(VByte);
|
|
VarWord : Result:=IntToStr(VWord);
|
|
VarLongWord : Result:=IntToStr(VLongWord);
|
|
VarInt64 : Result:=IntToStr(VInt64);
|
|
VarQword : Result:=IntToStr(VQWord);
|
|
else
|
|
VariantTypeMismatch;
|
|
end;
|
|
except
|
|
On EConvertError do
|
|
VariantTypeMismatch;
|
|
else
|
|
Raise;
|
|
end;
|
|
end;
|
|
|
|
Function VariantToAnsiString(Const VargSrc : TVarData) : AnsiString;
|
|
|
|
Const
|
|
BS : Array[Boolean] of AnsiString = ('False','True');
|
|
|
|
begin
|
|
Try
|
|
With VargSrc do
|
|
Case (VType and VarTypeMask) of
|
|
VarSmallInt : Result:=IntTostr(VSmallint);
|
|
VarShortInt : Result:=IntToStr(VShortInt);
|
|
VarInteger : Result:=IntToStr(VInteger);
|
|
VarSingle : Result:=FloatToStr(VSingle);
|
|
VarDouble : Result:=FloatToStr(VDouble);
|
|
VarCurrency : Result:=FloatToStr(VCurrency);
|
|
VarDate : Result:=DateTimeToStr(VDate);
|
|
VarOleStr : Result:=WideCharToString(VOleStr);
|
|
VarBoolean : Result:=BS[VBoolean];
|
|
VarByte : Result:=IntToStr(VByte);
|
|
VarWord : Result:=IntToStr(VWord);
|
|
VarLongWord : Result:=IntToStr(VLongWord);
|
|
VarInt64 : Result:=IntToStr(VInt64);
|
|
VarQword : Result:=IntToStr(VQWord);
|
|
else
|
|
VariantTypeMismatch;
|
|
end;
|
|
except
|
|
On EConvertError do
|
|
VariantTypeMismatch;
|
|
else
|
|
Raise;
|
|
end;
|
|
end;
|
|
|
|
Function VariantToShortString(Const VargSrc : TVarData) : ShortString;
|
|
|
|
Var
|
|
S : AnsiString;
|
|
|
|
begin
|
|
S:=VariantToAnsiString(VArgSrc);
|
|
Result:=S;
|
|
end;
|
|
|
|
{ ---------------------------------------------------------------------
|
|
Some debug routines
|
|
---------------------------------------------------------------------}
|
|
|
|
|
|
Procedure DumpVariant(Const VArgSrc : TVarData);
|
|
|
|
begin
|
|
DumpVariant(Output,VArgSrc);
|
|
end;
|
|
|
|
(*
|
|
tvardata = packed record
|
|
vtype : tvartype;
|
|
case integer of
|
|
0:(res1 : word;
|
|
case integer of
|
|
0:
|
|
(res2,res3 : word;
|
|
case word of
|
|
varsmallint : (vsmallint : smallint);
|
|
varinteger : (vinteger : longint);
|
|
varsingle : (vsingle : single);
|
|
vardouble : (vdouble : double);
|
|
varcurrency : (vcurrency : currency);
|
|
vardate : (vdate : tdatetime);
|
|
varolestr : (volestr : pwidechar);
|
|
vardispatch : (vdispatch : pointer);
|
|
varerror : (verror : dword);
|
|
varboolean : (vboolean : wordbool);
|
|
varunknown : (vunknown : pointer);
|
|
// vardecimal : ( : );
|
|
varshortint : (vshortint : shortint);
|
|
varbyte : (vbyte : byte);
|
|
varword : (vword : word);
|
|
varlongword : (vlongword : dword);
|
|
varint64 : (vint64 : int64);
|
|
varqword : (vqword : qword);
|
|
varword64 : (vword64 : qword);
|
|
varstring : (vstring : pointer);
|
|
varany : (vany : pointer);
|
|
vararray : (varray : pvararray);
|
|
varbyref : (vpointer : pointer);
|
|
);
|
|
1:
|
|
(vlongs : array[0..2] of longint);
|
|
);
|
|
1:(vwords : array[0..6] of word);
|
|
2:(vbytes : array[0..13] of byte);
|
|
end;
|
|
|
|
*)
|
|
|
|
Const
|
|
VarTypeStrings : Array [varEmpty..varqword] of string = (
|
|
'empty', 'null', 'smallint', 'integer', 'single', 'double',
|
|
'currency', 'date', 'olestr', 'dispatch', 'error', 'boolean',
|
|
'variant', 'unknown', 'unknown','decimal', 'shortint', 'byte', 'word',
|
|
'longword', 'int64', 'qword');
|
|
|
|
Procedure DumpVariant(Var F : Text; Const VArgSrc : TVarData);
|
|
|
|
Var
|
|
W : WideString;
|
|
|
|
begin
|
|
If VArgSrc.vType in [varEmpty..varqword] then
|
|
Writeln(F,'Variant has type : ',VarTypeStrings[VArgSrc.vType])
|
|
else if (VArgSrc.vType=VarArray) Then
|
|
begin
|
|
Write(F,'Variant is array.');
|
|
exit;
|
|
end
|
|
else if (VargSrc.vType=VarByRef) then
|
|
begin
|
|
Writeln(F,'Variant is by reference.');
|
|
exit;
|
|
end
|
|
else
|
|
begin
|
|
Writeln(F,'Variant has unknown type: ', VargSrc.vType);
|
|
Exit;
|
|
end;
|
|
If VArgSrc.vType<>varEmpty then
|
|
With VArgSrc do
|
|
begin
|
|
Write(F,'Value is: ') ;
|
|
Case vtype of
|
|
varnull : Write(F,'Null');
|
|
varsmallint : Write(F,vsmallint);
|
|
varinteger : Write(F,vinteger);
|
|
varsingle : Write(F,vsingle);
|
|
vardouble : Write(F,vdouble);
|
|
varcurrency : Write(F,vcurrency) ;
|
|
vardate : Write(F,vdate) ;
|
|
varolestr : begin
|
|
W:=vOleStr;
|
|
Write(F,W) ;
|
|
end;
|
|
vardispatch : Write(F,'Not suppordted') ;
|
|
varerror : Write(F,'Error') ;
|
|
varboolean : Write(F,vboolean) ;
|
|
varvariant : Write(F,'Unsupported') ;
|
|
varunknown : Write(F,'Unsupported') ;
|
|
vardecimal : Write(F,'Unsupported') ;
|
|
varshortint : Write(F,vshortint) ;
|
|
varbyte : Write(F,vbyte) ;
|
|
varword : Write(F,vword) ;
|
|
varlongword : Write(F,vlongword) ;
|
|
varint64 : Write(F,vint64) ;
|
|
varqword : Write(F,vqword) ;
|
|
end;
|
|
Writeln(f);
|
|
end;
|
|
end;
|
|
|
|
{$endif HASVARIANT}
|
|
|
|
{
|
|
$Log$
|
|
Revision 1.10 2003-11-04 23:15:58 michael
|
|
Support for ansistring and better debug outpu
|
|
|
|
Revision 1.9 2003/11/04 22:53:55 michael
|
|
+ Removed debug statements
|
|
|
|
Revision 1.8 2003/11/04 22:27:43 michael
|
|
+ Some fixes for string support
|
|
|
|
Revision 1.7 2002/09/07 16:01:22 peter
|
|
* old logs removed and tabs fixed
|
|
|
|
Revision 1.6 2002/07/01 16:25:10 peter
|
|
* currency updates
|
|
|
|
}
|