{ 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 VarIsBool(const V: Variant): Boolean; inline; 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 highbound0 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; 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 VarIsBool(const V: Variant): Boolean; begin Result := (TVarData(V).vType and varTypeMask) = varboolean; 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 AValueb 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 (RequestedVarTypeCMaxVarType) 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 (I64TypeData^.MaxValue) then raise ERangeError.Create(SRangeError); SetOrdProp(Instance, PropInfo, I64); end; end; tkInteger, tkChar, tkWChar: begin I64:=Value; if (TypeData^.OrdType=otULong) then if (I64LongWord(TypeData^.MaxValue)) then raise ERangeError.Create(SRangeError) else else if (I64TypeData^.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 (I64TypeData^.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 (I64TypeData^.MaxInt64Value) then raise ERangeError.Create(SRangeError); SetInt64Prop(Instance, PropInfo, I64); end; tkQWord: begin Qw:=Value; if (QwTypeData^.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.