It is currently Thu Jun 20, 2019 2:42 pm

All times are UTC + 1 hour




Post new topic Reply to topic  [ 38 posts ]  Go to page 1, 2, 3  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: 1743
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)

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

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

; Comment : Module as Object
; Author  : mk-soft
; Version : v1.13
; Created : 16.08.2017
; Updated : 03.05.2019
; 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(dq#ClassInterface#dq, 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()
    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 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

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

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


Last edited by mk-soft on Fri May 03, 2019 4:16 pm, edited 55 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: 1743
Location: Germany
Quote:
Description of the module BaseClassSmall

Update v1.13

Preface

Purebasic is Procedure Oriented. But it supports the call of objects.

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\Self : Pointer to the class with the tables of the methods, constructors and destructors.
- 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)

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)
- Empty Method with result #E_NOINTERFACE.
* 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.


Thanks to DeepL

Translated with http://www.DeepL.com/Translator

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


Last edited by mk-soft on Sat May 11, 2019 2:55 pm, edited 20 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: 1743
Location: Germany
Example 3 (Update)
Code:
; 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()

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


Last edited by mk-soft on Sat May 04, 2019 1:50 pm, edited 8 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: 1743
Location: Germany
Example 6 Update

Update
Code:
;-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

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


Last edited by mk-soft on Sat May 04, 2019 1:51 pm, edited 6 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: 1743
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 ThreadToGUI / OOP-BaseClass / OOP-BaseClassDispatch / Event-Designer
PB v3.30 / v5.70 - 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: 1743
Location: Germany
Update v1.15
* Added debugger functions
- ShowInterface(...)
- CheckInterface(...)

:wink:

_________________
My Projects ThreadToGUI / OOP-BaseClass / OOP-BaseClassDispatch / Event-Designer
PB v3.30 / v5.70 - 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: 1743
Location: Germany
Update v1.16
- optimize code
- added debugging info

GT :wink:

_________________
My Projects ThreadToGUI / OOP-BaseClass / OOP-BaseClassDispatch / Event-Designer
PB v3.30 / v5.70 - 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: 1743
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 ThreadToGUI / OOP-BaseClass / OOP-BaseClassDispatch / Event-Designer
PB v3.30 / v5.70 - 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: 1743
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 ThreadToGUI / OOP-BaseClass / OOP-BaseClassDispatch / Event-Designer
PB v3.30 / v5.70 - 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: 1743
Location: Germany
Update v1.23
- Safety RefCounter over Mutex

_________________
My Projects ThreadToGUI / OOP-BaseClass / OOP-BaseClassDispatch / Event-Designer
PB v3.30 / v5.70 - 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: 1743
Location: Germany
Update
- 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)
... 


Update
Code:
;-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."

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


Last edited by mk-soft on Sat May 04, 2019 1:53 pm, edited 5 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: 1743
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 ThreadToGUI / OOP-BaseClass / OOP-BaseClassDispatch / Event-Designer
PB v3.30 / v5.70 - 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: 1743
Location: Germany
Example 10

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

Update
Code:
;-TOP

; Example 10 IUnknown v1.13

IncludeFile "Modul_BaseClassSmall.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()
 
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 ThreadToGUI / OOP-BaseClass / OOP-BaseClassDispatch / Event-Designer
PB v3.30 / v5.70 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace


Last edited by mk-soft on Sat May 04, 2019 1:55 pm, edited 7 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: 5754
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.21 | Windows 10 Pro (x64) | Linux Mint 19.1 (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  [ 38 posts ]  Go to page 1, 2, 3  Next

All times are UTC + 1 hour


Who is online

Users browsing this forum: No registered users and 5 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