(**************************************************************************)

unit WrapDelphi;

SysUtils, Classes, PythonEngine, TypInfo, Types,

Variants,

Rtti,

ObjAuto,

Contnrs;

TObjectOwnership = (soReference, soOwned);

// forward declaration

TPyDelphiWrapper = class;

{

IFreeNotificationSubscriber = interface

['{F08FB6EA-3D8B-43C0-8343-77C8E06DE401}']

procedure Notify(ADeletedObject : TObject);

end;

IFreeNotification = interface

['{085FD1BB-44FC-457A-B357-4E06071BBEA5}']

procedure Subscribe(const ASubscriber: IFreeNotificationSubscriber);

procedure UnSubscribe(const ASubscriber: IFreeNotificationSubscriber);

end;

{ Helper class that handles the detail of implementing IFreeNotification.

TFreeNotificationImpl = class(TInterfacedObject, IFreeNotification)

private

fSubscribers : TInterfaceList;

fOwner: TObject;

function GetSubscribers : TInterfaceList;

protected

// implementation of IFreeNotification

procedure Subscribe(const ASubscriber: IFreeNotificationSubscriber);

procedure UnSubscribe(const ASubscriber: IFreeNotificationSubscriber);

public

constructor Create(AOwner : TObject);

destructor Destroy; override;

property Owner : TObject read fOwner;

end;

{

TContainerAccess = class

private

fContainer: TObject;

fWrapper: TPyDelphiWrapper;

protected

function Wrap(Obj : TObject; Ownership: TObjectOwnership = soReference) : PPyObject;

public

constructor Create(AWrapper : TPyDelphiWrapper; AContainer: TObject); virtual;

function Clone : TContainerAccess; virtual;

function GetItem(AIndex : Integer) : PPyObject; virtual; abstract;

function GetSize : Integer; virtual; abstract;

function IndexOf(AValue : PPyObject) : Integer; virtual;

function SetItem(AIndex : Integer; AValue : PPyObject) : Boolean; virtual;

class function ExpectedContainerClass : TClass; virtual; abstract;

class function Name : string; virtual;

class function SupportsWrite : Boolean; virtual;

class function SupportsIndexOf : Boolean; virtual;

property Container : TObject read fContainer;

property Wrapper : TPyDelphiWrapper read fWrapper;

end;

TContainerAccessClass = class of TContainerAccess;

{

TPyDelphiContainer = class(TPyObject)

private

fContainerAccess: TContainerAccess;

fPyDelphiWrapper: TPyDelphiWrapper;

public

destructor Destroy; override;

procedure Setup(APyDelphiWrapper : TPyDelphiWrapper; AContainerAccess : TContainerAccess);

class procedure SetupType( PythonType : TPythonType ); override;

function Repr : PPyObject; override;

function Iter : PPyObject; override;

// Sequence services

function SqLength : NativeInt; override;

function SqItem( idx : NativeInt ) : PPyObject; override;

function SqAssItem( idx : NativeInt; obj : PPyObject) : Integer; override;

function SqContains( obj: PPyObject): integer; override;

// Properties

property ContainerAccess : TContainerAccess read fContainerAccess;

property PyDelphiWrapper : TPyDelphiWrapper read fPyDelphiWrapper;

end;

{

TPyDelphiIterator = class(TPyObject)

private

fPosition: Integer;

fContainerAccess: TContainerAccess;

public

destructor Destroy; override;

procedure Setup(AContainerAccess : TContainerAccess);

class procedure SetupType( PythonType : TPythonType ); override;

function Repr : PPyObject; override;

function Iter : PPyObject; override;

function IterNext : PPyObject; override;

// Properties

property Position : Integer read fPosition;

property ContainerAccess : TContainerAccess read fContainerAccess;

end;

{

TPyInterfacedObject = class(TPyObject, IInterface)

private

// implementation of interface IInterface

{$IFDEF FPC_HAS_CONSTREF}

function QueryInterface(constref IID: TGUID; out Obj): HResult; {$IFDEF MSWINDOWS}stdcall{$ELSE}cdecl{$ENDIF};

function _AddRef: Integer; {$IFDEF MSWINDOWS}stdcall{$ELSE}cdecl{$ENDIF};

function _Release: Integer; {$IFDEF MSWINDOWS}stdcall{$ELSE}cdecl{$ENDIF};

{$ELSE}

function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;

function _AddRef: Integer; stdcall;

function _Release: Integer; stdcall;

{$ENDIF}

end;

{

TPyDelphiObject = class (TPyInterfacedObject, IFreeNotificationSubscriber)

private

fDelphiObject: TObject;

fContainerAccess : TContainerAccess;

function GetContainerAccess: TContainerAccess;

procedure SetDelphiObject(const Value: TObject);

protected

function CheckBound : Boolean;

function HasContainerAccessClass : Boolean;

procedure SubscribeToFreeNotification; virtual;

procedure UnSubscribeToFreeNotification; virtual;

class function GetTypeName : string; virtual;

// Exposed Methods

function Free_Wrapper(args : PPyObject) : PPyObject; cdecl;

function InheritsFrom_Wrapper(args : PPyObject) : PPyObject; cdecl;

function ToTuple_Wrapper(args : PPyObject) : PPyObject; cdecl;

function ToList_Wrapper(args : PPyObject) : PPyObject; cdecl;

function SetProps(args, keywords : PPyObject) : PPyObject; cdecl;

function Dir_Wrapper(args: PPyObject): PPyObject; cdecl;

// Exposed Getters

function Get_ClassName(Acontext : Pointer) : PPyObject; cdecl;

function Get_Owned(Acontext : Pointer) : PPyObject; cdecl;

function Set_Owned(AValue: PPyObject; AContext: Pointer): Integer;

function Get_Bound(Acontext : Pointer) : PPyObject; cdecl;

// implementation of interface IFreeNotificationSubscriber

procedure Notify(ADeletedObject : TObject);

public

PyDelphiWrapper : TPyDelphiWrapper;

Owned: Boolean;

constructor Create( APythonType : TPythonType ); override;

destructor Destroy; override;

function GetAttrO( key: PPyObject) : PPyObject; override;

function SetAttrO( key, value: PPyObject) : Integer; override;

// Objects are equal when they refer to the same DelphiObject

function Compare( obj: PPyObject) : Integer; override;

function Repr : PPyObject; override;

// automatic iterator support when the wrapper implements IContainerAccessProvider

function Iter : PPyObject; override;

// Sequence services

function SqLength : NativeInt; override;

function SqItem( idx : NativeInt ) : PPyObject; override;

function SqContains( obj: PPyObject): integer; override;

function SqAssItem( idx : NativeInt; obj : PPyObject) : Integer; override;

class function DelphiObjectClass : TClass; virtual;

class procedure RegisterMethods( PythonType : TPythonType ); override;

class procedure RegisterGetSets( PythonType : TPythonType ); override;

class procedure SetupType( PythonType : TPythonType ); override;

// if the class is a container (TStrings, TComponent, TCollection...),

// then return the class implementing the access to the contained items.

class function GetContainerAccessClass : TContainerAccessClass; virtual;

// creates a container access object using the class returned by GetContainerAccess.

function CreateContainerAccess : TContainerAccess; virtual;

// helper methods

function Wrap(AObject : TObject; AOwnership: TObjectOwnership = soReference) : PPyObject;

// Properties

property DelphiObject: TObject read fDelphiObject write SetDelphiObject;

property ContainerAccess : TContainerAccess read GetContainerAccess;

end;

TPyDelphiObjectClass = class of TPyDelphiObject;

{ Generic wrapper for pascal classes

TPyClassWrapper<T: class> = class(TPyDelphiObject)

function GetDelphiObject: T;

procedure SetDelphiObject(const Value: T);

public

class function DelphiObjectClass : TClass; override;

// Properties

property DelphiObject: T read GetDelphiObject write SetDelphiObject;

end;

{ This class will simply hold a Python object in its Value property.

TPyDelphiVarParameter = class(TPyObject)

private

fValue: PPyObject;

procedure SetValue(const Value: PPyObject);

protected

// Exposed Getters

function Get_Value(Acontext : Pointer) : PPyObject; cdecl;

// Exposed Setters

function Set_Value(AValue : PPyObject; AContext : Pointer) : Integer; cdecl;

public

destructor Destroy; override;

function RichCompare( obj : PPyObject; Op : TRichComparisonOpcode) : PPyObject; override;

function Repr : PPyObject; override;

class procedure RegisterGetSets( PythonType : TPythonType ); override;

class procedure SetupType( PythonType : TPythonType ); override;

property Value : PPyObject read fValue write SetValue;

end;

{$IFDEF EXTENDED_RTTI}

{ 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;

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;

procedure SetAddrAndType(Address: Pointer; Typ: TRttiStructuredType);

function GetAttrO( key: PPyObject) : PPyObject; override;

function SetAttrO( key, value: PPyObject) : Integer; override;

function Repr : PPyObject; override;

property Addr: Pointer read fAddr;

property RttiType: TRttiStructuredType read fRttiType;

property Value: TValue read GetValue;

//

class procedure RegisterMethods( PythonType : TPythonType ); override;

class procedure SetupType( PythonType : TPythonType ); override;

end;

TPyPascalRecord = class(TPyRttiObject)

private

function GetValue: TValue; override;

public

class procedure SetupType( PythonType : TPythonType ); override;

end;

TPyPascalInterface = class(TPyRttiObject)

private

function GetValue: TValue; override;

public

class procedure SetupType( PythonType : TPythonType ); override;

end;

{$ENDIF}

TEventHandler = class

private

fComponent: TObject;

public

PyDelphiWrapper : TPyDelphiWrapper;

PropertyInfo : PPropInfo;

EventType : PTypeInfo;

Callable : PPyObject;

// connects to the event on creation

constructor Create(PyDelphiWrapper : TPyDelphiWrapper; Component : TObject;

PropertyInfo : PPropInfo; Callable : PPyObject); virtual;

// Disconnects from the event on destruction

destructor Destroy; override;

// Disconnects from the free notification event now

procedure Unsubscribe;

// returns the type info of the supported event

class function GetTypeInfo : PTypeInfo; virtual; abstract;

// properties

property Component : TObject read fComponent;

end;

TEventHandlerClass = class of TEventHandler;

TEventHandlers = class

private

fItems : TObjectList;

fRegisteredClasses : TClassList;

fPyDelphiWrapper: TPyDelphiWrapper;

function GetCount: Integer;

function GetItem(AIndex: Integer): TEventHandler;

function GetRegisteredClass(AIndex: Integer): TEventHandlerClass;

function GetRegisteredClassCount: Integer;

protected

function FindHandler(ATypeInfo : PTypeInfo) : TEventHandlerClass;

property RegisteredClasses[AIndex : Integer] : TEventHandlerClass read GetRegisteredClass;

property RegisteredClassCount : Integer read GetRegisteredClassCount;

public

constructor Create(APyDelphiWrapper : TPyDelphiWrapper);

destructor Destroy; override;

function Add(AEventHandler : TEventHandler) : Boolean;

procedure Clear;

procedure Delete(AIndex : Integer);

function GetCallable(AComponent : TObject; APropInfo : PPropInfo) : PPyObject; overload;

function GetCallable(AComponent : TObject; const APropName : string) : PPyObject; overload;

function Link(AComponent : TObject; APropInfo : PPropInfo;

ACallable : PPyObject; out ErrMsg: string) : Boolean;

function IndexOf(AComponent : TObject; APropInfo : PPropInfo) : Integer;

procedure RegisterHandler(AEventHandlerClass : TEventHandlerClass);

function Unlink(AComponent : TObject; APropInfo : PPropInfo) : Boolean;

property Count : Integer read GetCount;

property Items[AIndex : Integer] : TEventHandler read GetItem; default;

property PyDelphiWrapper : TPyDelphiWrapper read fPyDelphiWrapper;

end;

TNotifyEventHandler = class(TEventHandler)

protected

procedure DoEvent(Sender: TObject);

public

constructor Create(PyDelphiWrapper : TPyDelphiWrapper; Component : TObject;

PropertyInfo : PPropInfo; Callable : PPyObject); override;

class function GetTypeInfo : PTypeInfo; override;

end;

{ Subclass TRegisteredUnit to register your wrappers for a specific unit.

TRegisteredUnit = class

public

function Name : string; virtual; abstract;

procedure RegisterWrappers(APyDelphiWrapper : TPyDelphiWrapper); virtual;

procedure DefineVars(APyDelphiWrapper : TPyDelphiWrapper); virtual;

procedure DefineFunctions(APyDelphiWrapper : TPyDelphiWrapper); virtual;

end;

{ Singleton containing all registered units.

TRegisteredUnits = class

private

fItems : TObjectList;

function GetCount: Integer;

function GetItem(AIndex: Integer): TRegisteredUnit;

public

constructor Create;

destructor Destroy; override;

procedure Add(ARegisteredModule : TRegisteredUnit);

property Count : Integer read GetCount;

property Items[AIndex : Integer] : TRegisteredUnit read GetItem; default;

end;

{

{$IF not Defined(FPC) and (CompilerVersion >= 23)}

[ComponentPlatformsAttribute(pidSupportedPlatforms)]

{$IFEND}

TPyDelphiWrapper = class(TEngineClient, IFreeNotificationSubscriber)

private

// Stores Delphi class registration information

fClassRegister : TObjectList;

// Stores registration for Helper Types (do not correspond to Delphi classes)

fHelperClassRegister : TStringList;

// Stores Created Event Handlers

fEventHandlerList : TEventHandlers;

fVarParamType: TPythonType;

fDelphiMethodType: TPythonType;

fRecordType: TPythonType;

fInterfaceType: TPythonType;

// Exposed Module level function CreateComponent(ComponentClass, Owner)

function CreateComponent( pself, args : PPyObject ) : PPyObject; cdecl;

// Implementation of interface IFreeNotificationSubscriber

procedure Notify(ADeletedObject : TObject);

protected

FModule : TPythonModule;

fDefaultIterType: TPythonType;

fDefaultContainerType: TPythonType;

procedure CreateWrappers; virtual;

procedure CreateModuleVars; virtual;

procedure CreateModuleFunctions; virtual;

procedure SetEngine(Value : TPythonEngine ); override;

procedure SetModule(const Value: TPythonModule);

procedure Notification( AComponent: TComponent;

Operation: TOperation); override;

procedure ModuleReady(Sender : TObject); override;

procedure UnsubscribeFreeNotifications;

procedure CreatePyFunc(AModule : TPythonModule; AMethodDef : PPyMethodDef);

public

constructor Create( AOwner : TComponent ); override;

destructor Destroy; override;

procedure Initialize; override;

procedure Finalize; override;

procedure DefineVar(const AName : string; const AValue : Variant); overload;

procedure DefineVar(const AName : string; AValue : TObject); overload;

function RegisterDelphiWrapper(AWrapperClass : TPyDelphiObjectClass): TPythonType;

function RegisterHelperType(APyObjectClass : TPyObjectClass) : TPythonType;

function RegisterFunction(AFuncName : PAnsiChar; AFunc : PyCFunction; ADocString : PAnsiChar ): PPyMethodDef; overload;

function RegisterFunction(AFuncName : PAnsiChar; AFunc : TDelphiMethod; ADocString : PAnsiChar ): PPyMethodDef; overload;

function GetHelperType(const TypeName : string) : TPythonType;

// Function that provides a Python object wrapping an object

function Wrap(AObj : TObject; AOwnership: TObjectOwnership = soReference) : PPyObject;

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 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;

{$ENDIF}

// properties

property EventHandlers : TEventHandlers read fEventHandlerList;

// Helper types

property DefaultContainerType : TPythonType read fDefaultContainerType;

property DefaultIterType : TPythonType read fDefaultIterType;

property DelphiMethodType : TPythonType read fDelphiMethodType;

property VarParamType : TPythonType read fVarParamType;

published

property Module : TPythonModule read FModule write SetModule;

end;

{ Singletons }

function RegisteredUnits : TRegisteredUnits;

function GlobalDelphiWrapper: TPyDelphiWrapper;

{ Helper Functions }

function CheckIndex(AIndex, ACount : Integer; const AIndexName : string = 'Index') : Boolean;

function CheckIntAttribute(AAttribute : PPyObject; const AAttributeName : string; out AValue : Integer) : Boolean;

function CheckFloatAttribute(AAttribute : PPyObject; const AAttributeName : string; out AValue : Double) : Boolean;

function CheckBoolAttribute(AAttribute : PPyObject; const AAttributeName : string; out AValue : Boolean) : Boolean;

function CheckStrAttribute(AAttribute : PPyObject; const AAttributeName : string; out AValue : string) : Boolean;

function CheckObjAttribute(AAttribute : PPyObject; const AAttributeName : string;

AExpectedClass : TClass;

out AValue : TObject) : Boolean;

function CheckCallableAttribute(AAttribute : PPyObject; const AAttributeName : string) : Boolean;

function CheckEnum(const AEnumName : string; AValue, AMinValue, AMaxValue : Integer) : Boolean;

function CreateVarParam(PyDelphiWrapper : TPyDelphiWrapper; const AValue : Variant) : PPyObject; overload;

function CreateVarParam(PyDelphiWrapper : TPyDelphiWrapper; AObject: TObject) : PPyObject; overload;

function SetToPython(ATypeInfo: PTypeInfo; AValue : Integer) : PPyObject; overload;

function SetToPython(APropInfo: PPropInfo; AValue : Integer) : PPyObject; overload;

function SetToPython(AInstance: TObject; APropInfo: PPropInfo) : PPyObject; overload;

function PythonToSet(APropInfo: PPropInfo; ASet : PPyObject) : Integer; overload;

function PythonToSet(ATypeInfo: PTypeInfo; ASet : PPyObject) : Integer; overload;

function SupportsFreeNotification(AObject : TObject) : Boolean;

procedure RaiseNotifyEvent(PyDelphiWrapper : TPyDelphiWrapper; ACallable : PPyObject; Sender: TObject);

{Sets mulptiple properties of PyObject from keywords argument}

function SetProperties(PyObject: PPyObject; keywords: PPyObject): PPyObject;

Math,

RTLConsts;

resourcestring

rs_ErrCheckIndex = '%s "%d" out of range';

rs_ErrCheckInt = '%s receives only integer values';

rs_ErrCheckFloat = '%s receives only float values';

rs_ErrCheckStr = '%s receives only string values';

rs_ErrCheckCallable = '%s accepts only None or Callable values';

rs_ErrCheckEnum = 'Enum %s accepts values between %d and %d. Received %d.';

rs_ErrCheckObjOfType = '%s receives only Delphi objects of type %s';

rs_ErrCheckObj = '%s receives only Delphi objects';

rs_ErrSqAss = 'Container %s does not support indexed write (f[i] = x)';

rs_ErrSqContains = 'Container %s does not support the Contains protocol';

rs_ErrCheckBound = 'Delphi wrapper %s is not bound';

rs_ErrSequence = 'Wrapper %s does not support sequences';

rs_ErrInvalidArgs = '"%s" called with invalid arguments.'#$A'Error: %s';

rs_ErrInvalidRet = 'Call "%s" returned a value that could not be coverted to Python'#$A'Error: %s';

rs_IncompatibleArguments = 'Could not find a method with compatible arguments';

rs_ErrAttrGet = 'Error in getting property "%s".'#$A'Error: %s';

rs_UnknownAttribute = 'Unknown attribute';

rs_ErrIterSupport = 'Wrapper %s does not support iterators';

rs_ErrAttrSetr = 'Error in setting property %s'#$A'Error: %s';

rs_IncompatibleClasses = 'Incompatible classes';

rs_IncompatibleRecords = 'Incompatible record types';

rs_IncompatibleInterfaces = 'Incompatible interfaces';

rs_NotPublished = 'Event handling is available only for published properties';

rs_ExpectedObject = 'Expected a Pascal object';

rs_ExpectedRecord = 'Expected a Pascal record';

rs_ExpectedClass = 'Expected a Pascal class';

rs_ExpectedInterface = 'Expected a Pascal interface';

rs_InvalidClass = 'Invalid class';

rs_ErrEventNotReg = 'No Registered EventHandler for events of type "%s';

rs_ErrEventNoSuport = 'Class %s does not support events because it must '+

'either inherit from TComponent or implement interface IFreeNotification';

rs_ErrEventExpectCallable = 'You can only assign a callable to method property "%s"';

rs_NotWritable = 'The class members is not writable';

rs_NotReadable = 'The class member is not readable';

rs_NoAccess = 'Private and protected class members cannot be accessed';

rs_ErrValueToPython = 'Unsupported conversion from TValue to Python value';

rs_ErrPythonToValue = 'Unsupported conversion from Python value to TValue';

rs_ErrNoTypeInfo = 'TypeInfo is not available';

rs_ErrUnexpected = 'Unexpected error';

gRegisteredUnits : TRegisteredUnits;

function RttiCall(ParentAddress: pointer; PythonType: TPythonType;

DelphiWrapper: TPyDelphiWrapper; MethName: string;

ParentRtti: TRttiStructuredType; ob1, ob2: PPyObject;

AParentAddrIsClass: boolean = false): PPyObject; forward;

function RegisteredUnits : TRegisteredUnits;

if not Assigned(gRegisteredUnits) then

gRegisteredUnits := TRegisteredUnits.Create;

Result := gRegisteredUnits;

end;

function GlobalDelphiWrapper: TPyDelphiWrapper;

Engine: TPythonEngine;

I: Integer;

Engine := GetPythonEngine;

for I := 0 to Engine.ClientCount -1 do

if Engine.Clients[I] is TPyDelphiWrapper then

Exit(TPyDelphiWrapper(Engine.Clients[I]));

Result := nil;

end;

function DynArrayToPython(const Value: TValue): PPyObject;

I: Integer;

V: Variant;

PyEngine: TPythonEngine;