Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- 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;
- }
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement