Wollte schon mein OOP-Precompiler auf Module umschreiben.
Stelle aber fest das es auch ohne Pre-Compiler zu lösen ist.
Mein Ziel ist es ohne viele neuen Schlüsselnamen ein Modul als ein Objekt zu programmieren . Ich glaube es ist mir gelungen.
Das Modul BaseClass bringt dazu alle erforderlichen Komponenten mit:
- Neue Klasse anlegen mit der BaseClass oder einer geerbten Klasse.
- Die Basisfunktion Object\Release() und Object\AddRef().
- Deklarierung von Aufruf Umgebung "Initalize" und "Dispose", auch bei Vererbung.
- Deklarierung von Methoden.
Es gibt nur wenige Regeln:
- Die Struktur für die Variablen (Properties) muss mit "Extends sBaseClass" oder mit "Extends sVererbung" definiert werden.
- Das Interface für die Methoden muss mit "Extends iBaseClass" oder mit "Extends iVererbung" definiert werden.
- Bei Vererbung muss die zu erbende Klasse eine BaseClass haben.
Update v1.07- Bugfix FreeMutex
Update v1.08- Die Klassen in der Procedure 'AddClass(...)' gekapselt
- Überprüfung der neuen Klasse in der Procedure 'AddClass(...)' erweitert
- Macros geändert da die Klassen nicht mehr global sind
- Geändert CheckInterface. Der Parameter wird nicht mehr benötigt
- Die Namen der Klassen sind nicht mehr 'Case Sensitive'
Update v1.10- Geändert ClassName Management
Update v1.13- CheckInterface optimiert
Modul_BaseClassSmall.pbCode:
;-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
; ***************************************************************************************
Link zum englischen Forum 
Zitat:
Beschreibung vom Modul BaseClassSmall
Update v1.13
Vorwort
Purebasic ist Procedure Orientiert. Unterstützt aber den Aufruf von Objekten.
Mein Ziel ist es nicht eine Objekt orientierte Sprache für Purebasic zu erstellen, sondern das anlegen von eigenen Objekten zu vereinfachen.
Für vollständige Unterstützung von Objekt orientierte Programmierung gibt es andere Programmiersprachen.
Bei machen Aufgaben ist es aber vom Vorteil diese objektorientiert anzulegen.
Hier gilt bei Purebasic der gleiche Aufwand wie zum Beispiel bei „C“.
Alles muss selber definiert und anlegen werden. Es müssen die Regeln für Objekte und der Funktionen und Methoden eingehalten werde.
1. Der erste Eintrag im Objekt ist immer der Zeiger auf die Tabelle mit den Methoden.
2. Der erste Parameter von den Methoden ist immer der Zeiger auf das eigene Objekt.
Klassen
Zum anlegen eines Objektes benötigt man ein Klasse.
Eine Klasse kann man auch den Datentyp eines Objekt nennen.
In diesen wird die Tabelle der Methoden (Funktionen) und der Attribute (Variablen) definiert.
Konstruktoren und Destruktoren
Konstruktoren sind Funktionen die beim anlegen des Objekt in einen definierten Zustand bringen und bei bedarf die erforderliche Ressourcen anlegen.
Destruktoren sind Funktionen die beim freigeben des Objekt die angelegen Ressourcen frei gibt.
Konstruktoren können auch Parameter haben, werden aber nicht von alle Programmiersprachen unterstützen.
Destruktoren haben keine Parameter.
Konstruktoren und Destruktoren haben keinen Rückgabewert.
Methode Super
Um eine Klasse oder auch Basisklasse genannt zu vererben, benötigt man eine Super Funktion welche die Methoden und Attribute an die Subklasse übergibt.
Hierzu gehören auch die Konstruktoren und Destruktoren der Basisklasse.
Bei mehrfache Vererbung kann es somit auch mehrere Konstruktoren und Destruktoren geben, die in der richtigen Reihenfolge aufgerufen werden müssen.
Interface
Interfaces definieren die Schnittstelle welche Methoden vorhanden sind oder vorhanden sein müssen.
Was unterstützt Purebasic
Purebasic unterstützt Interfaces und Attributen, sowie die Vererbung von Interfaces und Attributen
- Interface SubKlasse Extends BasisKlasse
- Structure SubAttribute Extends BasisAttribute
Aufruf der Methoden von dem Interfaces.
Was unterstützt das Modul BaseClassSmall
Anlegen und Verwalten von Klassen : NewClass(InterfaceName, …)
- Anlegen der Tabellen für Methoden, Konstruktoren und Destruktoren.
* Hinweis: Konstruktoren mit Parameter werden nicht unterstützt.
- Die Methode Super automatisiert.
Das Interface mit den Methoden von Typ IUnknown
- QueryInterface(*riid, *addr)
- AddRef()
- Release()
Die BasisAttribute mit der Struktur
- System\vTable : Zeiger auf die Methoden-Tabelle
- System\Self : Zeiger auf die Klasse mit den Tabellen der Methoden, Konstruktoren und Destruktoren.
- System\RefCount : Zähler zum schützen von dem Objekt
- System\Mutex : Mutex für asynchrone Bearbeitung vom dem Objekt
Zuweisung des Kontruktors : Macro AsInitializeObject(Name der Procedure)
Zuweisung des Destruktors : Macro AsDisposeObject(Name der Procedure)
Zuweisung der Methoden : Macro AsMethode(Name der Methode und Procedure)
Überschreiben der Methoden : Macro AsNewMethode(Name der Methode und Procedure)
Anlegen des Objekt : Macro InitObject oder AllocateObject/InitializeObject für die Procedure zum angelegen des Objekt
- Anlegen des Speichers für das Objekt.
- Zuweisung der Virtuellen Tabelle und Basis Attribute.
- Aufruf der Konstruktoren in der richtigen Reihenfolge.
Die Methode QueryInterface : Object\QuerInterface(*riid, *addr)
- Eine leere Methode mit den Rückgabewert #E_NOINTERFACE.
* Diese Methode kann bei bedarf überschrieben werden.
Die Methode AddRef : Object\AddRef()
- Erhöhung des Zählers des Objektes.
* Mit der Methode Release wird der Zähler reduziert und das Objekt wird erst freigegeben, wenn dieser Null erreicht hat.
! Nicht überschreiben !
Die Methode Release : Objekt\Release()
- Aufruf der Destruktoren in der richtigen Reihenfolge.
- Freigeben des Speichers.
! Nicht überschreiben !
Überprüfung der Klasse im Debugger-Modus
- CheckInterface() am Ende vom Modul aufrufen.
FAQ
Suche
Registrieren
Anmelden
), aber ich denke, dass ich die grundlegenden Funktionsprinzipien deiner OOP Lösung bei so einer überschaubaren Codelänge auch irgendwann in mein prozedurales Hirn hineingehämmert bekomme.
