Zur Initialisierung wird am ende des Modul nur noch das macro InitClass(Interfacename, ...) aufgerufen.
Alle Procedure für das Interface werden mit Runtime Procedure Methode(*this...) umgesetzt.
Die Procedure-Namen 'Runtime Procedure Initialize(*this...)' und 'Runtime Procedure Dispose(*this...) sind reserviert und werden automatisch hinzugefügt.
Durch die Verwendung von den Library JSON und Runtime wägst die Execute natürlich an und es muss die Lizenz-Information angegeben werden
Daher werden ich weiter beide Module, mit und ohne JSON, weiter pflegen.
Danke an GPI für die Idee mit der JSON Library
Update v2.02
- Code bereinigt
Update v2.03
- Überprüfung: Gibt den fehlenden Methodennamen aus
Update v2.05
- Geändert: Internen Aufruf von Initialize und Dispose von List auf Array geändert, zur Vermeidung von Thread-Blocking
Modul_BaseClassJS.pb
Code: Alles auswählen
;-Begin Module BaseClass (JS)
; Comment : Module as Object - With JSON und Runtime
; Author : mk-soft
; Version : v2.05
; Created : 23.08.2017
; Updated : 24.08.2017
; Link DE : http://www.purebasic.fr/german/viewtopic.php?f=8&t=30331
; Link EN : http://www.purebasic.fr/english/viewtopic.php?f=12&t=69033
; ***************************************************************************************
DeclareModule BaseClass
; ---------------------------------------------------------------------------
; Internal Class Manager
Prototype ProtoInvoke(*This)
Structure udtInvoke
*Invoke.ProtoInvoke
EndStructure
Structure udtClass
Array *vTable(3)
Array Initialize.udtInvoke(0)
Array Dispose.udtInvoke(0)
EndStructure
Structure udtClasses
Map Entry.udtClass()
EndStructure
Global Class.udtClasses
; ---------------------------------------------------------------------------
; BaseClass declaration
Structure sBaseSystem
*vTable
*Self.udtClass
RefCount.i
Mutex.i
EndStructure
; Public Structure
Structure sBaseClass
System.sBaseSystem
EndStructure
; Public Interface
Interface iBaseClass
QueryInterface(*riid, *addr)
AddRef()
Release()
EndInterface
; ---------------------------------------------------------------------------
Macro dq
"
EndMacro
; ---------------------------------------------------------------------------
; Added New Class
Declare AddClass(ClassName.s, ClassExtends.s, JSValue, Size)
Macro InitClass(ClassInterface, ClassExtends=BaseClass)
Procedure InitClass#MacroExpandedCount()
Protected js, jsvalue, index, size
js = CreateJSON(#PB_Any)
jsvalue = JSONValue(js)
size = SizeOf(ClassInterface) / SizeOf(integer) - 1
Dim iMethode(size)
For index = 0 To size
iMethode(index) = index
Next
InsertJSONStructure(jsvalue, iMethode(), ClassInterface)
AddClass(#PB_Compiler_Module, dq#ClassExtends#dq, jsvalue, size)
FreeJSON(js)
EndProcedure : InitClass#MacroExpandedCount()
EndMacro
; ---------------------------------------------------------------------------
; Macro for init object (short)
Macro InitObject(sProperty)
Protected *Object.sProperty, __cnt, __index
*Object = AllocateStructure(sProperty)
If *Object
*Object\System\vTable = Class\Entry(#PB_Compiler_Module)\vTable()
*Object\System\Self = @Class\Entry(#PB_Compiler_Module)
*Object\System\RefCount = 0
*Object\System\Mutex = CreateMutex()
If Not *Object\System\Mutex
Debug "Error: Class '" + #PB_Compiler_Module + "' create mutex"
FreeStructure(*Object)
*Object = 0
Else
__cnt = ArraySize(*Object\System\Self\Initialize())
For __index = 1 To __cnt
*Object\System\Self\Initialize(__index)\Invoke(*Object)
Next
EndIf
EndIf
ProcedureReturn *Object
EndMacro
; ---------------------------------------------------------------------------
; Macros for init object (advanced)
Macro AllocateObject(Object, sProperty)
Object = AllocateStructure(sProperty)
If Object
Object\System\vTable = Class\Entry(#PB_Compiler_Module)\vTable()
Object\System\Self = @Class\Entry(#PB_Compiler_Module)
Object\System\RefCount = 0
Object\System\Mutex = CreateMutex()
If Not Object\System\Mutex
Debug "Error: Class '" + #PB_Compiler_Module + "' create mutex"
FreeStructure(Object)
Object = 0
EndIf
EndIf
EndMacro
Macro InitializeObject(Object, sProperty=)
If Object
Protected __cnt, __index
__cnt = ArraySize(Object\System\Self\Initialize())
For __index = 1 To __cnt
Object\System\Self\Initialize(__index)\Invoke(Object)
Next
EndIf
EndMacro
; ---------------------------------------------------------------------------
Macro LockObject(This)
LockMutex(This\System\Mutex)
EndMacro
Macro UnlockObject(This)
UnlockMutex(This\System\Mutex)
EndMacro
; ---------------------------------------------------------------------------
EndDeclareModule
Module BaseClass
EnableExplicit
; ---------------------------------------------------------------------------
Procedure AddClass(ClassName.s, ClassExtends.s, JSValue, Size)
Protected r1, RuntimeName.s, MethodeName.s, MethodeID, *addr, index
; Create new class
If FindMapElement(Class\Entry(), ClassExtends)
r1 = AddMapElement(Class\Entry(), ClassName)
Else
DebuggerError("Error BaseClass: Class '" + ClassName + "' - Extends class '" + ClassExtends + "' not exists")
End -1
EndIf
If r1 = 0
DebuggerError("Error BaseClass: Class '" + ClassName + "' - Out of memory")
End -1
EndIf
; Copy extends class and resize vTable
CopyStructure(Class\Entry(ClassExtends), Class\Entry(ClassName), udtClass)
ReDim Class\Entry(ClassName)\vTable(Size)
; Set interface methodes
If ExamineJSONMembers(JSValue)
While NextJSONMember(JSValue)
MethodeName = JSONMemberKey(JSValue)
MethodeID = GetJSONInteger(JSONMemberValue(JSValue))
RuntimeName = ClassName + "::" + MethodeName + "()"
*addr = GetRuntimeInteger(RuntimeName)
If *addr
Class\Entry()\vTable(MethodeID) = *addr
Else
If Class\Entry()\vTable(MethodeID) = 0
DebuggerError("Error BaseClass: Class '" + ClassName + "' - Missing methode '" + MethodeName + "()'")
End -1
EndIf
EndIf
Wend
EndIf
; Added methode Initialize object
RuntimeName = ClassName + "::Initialize()"
*addr = GetRuntimeInteger(RuntimeName)
If *addr
index = ArraySize(Class\Entry()\Initialize()) + 1
ReDim Class\Entry()\Initialize(index)
Class\Entry()\Initialize(index)\Invoke = *addr
EndIf
; Added methode dispose object
RuntimeName = ClassName + "::Dispose()"
*addr = GetRuntimeInteger(RuntimeName)
If *addr
index = ArraySize(Class\Entry()\Dispose()) + 1
ReDim Class\Entry()\Dispose(index)
Class\Entry()\Dispose(index)\Invoke = *addr
EndIf
ProcedureReturn r1
EndProcedure
; ---------------------------------------------------------------------------
Procedure QueryInterface(*This.sBaseClass, *riid, *addr)
ProcedureReturn $80004002 ; (#E_NOINTERFACE)
EndProcedure
; ---------------------------------------------------------------------------
Procedure AddRef(*This.sBaseClass)
LockMutex(*This\System\Mutex)
*This\System\RefCount + 1
UnlockMutex(*This\System\Mutex)
ProcedureReturn *This\System\RefCount
EndProcedure
; ---------------------------------------------------------------------------
Procedure Release(*This.sBaseClass)
Protected index, cnt
With *This\System
LockMutex(*This\System\Mutex)
If \RefCount = 0
cnt = ArraySize(\Self\Dispose())
For index = cnt To 1 Step -1
\Self\Dispose(index)\Invoke(*This)
Next
FreeMutex(*This\System\Mutex)
FreeStructure(*This)
ProcedureReturn 0
Else
\RefCount - 1
EndIf
UnlockMutex(*This\System\Mutex)
ProcedureReturn \RefCount
EndWith
EndProcedure
; ---------------------------------------------------------------------------
Procedure InitBaseClass()
AddMapElement(Class\Entry(), "BaseClass")
With Class\Entry("BaseClass")
\vTable(0) = @QueryInterface()
\vTable(1) = @AddRef()
\vTable(2) = @Release()
EndWith
EndProcedure : InitBaseClass()
; ---------------------------------------------------------------------------
EndModule
;- End Module BaseClass (JS)
; ***************************************************************************************