{
    $Id: variants.pp,v 1.14 2003/12/08 20:19:00 peter Exp $
    This file is part of the Free Pascal run time library.
    Copyright (c) 2001 by the Free Pascal development team

    This include file contains the declarations for variants
    support in FPC

    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+}

unit variants;

interface

  uses
    sysutils,sysconst;

{$ifdef HASVARIANT}
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 = [varSingle, varDouble, varCurrency];

{ Variant support procedures and functions }

function VarType(const V: Variant): TVarType;
function VarAsType(const V: Variant; AVarType: TVarType): Variant;
function VarIsType(const V: Variant; AVarType: TVarType): Boolean; overload;
function VarIsType(const V: Variant; const AVarTypes: array of TVarType): Boolean; overload;
function VarIsByRef(const V: Variant): Boolean;

function VarIsEmpty(const V: Variant): Boolean;
procedure VarCheckEmpty(const V: Variant);
function VarIsNull(const V: Variant): Boolean;
function VarIsClear(const V: Variant): Boolean;

function VarIsCustom(const V: Variant): Boolean;
function VarIsOrdinal(const V: Variant): Boolean;
function VarIsFloat(const V: Variant): Boolean;
function VarIsNumeric(const V: Variant): Boolean;
function VarIsStr(const V: Variant): Boolean;

function VarToStr(const V: Variant): string;
function VarToStrDef(const V: Variant; const ADefault: string): string;
function VarToWideStr(const V: Variant): WideString;
function VarToWideStrDef(const V: Variant; const ADefault: WideString): WideString;

function VarToDateTime(const V: Variant): TDateTime;
function VarFromDateTime(const DateTime: TDateTime): Variant;

function VarInRange(const AValue, AMin, AMax: Variant): Boolean;
function VarEnsureRange(const AValue, AMin, AMax: Variant): Variant;

function VarIsEmptyParam(const V: Variant): Boolean;

procedure SetClearVarToEmptyParam(var V: TVarData);

function VarIsError(const V: Variant; out AResult: HRESULT): Boolean;
function VarIsError(const V: Variant): Boolean;
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 VarArrayOf(const Values: array of Variant): Variant;

function VarArrayDimCount(const A: Variant) : SizeInt;
function VarArrayLowBound(const A: Variant; Dim : SizeInt) : SizeInt;
function VarArrayHighBound(const A: Variant; Dim : SizeInt) : SizeInt;

function VarArrayLock(const A: Variant): Pointer;
procedure VarArrayUnlock(const A: Variant);

function VarArrayRef(const A: Variant): Variant;

function VarIsArray(const A: Variant): 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(var Dest: TVarData; 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(var Dest: TVarData; 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;

  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
  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 }

procedure VarCastError;
procedure VarCastError(const ASourceType, ADestType: TVarType);
procedure VarInvalidOp;
procedure VarInvalidNullOp;
procedure VarBadTypeError;
procedure VarOverflowError;
procedure VarOverflowError(const ASourceType, ADestType: TVarType);
procedure VarBadIndexError;
procedure VarArrayLockedError;
procedure VarNotImplError;
procedure VarOutOfMemoryError;
procedure VarInvalidArgError;
procedure VarUnexpectedError;
procedure VarRangeCheckError(const AType: TVarType);
procedure VarRangeCheckError(const ASourceType, ADestType: TVarType);
procedure VarArrayCreateError;
procedure VarResultCheck(AResult: HRESULT);
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;

{$endif HASVARIANT}

implementation

{$ifdef HASVARIANT}

uses
  varutils;

{ ---------------------------------------------------------------------
    String Messages
  ---------------------------------------------------------------------}

ResourceString
  SErrVarIsEmpty = 'Variant is empty';
  SErrInvalidIntegerRange = 'Invalid Integer range: %d';

{ ---------------------------------------------------------------------
    Auxiliary routines
  ---------------------------------------------------------------------}

Procedure VariantError (Const Msg : String);
begin
  Raise EVariantError.Create(Msg);
end;


Procedure NotSupported(Meth: String);
begin
  Raise EVariantError.CreateFmt('Method %s not yet supported.',[Meth]);
end;


{ ---------------------------------------------------------------------
    VariantManager support
  ---------------------------------------------------------------------}

procedure sysvarinit (var v : variant);
begin
  VariantInit(TVarData(V));
end;


procedure sysvarclear (var v : variant);
begin
  VariantClear(TVarData(V));
end;


function Sysvartoint (const v : variant) : longint;
begin
  Result:=VariantToLongint(TVarData(V));
end;


function Sysvartoint64 (const v : variant) : int64;
begin
  Result:=VariantToInt64(TVarData(V));
end;


function sysvartoword64 (const v : variant) : qword;
begin
  Result:=VariantToQWord (TVarData(V));
end;


function sysvartobool (const v : variant) : boolean;
begin
  Result:=VariantToBoolean(TVarData(V));
end;


function sysvartoreal (const v : variant) : extended;
begin
  Result:=VariantToDouble(TVarData(V));
end;


function sysvartocurr (const v : variant) : currency;
begin
  Result:=VariantToCurrency(TVarData(V));
end;

procedure sysvartolstr (var s : ansistring;const v : variant);
begin
  S:=VariantToAnsiString(TVarData(V));
end;

procedure sysvartopstr (var s;const v : variant);

Var
  T : String;

begin
  SysVarToLstr(T,V);
  ShortString(S):=T;
end;

procedure sysvartowstr (var s : widestring;const v : variant);

begin
  NotSupported('VariantManager.sysvartowstr')
end;

procedure sysvartointf (var intf : iinterface;const v : variant);

begin
  NotSupported('VariantManager.sysvartointf')
end;


procedure sysvartodisp (var disp : idispatch;const v : variant);

begin
  NotSupported('VariantManager.sysvartodisp')
end;


procedure sysvartodynarray (var dynarr : pointer;const v : variant; typeinfo : pointer);
begin
  NotSupported('VariantManager.sysvartodynarray')
end;

procedure sysvarfrombool (var dest : variant;const source : Boolean);

begin
  if TVarData(Dest).VType>=varOleStr then
    sysvarclear(Dest);
  With TVarData(dest) do
    begin
    VType:=varBoolean;
    VBoolean:=Source;
    end;
end;


procedure sysvarfromint (var dest : variant;const source,range : longint);

begin
  if TVarData(Dest).VType>=varOleStr then
    sysvarclear(Dest);
  With TVarData(dest) do
    begin
    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;
         vLongWord:=Source;
         end;
    else
       VariantError(Format(SErrInvalidIntegerRange,[Range]));
    end;
    end;
end;

procedure sysvarfromint64 (var dest : variant;const source : int64);

begin
  if TVarData(Dest).VType>=varOleStr then
    sysvarclear(Dest);
  With TVarData(dest) do
    begin
    vtype:=varint64;
    vInt64:=Source;
    end;
end;

procedure sysvarfromword64 (var dest : variant;const source : qword);

begin
  if TVarData(Dest).VType>=varOleStr then
    sysvarclear(Dest);
  With TVarData(dest) do
    begin
    vtype:=varQWord;
    vQword:=Source;
    end;
end;


procedure sysvarfromreal (var dest : variant;const source : extended);

begin
  if TVarData(Dest).VType>=varOleStr then
    sysvarclear(Dest);
  With TVarData(dest) do
    begin
    vtype:=varDouble;
    vDouble:=Source;
    end;
end;

procedure sysvarfrompstr (var dest : variant;const source : shortstring);

Var
  L : AnsiString;

begin
  if TVarData(Dest).VType>=varOleStr then
    sysvarclear(Dest);
  With TVarData(dest) do
    begin
    vtype:=varOleStr;
    L:=Source;
    vOleStr:=PWideChar(L);
    end;
//  NotSupported('VariantManager.sysvarfrompstr')
end;

procedure sysvarfromlstr (var dest : variant;const source : string);

Var
  W,W2 : WideString;

begin
  If TVarData(Dest).VType>=varOleStr then
    sysvarclear(Dest);
  With TVarData(Dest) do
    begin
    vType:=VarOleStr;
    W:=Source;
//    Writeln('Assigning widestring to variant : ',W);
    vOleStr:=PWideChar(W);
//    W2:=vOleStr;
//    Writeln('Assigned widestring to variant : ',W2);
    end;
end;

procedure sysvarfromwstr (var dest : variant;const source : widestring);

begin
  NotSupported('VariantManager.sysvarfromwstr')
end;

procedure sysvarop (var left : variant;const right : variant;opcdoe : tvarop);

begin
  NotSupported('VariantManager.sysvarop')
end;

function syscmpop (const left,right : variant;const opcode : tvarop) : boolean;

begin
  NotSupported('VariantManager.syscmpop')
end;


procedure sysvarneg (var v : variant);

begin
  NotSupported('VariantManager.sysvarneg')
end;


procedure sysvarnot (var v : variant);

begin
  NotSupported('VariantManager.sysvarnot')
end;

procedure sysvaraddref (var v : variant);

begin
  NotSupported('VariantManager.sysvaraddref')
end;

procedure sysvarcopy (var dest : variant;const source : variant);

begin
  NotSupported('VariantManager.sysvarcopy')
end;

procedure sysvarcast (var dest : variant;const source : variant;vartype : longint);

begin
  NotSupported('VariantManager.sysvarcast')
end;

procedure sysvarfromintf(var dest : variant;const source : iinterface);
  begin
  end;


procedure sysvarfromdisp(var dest : variant;const source : idispatch);
  begin
  end;


procedure sysvarfromdynarray(var dest : variant;const source : pointer; typeinfo: pointer);
  begin
  end;


procedure sysolevarfrompstr(var dest : olevariant; const source : shortstring);
  begin
  end;


procedure sysolevarfromlstr(var dest : olevariant; const source : ansistring);
  begin
  end;


procedure sysolevarfromvar(var dest : olevariant; const source : variant);
  begin
  end;


procedure sysolevarfromint(var dest : olevariant; const source : longint;const range : shortint);
  begin
  end;


procedure sysvarcastole(var dest : variant;const source : variant;vartype : longint);
  begin
  end;


procedure sysdispinvoke(dest : pvardata;const source : tvardata;calldesc : pcalldesc;params : pointer);cdecl;
  begin
  end;


procedure sysvararrayredim(var a : variant;highbound : SizeInt);
  begin
  end;


function sysvararrayget(var a : variant;indexcount : SizeInt;indices : SizeInt) : variant;cdecl;
  begin
  end;


procedure sysvararrayput(var a : variant; const value : variant;indexcount : SizeInt;indices : SizeInt);cdecl;
  begin
  end;


function syswritevariant(var t : text;const v : variant;width : longint) : Pointer;
  begin
  end;


function syswrite0Variant(var t : text;const v : Variant) : Pointer;
  begin
  end;


Const
  SysVariantManager : TVariantManager = (
    vartoint      : @sysvartoint;
    vartoint64    : @sysvartoint64;
    vartoword64   : @sysvartoword64;
    vartobool     : @sysvartobool;
    vartoreal     : @sysvartoreal;
    vartocurr     : @sysvartocurr;
    vartopstr     : @sysvartopstr;
    vartolstr     : @sysvartolstr;
    vartowstr     : @sysvartowstr;
    vartointf     : @sysvartointf;
    vartodisp     : @sysvartodisp;
    vartodynarray : @sysvartodynarray;
    varfrombool   : @sysvarfromBool;
    varfromint    : @sysvarfromint;
    varfromint64  : @sysvarfromint64;
    varfromword64 : @sysvarfromword64;
    varfromreal   : @sysvarfromreal;
    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 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;


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;




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;


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
  Result:=AValue;
{ !! Operator not overloaded error...
  If Result>AMAx then
    Result:=AMax
  else If Result<AMin Then
    Result:=AMin;
}
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
end;


function VarIsError(const V: Variant): Boolean;
var
  LResult: HRESULT;
begin
  Result := VarIsError(V, LResult);
end;


function VarAsError(AResult: HRESULT): Variant;
  begin
    tvardata(result).VType:=varError;
    tvardata(result).VError:=AResult;
  end;


function VarSupports(const V: Variant; const IID: TGUID; out Intf): Boolean;
begin
  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;

{****************************************************************************
              Variant array support procedures and functions
 ****************************************************************************}


function VarArrayCreate(const Bounds: array of SizeInt; AVarType: TVarType): Variant;
begin
  NotSupported('VarArrayCreate');
end;


function VarArrayOf(const Values: array of Variant): Variant;
begin
  NotSupported('VarArrayOf');
end;


function VarArrayDimCount(const A: Variant) : SizeInt;
begin
  NotSupported('VarArrayDimCount');
end;


function VarArrayLowBound(const A: Variant; Dim: SizeInt) : SizeInt;
begin
  NotSupported('VarArrayLowBound');
end;



function VarArrayHighBound(const A: Variant; Dim: SizeInt) : SizeInt;

begin
  NotSupported('VarArrayHighBound');
end;




function VarArrayLock(const A: Variant): Pointer;

begin
  NotSupported('VarArrayLock');
end;



procedure VarArrayUnlock(const A: Variant);

begin
  NotSupported('VarArrayUnlock');
end;




function VarArrayRef(const A: Variant): Variant;

begin
  NotSupported('VarArrayRef');
end;


function VarIsArray(const A: Variant): Boolean;

begin
  NotSupported('VarIsArray');
end;


function VarTypeIsValidArrayType(const AVarType: TVarType): Boolean;

begin
  NotSupported('VarTypeIsValidArrayType');
end;



function VarTypeIsValidElementType(const AVarType: TVarType): Boolean;

begin
  NotSupported('VarTypeIsValidElementType');
end;


{ ---------------------------------------------------------------------
    Variant <-> Dynamic arrays support
  ---------------------------------------------------------------------}


procedure DynArrayToVariant(var V: Variant; const DynArray: Pointer; TypeInfo: Pointer);

begin
  NotSupported('DynArrayToVariant');
end;



procedure DynArrayFromVariant(var DynArray: Pointer; const V: Variant; TypeInfo: Pointer);

begin
  NotSupported('DynArrayFromVariant');
end;

function FindCustomVariantType(const AVarType: TVarType; out CustomVariantType: TCustomVariantType): Boolean; overload;

begin
  NotSupported('FindCustomVariantType');
end;

function FindCustomVariantType(const TypeName: string;  out CustomVariantType: TCustomVariantType): Boolean; overload;

begin
  NotSupported('FindCustomVariantType');
end;

function Unassigned: Variant; // Unassigned standard constant

begin
  NotSupported('Unassigned');
end;


function Null: Variant;       // Null standard constant

begin
  NotSupported('Null');
end;


{ ---------------------------------------------------------------------
    TCustomVariantType Class.
  ---------------------------------------------------------------------}

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(var Dest: TVarData; 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
  NotSupported('TCustomVariantType.Create;');
end;


constructor TCustomVariantType.Create(RequestedVarType: TVarType);

begin
  NotSupported('TCustomVariantType.Create');
end;


destructor TCustomVariantType.Destroy;

begin
  NotSupported('TCustomVariantType.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;

{ ---------------------------------------------------------------------
    TInvokeableVariantType implementation
  ---------------------------------------------------------------------}

procedure TInvokeableVariantType.DispInvoke(var Dest: TVarData; 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;


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 VarInvalidOp;
  begin
    raise EVariantInvalidOpError.Create(SInvalidVarOp);
  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 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);
  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
    NotSupported('HandleConversionException');
  end;


function VarTypeAsText(const AType: TVarType): string;
  begin
    NotSupported('VarTypeAsText');
  end;


function FindVarData(const V: Variant): PVarData;
  begin
    NotSupported('FindVarData');
  end;


Initialization
  SetSysVariantManager;
  SetClearVarToEmptyParam(TVarData(EmptyParam));

Finalization
  UnSetSysVariantManager

{$endif HASVARIANT}

end.

{
  $Log: variants.pp,v $
  Revision 1.14  2003/12/08 20:19:00  peter
    * remove duplicate uses

  Revision 1.13  2003/11/26 20:34:53  michael
  + Some fixes to have everything compile again

  Revision 1.12  2003/11/26 20:00:19  florian
    * error handling for Variants improved

  Revision 1.11  2003/11/04 23:15:27  michael
  + Some fix in sysvarfromlstr

  Revision 1.10  2003/11/04 22:27:43  michael
  + Some fixes for string support

  Revision 1.9  2003/10/12 16:24:18  hajny
    + CVS log added
}