Skip to content

Add support for interface and record function results #5

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Closed
wants to merge 6 commits into from
Closed

Add support for interface and record function results #5

Changes from all commits
Commits
Show all changes
6 commits
Select commit Hold shift + click to select a range
7ff9756
Add support for interface and record function results
ElminsterAU Oct 9, 2021
369639b
fixed unused variable from previous commit
ElminsterAU Oct 9, 2021
6a0c62f
support interfaces and records (including var/out) as parameters of c…
ElminsterAU Oct 9, 2021
2f627f6
added support for tkMRecord
ElminsterAU Oct 9, 2021
61d3319
added support for reading record properties (setting them was already…
ElminsterAU Oct 9, 2021
c9e9d74
fix for bug that allowed uncounted interface references to be returne…
ElminsterAU Oct 9, 2021
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
169 changes: 150 additions & 19 deletions Source/WrapDelphi.pas
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -606,17 +606,20 @@ TPyDelphiVarParameter = class(TPyObject)
{ Base class for exposing Records and Interfaces when Extended RTTI is available }
TPyRttiObject = class (TPyObject)
private
fAddr: Pointer;
fRttiType: TRttiStructuredType;
function GetValue: TValue; virtual; abstract;
fCopy: PValue;
fAddr: Pointer;
fRttiType: TRttiStructuredType;
function GetValue: TValue; virtual; abstract;
protected
// Exposed Methods
function SetProps(args, keywords : PPyObject) : PPyObject; cdecl;
function Dir_Wrapper(args: PPyObject): PPyObject; cdecl;
public
PyDelphiWrapper : TPyDelphiWrapper;
constructor Create( APythonType : TPythonType ); override;
destructor Destroy; override;
procedure SetAddrAndType(Address: Pointer; Typ: TRttiStructuredType);
procedure KeepCopy(const aValue: TValue);

function GetAttrO( key: PPyObject) : PPyObject; override;
function SetAttrO( key, value: PPyObject) : Integer; override;
Expand Down Expand Up @@ -842,10 +845,16 @@ TPyDelphiWrapper = class(TEngineClient, IFreeNotificationSubscriber)
{$IFDEF EXTENDED_RTTI}
// Function that provides a Python object wrapping a record
function WrapRecord(Address: Pointer; Typ: TRttiStructuredType): PPyObject;
function WrapRecordCopy(const IValue: TValue): PPyObject;
// Function that provides a Python object wrapping an interface
// Note the the interface must be compiled in {$M+} mode and have a guid
// Usage: WrapInterface(TValue.From(YourInterfaceReference))
// Warning: WrapInterface represents a weak (uncounted) reference!
// Use WrapInterfaceCopy to retrieve a normal counted reference
// that will keep the interface alive as long as python has a
// reference to it.
function WrapInterface(const IValue: TValue): PPyObject;
function WrapInterfaceCopy(const IValue: TValue): PPyObject;
{$ENDIF}
// properties
property EventHandlers : TEventHandlers read fEventHandlerList;
Expand Down Expand Up @@ -999,7 +1008,7 @@ function SimpleValueToPython(const Value: TValue; out ErrMsg: string): PPyObject
tkArray, tkDynArray:
Result := DynArrayToPython(Value);
tkClass, tkMethod,
tkRecord, tkInterface,
tkRecord, tkInterface, {$IFDEF MANAGED_RECORD} tkMRecord,{$ENDIF}
tkClassRef, tkPointer, tkProcedure:
ErrMsg := rs_ErrValueToPython;
else
Expand Down Expand Up @@ -1065,7 +1074,7 @@ function SimplePythonToValue(PyValue: PPyObject; TypeInfo: PTypeInfo;
Result := True;
end;
tkClass, tkMethod, tkArray,
tkRecord, tkInterface,
tkRecord, tkInterface,{$IFDEF MANAGED_RECORD} tkMRecord,{$ENDIF}
tkClassRef, tkPointer, tkProcedure:
ErrMsg := rs_ErrPythonToValue;
else
Expand Down Expand Up @@ -1899,7 +1908,12 @@ function GetRttiAttr(ParentAddr: Pointer; ParentType: TRttiStructuredType;
tkClass:
Result := PyDelphiWrapper.Wrap(Prop.GetValue(ParentAddr).AsObject);
tkInterface:
Result := PyDelphiWrapper.WrapInterface(Prop.GetValue(ParentAddr));
// Must be a copy, otherwise reference counting fails and the returned
// interface might be freed while python is holding a reference to it
Result := PyDelphiWrapper.WrapInterfaceCopy(Prop.GetValue(ParentAddr));
tkRecord{$IFDEF MANAGED_RECORD},tkMRecord{$ENDIF}:
// Must be a copy, property getters are not allowed to leak access to underlying storage
Result := PyDelphiWrapper.WrapRecordCopy(Prop.GetValue(ParentAddr));
tkMethod:
if (ParentType is TRttiInstanceType) and (Prop is TRttiInstanceProperty) then
Result := PyDelphiWrapper.fEventHandlerList.GetCallable(TObject(ParentAddr),
Expand All @@ -1922,10 +1936,18 @@ function GetRttiAttr(ParentAddr: Pointer; ParentType: TRttiStructuredType;
tkClass:
Result := PyDelphiWrapper.Wrap(Field.GetValue(ParentAddr).AsObject); // Returns None if Field is nil
tkInterface:
Result := PyDelphiWrapper.WrapInterface(Field.GetValue(ParentAddr));
tkRecord:
// Must be a copy, otherwise reference counting fails and the returned
// interface might be freed while python is holding a reference to it
Result := PyDelphiWrapper.WrapInterfaceCopy(Field.GetValue(ParentAddr));
tkRecord{$IFDEF MANAGED_RECORD},tkMRecord{$ENDIF}:
if Field.FieldType is TRttiStructuredType then
//Result := PyDelphiWrapper.WrapRecord(Pointer(PPByte(ParentAddr)^ + Field.Offset), TRttiStructuredType(Field.FieldType));
//Potentially dangerous as the returned value, which is a pointer into the object,
//could be stored on the python side, then the object freed, and the stored pointer later
//used to access no longer allocated memory
//But I can't see any good alternative if Python should be able to write directly into
//fields of a record that's part of an object.
//Maybe a relationship should be established between this wrapper and the wrapper of the parent object
//such that a free notification on the parent object will disable access through this wrapper?
Result := PyDelphiWrapper.WrapRecord(PByte(ParentAddr) + Field.Offset, TRttiStructuredType(Field.FieldType));
else
Result := SimpleValueToPython(Field.GetValue(ParentAddr), ErrMsg)
Expand Down Expand Up @@ -1976,7 +1998,7 @@ function SetRttiAttr(const ParentAddr: Pointer; ParentType: TRttiStructuredType
Prop.SetValue(ParentAddr, ValueOut);
Result := True;
end;
tkRecord:
tkRecord{$IFDEF MANAGED_RECORD},tkMRecord{$ENDIF}:
if ValidateRecordProperty(Value, Prop.PropertyType.Handle, ValueOut, ErrMsg) then begin
Prop.SetValue(ParentAddr, ValueOut);
Result := True;
Expand Down Expand Up @@ -2021,7 +2043,7 @@ function SetRttiAttr(const ParentAddr: Pointer; ParentType: TRttiStructuredType
Field.SetValue(ParentAddr, ValueOut);
Result := True;
end;
tkRecord:
tkRecord{$IFDEF MANAGED_RECORD},tkMRecord{$ENDIF}:
if ValidateRecordProperty(Value, Field.FieldType.Handle, ValueOut, ErrMsg) then begin
Field.SetValue(ParentAddr, ValueOut);
Result := True;
Expand Down Expand Up @@ -2051,6 +2073,15 @@ constructor TPyRttiObject.Create(APythonType: TPythonType);
PyDelphiWrapper := TPyDelphiWrapper(APythonType.Owner);
end;

destructor TPyRttiObject.Destroy;
begin
if Assigned(fCopy) then begin
Dispose(fCopy);
fCopy := nil;
end;
inherited;
end;

function TPyRttiObject.Dir_Wrapper(args: PPyObject): PPyObject;
var
i : Integer;
Expand Down Expand Up @@ -2092,6 +2123,30 @@ function TPyRttiObject.GetAttrO(key: PPyObject): PPyObject;
PyUnicodeFromString(Format(rs_ErrAttrGet,[KeyName, ErrMsg])));
end;

procedure TPyRttiObject.KeepCopy(const aValue: TValue);
var
Context: TRttiContext;
RttiType: TRttiStructuredType;
Addr : Pointer;
begin
Context := TRttiContext.Create();
try
RttiType := Context.GetType(aValue.TypeInfo) as TRttiStructuredType;
finally
Context.Free;
end;
if Assigned(fCopy) then begin
Dispose(fCopy);
fCopy := nil;
end;
New(fCopy);
fCopy^ := aValue;
Addr := fCopy^.GetReferenceToRawData;
if RttiType.TypeKind = tkInterface then
Addr := PPointer(Addr)^;
SetAddrAndType(Addr, RttiType);
end;

class procedure TPyRttiObject.RegisterMethods(PythonType: TPythonType);
begin
inherited;
Expand Down Expand Up @@ -2158,7 +2213,10 @@ procedure TPyRttiObject.SetAddrAndType(Address: Pointer; Typ: TRttiStructuredTyp

function TPyPascalRecord.GetValue: TValue;
begin
TValue.Make(fAddr, RttiType.Handle, Result);
if Assigned(fCopy) then
Result := fCopy^
else
TValue.Make(fAddr, RttiType.Handle, Result);
end;

class procedure TPyPascalRecord.SetupType(PythonType: TPythonType);
Expand All @@ -2172,7 +2230,10 @@ class procedure TPyPascalRecord.SetupType(PythonType: TPythonType);

function TPyPascalInterface.GetValue: TValue;
begin
TValue.Make(@fAddr, RttiType.Handle, Result);
if Assigned(fCopy) then
Result := fCopy^
else
TValue.Make(@fAddr, RttiType.Handle, Result);
end;

class procedure TPyPascalInterface.SetupType(PythonType: TPythonType);
Expand Down Expand Up @@ -2893,9 +2954,13 @@ function TPyDelphiMethodObject.Call(ob1, ob2: PPyObject): PPyObject;
if (Param.ParamType = nil) or
(Param.Flags * [TParamFlag.pfVar, TParamFlag.pfOut] <> []) then
begin
Result := nil;
SearchContinue := True;
Break;
if Assigned(Param.ParamType) and (Param.ParamType.TypeKind in [tkRecord{$IFDEF MANAGED_RECORD},tkMRecord{$ENDIF}]) then
//ok
else begin
Result := nil;
SearchContinue := True;
Break;
end
end;

PyValue := PythonType.Engine.PyTuple_GetItem(PyArgs, Index);
Expand Down Expand Up @@ -2923,6 +2988,22 @@ function TPyDelphiMethodObject.Call(ob1, ob2: PPyObject): PPyObject;
Break
end
end
else if Param.ParamType.TypeKind = tkInterface then
begin
if not ValidateInterfaceProperty(PyValue, Param.ParamType as TRttiInterfaceType, Args[Index], ErrMsg)
then begin
Result := nil;
Break
end
end
else if Param.ParamType.TypeKind in [tkRecord{$IFDEF MANAGED_RECORD},tkMRecord{$ENDIF}] then
begin
if not ValidateRecordProperty(PyValue, Param.ParamType.Handle, Args[Index], ErrMsg)
then begin
Result := nil;
Break
end
end
else if (Param.ParamType.TypeKind = tkDynArray) and PythonType.Engine.PyList_Check(PyValue) then
begin
if ParamAsDynArray(PyValue, Param, Args[Index]) then
Expand Down Expand Up @@ -2994,9 +3075,14 @@ function TPyDelphiMethodObject.Call(ob1, ob2: PPyObject): PPyObject;
ret := meth.Invoke(Addr, Args);
if ret.IsEmpty then
Result := GetPythonEngine.ReturnNone
else if ret.Kind = tkClass then
Result := fDelphiWrapper.Wrap(ret.AsObject)
else begin
else case ret.Kind of
tkClass:
Result := fDelphiWrapper.Wrap(ret.AsObject);
tkInterface:
Result := fDelphiWrapper.WrapInterfaceCopy(ret);
tkRecord{$IFDEF MANAGED_RECORD},tkMRecord{$ENDIF}:
Result := fDelphiWrapper.WrapRecordCopy(ret);
else
Result := SimpleValueToPython(ret, ErrMsg);
if Result = nil then
with PythonType.Engine do
Expand Down Expand Up @@ -3842,6 +3928,28 @@ function TPyDelphiWrapper.WrapRecord(Address: Pointer; Typ: TRttiStructuredType)
end;
end;

function TPyDelphiWrapper.WrapRecordCopy(const IValue: TValue) : PPyObject;
var
PythonType: TPythonType;
begin
CheckEngine;
if IValue.IsEmpty then begin
Result := Engine.ReturnNone;
Exit;
end;
PythonType := GetHelperType('PascalRecordType');
if not Assigned(PythonType) or not (IValue.Kind in [tkRecord{$IFDEF MANAGED_RECORD},tkMRecord{$ENDIF}]) then
begin
Result := Engine.ReturnNone;
Exit;
end;
Result := PythonType.CreateInstance;
with PythonToDelphi(Result) as TPyPascalRecord do begin
KeepCopy(IValue);
PyDelphiWrapper := Self;
end;
end;

function TPyDelphiWrapper.WrapInterface(const IValue: TValue): PPyObject;
var
PythonType: TPythonType;
Expand All @@ -3868,6 +3976,29 @@ function TPyDelphiWrapper.WrapInterface(const IValue: TValue): PPyObject;
end;
end;

function TPyDelphiWrapper.WrapInterfaceCopy(const IValue: TValue): PPyObject;
var
PythonType: TPythonType;
begin
CheckEngine;
if IValue.IsEmpty then begin
Result := Engine.ReturnNone;
Exit;
end;
PythonType := GetHelperType('PascalInterfaceType');
if not Assigned(PythonType) or (IValue.Kind <> tkInterface) then
begin
Result := Engine.ReturnNone;
Exit;
end;
Result := PythonType.CreateInstance;
with PythonToDelphi(Result) as TPyPascalInterface do begin
KeepCopy(IValue);
PyDelphiWrapper := Self;
end;
end;


// To keep the RTTI Pool alive and avoid continuously creating/destroying it
// See also https://stackoverflow.com/questions/27368556/trtticontext-multi-thread-issue
Var
Expand Down