But firmly point this is also to solve without pre-compiler.
My goal is to walk without many new keyname a module in a object. I think I have succeeded.
The module BaseClass causes you with all the necessary components:
- Creating a new class with a "BaseClass" or an inherited class.
- The basic function Object\Release () and Object\AddRef ().
- Declaration of call environment "Initalize" and "Dispose", even when inheritance.
- Declaration of methods and overwrite inheritance methods.
There are few rules:
- The structure of the variables (Properties) must be defined with extends structure of "sBaseClass" or extends structure of "inheritance class".
- The interface for the methods must be defined with extends interface "iBaseClass" or extends interface of "inheritance class".
- The inheriting class must have a BaseClass.
Examples with BaseClassSmall:
- Own Flat Gadgets
BaseClass small version
Update v1.05
- Now compatible to extended version
+ Macro AsNewMethode, Macro CloneObject
Update v1.07
- Bugfix FreeMutex
Update v1.09r4
- Map of classes encapsulated
- Check of the new class in procedure 'AddClass(...)' extended
- Change Macros because map of classes not longer global
- Change CheckInterface. Parameter is not longer required
- Name of classes not longer case sensitive (no case)
Update v1.10
- Change ClassName Management.
The module name is no longer the internal class name. This means that the interface name is now specified for inheritance, and not the module name.
Is therefore more logical.
Update v1.13
- Optimize CheckInterface
Update v1.14
- Change name of Macro 'dq' to '_dq_'
Update v1.16
- Update Method QueryInterface with default result for 'IUnknown'
- Optimize code
Update v1.17
- Added Pointer for Private Attributes (Object)
- Added Pointer for Package Attributes (Classes)
- Added new Macro InitPackage()
- Rename internal BaseSystem structure name Self.udtClass to Class.udtClass
Update v1.21
- Removed Private Macros and Pointer
Modul_BaseClassSmall.pb
Code: Select all
;-Begin Module BaseClass Small Version
; Comment : Module as Object
; Author : mk-soft
; File : BaseClassSmall.pb
; Version : v1.21.1
; Created : 16.08.2017
; Updated : 07.06.2020
; Link DE : http://www.purebasic.fr/german/viewtopic.php?f=8&t=29343
; Link EN : http://www.purebasic.fr/english/viewtopic.php?f=12&t=64305
; OS : All
; ***************************************************************************************
DeclareModule BaseClass
; ---------------------------------------------------------------------------
; Internal class declaration
Prototype ProtoInvoke(*This)
Structure udtInvoke
*Invoke.ProtoInvoke
EndStructure
Structure udtClass
Array *vTable(3)
Array Initialize.udtInvoke(0)
Array Dispose.udtInvoke(0)
*Package.sPackage
EndStructure
; ---------------------------------------------------------------------------
; BaseClass declaration
Structure sBaseSystem
*vTable
*Class.udtClass
RefCount.i
Mutex.i
EndStructure
; Public Structure
Structure sBaseClass
System.sBaseSystem
EndStructure
; Public Interface
Interface iBaseClass
QueryInterface(*riid, *ppvObject)
AddRef()
Release()
EndInterface
; ---------------------------------------------------------------------------
Macro _dq_
"
EndMacro
; ---------------------------------------------------------------------------
; Added New Class
Declare AddClass(ClassInterface.s, ClassExtends.s, Size) ; Internal
Macro NewClass(ClassInterface, ClassExtends=)
; Interface helper
Interface __Interface Extends ClassInterface
EndInterface
; Internal class pointer
Global *__Class.udtClass
; Add new class
Procedure __NewClass()
*__Class = AddClass(_dq_#ClassInterface#_dq_, _dq_#ClassExtends#_dq_, SizeOf(ClassInterface) / SizeOf(integer))
EndProcedure : __NewClass()
EndMacro
; ---------------------------------------------------------------------------
; Macros for package attributes
Macro InitPackage(_Attributes_=sPackage)
Procedure __InitPackage()
*__Class\Package = AllocateStructure(_Attributes_)
EndProcedure : __InitPackage()
EndMacro
Macro GetPackage()
*__Class\Package
EndMacro
; ---------------------------------------------------------------------------
; Macro for init object (short)
Macro InitObject(sProperty)
Protected *Object.sProperty, __cnt, __index
*Object = AllocateStructure(sProperty)
If *Object
*Object\System\vTable = *__Class\vTable()
*Object\System\Class = *__Class
*Object\System\RefCount = 0
*Object\System\Mutex = CreateMutex()
__cnt = ArraySize(*Object\System\Class\Initialize())
For __index = 1 To __cnt
*Object\System\Class\Initialize(__index)\Invoke(*Object)
Next
EndIf
ProcedureReturn *Object
EndMacro
; ---------------------------------------------------------------------------
; Macros for init object (advanced)
Macro AllocateObject(Object, sProperty)
Object = AllocateStructure(sProperty)
If Object
Object\System\vTable = *__Class\vTable()
Object\System\Class = *__Class
Object\System\RefCount = 0
Object\System\Mutex = CreateMutex()
EndIf
EndMacro
Macro InitializeObject(Object)
If Object
Protected __cnt, __index
__cnt = ArraySize(Object\System\Class\Initialize())
For __index = 1 To __cnt
Object\System\Class\Initialize(__index)\Invoke(Object)
Next
EndIf
EndMacro
; ---------------------------------------------------------------------------
; Macros for clone object
Macro CloneObject(This, Clone, sProperty)
Clone = AllocateStructure(sProperty)
If Clone
CopyStructure(This, Clone, sProperty)
Clone\System\RefCount = 0
Clone\System\Mutex = CreateMutex()
EndIf
EndMacro
; ---------------------------------------------------------------------------
Macro LockObject(This)
LockMutex(This\System\Mutex)
EndMacro
Macro UnlockObject(This)
UnlockMutex(This\System\Mutex)
EndMacro
; ---------------------------------------------------------------------------
; Macros to defined Initialize, Dispose, Methods
; Add Procedure as Initialize Object
Macro AsInitializeObject(Name)
Procedure __AddInitializeObject#Name()
Protected index
index = ArraySize(*__Class\Initialize()) + 1
ReDim *__Class\Initialize(index)
*__Class\Initialize(index)\Invoke = @Name()
EndProcedure : __AddInitializeObject#Name()
EndMacro
; Add Procedure as Dispose Object
Macro AsDisposeObject(Name)
Procedure __AddDisposeObject#Name()
Protected index
index = ArraySize(*__Class\Dispose()) + 1
ReDim *__Class\Dispose(index)
*__Class\Dispose(index)\Invoke = @Name()
EndProcedure : __AddDisposeObject#Name()
EndMacro
; Add Procedure as Methode or Overwrite inheritance methode
Macro AsMethode(Name)
Procedure __AddMethode#Name()
*__Class\vTable(OffsetOf(__Interface\Name()) / SizeOf(integer)) = @Name()
EndProcedure : __AddMethode#Name()
EndMacro
Macro AsNewMethode(Name)
AsMethode(Name)
EndMacro
; ---------------------------------------------------------------------------
; Debugger functions
Macro CheckInterface()
CompilerIf #PB_Compiler_Debugger
Procedure __CheckInterface()
Protected *xml, *node, ErrorCount
*xml = CreateXML(#PB_Any)
If *xml
*node = InsertXMLStructure(RootXMLNode(*xml), *__Class\vTable(), __Interface)
*node = ChildXMLNode(*node)
Repeat
If Not *node
Break
EndIf
If GetXMLNodeText(*node) = "0"
ErrorCount + 1
Debug "Module " + #PB_Compiler_Module + ": Error Interface - Missing Methode '" + GetXMLNodeName(*node) + "()'"
EndIf
*node = NextXMLNode(*node)
ForEver
FreeXML(*xml)
If ErrorCount
Debug "Module " + #PB_Compiler_Module + ": Error Count " + ErrorCount
CallDebugger
EndIf
EndIf
EndProcedure : __CheckInterFace()
CompilerEndIf
EndMacro
; ---------------------------------------------------------------------------
EndDeclareModule
Module BaseClass
EnableExplicit
; ---------------------------------------------------------------------------
Procedure QueryInterface(*This.sBaseClass, *riid, *ppvObject.integer)
If *ppvObject = 0 Or *riid = 0
ProcedureReturn $80070057 ; #E_INVALIDARG
EndIf
If CompareMemory(*riid, ?IID_IUnknown, 16)
LockMutex(*This\System\Mutex)
*ppvObject\i = *This
*This\System\RefCount + 1
UnlockMutex(*This\System\Mutex)
ProcedureReturn 0 ; #S_OK
Else
*ppvObject\i = 0
ProcedureReturn $80004002 ; #E_NOINTERFACE
EndIf
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(\Class\Dispose())
For index = cnt To 1 Step -1
\Class\Dispose(index)\Invoke(*This)
Next
FreeMutex(\Mutex)
FreeStructure(*This)
ProcedureReturn 0
Else
\RefCount - 1
EndIf
UnlockMutex(*This\System\Mutex)
ProcedureReturn \RefCount
EndWith
EndProcedure
; ---------------------------------------------------------------------------
Procedure AddClass(ClassInterface.s, ClassExtends.s, Size)
Static NewMap Classes.udtClass()
Protected *class.udtClass, *extends.udtClass, sClassInterface.s, sClassExtends.s
sClassInterface = LCase(ClassInterface)
sClassExtends = LCase(ClassExtends)
CompilerIf #PB_Compiler_Debugger
If FindMapElement(Classes(), sClassInterface)
Debug "Error: Class '" + ClassInterface + "' already exists!"
CallDebugger
End -1
EndIf
If Bool(sClassExtends)
*extends = FindMapElement(Classes(), sClassExtends)
If Not *extends
Debug "Error: Extends Class '" + ClassExtends + "' not exists!"
CallDebugger
End -1
EndIf
EndIf
CompilerEndIf
*class = AddMapElement(Classes(), sClassInterface)
If *class
If Bool(sClassExtends)
*extends = FindMapElement(Classes(), sClassExtends)
CopyStructure(*extends, *class, udtClass)
ReDim *class\vTable(Size)
ProcedureReturn *class
Else
ReDim *class\vTable(Size)
*class\vTable(0) = @QueryInterface()
*class\vTable(1) = @AddRef()
*class\vTable(2) = @Release()
ProcedureReturn *class
EndIf
Else
Debug "Error: Class '" + ClassInterface + "' Out Of Memory!"
CallDebugger
End -1
EndIf
EndProcedure
; ---------------------------------------------------------------------------
DataSection
IID_IUnknown: ; {00000000-0000-0000-C000-000000000046}
Data.l $00000000
Data.w $0000, $0000
Data.b $C0, $00, $00, $00, $00, $00, $00, $46
EndDataSection
EndModule
;- End Module BaseClass
; ***************************************************************************************