It is currently Mon Jun 18, 2018 12:39 pm

All times are UTC + 1 hour




Post new topic Reply to topic  [ 29 posts ]  Go to page 1, 2  Next
Author Message
 Post subject: Module BaseClass (Module as Object)
PostPosted: Tue Dec 15, 2015 7:12 pm 
Offline
Addict
Addict
User avatar

Joined: Fri May 12, 2006 6:51 pm
Posts: 1253
Location: Germany
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.

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)

Modul_BaseClassSmall.pb
Code:
;-Begin Module BaseClass Small Version

; Comment : Module as Object
; Author  : mk-soft
; Version : v1.09r4
; Created : 16.08.2017
; Updated : 25.01.2018
; Link GE : 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
; License : MIT

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

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)
  EndStructure
 
  ; ---------------------------------------------------------------------------
 
  ; 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, 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(#PB_Compiler_Module, dq#ClassExtends#dq, SizeOf(ClassInterface) / SizeOf(integer))
    EndProcedure : __NewClass()
  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\Self = *__Class
      *Object\System\RefCount = 0
      *Object\System\Mutex = CreateMutex()
      __cnt = ArraySize(*Object\System\Self\Initialize())
      For __index = 1 To __cnt
        *Object\System\Self\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\Self = *__Class
      Object\System\RefCount = 0
      Object\System\Mutex = CreateMutex()
    EndIf
  EndMacro
 
  Macro InitializeObject(Object)
    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
 
  ; ---------------------------------------------------------------------------
 
  ; 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(InterfaceName=) ; Parameter is not required. Compatibility only
    CompilerIf #PB_Compiler_Debugger
      Define __IndexOfInterface
      For __IndexOfInterface = 0 To ArraySize(*__Class\vTable()) - 1
        If *__Class\vTable(__IndexOfInterface) = 0
          Debug "Error: Invalid Interface " + dq#InterfaceName#dq + " by Index " + __IndexOfInterface
          CallDebugger
        EndIf
      Next
    CompilerEndIf
  EndMacro

; ---------------------------------------------------------------------------

EndDeclareModule

Module BaseClass
 
  EnableExplicit
 
  Procedure InitBaseClass()
    Global NewMap Class.udtClass()
  EndProcedure : InitBaseClass()
   
  ; ---------------------------------------------------------------------------
 
  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 AddClass(ClassName.s, ClassExtends.s, Size)
    Protected *class.udtClass, *extends.udtClass, sClassName.s, sClassExtends.s
    sClassName = LCase(ClassName)
    sClassExtends = LCase(ClassExtends)
    CompilerIf #PB_Compiler_Debugger
      If FindMapElement(Class(), sClassName)
        Debug "Error: Class '" + ClassName + "' already exists!"
        CallDebugger
        End -1
      EndIf
      If Bool(sClassExtends)
        *extends = FindMapElement(Class(), sClassExtends)
        If Not *extends
          Debug "Error: Extends Class '" + ClassExtends + "' not exists!"
          CallDebugger
          End -1
        EndIf
      EndIf
    CompilerEndIf
    *class = AddMapElement(Class(), sClassName)
    If *class
      If Bool(sClassExtends)
        *extends = FindMapElement(Class(), 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 '" + ClassName + "' Out Of Memory!"
      CallDebugger
      End -1
    EndIf
  EndProcedure
 
  ; ---------------------------------------------------------------------------
 
EndModule

;- End Module BaseClass

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

GT :wink:

_________________
My Projects OOP-BaseClass / OOP-BaseClassDispatch / Event-Designer /
PB v3.30 / v5.60 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace


Last edited by mk-soft on Fri Jan 26, 2018 2:13 pm, edited 49 times in total.

Top
 Profile  
Reply with quote  
 Post subject: Re: Module BaseClass (OOP)
PostPosted: Tue Dec 15, 2015 7:14 pm 
Offline
Addict
Addict
User avatar

Joined: Fri May 12, 2006 6:51 pm
Posts: 1253
Location: Germany
BaseClass extended version

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 must not longer the same order as they are defined in the interface.
+ Better interface verification with CheckInterface
+ Smaller vTable
- Added debugger info ShowClasses
* Show all Interfaces

Update v1.23
- Safety RefCounter over Mutex

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

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

Update v1.27
- Bugfix BaseClass as DLL: Macros created codes as procedure encapsulated because on some Windows 7 machine crashed
- Code cleanup, some internal name changed

Update v1.28
- Changed internal class management because of the rules for creating DLLs

Update v1.29
- Dispose object work now revers
- Save LinkedList Initialize object and Dispose object over Mutex
- Added global ObjectCounter over all Classes

Update v1.31
- Spelling Correction: Initalize -> Initialize

Update v1.32
- Change internal Initialize and Dispose from list to array to avoid thread blocking
- Added small version v1.03. 'Modul_BaseClassSmall.pb'

Update v1.33
- Bugfix FreeMutex

Modul_BaseClass.pb
Code:
;-Begin Module BaseClass

; Comment : Module as Object
; Author  : mk-soft
; Version : v1.33
; Created : 13.12.2015
; Updated : 21.12.2017
; Link GE : 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
; License : MIT

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

DeclareModule BaseClass
 
  ; ---------------------------------------------------------------------------
 
  ; Internal Class Manager
 
  Prototype ProtoInvoke(*This)
 
  Structure udtInvoke
    *Invoke.ProtoInvoke
  EndStructure
 
  Structure udtClass
    Array *vTable(3)
    Map vMethodeID.i()
    Array Initialize.udtInvoke(0)
    Array Dispose.udtInvoke(0)
  EndStructure
 
  Structure udtClasses
    Map Entry.udtClass()
    ObjectCounter.i
    Mutex.i
  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, Size) ; Internal
 
  Macro NewClass(ClassInterface, ClassExtends=BaseClass)
    ; Interface helper
    Interface __Interface Extends ClassInterface
    EndInterface
    ; Add new class
    AddClass(#PB_Compiler_Module, dq#ClassExtends#dq, SizeOf(__Interface) / SizeOf(integer))
  EndMacro
 
 
  ; ---------------------------------------------------------------------------
 
  ; Macro for init object (short)
  Macro InitObject(sProperty)
    Protected *Object.sProperty, __cnt, __index
    *Object = AllocateStructure(sProperty)
    If *Object
      LockMutex(Class\Mutex)
      Class\ObjectCounter + 1
      UnlockMutex(Class\Mutex)
      *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: CreateMutex Class '" + #PB_Compiler_Module + "'!"
        FreeStructure(*Object)
        *Object = 0
        LockMutex(Class\Mutex)
        Class\ObjectCounter - 1
        UnlockMutex(Class\Mutex)
      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
      LockMutex(Class\Mutex)
      Class\ObjectCounter + 1
      UnlockMutex(Class\Mutex)
      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: CreateMutex Class '" + #PB_Compiler_Module + "'!"
        FreeStructure(Object)
        Object = 0
        LockMutex(Class\Mutex)
        Class\ObjectCounter - 1
        UnlockMutex(Class\Mutex)
      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
 
  ; ---------------------------------------------------------------------------
 
  ; 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()
      If Not Clone\System\Mutex
        Debug "Error: CreateMutex Class '" + #PB_Compiler_Module + "'!"
        FreeStructure(Clone)
        Clone = 0
      EndIf
    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
      If FindMapElement(Class\Entry(), #PB_Compiler_Module)
        index = ArraySize(Class\Entry()\Initialize()) + 1
        ReDim Class\Entry()\Initialize(index)
        Class\Entry()\Initialize(index)\Invoke = @Name()
      Else
        Debug "Error: Class is not initialized. Module '" + #PB_Compiler_Module + "'!"
        CallDebugger
      EndIf
    EndProcedure : __AddInitializeObject#Name()
  EndMacro
 
  ; Add Procedure as Dispose Object
  Macro AsDisposeObject(Name)
    Procedure __AddDisposeObject#Name()
      Protected index
      If FindMapElement(Class\Entry(), #PB_Compiler_Module)
        index = ArraySize(Class\Entry()\Dispose()) + 1
        ReDim Class\Entry()\Dispose(index)
        Class\Entry()\Dispose(index)\Invoke = @Name()
      Else
        Debug "Error: Class is not initialized. Module '" + #PB_Compiler_Module + "'!"
        CallDebugger
      EndIf
    EndProcedure : __AddDisposeObject#Name()
  EndMacro
 
  ; Add Procedure as Methode
  Macro AsMethode(Name)
    Procedure __AddMethode#Name()
      Protected MethodeID
      If FindMapElement(Class\Entry(), #PB_Compiler_Module)
        MethodeID = OffsetOf(__Interface\Name()) / SizeOf(integer)
        Class\Entry()\vTable(MethodeID) = @Name()
        Class\Entry()\vMethodeID(dq#Name#dq) = MethodeID
      Else
        Debug "Error: Class is not initialized. Module '" + #PB_Compiler_Module + "'!"
        CallDebugger
      EndIf
    EndProcedure : __AddMethode#Name()
  EndMacro
 
  ; Overwrite inheritance methode
  Macro AsNewMethode(Name)
    Procedure __OverwriteMethode#Name()
      Protected MethodeID
      If FindMapElement(Class\Entry(#PB_Compiler_Module)\vMethodeID(), dq#Name#dq)
        MethodeID = Class\Entry()\vMethodeID()
        Class\Entry()\vTable(MethodeID) = @Name()
      Else
        Debug "Error: Method in the inherited class not found. [" + dq#name#dq + "()]"
        CallDebugger
      EndIf
    EndProcedure : __OverwriteMethode#Name()
  EndMacro
 
  ; ---------------------------------------------------------------------------
 
  ; Debugger functions
 
  Macro ShowInterface(ClassName=#PB_Compiler_Module)
    CompilerIf #PB_Compiler_Debugger
      Define __index
      Debug "Interface " + ClassName
      Debug "{"
      If FindMapElement(BaseClass::Class\Entry(), ClassName)
        For __index = 0 To ArraySize(BaseClass::Class\Entry()\vTable()) - 1
          ForEach BaseClass::Class\Entry()\vMethodeID()
            If BaseClass::Class\Entry()\vMethodeID() = __index
              Debug " - MethodeID " + BaseClass::Class\Entry()\vMethodeID() + " - " + MapKey(BaseClass::Class\Entry()\vMethodeID()) + "()"
              Break
            EndIf
          Next
        Next
      Else
        Debug " - Interface not found."
      EndIf
      Debug "}"
    CompilerEndIf
  EndMacro
 
  Macro ShowClasses()
    CompilerIf #PB_Compiler_Debugger
      ForEach BaseClass::Class\Entry()
        Define __index
        Debug "Interface " + MapKey(BaseClass::Class\Entry())
        Debug "{"
        For __index = 0 To ArraySize(BaseClass::Class\Entry()\vTable()) - 1
          ForEach BaseClass::Class\Entry()\vMethodeID()
            If BaseClass::Class\Entry()\vMethodeID() = __index
              Debug " - MethodeID " + BaseClass::Class\Entry()\vMethodeID() + " - " + MapKey(BaseClass::Class\Entry()\vMethodeID()) + "()"
              Break
            EndIf
          Next
        Next
        Debug "}"
      Next
  CompilerEndIf
  EndMacro
 
  Macro CheckInterface(InterfaceName)
    CompilerIf #PB_Compiler_Debugger
      CompilerIf Defined(InterfaceName, #PB_Interface)
        Define __SizeOfInterface = SizeOf(InterfaceName) / SizeOf(Integer)
        Define __IndexOfInterface
        For __IndexOfInterface = 0 To __SizeOfInterface - 1
          If Class\Entry(#PB_Compiler_Module)\vTable(__IndexOfInterface) = 0
            Debug "Error: Invalid Interface " + dq#InterfaceName#dq + " by MethodeID " + __IndexOfInterface
            ShowInterface()
            CallDebugger
          EndIf
        Next
      CompilerElse
        Debug "Error: Interface not exists"
        CallDebugger
      CompilerEndIf
    CompilerEndIf
  EndMacro

  ; ---------------------------------------------------------------------------
 
EndDeclareModule

Module BaseClass
 
  EnableExplicit
 
  ; ---------------------------------------------------------------------------
 
  Procedure AddClass(ClassName.s, ClassExtends.s, Size)
    Protected r1
    If FindMapElement(Class\Entry(), ClassExtends)
      r1 = AddMapElement(Class\Entry(), ClassName)
    Else
      Debug "Error: Extends Class '" + ClassExtends + "' not exists!"
      CallDebugger
    EndIf
    If r1
      CopyStructure(Class\Entry(ClassExtends), Class\Entry(ClassName), udtClass)
      ReDim Class\Entry(ClassName)\vTable(Size)
    Else
      Debug "Warning: Class '" + ClassName + "' not Initialized!"
    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)
        LockMutex(Class\Mutex)
        If Class\ObjectCounter > 0
          Class\ObjectCounter - 1
        EndIf
        UnlockMutex(Class\Mutex)
        ProcedureReturn 0
      Else
        \RefCount - 1
      EndIf
      UnlockMutex(*This\System\Mutex)
      ProcedureReturn \RefCount
    EndWith
  EndProcedure
 
  ; ---------------------------------------------------------------------------
 
  Procedure InitBaseClass()
    Class\Mutex = CreateMutex()
    AddMapElement(Class\Entry(), "BaseClass")
    With Class\Entry("BaseClass")
      \vTable(0) = @QueryInterface()
      \vTable(1) = @AddRef()
      \vTable(2) = @Release()
      \vMethodeID("QueryInterface") = 0
      \vMethodeID("AddRef") = 1
      \vMethodeID("Release") = 2
    EndWith
  EndProcedure : InitBaseClass()
 
  ; ---------------------------------------------------------------------------
 
EndModule

;- End Module BaseClass

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

_________________
My Projects OOP-BaseClass / OOP-BaseClassDispatch / Event-Designer /
PB v3.30 / v5.60 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace


Last edited by mk-soft on Fri Jan 26, 2018 1:04 pm, edited 7 times in total.

Top
 Profile  
Reply with quote  
 Post subject: Re: Module BaseClass (OOP)
PostPosted: Tue Dec 15, 2015 7:45 pm 
Offline
Addict
Addict
User avatar

Joined: Fri May 12, 2006 6:51 pm
Posts: 1253
Location: Germany
Example 3 (Update)
Code:

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(iUser)
 
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, User)
 
  ; ---------------------------------------------------------------------------
 
  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(iAdress)
 
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()

_________________
My Projects OOP-BaseClass / OOP-BaseClassDispatch / Event-Designer /
PB v3.30 / v5.60 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace


Last edited by mk-soft on Fri Mar 30, 2018 10:10 am, edited 6 times in total.

Top
 Profile  
Reply with quote  
 Post subject: Re: Module BaseClass (OOP)
PostPosted: Tue Dec 22, 2015 9:48 pm 
Offline
Addict
Addict
User avatar

Joined: Fri May 12, 2006 6:51 pm
Posts: 1253
Location: Germany
Example 6

Update
Code:
;-TOP

; Example 6

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(iDataSet)
 
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

_________________
My Projects OOP-BaseClass / OOP-BaseClassDispatch / Event-Designer /
PB v3.30 / v5.60 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace


Last edited by mk-soft on Fri Mar 30, 2018 10:11 am, edited 5 times in total.

Top
 Profile  
Reply with quote  
 Post subject: Re: Module BaseClass (Module as Object)
PostPosted: Fri Jan 01, 2016 9:35 pm 
Offline
Addict
Addict
User avatar

Joined: Fri May 12, 2006 6:51 pm
Posts: 1253
Location: Germany
Update v1.13
- Change Macro InitObject for small code
- Added Macros AllocateObject and InitalizeObject for new object with parameters

Examples updated...

_________________
My Projects OOP-BaseClass / OOP-BaseClassDispatch / Event-Designer /
PB v3.30 / v5.60 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace


Top
 Profile  
Reply with quote  
 Post subject: Re: Module BaseClass (Module as Object)
PostPosted: Sun Jan 10, 2016 3:19 pm 
Offline
Addict
Addict
User avatar

Joined: Fri May 12, 2006 6:51 pm
Posts: 1253
Location: Germany
Update v1.15
* Added debugger functions
- ShowInterface(...)
- CheckInterface(...)

:wink:

_________________
My Projects OOP-BaseClass / OOP-BaseClassDispatch / Event-Designer /
PB v3.30 / v5.60 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace


Last edited by mk-soft on Mon Aug 15, 2016 10:10 pm, edited 1 time in total.

Top
 Profile  
Reply with quote  
 Post subject: Re: Module BaseClass (Module as Object)
PostPosted: Tue Feb 02, 2016 6:46 pm 
Offline
Addict
Addict
User avatar

Joined: Fri May 12, 2006 6:51 pm
Posts: 1253
Location: Germany
Update v1.16
- optimize code
- added debugging info

GT :wink:

_________________
My Projects OOP-BaseClass / OOP-BaseClassDispatch / Event-Designer /
PB v3.30 / v5.60 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace


Top
 Profile  
Reply with quote  
 Post subject: Re: Module BaseClass (Module as Object)
PostPosted: Mon Aug 15, 2016 1:53 pm 
Offline
Addict
Addict
User avatar

Joined: Fri May 12, 2006 6:51 pm
Posts: 1253
Location: Germany
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 OOP-BaseClass / OOP-BaseClassDispatch / Event-Designer /
PB v3.30 / v5.60 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace


Top
 Profile  
Reply with quote  
 Post subject: Re: Module BaseClass (Module as Object)
PostPosted: Tue Aug 16, 2016 12:23 pm 
Offline
Addict
Addict
User avatar

Joined: Fri May 12, 2006 6:51 pm
Posts: 1253
Location: Germany
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 OOP-BaseClass / OOP-BaseClassDispatch / Event-Designer /
PB v3.30 / v5.60 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace


Top
 Profile  
Reply with quote  
 Post subject: Re: Module BaseClass (Module as Object)
PostPosted: Sat Sep 17, 2016 11:55 am 
Offline
Addict
Addict
User avatar

Joined: Fri May 12, 2006 6:51 pm
Posts: 1253
Location: Germany
Update v1.23
- Safety RefCounter over Mutex

_________________
My Projects OOP-BaseClass / OOP-BaseClassDispatch / Event-Designer /
PB v3.30 / v5.60 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace


Last edited by mk-soft on Sat Feb 25, 2017 2:55 pm, edited 1 time in total.

Top
 Profile  
Reply with quote  
 Post subject: Re: Module BaseClass (Module as Object)
PostPosted: Sat Feb 25, 2017 1:31 pm 
Offline
Addict
Addict
User avatar

Joined: Fri May 12, 2006 6:51 pm
Posts: 1253
Location: Germany
Update v1.25
- Added Macro CloneObject because some things to do
- Added Check mutex
- Added Macro LockObject and UnlockObject

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


Code:
;-TOP

; Example 9

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(iWork)
 
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 2000
  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."

_________________
My Projects OOP-BaseClass / OOP-BaseClassDispatch / Event-Designer /
PB v3.30 / v5.60 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace


Last edited by mk-soft on Fri Mar 30, 2018 10:13 am, edited 4 times in total.

Top
 Profile  
Reply with quote  
 Post subject: Re: Module BaseClass (Module as Object)
PostPosted: Fri Mar 03, 2017 3:04 pm 
Offline
New User
New User

Joined: Tue May 31, 2016 7:19 am
Posts: 7
Excellent code :D
If you add a QueryInterface Method,it should support IUknwn Interface?


Top
 Profile  
Reply with quote  
 Post subject: Re: Module BaseClass (Module as Object)
PostPosted: Fri Mar 03, 2017 6:07 pm 
Offline
Addict
Addict
User avatar

Joined: Fri May 12, 2006 6:51 pm
Posts: 1253
Location: Germany
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:
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 OOP-BaseClass / OOP-BaseClassDispatch / Event-Designer /
PB v3.30 / v5.60 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace


Top
 Profile  
Reply with quote  
 Post subject: Re: Module BaseClass (Module as Object)
PostPosted: Fri Mar 03, 2017 6:08 pm 
Offline
Addict
Addict
User avatar

Joined: Fri May 12, 2006 6:51 pm
Posts: 1253
Location: Germany
Example 10

Update v1.4
- Added two methods 'QuerInterface' with result of same object or as new object...
- Bugfix

Code:
;-TOP

; Example 10 IUnknown

IncludeFile "Modul_BaseClass.pb"

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

Module MyObject
 
  EnableExplicit
 
  UseModule BaseClass
 
  NewClass(iMyObject)
 
  ; ---------------------------------------------------------------------------
 
  CompilerIf 0 ; Quer interface with same Object
    Procedure QueryInterface(*this, *riid, *addr)
      Protected *ppv.IUnknown
      If CompareMemory(*riid, ?IID_IUnknown, SizeOf(iid)) Or CompareMemory(*riid, ?IID_MyObject, SizeOf(iid))
        If *addr
          PokeI(*addr, *this)
        EndIf
        *ppv = *this
        *ppv\Addref()
        ProcedureReturn #S_OK
      Else
        ProcedureReturn #E_NOINTERFACE
      EndIf
    EndProcedure : AsNewMethode(QueryInterface)
  CompilerElse ; Query interface with new object
    Procedure QueryInterface(*this, *riid, *addr)
      Protected *ppv.IUnknown, *new.sMyObject
      If CompareMemory(*riid, ?IID_IUnknown, SizeOf(iid))
        If *addr
          PokeI(*addr, *this)
        EndIf
        *ppv = *this
        *ppv\Addref()
        ProcedureReturn #S_OK
      ElseIf CompareMemory(*riid, ?IID_IMyObject, SizeOf(iid))
        If *addr
          *new = New()
          If *new
            PokeI(*addr, *new)
            ProcedureReturn #S_OK
          Else
            ProcedureReturn #E_OUTOFMEMORY
          EndIf
        Else
          ProcedureReturn #E_INVALIDARG
        EndIf
      Else ; No Interface
        ProcedureReturn #E_NOINTERFACE
      EndIf
    EndProcedure : AsNewMethode(QueryInterface)
  CompilerEndIf
 
  ; ---------------------------------------------------------------------------
 
  Procedure Initalize(*this.sMyObject)
    Debug "Initalize Object " + *this
  EndProcedure : AsInitializeObject(Initalize)
 
  ; ---------------------------------------------------------------------------
 
  Procedure Dispose(*this.sMyObject)
    Debug "Dispose Object " + *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(iMyObject)
 
EndModule

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

;-Test

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

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

If *obj\QueryInterface(?IID_IUnknown, 0) = #S_OK
  Debug "QueryInterface IUnkown Ok: Object " + *obj
  Debug "Release IUnkown: " + *obj\Release()
EndIf

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

Define *obj2.MyObject::iMyObject
If *obj\QueryInterface(MyObject::?IID_IMyObject, @*obj2) = #S_OK
  Debug "QueryInterface IID_MyObject Ok: Object " + *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:

_________________
My Projects OOP-BaseClass / OOP-BaseClassDispatch / Event-Designer /
PB v3.30 / v5.60 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace


Last edited by mk-soft on Thu Aug 24, 2017 2:51 pm, edited 6 times in total.

Top
 Profile  
Reply with quote  
 Post subject: Re: Module BaseClass (Module as Object)
PostPosted: Fri Mar 03, 2017 6:23 pm 
Offline
Always Here
Always Here
User avatar

Joined: Thu Jun 24, 2004 2:44 pm
Posts: 5736
Location: Berlin - Germany
Better don't Import UUID.lib : viewtopic.php?p=205779#p205779

Better use Datasection, make a smaller foot :wink:

_________________
PureBasic 5.70 | SpiderBasic 2.10 | Windows 10 Pro (x64) | Linux Mint 19.0 (x64)
Old bugs good, new bugs bad! Updates are evil: might fix old bugs and introduce no new ones.
Image


Top
 Profile  
Reply with quote  
Display posts from previous:  Sort by  
Post new topic Reply to topic  [ 29 posts ]  Go to page 1, 2  Next

All times are UTC + 1 hour


Who is online

Users browsing this forum: Doc Hollyday and 6 guests


You cannot post new topics in this forum
You cannot reply to topics in this forum
You cannot edit your posts in this forum
You cannot delete your posts in this forum

Search for:
Jump to:  

 


Powered by phpBB © 2008 phpBB Group
subSilver+ theme by Canver Software, sponsor Sanal Modifiye