The module BaseClassSmall is needed to create the objects in a simplified way. Show Link OOP-BaseClass
Do not use the PB function SetGadgetData. This is needed for fast access to the object for event processing.
Use the methods of object SetUserData and GetUserData for own data
- ButtonColorGadget
- TextBoxGadget
- ClockGadget
- NumberGadget
- SwitchGadget
- GaugeGadget
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
; ***************************************************************************************