PureBoard

Das deutsche PureBasic-Forum
https://www.purebasic.fr/german/

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

https://www.purebasic.fr/german/viewtopic.php?t=30331

Seite 1 von 1

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

Verfasst: 23.08.2017 13:39
von mk-soft
Die Basis ist die gleiche wie das Module BaseClass. Verwendet aber zur Initialisierung von der Klasse die Library JSON und Runtime von Purebasic
Zur Initialisierung wird am ende des Modul nur noch das macro InitClass(Interfacename, ...) aufgerufen.

Alle Procedure für das Interface werden mit Runtime Procedure Methode(*this...) umgesetzt.
Die Procedure-Namen 'Runtime Procedure Initialize(*this...)' und 'Runtime Procedure Dispose(*this...) sind reserviert und werden automatisch hinzugefügt.

Durch die Verwendung von den Library JSON und Runtime wägst die Execute natürlich an und es muss die Lizenz-Information angegeben werden
Daher werden ich weiter beide Module, mit und ohne JSON, weiter pflegen.

Danke an GPI für die Idee mit der JSON Library

Update v2.02
- Code bereinigt

Update v2.03
- Überprüfung: Gibt den fehlenden Methodennamen aus

Update v2.05
- Geändert: Internen Aufruf von Initialize und Dispose von List auf Array geändert, zur Vermeidung von Thread-Blocking

Modul_BaseClassJS.pb

Code: Alles auswählen

;-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 BaseClass - JSON (Module as Object)

Verfasst: 23.08.2017 13:40
von mk-soft
Example 1 - Vererbung und überschreiben von Methoden

Eine geerbte Methode kann einfach überschrieben werden. Diese hat keinen Einfluss auf die geerbte Klasse

Code: Alles auswählen

;-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 BaseClass - JSON (Module as Object)

Verfasst: 23.08.2017 13:40
von mk-soft
Example 6 - Object mit Parametern

Erforderliche Schritte:
1. AllocateObject
2. Parameter übernehmen
3. InitializeObject

Code: Alles auswählen

;-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 - Mit JSON und Runtime (Module as Obj

Verfasst: 24.08.2017 12:26
von mk-soft
Example 9 - Threads

Code: Alles auswählen

;-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 - Mit JSON und Runtime (Module as Obj

Verfasst: 24.08.2017 12:33
von mk-soft
Update v2.02
- Code bereinigt

Habe den Code auf das wesentliche reduziert. Somit liegt die Basic unter 300 Zeilen :wink:

Re: Module BaseClassJS - Mit JSON und Runtime (Module as Obj

Verfasst: 24.08.2017 12:35
von GPI
Du könntest hier

Code: Alles auswählen

Debug "Error: Class '" + ClassName + "' missing MethodeID " + Str(MethodeID)
noch den Methodennamen ausgeben, die JSON-Datei ist ja noch da, so das du problemlos umrechnen kannst.
Ist halt bei einer größeren Klasse leichter zu finden und oft vergisst man nur ein Runtime.

Re: Module BaseClassJS - Mit JSON und Runtime (Module as Obj

Verfasst: 24.08.2017 17:08
von mk-soft
Danke für den Tipp :allright:

Update v2.03
- Überprüfung: Gibt den fehlende Methodennamen aus

Re: Module BaseClass - Mit JSON und Runtime (Module as Objec

Verfasst: 25.08.2017 12:17
von mk-soft
Update v2.05
- Geändert: Internen Aufruf von Initialize und Dispose von List auf Array geändert, zur Vermeidung von Thread-Blocking

:wink:
Alle Zeiten sind UTC+02:00
Seite 1 von 1

Powered by phpBB® Forum Software © phpBB Limited

Deutsche Übersetzung durch phpBB.de