{ This include file contains the variants support for FPC This file is part of the Free Pascal run time library. Copyright (c) 2001-2005 by the Free Pascal development team See the file COPYING.FPC, included in this distribution, for details about the copyright. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. **********************************************************************} {$IFDEF fpc} {$mode objfpc} {$ENDIF} {$h+} { Using inlining for small system functions/wrappers } {$inline on} {$define VARIANTINLINE} unit variants; interface uses sysutils,sysconst,rtlconsts,typinfo; type EVariantParamNotFoundError = class(EVariantError); EVariantInvalidOpError = class(EVariantError); EVariantTypeCastError = class(EVariantError); EVariantOverflowError = class(EVariantError); EVariantInvalidArgError = class(EVariantError); EVariantBadVarTypeError = class(EVariantError); EVariantBadIndexError = class(EVariantError); EVariantArrayLockedError = class(EVariantError); EVariantNotAnArrayError = class(EVariantError); EVariantArrayCreateError = class(EVariantError); EVariantNotImplError = class(EVariantError); EVariantOutOfMemoryError = class(EVariantError); EVariantUnexpectedError = class(EVariantError); EVariantDispatchError = class(EVariantError); EVariantRangeCheckError = class(EVariantOverflowError); EVariantInvalidNullOpError = class(EVariantInvalidOpError); TVariantRelationship = (vrEqual, vrLessThan, vrGreaterThan, vrNotEqual); TNullCompareRule = (ncrError, ncrStrict, ncrLoose); TBooleanToStringRule = (bsrAsIs, bsrLower, bsrUpper); Const OrdinalVarTypes = [varSmallInt, varInteger, varBoolean, varShortInt, varByte, varWord,varLongWord,varInt64]; FloatVarTypes = [ {$ifndef FPUNONE} varSingle, varDouble, {$endif} varCurrency]; { Variant support procedures and functions } function VarType(const V: Variant): TVarType; inline; function VarTypeDeRef(const V: Variant): TVarType; overload; function VarTypeDeRef(const V: TVarData): TVarType; overload; inline; function VarAsType(const V: Variant; aVarType: TVarType): Variant; function VarIsType(const V: Variant; aVarType: TVarType): Boolean; overload; inline; function VarIsType(const V: Variant; const AVarTypes: array of TVarType): Boolean; overload; function VarIsByRef(const V: Variant): Boolean; inline; function VarIsEmpty(const V: Variant): Boolean; inline; procedure VarCheckEmpty(const V: Variant); inline; function VarIsNull(const V: Variant): Boolean; inline; function VarIsClear(const V: Variant): Boolean; inline; function VarIsCustom(const V: Variant): Boolean; inline; function VarIsOrdinal(const V: Variant): Boolean; inline; function VarIsFloat(const V: Variant): Boolean; inline; function VarIsNumeric(const V: Variant): Boolean; inline; function VarIsStr(const V: Variant): Boolean; function VarToStr(const V: Variant): string; function VarToStrDef(const V: Variant; const ADefault: string): string; function VarToWideStr(const V: Variant): WideString; function VarToWideStrDef(const V: Variant; const ADefault: WideString): WideString; {$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(const IID: TGUID; out Obj): HResult; virtual; stdcall; function _AddRef: Integer; stdcall; function _Release: Integer; stdcall; 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 = $06FF; 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; {$IFOPT R-} {$DEFINE RANGECHECKINGOFF} {$ENDIF} {$IFOPT Q-} {$DEFINE OVERFLOWCHECKINGOFF} {$ENDIF} var customvarianttypes : array of TCustomVariantType; customvarianttypelock : trtlcriticalsection; 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; {$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; {$ifndef RANGECHECKINGOFF} {$r+} {$endif} 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;p : pdynarraytypeinfo;_dims: SizeInt;b : tdynarraybounds); function next : Boolean; destructor done; end; constructor tdynarrayiter.init(d : Pointer;p : pdynarraytypeinfo;_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 } inc(Pointer(p),ord(pdynarraytypeinfo(p)^.namelen)+2); p:=AlignToPtr(p); elesize[i]:=psizeint(p)^; { skip elesize } inc(Pointer(p),SizeOf(sizeint)); p:=pdynarraytypeinfo(ppointer(p)^); 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; begin if VarType(v) = varNull then if NullStrictConvert then VarCastError(varNull, varDouble) else Result := 0 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; procedure sysvartolstr (var s : AnsiString; const v : Variant); begin if VarType(v) = varNull then if NullStrictConvert then VarCastError(varNull, varString) else s := NullAsStringValue else S := VariantToAnsiString(TVarData(V)); end; procedure sysvartopstr (var s; const v : Variant); begin if VarType(v) = varNull then if NullStrictConvert then VarCastError(varNull, varString) else ShortString(s) := NullAsStringValue else ShortString(s) := VariantToShortString(TVarData(V)); 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 } inc(Pointer(TypeInfo),ord(pdynarraytypeinfo(TypeInfo)^.namelen)+2); TypeInfo:=AlignToPtr(TypeInfo); TypeInfo:=ppointer(TypeInfo+SizeOf(sizeint))^; { check recursively? } if assigned(pdynarraytypeinfo(TypeInfo)) and (pdynarraytypeinfo(TypeInfo)^.kind=byte(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 SameValue(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; begin {!! custom variants? } VarInvalidOp(Left.vType, Right.vType, OpCode); Result:=0; 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 {$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; {$IFDEF RANGECHECKINGOFF} {$R-} {$ENDIF} {$IFDEF OVERFLOWCHECKINGOFF} {$Q+} {$ENDIF} 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); begin {custom Variant support? } 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; { Clears variant array. If array element type is varVariant, then clear each element individually first. } 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; for i:=0 to arr^.dimcount - 1 do cnt:=cnt*cardinal(arr^.Bounds[i].ElementCount); { Clearing each element } for i:=1 to cnt do begin DoVarClear(data^); Inc(data); 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 = 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 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; 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 : psizeint);cdecl; var Dest : TVarData; p : pvararray; arraydest : pvariant; valuevtype, arrayelementtype : TVarType; tempvar : Variant; variantmanager : tvariantmanager; 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 GetVariantManager(variantmanager); variantmanager.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 : AnsiString); 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 Result:=((TVarData(V).vType and varTypeMask)=AVarTypes[I]); 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; begin VT:=TVarData(V).vType and varTypeMask; Result:=(VT=varEmpty) or (((VT=varDispatch) or (VT=varUnknown)) and (TVarData(V).vDispatch=Nil)); end; function VarIsCustom(const V: Variant): Boolean; begin Result:=TVarData(V).vType>=CFirstUserType; end; function VarIsOrdinal(const V: Variant): Boolean; begin Result:=(TVarData(V).vType and varTypeMask) in OrdinalVarTypes; end; function VarIsFloat(const V: Variant): Boolean; begin Result:=(TVarData(V).vType and varTypeMask) in FloatVarTypes; end; function VarIsNumeric(const V: Variant): Boolean; begin Result:=(TVarData(V).vType and varTypeMask) in (OrdinalVarTypes + FloatVarTypes); end; function VarIsStr(const V: Variant): Boolean; begin case (TVarData(V).vType and varTypeMask) of varOleStr, varString : Result:=True; else Result:=False; end; end; function VarToStr(const V: Variant): string; begin Result:=VarToStrDef(V,''); end; function VarToStrDef(const V: Variant; const ADefault: string): string; begin If TVarData(V).vType<>varNull then Result:=V else Result:=ADefault; end; function VarToWideStr(const V: Variant): WideString; begin Result:=VarToWideStrDef(V,''); end; function VarToWideStrDef(const V: Variant; const ADefault: WideString): WideString; begin If TVarData(V).vType<>varNull then Result:=V else Result:=ADefault; end; {$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 Result>AMAx then Result:=AMax else If Resultb 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; {$warnings off} function VarSupports(const V: Variant; const IID: TGUID; out Intf): Boolean; begin NotSupported('VarSupports'); end; function VarSupports(const V: Variant; const IID: TGUID): Boolean; begin NotSupported('VarSupports'); end; { Variant copy support } procedure VarCopyNoInd(var Dest: Variant; const Source: Variant); begin NotSupported('VarCopyNoInd'); end; {$warnings on} {**************************************************************************** Variant array support procedures and functions ****************************************************************************} {$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; {$ifndef RANGECHECKINGOFF} {$r+} {$endif} 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 if FindCustomVariantType(aVarType,customvarianttype) then Result:=true else begin Result:=(aVarType and not(varByRef)) in [varEmpty,varNull,varSmallInt,varInteger, {$ifndef FPUNONE} varSingle,varDouble,varDate, {$endif} varCurrency,varOleStr,varDispatch,varError,varBoolean, varVariant,varUnknown,varShortInt,varByte,varWord,varLongWord,varInt64]; end; end; { --------------------------------------------------------------------- Variant <-> Dynamic arrays support ---------------------------------------------------------------------} function DynArrayGetVariantInfo(p : Pointer; var Dims : sizeint) : sizeint; begin Result:=varNull; { skip kind and name } inc(Pointer(p),ord(pdynarraytypeinfo(p)^.namelen)+2); p:=AlignToPtr(p); { skip elesize } inc(p,SizeOf(sizeint)); { search recursive? } if pdynarraytypeinfo(ppointer(p)^)^.kind=21{tkDynArr} then Result:=DynArrayGetVariantInfo(ppointer(p)^,Dims) else begin { skip dynarraytypeinfo } inc(p,SizeOf(pdynarraytypeinfo)); Result:=plongint(p)^; end; inc(Dims); end; {$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; variantmanager : tvariantmanager; 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; GetVariantManager(variantmanager); { 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; variantmanager.VarArrayPut(V,temp,Dims,PSizeInt(iter.Coords)); 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; variantmanager : tvariantmanager; 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)); GetVariantManager(variantmanager); VarArrayLock(V); try iter.init(VarArrayDims,PVarArrayBoundArray(vararraybounds)); dynarriter.init(DynArray,TypeInfo,VarArrayDims,dynarraybounds); if not iter.AtEnd then repeat temp:=variantmanager.VarArrayGet(V,VarArrayDims,PSizeInt(iter.Coords)); 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; {$ifndef RANGECHECKINGOFF} {$r+} {$endif} 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; {$warnings off} function FindCustomVariantType(const TypeName: string; out CustomVariantType: TCustomVariantType): Boolean; overload; begin NotSupported('FindCustomVariantType'); end; {$warnings on} 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; { --------------------------------------------------------------------- TCustomVariantType Class. ---------------------------------------------------------------------} {$warnings off} function TCustomVariantType.QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; begin NotSupported('TCustomVariantType.QueryInterface'); end; function TCustomVariantType._AddRef: Integer; stdcall; begin NotSupported('TCustomVariantType._AddRef'); end; function TCustomVariantType._Release: Integer; stdcall; begin NotSupported('TCustomVariantType._Release'); end; procedure TCustomVariantType.SimplisticClear(var V: TVarData); begin NotSupported('TCustomVariantType.SimplisticClear'); end; procedure TCustomVariantType.SimplisticCopy(var Dest: TVarData; const Source: TVarData; const Indirect: Boolean = False); begin NotSupported('TCustomVariantType.SimplisticCopy'); end; procedure TCustomVariantType.RaiseInvalidOp; begin NotSupported('TCustomVariantType.RaiseInvalidOp'); end; procedure TCustomVariantType.RaiseCastError; begin NotSupported('TCustomVariantType.RaiseCastError'); end; procedure TCustomVariantType.RaiseDispError; begin NotSupported('TCustomVariantType.RaiseDispError'); 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 NotSupported('TCustomVariantType.DispInvoke'); end; procedure TCustomVariantType.VarDataInit(var Dest: TVarData); begin NotSupported('TCustomVariantType.VarDataInit'); end; procedure TCustomVariantType.VarDataClear(var Dest: TVarData); begin NotSupported('TCustomVariantType.VarDataClear'); end; procedure TCustomVariantType.VarDataCopy(var Dest: TVarData; const Source: TVarData); begin NotSupported('TCustomVariantType.VarDataCopy'); end; procedure TCustomVariantType.VarDataCopyNoInd(var Dest: TVarData; const Source: TVarData); begin NotSupported('TCustomVariantType.VarDataCopyNoInd'); end; procedure TCustomVariantType.VarDataCast(var Dest: TVarData; const Source: TVarData); begin NotSupported('TCustomVariantType.VarDataCast'); end; procedure TCustomVariantType.VarDataCastTo(var Dest: TVarData; const Source: TVarData; const aVarType: TVarType); begin NotSupported('TCustomVariantType.VarDataCastTo'); end; procedure TCustomVariantType.VarDataCastTo(var Dest: TVarData; const aVarType: TVarType); begin NotSupported('TCustomVariantType.VarDataCastTo'); end; procedure TCustomVariantType.VarDataCastToOleStr(var Dest: TVarData); begin NotSupported('TCustomVariantType.VarDataCastToOleStr'); end; procedure TCustomVariantType.VarDataFromStr(var V: TVarData; const Value: string); begin NotSupported('TCustomVariantType.VarDataFromStr'); end; procedure TCustomVariantType.VarDataFromOleStr(var V: TVarData; const Value: WideString); begin NotSupported('TCustomVariantType.VarDataFromOleStr'); end; function TCustomVariantType.VarDataToStr(const V: TVarData): string; begin NotSupported('TCustomVariantType.VarDataToStr'); end; function TCustomVariantType.VarDataIsEmptyParam(const V: TVarData): Boolean; begin NotSupported('TCustomVariantType.VarDataIsEmptyParam'); end; function TCustomVariantType.VarDataIsByRef(const V: TVarData): Boolean; begin NotSupported('TCustomVariantType.VarDataIsByRef'); end; function TCustomVariantType.VarDataIsArray(const V: TVarData): Boolean; begin NotSupported('TCustomVariantType.VarDataIsArray'); end; function TCustomVariantType.VarDataIsOrdinal(const V: TVarData): Boolean; begin NotSupported('TCustomVariantType.VarDataIsOrdinal'); end; function TCustomVariantType.VarDataIsFloat(const V: TVarData): Boolean; begin NotSupported('TCustomVariantType.VarDataIsFloat'); end; function TCustomVariantType.VarDataIsNumeric(const V: TVarData): Boolean; begin NotSupported('TCustomVariantType.VarDataIsNumeric'); end; function TCustomVariantType.VarDataIsStr(const V: TVarData): Boolean; begin NotSupported('TCustomVariantType.VarDataIsStr'); end; constructor TCustomVariantType.Create; begin inherited Create; EnterCriticalSection(customvarianttypelock); try SetLength(customvarianttypes,Length(customvarianttypes)+1); customvarianttypes[High(customvarianttypes)]:=self; FVarType:=CMinVarType+High(customvarianttypes); finally LeaveCriticalSection(customvarianttypelock); end; end; constructor TCustomVariantType.Create(RequestedVarType: TVarType); begin NotSupported('TCustomVariantType.Create'); 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 NotSupported('TCustomVariantType.IsClear'); end; procedure TCustomVariantType.Cast(var Dest: TVarData; const Source: TVarData); begin NotSupported('TCustomVariantType.Cast'); end; procedure TCustomVariantType.CastTo(var Dest: TVarData; const Source: TVarData; const aVarType: TVarType); begin NotSupported('TCustomVariantType.CastTo'); 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 NotSupported('TCustomVariantType.BinaryOp'); end; procedure TCustomVariantType.UnaryOp(var Right: TVarData; const Operation: TVarOp); begin NotSupported('TCustomVariantType.UnaryOp'); 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 ---------------------------------------------------------------------} {$warnings off} procedure TInvokeableVariantType.DispInvoke(Dest: PVarData; const Source: TVarData; CallDesc: PCallDesc; Params: Pointer); begin NotSupported('TInvokeableVariantType.DispInvoke'); end; function TInvokeableVariantType.DoFunction(var Dest: TVarData; const V: TVarData; const Name: string; const Arguments: TVarDataArray): Boolean; begin NotSupported('TInvokeableVariantType.DoFunction'); end; function TInvokeableVariantType.DoProcedure(const V: TVarData; const Name: string; const Arguments: TVarDataArray): Boolean; begin NotSupported('TInvokeableVariantType.DoProcedure'); end; function TInvokeableVariantType.GetProperty(var Dest: TVarData; const V: TVarData; const Name: string): Boolean; begin NotSupported('TInvokeableVariantType.GetProperty'); end; function TInvokeableVariantType.SetProperty(const V: TVarData; const Name: string; const Value: TVarData): Boolean; begin NotSupported('TInvokeableVariantType.SetProperty'); end; {$warnings on} 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] 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); tkVariant: Result := GetVariantProp(Instance, PropInfo); tkInt64: Result := 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; 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' } B:=Value; SetOrdProp(Instance, PropInfo, ord(B)); end; tkInteger, tkChar, tkWChar: begin O:=Value; SetOrdProp(Instance, PropInfo, O); end; tkEnumeration : begin if (VarType(Value)=varOleStr) or (VarType(Value)=varString) then begin S:=Value; SetEnumProp(Instance,PropInfo,S); end else begin O:=Value; SetOrdProp(Instance, PropInfo, O); 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)); tkVariant: SetVariantProp(Instance, PropInfo, Value); tkInt64: SetInt64Prop(Instance, PropInfo, Value); else raise EPropertyConvertError.CreateFmt('SetPropValue: Invalid Property Type %s', [PropInfo^.PropType^.Name]); end; end; end; var i : LongInt; Initialization InitCriticalSection(customvarianttypelock); 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.