PureBasic Forums - English

http://www.purebasic.com
https://www.purebasic.fr/english/

Module BaseClass - With JSON und Runtime (Module as Object)

https://www.purebasic.fr/english/viewtopic.php?t=69033

Page 1 of 1

Module BaseClass - With JSON und Runtime (Module as Object)

Posted: Thu Aug 24, 2017 11:57 am
by mk-soft
The base is the same as the Module BaseClass. But uses the JSON and Runtime library of Purebasic to initialize the class.
For initialization, the macro InitClass(Interfacename, ...) is called at the end of the module.

All procedures for the interface are implemented using the 'Runtime Procedure MethodName(* this ...)'.
The procedure names 'Runtime Procedure Initialize(* this ...)' and 'Runtime Procedure Dispose(* this ...)' are reserved and are added automatically.

By using the Library JSON and Runtime the Execute would of course be indicated and the license information must be specified
Therefore, I will continue to maintain both modules, with and without JSON.

Thanks to GPI for nice idea with JSON library

Update v2.02
- Cleanup Code

Update v2.03
- Optimize check interface

Update v2.05
- Change internal Initialize and Dispose from list to array to avoid thread blocking

'Modul_BaseClassJS'

Code: Select all

;-Begin Module BaseClass (JS)

; Comment : Module as Object - With JSON und Runtime
; Author  : mk-soft
; Version : v2.05
; Created : 23.08.2017
; Updated : 24.08.2017
; Link DE : http://www.purebasic.fr/german/viewtopic.php?f=8&t=30331
; Link EN : http://www.purebasic.fr/english/viewtopic.php?f=12&t=69033

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

DeclareModule BaseClass
  
  ; ---------------------------------------------------------------------------
  
  ; Internal Class Manager
  
  Prototype ProtoInvoke(*This)
  
  Structure udtInvoke
    *Invoke.ProtoInvoke
  EndStructure
  
  Structure udtClass
    Array *vTable(3)
    Array Initialize.udtInvoke(0)
    Array Dispose.udtInvoke(0)
  EndStructure
  
  Structure udtClasses
    Map Entry.udtClass()
  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, JSValue, Size)
  
  Macro InitClass(ClassInterface, ClassExtends=BaseClass)
    Procedure InitClass#MacroExpandedCount()
      Protected js, jsvalue, index, size
      js = CreateJSON(#PB_Any)
      jsvalue = JSONValue(js)
      size = SizeOf(ClassInterface) / SizeOf(integer) - 1
      Dim iMethode(size)
      For index = 0 To size
        iMethode(index) = index
      Next
      InsertJSONStructure(jsvalue, iMethode(), ClassInterface)
      AddClass(#PB_Compiler_Module, dq#ClassExtends#dq, jsvalue, size)
      FreeJSON(js)
    EndProcedure : InitClass#MacroExpandedCount()
  EndMacro
  
  ; ---------------------------------------------------------------------------
  
  ; Macro for init object (short)
  Macro InitObject(sProperty)
    Protected *Object.sProperty, __cnt, __index
    *Object = AllocateStructure(sProperty)
    If *Object
      *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: Class '" + #PB_Compiler_Module + "' create mutex"
        FreeStructure(*Object)
        *Object = 0
      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
      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: Class '" + #PB_Compiler_Module + "' create mutex"
        FreeStructure(Object)
        Object = 0
      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
  
  ; ---------------------------------------------------------------------------
  
  Macro LockObject(This)
    LockMutex(This\System\Mutex)
  EndMacro 
  
  Macro UnlockObject(This)
    UnlockMutex(This\System\Mutex)
  EndMacro 
    
  ; ---------------------------------------------------------------------------
  
EndDeclareModule

Module BaseClass
  
  EnableExplicit
  
  ; ---------------------------------------------------------------------------
  
  Procedure AddClass(ClassName.s, ClassExtends.s, JSValue, Size)
    Protected r1, RuntimeName.s, MethodeName.s, MethodeID, *addr, index
    ; Create new class
    If FindMapElement(Class\Entry(), ClassExtends)
      r1 = AddMapElement(Class\Entry(), ClassName)
    Else
      DebuggerError("Error BaseClass: Class '" + ClassName + "' - Extends class '" + ClassExtends + "' not exists")
      End -1
    EndIf
    If r1 = 0
      DebuggerError("Error BaseClass: Class '" + ClassName + "' - Out of memory")
      End -1
    EndIf
    ; Copy extends class and resize vTable
    CopyStructure(Class\Entry(ClassExtends), Class\Entry(ClassName), udtClass)
    ReDim Class\Entry(ClassName)\vTable(Size)
    ; Set interface methodes
    If ExamineJSONMembers(JSValue)
      While NextJSONMember(JSValue)
        MethodeName = JSONMemberKey(JSValue)
        MethodeID = GetJSONInteger(JSONMemberValue(JSValue))
        RuntimeName = ClassName + "::" + MethodeName + "()"
        *addr = GetRuntimeInteger(RuntimeName)
        If *addr
          Class\Entry()\vTable(MethodeID) = *addr
        Else
          If Class\Entry()\vTable(MethodeID) = 0
            DebuggerError("Error BaseClass: Class '" + ClassName + "' - Missing methode '" + MethodeName + "()'")
            End -1
          EndIf
        EndIf
      Wend
    EndIf
    ; Added methode Initialize object 
    RuntimeName = ClassName + "::Initialize()"
    *addr = GetRuntimeInteger(RuntimeName)
    If *addr
      index = ArraySize(Class\Entry()\Initialize()) + 1
      ReDim Class\Entry()\Initialize(index)
      Class\Entry()\Initialize(index)\Invoke = *addr
    EndIf
    ; Added methode dispose object
    RuntimeName = ClassName + "::Dispose()"
    *addr = GetRuntimeInteger(RuntimeName)
    If *addr
      index = ArraySize(Class\Entry()\Dispose()) + 1
      ReDim Class\Entry()\Dispose(index)
      Class\Entry()\Dispose(index)\Invoke = *addr
    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)
        ProcedureReturn 0
      Else
        \RefCount - 1
      EndIf
      UnlockMutex(*This\System\Mutex)
      ProcedureReturn \RefCount
    EndWith
  EndProcedure
  
  ; ---------------------------------------------------------------------------
  
  Procedure InitBaseClass()
    AddMapElement(Class\Entry(), "BaseClass")
    With Class\Entry("BaseClass")
      \vTable(0) = @QueryInterface()
      \vTable(1) = @AddRef()
      \vTable(2) = @Release()
    EndWith
  EndProcedure : InitBaseClass()
  
  ; ---------------------------------------------------------------------------
  
EndModule

;- End Module BaseClass (JS)

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

Re: Module BaseClassJS-With JSON und Runtime (Module as Obje

Posted: Thu Aug 24, 2017 11:57 am
by mk-soft
Example 1 - Inheritance and override of methods

Code: Select all

;-TOP

; Example 1

IncludeFile "Modul_BaseClassJS.pb"

; Erste Klasse

DeclareModule MyMath1
  
  UseModule BaseClass
  
  Structure sMyMath1 Extends sBaseClass
    Value.i
  EndStructure
  
  Interface iMyMath1 Extends iBaseClass
    Result.s()
    Add(Value)
    Sub(Value)
  EndInterface
  
  Declare NewMath1()
  
EndDeclareModule

Module MyMath1
  
  UseModule BaseClass
  
  ; ---------------------------------------------------------------------------
  
  Runtime Procedure Initialize(*this.sMyMath1)
    Debug "Initialize MyMath1"
  EndProcedure
  
  ; ---------------------------------------------------------------------------
  
  Runtime Procedure Dispose(*this.sMyMath1)
    Debug "Dispose MyMath1"   
  EndProcedure
  
  ; ---------------------------------------------------------------------------
  
  Runtime Procedure.s Result(*this.sMyMath1)
    ProcedureReturn Str(*this\Value)
  EndProcedure
  
  ; ---------------------------------------------------------------------------
  
  Runtime Procedure Add(*this.sMyMath1, Value = 0) 
    *this\Value + Value
  EndProcedure
  
  ; ---------------------------------------------------------------------------
  
  Runtime Procedure Sub(*this.sMyMath1, Value = 0)  
    *this\Value - Value
  EndProcedure
  
  ; ---------------------------------------------------------------------------
  
  Procedure NewMath1()
    InitObject(sMyMath1) ; Mehr kommt hier nicht rein!
  EndProcedure
  
  ; ---------------------------------------------------------------------------
  
  InitClass(iMyMath1)
  
  
EndModule

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

; Klasse Math 2 mit Vererbung Klasse Math 1

DeclareModule MyMath2
  
  UseModule MyMath1
  
  Structure sMyMath2 Extends sMyMath1
    ; Nothing
  EndStructure
  
  Interface iMyMath2 Extends iMyMath1
    Mul(Value)
    Div(Value)
  EndInterface
  
  Declare NewMath2()
  
EndDeclareModule

Module MyMath2
  
  EnableExplicit
  
  UseModule BaseClass
  
  ; ---------------------------------------------------------------------------
  
  Runtime Procedure Initialize(*this.sMyMath2)
    Debug "Initialize MyMath2"
  EndProcedure
  
  ; ---------------------------------------------------------------------------
  
  Runtime Procedure Dispose(*this.sMyMath2)
    Debug "Dispose MyMath2"   
  EndProcedure
  
  ; ---------------------------------------------------------------------------
  
  Runtime Procedure Mul(*this.sMyMath2, Value = 0)
    *this\Value * Value
  EndProcedure
  
  ; ---------------------------------------------------------------------------
  
  Runtime Procedure Div(*this.sMyMath2, Value = 1)
    *this\Value / Value
  EndProcedure
  
  ; ---------------------------------------------------------------------------
  
  Runtime Procedure.s Result(*this.sMyMath2)
    ProcedureReturn "$" + Hex(*this\Value)
  EndProcedure ; Methode Result() von geerbten Klasse ersetzen
    
  ; ---------------------------------------------------------------------------
  
  Procedure NewMath2()
    InitObject(sMyMath2) ; Mehr kommt hier nicht rein!
  EndProcedure
  
  InitClass(iMyMath2, MyMath1)
  
EndModule

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

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

Debug "Test Math 1"

UseModule MyMath1
Global *obj.iMyMath1 =NewMath1()
Debug "AddRef: " + *obj\AddRef()
Debug "AddRef: " + *obj\AddRef()
Debug "Release: " + *obj\Release()
Debug "Release: " + *obj\Release()
*obj\Add(200)
*obj\Sub(50)
Debug "Result = " + *obj\Result()
Debug "Release: " + *obj\Release()

Debug "Test Math 2"

UseModule MyMath2
Global *obj2.iMyMath2 = NewMath2()
Debug "AddRef: " + *obj2\AddRef()
Debug "AddRef: " + *obj2\AddRef()
Debug "Release: " + *obj2\Release()
Debug "Release: " + *obj2\Release()
*obj2\Add(200)
*obj2\Sub(50)
*obj2\Mul(100)
*obj2\Div(10)
Debug "Result = " + *obj2\Result()

Debug "Release: " + *obj2\Release()

Re: Module BaseClassJS-With JSON und Runtime (Module as Obje

Posted: Thu Aug 24, 2017 11:58 am
by mk-soft
Example 6 - Object with parameters

Required steps:
1. AllocateObject
2. Copy the parameter
3. InitializeObject

Code: Select all

;-TOP

; Example 6

IncludeFile "Modul_BaseClassJS.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
  
  ; ---------------------------------------------------------------------------
  
  Runtime Procedure.s Get(*this.sDataSet, index)
    With *this
      If index >= 0 And index < \Count
        ProcedureReturn PeekS(\pStr(index))
      Else
        ProcedureReturn ""
      EndIf
    EndWith
  EndProcedure
  
  ; ---------------------------------------------------------------------------
  
  Runtime Procedure Count(*this.sDataSet)
    ProcedureReturn *this\Count
  EndProcedure
  
  ; ---------------------------------------------------------------------------
  
  Runtime Procedure Initialize(*this.sDataSet)
    Protected *pos, len, index
    Debug "Initialize Object"
    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
  
  ; ---------------------------------------------------------------------------
  
  Runtime Procedure Dispose(*this.sDataSet)
    Debug "Dispose Object"
  EndProcedure
  
  ; ---------------------------------------------------------------------------
  
  Procedure New(*pData)
    
    Protected *obj.sDataSet
    
    AllocateObject(*obj, sDataSet)
    If *obj
      *obj\pData = *pData
    EndIf
    InitializeObject(*obj)
    
    ProcedureReturn *obj
    
  EndProcedure
  
  ; ---------------------------------------------------------------------------
  
  InitClass(iDataSet)
  
EndModule

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

;- Test

EnableExplicit

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

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
*set1\Release()

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

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

Re: Module BaseClassJS-With JSON und Runtime (Module as Obje

Posted: Thu Aug 24, 2017 11:58 am
by mk-soft
Example 9 - Threads

Code: Select all

;-TOP

; Example 9

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

IncludeFile "Modul_BaseClassJS.pb"

DeclareModule Work

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

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

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

;-Test AddRef

Procedure thAdd(*Object.Work::iWork)
  Protected time
  *Object\AddRef()
  Delay(20)
  ;Debug "Start"
  For i = 1 To 100
    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()

Debug "Start Threads"
For i = 1 To 1000
  CreateThread(@thAdd(), *Object)
Next

Repeat
  Delay(1000)
  ref = *Object\AddRef()
  ref = *Object\Release()
  Debug ref
  If ref = 0
    Break
  EndIf
ForEver
Debug "Result = " + *Object\Result()
Debug "Mainscope Release Object"
*Object\Release()

Debug "Ready."

Re: Module BaseClassJS-With JSON und Runtime (Module as Obje

Posted: Thu Aug 24, 2017 12:01 pm
by mk-soft
Update v2.02
- Cleanup Code

This is the smallest code to implementation of object programmings. :wink:

Re: Module BaseClassJS-With JSON und Runtime (Module as Obje

Posted: Thu Aug 24, 2017 1:46 pm
by Kwai chang caine
Like usually a power code, like you know create (OOP, OLE, etc...) 8)
You remember me a little bit SROD, numerous of his jewel code, are never understanding by me :oops: even not the title or utility :lol:
But believe me, like also all the ASM code create by another members.....always admired :shock: 8)

The only thing i can say about your splendid works, it's that's works without error here , if that can help you a little bit ... :oops:
Thanks for sharing :wink:

Re: Module BaseClassJS-With JSON und Runtime (Module as Obje

Posted: Thu Aug 24, 2017 3:18 pm
by djes
Beautiful work ! It's a nice exercise, mastered as a jeweller. Can't wait to see how far you'll go.

Re: Module BaseClassJS-With JSON und Runtime (Module as Obje

Posted: Thu Aug 24, 2017 4:15 pm
by mk-soft
Thank´s :D

Now a small update for better finding a missing methods into the class.

Update v2.03
- Optimize check interface

Re: Module BaseClass - With JSON und Runtime (Module as Obje

Posted: Fri Aug 25, 2017 11:07 am
by mk-soft
Update v2.05
- Change internal Initialize and Dispose from list to array to avoid thread blocking

:wink:
All times are UTC+01:00
Page 1 of 1

Powered by phpBB® Forum Software © phpBB Limited