mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-10-31 05:51:48 +01:00
4659 lines
131 KiB
ObjectPascal
4659 lines
131 KiB
ObjectPascal
{
|
|
This include file contains the variants
|
|
support for FPC
|
|
|
|
This file is part of the Free Pascal run time library.
|
|
Copyright (c) 2001-2005 by the Free Pascal development team
|
|
|
|
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 fpc}
|
|
{$mode objfpc}
|
|
{$ENDIF}
|
|
{$h+}
|
|
|
|
{ Using inlining for small system functions/wrappers }
|
|
{$inline on}
|
|
{$define VARIANTINLINE}
|
|
|
|
unit variants;
|
|
|
|
interface
|
|
|
|
uses
|
|
sysutils,sysconst,rtlconsts,typinfo;
|
|
|
|
type
|
|
EVariantParamNotFoundError = class(EVariantError);
|
|
EVariantInvalidOpError = class(EVariantError);
|
|
EVariantTypeCastError = class(EVariantError);
|
|
EVariantOverflowError = class(EVariantError);
|
|
EVariantInvalidArgError = class(EVariantError);
|
|
EVariantBadVarTypeError = class(EVariantError);
|
|
EVariantBadIndexError = class(EVariantError);
|
|
EVariantArrayLockedError = class(EVariantError);
|
|
EVariantNotAnArrayError = class(EVariantError);
|
|
EVariantArrayCreateError = class(EVariantError);
|
|
EVariantNotImplError = class(EVariantError);
|
|
EVariantOutOfMemoryError = class(EVariantError);
|
|
EVariantUnexpectedError = class(EVariantError);
|
|
EVariantDispatchError = class(EVariantError);
|
|
EVariantRangeCheckError = class(EVariantOverflowError);
|
|
EVariantInvalidNullOpError = class(EVariantInvalidOpError);
|
|
|
|
TVariantRelationship = (vrEqual, vrLessThan, vrGreaterThan, vrNotEqual);
|
|
TNullCompareRule = (ncrError, ncrStrict, ncrLoose);
|
|
TBooleanToStringRule = (bsrAsIs, bsrLower, bsrUpper);
|
|
|
|
Const
|
|
OrdinalVarTypes = [varSmallInt, varInteger, varBoolean, varShortInt,
|
|
varByte, varWord,varLongWord,varInt64];
|
|
FloatVarTypes = [
|
|
{$ifndef FPUNONE}
|
|
varSingle, varDouble,
|
|
{$endif}
|
|
varCurrency];
|
|
|
|
{ Variant support procedures and functions }
|
|
|
|
function VarType(const V: Variant): TVarType; inline;
|
|
function VarTypeDeRef(const V: Variant): TVarType; overload;
|
|
function VarTypeDeRef(const V: TVarData): TVarType; overload; inline;
|
|
function VarAsType(const V: Variant; aVarType: TVarType): Variant;
|
|
function VarIsType(const V: Variant; aVarType: TVarType): Boolean; overload; inline;
|
|
function VarIsType(const V: Variant; const AVarTypes: array of TVarType): Boolean; overload;
|
|
function VarIsByRef(const V: Variant): Boolean; inline;
|
|
|
|
function VarIsEmpty(const V: Variant): Boolean; inline;
|
|
procedure VarCheckEmpty(const V: Variant); inline;
|
|
function VarIsNull(const V: Variant): Boolean; inline;
|
|
function VarIsClear(const V: Variant): Boolean; inline;
|
|
|
|
function VarIsCustom(const V: Variant): Boolean; inline;
|
|
function VarIsOrdinal(const V: Variant): Boolean; inline;
|
|
function VarIsFloat(const V: Variant): Boolean; inline;
|
|
function VarIsNumeric(const V: Variant): Boolean; inline;
|
|
function VarIsStr(const V: Variant): Boolean;
|
|
|
|
function VarToStr(const V: Variant): string;
|
|
function VarToStrDef(const V: Variant; const ADefault: string): string;
|
|
function VarToWideStr(const V: Variant): WideString;
|
|
function VarToWideStrDef(const V: Variant; const ADefault: WideString): WideString;
|
|
function VarToUnicodeStr(const V: Variant): UnicodeString;
|
|
function VarToUnicodeStrDef(const V: Variant; const ADefault: UnicodeString): UnicodeString;
|
|
|
|
{$ifndef FPUNONE}
|
|
function VarToDateTime(const V: Variant): TDateTime;
|
|
function VarFromDateTime(const DateTime: TDateTime): Variant;
|
|
{$endif}
|
|
|
|
function VarInRange(const AValue, AMin, AMax: Variant): Boolean;
|
|
function VarEnsureRange(const AValue, AMin, AMax: Variant): Variant;
|
|
|
|
function VarSameValue(const A, B: Variant): Boolean;
|
|
function VarCompareValue(const A, B: Variant): TVariantRelationship;
|
|
|
|
function VarIsEmptyParam(const V: Variant): Boolean; inline;
|
|
|
|
procedure VarClear(var V: Variant);{$IFDEF VARIANTINLINE}inline;{$ENDIF VARIANTINLINE}
|
|
procedure VarClear(var V: OleVariant);{$IFDEF VARIANTINLINE}inline;{$ENDIF VARIANTINLINE}
|
|
|
|
procedure SetClearVarToEmptyParam(var V: TVarData);
|
|
|
|
function VarIsError(const V: Variant; out AResult: HRESULT): Boolean;
|
|
function VarIsError(const V: Variant): Boolean; inline;
|
|
function VarAsError(AResult: HRESULT): Variant;
|
|
|
|
function VarSupports(const V: Variant; const IID: TGUID; out Intf): Boolean;
|
|
function VarSupports(const V: Variant; const IID: TGUID): Boolean;
|
|
|
|
{ Variant copy support }
|
|
procedure VarCopyNoInd(var Dest: Variant; const Source: Variant);
|
|
|
|
{ Variant array support procedures and functions }
|
|
|
|
function VarArrayCreate(const Bounds: array of SizeInt; aVarType: TVarType): Variant;
|
|
function VarArrayCreate(const Bounds: PVarArrayBoundArray; Dims : SizeInt; aVarType: TVarType): Variant;
|
|
function VarArrayOf(const Values: array of Variant): Variant;
|
|
|
|
function VarArrayAsPSafeArray(const A: Variant): PVarArray;
|
|
|
|
function VarArrayDimCount(const A: Variant) : LongInt;
|
|
function VarArrayLowBound(const A: Variant; Dim : LongInt) : LongInt;
|
|
function VarArrayHighBound(const A: Variant; Dim : LongInt) : LongInt;
|
|
|
|
function VarArrayLock(const A: Variant): Pointer;
|
|
procedure VarArrayUnlock(const A: Variant);
|
|
|
|
function VarArrayRef(const A: Variant): Variant;
|
|
|
|
function VarIsArray(const A: Variant): Boolean; inline;
|
|
function VarIsArray(const A: Variant; AResolveByRef: Boolean): Boolean;
|
|
|
|
function VarTypeIsValidArrayType(const aVarType: TVarType): Boolean;
|
|
function VarTypeIsValidElementType(const aVarType: TVarType): Boolean;
|
|
|
|
{ Variant <--> Dynamic Arrays }
|
|
|
|
procedure DynArrayToVariant(var V: Variant; const DynArray: Pointer; TypeInfo: Pointer);
|
|
procedure DynArrayFromVariant(var DynArray: Pointer; const V: Variant; TypeInfo: Pointer);
|
|
|
|
{ Global constants }
|
|
|
|
function Unassigned: Variant; // Unassigned standard constant
|
|
function Null: Variant; // Null standard constant
|
|
|
|
var
|
|
EmptyParam: OleVariant;
|
|
|
|
{ Custom Variant base class }
|
|
|
|
type
|
|
TVarCompareResult = (crLessThan, crEqual, crGreaterThan);
|
|
TCustomVariantType = class(TObject, IInterface)
|
|
private
|
|
FVarType: TVarType;
|
|
protected
|
|
function QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID; out Obj): HResult; virtual; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
|
|
function _AddRef: Integer; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
|
|
function _Release: Integer; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
|
|
procedure SimplisticClear(var V: TVarData);
|
|
procedure SimplisticCopy(var Dest: TVarData; const Source: TVarData; const Indirect: Boolean = False);
|
|
procedure RaiseInvalidOp;
|
|
procedure RaiseCastError;
|
|
procedure RaiseDispError;
|
|
function LeftPromotion(const V: TVarData; const Operation: TVarOp; out RequiredVarType: TVarType): Boolean; virtual;
|
|
function RightPromotion(const V: TVarData; const Operation: TVarOp; out RequiredVarType: TVarType): Boolean; virtual;
|
|
function OlePromotion(const V: TVarData; out RequiredVarType: TVarType): Boolean; virtual;
|
|
procedure DispInvoke(Dest: PVarData; const Source: TVarData; CallDesc: PCallDesc; Params: Pointer); virtual;
|
|
procedure VarDataInit(var Dest: TVarData);
|
|
procedure VarDataClear(var Dest: TVarData);
|
|
procedure VarDataCopy(var Dest: TVarData; const Source: TVarData);
|
|
procedure VarDataCopyNoInd(var Dest: TVarData; const Source: TVarData);
|
|
procedure VarDataCast(var Dest: TVarData; const Source: TVarData);
|
|
procedure VarDataCastTo(var Dest: TVarData; const Source: TVarData; const aVarType: TVarType); overload;
|
|
procedure VarDataCastTo(var Dest: TVarData; const aVarType: TVarType); overload;
|
|
procedure VarDataCastToOleStr(var Dest: TVarData);
|
|
procedure VarDataFromStr(var V: TVarData; const Value: string);
|
|
procedure VarDataFromOleStr(var V: TVarData; const Value: WideString);
|
|
function VarDataToStr(const V: TVarData): string;
|
|
function VarDataIsEmptyParam(const V: TVarData): Boolean;
|
|
function VarDataIsByRef(const V: TVarData): Boolean;
|
|
function VarDataIsArray(const V: TVarData): Boolean;
|
|
function VarDataIsOrdinal(const V: TVarData): Boolean;
|
|
function VarDataIsFloat(const V: TVarData): Boolean;
|
|
function VarDataIsNumeric(const V: TVarData): Boolean;
|
|
function VarDataIsStr(const V: TVarData): Boolean;
|
|
public
|
|
constructor Create; overload;
|
|
constructor Create(RequestedVarType: TVarType); overload;
|
|
destructor Destroy; override;
|
|
function IsClear(const V: TVarData): Boolean; virtual;
|
|
procedure Cast(var Dest: TVarData; const Source: TVarData); virtual;
|
|
procedure CastTo(var Dest: TVarData; const Source: TVarData; const aVarType: TVarType); virtual;
|
|
procedure CastToOle(var Dest: TVarData; const Source: TVarData); virtual;
|
|
procedure Clear(var V: TVarData); virtual; abstract;
|
|
procedure Copy(var Dest: TVarData; const Source: TVarData; const Indirect: Boolean); virtual; abstract;
|
|
procedure BinaryOp(var Left: TVarData; const Right: TVarData; const Operation: TVarOp); virtual;
|
|
procedure UnaryOp(var Right: TVarData; const Operation: TVarOp); virtual;
|
|
function CompareOp(const Left, Right: TVarData; const Operation: TVarOp): Boolean; virtual;
|
|
procedure Compare(const Left, Right: TVarData; var Relationship: TVarCompareResult); virtual;
|
|
property VarType: TVarType read FVarType;
|
|
end;
|
|
TCustomVariantTypeClass = class of TCustomVariantType;
|
|
|
|
TVarDataArray = array of TVarData;
|
|
IVarInvokeable = interface
|
|
['{1CB65C52-BBCB-41A6-9E58-7FB916BEEB2D}']
|
|
function DoFunction(var Dest: TVarData; const V: TVarData;
|
|
const Name: string; const Arguments: TVarDataArray): Boolean;
|
|
function DoProcedure(const V: TVarData; const Name: string;
|
|
const Arguments: TVarDataArray): Boolean;
|
|
function GetProperty(var Dest: TVarData; const V: TVarData;
|
|
const Name: string): Boolean;
|
|
function SetProperty(const V: TVarData; const Name: string;
|
|
const Value: TVarData): Boolean;
|
|
end;
|
|
|
|
TInvokeableVariantType = class(TCustomVariantType, IVarInvokeable)
|
|
protected
|
|
procedure DispInvoke(Dest: PVarData; const Source: TVarData;
|
|
CallDesc: PCallDesc; Params: Pointer); override;
|
|
public
|
|
{ IVarInvokeable }
|
|
function DoFunction(var Dest: TVarData; const V: TVarData;
|
|
const Name: string; const Arguments: TVarDataArray): Boolean; virtual;
|
|
function DoProcedure(const V: TVarData; const Name: string;
|
|
const Arguments: TVarDataArray): Boolean; virtual;
|
|
function GetProperty(var Dest: TVarData; const V: TVarData;
|
|
const Name: string): Boolean; virtual;
|
|
function SetProperty(const V: TVarData; const Name: string;
|
|
const Value: TVarData): Boolean; virtual;
|
|
end;
|
|
|
|
IVarInstanceReference = interface
|
|
['{5C176802-3F89-428D-850E-9F54F50C2293}']
|
|
function GetInstance(const V: TVarData): TObject;
|
|
end;
|
|
|
|
TPublishableVariantType = class(TInvokeableVariantType, IVarInstanceReference)
|
|
protected
|
|
{ IVarInstanceReference }
|
|
function GetInstance(const V: TVarData): TObject; virtual; abstract;
|
|
public
|
|
function GetProperty(var Dest: TVarData; const V: TVarData;
|
|
const Name: string): Boolean; override;
|
|
function SetProperty(const V: TVarData; const Name: string;
|
|
const Value: TVarData): Boolean; override;
|
|
end;
|
|
|
|
function FindCustomVariantType(const aVarType: TVarType;
|
|
out CustomVariantType: TCustomVariantType): Boolean; overload;
|
|
function FindCustomVariantType(const TypeName: string;
|
|
out CustomVariantType: TCustomVariantType): Boolean; overload;
|
|
|
|
type
|
|
TAnyProc = procedure (var V: TVarData);
|
|
TVarDispProc = procedure (Dest: PVariant; const Source: Variant;
|
|
CallDesc: PCallDesc; Params: Pointer); cdecl;
|
|
|
|
Const
|
|
CMaxNumberOfCustomVarTypes = $0EFF;
|
|
CMinVarType = $0100;
|
|
CMaxVarType = CMinVarType + CMaxNumberOfCustomVarTypes;
|
|
CIncVarType = $000F;
|
|
CFirstUserType = CMinVarType + CIncVarType;
|
|
|
|
var
|
|
NullEqualityRule: TNullCompareRule = ncrLoose;
|
|
NullMagnitudeRule: TNullCompareRule = ncrLoose;
|
|
NullStrictConvert: Boolean = true;
|
|
NullAsStringValue: string = '';
|
|
PackVarCreation: Boolean = True;
|
|
{$ifndef FPUNONE}
|
|
OleVariantInt64AsDouble: Boolean = False;
|
|
{$endif}
|
|
|
|
|
|
VarDispProc: TVarDispProc;
|
|
ClearAnyProc: TAnyProc; { Handler clearing a varAny }
|
|
ChangeAnyProc: TAnyProc; { Handler to change any to Variant }
|
|
RefAnyProc: TAnyProc; { Handler to add a reference to an varAny }
|
|
InvalidCustomVariantType : TCustomVariantType;
|
|
|
|
procedure VarCastError;
|
|
procedure VarCastError(const ASourceType, ADestType: TVarType);
|
|
procedure VarCastErrorOle(const ASourceType: TVarType);
|
|
procedure VarInvalidOp;
|
|
procedure VarInvalidOp(const aLeft, aRight: TVarType; aOpCode: TVarOp);
|
|
procedure VarInvalidOp(const aRight: TVarType; aOpCode: TVarOp);
|
|
procedure VarInvalidNullOp;
|
|
procedure VarBadTypeError;
|
|
procedure VarOverflowError;
|
|
procedure VarOverflowError(const ASourceType, ADestType: TVarType);
|
|
procedure VarBadIndexError;
|
|
procedure VarArrayLockedError;
|
|
procedure VarNotImplError;
|
|
procedure VarOutOfMemoryError;
|
|
procedure VarInvalidArgError;
|
|
procedure VarInvalidArgError(AType: TVarType);
|
|
procedure VarUnexpectedError;
|
|
procedure VarRangeCheckError(const AType: TVarType);
|
|
procedure VarRangeCheckError(const ASourceType, ADestType: TVarType);
|
|
procedure VarArrayCreateError;
|
|
procedure VarResultCheck(AResult: HRESULT);{$IFDEF VARIANTINLINE}inline;{$ENDIF VARIANTINLINE}
|
|
procedure VarResultCheck(AResult: HRESULT; ASourceType, ADestType: TVarType);
|
|
procedure HandleConversionException(const ASourceType, ADestType: TVarType);
|
|
function VarTypeAsText(const AType: TVarType): string;
|
|
function FindVarData(const V: Variant): PVarData;
|
|
|
|
const
|
|
VarOpAsText : array[TVarOp] of string = (
|
|
'+', {opAdd}
|
|
'-', {opSubtract}
|
|
'*', {opMultiply}
|
|
'/', {opDivide}
|
|
'div', {opIntDivide}
|
|
'mod', {opModulus}
|
|
'shl', {opShiftLeft}
|
|
'shr', {opShiftRight}
|
|
'and', {opAnd}
|
|
'or', {opOr}
|
|
'xor', {opXor}
|
|
'', {opCompare}
|
|
'-', {opNegate}
|
|
'not', {opNot}
|
|
'=', {opCmpEq}
|
|
'<>', {opCmpNe}
|
|
'<', {opCmpLt}
|
|
'<=', {opCmpLe}
|
|
'>', {opCmpGt}
|
|
'>=', {opCmpGe}
|
|
'**' {opPower}
|
|
);
|
|
|
|
{ Typinfo unit Variant routines have been moved here, so as not to make TypInfo dependent on variants }
|
|
|
|
Function GetPropValue(Instance: TObject; const PropName: string): Variant;
|
|
Function GetPropValue(Instance: TObject; const PropName: string; PreferStrings: Boolean): Variant;
|
|
Procedure SetPropValue(Instance: TObject; const PropName: string; const Value: Variant);
|
|
Function GetVariantProp(Instance: TObject; PropInfo : PPropInfo): Variant;
|
|
Function GetVariantProp(Instance: TObject; const PropName: string): Variant;
|
|
Procedure SetVariantProp(Instance: TObject; const PropName: string; const Value: Variant);
|
|
Procedure SetVariantProp(Instance: TObject; PropInfo : PPropInfo; const Value: Variant);
|
|
|
|
|
|
{$IFDEF DEBUG_VARIANTS}
|
|
var
|
|
__DEBUG_VARIANTS: Boolean = False;
|
|
{$ENDIF}
|
|
|
|
implementation
|
|
|
|
uses
|
|
Math,
|
|
VarUtils;
|
|
|
|
var
|
|
customvarianttypes : array of TCustomVariantType;
|
|
customvarianttypelock : trtlcriticalsection;
|
|
customvariantcurrtype : LongInt;
|
|
|
|
const
|
|
{ all variants for which vType and varComplexType = 0 do not require
|
|
finalization. }
|
|
varComplexType = $BFE8;
|
|
|
|
procedure DoVarClearComplex(var v : TVarData); forward;
|
|
procedure DoVarCopy(var Dest : TVarData; const Source : TVarData); forward;
|
|
procedure DoVarCast(var aDest : TVarData; const aSource : TVarData; aVarType : LongInt); forward;
|
|
|
|
procedure DoVarClear(var v : TVarData); inline;
|
|
begin
|
|
if v.vType and varComplexType <> 0 then
|
|
DoVarClearComplex(v)
|
|
else
|
|
v.vType := varEmpty;
|
|
end;
|
|
|
|
procedure DoVarClearIfComplex(var v : TVarData); inline;
|
|
begin
|
|
if v.vType and varComplexType <> 0 then
|
|
DoVarClearComplex(v);
|
|
end;
|
|
|
|
function AlignToPtr(p : Pointer) : Pointer;inline;
|
|
begin
|
|
{$IFDEF FPC_REQUIRES_PROPER_ALIGNMENT}
|
|
Result:=align(p,SizeOf(p));
|
|
{$ELSE FPC_REQUIRES_PROPER_ALIGNMENT}
|
|
Result:=p;
|
|
{$ENDIF FPC_REQUIRES_PROPER_ALIGNMENT}
|
|
end;
|
|
|
|
|
|
{ ---------------------------------------------------------------------
|
|
String Messages
|
|
---------------------------------------------------------------------}
|
|
|
|
ResourceString
|
|
SErrVarIsEmpty = 'Variant is empty';
|
|
SErrInvalidIntegerRange = 'Invalid Integer range: %d';
|
|
|
|
{ ---------------------------------------------------------------------
|
|
Auxiliary routines
|
|
---------------------------------------------------------------------}
|
|
|
|
Procedure VariantError (Const Msg : String); inline;
|
|
begin
|
|
Raise EVariantError.Create(Msg);
|
|
end;
|
|
|
|
Procedure NotSupported(Meth: String);
|
|
begin
|
|
Raise EVariantError.CreateFmt('Method %s not yet supported.',[Meth]);
|
|
end;
|
|
|
|
type
|
|
TVariantArrayIterator = object
|
|
Bounds : PVarArrayBoundArray;
|
|
Coords : PVarArrayCoorArray;
|
|
Dims : SizeInt;
|
|
constructor Init(aDims: SizeInt; aBounds : PVarArrayBoundArray);
|
|
destructor Done;
|
|
|
|
function Next : Boolean;
|
|
{ returns true if the iterator reached the end of the variant array }
|
|
function AtEnd: Boolean;
|
|
end;
|
|
|
|
{$push}
|
|
{$r-}
|
|
|
|
constructor TVariantArrayIterator.Init(aDims: SizeInt; aBounds : PVarArrayBoundArray);
|
|
var
|
|
i : sizeint;
|
|
begin
|
|
Dims := aDims;
|
|
Bounds := aBounds;
|
|
|
|
GetMem(Coords, SizeOf(SizeInt) * Dims);
|
|
{ initialize coordinate counter }
|
|
for i:= 0 to Pred(Dims) do
|
|
Coords^[i] := Bounds^[i].LowBound;
|
|
end;
|
|
|
|
|
|
function TVariantArrayIterator.Next: Boolean;
|
|
var
|
|
Finished : Boolean;
|
|
|
|
procedure IncDim(Dim : SizeInt);
|
|
begin
|
|
if Finished then
|
|
Exit;
|
|
|
|
Inc(Coords^[Dim]);
|
|
if Coords^[Dim] >= Bounds^[Dim].LowBound + Bounds^[Dim].ElementCount then begin
|
|
Coords^[Dim]:=Bounds^[Dim].LowBound;
|
|
if Dim > 0 then
|
|
IncDim(Pred(Dim))
|
|
else
|
|
Finished := True;
|
|
end;
|
|
end;
|
|
|
|
|
|
begin
|
|
Finished := False;
|
|
IncDim(Pred(Dims));
|
|
Result := not Finished;
|
|
end;
|
|
|
|
|
|
function TVariantArrayIterator.AtEnd: Boolean;
|
|
var
|
|
i : sizeint;
|
|
begin
|
|
result:=true;
|
|
for i:=0 to Pred(Dims) do
|
|
if Coords^[i] < Bounds^[i].LowBound + Bounds^[i].ElementCount then
|
|
begin
|
|
result:=false;
|
|
exit;
|
|
end;
|
|
end;
|
|
|
|
{$pop}// {$r-} for TVariantArrayIterator
|
|
|
|
destructor TVariantArrayIterator.done;
|
|
begin
|
|
FreeMem(Coords);
|
|
end;
|
|
|
|
|
|
type
|
|
tdynarraybounds = array of SizeInt;
|
|
tdynarraycoords = tdynarraybounds;
|
|
tdynarrayelesize = tdynarraybounds;
|
|
tdynarraypositions = array of Pointer;
|
|
tdynarrayiter = object
|
|
Bounds : tdynarraybounds;
|
|
Coords : tdynarraycoords;
|
|
elesize : tdynarrayelesize;
|
|
positions : tdynarraypositions;
|
|
Dims : SizeInt;
|
|
data : Pointer;
|
|
constructor init(d : Pointer;typeInfo : Pointer;_dims: SizeInt;b : tdynarraybounds);
|
|
function next : Boolean;
|
|
destructor done;
|
|
end;
|
|
|
|
|
|
constructor tdynarrayiter.init(d : Pointer;typeInfo : Pointer;_dims: SizeInt;b : tdynarraybounds);
|
|
var
|
|
i : sizeint;
|
|
begin
|
|
Bounds:=b;
|
|
Dims:=_dims;
|
|
SetLength(Coords,Dims);
|
|
SetLength(elesize,Dims);
|
|
SetLength(positions,Dims);
|
|
positions[0]:=d;
|
|
{ initialize coordinate counter and elesize }
|
|
for i:=0 to Dims-1 do
|
|
begin
|
|
Coords[i]:=0;
|
|
if i>0 then
|
|
positions[i]:=Pointer(positions[i-1]^);
|
|
{ skip kind and name }
|
|
typeInfo:=aligntoptr(typeInfo+2+Length(PTypeInfo(typeInfo)^.Name));
|
|
|
|
elesize[i]:=PTypeData(typeInfo)^.elSize;
|
|
typeInfo:=PTypeData(typeInfo)^.elType2;
|
|
end;
|
|
data:=positions[Dims-1];
|
|
end;
|
|
|
|
|
|
function tdynarrayiter.next : Boolean;
|
|
var
|
|
Finished : Boolean;
|
|
|
|
procedure incdim(d : SizeInt);
|
|
begin
|
|
if Finished then
|
|
exit;
|
|
inc(Coords[d]);
|
|
inc(Pointer(positions[d]),elesize[d]);
|
|
|
|
if Coords[d]>=Bounds[d] then
|
|
begin
|
|
Coords[d]:=0;
|
|
if d>0 then
|
|
begin
|
|
incdim(d-1);
|
|
positions[d]:=Pointer(positions[d-1]^);
|
|
end
|
|
else
|
|
Finished:=true;
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
Finished:=False;
|
|
incdim(Dims-1);
|
|
data:=positions[Dims-1];
|
|
Result:=not(Finished);
|
|
end;
|
|
|
|
|
|
destructor tdynarrayiter.done;
|
|
begin
|
|
Bounds:=nil;
|
|
Coords:=nil;
|
|
elesize:=nil;
|
|
positions:=nil;
|
|
end;
|
|
|
|
{ ---------------------------------------------------------------------
|
|
VariantManager support
|
|
---------------------------------------------------------------------}
|
|
|
|
procedure sysvarinit(var v : Variant);
|
|
begin
|
|
TVarData(V).vType := varEmpty;
|
|
end;
|
|
|
|
|
|
procedure sysvarclear(var v : Variant);
|
|
begin
|
|
if TVarData(v).vType and varComplexType <> 0 then
|
|
VarClearProc(TVarData(V))
|
|
else
|
|
TVarData(v).vType := varEmpty;
|
|
end;
|
|
|
|
|
|
function Sysvartoint (const v : Variant) : Integer;
|
|
begin
|
|
if VarType(v) = varNull then
|
|
if NullStrictConvert then
|
|
VarCastError(varNull, varInt64)
|
|
else
|
|
Result := 0
|
|
else
|
|
Result := VariantToLongInt(TVarData(V));
|
|
end;
|
|
|
|
function Sysvartoint64 (const v : Variant) : Int64;
|
|
begin
|
|
if VarType(v) = varNull then
|
|
if NullStrictConvert then
|
|
VarCastError(varNull, varInt64)
|
|
else
|
|
Result := 0
|
|
else
|
|
Result := VariantToInt64(TVarData(V));
|
|
end;
|
|
|
|
|
|
function sysvartoword64 (const v : Variant) : QWord;
|
|
begin
|
|
if VarType(v) = varNull then
|
|
if NullStrictConvert then
|
|
VarCastError(varNull, varQWord)
|
|
else
|
|
Result := 0
|
|
else
|
|
Result := VariantToQWord (TVarData(V));
|
|
end;
|
|
|
|
|
|
function sysvartobool (const v : Variant) : Boolean;
|
|
begin
|
|
if VarType(v) = varNull then
|
|
if NullStrictConvert then
|
|
VarCastError(varNull, varBoolean)
|
|
else
|
|
Result := False
|
|
else
|
|
Result := VariantToBoolean(TVarData(V));
|
|
end;
|
|
|
|
|
|
{$ifndef FPUNONE}
|
|
function sysvartoreal (const v : Variant) : Extended;
|
|
var Handler: TCustomVariantType;
|
|
dest: TVarData;
|
|
begin
|
|
if VarType(v) = varNull then
|
|
if NullStrictConvert then
|
|
VarCastError(varNull, varDouble)
|
|
else
|
|
Result := 0
|
|
{ TODO: performance: custom variants must be handled after standard ones }
|
|
else if FindCustomVariantType(TVarData(v).vType, Handler) then
|
|
begin
|
|
VariantInit(dest);
|
|
Handler.CastTo(dest, TVarData(v), varDouble);
|
|
Result := dest.vDouble;
|
|
end
|
|
else
|
|
Result := VariantToDouble(TVarData(V));
|
|
end;
|
|
{$endif}
|
|
|
|
|
|
function sysvartocurr (const v : Variant) : Currency;
|
|
begin
|
|
if VarType(v) = varNull then
|
|
if NullStrictConvert then
|
|
VarCastError(varNull, varCurrency)
|
|
else
|
|
Result := 0
|
|
else
|
|
Result := VariantToCurrency(TVarData(V));
|
|
end;
|
|
|
|
function CustomVarToLStr(const v: TVarData; out s: AnsiString): Boolean;
|
|
var
|
|
handler: TCustomVariantType;
|
|
temp: TVarData;
|
|
begin
|
|
result := FindCustomVariantType(v.vType, handler);
|
|
if result then
|
|
begin
|
|
VariantInit(temp);
|
|
handler.CastTo(temp, v, varString);
|
|
{ out-semantic ensures that s is finalized,
|
|
so just copy the pointer and don't finalize the temp }
|
|
Pointer(s) := temp.vString;
|
|
end;
|
|
end;
|
|
|
|
procedure sysvartolstr (var s : AnsiString; const v : Variant);
|
|
begin
|
|
if VarType(v) = varNull then
|
|
if NullStrictConvert then
|
|
VarCastError(varNull, varString)
|
|
else
|
|
s := NullAsStringValue
|
|
{ TODO: performance: custom variants must be handled after standard ones }
|
|
else if not CustomVarToLStr(TVarData(v), s) then
|
|
S := VariantToAnsiString(TVarData(V));
|
|
end;
|
|
|
|
|
|
procedure sysvartopstr (var s; const v : Variant);
|
|
var
|
|
tmp: AnsiString;
|
|
begin
|
|
sysvartolstr(tmp, v);
|
|
ShortString(s) := tmp;
|
|
end;
|
|
|
|
|
|
procedure sysvartowstr (var s : WideString; const v : Variant);
|
|
begin
|
|
if VarType(v) = varNull then
|
|
if NullStrictConvert then
|
|
VarCastError(varNull, varOleStr)
|
|
else
|
|
s := NullAsStringValue
|
|
else
|
|
S := VariantToWideString(TVarData(V));
|
|
end;
|
|
|
|
|
|
procedure sysvartointf (var Intf : IInterface; const v : Variant);
|
|
begin
|
|
case TVarData(v).vType of
|
|
varEmpty:
|
|
Intf := nil;
|
|
varNull:
|
|
if NullStrictConvert then
|
|
VarCastError(varNull, varUnknown)
|
|
else
|
|
Intf := nil;
|
|
varUnknown:
|
|
Intf := IInterface(TVarData(v).vUnknown);
|
|
varUnknown or varByRef:
|
|
Intf := IInterface(TVarData(v).vPointer^);
|
|
varDispatch:
|
|
Intf := IInterface(TVarData(v).vDispatch);
|
|
varDispatch or varByRef:
|
|
Intf := IInterface(TVarData(v).vPointer^);
|
|
varVariant, varVariant or varByRef: begin
|
|
if not Assigned(TVarData(v).vPointer) then
|
|
VarBadTypeError;
|
|
sysvartointf(Intf, Variant(PVarData(TVarData(v).vPointer)^) );
|
|
end;
|
|
else
|
|
VarCastError(TVarData(v).vType, varUnknown);
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure sysvartodisp (var Disp : IDispatch; const v : Variant);
|
|
begin
|
|
case TVarData(v).vType of
|
|
varEmpty:
|
|
Disp := nil;
|
|
varNull:
|
|
if NullStrictConvert then
|
|
VarCastError(varNull, varDispatch)
|
|
else
|
|
Disp := nil;
|
|
varUnknown:
|
|
if IInterface(TVarData(v).vUnknown).QueryInterface(IDispatch, Disp) <> S_OK then
|
|
VarCastError(varUnknown, varDispatch);
|
|
varUnknown or varByRef:
|
|
if IInterface(TVarData(v).vPointer^).QueryInterface(IDispatch, Disp) <> S_OK then
|
|
VarCastError(varUnknown or varByRef, varDispatch);
|
|
varDispatch:
|
|
Disp := IDispatch(TVarData(v).vDispatch);
|
|
varDispatch or varByRef:
|
|
Disp := IDispatch(TVarData(v).vPointer^);
|
|
varVariant, varVariant or varByRef: begin
|
|
if not Assigned(TVarData(v).vPointer) then
|
|
VarBadTypeError;
|
|
sysvartodisp(Disp, Variant(PVarData(TVarData(v).vPointer)^) );
|
|
end;
|
|
else
|
|
VarCastError(TVarData(v).vType, varDispatch);
|
|
end;
|
|
end;
|
|
|
|
{$ifndef FPUNONE}
|
|
function sysvartotdatetime (const v : Variant) : TDateTime;
|
|
begin
|
|
if VarType(v) = varNull then
|
|
if NullStrictConvert then
|
|
VarCastError(varNull, varDate)
|
|
else
|
|
Result := 0
|
|
else
|
|
Result:=VariantToDate(TVarData(v));
|
|
end;
|
|
{$endif}
|
|
|
|
function DynamicArrayIsRectangular(p : Pointer;TypeInfo : Pointer) : Boolean;
|
|
var
|
|
arraysize,i : sizeint;
|
|
begin
|
|
Result := False;
|
|
|
|
{ get TypeInfo of second level }
|
|
{ skip kind and name }
|
|
TypeInfo:=aligntoptr(TypeInfo+2+Length(PTypeInfo(TypeInfo)^.Name));
|
|
TypeInfo:=PTypeData(TypeInfo)^.elType2;
|
|
|
|
{ check recursively? }
|
|
if assigned(TypeInfo) and (PTypeInfo(TypeInfo)^.kind=tkDynArray) then
|
|
begin
|
|
{ set to dimension of first element }
|
|
arraysize:=psizeint(ppointer(p)^-SizeOf(sizeint))^;
|
|
{ walk through all elements }
|
|
for i:=1 to psizeint(p-SizeOf(sizeint))^ do
|
|
begin
|
|
{ ... and check dimension }
|
|
if psizeint(ppointer(p)^-SizeOf(sizeint))^<>arraysize then
|
|
exit;
|
|
if not(DynamicArrayIsRectangular(ppointer(p)^,TypeInfo)) then
|
|
exit;
|
|
inc(p,SizeOf(Pointer));
|
|
end;
|
|
end;
|
|
Result:=true;
|
|
end;
|
|
|
|
procedure sysvartodynarray (var dynarr : Pointer; const v : Variant; TypeInfo : Pointer);
|
|
begin
|
|
DynArrayFromVariant(dynarr, v, TypeInfo);
|
|
end;
|
|
|
|
procedure sysvarfrombool (var Dest : Variant; const Source : Boolean);
|
|
begin
|
|
DoVarClearIfComplex(TVarData(Dest));
|
|
with TVarData(Dest) do begin
|
|
vType := varBoolean;
|
|
vBoolean := Source;
|
|
end;
|
|
end;
|
|
|
|
procedure VariantErrorInvalidIntegerRange(Range: LongInt);
|
|
begin
|
|
VariantError(Format(SErrInvalidIntegerRange,[Range]));
|
|
end;
|
|
|
|
procedure sysvarfromint (var Dest : Variant; const Source, Range : LongInt);
|
|
begin
|
|
DoVarClearIfComplex(TVarData(Dest));
|
|
with TVarData(Dest) do
|
|
if PackVarCreation then
|
|
case Range of
|
|
-4 : begin
|
|
vType := varInteger;
|
|
vInteger := Source;
|
|
end;
|
|
-2 : begin
|
|
vType := varSmallInt;
|
|
vSmallInt := Source;
|
|
end;
|
|
-1 : Begin
|
|
vType := varShortInt;
|
|
vshortint := Source;
|
|
end;
|
|
1 : begin
|
|
vType := varByte;
|
|
vByte := Source;
|
|
end;
|
|
2 : begin
|
|
vType := varWord;
|
|
vWord := Source;
|
|
end;
|
|
4 : Begin
|
|
vType := varLongWord;
|
|
{use vInteger, not vLongWord as the value came passed in as an Integer }
|
|
vInteger := Source;
|
|
end;
|
|
else
|
|
VariantErrorInvalidIntegerRange(Range);
|
|
end
|
|
else begin
|
|
vType := varInteger;
|
|
vInteger := Source;
|
|
end;
|
|
end;
|
|
|
|
procedure sysvarfromint64 (var Dest : Variant; const Source : Int64);
|
|
begin
|
|
DoVarClearIfComplex(TVarData(Dest));
|
|
with TVarData(Dest) do begin
|
|
vType := varInt64;
|
|
vInt64 := Source;
|
|
end;
|
|
end;
|
|
|
|
procedure sysvarfromword64 (var Dest : Variant; const Source : QWord);
|
|
begin
|
|
DoVarClearIfComplex(TVarData(Dest));
|
|
with TVarData(Dest) do begin
|
|
vType := varQWord;
|
|
vQWord := Source;
|
|
end;
|
|
end;
|
|
|
|
{$ifndef FPUNONE}
|
|
procedure sysvarfromreal (var Dest : Variant; const Source : Extended);
|
|
begin
|
|
DoVarClearIfComplex(TVarData(Dest));
|
|
with TVarData(Dest) do begin
|
|
vType := varDouble;
|
|
vDouble := Source;
|
|
end;
|
|
end;
|
|
|
|
procedure sysvarfromsingle (var Dest : Variant; const Source : single);
|
|
begin
|
|
DoVarClearIfComplex(TVarData(Dest));
|
|
with TVarData(Dest) do begin
|
|
vType := varSingle;
|
|
vSingle := Source;
|
|
end;
|
|
end;
|
|
|
|
procedure sysvarfromdouble (var Dest : Variant; const Source : double);
|
|
begin
|
|
DoVarClearIfComplex(TVarData(Dest));
|
|
with TVarData(Dest) do begin
|
|
vType := varDouble;
|
|
vDouble := Source;
|
|
end;
|
|
end;
|
|
{$endif}
|
|
|
|
procedure sysvarfromcurr (var Dest : Variant; const Source : Currency);
|
|
begin
|
|
DoVarClearIfComplex(TVarData(Dest));
|
|
with TVarData(Dest) do begin
|
|
vType := varCurrency;
|
|
vCurrency := Source;
|
|
end;
|
|
end;
|
|
|
|
|
|
{$ifndef FPUNONE}
|
|
procedure sysvarfromtdatetime (var Dest : Variant; const Source : TDateTime);
|
|
begin
|
|
DoVarClearIfComplex(TVarData(Dest));
|
|
with TVarData(Dest) do begin
|
|
vType := varDate;
|
|
vDate := Source;
|
|
end;
|
|
end;
|
|
{$endif}
|
|
|
|
|
|
procedure sysvarfrompstr (var Dest : Variant; const Source : ShortString);
|
|
begin
|
|
DoVarClearIfComplex(TVarData(Dest));
|
|
with TVarData(Dest) do begin
|
|
vType := varString;
|
|
vString := nil;
|
|
AnsiString(vString) := Source;
|
|
end;
|
|
end;
|
|
|
|
procedure sysvarfromlstr (var Dest : Variant; const Source : AnsiString);
|
|
begin
|
|
DoVarClearIfComplex(TVarData(Dest));
|
|
with TVarData(Dest) do begin
|
|
vType := varString;
|
|
vString := nil;
|
|
AnsiString(vString) := Source;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure sysvarfromwstr (var Dest : Variant; const Source : WideString);
|
|
begin
|
|
DoVarClearIfComplex(TVarData(Dest));
|
|
with TVarData(Dest) do begin
|
|
vType := varOleStr;
|
|
vOleStr := nil;
|
|
WideString(Pointer(vOleStr)) := Source;
|
|
end;
|
|
end;
|
|
|
|
procedure sysvarfromintf(var Dest : Variant; const Source : IInterface);
|
|
begin
|
|
DoVarClearIfComplex(TVarData(Dest));
|
|
with TVarData(Dest) do begin
|
|
vUnknown := nil;
|
|
IInterface(vUnknown) := Source;
|
|
vType := varUnknown;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure sysvarfromdisp(var Dest : Variant; const Source : IDispatch);
|
|
begin
|
|
DoVarClearIfComplex(TVarData(Dest));
|
|
with TVarData(Dest) do begin
|
|
vUnknown := nil;
|
|
IDispatch(vDispatch) := Source;
|
|
vType := varDispatch;
|
|
end;
|
|
end;
|
|
|
|
type
|
|
TCommonType = (ctEmpty,ctAny,ctError,ctLongInt,ctBoolean,
|
|
{$ifndef FPUNONE}
|
|
ctFloat,ctDate,ctCurrency,
|
|
{$endif}
|
|
ctInt64,ctNull,ctWideStr,ctString);
|
|
|
|
TCommonVarType = varEmpty..varQWord;
|
|
|
|
const
|
|
{$ifdef FPUNONE}
|
|
ctFloat = ctError;
|
|
ctDate = ctError;
|
|
ctCurrency = ctError;
|
|
{$endif}
|
|
|
|
{ get the basic type for a Variant type }
|
|
VarTypeToCommonType : array[TCommonVarType] of TCommonType =
|
|
(ctEmpty, // varEmpty = 0;
|
|
ctNull, // varNull = 1;
|
|
ctLongInt, // varSmallInt = 2;
|
|
ctLongInt, // varInteger = 3;
|
|
ctFloat, // varSingle = 4;
|
|
ctFloat, // varDouble = 5;
|
|
ctCurrency, // varCurrency = 6;
|
|
ctDate, // varDate = 7;
|
|
ctWideStr, // varOleStr = 8;
|
|
ctError, // varDispatch = 9;
|
|
ctError, // varError = 10;
|
|
ctBoolean, // varBoolean = 11;
|
|
ctError, // varVariant = 12;
|
|
ctError, // varUnknown = 13;
|
|
ctError, // ??? 15
|
|
ctError, // varDecimal = 14;
|
|
ctLongInt, // varShortInt = 16;
|
|
ctLongInt, // varByte = 17;
|
|
ctLongInt, // varWord = 18;
|
|
ctInt64, // varLongWord = 19;
|
|
ctInt64, // varInt64 = 20;
|
|
ctInt64 // varQWord = 21;
|
|
);
|
|
|
|
{ map a basic type back to a Variant type }
|
|
{ Not used yet
|
|
CommonTypeToVarType : array[TCommonType] of TVarType =
|
|
(
|
|
varEmpty,
|
|
varany,
|
|
varError,
|
|
varInteger,
|
|
varDouble,
|
|
varBoolean,
|
|
varInt64,
|
|
varNull,
|
|
varOleStr,
|
|
varDate,
|
|
varCurrency,
|
|
varString
|
|
);
|
|
}
|
|
function MapToCommonType(const vType : TVarType) : TCommonType;
|
|
begin
|
|
case vType of
|
|
Low(TCommonVarType)..High(TCommonVarType):
|
|
Result := VarTypeToCommonType[vType];
|
|
varString:
|
|
Result:=ctString;
|
|
varAny:
|
|
Result:=ctAny;
|
|
else
|
|
Result:=ctError;
|
|
end;
|
|
end;
|
|
|
|
const
|
|
FindCmpCommonType : array[TCommonType, TCommonType] of TCommonType = (
|
|
{ ctEmpty ctAny ctError ctLongInt ctBoolean ctFloat ctDate ctCurrency ctInt64 ctNull ctWideStr ctString }
|
|
({ ctEmpty } ctEmpty, ctEmpty, ctError, ctEmpty, ctEmpty, {$ifndef FPUNONE}ctEmpty, ctEmpty, ctEmpty, {$endif}ctEmpty, ctEmpty, ctEmpty, ctEmpty ),
|
|
({ ctAny } ctEmpty, ctAny, ctError, ctAny, ctAny, {$ifndef FPUNONE}ctAny, ctAny, ctAny, {$endif}ctAny, ctAny, ctAny, ctAny ),
|
|
({ ctError } ctError, ctError, ctError, ctError, ctError, {$ifndef FPUNONE}ctError, ctError, ctError, {$endif}ctError, ctError, ctError, ctError ),
|
|
({ ctLongInt } ctEmpty, ctAny, ctError, ctLongInt, ctBoolean, {$ifndef FPUNONE}ctFloat, ctDate, ctCurrency, {$endif}ctInt64, ctNull, ctFloat, ctFloat ),
|
|
({ ctBoolean } ctEmpty, ctAny, ctError, ctLongInt, ctBoolean, {$ifndef FPUNONE}ctFloat, ctDate, ctCurrency, {$endif}ctInt64, ctNull, ctWideStr, ctString ),
|
|
{$ifndef FPUNONE}
|
|
({ ctFloat } ctEmpty, ctAny, ctError, ctFloat, ctFloat, ctFloat, ctDate, ctCurrency, ctFloat, ctNull, ctFloat, ctFloat ),
|
|
({ ctDate } ctEmpty, ctAny, ctError, ctDate, ctDate, ctDate, ctDate, ctDate, ctDate, ctNull, ctDate, ctDate ),
|
|
({ ctCurrency } ctEmpty, ctAny, ctError, ctCurrency, ctCurrency, ctCurrency,ctDate, ctCurrency, ctCurrency, ctNull, ctCurrency, ctCurrency ),
|
|
{$endif}
|
|
({ ctInt64 } ctEmpty, ctAny, ctError, ctInt64, ctInt64, {$ifndef FPUNONE}ctFloat, ctDate, ctCurrency, {$endif}ctInt64, ctNull, ctFloat, ctFloat ),
|
|
({ ctNull } ctEmpty, ctAny, ctError, ctNull, ctNull, {$ifndef FPUNONE}ctNull, ctNull, ctNull, {$endif}ctNull, ctNull, ctNull, ctNull ),
|
|
({ ctWideStr } ctEmpty, ctAny, ctError, ctFloat, ctWideStr, {$ifndef FPUNONE}ctFloat, ctDate, ctCurrency, {$endif}ctFloat, ctNull, ctWideStr, ctWideStr ),
|
|
({ ctString } ctEmpty, ctAny, ctError, ctFloat, ctString, {$ifndef FPUNONE}ctFloat, ctDate, ctCurrency, {$endif}ctFloat, ctNull, ctWideStr, ctString )
|
|
);
|
|
|
|
function DoVarCmpSimple (const Left, Right, Common: TCommonType) : ShortInt; inline;
|
|
begin
|
|
if Left = Common then
|
|
if Right = Common then
|
|
Result := 0
|
|
else
|
|
Result := -1
|
|
else
|
|
Result := 1;
|
|
end;
|
|
|
|
function DoVarCmpAny(const Left, Right: TVarData; const OpCode: TVarOp) : ShortInt;
|
|
begin
|
|
VarInvalidOp(Left.vType, Right.vType, OpCode);
|
|
Result:=0;
|
|
end;
|
|
|
|
function DoVarCmpLongInt(const Left, Right: LongInt): ShortInt; inline;
|
|
begin
|
|
if Left < Right then
|
|
Result := -1
|
|
else if Left > Right then
|
|
Result := 1
|
|
else
|
|
Result := 0;
|
|
end;
|
|
|
|
{$ifndef FPUNONE}
|
|
function DoVarCmpFloat(const Left, Right: Double; const OpCode: TVarOp): ShortInt;
|
|
begin
|
|
if Left = Right then
|
|
Result := 0
|
|
else if (OpCode in [opCmpEq, opCmpNe]) or (Left < Right) then
|
|
Result := -1
|
|
else
|
|
Result := 1;
|
|
end;
|
|
{$endif}
|
|
|
|
function DoVarCmpInt64(const Left, Right: Int64): ShortInt;
|
|
begin
|
|
if Left < Right then
|
|
Result := -1
|
|
else if Left > Right then
|
|
Result := 1
|
|
else
|
|
Result := 0;
|
|
end;
|
|
|
|
function DoVarCmpNull(const Left, Right: TCommonType; const OpCode: TVarOp) : ShortInt;
|
|
const
|
|
ResultMap: array [Boolean, opCmpEq..opCmpGe] of ShortInt =
|
|
( ( -1, 0, 0, 1, 0, -1 ), ( 0, -1, -1, -1, 1, 1 ) );
|
|
begin
|
|
if OpCode in [opCmpEq, opCmpNe] then
|
|
case NullEqualityRule of
|
|
ncrError: VarInvalidNullOp;
|
|
ncrStrict: Result := ResultMap[False, OpCode];
|
|
ncrLoose: Result := ResultMap[(Left = Right) xor (OpCode = opCmpNe), OpCode];
|
|
end
|
|
else
|
|
case NullMagnitudeRule of
|
|
ncrError: VarInvalidNullOp;
|
|
ncrStrict: Result := ResultMap[False, OpCode];
|
|
ncrLoose: Result := DoVarCmpSimple(Left, Right, ctNull);
|
|
end;
|
|
end;
|
|
|
|
function DoVarCmpCurr(const Left, Right: Currency): ShortInt;
|
|
begin
|
|
if Left < Right then
|
|
Result := -1
|
|
else if Left > Right then
|
|
Result := 1
|
|
else
|
|
Result := 0;
|
|
end;
|
|
|
|
function DoVarCmpWStrDirect(const Left, Right: Pointer; const OpCode: TVarOp): ShortInt; inline;
|
|
begin
|
|
{ we can do this without ever copying the string }
|
|
if OpCode in [opCmpEq, opCmpNe] then
|
|
if Length(WideString(Left)) <> Length(WideString(Right)) then
|
|
Exit(-1);
|
|
Result := WideCompareStr(
|
|
WideString(Left),
|
|
WideString(Right)
|
|
);
|
|
end;
|
|
|
|
|
|
function DoVarCmpWStr(const Left, Right: TVarData; const OpCode: TVarOp): ShortInt;
|
|
begin
|
|
{ keep the temps away from the main proc }
|
|
Result := DoVarCmpWStrDirect(Pointer(VariantToWideString(Left)),
|
|
Pointer(VariantToWideString(Right)), OpCode);
|
|
end;
|
|
|
|
|
|
function DoVarCmpLStrDirect(const Left, Right: Pointer; const OpCode: TVarOp): ShortInt; inline;
|
|
begin
|
|
{ we can do this without ever copying the string }
|
|
if OpCode in [opCmpEq, opCmpNe] then
|
|
if Length(AnsiString(Left)) <> Length(AnsiString(Right)) then
|
|
Exit(-1);
|
|
Result := CompareStr(
|
|
AnsiString(Left),
|
|
AnsiString(Right)
|
|
);
|
|
end;
|
|
|
|
|
|
function DoVarCmpLStr(const Left, Right: TVarData; const OpCode: TVarOp): ShortInt;
|
|
begin
|
|
{ keep the temps away from the main proc }
|
|
Result := DoVarCmpLStrDirect(Pointer(VariantToAnsiString(Left)),
|
|
Pointer(VariantToAnsiString(Right)), OpCode);
|
|
end;
|
|
|
|
function DoVarCmpComplex(const Left, Right: TVarData; const OpCode: TVarOp): ShortInt;
|
|
var Handler: TCustomVariantType;
|
|
CmpRes: boolean;
|
|
begin
|
|
if (Left.vType=varnull) or (Right.vType=varnull) then
|
|
// don't bother custom variant handlers with conversion to NULL
|
|
begin
|
|
if OpCode in [opCmpEq,opCmpNe] then
|
|
begin
|
|
if (Left.vType=Right.vType) xor (OpCode=opCmpNe) then
|
|
result:=0
|
|
else
|
|
result:=-1;
|
|
end
|
|
else
|
|
if Left.vType=varnull then
|
|
begin
|
|
if Right.vType=varnull then
|
|
Result := 0
|
|
else
|
|
Result := -1;
|
|
end
|
|
else
|
|
Result := 1;
|
|
end
|
|
else
|
|
begin
|
|
if FindCustomVariantType(Left.vType, Handler) then
|
|
CmpRes := Handler.CompareOp(Left, Right, OpCode)
|
|
else if FindCustomVariantType(Right.vType, Handler) then
|
|
CmpRes := Handler.CompareOp(Left, Right, OpCode)
|
|
else
|
|
VarInvalidOp(Left.vType, Right.vType, OpCode);
|
|
|
|
case OpCode of
|
|
opCmpEq:
|
|
if CmpRes then
|
|
Result:=0
|
|
else
|
|
Result:=1;
|
|
opCmpNe:
|
|
if CmpRes then
|
|
Result:=1
|
|
else
|
|
Result:=0;
|
|
opCmpLt,
|
|
opCmpLe:
|
|
if CmpRes then
|
|
Result:=-1
|
|
else
|
|
Result:=1;
|
|
opCmpGt,
|
|
opCmpGe:
|
|
if CmpRes then
|
|
Result:=1
|
|
else
|
|
Result:=-1;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
function DoVarCmp(const vl, vr : TVarData; const OpCode : TVarOp) : ShortInt;
|
|
var
|
|
lct: TCommonType;
|
|
rct: TCommonType;
|
|
begin
|
|
{ as the function in cvarutil.inc can handle varByRef correctly we simply
|
|
resolve the final type }
|
|
lct := MapToCommonType(VarTypeDeRef(vl));
|
|
rct := MapToCommonType(VarTypeDeRef(vr));
|
|
|
|
{$IFDEF DEBUG_VARIANTS}
|
|
if __DEBUG_VARIANTS then begin
|
|
WriteLn('DoVarCmp $', IntToHex(Cardinal(@vl),8), ' ', GetEnumName(TypeInfo(TVarOp), Ord(OpCode)) ,' $', IntToHex(Cardinal(@vr),8));
|
|
DumpVariant('DoVarCmp/vl', vl);
|
|
WriteLn('lct ', GetEnumName(TypeInfo(TCommonType), Ord(lct)));
|
|
|
|
DumpVariant('DoVarCmp/vr', vr);
|
|
WriteLn('rct ', GetEnumName(TypeInfo(TCommonType), Ord(rct)));
|
|
|
|
WriteLn('common ', GetEnumName(TypeInfo(TCommonType), Ord(FindCmpCommonType[lct, rct])));
|
|
end;
|
|
{$ENDIF}
|
|
|
|
case FindCmpCommonType[lct, rct] of
|
|
ctEmpty: Result := DoVarCmpSimple(lct, rct, ctEmpty);
|
|
ctAny: Result := DoVarCmpAny(vl, vr, OpCode);
|
|
ctLongInt: Result := DoVarCmpLongInt(VariantToLongInt(vl), VariantToLongInt(vr));
|
|
{$ifndef FPUNONE}
|
|
ctFloat: Result := DoVarCmpFloat(VariantToDouble(vl), VariantToDouble(vr), OpCode);
|
|
{$endif}
|
|
ctBoolean: Result := DoVarCmpLongInt(LongInt(VariantToBoolean(vl)), LongInt(VariantToBoolean(vr)));
|
|
ctInt64: Result := DoVarCmpInt64(VariantToInt64(vl), VariantToInt64(vr));
|
|
ctNull: Result := DoVarCmpNull(lct, rct, OpCode);
|
|
ctWideStr:
|
|
if (vl.vType = varOleStr) and (vr.vType = varOleStr) then
|
|
Result := DoVarCmpWStrDirect(Pointer(vl.vOleStr), Pointer(vr.vOleStr), OpCode)
|
|
else
|
|
Result := DoVarCmpWStr(vl, vr, OpCode);
|
|
{$ifndef FPUNONE}
|
|
ctDate: Result := DoVarCmpFloat(VariantToDate(vl), VariantToDate(vr), OpCode);
|
|
ctCurrency: Result := DoVarCmpCurr(VariantToCurrency(vl), VariantToCurrency(vr));
|
|
{$endif}
|
|
ctString:
|
|
if (vl.vType = varString) and (vr.vType = varString) then
|
|
Result := DoVarCmpLStrDirect(Pointer(vl.vString), Pointer(vr.vString), OpCode)
|
|
else
|
|
Result := DoVarCmpLStr(vl, vr, OpCode);
|
|
else
|
|
Result := DoVarCmpComplex(vl, vr, OpCode);
|
|
end;
|
|
end;
|
|
|
|
function syscmpop (const Left, Right : Variant; const OpCode : TVarOp) : Boolean;
|
|
var
|
|
CmpRes : ShortInt;
|
|
begin
|
|
CmpRes:=DoVarCmp(TVarData(Left),TVarData(Right),OpCode);
|
|
case OpCode of
|
|
opCmpEq:
|
|
Result:=CmpRes=0;
|
|
opCmpNe:
|
|
Result:=CmpRes<>0;
|
|
opCmpLt:
|
|
Result:=CmpRes<0;
|
|
opCmpLe:
|
|
Result:=CmpRes<=0;
|
|
opCmpGt:
|
|
Result:=CmpRes>0;
|
|
opCmpGe:
|
|
Result:=CmpRes>=0;
|
|
else
|
|
VarInvalidOp;
|
|
end;
|
|
end;
|
|
|
|
|
|
const
|
|
FindOpCommonType : array[TCommonType,TCommonType] of TCommonType = (
|
|
{ ctEmpty ctAny ctError ctLongInt ctBoolean ctFloat ctDate ctCurrency ctInt64 ctNull ctWideStr ctString }
|
|
({ ctEmpty } ctEmpty, ctAny, ctError, ctEmpty, ctEmpty, {$ifndef FPUNONE}ctEmpty, ctEmpty, ctEmpty, {$endif}ctEmpty, ctEmpty, ctEmpty, ctEmpty ),
|
|
({ ctAny } ctAny, ctAny, ctError, ctAny, ctAny, {$ifndef FPUNONE}ctAny, ctAny, ctAny, {$endif}ctAny, ctAny, ctAny, ctAny ),
|
|
({ ctError } ctError, ctError, ctError, ctError, ctError, {$ifndef FPUNONE}ctError, ctError, ctError, {$endif}ctError, ctError, ctError, ctError ),
|
|
({ ctLongInt } ctEmpty, ctAny, ctError, ctLongInt, ctBoolean, {$ifndef FPUNONE}ctFloat, ctDate, ctCurrency, {$endif}ctInt64, ctNull, ctFloat, ctFloat ),
|
|
({ ctBoolean } ctEmpty, ctAny, ctError, ctLongInt, ctBoolean, {$ifndef FPUNONE}ctFloat, ctDate, ctCurrency, {$endif}ctInt64, ctNull, ctBoolean, ctBoolean ),
|
|
{$ifndef FPUNONE}
|
|
({ ctFloat } ctEmpty, ctAny, ctError, ctFloat, ctFloat, ctFloat, ctDate, ctCurrency, ctFloat, ctNull, ctFloat, ctFloat ),
|
|
({ ctDate } ctEmpty, ctAny, ctError, ctDate, ctDate, ctDate, ctDate, ctDate, ctDate, ctNull, ctDate, ctDate ),
|
|
({ ctCurrency } ctEmpty, ctAny, ctError, ctCurrency, ctCurrency, ctCurrency, ctDate, ctCurrency, ctCurrency, ctNull, ctCurrency, ctCurrency ),
|
|
{$endif}
|
|
({ ctInt64 } ctEmpty, ctAny, ctError, ctInt64, ctInt64, {$ifndef FPUNONE}ctFloat, ctDate, ctCurrency, {$endif}ctInt64, ctNull, ctFloat, ctFloat ),
|
|
({ ctNull } ctEmpty, ctAny, ctError, ctNull, ctNull, {$ifndef FPUNONE}ctNull, ctNull, ctNull, {$endif}ctNull, ctNull, ctNull, ctNull ),
|
|
({ ctWideStr } ctEmpty, ctAny, ctError, ctFloat, ctBoolean, {$ifndef FPUNONE}ctFloat, ctDate, ctCurrency, {$endif}ctFloat, ctNull, ctWideStr, ctWideStr ),
|
|
({ ctString } ctEmpty, ctAny, ctError, ctFloat, ctBoolean, {$ifndef FPUNONE}ctFloat, ctDate, ctCurrency, {$endif}ctFloat, ctNull, ctWideStr, ctString )
|
|
);
|
|
|
|
procedure DoVarOpFloat(var vl :TVarData; const vr : TVarData; const OpCode : TVarOp);
|
|
{$ifndef FPUNONE}
|
|
var
|
|
l, r : Double;
|
|
begin
|
|
l := VariantToDouble(vl);
|
|
r := VariantToDouble(vr);
|
|
case OpCode of
|
|
opAdd : l := l + r;
|
|
opSubtract : l := l - r;
|
|
opMultiply : l := l * r;
|
|
opDivide : l := l / r;
|
|
opPower : l := l ** r;
|
|
else
|
|
VarInvalidOp(vl.vType, vr.vType, OpCode);
|
|
end;
|
|
DoVarClearIfComplex(vl);
|
|
vl.vType := varDouble;
|
|
vl.vDouble := l;
|
|
{$else}
|
|
begin
|
|
VarInvalidOp(vl.vType, vr.vType, OpCode);
|
|
{$endif}
|
|
end;
|
|
|
|
procedure DoVarOpAny(var vl : TVarData; const vr : TVarData; const OpCode : TVarOp);
|
|
begin
|
|
VarInvalidOp(vl.vType, vr.vType, OpCode);
|
|
end;
|
|
|
|
procedure DoVarOpLongInt(var vl : TVarData; const vr : TVarData; const OpCode : TVarOp);
|
|
var
|
|
l, r: LongInt;
|
|
begin
|
|
l := VariantToLongint(vl);
|
|
r := VariantToLongint(vr);
|
|
case OpCode of
|
|
opIntDivide : l := l div r;
|
|
opModulus : l := l mod r;
|
|
opShiftLeft : l := l shl r;
|
|
opShiftRight : l := l shr r;
|
|
opAnd : l := l and r;
|
|
opOr : l := l or r;
|
|
opXor : l := l xor r;
|
|
else
|
|
VarInvalidOp(vl.vType, vr.vType, OpCode);
|
|
end;
|
|
DoVarClearIfComplex(vl);
|
|
vl.vType := varInteger;
|
|
vl.vInteger := l;
|
|
end;
|
|
|
|
procedure DoVarOpInt64(var vl : TVarData; const vr : TVarData; const OpCode : TVarOp);
|
|
var
|
|
l, r : Int64;
|
|
Overflow : Boolean;
|
|
begin
|
|
l := VariantToInt64(vl);
|
|
r := VariantToInt64(vr);
|
|
Overflow := False;
|
|
case OpCode of
|
|
{$push}
|
|
{$R+}{$Q+}
|
|
opAdd..opMultiply,opPower: try
|
|
case OpCode of
|
|
opAdd : l := l + r;
|
|
opSubtract : l := l - r;
|
|
opMultiply : l := l * r;
|
|
{$ifndef FPUNONE}
|
|
opPower : l := l ** r;
|
|
{$endif}
|
|
end;
|
|
except
|
|
on E: SysUtils.ERangeError do
|
|
Overflow := True;
|
|
on E: SysUtils.EIntOverflow do
|
|
Overflow := True;
|
|
end;
|
|
{$pop}
|
|
opIntDivide : l := l div r;
|
|
opModulus : l := l mod r;
|
|
opShiftLeft : l := l shl r;
|
|
opShiftRight : l := l shr r;
|
|
opAnd : l := l and r;
|
|
opOr : l := l or r;
|
|
opXor : l := l xor r;
|
|
else
|
|
VarInvalidOp(vl.vType, vr.vType, OpCode);
|
|
end;
|
|
if Overflow then
|
|
DoVarOpFloat(vl,vr,OpCode)
|
|
else begin
|
|
DoVarClearIfComplex(vl);
|
|
vl.vType := varInt64;
|
|
vl.vInt64 := l;
|
|
end;
|
|
end;
|
|
|
|
procedure DoVarOpInt64to32(var vl : TVarData; const vr : TVarData; const OpCode : TVarOp);
|
|
begin
|
|
{ can't do this well without an efficent way to check for overflows,
|
|
let the Int64 version handle it and check the Result if we can downgrade it
|
|
to integer }
|
|
DoVarOpInt64(vl, vr, OpCode);
|
|
with vl do
|
|
if (vType = varInt64) and (vInt64 >= Low(LongInt)) and (vInt64 <= High(LongInt)) then begin
|
|
vInteger := vInt64;
|
|
vType := varInteger;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure DoVarOpBool(var vl : TVarData; const vr : TVarData; const OpCode : TVarOp);
|
|
var
|
|
l,r: Boolean;
|
|
begin
|
|
l := VariantToBoolean(vl);
|
|
r := VariantToBoolean(vr);
|
|
case OpCode of
|
|
opAnd : l := l and r;
|
|
opOr : l := l or r;
|
|
opXor : l := l xor r;
|
|
else
|
|
VarInvalidOp(vl.vType, vr.vType, OpCode);
|
|
end;
|
|
DoVarClearIfComplex(vl);
|
|
vl.vType := varBoolean;
|
|
vl.vBoolean := l;
|
|
end;
|
|
|
|
procedure DoVarOpNull(var vl : TVarData; const vr : TVarData; const OpCode : TVarOp);
|
|
begin
|
|
if (OpCode = opAnd) or (OpCode = opOr) then
|
|
if vl.vType = varNull then begin
|
|
if vr.vType = varNull then begin
|
|
{both null, do nothing }
|
|
end else begin
|
|
{Left null, Right not}
|
|
if OpCode = opAnd then begin
|
|
if not VariantToBoolean(vr) then
|
|
VarCopyProc(vl, vr);
|
|
end else {OpCode = opOr} begin
|
|
if VariantToBoolean(vr) then
|
|
VarCopyProc(vl, vr);
|
|
end;
|
|
end;
|
|
end else begin
|
|
if vr.vType = varNull then begin
|
|
{Right null, Left not}
|
|
if OpCode = opAnd then begin
|
|
if VariantToBoolean(vl) then begin
|
|
DoVarClearIfComplex(vl);
|
|
vl.vType := varNull;
|
|
end;
|
|
end else {OpCode = opOr} begin
|
|
if not VariantToBoolean(vl) then begin
|
|
DoVarClearIfComplex(vl);
|
|
vl.vType := varNull;
|
|
end;
|
|
end;
|
|
end else begin
|
|
{ both not null, shouldn't happen }
|
|
VarInvalidOp(vl.vType, vr.vType, OpCode);
|
|
end;
|
|
end
|
|
else begin
|
|
DoVarClearIfComplex(vl);
|
|
vl.vType := varNull;
|
|
end;
|
|
end;
|
|
|
|
procedure DoVarOpWStrCat(var vl : TVarData; const vr : TVarData);
|
|
var
|
|
ws: WideString;
|
|
begin
|
|
ws := VariantToWideString(vl) + VariantToWideString(vr);
|
|
DoVarClearIfComplex(vl);
|
|
vl.vType := varOleStr;
|
|
{ transfer the WideString without making a copy }
|
|
Pointer(vl.vOleStr) := Pointer(ws);
|
|
{ prevent the WideString from being freed, the reference has been transfered
|
|
from the local to the variant and will be correctly finalized when the
|
|
variant is finalized. }
|
|
Pointer(ws) := nil;
|
|
end;
|
|
|
|
procedure DoVarOpLStrCat(var vl: TVarData; const vr : TVarData);
|
|
var
|
|
s: AnsiString;
|
|
begin
|
|
s := VariantToAnsiString(vl) + VariantToAnsiString(vr);
|
|
DoVarClearIfComplex(vl);
|
|
vl.vType := varString;
|
|
{ transfer the AnsiString without making a copy }
|
|
Pointer(vl.vString) := Pointer(s);
|
|
{ prevent the AnsiString from being freed, the reference has been transfered
|
|
from the local to the variant and will be correctly finalized when the
|
|
variant is finalized. }
|
|
Pointer(s) := nil;
|
|
end;
|
|
|
|
procedure DoVarOpDate(var vl : TVarData; const vr : TVarData; const OpCode : TVarOp);
|
|
{$ifndef FPUNONE}
|
|
var
|
|
l, r : TDateTime;
|
|
begin
|
|
l := VariantToDate(vl);
|
|
r := VariantToDate(vr);
|
|
case OpCode of
|
|
opAdd : l := l + r;
|
|
opSubtract : l := l - r;
|
|
else
|
|
VarInvalidOp(vl.vType, vr.vType, OpCode);
|
|
end;
|
|
DoVarClearIfComplex(vl);
|
|
vl.vType := varDate;
|
|
vl.vDate := l;
|
|
{$else}
|
|
begin
|
|
VarInvalidOp(vl.vType, vr.vType, OpCode);
|
|
{$endif}
|
|
end;
|
|
|
|
procedure DoVarOpCurr(var vl : TVarData; const vr : TVarData; const OpCode : TVarOp; const lct, rct : TCommonType);
|
|
{$ifndef FPUNONE}
|
|
var
|
|
c : Currency;
|
|
d : Double;
|
|
begin
|
|
case OpCode of
|
|
opAdd:
|
|
c := VariantToCurrency(vl) + VariantToCurrency(vr);
|
|
opSubtract:
|
|
c := VariantToCurrency(vl) - VariantToCurrency(vr);
|
|
opMultiply:
|
|
if lct = ctCurrency then
|
|
if rct = ctCurrency then {both Currency}
|
|
c := VariantToCurrency(vl) * VariantToCurrency(vr)
|
|
else {Left Currency}
|
|
c := VariantToCurrency(vl) * VariantToDouble(vr)
|
|
else
|
|
if rct = ctCurrency then {rigth Currency}
|
|
c := VariantToDouble(vl) * VariantToCurrency(vr)
|
|
else {non Currency, error}
|
|
VarInvalidOp(vl.vType, vr.vType, OpCode);
|
|
opDivide:
|
|
if lct = ctCurrency then
|
|
if rct = ctCurrency then {both Currency}
|
|
c := VariantToCurrency(vl) / VariantToCurrency(vr)
|
|
else {Left Currency}
|
|
c := VariantToCurrency(vl) / VariantToDouble(vr)
|
|
else
|
|
if rct = ctCurrency then begin {rigth Currency}
|
|
d := VariantToCurrency(vl) / VariantToCurrency(vr);
|
|
DoVarClearIfComplex(vl);
|
|
vl.vType := varDouble;
|
|
vl.vDouble := d;
|
|
Exit;
|
|
end else {non Currency, error}
|
|
VarInvalidOp(vl.vType, vr.vType, OpCode);
|
|
opPower:
|
|
if lct = ctCurrency then
|
|
if rct = ctCurrency then {both Currency}
|
|
c := VariantToCurrency(vl) ** VariantToCurrency(vr)
|
|
else {Left Currency}
|
|
c := VariantToCurrency(vl) ** VariantToDouble(vr)
|
|
else
|
|
if rct = ctCurrency then {rigth Currency}
|
|
c := VariantToDouble(vl) ** VariantToCurrency(vr)
|
|
else {non Currency, error}
|
|
VarInvalidOp(vl.vType, vr.vType, OpCode);
|
|
else
|
|
VarInvalidOp(vl.vType, vr.vType, OpCode);
|
|
end;
|
|
DoVarClearIfComplex(vl);
|
|
vl.vType := varCurrency;
|
|
vl.vCurrency := c;
|
|
{$else}
|
|
begin
|
|
VarInvalidOp(vl.vType, vr.vType, OpCode);
|
|
{$endif}
|
|
end;
|
|
|
|
procedure DoVarOpComplex(var vl : TVarData; const vr : TVarData; const OpCode : TVarOp);
|
|
var Handler: TCustomVariantType;
|
|
begin
|
|
if FindCustomVariantType(vl.vType, Handler) then
|
|
Handler.BinaryOp(vl, vr, OpCode)
|
|
else if FindCustomVariantType(vr.vType, Handler) then
|
|
Handler.BinaryOp(vl, vr, OpCode)
|
|
else
|
|
VarInvalidOp(vl.vType, vr.vType, OpCode);
|
|
end;
|
|
|
|
procedure SysVarOp(var Left : Variant; const Right : Variant; OpCode : TVarOp);
|
|
var
|
|
lct: TCommonType;
|
|
rct: TCommonType;
|
|
{$IFDEF DEBUG_VARIANTS}
|
|
i: Integer;
|
|
{$ENDIF}
|
|
begin
|
|
{ as the function in cvarutil.inc can handle varByRef correctly we simply
|
|
resolve the final type }
|
|
lct := MapToCommonType(VarTypeDeRef(Left));
|
|
rct := MapToCommonType(VarTypeDeRef(Right));
|
|
|
|
{$IFDEF DEBUG_VARIANTS}
|
|
if __DEBUG_VARIANTS then begin
|
|
WriteLn('SysVarOp $', IntToHex(Cardinal(@TVarData(Left)),8), ' ', GetEnumName(TypeInfo(TVarOp), Ord(OpCode)) ,' $', IntToHex(Cardinal(@TVarData(Right)),8));
|
|
DumpVariant('SysVarOp/TVarData(Left)', TVarData(Left));
|
|
WriteLn('lct ', GetEnumName(TypeInfo(TCommonType), Ord(lct)));
|
|
|
|
DumpVariant('SysVarOp/TVarData(Right)', TVarData(Right));
|
|
WriteLn('rct ', GetEnumName(TypeInfo(TCommonType), Ord(rct)));
|
|
|
|
WriteLn('common ', GetEnumName(TypeInfo(TCommonType), Ord(FindOpCommonType[lct, rct])));
|
|
end;
|
|
{$ENDIF}
|
|
|
|
case FindOpCommonType[lct, rct] of
|
|
ctEmpty:
|
|
case OpCode of
|
|
opDivide:
|
|
Error(reZeroDivide);
|
|
opIntDivide, opModulus:
|
|
Error(reDivByZero);
|
|
else
|
|
DoVarClear(TVarData(Left));
|
|
end;
|
|
ctAny:
|
|
DoVarOpAny(TVarData(Left),TVarData(Right),OpCode);
|
|
ctLongInt:
|
|
case OpCode of
|
|
opAdd..opMultiply,opPower:
|
|
DoVarOpInt64to32(TVarData(Left),TVarData(Right),OpCode);
|
|
opDivide:
|
|
DoVarOpFloat(TVarData(Left),TVarData(Right),OpCode);
|
|
else
|
|
DoVarOpLongInt(TVarData(Left),TVarData(Right),OpCode);
|
|
end;
|
|
{$ifndef FPUNONE}
|
|
ctFloat:
|
|
if OpCode in [opAdd,opSubtract,opMultiply,opDivide] then
|
|
DoVarOpFloat(TVarData(Left),TVarData(Right),OpCode)
|
|
else
|
|
DoVarOpInt64to32(TVarData(Left),TVarData(Right),OpCode);
|
|
{$endif}
|
|
ctBoolean:
|
|
case OpCode of
|
|
opAdd..opMultiply, opPower:
|
|
DoVarOpFloat(TVarData(Left),TVarData(Right),OpCode);
|
|
opIntDivide..opShiftRight:
|
|
DoVarOpLongInt(TVarData(Left),TVarData(Right),OpCode);
|
|
opAnd..opXor:
|
|
DoVarOpBool(TVarData(Left),TVarData(Right),OpCode);
|
|
else
|
|
VarInvalidOp(TVarData(Left).vType, TVarData(Right).vType, OpCode);
|
|
end;
|
|
ctInt64:
|
|
if OpCode <> opDivide then
|
|
DoVarOpInt64(TVarData(Left),TVarData(Right),OpCode)
|
|
else
|
|
DoVarOpFloat(TVarData(Left),TVarData(Right),OpCode);
|
|
ctNull:
|
|
DoVarOpNull(TVarData(Left),TVarData(Right),OpCode);
|
|
ctWideStr:
|
|
case OpCode of
|
|
opAdd:
|
|
DoVarOpWStrCat(TVarData(Left),TVarData(Right));
|
|
opSubtract..opDivide,opPower:
|
|
DoVarOpFloat(TVarData(Left),TVarData(Right),OpCode);
|
|
opIntDivide..opXor:
|
|
DoVarOpInt64to32(TVarData(Left),TVarData(Right),OpCode);
|
|
else
|
|
VarInvalidOp(TVarData(Left).vType, TVarData(Right).vType, OpCode);
|
|
end;
|
|
{$ifndef FPUNONE}
|
|
ctDate:
|
|
case OpCode of
|
|
opAdd:
|
|
DoVarOpDate(TVarData(Left),TVarData(Right),OpCode);
|
|
opSubtract: begin
|
|
DoVarOpDate(TVarData(Left),TVarData(Right),OpCode);
|
|
if lct = rct then {both are date}
|
|
TVarData(Left).vType := varDouble;
|
|
end;
|
|
opMultiply, opDivide:
|
|
DoVarOpFloat(TVarData(Left),TVarData(Right),OpCode);
|
|
else
|
|
DoVarOpInt64to32(TVarData(Left),TVarData(Right),OpCode);
|
|
end;
|
|
ctCurrency:
|
|
if OpCode in [opAdd..opDivide, opPower] then
|
|
DoVarOpCurr(TVarData(Left),TVarData(Right),OpCode, lct, rct)
|
|
else
|
|
DoVarOpInt64to32(TVarData(Left),TVarData(Right),OpCode);
|
|
{$endif}
|
|
ctString:
|
|
case OpCode of
|
|
opAdd:
|
|
DoVarOpLStrCat(TVarData(Left),TVarData(Right));
|
|
opSubtract..opDivide,opPower:
|
|
DoVarOpFloat(TVarData(Left),TVarData(Right),OpCode);
|
|
opIntDivide..opXor:
|
|
DoVarOpInt64to32(TVarData(Left),TVarData(Right),OpCode);
|
|
else
|
|
VarInvalidOp(TVarData(Left).vType, TVarData(Right).vType, OpCode);
|
|
end;
|
|
else
|
|
{ more complex case }
|
|
DoVarOpComplex(TVarData(Left),TVarData(Right),OpCode);
|
|
end;
|
|
end;
|
|
|
|
procedure DoVarNegAny(var v: TVarData);
|
|
begin
|
|
VarInvalidOp(v.vType, opNegate);
|
|
end;
|
|
|
|
procedure DoVarNegComplex(var v: TVarData);
|
|
begin
|
|
{ custom variants? }
|
|
VarInvalidOp(v.vType, opNegate);
|
|
end;
|
|
|
|
procedure sysvarneg(var v: Variant);
|
|
const
|
|
BoolMap: array [Boolean] of SmallInt = (0, -1);
|
|
begin
|
|
with TVarData(v) do case vType of
|
|
varEmpty: begin
|
|
vSmallInt := 0;
|
|
vType := varSmallInt;
|
|
end;
|
|
varNull:;
|
|
varSmallint: vSmallInt := -vSmallInt;
|
|
varInteger: vInteger := -vInteger;
|
|
{$ifndef FPUNONE}
|
|
varSingle: vSingle := -vSingle;
|
|
varDouble: vDouble := -vDouble;
|
|
varCurrency: vCurrency := -vCurrency;
|
|
varDate: vDate := -vDate;
|
|
varOleStr: sysvarfromreal(v, -VariantToDouble(TVarData(v)));
|
|
{$else}
|
|
varOleStr: sysvarfromint64(v, -VariantToInt64(TVarData(v)));
|
|
{$endif}
|
|
varBoolean: begin
|
|
vSmallInt := BoolMap[vBoolean];
|
|
vType := varSmallInt;
|
|
end;
|
|
varShortInt: vShortInt := -vShortInt;
|
|
varByte: begin
|
|
vSmallInt := -vByte;
|
|
vType := varSmallInt;
|
|
end;
|
|
varWord: begin
|
|
vInteger := -vWord;
|
|
vType := varInteger;
|
|
end;
|
|
varLongWord:
|
|
if vLongWord and $80000000 <> 0 then begin
|
|
vInt64 := -vLongWord;
|
|
vType := varInt64;
|
|
end else begin
|
|
vInteger := -vLongWord;
|
|
vType := varInteger;
|
|
end;
|
|
varInt64: vInt64 := -vInt64;
|
|
varQWord: begin
|
|
if vQWord and $8000000000000000 <> 0 then
|
|
VarRangeCheckError(varQWord, varInt64);
|
|
vInt64 := -vQWord;
|
|
vType := varInt64;
|
|
end;
|
|
varVariant: v := -Variant(PVarData(vPointer)^);
|
|
else {with TVarData(v) do case vType of}
|
|
case vType of
|
|
{$ifndef FPUNONE}
|
|
varString: sysvarfromreal(v, -VariantToDouble(TVarData(v)));
|
|
{$else}
|
|
varString: sysvarfromint64(v, -VariantToInt64(TVarData(v)));
|
|
{$endif}
|
|
varAny: DoVarNegAny(TVarData(v));
|
|
else {case vType of}
|
|
if (vType and not varTypeMask) = varByRef then
|
|
case vType and varTypeMask of
|
|
varSmallInt: begin
|
|
vSmallInt := -PSmallInt(vPointer)^;
|
|
vType := varSmallInt;
|
|
end;
|
|
varInteger: begin
|
|
vInteger := -PInteger(vPointer)^;
|
|
vType := varInteger;
|
|
end;
|
|
{$ifndef FPUNONE}
|
|
varSingle: begin
|
|
vSingle := -PSingle(vPointer)^;
|
|
vType := varSingle;
|
|
end;
|
|
varDouble: begin
|
|
vDouble := -PDouble(vPointer)^;
|
|
vType := varDouble;
|
|
end;
|
|
varCurrency: begin
|
|
vCurrency := -PCurrency(vPointer)^;
|
|
vType := varCurrency;
|
|
end;
|
|
varDate: begin
|
|
vDate := -PDate(vPointer)^;
|
|
vType := varDate;
|
|
end;
|
|
varOleStr: sysvarfromreal(v, -VariantToDouble(TVarData(v)));
|
|
{$else}
|
|
varOleStr: sysvarfromint64(v, -VariantToInt64(TVarData(v)));
|
|
{$endif}
|
|
varBoolean: begin
|
|
vSmallInt := BoolMap[PWordBool(vPointer)^];
|
|
vType := varSmallInt;
|
|
end;
|
|
varShortInt: begin
|
|
vShortInt := -PShortInt(vPointer)^;
|
|
vType := varShortInt;
|
|
end;
|
|
varByte: begin
|
|
vSmallInt := -PByte(vPointer)^;
|
|
vType := varSmallInt;
|
|
end;
|
|
varWord: begin
|
|
vInteger := -PWord(vPointer)^;
|
|
vType := varInteger;
|
|
end;
|
|
varLongWord:
|
|
if PLongWord(vPointer)^ and $80000000 <> 0 then begin
|
|
vInt64 := -PLongWord(vPointer)^;
|
|
vType := varInt64;
|
|
end else begin
|
|
vInteger := -PLongWord(vPointer)^;
|
|
vType := varInteger;
|
|
end;
|
|
varInt64: begin
|
|
vInt64 := -PInt64(vPointer)^;
|
|
vType := varInt64;
|
|
end;
|
|
varQWord: begin
|
|
if PQWord(vPointer)^ and $8000000000000000 <> 0 then
|
|
VarRangeCheckError(varQWord, varInt64);
|
|
vInt64 := -PQWord(vPointer)^;
|
|
vType := varInt64;
|
|
end;
|
|
varVariant:
|
|
v := -Variant(PVarData(vPointer)^);
|
|
else {case vType and varTypeMask of}
|
|
DoVarNegComplex(TVarData(v));
|
|
end {case vType and varTypeMask of}
|
|
else {if (vType and not varTypeMask) = varByRef}
|
|
DoVarNegComplex(TVarData(v));
|
|
end; {case vType of}
|
|
end; {with TVarData(v) do case vType of}
|
|
end;
|
|
|
|
procedure DoVarNotAny(var v: TVarData);
|
|
begin
|
|
VarInvalidOp(v.vType, opNot);
|
|
end;
|
|
|
|
procedure DoVarNotOrdinal(var v: TVarData);
|
|
var
|
|
i: Int64;
|
|
begin
|
|
{ only called for types that do no require finalization }
|
|
i := VariantToInt64(v);
|
|
with v do
|
|
if (i < Low(Integer)) or (i > High(Integer)) then begin
|
|
vInt64 := not i;
|
|
vType := varInt64;
|
|
end else begin
|
|
vInteger := not Integer(i);
|
|
vType := varInteger;
|
|
end
|
|
end;
|
|
|
|
procedure DoVarNotWStr(var v: TVarData; const p: Pointer);
|
|
var
|
|
i: Int64;
|
|
e: Word;
|
|
b: Boolean;
|
|
begin
|
|
Val(WideString(p), i, e);
|
|
with v do
|
|
if e = 0 then begin
|
|
DoVarClearIfComplex(v);
|
|
if (i < Low(Integer)) or (i > High(Integer)) then begin
|
|
vInt64 := not i;
|
|
vType := varInt64;
|
|
end else begin
|
|
vInteger := not Integer(i);
|
|
vType := varInteger;
|
|
end
|
|
end else begin
|
|
if not TryStrToBool(WideString(p), b) then
|
|
VarInvalidOp(vType, opNot);
|
|
DoVarClearIfComplex(v);
|
|
vBoolean := not b;
|
|
vType := varBoolean;
|
|
end;
|
|
end;
|
|
|
|
procedure DoVarNotLStr(var v: TVarData; const p: Pointer);
|
|
var
|
|
i: Int64;
|
|
e: Word;
|
|
b: Boolean;
|
|
begin
|
|
Val(AnsiString(p), i, e);
|
|
with v do
|
|
if e = 0 then begin
|
|
DoVarClearIfComplex(v);
|
|
if (i < Low(Integer)) or (i > High(Integer)) then begin
|
|
vInt64 := not i;
|
|
vType := varInt64;
|
|
end else begin
|
|
vInteger := not Integer(i);
|
|
vType := varInteger;
|
|
end
|
|
end else begin
|
|
if not TryStrToBool(AnsiString(p), b) then
|
|
VarInvalidOp(v.vType, opNot);
|
|
DoVarClearIfComplex(v);
|
|
vBoolean := not b;
|
|
vType := varBoolean;
|
|
end;
|
|
end;
|
|
|
|
procedure DoVarNotComplex(var v: TVarData);
|
|
begin
|
|
{ custom variant support ?}
|
|
VarInvalidOp(v.vType, opNot);
|
|
end;
|
|
|
|
procedure sysvarnot(var v: Variant);
|
|
begin
|
|
with TVarData(v) do case vType of
|
|
varEmpty: v := -1;
|
|
varNull:;
|
|
varSmallint: vSmallInt := not vSmallInt;
|
|
varInteger: vInteger := not vInteger;
|
|
{$ifndef FPUNONE}
|
|
varSingle,
|
|
varDouble,
|
|
varCurrency,
|
|
varDate: DoVarNotOrdinal(TVarData(v));
|
|
{$endif}
|
|
varOleStr: DoVarNotWStr(TVarData(v), Pointer(vOleStr));
|
|
varBoolean: vBoolean := not vBoolean;
|
|
varShortInt: vShortInt := not vShortInt;
|
|
varByte: vByte := not vByte;
|
|
varWord: vWord := not vWord;
|
|
varLongWord: vLongWord := not vLongWord;
|
|
varInt64: vInt64 := not vInt64;
|
|
varQWord: vQWord := not vQWord;
|
|
varVariant: v := not Variant(PVarData(vPointer)^);
|
|
else {with TVarData(v) do case vType of}
|
|
case vType of
|
|
varString: DoVarNotLStr(TVarData(v), Pointer(vString));
|
|
varAny: DoVarNotAny(TVarData(v));
|
|
else {case vType of}
|
|
if (vType and not varTypeMask) = varByRef then
|
|
case vType and varTypeMask of
|
|
varSmallInt: begin
|
|
vSmallInt := not PSmallInt(vPointer)^;
|
|
vType := varSmallInt;
|
|
end;
|
|
varInteger: begin
|
|
vInteger := not PInteger(vPointer)^;
|
|
vType := varInteger;
|
|
end;
|
|
{$ifndef FPUNONE}
|
|
varSingle,
|
|
varDouble,
|
|
varCurrency,
|
|
varDate: DoVarNotOrdinal(TVarData(v));
|
|
{$endif}
|
|
varOleStr: DoVarNotWStr(TVarData(v), PPointer(vPointer)^);
|
|
varBoolean: begin
|
|
vBoolean := not PWordBool(vPointer)^;
|
|
vType := varBoolean;
|
|
end;
|
|
varShortInt: begin
|
|
vShortInt := not PShortInt(vPointer)^;
|
|
vType := varShortInt;
|
|
end;
|
|
varByte: begin
|
|
vByte := not PByte(vPointer)^;
|
|
vType := varByte;
|
|
end;
|
|
varWord: begin
|
|
vWord := not PWord(vPointer)^;
|
|
vType := varWord;
|
|
end;
|
|
varLongWord: begin
|
|
vLongWord := not PLongWord(vPointer)^;
|
|
vType := varLongWord;
|
|
end;
|
|
varInt64: begin
|
|
vInt64 := not PInt64(vPointer)^;
|
|
vType := varInt64;
|
|
end;
|
|
varQWord: begin
|
|
vQWord := not PQWord(vPointer)^;
|
|
vType := varQWord;
|
|
end;
|
|
varVariant:
|
|
v := not Variant(PVarData(vPointer)^);
|
|
else {case vType and varTypeMask of}
|
|
DoVarNotComplex(TVarData(v));
|
|
end {case vType and varTypeMask of}
|
|
else {if (vType and not varTypeMask) = varByRef}
|
|
DoVarNotComplex(TVarData(v));
|
|
end; {case vType of}
|
|
end; {with TVarData(v) do case vType of}
|
|
end;
|
|
|
|
{
|
|
This procedure is needed to destroy and clear non-standard variant type array elements,
|
|
which can not be handled by SafeArrayDestroy.
|
|
If array element type is varVariant, then clear each element individually before
|
|
calling VariantClear for array. VariantClear just calls SafeArrayDestroy.
|
|
}
|
|
procedure DoVarClearArray(var VArray: TVarData);
|
|
var
|
|
arr: pvararray;
|
|
i, cnt: cardinal;
|
|
data: pvardata;
|
|
begin
|
|
if VArray.vtype and varTypeMask = varVariant then begin
|
|
if WordBool(VArray.vType and varByRef) then
|
|
arr:=PVarArray(VArray.vPointer^)
|
|
else
|
|
arr:=VArray.vArray;
|
|
VarResultCheck(SafeArrayAccessData(arr, data));
|
|
try
|
|
{ Calculation total number of elements in the array }
|
|
cnt:=1;
|
|
{$push}
|
|
{ arr^.bounds[] is an array[0..0] }
|
|
{$r-}
|
|
for i:=0 to arr^.dimcount - 1 do
|
|
cnt:=cnt*cardinal(arr^.Bounds[i].ElementCount);
|
|
{$pop}
|
|
|
|
{ Clearing each element }
|
|
for i:=1 to cnt do begin
|
|
DoVarClear(data^);
|
|
Inc(pointer(data), arr^.ElementSize);
|
|
end;
|
|
finally
|
|
VarResultCheck(SafeArrayUnaccessData(arr));
|
|
end;
|
|
end;
|
|
VariantClear(VArray);
|
|
end;
|
|
|
|
procedure DoVarClearComplex(var v : TVarData);
|
|
var
|
|
Handler : TCustomVariantType;
|
|
begin
|
|
with v do
|
|
if vType < varInt64 then
|
|
VarResultCheck(VariantClear(v))
|
|
else if vType = varString then
|
|
begin
|
|
AnsiString(vString) := '';
|
|
vType := varEmpty;
|
|
end
|
|
else if vType = varUString then
|
|
begin
|
|
UnicodeString(vString) := '';
|
|
vType := varEmpty;
|
|
end
|
|
else if vType = varAny then
|
|
ClearAnyProc(v)
|
|
else if vType and varArray <> 0 then
|
|
DoVarClearArray(v)
|
|
else if FindCustomVariantType(vType, Handler) then
|
|
Handler.Clear(v)
|
|
else begin
|
|
{ ignore errors, if the OS doesn't know how to free it, we don't either }
|
|
VariantClear(v);
|
|
vType := varEmpty;
|
|
end;
|
|
end;
|
|
|
|
type
|
|
TVarArrayCopyCallback = procedure(var aDest: TVarData; const aSource: TVarData);
|
|
|
|
procedure DoVarCopyArray(var aDest: TVarData; const aSource: TVarData; aCallback: TVarArrayCopyCallback);
|
|
var
|
|
SourceArray : PVarArray;
|
|
SourcePtr : Pointer;
|
|
DestArray : PVarArray;
|
|
DestPtr : Pointer;
|
|
|
|
Bounds : array[0..63] of TVarArrayBound;
|
|
Iterator : TVariantArrayIterator;
|
|
|
|
Dims : Integer;
|
|
HighBound : Integer;
|
|
i : Integer;
|
|
begin
|
|
with aSource do begin
|
|
if vType and varArray = 0 then
|
|
VarResultCheck(VAR_INVALIDARG);
|
|
|
|
if (vType and varTypeMask) = varVariant then begin
|
|
|
|
if (vType and varByRef) <> 0 then
|
|
SourceArray := PVarArray(vPointer^)
|
|
else
|
|
SourceArray := vArray;
|
|
|
|
Dims := SourceArray^.DimCount;
|
|
for i := 0 to Pred(Dims) do
|
|
with Bounds[i] do begin
|
|
VarResultCheck(SafeArrayGetLBound(SourceArray, Succ(i), LowBound));
|
|
VarResultCheck(SafeArrayGetUBound(SourceArray, Succ(i), HighBound));
|
|
ElementCount := HighBound - LowBound + 1;
|
|
end;
|
|
|
|
DestArray := SafeArrayCreate(varVariant, Dims, PVarArrayBoundArray(@Bounds)^);
|
|
if not Assigned(DestArray) then
|
|
VarArrayCreateError;
|
|
|
|
DoVarClearIfComplex(aDest);
|
|
with aDest do begin
|
|
vType := varVariant or varArray;
|
|
vArray := DestArray;
|
|
end;
|
|
|
|
Iterator.Init(Dims, @Bounds);
|
|
try
|
|
if not(Iterator.AtEnd) then
|
|
repeat
|
|
VarResultCheck(SafeArrayPtrOfIndex(SourceArray, Iterator.Coords, SourcePtr));
|
|
VarResultCheck(SafeArrayPtrOfIndex(DestArray, Iterator.Coords, DestPtr));
|
|
aCallback(PVarData(DestPtr)^, PVarData(SourcePtr)^);
|
|
until not Iterator.Next;
|
|
finally
|
|
Iterator.Done;
|
|
end;
|
|
|
|
end else
|
|
VarResultCheck(VariantCopy(aDest, aSource));
|
|
end;
|
|
end;
|
|
|
|
procedure DoVarCopyComplex(var Dest: TVarData; const Source: TVarData);
|
|
var
|
|
Handler: TCustomVariantType;
|
|
begin
|
|
DoVarClearIfComplex(Dest);
|
|
|
|
with Source do
|
|
if vType < varInt64 then
|
|
VarResultCheck(VariantCopy(Dest, Source))
|
|
else if vType = varString then begin
|
|
Dest.vType := varString;
|
|
Dest.vString := nil;
|
|
AnsiString(Dest.vString) := AnsiString(vString);
|
|
end else if vType = varAny then begin
|
|
Dest := Source;
|
|
RefAnyProc(Dest);
|
|
end else if vType and varArray <> 0 then
|
|
DoVarCopyArray(Dest, Source, @DoVarCopy)
|
|
else if (vType and varByRef <> 0) and (vType xor varByRef = varString) then
|
|
Dest := Source
|
|
else if FindCustomVariantType(vType, Handler) then
|
|
Handler.Copy(Dest, Source, False)
|
|
else
|
|
VarResultCheck(VariantCopy(Dest, Source));
|
|
end;
|
|
|
|
procedure DoVarCopy(var Dest : TVarData; const Source : TVarData);
|
|
begin
|
|
if @Dest <> @Source then
|
|
if (Source.vType and varComplexType) = 0 then begin
|
|
DoVarClearIfComplex(Dest);
|
|
Dest := Source;
|
|
end else
|
|
DoVarCopyComplex(Dest, Source);
|
|
end;
|
|
|
|
procedure sysvarcopy (var Dest : Variant; const Source : Variant);
|
|
begin
|
|
DoVarCopy(TVarData(Dest),TVarData(Source));
|
|
end;
|
|
|
|
procedure DoVarAddRef(var v : TVarData); inline;
|
|
var
|
|
Dummy : TVarData;
|
|
begin
|
|
Dummy := v;
|
|
v.vType := varEmpty;
|
|
DoVarCopy(v, Dummy);
|
|
end;
|
|
|
|
procedure sysvaraddref(var v : Variant);
|
|
begin
|
|
DoVarAddRef(TVarData(v));
|
|
end;
|
|
|
|
procedure DoVarCastWStr(var aDest : TVarData; const aSource : TVarData);
|
|
begin
|
|
SysVarFromWStr(Variant(aDest), VariantToWideString(aSource));
|
|
end;
|
|
|
|
procedure DoVarCastLStr(var aDest : TVarData; const aSource : TVarData);
|
|
begin
|
|
SysVarFromLStr(Variant(aDest), VariantToAnsiString(aSource));
|
|
end;
|
|
|
|
procedure DoVarCastDispatch(var aDest : TVarData; const aSource : TVarData);
|
|
var
|
|
Disp: IDispatch;
|
|
begin
|
|
SysVarToDisp(Disp, Variant(aSource));
|
|
SysVarFromDisp(Variant(aDest), Disp);
|
|
end;
|
|
|
|
procedure DoVarCastInterface(var aDest : TVarData; const aSource : TVarData);
|
|
var
|
|
Intf: IInterface;
|
|
begin
|
|
SysVarToIntf(Intf, Variant(aSource));
|
|
SysVarFromIntf(Variant(aDest), Intf);
|
|
end;
|
|
|
|
procedure DoVarCastAny(var aDest : TVarData; const aSource : TVarData; aVarType : LongInt);
|
|
begin
|
|
VarCastError(aSource.vType, aVarType)
|
|
end;
|
|
|
|
procedure DoVarCastFallback(var aDest : TVarData; const aSource : TVarData; aVarType : LongInt);
|
|
begin
|
|
if aSource.vType and varTypeMask >= varInt64 then begin
|
|
DoVarCast(aDest, aSource, varOleStr);
|
|
VarResultCheck(VariantChangeTypeEx(aDest, aDest, VAR_LOCALE_USER_DEFAULT,
|
|
0, aVarType), aSource.vType, aVarType);
|
|
end else if aVarType and varTypeMask < varInt64 then
|
|
VarResultCheck(VariantChangeTypeEx(aDest, aSource, VAR_LOCALE_USER_DEFAULT,
|
|
0, aVarType), aSource.vType, aVarType)
|
|
else
|
|
VarCastError(aSource.vType, aVarType);
|
|
end;
|
|
|
|
procedure DoVarCastComplex(var aDest : TVarData; const aSource : TVarData; aVarType : LongInt);
|
|
var
|
|
Handler: TCustomVariantType;
|
|
begin
|
|
if aSource.vType = varAny then
|
|
DoVarCastAny(aDest, aSource, aVarType)
|
|
else if FindCustomVariantType(aSource.vType, Handler) then
|
|
Handler.CastTo(aDest, aSource, aVarType)
|
|
else if FindCustomVariantType(aVarType, Handler) then
|
|
Handler.Cast(aDest, aSource)
|
|
else
|
|
DoVarCastFallback(aDest, aSource, aVarType);
|
|
end;
|
|
|
|
procedure DoVarCast(var aDest : TVarData; const aSource : TVarData; aVarType : LongInt);
|
|
begin
|
|
with aSource do
|
|
if vType = aVarType then
|
|
DoVarCopy(aDest, aSource)
|
|
else begin
|
|
if (vType = varNull) and NullStrictConvert then
|
|
VarCastError(varNull, aVarType);
|
|
|
|
case aVarType of
|
|
varEmpty, varNull: begin
|
|
DoVarClearIfComplex(aDest);
|
|
aDest.vType := aVarType;
|
|
end;
|
|
varSmallInt: SysVarFromInt(Variant(aDest), VariantToSmallInt(aSource), -2);
|
|
varInteger: SysVarFromInt(Variant(aDest), VariantToLongInt(aSource), -4);
|
|
{$ifndef FPUNONE}
|
|
varSingle: SysVarFromSingle(Variant(aDest), VariantToSingle(aSource));
|
|
varDouble: SysVarFromDouble(Variant(aDest), VariantToDouble(aSource));
|
|
varCurrency: SysVarFromCurr(Variant(aDest), VariantToCurrency(aSource));
|
|
varDate: SysVarFromTDateTime(Variant(aDest), VariantToDate(aSource));
|
|
{$endif}
|
|
varOleStr: DoVarCastWStr(aDest, aSource);
|
|
varBoolean: SysVarFromBool(Variant(aDest), VariantToBoolean(aSource));
|
|
varShortInt: SysVarFromInt(Variant(aDest), VariantToShortInt(aSource), -1);
|
|
varByte: SysVarFromInt(Variant(aDest), VariantToByte(aSource), 1);
|
|
varWord: SysVarFromInt(Variant(aDest), VariantToLongInt(aSource), 2);
|
|
varLongWord: SysVarFromInt(Variant(aDest), Integer(VariantToCardinal(aSource)), 4);
|
|
varInt64: SysVarFromInt64(Variant(aDest), VariantToInt64(aSource));
|
|
varQWord: SysVarFromWord64(Variant(aDest), VariantToQWord(aSource));
|
|
|
|
varDispatch: DoVarCastDispatch(aDest, aSource);
|
|
varUnknown: DoVarCastInterface(aDest, aSource);
|
|
else
|
|
case aVarType of
|
|
varString: DoVarCastLStr(aDest, aSource);
|
|
varAny: VarCastError(vType, varAny);
|
|
else
|
|
DoVarCastComplex(aDest, aSource, aVarType);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
end;
|
|
|
|
procedure sysvarcast (var aDest : Variant; const aSource : Variant; aVarType : LongInt);
|
|
begin
|
|
DoVarCast(TVarData(aDest), TVarData(aSource), aVarType);
|
|
end;
|
|
|
|
|
|
procedure sysvarfromdynarray(var Dest : Variant; const Source : Pointer; TypeInfo: Pointer);
|
|
begin
|
|
DynArrayToVariant(Dest,Source,TypeInfo);
|
|
if VarIsEmpty(Dest) then
|
|
VarCastError;
|
|
end;
|
|
|
|
|
|
procedure sysolevarfrompstr(var Dest : olevariant; const Source : ShortString);
|
|
begin
|
|
sysvarfromwstr(Variant(TVarData(Dest)), Source);
|
|
end;
|
|
|
|
|
|
procedure sysolevarfromlstr(var Dest : olevariant; const Source : AnsiString);
|
|
begin
|
|
sysvarfromwstr(Variant(TVarData(Dest)), Source);
|
|
end;
|
|
|
|
procedure DoOleVarFromAny(var aDest : TVarData; const aSource : TVarData);
|
|
begin
|
|
VarCastErrorOle(aSource.vType);
|
|
end;
|
|
|
|
procedure DoOleVarFromVar(var aDest : TVarData; const aSource : TVarData);
|
|
var
|
|
Handler: TCustomVariantType;
|
|
begin
|
|
with aSource do
|
|
if vType = varByRef or varVariant then
|
|
DoOleVarFromVar(aDest, PVarData(vPointer)^)
|
|
else begin
|
|
case vType of
|
|
varShortInt, varByte, varWord:
|
|
DoVarCast(aDest, aSource, varInteger);
|
|
varLongWord:
|
|
if vLongWord and $80000000 = 0 then
|
|
DoVarCast(aDest, aSource, varInteger)
|
|
else
|
|
{$ifndef FPUNONE}
|
|
if OleVariantInt64AsDouble then
|
|
DoVarCast(aDest, aSource, varDouble)
|
|
else
|
|
{$endif}
|
|
DoVarCast(aDest, aSource, varInt64);
|
|
varInt64:
|
|
if (vInt64 < Low(Integer)) or (vInt64 > High(Integer)) then
|
|
{$ifndef FPUNONE}
|
|
if OleVariantInt64AsDouble then
|
|
DoVarCast(aDest, aSource, varDouble)
|
|
else
|
|
{$endif}
|
|
DoVarCast(aDest, aSource, varInt64)
|
|
else
|
|
DoVarCast(aDest, aSource, varInteger);
|
|
varQWord:
|
|
if vQWord > High(Integer) then
|
|
{$ifndef FPUNONE}
|
|
if OleVariantInt64AsDouble or (vQWord and $8000000000000000 <> 0) then
|
|
DoVarCast(aDest, aSource, varDouble)
|
|
else
|
|
{$endif}
|
|
DoVarCast(aDest, aSource, varInt64)
|
|
else
|
|
DoVarCast(aDest, aSource, varInteger);
|
|
varString:
|
|
DoVarCast(aDest, aSource, varOleStr);
|
|
varAny:
|
|
DoOleVarFromAny(aDest, aSource);
|
|
else
|
|
if (vType and varArray) <> 0 then
|
|
DoVarCopyArray(aDest, aSource, @DoOleVarFromVar)
|
|
else if (vType and varTypeMask) < CFirstUserType then
|
|
DoVarCopy(aDest, aSource)
|
|
else if FindCustomVariantType(vType, Handler) then
|
|
Handler.CastToOle(aDest, aSource)
|
|
else
|
|
VarCastErrorOle(vType);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure sysolevarfromvar(var aDest : OleVariant; const aSource : Variant);
|
|
begin
|
|
DoOleVarFromVar(TVarData(aDest), TVarData(aSource));
|
|
end;
|
|
|
|
procedure sysolevarfromint(var Dest : olevariant; const Source : LongInt; const range : ShortInt);
|
|
begin
|
|
DoVarClearIfComplex(TVarData(Dest));
|
|
with TVarData(Dest) do begin
|
|
vInteger := Source;
|
|
vType := varInteger;
|
|
end;
|
|
end;
|
|
|
|
procedure DoVarCastOle(var aDest: TVarData; const aSource: TVarData; aVarType: LongInt);
|
|
var
|
|
Handler: TCustomVariantType;
|
|
begin
|
|
with aSource do
|
|
if vType = varByRef or varVariant then
|
|
DoVarCastOle(aDest, PVarData(VPointer)^, aVarType)
|
|
else
|
|
if (aVarType = varString) or (aVarType = varAny) then
|
|
VarCastError(vType, aVarType)
|
|
else if FindCustomVariantType(vType, Handler) then
|
|
Handler.CastTo(aDest, aSource, aVarType)
|
|
else
|
|
DoVarCast(aDest, aSource, aVarType);
|
|
end;
|
|
|
|
procedure sysvarcastole(var Dest : Variant; const Source : Variant; aVarType : LongInt);
|
|
begin
|
|
DoVarCastOle(TVarData(Dest), TVarData(Source), aVarType);
|
|
end;
|
|
|
|
|
|
procedure sysdispinvoke(Dest : PVarData; const Source : TVarData;calldesc : pcalldesc;params : Pointer);cdecl;
|
|
var
|
|
temp : TVarData;
|
|
tempp : ^TVarData;
|
|
customvarianttype : TCustomVariantType;
|
|
begin
|
|
if Source.vType=(varByRef or varVariant) then
|
|
sysdispinvoke(Dest,PVarData(Source.vPointer)^,calldesc,params)
|
|
else
|
|
begin
|
|
try
|
|
{ get a defined Result }
|
|
if not(assigned(Dest)) then
|
|
tempp:=nil
|
|
else
|
|
begin
|
|
fillchar(temp,SizeOf(temp),0);
|
|
tempp:=@temp;
|
|
end;
|
|
case Source.vType of
|
|
varDispatch,
|
|
varAny,
|
|
varUnknown,
|
|
varDispatch or varByRef,
|
|
varAny or varByRef,
|
|
varUnknown or varByRef:
|
|
VarDispProc(pvariant(tempp),Variant(Source),calldesc,params);
|
|
else
|
|
begin
|
|
if FindCustomVariantType(Source.vType,customvarianttype) then
|
|
customvarianttype.DispInvoke(tempp,Source,calldesc,params)
|
|
else
|
|
VarInvalidOp;
|
|
end;
|
|
end;
|
|
finally
|
|
if assigned(tempp) then
|
|
begin
|
|
DoVarCopy(Dest^,tempp^);
|
|
DoVarClear(temp);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure sysvararrayredim(var a : Variant;highbound : SizeInt);
|
|
var
|
|
src : TVarData;
|
|
p : pvararray;
|
|
newbounds : tvararraybound;
|
|
begin
|
|
src:=TVarData(a);
|
|
{ get final Variant }
|
|
while src.vType=varByRef or varVariant do
|
|
src:=TVarData(src.vPointer^);
|
|
|
|
if (src.vType and varArray)<>0 then
|
|
begin
|
|
{ get Pointer to the array }
|
|
if (src.vType and varByRef)<>0 then
|
|
p:=pvararray(src.vPointer^)
|
|
else
|
|
p:=src.vArray;
|
|
|
|
{$push}
|
|
{$r-}
|
|
if highbound<p^.Bounds[p^.dimcount-1].LowBound-1 then
|
|
VarInvalidArgError;
|
|
|
|
newbounds.LowBound:=p^.Bounds[p^.dimcount-1].LowBound;
|
|
{$pop}
|
|
newbounds.ElementCount:=highbound-newbounds.LowBound+1;
|
|
|
|
VarResultCheck(SafeArrayRedim(p,newbounds));
|
|
end
|
|
else
|
|
VarInvalidArgError(src.vType);
|
|
end;
|
|
|
|
|
|
function getfinalvartype(const v : TVarData) : TVarType;{$IFDEF VARIANTINLINE}inline;{$ENDIF VARIANTINLINE}
|
|
var
|
|
p: PVarData;
|
|
begin
|
|
p := @v;
|
|
while p^.vType = varByRef or varVariant do
|
|
p := PVarData(p^.vPointer);
|
|
Result := p^.vType;
|
|
end;
|
|
|
|
|
|
function sysvararrayget(const a : Variant;indexcount : SizeInt;indices : plongint) : Variant;cdecl;
|
|
var
|
|
src : TVarData;
|
|
p : pvararray;
|
|
arraysrc : pvariant;
|
|
arrayelementtype : TVarType;
|
|
begin
|
|
src:=TVarData(a);
|
|
{ get final Variant }
|
|
while src.vType=varByRef or varVariant do
|
|
src:=TVarData(src.vPointer^);
|
|
|
|
if (src.vType and varArray)<>0 then
|
|
begin
|
|
{ get Pointer to the array }
|
|
if (src.vType and varByRef)<>0 then
|
|
p:=pvararray(src.vPointer^)
|
|
else
|
|
p:=src.vArray;
|
|
|
|
{ number of indices ok? }
|
|
if p^.DimCount<>indexcount then
|
|
VarInvalidArgError;
|
|
|
|
arrayelementtype:=src.vType and varTypeMask;
|
|
if arrayelementtype=varVariant then
|
|
begin
|
|
VarResultCheck(SafeArrayPtrOfIndex(p,PVarArrayCoorArray(indices),arraysrc));
|
|
Result:=arraysrc^;
|
|
end
|
|
else
|
|
begin
|
|
TVarData(Result).vType:=arrayelementtype;
|
|
VarResultCheck(SafeArrayGetElement(p,PVarArrayCoorArray(indices),@TVarData(Result).vPointer));
|
|
end;
|
|
end
|
|
else
|
|
VarInvalidArgError(src.vType);
|
|
end;
|
|
|
|
|
|
procedure sysvararrayput(var a : Variant; const value : Variant;indexcount : SizeInt;indices : plongint);cdecl;
|
|
var
|
|
Dest : TVarData;
|
|
p : pvararray;
|
|
arraydest : pvariant;
|
|
valuevtype,
|
|
arrayelementtype : TVarType;
|
|
tempvar : Variant;
|
|
begin
|
|
Dest:=TVarData(a);
|
|
{ get final Variant }
|
|
while Dest.vType=varByRef or varVariant do
|
|
Dest:=TVarData(Dest.vPointer^);
|
|
|
|
valuevtype:=getfinalvartype(TVarData(value));
|
|
|
|
if not(VarTypeIsValidElementType(valuevtype)) and
|
|
{ varString isn't a valid varArray type but it is converted
|
|
later }
|
|
(valuevtype<>varString) then
|
|
VarCastError(valuevtype,Dest.vType);
|
|
|
|
if (Dest.vType and varArray)<>0 then
|
|
begin
|
|
{ get Pointer to the array }
|
|
if (Dest.vType and varByRef)<>0 then
|
|
p:=pvararray(Dest.vPointer^)
|
|
else
|
|
p:=Dest.vArray;
|
|
|
|
{ number of indices ok? }
|
|
if p^.DimCount<>indexcount then
|
|
VarInvalidArgError;
|
|
|
|
arrayelementtype:=Dest.vType and varTypeMask;
|
|
if arrayelementtype=varVariant then
|
|
begin
|
|
VarResultCheck(SafeArrayPtrOfIndex(p,PVarArrayCoorArray(indices),arraydest));
|
|
{ we can't store ansistrings in Variant arrays so we convert the string to
|
|
an olestring }
|
|
if valuevtype=varString then
|
|
begin
|
|
tempvar:=VarToWideStr(value);
|
|
arraydest^:=tempvar;
|
|
end
|
|
else
|
|
arraydest^:=value;
|
|
end
|
|
else
|
|
begin
|
|
VarCast(tempvar,value,arrayelementtype);
|
|
if arrayelementtype in [varOleStr,varDispatch,varUnknown] then
|
|
VarResultCheck(SafeArrayPutElement(p,PVarArrayCoorArray(indices),TVarData(tempvar).vPointer))
|
|
else
|
|
VarResultCheck(SafeArrayPutElement(p,PVarArrayCoorArray(indices),@TVarData(tempvar).vPointer));
|
|
end;
|
|
end
|
|
else
|
|
VarInvalidArgError(Dest.vType);
|
|
end;
|
|
|
|
|
|
{ import from system unit }
|
|
Procedure fpc_Write_Text_AnsiStr (Len : LongInt; Var f : Text; S : RawByteString); external name 'FPC_WRITE_TEXT_ANSISTR';
|
|
|
|
|
|
function syswritevariant(var t : text; const v : Variant;width : LongInt) : Pointer;
|
|
var
|
|
s : AnsiString;
|
|
variantmanager : tvariantmanager;
|
|
begin
|
|
GetVariantManager(variantmanager);
|
|
variantmanager.vartolstr(s,v);
|
|
fpc_write_text_ansistr(width,t,s);
|
|
Result:=nil; // Pointer to what should be returned?
|
|
end;
|
|
|
|
|
|
function syswrite0Variant(var t : text; const v : Variant) : Pointer;
|
|
var
|
|
s : AnsiString;
|
|
variantmanager : tvariantmanager;
|
|
begin
|
|
getVariantManager(variantmanager);
|
|
variantmanager.vartolstr(s,v);
|
|
fpc_write_text_ansistr(-1,t,s);
|
|
Result:=nil; // Pointer to what should be returned?
|
|
end;
|
|
|
|
Const
|
|
SysVariantManager : TVariantManager = (
|
|
vartoint : @sysvartoint;
|
|
vartoint64 : @sysvartoint64;
|
|
vartoword64 : @sysvartoword64;
|
|
vartobool : @sysvartobool;
|
|
{$ifndef FPUNONE}
|
|
vartoreal : @sysvartoreal;
|
|
vartotdatetime: @sysvartotdatetime;
|
|
{$endif}
|
|
vartocurr : @sysvartocurr;
|
|
vartopstr : @sysvartopstr;
|
|
vartolstr : @sysvartolstr;
|
|
vartowstr : @sysvartowstr;
|
|
vartointf : @sysvartointf;
|
|
vartodisp : @sysvartodisp;
|
|
vartodynarray : @sysvartodynarray;
|
|
varfrombool : @sysvarfromBool;
|
|
varfromint : @sysvarfromint;
|
|
varfromint64 : @sysvarfromint64;
|
|
varfromword64 : @sysvarfromword64;
|
|
{$ifndef FPUNONE}
|
|
varfromreal : @sysvarfromreal;
|
|
varfromtdatetime: @sysvarfromtdatetime;
|
|
{$endif}
|
|
varfromcurr : @sysvarfromcurr;
|
|
varfrompstr : @sysvarfrompstr;
|
|
varfromlstr : @sysvarfromlstr;
|
|
varfromwstr : @sysvarfromwstr;
|
|
varfromintf : @sysvarfromintf;
|
|
varfromdisp : @sysvarfromdisp;
|
|
varfromdynarray: @sysvarfromdynarray;
|
|
olevarfrompstr: @sysolevarfrompstr;
|
|
olevarfromlstr: @sysolevarfromlstr;
|
|
olevarfromvar : @sysolevarfromvar;
|
|
olevarfromint : @sysolevarfromint;
|
|
varop : @SysVarOp;
|
|
cmpop : @syscmpop;
|
|
varneg : @sysvarneg;
|
|
varnot : @sysvarnot;
|
|
varinit : @sysvarinit;
|
|
varclear : @sysvarclear;
|
|
varaddref : @sysvaraddref;
|
|
varcopy : @sysvarcopy;
|
|
varcast : @sysvarcast;
|
|
varcastole : @sysvarcastole;
|
|
dispinvoke : @sysdispinvoke;
|
|
vararrayredim : @sysvararrayredim;
|
|
vararrayget : @sysvararrayget;
|
|
vararrayput : @sysvararrayput;
|
|
writevariant : @syswritevariant;
|
|
write0Variant : @syswrite0variant;
|
|
);
|
|
|
|
Var
|
|
PrevVariantManager : TVariantManager;
|
|
|
|
Procedure SetSysVariantManager;
|
|
|
|
begin
|
|
GetVariantManager(PrevVariantManager);
|
|
SetVariantManager(SysVariantManager);
|
|
end;
|
|
|
|
Procedure UnsetSysVariantManager;
|
|
|
|
begin
|
|
SetVariantManager(PrevVariantManager);
|
|
end;
|
|
|
|
|
|
{ ---------------------------------------------------------------------
|
|
Variant support procedures and functions
|
|
---------------------------------------------------------------------}
|
|
|
|
|
|
function VarType(const V: Variant): TVarType;
|
|
|
|
begin
|
|
Result:=TVarData(V).vType;
|
|
end;
|
|
|
|
|
|
function VarTypeDeRef(const V: Variant): TVarType;
|
|
var
|
|
p: PVarData;
|
|
begin
|
|
p := @TVarData(V);
|
|
Result := p^.vType and not varByRef;
|
|
while Result = varVariant do begin
|
|
p := p^.vPointer;
|
|
if not Assigned(p) then
|
|
VarBadTypeError;
|
|
Result := p^.vType and not varByRef;
|
|
end;
|
|
end;
|
|
|
|
function VarTypeDeRef(const V: TVarData): TVarType;
|
|
begin
|
|
Result := VarTypeDeRef(Variant(v));
|
|
end;
|
|
|
|
function VarAsType(const V: Variant; aVarType: TVarType): Variant;
|
|
|
|
begin
|
|
sysvarcast(Result,V,aVarType);
|
|
end;
|
|
|
|
|
|
|
|
function VarIsType(const V: Variant; aVarType: TVarType): Boolean; overload;
|
|
|
|
begin
|
|
Result:=((TVarData(V).vType and varTypeMask)=aVarType);
|
|
end;
|
|
|
|
|
|
function VarIsType(const V: Variant; const AVarTypes: array of TVarType): Boolean; overload;
|
|
|
|
Var
|
|
I : Integer;
|
|
|
|
begin
|
|
I:=Low(AVarTypes);
|
|
Result:=False;
|
|
While Not Result and (I<=High(AVarTypes)) do
|
|
begin
|
|
Result:=((TVarData(V).vType and varTypeMask)=AVarTypes[I]);
|
|
inc(i);
|
|
end;
|
|
end;
|
|
|
|
|
|
function VarIsByRef(const V: Variant): Boolean;
|
|
begin
|
|
Result:=(TVarData(V).vType and varByRef)<>0;
|
|
end;
|
|
|
|
|
|
function VarIsEmpty(const V: Variant): Boolean;
|
|
begin
|
|
Result:=TVarData(V).vType=varEmpty;
|
|
end;
|
|
|
|
|
|
procedure VarCheckEmpty(const V: Variant);
|
|
begin
|
|
If VarIsEmpty(V) Then
|
|
VariantError(SErrVarIsEmpty);
|
|
end;
|
|
|
|
|
|
procedure VarClear(var V: Variant);{$IFDEF VARIANTINLINE}inline;{$ENDIF VARIANTINLINE}
|
|
begin
|
|
sysvarclear(v);
|
|
end;
|
|
|
|
|
|
procedure VarClear(var V: OleVariant);{$IFDEF VARIANTINLINE}inline;{$ENDIF VARIANTINLINE}
|
|
begin
|
|
{ strange casting using TVarData to avoid call of helper olevariant->Variant }
|
|
sysvarclear(Variant(TVarData(v)));
|
|
end;
|
|
|
|
|
|
function VarIsNull(const V: Variant): Boolean;
|
|
begin
|
|
Result:=TVarData(V).vType=varNull;
|
|
end;
|
|
|
|
|
|
function VarIsClear(const V: Variant): Boolean;
|
|
|
|
Var
|
|
VT : TVarType;
|
|
CustomType: TCustomVariantType;
|
|
begin
|
|
VT:=TVarData(V).vType and varTypeMask;
|
|
if VT<CFirstUserType then
|
|
Result:=(VT=varEmpty) or
|
|
(((VT=varDispatch) or (VT=varUnknown))
|
|
and (TVarData(V).vDispatch=Nil))
|
|
else
|
|
Result:=FindCustomVariantType(VT,CustomType) and CustomType.IsClear(TVarData(V));
|
|
end;
|
|
|
|
|
|
function VarIsCustom(const V: Variant): Boolean;
|
|
|
|
begin
|
|
Result:=TVarData(V).vType>=CFirstUserType;
|
|
end;
|
|
|
|
|
|
function VarIsOrdinal(const V: Variant): Boolean;
|
|
begin
|
|
Result:=(TVarData(V).vType and varTypeMask) in OrdinalVarTypes;
|
|
end;
|
|
|
|
|
|
|
|
function VarIsFloat(const V: Variant): Boolean;
|
|
|
|
begin
|
|
Result:=(TVarData(V).vType and varTypeMask) in FloatVarTypes;
|
|
end;
|
|
|
|
|
|
function VarIsNumeric(const V: Variant): Boolean;
|
|
begin
|
|
Result:=(TVarData(V).vType and varTypeMask) in (OrdinalVarTypes + FloatVarTypes);
|
|
end;
|
|
|
|
|
|
|
|
function VarIsStr(const V: Variant): Boolean;
|
|
|
|
begin
|
|
case (TVarData(V).vType and varTypeMask) of
|
|
varOleStr,
|
|
varUString,
|
|
varString :
|
|
Result:=True;
|
|
else
|
|
Result:=False;
|
|
end;
|
|
end;
|
|
|
|
|
|
function VarToStr(const V: Variant): string;
|
|
|
|
begin
|
|
Result:=VarToStrDef(V,'');
|
|
end;
|
|
|
|
|
|
function VarToStrDef(const V: Variant; const ADefault: string): string;
|
|
|
|
begin
|
|
If TVarData(V).vType<>varNull then
|
|
Result:=V
|
|
else
|
|
Result:=ADefault;
|
|
end;
|
|
|
|
|
|
function VarToWideStr(const V: Variant): WideString;
|
|
|
|
begin
|
|
Result:=VarToWideStrDef(V,'');
|
|
end;
|
|
|
|
|
|
function VarToWideStrDef(const V: Variant; const ADefault: WideString): WideString;
|
|
|
|
begin
|
|
If TVarData(V).vType<>varNull then
|
|
Result:=V
|
|
else
|
|
Result:=ADefault;
|
|
end;
|
|
|
|
|
|
function VarToUnicodeStr(const V: Variant): UnicodeString;
|
|
|
|
begin
|
|
Result:=VarToUnicodeStrDef(V,'');
|
|
end;
|
|
|
|
|
|
function VarToUnicodeStrDef(const V: Variant; const ADefault: UnicodeString): UnicodeString;
|
|
|
|
begin
|
|
If TVarData(V).vType<>varNull then
|
|
Result:=V
|
|
else
|
|
Result:=ADefault;
|
|
end;
|
|
|
|
|
|
{$ifndef FPUNONE}
|
|
|
|
function VarToDateTime(const V: Variant): TDateTime;
|
|
begin
|
|
Result:=VariantToDate(TVarData(V));
|
|
end;
|
|
|
|
|
|
function VarFromDateTime(const DateTime: TDateTime): Variant;
|
|
|
|
begin
|
|
SysVarClear(Result);
|
|
with TVarData(Result) do
|
|
begin
|
|
vType:=varDate;
|
|
vdate:=DateTime;
|
|
end;
|
|
end;
|
|
|
|
{$endif}
|
|
|
|
|
|
function VarInRange(const AValue, AMin, AMax: Variant): Boolean;
|
|
begin
|
|
Result:=(AValue>=AMin) and (AValue<=AMax);
|
|
end;
|
|
|
|
|
|
function VarEnsureRange(const AValue, AMin, AMax: Variant): Variant;
|
|
begin
|
|
If AValue>AMAx then
|
|
Result:=AMax
|
|
else If AValue<AMin Then
|
|
Result:=AMin
|
|
else
|
|
Result:=AValue;
|
|
end;
|
|
|
|
|
|
function VarSameValue(const A, B: Variant): Boolean;
|
|
var
|
|
v1,v2 : TVarData;
|
|
begin
|
|
v1:=FindVarData(a)^;
|
|
v2:=FindVarData(b)^;
|
|
if v1.vType in [varEmpty,varNull] then
|
|
Result:=v1.vType=v2.vType
|
|
else if v2.vType in [varEmpty,varNull] then
|
|
Result:=False
|
|
else
|
|
Result:=A=B;
|
|
end;
|
|
|
|
|
|
function VarCompareValue(const A, B: Variant): TVariantRelationship;
|
|
var
|
|
v1,v2 : TVarData;
|
|
begin
|
|
Result:=vrNotEqual;
|
|
v1:=FindVarData(a)^;
|
|
v2:=FindVarData(b)^;
|
|
if (v1.vType in [varEmpty,varNull]) and (v1.vType=v2.vType) then
|
|
Result:=vrEqual
|
|
else if not(v2.vType in [varEmpty,varNull]) and
|
|
not(v1.vType in [varEmpty,varNull]) then
|
|
begin
|
|
if a=b then
|
|
Result:=vrEqual
|
|
else if a>b then
|
|
Result:=vrGreaterThan
|
|
else
|
|
Result:=vrLessThan;
|
|
end;
|
|
end;
|
|
|
|
|
|
function VarIsEmptyParam(const V: Variant): Boolean;
|
|
begin
|
|
Result:=(TVarData(V).vType = varError) and
|
|
(TVarData(V).vError=VAR_PARAMNOTFOUND);
|
|
end;
|
|
|
|
|
|
procedure SetClearVarToEmptyParam(var V: TVarData);
|
|
begin
|
|
VariantClear(V);
|
|
V.vType := varError;
|
|
V.vError := VAR_PARAMNOTFOUND;
|
|
end;
|
|
|
|
|
|
function VarIsError(const V: Variant; out aResult: HRESULT): Boolean;
|
|
begin
|
|
Result := TVarData(V).vType = varError;
|
|
if Result then
|
|
aResult := TVarData(v).vError;
|
|
end;
|
|
|
|
|
|
function VarIsError(const V: Variant): Boolean;
|
|
begin
|
|
Result := TVarData(V).vType = varError;
|
|
end;
|
|
|
|
|
|
function VarAsError(AResult: HRESULT): Variant;
|
|
begin
|
|
TVarData(Result).vType:=varError;
|
|
TVarData(Result).vError:=AResult;
|
|
end;
|
|
|
|
|
|
function VarSupports(const V: Variant; const IID: TGUID; out Intf): Boolean;
|
|
begin
|
|
case TVarData(v).vType of
|
|
varUnknown:
|
|
Result := Assigned(TVarData(v).vUnknown) and (IInterface(TVarData(v).vUnknown).QueryInterface(IID, Intf) = S_OK);
|
|
varUnknown or varByRef:
|
|
Result := Assigned(TVarData(v).vPointer) and Assigned(pointer(TVarData(v).vPointer^)) and (IInterface(TVarData(v).vPointer^).QueryInterface(IID, Intf) = S_OK);
|
|
varDispatch:
|
|
Result := Assigned(TVarData(v).vDispatch) and (IInterface(TVarData(v).vDispatch).QueryInterface(IID, Intf) = S_OK);
|
|
varDispatch or varByRef:
|
|
Result := Assigned(TVarData(v).vPointer) and Assigned(pointer(TVarData(v).vPointer^)) and (IInterface(TVarData(v).vPointer^).QueryInterface(IID, Intf) = S_OK);
|
|
varVariant, varVariant or varByRef:
|
|
Result := Assigned(TVarData(v).vPointer) and VarSupports(Variant(PVarData(TVarData(v).vPointer)^), IID, Intf);
|
|
else
|
|
Result := False;
|
|
end;
|
|
end;
|
|
|
|
|
|
function VarSupports(const V: Variant; const IID: TGUID): Boolean;
|
|
var
|
|
Dummy: IInterface;
|
|
begin
|
|
Result := VarSupports(V, IID, Dummy);
|
|
end;
|
|
|
|
|
|
{ Variant copy support }
|
|
{$push}
|
|
{$warnings off}
|
|
procedure VarCopyNoInd(var Dest: Variant; const Source: Variant);
|
|
|
|
begin
|
|
NotSupported('VarCopyNoInd');
|
|
end;
|
|
{$pop}
|
|
|
|
{****************************************************************************
|
|
Variant array support procedures and functions
|
|
****************************************************************************}
|
|
|
|
{$push}
|
|
{$r-}
|
|
|
|
function VarArrayCreate(const Bounds: array of SizeInt; aVarType: TVarType): Variant;
|
|
var
|
|
hp : PVarArrayBoundArray;
|
|
p : pvararray;
|
|
i,lengthb : SizeInt;
|
|
begin
|
|
if not(VarTypeIsValidArrayType(aVarType)) or odd(length(Bounds)) then
|
|
VarArrayCreateError;
|
|
lengthb:=length(Bounds) div 2;
|
|
try
|
|
GetMem(hp,lengthb*SizeOf(TVarArrayBound));
|
|
for i:=0 to lengthb-1 do
|
|
begin
|
|
hp^[i].LowBound:=Bounds[i*2];
|
|
hp^[i].ElementCount:=Bounds[i*2+1]-Bounds[i*2]+1;
|
|
end;
|
|
SysVarClear(Result);
|
|
|
|
p:=SafeArrayCreate(aVarType,lengthb,hp^);
|
|
|
|
if not(assigned(p)) then
|
|
VarArrayCreateError;
|
|
|
|
TVarData(Result).vType:=aVarType or varArray;
|
|
TVarData(Result).vArray:=p;
|
|
finally
|
|
FreeMem(hp);
|
|
end;
|
|
end;
|
|
|
|
{$pop}
|
|
|
|
function VarArrayCreate(const Bounds: PVarArrayBoundArray; Dims : SizeInt; aVarType: TVarType): Variant;
|
|
var
|
|
p : pvararray;
|
|
begin
|
|
if not(VarTypeIsValidArrayType(aVarType)) then
|
|
VarArrayCreateError;
|
|
SysVarClear(Result);
|
|
|
|
p:=SafeArrayCreate(aVarType,Dims,Bounds^);
|
|
|
|
if not(assigned(p)) then
|
|
VarArrayCreateError;
|
|
|
|
TVarData(Result).vType:=aVarType or varArray;
|
|
TVarData(Result).vArray:=p;
|
|
end;
|
|
|
|
function VarArrayOf(const Values: array of Variant): Variant;
|
|
var
|
|
i : SizeInt;
|
|
begin
|
|
Result:=VarArrayCreate([0,high(Values)],varVariant);
|
|
for i:=0 to high(Values) do
|
|
Result[i]:=Values[i];
|
|
end;
|
|
|
|
|
|
function VarArrayAsPSafeArray(const A: Variant): PVarArray;
|
|
var
|
|
v : TVarData;
|
|
begin
|
|
v:=TVarData(a);
|
|
while v.vType=varByRef or varVariant do
|
|
v:=TVarData(v.vPointer^);
|
|
|
|
if (v.vType and varArray)=varArray then
|
|
begin
|
|
if (v.vType and varByRef)<>0 then
|
|
Result:=pvararray(v.vPointer^)
|
|
else
|
|
Result:=v.vArray;
|
|
end
|
|
else
|
|
VarResultCheck(VAR_INVALIDARG);
|
|
end;
|
|
|
|
|
|
function VarArrayDimCount(const A: Variant) : LongInt;
|
|
var
|
|
hv : TVarData;
|
|
begin
|
|
hv:=TVarData(a);
|
|
|
|
{ get final Variant }
|
|
while hv.vType=varByRef or varVariant do
|
|
hv:=TVarData(hv.vPointer^);
|
|
|
|
if (hv.vType and varArray)<>0 then
|
|
Result:=hv.vArray^.DimCount
|
|
else
|
|
Result:=0;
|
|
end;
|
|
|
|
|
|
function VarArrayLowBound(const A: Variant; Dim: LongInt) : LongInt;
|
|
begin
|
|
VarResultCheck(SafeArrayGetLBound(VarArrayAsPSafeArray(A),Dim,Result));
|
|
end;
|
|
|
|
|
|
function VarArrayHighBound(const A: Variant; Dim: LongInt) : LongInt;
|
|
begin
|
|
VarResultCheck(SafeArrayGetUBound(VarArrayAsPSafeArray(A),Dim,Result));
|
|
end;
|
|
|
|
|
|
function VarArrayLock(const A: Variant): Pointer;
|
|
begin
|
|
VarResultCheck(SafeArrayAccessData(VarArrayAsPSafeArray(A),Result));
|
|
end;
|
|
|
|
|
|
procedure VarArrayUnlock(const A: Variant);
|
|
begin
|
|
VarResultCheck(SafeArrayUnaccessData(VarArrayAsPSafeArray(A)));
|
|
end;
|
|
|
|
|
|
function VarArrayRef(const A: Variant): Variant;
|
|
begin
|
|
if (TVarData(a).vType and varArray)=0 then
|
|
VarInvalidArgError(TVarData(a).vType);
|
|
TVarData(Result).vType:=TVarData(a).vType or varByRef;
|
|
if (TVarData(a).vType and varByRef)=0 then
|
|
TVarData(Result).vPointer:=@TVarData(a).vArray
|
|
else
|
|
TVarData(Result).vPointer:=@TVarData(a).vPointer;
|
|
end;
|
|
|
|
|
|
function VarIsArray(const A: Variant; AResolveByRef: Boolean): Boolean;
|
|
var
|
|
v : TVarData;
|
|
begin
|
|
v:=TVarData(a);
|
|
if AResolveByRef then
|
|
while v.vType=varByRef or varVariant do
|
|
v:=TVarData(v.vPointer^);
|
|
|
|
Result:=(v.vType and varArray)=varArray;
|
|
end;
|
|
|
|
|
|
function VarIsArray(const A: Variant): Boolean;
|
|
begin
|
|
VarIsArray:=VarIsArray(A,true);
|
|
end;
|
|
|
|
|
|
function VarTypeIsValidArrayType(const aVarType: TVarType): Boolean;
|
|
begin
|
|
Result:=aVarType in [varSmallInt,varInteger,
|
|
{$ifndef FPUNONE}
|
|
varSingle,varDouble,varDate,
|
|
{$endif}
|
|
varCurrency,varOleStr,varDispatch,varError,varBoolean,
|
|
varVariant,varUnknown,varShortInt,varByte,varWord,varLongWord];
|
|
end;
|
|
|
|
|
|
function VarTypeIsValidElementType(const aVarType: TVarType): Boolean;
|
|
var
|
|
customvarianttype : TCustomVariantType;
|
|
begin
|
|
Result:=((aVarType and not(varByRef) and not(varArray)) in [varEmpty,varNull,varSmallInt,varInteger,
|
|
{$ifndef FPUNONE}
|
|
varSingle,varDouble,varDate,
|
|
{$endif}
|
|
varCurrency,varOleStr,varDispatch,varError,varBoolean,
|
|
varVariant,varUnknown,varShortInt,varByte,varWord,varLongWord,varInt64]) or
|
|
FindCustomVariantType(aVarType,customvarianttype);
|
|
end;
|
|
|
|
|
|
{ ---------------------------------------------------------------------
|
|
Variant <-> Dynamic arrays support
|
|
---------------------------------------------------------------------}
|
|
|
|
function DynArrayGetVariantInfo(p : Pointer; var Dims : sizeint) : sizeint;
|
|
begin
|
|
Result:=varNull;
|
|
{ skip kind and name }
|
|
p:=aligntoptr(p+2+Length(PTypeInfo(p)^.Name));
|
|
|
|
{ search recursive? }
|
|
if PTypeInfo(PTypeData(p)^.elType2)^.kind=tkDynArray then
|
|
Result:=DynArrayGetVariantInfo(PTypeData(p)^.elType2,Dims)
|
|
else
|
|
Result:=PTypeData(p)^.varType;
|
|
inc(Dims);
|
|
end;
|
|
|
|
{$push}
|
|
{$r-}
|
|
|
|
procedure DynArrayToVariant(var V: Variant; const DynArray: Pointer; TypeInfo: Pointer);
|
|
var
|
|
i,
|
|
Dims : sizeint;
|
|
vararrtype,
|
|
dynarrvartype : LongInt;
|
|
vararraybounds : PVarArrayBoundArray;
|
|
iter : TVariantArrayIterator;
|
|
dynarriter : tdynarrayiter;
|
|
p : Pointer;
|
|
temp : Variant;
|
|
dynarraybounds : tdynarraybounds;
|
|
type
|
|
TDynArray = array of Pointer;
|
|
begin
|
|
DoVarClear(TVarData(v));
|
|
|
|
Dims:=0;
|
|
dynarrvartype:=DynArrayGetVariantInfo(TypeInfo,Dims);
|
|
|
|
vararrtype:=dynarrvartype;
|
|
|
|
if (Dims>1) and not(DynamicArrayIsRectangular(DynArray,TypeInfo)) then
|
|
exit;
|
|
|
|
{ retrieve Bounds array }
|
|
Setlength(dynarraybounds,Dims);
|
|
GetMem(vararraybounds,Dims*SizeOf(TVarArrayBound));
|
|
try
|
|
p:=DynArray;
|
|
for i:=0 to Dims-1 do
|
|
begin
|
|
vararraybounds^[i].LowBound:=0;
|
|
vararraybounds^[i].ElementCount:=length(TDynArray(p));
|
|
dynarraybounds[i]:=length(TDynArray(p));
|
|
if dynarraybounds[i]>0 then
|
|
{ we checked that the array is rectangular }
|
|
p:=TDynArray(p)[0];
|
|
end;
|
|
{ .. create Variant array }
|
|
V:=VarArrayCreate(vararraybounds,Dims,vararrtype);
|
|
|
|
VarArrayLock(V);
|
|
try
|
|
iter.init(Dims,PVarArrayBoundArray(vararraybounds));
|
|
dynarriter.init(DynArray,TypeInfo,Dims,dynarraybounds);
|
|
if not iter.AtEnd then
|
|
repeat
|
|
case vararrtype of
|
|
varSmallInt:
|
|
temp:=PSmallInt(dynarriter.data)^;
|
|
varInteger:
|
|
temp:=PInteger(dynarriter.data)^;
|
|
{$ifndef FPUNONE}
|
|
varSingle:
|
|
temp:=PSingle(dynarriter.data)^;
|
|
varDouble:
|
|
temp:=PDouble(dynarriter.data)^;
|
|
varDate:
|
|
temp:=PDouble(dynarriter.data)^;
|
|
{$endif}
|
|
varCurrency:
|
|
temp:=PCurrency(dynarriter.data)^;
|
|
varOleStr:
|
|
temp:=PWideString(dynarriter.data)^;
|
|
varDispatch:
|
|
temp:=PDispatch(dynarriter.data)^;
|
|
varError:
|
|
temp:=PError(dynarriter.data)^;
|
|
varBoolean:
|
|
temp:=PBoolean(dynarriter.data)^;
|
|
varVariant:
|
|
temp:=PVariant(dynarriter.data)^;
|
|
varUnknown:
|
|
temp:=PUnknown(dynarriter.data)^;
|
|
varShortInt:
|
|
temp:=PShortInt(dynarriter.data)^;
|
|
varByte:
|
|
temp:=PByte(dynarriter.data)^;
|
|
varWord:
|
|
temp:=PWord(dynarriter.data)^;
|
|
varLongWord:
|
|
temp:=PLongWord(dynarriter.data)^;
|
|
varInt64:
|
|
temp:=PInt64(dynarriter.data)^;
|
|
varQWord:
|
|
temp:=PQWord(dynarriter.data)^;
|
|
else
|
|
VarClear(temp);
|
|
end;
|
|
dynarriter.next;
|
|
VarArrayPut(V,temp,Slice(iter.Coords^,Dims));
|
|
until not(iter.next);
|
|
finally
|
|
iter.done;
|
|
dynarriter.done;
|
|
VarArrayUnlock(V);
|
|
end;
|
|
finally
|
|
FreeMem(vararraybounds);
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure DynArrayFromVariant(var DynArray: Pointer; const V: Variant; TypeInfo: Pointer);
|
|
var
|
|
DynArrayDims,
|
|
VarArrayDims : SizeInt;
|
|
iter : TVariantArrayIterator;
|
|
dynarriter : tdynarrayiter;
|
|
temp : Variant;
|
|
dynarrvartype : LongInt;
|
|
vararraybounds : PVarArrayBoundArray;
|
|
dynarraybounds : tdynarraybounds;
|
|
i : SizeInt;
|
|
type
|
|
TDynArray = array of Pointer;
|
|
begin
|
|
VarArrayDims:=VarArrayDimCount(V);
|
|
|
|
DynArrayDims:=0;
|
|
dynarrvartype:=DynArrayGetVariantInfo(TypeInfo,DynArrayDims);
|
|
|
|
if (VarArrayDims=0) or (VarArrayDims<>DynArrayDims) then
|
|
VarResultCheck(VAR_INVALIDARG);
|
|
|
|
{ retrieve Bounds array }
|
|
Setlength(dynarraybounds,VarArrayDims);
|
|
GetMem(vararraybounds,VarArrayDims*SizeOf(TVarArrayBound));
|
|
try
|
|
for i:=0 to VarArrayDims-1 do
|
|
begin
|
|
vararraybounds^[i].LowBound:=VarArrayLowBound(V,i+1);
|
|
vararraybounds^[i].ElementCount:=VarArrayHighBound(V,i+1)-vararraybounds^[i].LowBound+1;
|
|
dynarraybounds[i]:=vararraybounds^[i].ElementCount;
|
|
end;
|
|
DynArraySetLength(DynArray,TypeInfo,VarArrayDims,PSizeInt(dynarraybounds));
|
|
VarArrayLock(V);
|
|
try
|
|
iter.init(VarArrayDims,PVarArrayBoundArray(vararraybounds));
|
|
dynarriter.init(DynArray,TypeInfo,VarArrayDims,dynarraybounds);
|
|
if not iter.AtEnd then
|
|
repeat
|
|
temp:=VarArrayGet(V,Slice(iter.Coords^,VarArrayDims));
|
|
case dynarrvartype of
|
|
varSmallInt:
|
|
PSmallInt(dynarriter.data)^:=temp;
|
|
varInteger:
|
|
PInteger(dynarriter.data)^:=temp;
|
|
{$ifndef FPUNONE}
|
|
varSingle:
|
|
PSingle(dynarriter.data)^:=temp;
|
|
varDouble:
|
|
PDouble(dynarriter.data)^:=temp;
|
|
varDate:
|
|
PDouble(dynarriter.data)^:=temp;
|
|
{$endif}
|
|
varCurrency:
|
|
PCurrency(dynarriter.data)^:=temp;
|
|
varOleStr:
|
|
PWideString(dynarriter.data)^:=temp;
|
|
varDispatch:
|
|
PDispatch(dynarriter.data)^:=temp;
|
|
varError:
|
|
PError(dynarriter.data)^:=temp;
|
|
varBoolean:
|
|
PBoolean(dynarriter.data)^:=temp;
|
|
varVariant:
|
|
PVariant(dynarriter.data)^:=temp;
|
|
varUnknown:
|
|
PUnknown(dynarriter.data)^:=temp;
|
|
varShortInt:
|
|
PShortInt(dynarriter.data)^:=temp;
|
|
varByte:
|
|
PByte(dynarriter.data)^:=temp;
|
|
varWord:
|
|
PWord(dynarriter.data)^:=temp;
|
|
varLongWord:
|
|
PLongWord(dynarriter.data)^:=temp;
|
|
varInt64:
|
|
PInt64(dynarriter.data)^:=temp;
|
|
varQWord:
|
|
PQWord(dynarriter.data)^:=temp;
|
|
else
|
|
VarCastError;
|
|
end;
|
|
dynarriter.next;
|
|
until not(iter.next);
|
|
finally
|
|
iter.done;
|
|
dynarriter.done;
|
|
VarArrayUnlock(V);
|
|
end;
|
|
finally
|
|
FreeMem(vararraybounds);
|
|
end;
|
|
end;
|
|
{$pop}//{$r-} for DynArray[From|To]Variant
|
|
|
|
|
|
function FindCustomVariantType(const aVarType: TVarType; out CustomVariantType: TCustomVariantType): Boolean; overload;
|
|
begin
|
|
Result:=(aVarType>=CMinVarType);
|
|
if Result then
|
|
begin
|
|
EnterCriticalSection(customvarianttypelock);
|
|
try
|
|
Result:=(aVarType-CMinVarType)<=high(customvarianttypes);
|
|
if Result then
|
|
begin
|
|
CustomVariantType:=customvarianttypes[aVarType-CMinVarType];
|
|
Result:=assigned(CustomVariantType) and
|
|
(CustomVariantType<>InvalidCustomVariantType);
|
|
end;
|
|
finally
|
|
LeaveCriticalSection(customvarianttypelock);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
function FindCustomVariantType(const TypeName: string; out CustomVariantType: TCustomVariantType): Boolean; overload;
|
|
var
|
|
i: Integer;
|
|
tmp: TCustomVariantType;
|
|
ShortTypeName: shortstring;
|
|
begin
|
|
ShortTypeName:=TypeName; // avoid conversion in the loop
|
|
result:=False;
|
|
EnterCriticalSection(customvarianttypelock);
|
|
try
|
|
for i:=low(customvarianttypes) to high(customvarianttypes) do
|
|
begin
|
|
tmp:=customvarianttypes[i];
|
|
result:=Assigned(tmp) and (tmp<>InvalidCustomVariantType) and
|
|
tmp.ClassNameIs(ShortTypeName);
|
|
if result then
|
|
begin
|
|
CustomVariantType:=tmp;
|
|
Exit;
|
|
end;
|
|
end;
|
|
finally
|
|
LeaveCriticalSection(customvarianttypelock);
|
|
end;
|
|
end;
|
|
|
|
function Unassigned: Variant; // Unassigned standard constant
|
|
begin
|
|
SysVarClear(Result);
|
|
TVarData(Result).vType := varEmpty;
|
|
end;
|
|
|
|
|
|
function Null: Variant; // Null standard constant
|
|
begin
|
|
SysVarClear(Result);
|
|
TVarData(Result).vType := varNull;
|
|
end;
|
|
|
|
procedure VarDispInvokeError;
|
|
begin
|
|
raise EVariantDispatchError.Create(SDispatchError);
|
|
end;
|
|
|
|
{ ---------------------------------------------------------------------
|
|
TCustomVariantType Class.
|
|
---------------------------------------------------------------------}
|
|
|
|
{ All TCustomVariantType descendants are singletons, they ignore automatic refcounting. }
|
|
function TCustomVariantType.QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID; out Obj): HResult; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
|
|
begin
|
|
if GetInterface(IID, obj) then
|
|
result := S_OK
|
|
else
|
|
result := E_NOINTERFACE;
|
|
end;
|
|
|
|
|
|
function TCustomVariantType._AddRef: Integer; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
|
|
begin
|
|
result := -1;
|
|
end;
|
|
|
|
|
|
function TCustomVariantType._Release: Integer; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
|
|
begin
|
|
result := -1;
|
|
end;
|
|
|
|
{$warnings off}
|
|
procedure TCustomVariantType.SimplisticClear(var V: TVarData);
|
|
begin
|
|
VarDataInit(V);
|
|
end;
|
|
|
|
|
|
procedure TCustomVariantType.SimplisticCopy(var Dest: TVarData; const Source: TVarData; const Indirect: Boolean = False);
|
|
begin
|
|
NotSupported('TCustomVariantType.SimplisticCopy');
|
|
end;
|
|
|
|
|
|
procedure TCustomVariantType.RaiseInvalidOp;
|
|
begin
|
|
VarInvalidOp;
|
|
end;
|
|
|
|
|
|
procedure TCustomVariantType.RaiseCastError;
|
|
begin
|
|
VarCastError;
|
|
end;
|
|
|
|
|
|
procedure TCustomVariantType.RaiseDispError;
|
|
begin
|
|
VarDispInvokeError;
|
|
end;
|
|
|
|
|
|
|
|
function TCustomVariantType.LeftPromotion(const V: TVarData; const Operation: TVarOp; out RequiredVarType: TVarType): Boolean;
|
|
|
|
begin
|
|
NotSupported('TCustomVariantType.LeftPromotion');
|
|
end;
|
|
|
|
|
|
function TCustomVariantType.RightPromotion(const V: TVarData; const Operation: TVarOp; out RequiredVarType: TVarType): Boolean;
|
|
|
|
begin
|
|
NotSupported('TCustomVariantType.RightPromotion');
|
|
end;
|
|
|
|
|
|
function TCustomVariantType.OlePromotion(const V: TVarData; out RequiredVarType: TVarType): Boolean;
|
|
|
|
begin
|
|
NotSupported('TCustomVariantType.OlePromotion');
|
|
end;
|
|
|
|
|
|
procedure TCustomVariantType.DispInvoke(Dest: PVarData; const Source: TVarData; CallDesc: PCallDesc; Params: Pointer);
|
|
|
|
begin
|
|
RaiseDispError;
|
|
end;
|
|
|
|
|
|
|
|
procedure TCustomVariantType.VarDataInit(var Dest: TVarData);
|
|
|
|
begin
|
|
FillChar(Dest,SizeOf(Dest),0);
|
|
end;
|
|
|
|
|
|
procedure TCustomVariantType.VarDataClear(var Dest: TVarData);
|
|
|
|
begin
|
|
VarClearProc(Dest);
|
|
end;
|
|
|
|
|
|
|
|
procedure TCustomVariantType.VarDataCopy(var Dest: TVarData; const Source: TVarData);
|
|
|
|
begin
|
|
DoVarCopy(Dest,Source)
|
|
end;
|
|
|
|
|
|
procedure TCustomVariantType.VarDataCopyNoInd(var Dest: TVarData; const Source: TVarData);
|
|
|
|
begin
|
|
// This is probably not correct, but there is no DoVarCopyInd
|
|
DoVarCopy(Dest,Source);
|
|
end;
|
|
|
|
|
|
|
|
procedure TCustomVariantType.VarDataCast(var Dest: TVarData; const Source: TVarData);
|
|
|
|
begin
|
|
DoVarCast(Dest, Source, VarType);
|
|
end;
|
|
|
|
|
|
procedure TCustomVariantType.VarDataCastTo(var Dest: TVarData; const Source: TVarData; const aVarType: TVarType);
|
|
|
|
begin
|
|
DoVarCast(Dest, Source, AVarType);
|
|
end;
|
|
|
|
|
|
procedure TCustomVariantType.VarDataCastTo(var Dest: TVarData; const aVarType: TVarType);
|
|
|
|
begin
|
|
DoVarCast(Dest,Dest,AVarType);
|
|
end;
|
|
|
|
|
|
procedure TCustomVariantType.VarDataCastToOleStr(var Dest: TVarData);
|
|
|
|
begin
|
|
VarDataCastTo(Dest, Dest, varOleStr);
|
|
end;
|
|
|
|
|
|
|
|
procedure TCustomVariantType.VarDataFromStr(var V: TVarData; const Value: string);
|
|
|
|
begin
|
|
sysvarfromlstr(Variant(V),Value);
|
|
end;
|
|
|
|
|
|
procedure TCustomVariantType.VarDataFromOleStr(var V: TVarData; const Value: WideString);
|
|
|
|
begin
|
|
sysvarfromwstr(variant(V),Value);
|
|
end;
|
|
|
|
|
|
function TCustomVariantType.VarDataToStr(const V: TVarData): string;
|
|
|
|
begin
|
|
sysvartolstr(Result,Variant(V));
|
|
end;
|
|
|
|
|
|
|
|
function TCustomVariantType.VarDataIsEmptyParam(const V: TVarData): Boolean;
|
|
|
|
begin
|
|
Result:=VarIsEmptyParam(Variant(V));
|
|
end;
|
|
|
|
|
|
function TCustomVariantType.VarDataIsByRef(const V: TVarData): Boolean;
|
|
|
|
begin
|
|
Result:=(V.vType and varByRef)=varByRef;
|
|
end;
|
|
|
|
|
|
function TCustomVariantType.VarDataIsArray(const V: TVarData): Boolean;
|
|
|
|
begin
|
|
Result:=(V.vType and varArray)=varArray;
|
|
end;
|
|
|
|
|
|
|
|
function TCustomVariantType.VarDataIsOrdinal(const V: TVarData): Boolean;
|
|
|
|
begin
|
|
Result:=(V.vType and varTypeMask) in OrdinalVarTypes;
|
|
end;
|
|
|
|
|
|
function TCustomVariantType.VarDataIsFloat(const V: TVarData): Boolean;
|
|
|
|
begin
|
|
Result:=(V.vType and varTypeMask) in FloatVarTypes;
|
|
end;
|
|
|
|
|
|
function TCustomVariantType.VarDataIsNumeric(const V: TVarData): Boolean;
|
|
|
|
begin
|
|
Result:=(V.vType and varTypeMask) in (OrdinalVarTypes + FloatVarTypes);
|
|
end;
|
|
|
|
|
|
function TCustomVariantType.VarDataIsStr(const V: TVarData): Boolean;
|
|
|
|
begin
|
|
Result:=
|
|
((V.vType and varTypeMask) = varOleStr) or
|
|
((V.vType and varTypeMask) = varString);
|
|
end;
|
|
|
|
|
|
procedure RegisterCustomVariantType(obj: TCustomVariantType; RequestedVarType: TVarType;
|
|
UseFirstAvailable: Boolean);
|
|
var
|
|
index,L: Integer;
|
|
begin
|
|
EnterCriticalSection(customvarianttypelock);
|
|
try
|
|
L:=Length(customvarianttypes);
|
|
if UseFirstAvailable then
|
|
begin
|
|
repeat
|
|
inc(customvariantcurrtype);
|
|
if customvariantcurrtype>=CMaxVarType then
|
|
raise EVariantError.Create(SVarTypeTooManyCustom);
|
|
until ((customvariantcurrtype-CMinVarType)>=L) or
|
|
(customvarianttypes[customvariantcurrtype-CMinVarType]=nil);
|
|
RequestedVarType:=customvariantcurrtype;
|
|
end
|
|
else if (RequestedVarType<CFirstUserType) or (RequestedVarType>CMaxVarType) then
|
|
raise EVariantError.CreateFmt(SVarTypeOutOfRangeWithPrefix, ['$', RequestedVarType]);
|
|
|
|
index:=RequestedVarType-CMinVarType;
|
|
if index>=L then
|
|
SetLength(customvarianttypes,L+1);
|
|
if Assigned(customvarianttypes[index]) then
|
|
begin
|
|
if customvarianttypes[index]=InvalidCustomVariantType then
|
|
raise EVariantError.CreateFmt(SVarTypeNotUsableWithPrefix, ['$', RequestedVarType])
|
|
else
|
|
raise EVariantError.CreateFmt(SVarTypeAlreadyUsedWithPrefix,
|
|
['$', RequestedVarType, customvarianttypes[index].ClassName]);
|
|
end;
|
|
customvarianttypes[index]:=obj;
|
|
obj.FVarType:=RequestedVarType;
|
|
finally
|
|
LeaveCriticalSection(customvarianttypelock);
|
|
end;
|
|
end;
|
|
|
|
constructor TCustomVariantType.Create;
|
|
begin
|
|
RegisterCustomVariantType(Self,0,True);
|
|
end;
|
|
|
|
constructor TCustomVariantType.Create(RequestedVarType: TVarType);
|
|
begin
|
|
RegisterCustomVariantType(Self,RequestedVarType,False);
|
|
end;
|
|
|
|
|
|
destructor TCustomVariantType.Destroy;
|
|
begin
|
|
EnterCriticalSection(customvarianttypelock);
|
|
try
|
|
if FVarType<>0 then
|
|
customvarianttypes[FVarType-CMinVarType]:=InvalidCustomVariantType;
|
|
finally
|
|
LeaveCriticalSection(customvarianttypelock);
|
|
end;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
|
|
|
|
function TCustomVariantType.IsClear(const V: TVarData): Boolean;
|
|
begin
|
|
result:=False;
|
|
end;
|
|
|
|
|
|
procedure TCustomVariantType.Cast(var Dest: TVarData; const Source: TVarData);
|
|
|
|
begin
|
|
DoVarCast(Dest,Source,VarType);
|
|
end;
|
|
|
|
|
|
procedure TCustomVariantType.CastTo(var Dest: TVarData; const Source: TVarData; const aVarType: TVarType);
|
|
|
|
begin
|
|
DoVarCast(Dest,Source,AVarType);
|
|
end;
|
|
|
|
|
|
procedure TCustomVariantType.CastToOle(var Dest: TVarData; const Source: TVarData);
|
|
|
|
begin
|
|
NotSupported('TCustomVariantType.CastToOle');
|
|
end;
|
|
|
|
|
|
|
|
procedure TCustomVariantType.BinaryOp(var Left: TVarData; const Right: TVarData; const Operation: TVarOp);
|
|
|
|
begin
|
|
RaiseInvalidOp;
|
|
end;
|
|
|
|
|
|
procedure TCustomVariantType.UnaryOp(var Right: TVarData; const Operation: TVarOp);
|
|
|
|
begin
|
|
RaiseInvalidOp;
|
|
end;
|
|
|
|
|
|
function TCustomVariantType.CompareOp(const Left, Right: TVarData; const Operation: TVarOp): Boolean;
|
|
|
|
begin
|
|
NotSupported('TCustomVariantType.CompareOp');
|
|
end;
|
|
|
|
|
|
procedure TCustomVariantType.Compare(const Left, Right: TVarData; var Relationship: TVarCompareResult);
|
|
|
|
begin
|
|
NotSupported('TCustomVariantType.Compare');
|
|
end;
|
|
{$warnings on}
|
|
|
|
{ ---------------------------------------------------------------------
|
|
TInvokeableVariantType implementation
|
|
---------------------------------------------------------------------}
|
|
|
|
procedure TInvokeableVariantType.DispInvoke(Dest: PVarData; const Source: TVarData;
|
|
CallDesc: PCallDesc; Params: Pointer);
|
|
var
|
|
method_name: ansistring;
|
|
arg_count: byte;
|
|
args: TVarDataArray;
|
|
arg_idx: byte;
|
|
arg_type: byte;
|
|
arg_byref, has_result: boolean;
|
|
arg_ptr: pointer;
|
|
arg_data: PVarData;
|
|
dummy_data: TVarData;
|
|
const
|
|
argtype_mask = $7F;
|
|
argref_mask = $80;
|
|
begin
|
|
arg_count := CallDesc^.ArgCount;
|
|
method_name := ansistring(pchar(@CallDesc^.ArgTypes[arg_count]));
|
|
setLength(args, arg_count);
|
|
if arg_count > 0 then
|
|
begin
|
|
arg_ptr := Params;
|
|
for arg_idx := 0 to arg_count - 1 do
|
|
begin
|
|
arg_type := CallDesc^.ArgTypes[arg_idx] and argtype_mask;
|
|
arg_byref := (CallDesc^.ArgTypes[arg_idx] and argref_mask) <> 0;
|
|
arg_data := @args[arg_count - arg_idx - 1];
|
|
case arg_type of
|
|
varUStrArg: arg_data^.vType := varUString;
|
|
varStrArg: arg_data^.vType := varString;
|
|
else
|
|
arg_data^.vType := arg_type
|
|
end;
|
|
if arg_byref then
|
|
begin
|
|
arg_data^.vType := arg_data^.vType or varByRef;
|
|
arg_data^.vPointer := PPointer(arg_ptr)^;
|
|
Inc(arg_ptr,sizeof(Pointer));
|
|
end
|
|
else
|
|
case arg_type of
|
|
varError:
|
|
arg_data^.vError:=VAR_PARAMNOTFOUND;
|
|
varVariant:
|
|
begin
|
|
arg_data^ := PVarData(PPointer(arg_ptr)^)^;
|
|
Inc(arg_ptr,sizeof(Pointer));
|
|
end;
|
|
varDouble, varCurrency, varInt64, varQWord:
|
|
begin
|
|
arg_data^.vQWord := PQWord(arg_ptr)^; // 64bit on all platforms
|
|
inc(arg_ptr,sizeof(qword))
|
|
end
|
|
else
|
|
arg_data^.vAny := PPointer(arg_ptr)^; // 32 or 64bit
|
|
inc(arg_ptr,sizeof(pointer))
|
|
end;
|
|
end;
|
|
end;
|
|
has_result := (Dest <> nil);
|
|
if has_result then
|
|
variant(Dest^) := Unassigned;
|
|
case CallDesc^.CallType of
|
|
|
|
1: { DISPATCH_METHOD }
|
|
if has_result then
|
|
begin
|
|
if arg_count = 0 then
|
|
begin
|
|
// no args -- try GetProperty first, then DoFunction
|
|
if not (GetProperty(Dest^,Source,method_name) or
|
|
DoFunction(Dest^,Source,method_name,args)) then
|
|
RaiseDispError
|
|
end
|
|
else
|
|
if not DoFunction(Dest^,Source,method_name,args) then
|
|
RaiseDispError;
|
|
end
|
|
else
|
|
begin
|
|
// may be procedure?
|
|
if not DoProcedure(Source,method_name,args) then
|
|
// may be function?
|
|
try
|
|
variant(dummy_data) := Unassigned;
|
|
if not DoFunction(dummy_data,Source,method_name,args) then
|
|
RaiseDispError;
|
|
finally
|
|
VarDataClear(dummy_data)
|
|
end;
|
|
end;
|
|
|
|
2: { DISPATCH_PROPERTYGET -- currently never generated by compiler for Variant Dispatch }
|
|
if has_result then
|
|
begin
|
|
// must be property...
|
|
if not GetProperty(Dest^,Source,method_name) then
|
|
// may be function?
|
|
if not DoFunction(Dest^,Source,method_name,args) then
|
|
RaiseDispError
|
|
end
|
|
else
|
|
RaiseDispError;
|
|
|
|
4: { DISPATCH_PROPERTYPUT }
|
|
if has_result or (arg_count<>1) or // must be no result and a single arg
|
|
(not SetProperty(Source,method_name,args[0])) then
|
|
RaiseDispError;
|
|
else
|
|
RaiseDispError;
|
|
end;
|
|
end;
|
|
|
|
function TInvokeableVariantType.DoFunction(var Dest: TVarData; const V: TVarData; const Name: string; const Arguments: TVarDataArray): Boolean;
|
|
|
|
begin
|
|
result := False;
|
|
end;
|
|
|
|
function TInvokeableVariantType.DoProcedure(const V: TVarData; const Name: string; const Arguments: TVarDataArray): Boolean;
|
|
begin
|
|
result := False
|
|
end;
|
|
|
|
|
|
function TInvokeableVariantType.GetProperty(var Dest: TVarData; const V: TVarData; const Name: string): Boolean;
|
|
begin
|
|
result := False;
|
|
end;
|
|
|
|
|
|
function TInvokeableVariantType.SetProperty(const V: TVarData; const Name: string; const Value: TVarData): Boolean;
|
|
begin
|
|
result := False;
|
|
end;
|
|
|
|
|
|
{ ---------------------------------------------------------------------
|
|
TPublishableVariantType implementation
|
|
---------------------------------------------------------------------}
|
|
|
|
function TPublishableVariantType.GetProperty(var Dest: TVarData; const V: TVarData; const Name: string): Boolean;
|
|
begin
|
|
Result:=true;
|
|
Variant(Dest):=GetPropValue(getinstance(v),name);
|
|
end;
|
|
|
|
|
|
function TPublishableVariantType.SetProperty(const V: TVarData; const Name: string; const Value: TVarData): Boolean;
|
|
begin
|
|
Result:=true;
|
|
SetPropValue(getinstance(v),name,Variant(value));
|
|
end;
|
|
|
|
|
|
procedure VarCastError;
|
|
begin
|
|
raise EVariantTypeCastError.Create(SInvalidVarCast);
|
|
end;
|
|
|
|
|
|
procedure VarCastError(const ASourceType, ADestType: TVarType);
|
|
begin
|
|
raise EVariantTypeCastError.CreateFmt(SVarTypeCouldNotConvert,
|
|
[VarTypeAsText(ASourceType),VarTypeAsText(ADestType)]);
|
|
end;
|
|
|
|
|
|
procedure VarCastErrorOle(const ASourceType: TVarType);
|
|
begin
|
|
raise EVariantTypeCastError.CreateFmt(SVarTypeCouldNotConvert,
|
|
[VarTypeAsText(ASourceType),'(OleVariant)']);
|
|
end;
|
|
|
|
|
|
procedure VarInvalidOp;
|
|
begin
|
|
raise EVariantInvalidOpError.Create(SInvalidVarOp);
|
|
end;
|
|
|
|
procedure VarInvalidOp(const aLeft, aRight: TVarType; aOpCode: TVarOp);
|
|
begin
|
|
raise EVariantInvalidOpError.CreateFmt(SInvalidBinaryVarOp,
|
|
[VarTypeAsText(aLeft),VarOpAsText[aOpCode],VarTypeAsText(aRight)]);
|
|
end;
|
|
|
|
|
|
procedure VarInvalidOp(const aRight: TVarType; aOpCode: TVarOp);
|
|
begin
|
|
raise EVariantInvalidOpError.CreateFmt(SInvalidUnaryVarOp,
|
|
[VarOpAsText[aOpCode],VarTypeAsText(aRight)]);
|
|
end;
|
|
|
|
|
|
procedure VarInvalidNullOp;
|
|
begin
|
|
raise EVariantInvalidOpError.Create(SInvalidvarNullOp);
|
|
end;
|
|
|
|
|
|
procedure VarParamNotFoundError;
|
|
begin
|
|
raise EVariantParamNotFoundError.Create(SVarParamNotFound);
|
|
end;
|
|
|
|
|
|
procedure VarBadTypeError;
|
|
begin
|
|
raise EVariantBadVarTypeError.Create(SVarBadType);
|
|
end;
|
|
|
|
|
|
procedure VarOverflowError;
|
|
begin
|
|
raise EVariantOverflowError.Create(SVarOverflow);
|
|
end;
|
|
|
|
|
|
procedure VarOverflowError(const ASourceType, ADestType: TVarType);
|
|
begin
|
|
raise EVariantOverflowError.CreateFmt(SVarTypeConvertOverflow,
|
|
[VarTypeAsText(ASourceType),VarTypeAsText(ADestType)]);
|
|
end;
|
|
|
|
|
|
procedure VarRangeCheckError(const AType: TVarType);
|
|
begin
|
|
raise EVariantOverflowError.CreateFmt(SVarTypeRangeCheck1,
|
|
[VarTypeAsText(AType)])
|
|
end;
|
|
|
|
|
|
procedure VarRangeCheckError(const ASourceType, ADestType: TVarType);
|
|
begin
|
|
if ASourceType<>ADestType then
|
|
raise EVariantOverflowError.CreateFmt(SVarTypeRangeCheck2,
|
|
[VarTypeAsText(ASourceType),VarTypeAsText(ADestType)])
|
|
else
|
|
VarRangeCheckError(ASourceType);
|
|
end;
|
|
|
|
|
|
procedure VarBadIndexError;
|
|
begin
|
|
raise EVariantBadIndexError.Create(SVarArrayBounds);
|
|
end;
|
|
|
|
|
|
procedure VarArrayLockedError;
|
|
begin
|
|
raise EVariantArrayLockedError.Create(SVarArrayLocked);
|
|
end;
|
|
|
|
|
|
procedure VarNotImplError;
|
|
begin
|
|
raise EVariantNotImplError.Create(SVarNotImplemented);
|
|
end;
|
|
|
|
|
|
procedure VarOutOfMemoryError;
|
|
begin
|
|
raise EVariantOutOfMemoryError.Create(SOutOfMemory);
|
|
end;
|
|
|
|
|
|
procedure VarInvalidArgError;
|
|
begin
|
|
raise EVariantInvalidArgError.Create(SVarInvalid);
|
|
end;
|
|
|
|
|
|
procedure VarInvalidArgError(AType: TVarType);
|
|
begin
|
|
raise EVariantInvalidArgError.CreateFmt(SVarInvalid1,
|
|
[VarTypeAsText(AType)])
|
|
end;
|
|
|
|
|
|
procedure VarUnexpectedError;
|
|
begin
|
|
raise EVariantUnexpectedError.Create(SVarUnexpected);
|
|
end;
|
|
|
|
|
|
procedure VarArrayCreateError;
|
|
begin
|
|
raise EVariantArrayCreateError.Create(SVarArrayCreate);
|
|
end;
|
|
|
|
|
|
procedure RaiseVarException(res : HRESULT);
|
|
begin
|
|
case res of
|
|
VAR_PARAMNOTFOUND:
|
|
VarParamNotFoundError;
|
|
VAR_TYPEMISMATCH:
|
|
VarCastError;
|
|
VAR_BADVARTYPE:
|
|
VarBadTypeError;
|
|
VAR_EXCEPTION:
|
|
VarInvalidOp;
|
|
VAR_OVERFLOW:
|
|
VarOverflowError;
|
|
VAR_BADINDEX:
|
|
VarBadIndexError;
|
|
VAR_ARRAYISLOCKED:
|
|
VarArrayLockedError;
|
|
VAR_NOTIMPL:
|
|
VarNotImplError;
|
|
VAR_OUTOFMEMORY:
|
|
VarOutOfMemoryError;
|
|
VAR_INVALIDARG:
|
|
VarInvalidArgError;
|
|
VAR_UNEXPECTED:
|
|
VarUnexpectedError;
|
|
else
|
|
raise EVariantError.CreateFmt(SInvalidVarOpWithHResultWithPrefix,
|
|
['$',res,'']);
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure VarResultCheck(AResult: HRESULT);{$IFDEF VARIANTINLINE}inline;{$ENDIF VARIANTINLINE}
|
|
begin
|
|
if AResult<>VAR_OK then
|
|
RaiseVarException(AResult);
|
|
end;
|
|
|
|
|
|
procedure VarResultCheck(AResult: HRESULT; ASourceType, ADestType: TVarType);
|
|
begin
|
|
case AResult of
|
|
VAR_OK:
|
|
;
|
|
VAR_OVERFLOW:
|
|
VarOverflowError(ASourceType,ADestType);
|
|
VAR_TYPEMISMATCH:
|
|
VarCastError(ASourceType,ADestType);
|
|
else
|
|
RaiseVarException(AResult);
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure HandleConversionException(const ASourceType, ADestType: TVarType);
|
|
begin
|
|
if exceptobject is econverterror then
|
|
VarCastError(asourcetype,adesttype)
|
|
else if (exceptobject is eoverflow) or
|
|
(exceptobject is erangeerror) then
|
|
varoverflowerror(asourcetype,adesttype)
|
|
else
|
|
raise exception(acquireexceptionobject);
|
|
end;
|
|
|
|
|
|
function VarTypeAsText(const AType: TVarType): string;
|
|
var
|
|
customvarianttype : TCustomVariantType;
|
|
const
|
|
names : array[varEmpty..varQWord] of string[8] = (
|
|
'Empty','Null','Smallint','Integer','Single','Double','Currency','Date','OleStr','Dispatch','Error','Boolean','Variant',
|
|
'Unknown','Decimal','???','ShortInt','Byte','Word','DWord','Int64','QWord');
|
|
begin
|
|
if ((AType and varTypeMask)>=low(names)) and ((AType and varTypeMask)<=high(names)) then
|
|
Result:=names[AType and varTypeMask]
|
|
else
|
|
case AType and varTypeMask of
|
|
varString:
|
|
Result:='String';
|
|
varAny:
|
|
Result:='Any';
|
|
else
|
|
begin
|
|
if FindCustomVariantType(AType and varTypeMask,customvarianttype) then
|
|
Result:=customvarianttype.classname
|
|
else
|
|
Result:='$'+IntToHex(AType and varTypeMask,4)
|
|
end;
|
|
end;
|
|
if (AType and vararray)<>0 then
|
|
Result:='Array of '+Result;
|
|
if (AType and varByRef)<>0 then
|
|
Result:='Ref to '+Result;
|
|
end;
|
|
|
|
|
|
function FindVarData(const V: Variant): PVarData;
|
|
begin
|
|
Result:=PVarData(@V);
|
|
while Result^.vType=varVariant or varByRef do
|
|
Result:=PVarData(Result^.vPointer);
|
|
end;
|
|
|
|
{ ---------------------------------------------------------------------
|
|
Variant properties from typinfo
|
|
---------------------------------------------------------------------}
|
|
|
|
function GetVariantProp(Instance : TObject;PropInfo : PPropInfo) : Variant;
|
|
type
|
|
TGetVariantProc = function:Variant of object;
|
|
TGetVariantProcIndex = function(Index: integer): Variant of object;
|
|
var
|
|
AMethod : TMethod;
|
|
begin
|
|
Result:=Null;
|
|
case PropInfo^.PropProcs and 3 of
|
|
ptField:
|
|
Result:=PVariant(Pointer(Instance)+PtrUInt(PropInfo^.GetProc))^;
|
|
ptStatic,
|
|
ptVirtual:
|
|
begin
|
|
if (PropInfo^.PropProcs and 3)=ptStatic then
|
|
AMethod.Code:=PropInfo^.GetProc
|
|
else
|
|
AMethod.Code:=PPointer(Pointer(Instance.ClassType)+PtrUInt(PropInfo^.GetProc))^;
|
|
AMethod.Data:=Instance;
|
|
|
|
if ((PropInfo^.PropProcs shr 6) and 1)=0 then
|
|
Result:=TGetVariantProc(AMethod)()
|
|
else
|
|
Result:=TGetVariantProcIndex(AMethod)(PropInfo^.Index);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
Procedure SetVariantProp(Instance : TObject;PropInfo : PPropInfo; const Value : Variant);
|
|
type
|
|
TSetVariantProc = procedure(const AValue: Variant) of object;
|
|
TSetVariantProcIndex = procedure(Index: integer; AValue: Variant) of object;
|
|
Var
|
|
AMethod : TMethod;
|
|
begin
|
|
case (PropInfo^.PropProcs shr 2) and 3 of
|
|
ptfield:
|
|
PVariant(Pointer(Instance)+PtrUInt(PropInfo^.SetProc))^:=Value;
|
|
ptVirtual,ptStatic:
|
|
begin
|
|
if ((PropInfo^.PropProcs shr 2) and 3)=ptStatic then
|
|
AMethod.Code:=PropInfo^.SetProc
|
|
else
|
|
AMethod.Code:=PPointer(Pointer(Instance.ClassType)+PtrUInt(PropInfo^.SetProc))^;
|
|
AMethod.Data:=Instance;
|
|
|
|
if ((PropInfo^.PropProcs shr 6) and 1)=0 then
|
|
TSetVariantProc(AMethod)(Value)
|
|
else
|
|
TSetVariantProcIndex(AMethod)(PropInfo^.Index,Value);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
Function GetVariantProp(Instance: TObject; const PropName: string): Variant;
|
|
begin
|
|
Result:=GetVariantProp(Instance,FindPropInfo(Instance,PropName));
|
|
end;
|
|
|
|
|
|
Procedure SetVariantProp(Instance: TObject; const PropName: string; const Value: Variant);
|
|
begin
|
|
SetVariantprop(instance,FindpropInfo(Instance,PropName),Value);
|
|
end;
|
|
|
|
{ ---------------------------------------------------------------------
|
|
All properties through Variant.
|
|
---------------------------------------------------------------------}
|
|
|
|
Function GetPropValue(Instance: TObject; const PropName: string): Variant;
|
|
begin
|
|
Result:=GetPropValue(Instance,PropName,True);
|
|
end;
|
|
|
|
|
|
Function GetPropValue(Instance: TObject; const PropName: string; PreferStrings: Boolean): Variant;
|
|
|
|
var
|
|
PropInfo: PPropInfo;
|
|
|
|
begin
|
|
// find the property
|
|
PropInfo := GetPropInfo(Instance, PropName);
|
|
if PropInfo = nil then
|
|
raise EPropertyError.CreateFmt(SErrPropertyNotFound, [PropName])
|
|
else
|
|
begin
|
|
Result := Null; //at worst
|
|
// call the Right GetxxxProp
|
|
case PropInfo^.PropType^.Kind of
|
|
tkInteger, tkChar, tkWChar, tkClass, tkBool:
|
|
Result := GetOrdProp(Instance, PropInfo);
|
|
tkEnumeration:
|
|
if PreferStrings then
|
|
Result := GetEnumProp(Instance, PropInfo)
|
|
else
|
|
Result := GetOrdProp(Instance, PropInfo);
|
|
tkSet:
|
|
if PreferStrings then
|
|
Result := GetSetProp(Instance, PropInfo, False)
|
|
else
|
|
Result := GetOrdProp(Instance, PropInfo);
|
|
{$ifndef FPUNONE}
|
|
tkFloat:
|
|
Result := GetFloatProp(Instance, PropInfo);
|
|
{$endif}
|
|
tkMethod:
|
|
Result := PropInfo^.PropType^.Name;
|
|
tkString, tkLString, tkAString:
|
|
Result := GetStrProp(Instance, PropInfo);
|
|
tkWString:
|
|
Result := GetWideStrProp(Instance, PropInfo);
|
|
tkUString:
|
|
Result := GetUnicodeStrProp(Instance, PropInfo);
|
|
tkVariant:
|
|
Result := GetVariantProp(Instance, PropInfo);
|
|
tkInt64:
|
|
Result := GetInt64Prop(Instance, PropInfo);
|
|
tkQWord:
|
|
Result := QWord(GetInt64Prop(Instance, PropInfo));
|
|
else
|
|
raise EPropertyConvertError.CreateFmt('Invalid Property Type: %s',[PropInfo^.PropType^.Name]);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
Procedure SetPropValue(Instance: TObject; const PropName: string; const Value: Variant);
|
|
|
|
var
|
|
PropInfo: PPropInfo;
|
|
TypeData: PTypeData;
|
|
O: Integer;
|
|
I64: Int64;
|
|
Qw: QWord;
|
|
S: String;
|
|
B: Boolean;
|
|
|
|
begin
|
|
// find the property
|
|
PropInfo := GetPropInfo(Instance, PropName);
|
|
if PropInfo = nil then
|
|
raise EPropertyError.CreateFmt(SErrPropertyNotFound, [PropName])
|
|
else
|
|
begin
|
|
TypeData := GetTypeData(PropInfo^.PropType);
|
|
// call Right SetxxxProp
|
|
case PropInfo^.PropType^.Kind of
|
|
tkBool:
|
|
begin
|
|
{ to support the strings 'true' and 'false' }
|
|
if (VarType(Value)=varOleStr) or
|
|
(VarType(Value)=varString) or
|
|
(VarType(Value)=varBoolean) then
|
|
begin
|
|
B:=Value;
|
|
SetOrdProp(Instance, PropInfo, ord(B));
|
|
end
|
|
else
|
|
begin
|
|
I64:=Value;
|
|
if (I64<TypeData^.MinValue) or (I64>TypeData^.MaxValue) then
|
|
raise ERangeError.Create(SRangeError);
|
|
SetOrdProp(Instance, PropInfo, I64);
|
|
end;
|
|
end;
|
|
tkInteger, tkChar, tkWChar:
|
|
begin
|
|
I64:=Value;
|
|
if (TypeData^.OrdType=otULong) then
|
|
if (I64<LongWord(TypeData^.MinValue)) or (I64>LongWord(TypeData^.MaxValue)) then
|
|
raise ERangeError.Create(SRangeError)
|
|
else
|
|
else
|
|
if (I64<TypeData^.MinValue) or (I64>TypeData^.MaxValue) then
|
|
raise ERangeError.Create(SRangeError);
|
|
SetOrdProp(Instance, PropInfo, I64);
|
|
end;
|
|
tkEnumeration :
|
|
begin
|
|
if (VarType(Value)=varOleStr) or (VarType(Value)=varString) then
|
|
begin
|
|
S:=Value;
|
|
SetEnumProp(Instance,PropInfo,S);
|
|
end
|
|
else
|
|
begin
|
|
I64:=Value;
|
|
if (I64<TypeData^.MinValue) or (I64>TypeData^.MaxValue) then
|
|
raise ERangeError.Create(SRangeError);
|
|
SetOrdProp(Instance, PropInfo, I64);
|
|
end;
|
|
end;
|
|
tkSet :
|
|
begin
|
|
if (VarType(Value)=varOleStr) or (VarType(Value)=varString) then
|
|
begin
|
|
S:=Value;
|
|
SetSetProp(Instance,PropInfo,S);
|
|
end
|
|
else
|
|
begin
|
|
O:=Value;
|
|
SetOrdProp(Instance, PropInfo, O);
|
|
end;
|
|
end;
|
|
{$ifndef FPUNONE}
|
|
tkFloat:
|
|
SetFloatProp(Instance, PropInfo, Value);
|
|
{$endif}
|
|
tkString, tkLString, tkAString:
|
|
SetStrProp(Instance, PropInfo, VarToStr(Value));
|
|
tkWString:
|
|
SetWideStrProp(Instance, PropInfo, VarToWideStr(Value));
|
|
tkUString:
|
|
SetUnicodeStrProp(Instance, PropInfo, VarToUnicodeStr(Value));
|
|
tkVariant:
|
|
SetVariantProp(Instance, PropInfo, Value);
|
|
tkInt64:
|
|
begin
|
|
I64:=Value;
|
|
if (I64<TypeData^.MinInt64Value) or (I64>TypeData^.MaxInt64Value) then
|
|
raise ERangeError.Create(SRangeError);
|
|
SetInt64Prop(Instance, PropInfo, I64);
|
|
end;
|
|
tkQWord:
|
|
begin
|
|
Qw:=Value;
|
|
if (Qw<TypeData^.MinQWordValue) or (Qw>TypeData^.MaxQWordValue) then
|
|
raise ERangeError.Create(SRangeError);
|
|
SetInt64Prop(Instance, PropInfo,Qw);
|
|
end
|
|
else
|
|
raise EPropertyConvertError.CreateFmt('SetPropValue: Invalid Property Type %s',
|
|
[PropInfo^.PropType^.Name]);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
var
|
|
i : LongInt;
|
|
|
|
Initialization
|
|
InitCriticalSection(customvarianttypelock);
|
|
// start with one-less value, so first increment yields CFirstUserType
|
|
customvariantcurrtype:=CFirstUserType-1;
|
|
SetSysVariantManager;
|
|
SetClearVarToEmptyParam(TVarData(EmptyParam));
|
|
VarClearProc:=@DoVarClear;
|
|
VarAddRefProc:=@DoVarAddRef;
|
|
VarCopyProc:=@DoVarCopy;
|
|
// Typinfo Variant support
|
|
OnGetVariantProp:=@GetVariantprop;
|
|
OnSetVariantProp:=@SetVariantprop;
|
|
OnSetPropValue:=@SetPropValue;
|
|
OnGetPropValue:=@GetPropValue;
|
|
InvalidCustomVariantType:=TCustomVariantType(-1);
|
|
SetLength(customvarianttypes,CFirstUserType);
|
|
Finalization
|
|
EnterCriticalSection(customvarianttypelock);
|
|
try
|
|
for i:=0 to high(customvarianttypes) do
|
|
if customvarianttypes[i]<>InvalidCustomVariantType then
|
|
customvarianttypes[i].Free;
|
|
finally
|
|
LeaveCriticalSection(customvarianttypelock);
|
|
end;
|
|
UnSetSysVariantManager;
|
|
DoneCriticalSection(customvarianttypelock);
|
|
end.
|