Pasted

unit VarObject;
 
interface
 
uses
  SysUtils, Variants;
 
function VarObjectCreate(const AObject: TObject): Variant;
 
function VarObjectType: TVarType;
function VarDataIsObject(const AVarData: TVarData): Boolean;
function VarTypeIsObject(const AVarType: TVarType): Boolean;
function VarIsObject(const AValue: Variant): Boolean;
function VarToObject(const AValue: Variant): TObject;
function VarToObjectDef(const AValue: Variant; const ADefault: TObject = nil): TObject;
 
type
  IGetImplement = interface
  ['{33A0A83F-7D7C-49F0-88D6-926CF995D6AE}']
    function GetSelf: TObject;
  end;
 
implementation
 
uses
  TypInfo, Classes, ComObj, Rtti;
 
type
  TObjectVariantType = class(TPublishableVariantType)
  strict private
    function TValueFromVarData(const V: TVarData): TValue;
    function TValueToVarData(const V: TValue): TVarData;
  protected
    { IVarInstanceReference }
    function GetInstance(const V: TVarData): TObject; override;
    { TCustomVariantType }
    function LeftPromotion(const V: TVarData; const Operator: TVarOp; out RequiredVarType: TVarType): Boolean; override;
    function RightPromotion(const V: TVarData; const Operator: TVarOp; out RequiredVarType: TVarType): Boolean; override;
    function OlePromotion(const V: TVarData; out RequiredVarType: TVarType): Boolean; override;
  public
    procedure Clear(var V: TVarData); override;
    function IsClear(const V: TVarData): Boolean; override;
    procedure Copy(var Dest: TVarData; const Source: TVarData; const Indirect: Boolean); override;
 
    procedure BinaryOp(var Left: TVarData; const Right: TVarData; const Operator: TVarOp); override;
    procedure Compare(const Left: TVarData; const Right: TVarData; var Relationship: TVarCompareResult); override;
 
    function GetProperty(var Dest: TVarData; const V: TVarData; const Name: string): Boolean; override;
    function DoFunction(var Dest: TVarData; const V: TVarData; const Name: string; const Arguments: TVarDataArray): Boolean; override;
    function DoProcedure(const V: TVarData; const Name: string; const Arguments: TVarDataArray): Boolean; override;
 
    procedure Cast(var Dest: TVarData; const Source: TVarData); override;
    procedure CastTo(var Dest: TVarData; const Source: TVarData; const AVarType: Word); override;
  end;
 
  TObjectVarData = packed record
    VType: TVarType;
    Reserved1, Reserved2, Reserved3: Word;
    VObject: TObject;
    Reserved4: LongWord;
  end;
 
var
  ObjectVariantType: TObjectVariantType;
 
function VarObjectCreate(const AObject: TObject): Variant;
begin
  VarClear(Result);
  TObjectVarData(Result).VType := VarObjectType;
  TObjectVarData(Result).VObject := AObject;
end;
 
function VarObjectType: TVarType;
begin
  Result := ObjectVariantType.VarType;
end;
 
function VarDataIsObject(const AVarData: TVarData): Boolean;
begin
  Result := VarTypeIsObject(AVarData.VType);
end;
 
function VarTypeIsObject(const AVarType: TVarType): Boolean;
begin
  Result := ((AVarType and varTypeMask) = VarObjectType);
end;
 
function VarIsObject(const AValue: Variant): Boolean;
begin
  Result := VarTypeIsObject(TVarData(AValue).VType and varTypeMask);
end;
 
function VarToObject(const AValue: Variant): TObject;
var
  LSource, LDest: TVarType;
begin
  Result := VarToObjectDef(AValue, TObject(666));
  if Result = TObject(666) then
  begin
    LSource := TVarData(AValue).VType and varTypeMask;
    LDest := VarObjectType;
    VarCastError(LSource, LDest);
  end;
end;
 
function VarToObjectDef(const AValue: Variant; const ADefault: TObject = nil): TObject;
var
  LDest: Variant;
begin
  if VarIsEmpty(AValue) then
    Result := nil
  else
  if VarIsNull(AValue) then
  begin
    if NullStrictConvert then
      Result := ADefault
    else
      Result := nil;
  end
  else
  if VarIsObject(AValue) then
    Result := TObjectVarData(AValue).VObject
  else
  begin
    try
      VarCast(LDest, AValue, VarObjectType);
      Result := TObjectVarData(LDest).VObject;
    except
      Result := ADefault;
    end;
  end;
end;
 
//________________________________________________________________________________________
 
{ TObjectVariantType }
 
function TObjectVariantType.GetInstance(const V: TVarData): TObject;
begin
  Result := TObjectVarData(V).VObject;
end;
 
procedure TObjectVariantType.Cast(var Dest: TVarData; const Source: TVarData);
const
  ObjCastGUID: TGUID = '{CEDF24DE-80A4-447D-8C75-EB871DC121FD}';
var
  UI: NativeUInt;
  S: String;
  X: Integer;
  I: IInterface;
  D: IDispatch;
  O: TObject;
  GetImpl: IGetImplement;
  GetComp: IInterfaceComponentReference;
begin
  if VarDataIsOrdinal(Source) then
  begin
    UI := Variant(Source);
    VarDataClear(Dest);
    TObjectVarData(Dest).VObject := TObject(UI);
    Dest.VType := VarObjectType;
    Exit;
  end;
 
  if Source.VType = varUnknown then
  begin
    I := IInterface(Source.VUnknown);
    if Supports(I, ObjCastGUID, O) then
    begin
      VarDataClear(Dest);
      TObjectVarData(Dest).VObject := O;
      Dest.VType := VarObjectType;
    end
    else
    if Supports(I, IInterfaceComponentReference, GetComp) then
    begin
      VarDataClear(Dest);
      TObjectVarData(Dest).VObject := GetComp.GetComponent;
      Dest.VType := VarObjectType;
    end
    else
    if Supports(I, IGetImplement, GetImpl) then
    begin
      VarDataClear(Dest);
      TObjectVarData(Dest).VObject := GetImpl.GetSelf;
      Dest.VType := VarObjectType;
    end
 
    else
      VarCastError(Source.VType, VarObjectType);
    Exit;
  end;
 
  if Source.VType = varDispatch then
  begin
    D := IDispatch(Source.VDispatch);
    if Supports(D, ObjCastGUID, O) then
    begin
      VarDataClear(Dest);
      TObjectVarData(Dest).VObject := O;
      Dest.VType := VarObjectType;
    end
    else
    if Supports(D, IInterfaceComponentReference, GetComp) then
    begin
      VarDataClear(Dest);
      TObjectVarData(Dest).VObject := GetComp.GetComponent;
      Dest.VType := VarObjectType;
    end
    else
    if Supports(D, IGetImplement, GetImpl) then
    begin
      VarDataClear(Dest);
      TObjectVarData(Dest).VObject := GetImpl.GetSelf;
      Dest.VType := VarObjectType;
    end
    else
      VarCastError(Source.VType, VarObjectType);
    Exit;
  end;
 
  S := Trim(AdjustLineBreaks(VarDataToStr(Source)));
  X := Pos(sLineBreak, S);
  if X > 0 then
  begin
    SetLength(S, X - 1);
    S := Trim(S);
  end;
 
  if {$IFDEF CPUX64}TryStrToInt64{$ELSE}TryStrToInt{$ENDIF}(S, {$IFDEF CPUX64}Int64{$ELSE}Integer{$ENDIF}(UI)) then
  begin
    VarDataClear(Dest);
    TObjectVarData(Dest).VObject := TObject(UI);
    Dest.VType := VarObjectType;
  end
  else
    VarCastError(Source.VType, VarObjectType);
end;
 
procedure TObjectVariantType.CastTo(var Dest: TVarData; const Source: TVarData; const AVarType: Word);
var
  I: IInterface;
  D: IDispatch;
begin
  Assert(Source.VType = VarObjectType);
  case AVarType of
    varUnknown:
    begin
      if Supports(TObjectVarData(Source).VObject, IInterface, I) then
      begin
        VarDataClear(Dest);
        Dest.VDispatch := nil;
        Dest.VType := varUnknown;
        IInterface(Dest.VUnknown) := I;
      end
      else
        VarCastError(Source.VType, AVarType);
    end;
    varDispatch:
    begin
      if Supports(TObjectVarData(Source).VObject, IDispatch, D) then
      begin
        VarDataClear(Dest);
        Dest.VDispatch := nil;
        Dest.VType := varDispatch;
        IInterface(Dest.VDispatch) := D;
      end
      else
        VarCastError(Source.VType, AVarType);
    end;
    varOleStr:
      VarDataFromOleStr(Dest, '$' + IntToHex(NativeUInt(TObjectVarData(Source).VObject), SizeOf(Pointer)) + sLineBreak + TObjectVarData(Source).VObject.ToString);
    varString:
      VarDataFromStr(Dest, '$' + IntToHex(NativeUInt(TObjectVarData(Source).VObject), SizeOf(Pointer)) + sLineBreak + TObjectVarData(Source).VObject.ToString);
    varUString:
      VarDataFromStr(Dest, '$' + IntToHex(NativeUInt(TObjectVarData(Source).VObject), SizeOf(Pointer)) + sLineBreak + TObjectVarData(Source).VObject.ToString);
    varSmallint, varInteger, varShortInt, varByte, varWord, varLongWord, varInt64, varUInt64, varSingle, varDouble, varCurrency:
    begin
      VarDataClear(Dest);
      Dest.VType := varUInt64;
      Dest.VUInt64 := NativeUInt(TObjectVarData(Source).VObject);
      if AVarType <> varUInt64 then
        VarDataCastTo(Dest, AVarType);
    end;
    varBoolean:
    begin
      VarDataClear(Dest);
      Dest.VType := varBoolean;
      Dest.VBoolean := (TObjectVarData(Source).VObject <> nil);
    end;
  else
    VarCastError(Source.VType, AVarType);
  end;
end;
 
procedure TObjectVariantType.Copy(var Dest: TVarData; const Source: TVarData; const Indirect: Boolean);
begin
  SimplisticCopy(Dest, Source, Indirect);
end;
 
procedure TObjectVariantType.Clear(var V: TVarData);
begin
  SimplisticClear(V);
end;
 
function TObjectVariantType.IsClear(const V: TVarData): Boolean;
begin
  Result := TObjectVarData(V).VObject = nil;
end;
 
procedure TObjectVariantType.BinaryOp(var Left: TVarData; const Right: TVarData; const Operator: TVarOp);
var
  I: UInt64;
  F: Extended;
  S: String;
  L, R: Variant;
begin
  if VarDataIsObject(Left) then
  begin
    if VarDataIsStr(Right) then
    begin
      S := Variant(Left);
      L := S;
    end
    else
    begin
      I := NativeUInt(TObjectVarData(Left).VObject);
      L := I;
    end;
  end
  else
  if VarDataIsOrdinal(Left) then
  begin
    I := Variant(Left);
    L := I;
  end
  else
  if VarDataIsFloat(Left) then
  begin
    F := Variant(Left);
    L := F;
  end
  else
  if VarDataIsStr(Left) then
  begin
    S := Variant(Left);
    L := S;
  end
  else
    L := Variant(Left);
 
  if VarDataIsObject(Right) then
  begin
    if VarIsStr(L) then
    begin
      S := Variant(Right);
      R := S;
    end
    else
    begin
      I := NativeUInt(TObjectVarData(Right).VObject);
      R := I;
    end;
  end
  else
  if VarDataIsOrdinal(Right) then
  begin
    I := Variant(Right);
    R := I;
  end
  else
  if VarDataIsFloat(Right) then
  begin
    F := Variant(Right);
    R := F;
  end
  else
  if VarDataIsStr(Right) then
  begin
    S := Variant(Right);
    R := S;
  end
  else
    R := Variant(Right);
 
  case Operator of
    opAdd:
      R := L + R;
    opSubtract:
      R := L - R;
    opMultiply:
      R := L * R;
    opDivide:
      R := L / R;
    opIntDivide:
      R := L div R;
    opModulus:
      R := L mod R;
    opShiftLeft:
      R := L shl R;
    opShiftRight:
      R := L shr R;
    opAnd:
      R := L and R;
    opOr:
      R := L or R;
    opXor:
      R := L xor R;
  else
    RaiseInvalidOp;
  end;
 
  VarDataClear(Left);
  Left := TVarData(R);
  FillChar(R, SizeOf(R), 0);
end;
 
procedure TObjectVariantType.Compare(const Left, Right: TVarData; var Relationship: TVarCompareResult);
var
  LLeft: NativeUInt;
  LRight: NativeUInt;
begin
  if Left.VType = VarObjectType then
    LLeft := NativeUInt(TObjectVarData(Left).VObject)
  else
  if VarDataIsStr(Left) then
    LLeft := NativeUInt(VarToObjectDef(Variant(Left)))
  else
    LLeft := Variant(Left);
  if Right.VType = VarObjectType then
    LRight := NativeUInt(TObjectVarData(Right).VObject)
  else
  if VarDataIsStr(Right) then
    LRight := NativeUInt(VarToObjectDef(Variant(Right)))
  else
    LRight := Variant(Right);
 
  if LLeft = LRight then
    Relationship := crEqual
  else
  if LLeft < LRight then
    Relationship := crLessThan
  else
    Relationship := crGreaterThan
end;
 
function TObjectVariantType.LeftPromotion(const V: TVarData; const Operator: TVarOp; out RequiredVarType: TVarType): Boolean;
begin
  if VarDataIsObject(V) then
  begin
    Result := False;
    Exit;
  end;
 
  if VarDataIsOrdinal(V) then
    RequiredVarType := {$IFDEF CPUX64}varLongWord{$ELSE}varUInt64{$ENDIF}
  else
  if VarDataIsStr(V) then
    RequiredVarType := varString
  else
    RequiredVarType := VarType;
  Result := True;
end;
 
function TObjectVariantType.RightPromotion(const V: TVarData; const Operator: TVarOp; out RequiredVarType: TVarType): Boolean;
begin
  if VarDataIsObject(V) then
  begin
    Result := False;
    Exit;
  end;
 
  if VarDataIsOrdinal(V) then
    RequiredVarType := {$IFDEF CPUX64}varLongWord{$ELSE}varUInt64{$ENDIF}
  else
  if VarDataIsStr(V) then
    RequiredVarType := varString
  else
    RequiredVarType := VarType;
  Result := True;
end;
 
function TObjectVariantType.OlePromotion(const V: TVarData; out RequiredVarType: TVarType): Boolean;
var
  D: IDispatch;
begin
  if Supports(TObjectVarData(V).VObject, IDispatch, D) then
    RequiredVarType := varDispatch
  else
    RequiredVarType := varUnknown;
  Result := True;
end;
 
function TObjectVariantType.GetProperty(var Dest: TVarData; const V: TVarData; const Name: string): Boolean;
var
  O: TObject;
begin
  if UpperCase(Name) = 'SELF' then
  begin
    O := GetInstance(V);
    VarDataClear(Dest);
    {$IFDEF CPUX64}
    Dest.VType := varUInt64;
    Dest.VLongWord := NativeUInt(O);
    {$ELSE}
    Dest.VType := varLongWord;
    Dest.VLongWord := NativeUInt(O);
    {$ENDIF}
    Result := True;
  end
  else
    Result := inherited GetProperty(Dest, V, Name);
end;
 
function TObjectVariantType.DoFunction(var Dest: TVarData; const V: TVarData; const Name: string; const Arguments: TVarDataArray): Boolean;
var
  LContext: TRttiContext;
  LType: TRttiInstanceType;
  LMethod: TRttiMethod;
  LObj: TObject;
  LParams: array of TValue;
  LResult: TValue;
  LArgBase, X: Integer;
begin
  Result := True;
  LObj := GetInstance(V);
 
  LContext := TRttiContext.Create; // record, not object, do not call FreeAndNil
  try
    LType := TRttiInstanceType(LContext.GetType(LObj.ClassType));
    try
      LMethod := LType.GetMethod(Name);
 
      if (not Assigned(LMethod)) or
         (LMethod.Visibility in [mvPrivate, mvProtected]) or
         LMethod.IsConstructor or
         LMethod.IsDestructor then
      begin
        Result := False;
        Exit;
      end;
 
      LArgBase := 0;
      if Length(Arguments) > 0 then
      begin
        if Arguments[0].VType = varError then
          Inc(LArgBase);
 
        SetLength(LParams, Length(Arguments) - LArgBase);
 
        for X := LArgBase to Length(Arguments) - 1 do
          LParams[X - LArgBase] := TValueFromVarData(Arguments[X]);
      end
      else
        LParams := nil;
 
      if LMethod.IsClassMethod or LMethod.IsStatic then
        LResult := LMethod.Invoke(LObj.ClassType, LParams)
      else
        LResult := LMethod.Invoke(LObj, LParams);
 
      Dest := TValueToVarData(LResult);
 
      if Length(Arguments) > 0 then
      begin
        for X := LArgBase to Length(Arguments) - 1 do
          if VarDataIsByRef(Arguments[X]) then
            TVarData(Arguments[X].VPointer^) := TValueToVarData(LParams[X - LArgBase]);
      end;
    finally
      FreeAndNil(LType);
    end;
  finally
    LContext.Free;
  end;
end;
 
function TObjectVariantType.DoProcedure(const V: TVarData; const Name: string; const Arguments: TVarDataArray): Boolean;
var
  LDummy: TVarData;
begin
  Result := DoFunction(LDummy, V, Name, Arguments);
  VarDataClear(LDummy);
end;
 
function TObjectVariantType.TValueFromVarData(const V: TVarData): TValue;
var
  O: TObject;
begin
  if VarDataIsObject(V) then
  begin
    O := TObjectVarData(V).VObject;
    Result := TValue.From(O);
  end
  else
    Result := TValue.FromVariant(Variant(V));
end;
 
function TObjectVariantType.TValueToVarData(const V: TValue): TVarData;
var
  Rslt: Variant;
begin
  VarClear(Rslt);
  if V.IsObject then
    Rslt := VarObjectCreate(V.AsObject)
  else
    Rslt := V.AsVariant;
 
  VarDataClear(Result);
  Result := TVarData(Rslt);
  FillChar(Rslt, SizeOf(Rslt), 0);
end;
 
initialization
  ObjectVariantType := TObjectVariantType.Create;
finalization
  FreeAndNil(ObjectVariantType);
end.
 
{
 
Usage sample:
 
uses
  VarObject;
 
procedure TForm1.Button1Click(Sender: TObject);
var
  B: TButton;
  V: Variant;
  O: TObject;
  S: String;
  OV: OleVariant;
  I: Integer;
  Intf: IUnknown;
begin
  B := Sender as TButton;
 
  // V := B;               // - FAIL: Incompatible types: 'Variant' and 'TButton'
  V := VarObjectCreate(B); // - OK
 
  if VarIsObject(V) then
  begin
    // O := V;             // - FAIL: Incompatible types: 'TObject' and 'Variant'
    O := VarToObject(V);   // - OK
    if O.InheritsFrom(TButton) then
    begin
      B := TButton(O);
      B.Caption := B.Caption + ' 1';
    end;
  end;
 
  B := VarToObject(V) as TButton;    // - OK, shorter version, raises exception on error
  B := VarToObjectDef(V) as TButton; // - OK, shorter version, returns nil on error
  B.Caption := B.Caption + ' 2';
 
  Caption := Caption + ' ' + V;   // - Object is interchable with strings (outputs pointer + .ToString - e.g. '$00123456'#13#10'TButton')
  Caption := V + ' ' + Caption;   // - Works both ways
 
  I := Tag;
  I := I + V;                      // - Integer is interchable with objects
  I := V + I;                      // - Works both ways
  Tag := I;                        // - Here: Tag = 2 * NativeUInt(B)
 
  V := NativeUInt(B);              // - Integer = pointer(Object)
  B := VarToObject(V) as TButton;  // - OK, B does not change (same value)
 
  S := V;                          // - OK, S = '$00123456'#13#10'TButton' (pointer + .ToString)
  V := S;                          // - OK, V = varString
  B := VarToObject(V) as TButton;  // - OK, B does not change (same value)
 
  V := VarObjectCreate(B);         // - Reset to custom variant type, need to support invokes below, since (obviosly) we can not call properties/methods on integer, strings, etc.
  V.Caption := V.Caption + ' 3';   // - OK, works via RTTI/published (see TypInfo.TPublishableVariantType.Get/SetProperty - uses Get/SetPropValue)
 
  Tag := V.Self;                   // - OK, "V.Self" always returns NativeUInt (unlike simple "V", which can return NativeUInt or String - depending on expression)
 
  OV := V;                            // - OK, TButton implements IInterface (via TComponent); OV = IUnknown
  // OV.Caption := OV.Caption + ' 4'; // - FAIL: TButton does not support IDispatch
 
  // Intf := V;                       // - OK, but returns wrong info, current implementation of custom variants returns inteface to custom variant stub, not to actual data
  Intf := OV;                         // - OK, as expected
 
  V := Intf;                          // - OK; here: V = varUnknown
  // V.Caption := V.Caption + ' 5';   // - FAIL, V/Intf is not IDispatch
  VarCast(V, V, VarObjectType);       // - OK, since TButton implements ObjCastGUID (D2010+), alternative is to implement VarObject.IGetImplement
  V.Caption := V.Caption + ' 6';      // - OK, since V is VarObjectType
 
  V.Click;                            // - OK, works in D2010+ only
 
  // infinite recursion: V.Click -> Button1Click -> V.Click -> Button1Click -> ...
end;
}