Skip to content

Partially merging #5 #72

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

Merged
merged 2 commits into from
Sep 3, 2023
Merged

Partially merging #5 #72

Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
c59176d
Partially merging #5
lmbelo Sep 3, 2023
6118bb4
Merge branch 'ElminsterAU-Feature-InterfaceAndRecordAsCallResult' int…
lmbelo Sep 3, 2023
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
185 changes: 156 additions & 29 deletions Source/WrapDelphi.pas
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -712,17 +712,22 @@ 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;
function CreateCopy(const AValue: TValue): pointer;
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 SetValueAndType(const AValue: TValue;
const ACopy: boolean = false);

function GetAttrO( key: PPyObject) : PPyObject; override;
function SetAttrO( key, value: PPyObject) : Integer; override;
Expand Down Expand Up @@ -950,11 +955,16 @@ TPyDelphiWrapper = class(TEngineClient, IFreeNotificationSubscriber)
function WrapClass(AClass: TClass): PPyObject;
{$IFDEF EXTENDED_RTTI}
// Function that provides a Python object wrapping a record
function WrapRecord(Address: Pointer; Typ: TRttiStructuredType): PPyObject;
function WrapRecord(Address: Pointer; Typ: TRttiStructuredType): PPyObject; overload;
function WrapRecord(const AValue: TValue; const ACopy: boolean = false): PPyObject; overload;
// 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))
function WrapInterface(const IValue: TValue): PPyObject;
// 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; const ACopy: boolean = false): PPyObject;
{$ENDIF}
// properties
property EventHandlers : TEventHandlers read fEventHandlerList;
Expand Down Expand Up @@ -1766,7 +1776,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 @@ -1832,7 +1842,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 @@ -2838,6 +2848,22 @@ function RttiCall(ParentAddress: pointer; PythonType: TPythonType;
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 @@ -2916,6 +2942,10 @@ function RttiCall(ParentAddress: pointer; PythonType: TPythonType;
Result := DelphiWrapper.Wrap(ret.AsObject)
else if ret.Kind = tkClassRef then
Result := DelphiWrapper.WrapClass(ret.AsClass)
else if ret.Kind = tkInterface then
Result := DelphiWrapper.WrapInterface(ret, true)
else if ret.Kind in [tkRecord{$IFDEF MANAGED_RECORD},tkMRecord{$ENDIF}] then
Result := DelphiWrapper.WrapRecord(ret, true)
else begin
Result := SimpleValueToPython(ret, ErrMsg);
if Result = nil then
Expand Down Expand Up @@ -2972,7 +3002,12 @@ function GetRttiAttr(ParentAddr: Pointer; ParentType: TRttiStructuredType;
tkClassRef:
Result := PyDelphiWrapper.WrapClass(Prop.GetValue(ParentAddr).AsClass);
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.WrapInterface(Prop.GetValue(ParentAddr), true);
tkRecord{$IFDEF MANAGED_RECORD},tkMRecord{$ENDIF}:
// Must be a copy, property getters are not allowed to leak access to underlying storage
Result := PyDelphiWrapper.WrapRecord(Prop.GetValue(ParentAddr), true);
tkMethod:
if (ParentType is TRttiInstanceType) and (Prop is TRttiInstanceProperty) then
Result := PyDelphiWrapper.fEventHandlerList.GetCallable(TObject(ParentAddr),
Expand All @@ -2997,11 +3032,19 @@ function GetRttiAttr(ParentAddr: Pointer; ParentType: TRttiStructuredType;
tkClassRef:
Result := PyDelphiWrapper.WrapClass(Field.GetValue(ParentAddr).AsClass); // 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.WrapInterface(Field.GetValue(ParentAddr), true);
tkRecord{$IFDEF MANAGED_RECORD},tkMRecord{$ENDIF}:
if Field.FieldType is TRttiStructuredType then
//Result := PyDelphiWrapper.WrapRecord(Pointer(PPByte(ParentAddr)^ + Field.Offset), TRttiStructuredType(Field.FieldType));
Result := PyDelphiWrapper.WrapRecord(PByte(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)
end;
Expand Down Expand Up @@ -3057,7 +3100,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 @@ -3107,7 +3150,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 @@ -3137,6 +3180,13 @@ constructor TPyRttiObject.Create(APythonType: TPythonType);
PyDelphiWrapper := TPyDelphiWrapper(APythonType.Owner);
end;

destructor TPyRttiObject.Destroy;
begin
if Assigned(FCopy) then
Dispose(FCopy);
inherited;
end;

function TPyRttiObject.Dir_Wrapper(args: PPyObject): PPyObject;
var
i : Integer;
Expand Down Expand Up @@ -3232,6 +3282,31 @@ class procedure TPyRttiObject.SetupType(PythonType: TPythonType);
PythonType.Services.Basic := [bsGetAttrO, bsSetAttrO, bsRepr, bsStr];
end;

function TPyRttiObject.CreateCopy(const AValue: TValue): pointer;
var
LContext: TRttiContext;
LRttiType: TRttiStructuredType;
begin
LContext := TRttiContext.Create();
try
LRttiType := LContext.GetType(AValue.TypeInfo) as TRttiStructuredType;
finally
LContext.Free;
end;

if Assigned(FCopy) then begin
Dispose(FCopy);
FCopy := nil;
end;

New(FCopy);
FCopy^ := AValue;
Result := FCopy^.GetReferenceToRawData();

if LRttiType.TypeKind = tkInterface then
Result := PPointer(Addr)^;
end;

procedure TPyRttiObject.SetAddrAndType(Address: Pointer; Typ: TRttiStructuredType);
begin
fAddr := Address;
Expand All @@ -3240,11 +3315,36 @@ procedure TPyRttiObject.SetAddrAndType(Address: Pointer; Typ: TRttiStructuredTyp
fRttiType := Typ;
end;

procedure TPyRttiObject.SetValueAndType(const AValue: TValue;
const ACopy: boolean);
var
LRttiCtx: TRttiContext;
LRttiType: TRttiStructuredType;
begin
LRttiCtx := TRttiContext.Create();
try
LRttiType := LRttiCtx.GetType(AValue.TypeInfo) as TRttiStructuredType;
finally
LRttiCtx.Free();
end;

if ACopy then
SetAddrAndType(CreateCopy(AValue), LRttiType)
else if RttiType.TypeKind in [tkRecord{$IFDEF MANAGED_RECORD}, tkMRecord{$ENDIF}] then
SetAddrAndType(AValue.GetReferenceToRawData(), LRttiType)
else if RttiType.TypeKind = tkInterface then
SetAddrAndType(Pointer(AValue.GetReferenceToRawData()^), LRttiType)
end;


{ TPyPascalRecord }

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 @@ -3258,7 +3358,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 @@ -5261,28 +5364,52 @@ function TPyDelphiWrapper.WrapRecord(Address: Pointer; Typ: TRttiStructuredType)
end;
end;

function TPyDelphiWrapper.WrapInterface(const IValue: TValue): PPyObject;
function TPyDelphiWrapper.WrapRecord(const AValue: TValue; const ACopy: boolean): PPyObject;
var
PythonType: TPythonType;
Address: Pointer;
Typ: TRttiStructuredType;
LPythonType: TPythonType;
begin
CheckEngine;
CheckEngine();

if AValue.IsEmpty then begin
Result := Engine.ReturnNone();
Exit;
end;

LPythonType := GetHelperType('PascalRecordType');
if not Assigned(LPythonType) or not (AValue.Kind in [tkRecord{$IFDEF MANAGED_RECORD}, tkMRecord{$ENDIF}]) then
begin
Result := Engine.ReturnNone();
Exit;
end;

Result := LPythonType.CreateInstance();
with PythonToDelphi(Result) as TPyPascalRecord do begin
SetValueAndType(AValue, ACopy);
PyDelphiWrapper := Self;
end;
end;

function TPyDelphiWrapper.WrapInterface(const IValue: TValue; const ACopy: boolean): PPyObject;
var
LPythonType: TPythonType;
begin
CheckEngine();

if IValue.IsEmpty then begin
Result := Engine.ReturnNone;
Result := Engine.ReturnNone();
Exit;
end;
PythonType := GetHelperType('PascalInterfaceType');
if not Assigned(PythonType) or (IValue.Kind <> tkInterface) then

LPythonType := GetHelperType('PascalInterfaceType');
if not Assigned(LPythonType) or (IValue.Kind <> tkInterface) then
begin
Result := Engine.ReturnNone;
Result := Engine.ReturnNone();
Exit;
end;
Result := PythonType.CreateInstance;
Typ := TRttiContext.Create.GetType(IValue.TypeInfo) as TRttiStructuredType;
Address := Pointer(IValue.GetReferenceToRawData^);

Result := LPythonType.CreateInstance();
with PythonToDelphi(Result) as TPyPascalInterface do begin
SetAddrAndType(Address, Typ);
SetValueAndType(IValue, ACopy);
PyDelphiWrapper := Self;
end;
end;
Expand Down