Module BaseClass (Module as Object)

Share your advanced PureBasic knowledge/code with the community.
User avatar
mk-soft
Addict
Addict
Posts: 3110
Joined: Fri May 12, 2006 6:51 pm
Location: Germany

Module BaseClass (Module as Object)

Post by mk-soft »

Wanted to rewrite my OOP precompiler.
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

; ***************************************************************************************
Last edited by mk-soft on Sun Jun 07, 2020 12:56 pm, edited 70 times in total.
My Projects ThreadToGUI / OOP-BaseClass / OOP-BaseClassDispatch / EventDesigner V3
PB v3.30 / v5.70 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace
User avatar
mk-soft
Addict
Addict
Posts: 3110
Joined: Fri May 12, 2006 6:51 pm
Location: Germany

Re: Module BaseClass (OOP)

Post by mk-soft »

Description of the Module BaseClassSmall

Update v1.17

Preface

Purebasic is a procedure-oriented programming language, but supports the creation of object-oriented programs.

My goal is not to create an object oriented language for Purebasic, but to simplify the creation of own objects.
For full support of object oriented programming there are other programming languages available.

For some tasks it is advantageous to create them object-oriented.
Here the same effort applies with Purebasic as for example with "C".
Everything has to be defined and created by yourself. The rules for objects and the functions and methods must be kept.

1. The first entry in the object is always the pointer to the table with the methods.
2. The first parameter of the methods is always the pointer to the own object.

Classes

To create an object you need a class.
A class defines the data type of an object.
This defines the table of methods (functions) and attributes (variables).

Constructors and Destructors

Constructors are functions that bring the object into a defined state when it is created and, if necessary, create the required resources.
Destructors are functions that release resources when the object is released.

Constructors can also have parameters, but are not supported by all programming languages.
Destructors have no parameters.

Constructors and destructors have no return value.

Method Super

To inherit a class, you need a super function that passes the methods and attributes to the subclass.
This also includes the constructors and destructors of the class.
Multiple inheritance can therefore result in multiple constructors and destructors that must be called in the correct order.

Interface

Interfaces define the interface which methods exist or must exist.


What Purebasic supports

Purebasic supports interfaces and attributes, as well as inheritance of interfaces and attributes.

- Interface SubClass Extends BaseClass
- Structure SubAttribute Extends BaseAttribute

Call the methods from the interfaces.


What does the module BaseClassSmall support

Creating and managing classes : NewClass(InterfaceName, ...)
- Create tables for methods, constructors, and destructors.
* Note: Contructors with parameters are not supported.
- The method Super, automated.

The base interface with the methods of type IUnknown
- QueryInterface(*riid, *addr)
- AddRef()
- Release()

The base attributes with the structure
- System\vTable : pointer to the method table.
- System\Class : Pointer to the class with the tables of the methods, constructors, destructors and package attributes.
- System\RefCount : Counter to protect the object.
- System\Mutex : Mutex for asynchronous processing of the object.

Assignment of the contructor : Macro AsInitializeObject(Name of the procedure)
Assignment of the destructor : Macro AsDisposeObject(Name of the procedure)

Initialize of package attributes : Macro InitPackage()

Assignment of methods : Macro AsMethod(Name of method and procedure)
Overwrite methods : Macro AsNewMethod(Name of method and procedure)

Creating the object : Macro InitObject or AllocateObject/InitializeObject for the procedure to create the object
- Creating the memory for the object.
- Assignment of the Virtual Table and Basic Attributes.
- Calling the constructors in the correct order.

Method QueryInterface : Object\QueryInterface(*riid, *addr)
- Default Method with result of query IUnknown.
* The method can be overwritten if necessary.

Method AddRef : Object\AddRef()
- Increases the counter of the object.
* This is deduced with Release object. The object is only released after it has been reset to zero.
! Do not overwrite !

Method Release : Object\Release()
- Calling the destructors in the correct order.
- Releasing the memory.
! Do not overwrite !

Checking the Class in Debugger Mode
- Call CheckInterface() at the end of the module.
Last edited by mk-soft on Wed Jun 17, 2020 4:10 pm, edited 24 times in total.
My Projects ThreadToGUI / OOP-BaseClass / OOP-BaseClassDispatch / EventDesigner V3
PB v3.30 / v5.70 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace
User avatar
mk-soft
Addict
Addict
Posts: 3110
Joined: Fri May 12, 2006 6:51 pm
Location: Germany

Re: Module BaseClass (OOP)

Post by mk-soft »

Example 3 (Update)

Code: Select all

; Example 3 v1.13

IncludeFile "Modul_BaseClassSmall.pb"

; *******************************************************************************

DeclareModule User
  
  UseModule BaseClass
  
  Structure sUser Extends sBaseClass
    firstname.s
    lastname.s
  EndStructure
  
  Interface iUser Extends iBaseClass
    SetName(FirstName.s, LastName.s)
    GetName.s()
    GetFirstName.s()
    GetLastName.s()
    Clone()
  EndInterface
  
  UnuseModule BaseClass
  
  Declare.i New()
  
EndDeclareModule

Module User
  
  UseModule BaseClass
  
  NewClass(iUser)
  
  ; ---------------------------------------------------------------------------
  
  Procedure Init(*this.sUser)
    *this\firstname = "no name"
    *this\lastname = "no name"
    Debug "Initalize Object Class User " + *this
  EndProcedure : AsInitializeObject(Init)
  
  ; ---------------------------------------------------------------------------
  
  Procedure Dispose(*this.sUser)
    Debug "Dispose Object Class User " + *this
  EndProcedure : AsDisposeObject(Dispose)
  
  ; ---------------------------------------------------------------------------
  
  Procedure SetName(*this.sUser, FirstName.s, LastName.s)
    With *this
      \firstname = FirstName
      \lastname = LastName
    EndWith
  EndProcedure : AsMethode(SetName)
  
  ; ---------------------------------------------------------------------------
  
  Procedure.s GetName(*this.sUser)
    With *this
      ProcedureReturn \lastname + ";" + \firstname
    EndWith
  EndProcedure : AsMethode(GetName)
  
  ; ---------------------------------------------------------------------------
  
  Procedure.s GetFirstName(*this.sUser)
    ProcedureReturn *this\firstname
  EndProcedure : AsMethode(GetFirstName)
  
  ; ---------------------------------------------------------------------------
  
  Procedure.s GetLastName(*this.sUser)
    ProcedureReturn *this\lastname
  EndProcedure : AsMethode(GetLastName)
  
  ; ---------------------------------------------------------------------------
  
  Procedure Clone(*this.sUser)
    Protected *clone.sUser
    CloneObject(*this, *clone, sUser) 
    ProcedureReturn *clone
  EndProcedure : AsMethode(Clone)
  
  ; ---------------------------------------------------------------------------
  
  Procedure New()
    InitObject(sUser)
  EndProcedure
  
  ; ---------------------------------------------------------------------------
  
  CheckInterface()
  
EndModule

; *******************************************************************************

DeclareModule Adress
  
  UseModule User
  
  Structure sAdress Extends sUser
    street.s
    postal.i
    city.s
    country.s
  EndStructure
  
  Interface iAdress Extends iUser
    SetAdress(street.s, postal.i, city.s, country.s)
    GetStreet.s()
    GetPostal.i()
    GetCity.s()
    GetCountry.s()
    GetAll.s()
  EndInterface
  
  UnuseModule User
  
  Declare New()
  
EndDeclareModule

Module Adress
  
  UseModule BaseClass
  
  NewClass(iAdress, iUser)
  
  ; ---------------------------------------------------------------------------
  
  Procedure Init(*this.sAdress)
    Debug "Initalize Object Class Adress " + *this
  EndProcedure : AsInitializeObject(Init)
  
  ; ---------------------------------------------------------------------------
  
  Procedure Dispose(*this.sAdress)
    Debug "Dispose Object Class Adress " + *this
  EndProcedure : AsDisposeObject(Dispose)
  
  ; ---------------------------------------------------------------------------
  
  Procedure SetAdress(*this.sAdress, street.s, postal.i, city.s, country.s)
    With *this
      \street = street
      \postal = postal
      \city = city
      \country = country
    EndWith
  EndProcedure : AsMethode(SetAdress)
  
  ; ---------------------------------------------------------------------------
  
  Procedure.s GetStreet(*this.sAdress)
    With *this
      ProcedureReturn \street
    EndWith
  EndProcedure : AsMethode(GetStreet)
  
  ; ---------------------------------------------------------------------------
  
  Procedure GetPostal(*this.sAdress)
    With *this
      ProcedureReturn \postal
    EndWith
  EndProcedure : AsMethode(GetPostal)
  
  ; ---------------------------------------------------------------------------
  
  Procedure.s GetCity(*this.sAdress)
    With *this
      ProcedureReturn \city
    EndWith
  EndProcedure : AsMethode(GetCity)
  
  ; ---------------------------------------------------------------------------
  
  Procedure.s GetCountry(*this.sAdress)
    With *this
      ProcedureReturn \country
    EndWith
  EndProcedure : AsMethode(GetCountry)
  
  ; ---------------------------------------------------------------------------
  
  Procedure.s GetAll(*this.sAdress)
    Protected r1.s
    With *this
      r1 = \LastName + ";"
      r1 + \FirstName + ";"
      r1 + \street + ";"
      r1 + \city + ";"
      r1 + \postal + ";"
      r1 + \country
      ProcedureReturn r1
    EndWith
  EndProcedure : AsMethode(GetAll)
  
  ; ---------------------------------------------------------------------------
  
  Procedure Clone(*this.sAdress)
    Protected *clone.sAdress
    CloneObject(*this, *clone, sAdress)
    ProcedureReturn *clone
  EndProcedure : AsNewMethode(Clone)
  
  ; ---------------------------------------------------------------------------
  
  Procedure New()
    InitObject(sAdress)
  EndProcedure
  
  ; ---------------------------------------------------------------------------
  
  CheckInterface()
  
EndModule

; *******************************************************************************

;- Test

Define.Adress::iAdress *user, *user2

*user=Adress::New()
Debug *user\GetName()
*user\SetName("Toto", "Buddy")
*user\AddRef()
Debug *user\GetName()
*user2 = *user\Clone()
*user2\SetAdress("My Street", 12345, "My City", "My Country")
Debug *user2\GetAll()

Debug *user\Release()
Debug *user\Release()
Debug *user2\Release()
Last edited by mk-soft on Sat May 04, 2019 1:50 pm, edited 8 times in total.
My Projects ThreadToGUI / OOP-BaseClass / OOP-BaseClassDispatch / EventDesigner V3
PB v3.30 / v5.70 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace
User avatar
mk-soft
Addict
Addict
Posts: 3110
Joined: Fri May 12, 2006 6:51 pm
Location: Germany

Re: Module BaseClass (OOP)

Post by mk-soft »

Example 6 Update

Update

Code: Select all

;-TOP

; Example 6 v1.13

IncludeFile "Modul_BaseClassSmall.pb"

; *******************************************************************************

DeclareModule DataSet
  
  UseModule BaseClass
  
  ; Properties
  Structure sDataSet Extends sBaseClass
    *pData
    Count.i
    Array *pStr(0)
  EndStructure
  
  ; Methods
  Interface iDataSet Extends iBaseClass
    Get.s(index)
    Count()
  EndInterface
  
  UnuseModule BaseClass
  
  ; New Object
  Declare New(*pData)
  
EndDeclareModule

Module DataSet
  
  UseModule BaseClass
  
  NewClass(iDataSet)
  
  ; ---------------------------------------------------------------------------
  
  Procedure.s Get(*this.sDataSet, index)
    With *this
      If index < \Count
        ProcedureReturn PeekS(\pStr(index))
      Else
        ProcedureReturn ""
      EndIf
    EndWith
  EndProcedure : AsMethode(Get)
  
  ; ---------------------------------------------------------------------------
  
  Procedure Count(*this.sDataSet)
    ProcedureReturn *this\Count
  EndProcedure : AsMethode(Count)
  
  ; ---------------------------------------------------------------------------
  
  Procedure Init(*this.sDataSet)
    Protected *pos, len, index
    With *this
      *pos = \pData
      Repeat
        len = MemoryStringLength(*pos)
        If len
          \Count + 1
          *pos + len * SizeOf(character) + SizeOf(character)
        Else
          Break
        EndIf
      ForEver
      Dim \pStr(\Count)
      *pos = \pData
      Repeat
        len = MemoryStringLength(*pos)
        If len
          \pStr(index) = *pos
          index + 1
          *pos + len * SizeOf(character) + SizeOf(character)
        Else
          Break
        EndIf
      ForEver
      
    EndWith
    
  EndProcedure : AsInitializeObject(Init)
  
  ; ---------------------------------------------------------------------------
  
  Procedure New(*pData)
    
    Protected *obj.sDataSet
    
    AllocateObject(*obj, sDataSet)
    If *obj
      *obj\pData = *pData
    EndIf
    InitializeObject(*obj)
    
    ProcedureReturn *obj
    
  EndProcedure
  
  ; ---------------------------------------------------------------------------
  
  CheckInterface()
  
EndModule

; *******************************************************************************

;- Test

EnableExplicit

Macro Object(ObjectName, ObjectType)
  ObjectName.ObjectType#::i#ObjectType
EndMacro

;BaseClass::ShowClasses()

Define.DataSet::iDataSet *set1, *set2

Define i

Debug "Data 1"
*set1 = DataSet::New(?DataSet1)
For i = 0 To *set1\Count() - 1
  Debug *set1\Get(i)
Next

Debug "----------------"
Debug "Data 2"
*set2 = DataSet::New(?DataSet2)
For i = 0 To *set2\Count() - 1
  Debug *set2\Get(i)
Next

DataSection
  DataSet1:
  Data.s "Sontag"
  Data.s "Montag"
  Data.s "Dienstag"
  Data.s "Mittwoch"
  Data.s "Donnerstag"
  Data.s "Freitag"
  Data.s "Samstag"
  Data.i 0
  
  DataSet2:
  Data.s "Januar"
  Data.s "Februar"
  Data.s "März"
  Data.s "April"
  Data.s "Mai"
  Data.s "Juni"
  Data.s "Juli"
  Data.s "August"
  Data.s "September"
  Data.s "Oktober"
  Data.s "November"
  Data.s "Dezember"
  Data.i 0
EndDataSection
Last edited by mk-soft on Sat May 04, 2019 1:51 pm, edited 6 times in total.
My Projects ThreadToGUI / OOP-BaseClass / OOP-BaseClassDispatch / EventDesigner V3
PB v3.30 / v5.70 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace
User avatar
mk-soft
Addict
Addict
Posts: 3110
Joined: Fri May 12, 2006 6:51 pm
Location: Germany

Re: Module BaseClass (Module as Object)

Post by mk-soft »

Update v1.13
- Change Macro InitObject for small code
- Added Macros AllocateObject and InitalizeObject for new object with parameters

Examples updated...
My Projects ThreadToGUI / OOP-BaseClass / OOP-BaseClassDispatch / EventDesigner V3
PB v3.30 / v5.70 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace
User avatar
mk-soft
Addict
Addict
Posts: 3110
Joined: Fri May 12, 2006 6:51 pm
Location: Germany

Re: Module BaseClass (Module as Object)

Post by mk-soft »

Update v1.15
* Added debugger functions
- ShowInterface(...)
- CheckInterface(...)

:wink:
Last edited by mk-soft on Mon Aug 15, 2016 10:10 pm, edited 1 time in total.
My Projects ThreadToGUI / OOP-BaseClass / OOP-BaseClassDispatch / EventDesigner V3
PB v3.30 / v5.70 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace
User avatar
mk-soft
Addict
Addict
Posts: 3110
Joined: Fri May 12, 2006 6:51 pm
Location: Germany

Re: Module BaseClass (Module as Object)

Post by mk-soft »

Update v1.16
- optimize code
- added debugging info

GT :wink:
My Projects ThreadToGUI / OOP-BaseClass / OOP-BaseClassDispatch / EventDesigner V3
PB v3.30 / v5.70 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace
User avatar
mk-soft
Addict
Addict
Posts: 3110
Joined: Fri May 12, 2006 6:51 pm
Location: Germany

Re: Module BaseClass (Module as Object)

Post by mk-soft »

Update v1.20
-
Update v1.21
- Change NewClass(Extends=BaseClass) -> NewClass(CLassInterface, ClassExtends=BaseClass)
* First parameter now the name of interface
+ The sequence of procedures for the methods not longer the same order as they are defined in the interface.
+ Better CheckInterface

- Added debugger info ShowClasses
* Show all Interfaces

:wink:
My Projects ThreadToGUI / OOP-BaseClass / OOP-BaseClassDispatch / EventDesigner V3
PB v3.30 / v5.70 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace
User avatar
mk-soft
Addict
Addict
Posts: 3110
Joined: Fri May 12, 2006 6:51 pm
Location: Germany

Re: Module BaseClass (Module as Object)

Post by mk-soft »

Update v1.22
- Code cleaned

That is probably the smallest code to use OOP with PureBasic, without a new syntax in PureBasic to develop. :wink:
My Projects ThreadToGUI / OOP-BaseClass / OOP-BaseClassDispatch / EventDesigner V3
PB v3.30 / v5.70 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace
User avatar
mk-soft
Addict
Addict
Posts: 3110
Joined: Fri May 12, 2006 6:51 pm
Location: Germany

Re: Module BaseClass (Module as Object)

Post by mk-soft »

Update v1.23
- Safety RefCounter over Mutex
Last edited by mk-soft on Sat Feb 25, 2017 2:55 pm, edited 1 time in total.
My Projects ThreadToGUI / OOP-BaseClass / OOP-BaseClassDispatch / EventDesigner V3
PB v3.30 / v5.70 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace
User avatar
mk-soft
Addict
Addict
Posts: 3110
Joined: Fri May 12, 2006 6:51 pm
Location: Germany

Re: Module BaseClass (Module as Object)

Post by mk-soft »

Update
- Added Macro CloneObject because some things to do
- Added Check mutex
- Added Macro LockObject and UnlockObject

Code: Select all

...
Procedure Clone(*this.sUser)
    Protected *clone.sUser
    CloneObject(*this, *clone, sUser) 
    ProcedureReturn *clone
EndProcedure : AsMethode(Clone)
...  
Update

Code: Select all

;-TOP

; Example 9 v1.13

CompilerIf #PB_Compiler_Thread = 0
  CompilerError "Use compiler option theadsafe"
CompilerEndIf

IncludeFile "Modul_BaseClassSmall.pb"

DeclareModule Work

  UseModule BaseClass
  
  Structure sWork Extends sBaseClass
    Value.i
  EndStructure
  
  Interface iWork Extends iBaseClass
    Add(Value)
    Sub(Value)
  EndInterface
  
  Declare New()
  
EndDeclareModule

Module Work
  
  UseModule BaseClass
  
  NewClass(iWork)
  
  ; ---------------------------------------------------------------------------
  
  Procedure Init(*this.sWork)
    Debug "Initialize Work"
  EndProcedure : AsInitializeObject(Init)
  
  ; ---------------------------------------------------------------------------
  
  Procedure Destroy(*this.sWork)
    Debug "Dispose Work"
    Debug "Result: " + *this\Value
  EndProcedure : AsDisposeObject(Destroy)
  
  ; ---------------------------------------------------------------------------
  
  Procedure Add(*this.sWork, Value)
    Protected result
    LockObject(*this)
    *this\Value + Value
    result = *this\Value
    UnlockObject(*this)
    ProcedureReturn result
  EndProcedure : AsMethode(Add)
  
  ; ---------------------------------------------------------------------------
  
  Procedure Sub(*this.sWork, Value = 0)
    Protected result
    LockObject(*this)
    *this\Value - Value
    result = *this\Value
    UnlockObject(*this)
    ProcedureReturn result
  EndProcedure : AsMethode(Sub)
  
  ; ---------------------------------------------------------------------------
  
  Procedure New()
    InitObject(sWork) ; Mehr kommt hier nicht rein!
  EndProcedure
  
  ; ---------------------------------------------------------------------------
  
  CheckInterface()
  
EndModule

; ***************************************************************************************

;-Test AddRef

Procedure thAdd(*Object.Work::iWork)
  Protected time
  *Object\AddRef()
  Delay(1000)
  ;Debug "Start"
  For i = 1 To 10
    time = Random(200)
    *Object\Add(1)
    Delay(time)
  Next
  ;Debug "Ready."
  *Object\Release()
EndProcedure

Debug "Mainscope Create Object"
Define *Object.Work::iWork
*Object = Work::New()

mutex = CreateMutex()
Debug "Start Threads"
For i = 1 To 1000
  th = CreateThread(@thAdd(), *Object)
  Delay(5)
  If th = 0
    Debug "No Thread " + i
  EndIf
Next

Debug "Mainscope Wait..."
Repeat
  Delay(200)
  ref = *Object\AddRef()
  ref = *Object\Release()
  Debug ref
  If ref = 0
    Break
  EndIf
ForEver
Debug "Mainscope Release Object"
*Object\Release()

Debug "Ready."
Last edited by mk-soft on Sat May 04, 2019 1:53 pm, edited 5 times in total.
My Projects ThreadToGUI / OOP-BaseClass / OOP-BaseClassDispatch / EventDesigner V3
PB v3.30 / v5.70 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace
step11
New User
New User
Posts: 7
Joined: Tue May 31, 2016 7:19 am

Re: Module BaseClass (Module as Object)

Post by step11 »

Excellent code :D
If you add a QueryInterface Method,it should support IUknwn Interface?
User avatar
mk-soft
Addict
Addict
Posts: 3110
Joined: Fri May 12, 2006 6:51 pm
Location: Germany

Re: Module BaseClass (Module as Object)

Post by mk-soft »

Update v1.26
- Added QueryInterface for compatible with Interface 'IUnknown'.
-- The default result of QueryInterface is constant 'E_NoInterface' for compatibles with Linux and Mac
-- Show Example 10 to managed AsNewMethode 'QuerInterface'
- Change RefCounter. Begin now with Zero

Helpcode to create own Uuid

Code: Select all

Procedure.s CreateUuid()
  Protected Uuid.iid, result.s, i
  UuidCreate_(Uuid.iid)
  result = "  DataSection" + #LF$
  result + "    Uuid:" + #LF$
  result + "    Data.l $" + RSet(Hex(Uuid\Data1), 8, "0") + #LF$
  result + "    Data.w $" + RSet(Hex(Uuid\Data2), 4, "0") + ", $" + RSet(Hex(Uuid\Data3), 4, "0") + #LF$
  result + "    Data.b $" + RSet(Hex(Uuid\Data4[0]), 2, "0")
  For i = 1 To 7
    result + ", $" + RSet(Hex(Uuid\Data4[i]), 2, "0")
  Next
  result + #LF$
  result + "  EndDataSection" + #LF$
  ProcedureReturn result
EndProcedure

; ***************************************************************************************

Uuid.s = CreateUuid()
SetClipboardText(Uuid)
Debug Uuid
Debug "Copied into clipboard"
My Projects ThreadToGUI / OOP-BaseClass / OOP-BaseClassDispatch / EventDesigner V3
PB v3.30 / v5.70 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace
User avatar
mk-soft
Addict
Addict
Posts: 3110
Joined: Fri May 12, 2006 6:51 pm
Location: Germany

Re: Module BaseClass (Module as Object)

Post by mk-soft »

Example 10 - Overwrite Method QueryInterface (For Windows)

Update v1.15

Code: Select all

;-TOP

; Example 10 IUnknown

IncludeFile "Modul_BaseClassSmall.pb"

DeclareModule MyObject
  
  EnableExplicit
  
  Interface iMyObject Extends BaseClass::iBaseClass
    Add(Value)
    Sub(Value)
    Result()
  EndInterface
  
  Structure sMyObject Extends BaseClass::sBaseClass
    Value.i
  EndStructure
  
  ; Own Uuid
  DataSection
    IID_IMyObject:
    Data.l $3C4855AF
    Data.w $3AC7, $4A60
    Data.b $FF, $FF, $FF, $2A, $06, $54, $54, $FF
  EndDataSection
  
  Declare New()
  
EndDeclareModule

Module MyObject
  
  EnableExplicit
  
  UseModule BaseClass
  
  NewClass(iMyObject)
  
  ; ---------------------------------------------------------------------------
  
  ; Overwrite Methode QueryInterface
  
  Procedure QueryInterface(*This.sBaseClass, *riid, *ppvObject.integer)
    Protected *new
    If *ppvObject = 0
      ProcedureReturn #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 #S_OK
    ElseIf CompareMemory(*riid, ?IID_IMyObject, SizeOf(iid))
      *new = New()
      If *new
        *ppvObject\i = *new
        ProcedureReturn #S_OK
      Else 
        ProcedureReturn #E_OUTOFMEMORY
      EndIf
    Else ; No Interface
      ProcedureReturn #E_NOINTERFACE
    EndIf
  EndProcedure : AsNewMethode(QueryInterface)
  
  ; ---------------------------------------------------------------------------
  
  Procedure Initialize(*this.sMyObject)
    Debug "Initialize Object " + Hex(*this)
  EndProcedure : AsInitializeObject(Initialize)
  
  ; ---------------------------------------------------------------------------
  
  Procedure Dispose(*this.sMyObject)
    Debug "Dispose Object " + Hex(*this)
  EndProcedure : AsDisposeObject(Dispose)
  
  ; ---------------------------------------------------------------------------
  
  Procedure Add(*this.sMyObject, Value)
    *this\Value + Value
  EndProcedure : AsMethode(Add)
  
  ; ---------------------------------------------------------------------------
  
  Procedure Sub(*this.sMyObject, Value)
    *this\Value - Value
  EndProcedure : AsMethode(Sub)
  
  ; ---------------------------------------------------------------------------
  
  Procedure Result(*this.sMyObject)
    ProcedureReturn *this\Value
  EndProcedure : AsMethode(Result)
  
  ; ---------------------------------------------------------------------------
  
  Procedure New()
    InitObject(sMyObject)
  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
  
  ; ---------------------------------------------------------------------------
  
  CheckInterface()
  
EndModule

; ***************************************************************************************

;-Test

Debug "Create Object"
Define *obj.IUnknown
*obj = MyObject::New()

Debug "--------------------------------"

r1 = *obj\QueryInterface(?IID_IUnknown, @*obj_temp)
If r1 = #S_OK
  Debug "QueryInterface IUnknown Ok: Object " + Hex(*obj)
  Debug "AddRef: " + *obj\AddRef()
  Debug "Release IUnknown: " + *obj\Release()
  Debug "Release IUnknown: " + *obj\Release()
EndIf

Debug "--------------------------------"

Define *obj2.MyObject::iMyObject
If *obj\QueryInterface(MyObject::?IID_IMyObject, @*obj2) = #S_OK
  Debug "QueryInterface IID_MyObject Ok: Object " + Hex(*obj2)
  Debug "Add 1000"
  *obj2\Add(1000)
  Debug "Sub 100"
  *obj2\Sub(100)
  Debug "Result: " + *obj2\Result()
  Debug "Relaease MyObject: " + *obj2\Release()
EndIf

Debug "--------------------------------"

If *obj\QueryInterface(?IID_IDispatch, 0) = #S_OK
  Debug "IDispatch Ok"
  Debug "Release IDispatch: " + *obj\Release()
Else
  Debug "No Interface IDispatch"
EndIf

Debug "--------------------------------"

Debug "Release Object"
Debug "Release: " + *obj\Release()

DataSection
  IID_NULL: ; {00000000-0000-0000-0000-000000000000}
  Data.l $00000000
  Data.w $0000, $0000
  Data.b $00, $00, $00, $00, $00, $00, $00, $00 
  IID_IUnknown: ; {00000000-0000-0000-C000-000000000046}'
  Data.l $00000000
  Data.w $0000, $0000 
  Data.b $C0, $00, $00 , $00 , $00, $00 , $00 , $46
  IID_IDispatch:
  Data.l $00020400
  Data.w $0000, $0000
  Data.b $C0,$00,$00,$00,$00,$00,$00,$46
  IID_IClassFactory:
  Data.l $00000001
  Data.w $0000, $0000
  Data.b $C0, $0, $0, $0, $0, $0, $0, $46
EndDataSection

:wink:
Last edited by mk-soft on Sat Feb 08, 2020 2:02 pm, edited 12 times in total.
My Projects ThreadToGUI / OOP-BaseClass / OOP-BaseClassDispatch / EventDesigner V3
PB v3.30 / v5.70 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace
User avatar
ts-soft
Always Here
Always Here
Posts: 5758
Joined: Thu Jun 24, 2004 2:44 pm
Location: Berlin - Germany

Re: Module BaseClass (Module as Object)

Post by ts-soft »

Better don't Import UUID.lib : http://www.purebasic.fr/english/viewtop ... 79#p205779

Better use Datasection, make a smaller foot :wink:
PureBasic 5.73 | SpiderBasic 2.30 | Windows 10 Pro (x64) | Linux Mint 20.1 (x64)
Old bugs good, new bugs bad! Updates are evil: might fix old bugs and introduce no new ones.
Image
Post Reply