With inheritance, the situation is somewhat different.
Here the virtual table must be managed in a class. A map is a good place to store the class name and the virtual table.
The base class must always have the pointer to the virtual table as the first entry. This can then be inherited. Even multiple times.
When creating a new class with inheritance, the methods of the virtual table are then copied to the new table.
This allows you to overwrite the inherited methods without changing the original methods.
Update v1.05
Code: Select all
;-TOP
; Comment : OOP Interface Example With Inheritance
; Author : mk-soft
; Version : v1.05
; Create : 18.12.2024
; Update : 22.12.2024
; Link : https://www.purebasic.fr/english/viewtopic.php?t=85960
EnableExplicit
DeclareModule ClassCommon
Structure sMethod
*Index[0]
EndStructure
Structure sClass
ClassName.s ; Name of class
Size.i ; Size of interface in bytes
*Methods.sMethod ; Pointer to method table
EndStructure
Declare NewClass(ClassName.s, SizeOfInterface, ClassExtends.s = "")
Macro SetMethod(Method, Class=*Class, iMethods=iMethods)
Class\Methods\Index[OffsetOf(iMethods\Method()) / SizeOf(Integer)] = @Method()
EndMacro
EndDeclareModule
Module ClassCommon
EnableExplicit
Global NewMap Classes.sClass()
Procedure NewClass(ClassName.s, SizeOfInterface, ClassExtends.s = "")
Protected *Class.sClass, *ClassExtends.sClass
With Classes()
; Check class is always exists
If FindMapElement(Classes(), ClassName)
Debug "ClassCommon Error: Class always exists: " + ClassName
ProcedureReturn 0
EndIf
; If use extends, check exists extends class
If ClassExtends
*ClassExtends = FindMapElement(Classes(), ClassExtends)
If Not *ClassExtends
Debug "ClassCommon Error: Extends class not exists: " + ClassExtends
ProcedureReturn 0
EndIf
EndIf
; Create new class
*Class = AddMapElement(Classes(), ClassName)
If *Class
; Store class name
\ClassName = ClassName
; Store byte size of method table
\Size = SizeOfInterface
; Allocate memory for method table
\Methods = AllocateMemory(SizeOfInterface)
If Not \Methods
Debug "ClassCommon Error: Out Of Memory:" + ClassName
DeleteMapElement(Classes())
ProcedureReturn 0
EndIf
; If use extends, copy extends methods to new method table
If *ClassExtends
CopyMemory(*ClassExtends\Methods, *Class\Methods, *ClassExtends\Size)
EndIf
ProcedureReturn *Class
Else
Debug "ClassCommon Error: Out Of Memory:" + ClassName
ProcedureReturn 0
EndIf
EndWith
EndProcedure
EndModule
; ****
CompilerIf #PB_Compiler_IsMainFile
;- *** Example ***
;- Userbase
DeclareModule UserBase
Interface iUserBase
Destroy()
GetFirstName.s()
SetFirstName(Name.s)
GetLastName.s()
SetLastName(Name.s)
GetLabel.s()
EndInterface
Structure sUserBase
*vTable ; Allways first entry
FirstName.s
LastName.s
EndStructure
Declare New(FirstName.s = "", LastName.s = "")
EndDeclareModule
Module UserBase
EnableExplicit
UseModule ClassCommon
; Static pointer to *class
Global *Class.sClass
; Macro Interface Helper
Interface iMethods Extends iUserBase
EndInterface
Procedure New(FirstName.s = "", LastName.s = "")
Protected *This.sUserBase
If *Class
*This = AllocateStructure(sUserBase)
If *This
*This\vTable = *Class\Methods
*This\FirstName = FirstName
*This\LastName = LastName
EndIf
EndIf
ProcedureReturn *This
EndProcedure
Procedure Destroy(*This.sUserBase)
Debug *Class\ClassName + ": Destroy was called"
; Free all resources here:
; - Do not forget to delete fonts, images, files, etc.
FreeStructure(*This)
EndProcedure
Procedure.s GetFirstName(*This.sUserBase)
With *This
ProcedureReturn \FirstName
EndWith
EndProcedure
Procedure SetFirstName(*This.sUserBase, Name.s)
With *This
\FirstName = Name
EndWith
EndProcedure
Procedure.s GetLastName(*This.sUserBase)
With *This
ProcedureReturn \LastName
EndWith
EndProcedure
Procedure SetLastName(*This.sUserBase, Name.s)
With *This
\LastName = Name
EndWith
EndProcedure
Procedure.s GetLabel(*This.sUserBase)
Protected r1
With *This
ProcedureReturn \LastName + ", " + \FirstName
EndWith
EndProcedure
Procedure InitClass()
; Create new class
*Class = NewClass("UserBase", SizeOf(iUserBase))
If *Class
; Set method with macro
SetMethod(Destroy) ; Macro -> *Class\Methods\Index[OffsetOf(iMethods\Destroy()) / SizeOf(Integer)] = @Destroy()
SetMethod(GetFirstName)
SetMethod(SetFirstName)
SetMethod(GetLastName)
SetMethod(SetLastName)
SetMethod(GetLabel)
Else
Debug "Error: NewClass UserBase"
CallDebugger
EndIf
EndProcedure : InitClass()
EndModule
;- UserAddress
DeclareModule UserAddress
Interface iUserAddress Extends UserBase::iUserBase
SetAddress(Country.s, City.s, Street.s)
GetCountry.s()
GetCity.s()
GetStreet.s()
EndInterface
Structure sUserAddress Extends UserBase::sUserBase
Country.s
City.s
Street.s
EndStructure
Declare New(FirstName.s = "", LastName.s = "")
EndDeclareModule
Module UserAddress
EnableExplicit
UseModule ClassCommon
; Static pointer to *class
Global *Class.sClass
; Macro Interface Helper
Interface iMethods Extends iUserAddress
EndInterface
Procedure New(FirstName.s = "", LastName.s = "")
Protected *This.sUserAddress
If *Class
*This = AllocateStructure(sUserAddress)
If *This
*This\vTable = *Class\Methods
*This\FirstName = FirstName
*This\LastName = LastName
EndIf
EndIf
ProcedureReturn *This
EndProcedure
Procedure Destroy(*This.sUserAddress)
Debug *Class\ClassName + ": Destroy was called"
; Free all resources here:
; - Do not forget to delete fonts, images, files, etc.
FreeStructure(*This)
EndProcedure
Procedure SetAddress(*This.sUserAddress, Country.s, City.s, Street.s)
With *This
\Country = Country
\City = City
\Street = Street
EndWith
EndProcedure
Procedure.s GetCountry(*This.sUserAddress)
With *This
ProcedureReturn \Country
EndWith
EndProcedure
Procedure.s GetCity(*This.sUserAddress)
With *This
ProcedureReturn \City
EndWith
EndProcedure
Procedure.s GetStreet(*This.sUserAddress)
With *This
ProcedureReturn \Street
EndWith
EndProcedure
Procedure.s GetLabel(*This.sUserAddress)
Protected r1.s
With *This
r1 = "ADDRESS"
r1 + #LF$ + \LastName + ", " + \FirstName
r1 + #LF$ + \Street
r1 + #LF$ + \City
r1 + #LF$ + \Country
ProcedureReturn r1
EndWith
EndProcedure
Procedure InitClass()
; Create new class
*Class = NewClass("UserAddress", SizeOf(iUseraddress), "UserBase")
If *Class
; Set method with macro
SetMethod(Destroy) ; Macro -> *Class\Methods\Index[OffsetOf(iMethods\Destroy()) / SizeOf(Integer)] = @Destroy()
SetMethod(SetAddress)
SetMethod(GetCountry)
SetMethod(GetCity)
SetMethod(GetStreet)
; Overwrite method with macro
SetMethod(Destroy)
SetMethod(GetLabel)
Else
Debug "Error: NewClass UserAddress"
CallDebugger
EndIf
EndProcedure : InitClass()
EndModule
;-Test
Define *Obj1.UserBase::iUserBase = UserBase::New("Tom")
If *Obj1
*Obj1\SetLastName("Clancy")
Debug "" + *Obj1\GetLastName()
Debug *Obj1\GetLabel()
*Obj1\Destroy() : *Obj1 = 0
EndIf
Debug "----"
Define *Obj2.UserAddress::iUserAddress = UserAddress::New("Tom", "Unknown")
If *Obj2
*Obj2\SetAddress("German", "Unknown City", "Unknown Street")
Debug *Obj2\GetLabel()
*Obj2\Destroy() : *Obj2 = 0
EndIf
CompilerEndIf
