From ec630909e38d08563548907a7a4a4340485de7cc Mon Sep 17 00:00:00 2001 From: TetzkatLipHoka Date: Sat, 11 Jul 2026 11:24:47 +0200 Subject: [PATCH] Support assigning Variants and cross-typed interfaces to interface variables Assigning a Variant that holds an interface reference to a script variable of an interface type only worked when the destination was exactly IDispatch; every other interface destination failed with a plain 'Type Mismatch'. Assignments between differently declared interface types blindly copied the reference without ever consulting QueryInterface. SetVariantValue's btInterface branch now: - accepts Variants holding varUnknown/varDispatch values (including by-ref variants) for ANY interface destination, casting via QueryInterface on the destination's GUID; empty/nil Variants assign nil. Destinations declared as IUnknown (or without a GUID) receive the reference as-is, preserving existing behaviour. - performs interface-to-interface assignments of differently declared types via QueryInterface as well; same-GUID (and nil) assignments stay plain reference copies. Failed casts raise a descriptive, script-catchable error that names the destination type (or its GUID when the type is unnamed) instead of the generic type mismatch. Pre-Delphi3 builds keep their previous paths. Note: the companion fix 'Make failing interface/object casts catchable' covers the explicit cast-import path (CastProc); together they make all interface conversion failures catchable with descriptive messages. Co-Authored-By: Claude Fable 5 --- Source/uPSRuntime.pas | 103 ++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 100 insertions(+), 3 deletions(-) diff --git a/Source/uPSRuntime.pas b/Source/uPSRuntime.pas index d22c6182..5d13f491 100644 --- a/Source/uPSRuntime.pas +++ b/Source/uPSRuntime.pas @@ -4516,6 +4516,90 @@ procedure AssignIDispatchFromVariant(var Dest: IDispatch; const Src: Variant); end; {$ENDIF} +{$IFNDEF PS_NOINTERFACES} +const + GUID_NULL: TGUID = '{00000000-0000-0000-0000-000000000000}'; + IUnknown_GUID: TGUID = '{00000000-0000-0000-C000-000000000046}'; + +// variant payload as IUnknown, no conversion (varAny/CORBA not supported) +function VarToIInterface(const Value: TVarData; out Obj): Boolean; +var + Intf: IUnknown absolute Obj; +begin + Pointer(Obj) := nil; + case Value.VType of + varUnknown, varDispatch: + if Assigned(Value.VUnknown) then + Intf := IUnknown(Value.VUnknown); + varUnknown + varByRef, varDispatch + varByRef: + if Assigned(Value.VPointer) then + Intf := IUnknown(PPointer(Value.VPointer)^); + end; + Result := Assigned(Intf); +end; + +// assign a Variant to an interface slot, casting to the destination GUID via +// QueryInterface; empty/nil variants assign nil when AllowEmptyAssign +function AssignIInterfaceFromVariant(var Dest: IUnknown; const Src: Variant; + const DestGuid: TGUID; AllowEmptyAssign: Boolean = True): Boolean; +var + iObj: IUnknown; +begin + Dest := nil; + case TVarData(Src).VType of + varEmpty, varNull: + begin + Result := AllowEmptyAssign; + Exit; + end; + varDispatch, varUnknown: + if TVarData(Src).VUnknown = nil then + begin + Result := AllowEmptyAssign; + Exit; + end; + end; + if VarToIInterface(TVarData(Src), iObj) then + begin + // GUID-less destinations (IUnknown or script interfaces declared without + // a GUID) get the reference as-is, everything else must support the GUID + if IsEqualGUID(DestGuid, IUnknown_GUID) or IsEqualGUID(DestGuid, GUID_NULL) then + Dest := iObj + else if iObj.QueryInterface(DestGuid, Dest) <> 0 then + Dest := nil; + end; + Result := Dest <> nil; +end; + +// assign between interface slots of different declared types (cast via +// QueryInterface); same GUID-less fallback as above +function AssignIntfFromIntf(var Dest: IUnknown; const Src: IUnknown; + const DestGuid: TGUID; AllowNilAssign: Boolean = True): Boolean; +begin + Dest := nil; + if Src = nil then + begin + Result := AllowNilAssign; + Exit; + end; + if IsEqualGUID(DestGuid, IUnknown_GUID) or IsEqualGUID(DestGuid, GUID_NULL) then + Dest := Src + else if Src.QueryInterface(DestGuid, Dest) <> 0 then + Dest := nil; + Result := Dest <> nil; +end; + +// 'Cannot cast an interface' plus the target's name (or GUID when unnamed) +function PSIntfCastErrorMsg(const BaseMsg: TbtString; DestType: TPSTypeRec): TbtString; +begin + Result := BaseMsg; + if DestType.ExportName <> '' then + Result := Result + TbtString(' ') + DestType.ExportName + else + Result := Result + TbtString(' ') + TbtString(GUIDToString(TPSTypeRec_Interface(DestType).Guid)); +end; +{$ENDIF !PS_NOINTERFACES} + function TPSExec.SetVariantValue(dest, Src: Pointer; desttype, srctype: TPSTypeRec): Boolean; var Tmp: TObject; @@ -4850,7 +4934,13 @@ function TPSExec.SetVariantValue(dest, Src: Pointer; desttype, srctype: TPSTypeR AssignIDispatchFromVariant(IDispatch(Dest^), Variant(Src^)); {$ENDIF} end else + {$IFDEF Delphi3UP} + if not AssignIInterfaceFromVariant(IUnknown(Dest^), Variant(Src^), + TPSTypeRec_Interface(desttype).Guid) then + raise Exception.Create(string(PSIntfCastErrorMsg(TbtString(RPS_CannotCastInterface), desttype))); + {$ELSE} Result := False; + {$ENDIF} {$IFDEF Delphi3UP} end else if srctype.BaseType = btClass then @@ -4864,15 +4954,22 @@ function TPSExec.SetVariantValue(dest, Src: Pointer; desttype, srctype: TPSTypeR {$ENDIF} end else if srctype.BaseType = btInterface then begin - {$IFNDEF Delphi3UP} + {$IFDEF Delphi3UP} + // same declared type (or nil source): plain assignment, otherwise + // cast to the destination interface via QueryInterface + if (Pointer(Src^) = nil) or + IsEqualGUID(TPSTypeRec_Interface(srctype).Guid, TPSTypeRec_Interface(desttype).Guid) then + IUnknown(Dest^) := IUnknown(Src^) + else if not AssignIntfFromIntf(IUnknown(Dest^), IUnknown(Src^), + TPSTypeRec_Interface(desttype).Guid) then + raise Exception.Create(string(PSIntfCastErrorMsg(TbtString(RPS_CannotCastInterface), desttype))); + {$ELSE} if IUnknown(Dest^) <> nil then begin IUnknown(Dest^).Release; IUnknown(Dest^) := nil; end; - {$ENDIF} IUnknown(Dest^) := IUnknown(Src^); - {$IFNDEF Delphi3UP} if IUnknown(Dest^) <> nil then IUnknown(Dest^).AddRef; {$ENDIF}