Klassen/Objecte mittels RES-Datei und Runtime

Hier könnt Ihr gute, von Euch geschriebene Codes posten. Sie müssen auf jeden Fall funktionieren und sollten möglichst effizient, elegant und beispielhaft oder einfach nur cool sein.
GPI
Beiträge: 1511
Registriert: 29.08.2004 13:18
Kontaktdaten:

Klassen/Objecte mittels RES-Datei und Runtime

Beitrag von GPI »

Ich hab zufällig letztens gelesen, das RES-Datei auch Macros enthalten können. Diese sind sogar global in allen Modulen vorhanden und man muss das ganze nicht in jeden Quellcode einfügen (kann auch ein Nachteil sein).

Folgende Punkte waren mir wichtig:
  • Bei DLLs darf keine Befehls-Zeile außerhalb von Proceduren sein
  • IDE soll die Programmierung unterstützen, z.b. Autovervollständigung
  • Es sollen keine Dateien rumkopiert werden (Module)
  • Vererbung
  • Unabhängig von Modulen etc.
  • Keine vordefinierten Methoden/Member
  • Optionaler Startparameter
  • Es soll sich wie eine PB-Syntax anfühlen
  • Unterstützung von Konstruktor, Destruktor und Kopiekonstruktor
[Threadsafe_]DeclareClass(<class>[,<SuperClass>[,(<Startparameter>)]])
Eine Klasse ist schnell deklariert. Man erstellt ein Interface und eine Structure. Die Structure muss den Namen des Interface haben, aber mit _ beginnen. Idealerweise sollten sie mit EXTENDS die BaseClass bzw. _BaseClass definieren. Alternativ kann man bei der Structure auch als erstes Element ein __VT.i nutzen.
mit DefineClass(<ClassName>[,<Extends>]) deklariert man die Klasse. Das Sieht dann bspw. so aus:

Code: Alles auswählen

Interface Counter Extends BaseClass
  Get()
  Set(Value)
  Add(Value=1)
EndInterface
Structure _Counter Extends _BaseClass
  _Value.i
EndStructure
DeclareClass(Counter)
Diese Deklaration kann man bspw auch in DeclareModule-Part einbauen.

AllcoateObject(<Class> [,(<StartParameter>)])
FreeObject(<object>)
Jetzt kann man schon die Klasse benutzen. Mit AllocateObject(<ClassName>) oder <ClassName>() kann man ein Objekt erzeugen. Mit FreeObject(<Object>) wird das Objekt zerstört. FreeObject gibt übrigens immer 0 zurück, so das man es gut zum Löschen des Pointers nutzen kann.

Code: Alles auswählen

Define  *test.Counter
*test=AllocateObject(Counter)
Debug "obj:"+Hex(*test)
Debug *test\Get()
*test\set(20)
Debug *test\get()
*test\add(20)
Debug *test\Get()
*test=FreeObject(*test)
Class(<class>,<method>,(<parameter with *self>))
Etwas Trickreicher ist die Erstellung der Methoden. Es wird die normale Procedure-Kommando benutzt, als Procedure-Namen nimmt man das Maco Class(<ClassName>,<Method>,<Parameterblock>). Der Parameterblock muss zwingend als erstes Element das Object enthalten, als bspw. *Self._Counter . Will man statt eines Integers ein String zurückgeben, muss man ClassS benutzen, bei den anderen Typen entsprechend.
Sieht dann so aus:

Code: Alles auswählen

Procedure Class(Counter,Get, (*self._counter))
  ProcedureReturn *self\_Value
EndProcedure
Procedure Class(Counter,Set, (*self._counter,Value))
  *self\_Value=Value
EndProcedure
Procedure Class(Counter,Add, (*self._counter,Value=1))
  *self\_Value+Value
EndProcedure
AsMethod(<class>,<method>)
Alternativ kann man auch
AsMethod(<Class>,<Method>)
Einfach eine Procedure mit den Namen <Class>_<Method> und anschließend ein AsMethod einfügen. bspw so:

Code: Alles auswählen

Procedure Counter_Add(*self._counter.Value=1)
  *self\_Value+Value
EndProcedure:AsMethod(Counter,Add)
Beide Varianten (Class()/AsMethod()) lassen sich auch problemlos mischen.

Wenn übrigens eine Klasse vererbt wurde, kann man die SuperClass (=Parent) -Methoden hier auch überschreiben.

ClassConstructor(<Class>,(<Parameter>))
ClassDestructor(<Class>,(<Parameter>))
ClassCopyConstructor(<Class>,(<Parameter>))
Für die Konstruktoren/Destruktoren muss man entsprechend ClassConstructor(<ClassName>,<Parameter>), ClassDestructor(<ClassName>,<Parameter>) und ClassCopyConstructor(<ClassName>,<Parameter>) verwenden. Alternativ kann man auch direkt <Class>___Constuctor(), <Class>__Destructor() und <Class>___CopyConstructor(). Achtet auf die drei Unterstriche. Ein "AsMethod()" ist hier nicht nötig, die Konstruktoren/Destruktoren werden automatisch erkannt.
Wobei man hier Aufpassen muss, das eine SuperClass-Constructor nicht überschrieben wird, sondern beide aufgerufen werden. Gleiches beim Destructor. Der CopyConstructor erhält zwei Parameter. Das aktuelle neue Object und das alte. Das Object wurde schon kopiert! Es muss nur die Klasse überprüft werden, ob sie Member noch Sinn machen. Bspw. wenn ein Image in der Klasse gespeichert wurde, dann muss man eine Kopie erstellen und diese in neuen Object abspeichern.
WICHTIG: Ein (Copy)Constructor muss #True zurückliefern, ansonsten wird das Objekt sofort wieder zerstört!

Code: Alles auswählen

Procedure ClassConstructor(counter, (*self._counter))
  Debug "New Counter:"+Hex(*self)
  Procedurereturn #True
EndProcedure
Procedure ClassDestructor(counter, (*self._counter))
  Debug "Free Counter:"+Hex(*self)
EndProcedure
Procedure ClassCopyConstructor(Counter, (*self._Counter,*org._Counter))
  Debug "Copy Counter:"+Hex(*self)+" from "+Hex(*org) 
  Procedurereturn #True
EndProcedure
DefineClass(<class>[,<SuperClass>[,(<Startparameter>)]])
Wenn man alle Methoden definiert hat, muss man die Klasse noch mit einen DefineClass(<Classname>[,<Extends>]) finalisieren. Wichtig hier ist, das <Extends> wirklich optional ist, es reicht völlig aus, ein Extends bei Declare anzugeben, er wird übernommen. Gibt man ihn bei DeclareClass auch an, wird der Code ein bisschen einfacher.

Code: Alles auswählen

DefineClass(counter)
Wichtig ist, das zwischen der ersten Member-Methode und DefineClass *KEINE* andere Klasse definiert werden darf.

Hier ein Beispiel für ein Vererbung:

Code: Alles auswählen

Interface CounterPlus Extends Counter
   GetTimestamp()
EndInterface
Structure _CounterPlus Extends _Counter
  _timestamp.i
EndStructure
DeclareClass(CounterPlus,Counter)
Procedure Class(CounterPlus,Set, (*self._CounterPlus,value));-counterplus set
  *self\_Value=value
  *self\_timestamp=12
EndProcedure
Procedure Class(CounterPlus,Add, (*self._CounterPlus,value))
  *self\_Value+value
  *self\_timestamp=1
EndProcedure
Procedure Class(CounterPlus,GetTimestamp, (*self._CounterPlus))
  ProcedureReturn *self\_timestamp
EndProcedure
  
Procedure ClassConstructor(CounterPlus, (*self._CounterPlus))
  Debug "New Counterplus:"+Hex(*self)    
EndProcedure
Procedure ClassDestructor(CounterPlus, (*self._CounterPlus))
  Debug "Free Counterplus:"+Hex(*self)
EndProcedure
Procedure ClassCopyConstructor(CounterPlus, (*self._CounterPlus,*org._CounterPlus))
  Debug "Copy Counterplus:"+Hex(*self)+" from "+Hex(*org)
EndProcedure
DefineClass(CounterPlus)
Neben AllocateObject() und FreeObject() gibts noch folgende Möglichkeiten:

ReferenceObject(<Object>)
Erhöht den Referenz-Zähler des Objekts. Für jede Referenz muss ein separates FreeObject() aufgerufen werden, bevor das Objekt wirklich freigegeben wird.
Zurück wird übrigens der Zähler zurückgegeben.

CountReferenceObject(<Object>)
Gibt die Anzahl der Referenzen des Objekts zurück.

CopyObject(<Object>)
Erstellt eine Kopie von Objekt und gibt es zurück. Falls es Fehlschlägt, #Null.

IsClassObject(<ClassName>,<Object>)
Überprüft, ob das Objekt zur Klasse gehört. Wichtig: Objekte gehören auch immer zu der SuperClass (=Parent)!

IsObject(<Object>)
Überprüft, ob das Ding wirklich ein Objekt ist, das mit meinen Routinen erstellt wird. *WICHTIG* es wird hier mit einen PEEKI ein Integer unter den Objekt gelesen und kontrolliert, ob es einen bestimmten Wert hat. Das ganze kann also ein Programm zum Absturz bringen, wenn man bspw ein Test mit den Wert 8 macht! (Null wird abgefangen)

ClassId(<Class>)
Gibt die Klassen-ID zurück. Ist im Prinzip die Adresse der VTable.

ObjectId(<Object>)
Gibt die Klassen-ID eines Objekts zurück. Damit kann man überprüfen, ob ein Objekt wirklich exakt zu einer Klasse gehört. ClassId(<Class>)=ObjectId(<Object>)

CountObject(<Class>)
Gibt zurück, wieviele Objekte zu dieser Klasse gehören. Kann man nutzen um Speicherlecks rauszufinden.
GetClassMethod(<class>,method.s)
Ermittelt zu einer Klasse eine bestimmte Methode und gibt die Adresse der Procedure zurück, oder 0 wenn es die Methode nicht gibt.

Code: Alles auswählen

Debug "Method CounterPlus\Timestamp "+Hex(GetClassMethod(test::CounterPlus,"GetTimeStamp"))
GetObjectMethod(<Object>,method.s)
Wie oben, nur wird hier nach einer Methode eines Objekts gesucht.

Code: Alles auswählen

Debug "Method x4\text "+Hex(GetObjectMethod(x4,"text"))
GetClassIndex(<class>,method.s) und [GetObjectIndex(<class>,method.s)[/b]
wie oben, nur wird anstelle der Adresse ein Index in der VT-Table (beginnend mit 0) zurückgegeben. Wenn der Index nicht vorhanden ist, wird eine -1 zurückgegeben.

DeclareDebugObject()
DefineDebugObject()
DebugObject(<Object>)

Leider muss man den Befehl erst Definieren, sonst ist er nicht einsetzbar (REF-Version/bei der Includeversion ist das schon passiert). Er gibt in Debug-Fenster aus, zu welchen Klasse das Objekt gehört und welche Methoden es kennt.

Code: Alles auswählen

DebugObject(x4)
Output hat geschrieben:OUTPUT OBJECT x4 @49B0C70 of SteuerP
Set @14000AF7C
get @140008B18
Text @1400077CD
OUTPUT END
DeclareGetClassNameMethod()
DefineGetClassNameMethod()
GetClassNameMethod(ClassName.s,Method.s)

Auch hier muss man zuerst die Procedure definieren (REF-Version/bei der Includeversion ist das schon passiert). Funktioniert ähnlich wie GetClassMethod(), nur das hier zwei Strings übergeben werden. Wichtig beim Klassenname ist, das der Modulname *IMMER* (falls vorhanden) angegeben werden muss, auch wenn das Modul eigentlich mit UseModule verfügbar ist.

Code: Alles auswählen

Debug "Class test::counter get:"+Hex(GetClassNameMethod("teSt::CounTeR","Get"))
GetObjectClassName(<obj>)
Gibt den Klassenname des Objekts zurück.

GetClassIdName(classid)
Gibt den Klassenname einer ClassID (=VT Table) zurück.

Well man ein Objekt Threadsafe machen, sollte man bei der Declaration Threadsafe_DeclareClass(), Parameter sind identisch wie bei DeclareClass().
Die Methoden muss man allerdings manuell absichern:
LockObject(Object) und UnlockObject(Object)
Das kann man auch ohne Threadsafe nutzen, es wird dann automatisch ein Mutex erstellt und später freigegeben. Konstruktoren und Destruktoren müssen nicht abgesichet werden.

Wer oben richtig gelesen hat, wird sich erinnern, das ich was von Startwerten gesagt hab. Es gibt nur eine Einschränkung, man kann keine Optionale Parameter benutzen. Einfach eine Parameter-Angabe bei Declare/DefineClass einfügen. Den Constructor nicht vergessen, sonst machts keinen Sinn :)
Hier mal ein Beispiel:

Code: Alles auswählen

Interface Steuer Extends BaseClass
  set()
  get()
EndInterface
Structure _Steuer Extends _BaseClass
  value.i
EndStructure
DeclareClass(Steuer,BaseClass,(StartValue))

Procedure Class(Steuer,set,(*self._steuer,value))
  *self\value=value
EndProcedure
Procedure Class(Steuer,get,(*self._steuer))
  ProcedureReturn *self\value
EndProcedure
Procedure ClassConstructor(Steuer,(*self._steuer,StartValue))
  Debug "Steuer-Constructor "+Hex(*self)+" with Value:"+StartValue
  *self\value=StartValue
  ProcedureReturn #true
EndProcedure
DefineClass(Steuer,BaseClass,(StartValue),(*self,StartValue))
Benutzen kann man das ganze folgendermaßen:

Code: Alles auswählen

Define x1.steuer=Steuer(10)
Debug x1\get()

Define x2.steuer=AllocateObject(Steuer,(20))
Debug x2\get()

Define x3.steuer=AllocateObject(Steuer,(30))
Debug x3\get()
Zuletzt geändert von GPI am 14.05.2017 17:52, insgesamt 3-mal geändert.
CodeArchiv Rebirth: Deutsches Forum Github Hilfe ist immer gern gesehen!
GPI
Beiträge: 1511
Registriert: 29.08.2004 13:18
Kontaktdaten:

Re: Klassen/Objecte mittels RES-Datei und Runtime

Beitrag von GPI »

Das IDE unterstützt leider nicht die Erstellung von RES-Dateien. Ich hab mir ein kleines Programm geschrieben, dass das relativ leicht macht

Class.pb

Code: Alles auswählen

OpenConsole()
  a=RunProgram(#PB_Compiler_Home+"Compilers\pbcompiler.exe",Chr(34)+#PB_Compiler_File+"i"+Chr(34)+" /IGNORERESIDENT "+Chr(34)+#PB_Compiler_Filename+".res"+Chr(34)+" /RESIDENT "+Chr(34)+#PB_Compiler_Home+"Residents\"+#PB_Compiler_Filename+".res"+Chr(34),#PB_Compiler_Home,#PB_Program_Open|#PB_Program_Wait)
  If ProgramExitCode(a)
    Input()
  EndIf
  CloseProgram(a)
  CloseConsole()
  End
WICHTIG: Wenn PB in Standard-Programm-Ordner installiert wurde, muss man den Programm Adminrechte verpassen (Compileroptionen)!
Es wird dann automatisch auf Class.PBI in eine RES-Datei umgewandelt und in Compiler-Verzeichnis abgelegt.
WICHTIG2: Die Datei liegt zwar in Compilerverzeichnis, der Compiler beachtet sie aber erst nach den nächsten Neustart. Geht über das Compiler-Menü des IDE.
Hier die

Class.pbi

Code: Alles auswählen

;    Description: Class-Definition (Work as IncludeFile and as RES-File)
;         Author: GPI
;           Date: 2017-05-14
;     PB-Version: 5.60
;             OS: Windows, Linux, Mac
;  English-Forum: 
;   French-Forum: 
;   German-Forum: http://www.purebasic.fr/german/viewtopic.php?f=8&t=30133
; -----------------------------------------------------------------------------
; Compile this file with /RESIDENT for create a RES file
; OR use it as IncludeFile (UseModul Class)
;
; Changelog 1.4
;    - NEW: GetClassIdName
;    - CHANGE: Declare/DefineClass doesn't need the second para-Block anymore
;
; Changelog 1.3
;    - Bugfix
;
; Changelog 1.2
;    - CHANGE: GetReference and FreeObject now return the reference-counter
;    - CHANGE: Constructors must return #true, otherwise the object is released
;    - NEW: It is now possible, that a subclass has start-parameter and the superclass not
;    - CHANGE: First Parameter *obj of define/declareclass changed to *self
;    - NEW: ThreadSafe_DeclareClass declares a class threadsafe
;    - NEW GetObjectIndex and GetClassIndex 
;    - Change: Referece starts now with 1 instead of 0 again :)
;
; Changelog 1.1
;   - New: AsMethod
;   - New: GetClassMethod
;   - New: GetObjectMethod
;   - New: (Declare/Define)GetClassNameMethod
;   - New: (Declare/Define)DebugObject
;   - Change: Referece starts now with 0 instead of 1
;   - NEW:Can be used als IncludeFile or RES-Source-File

;{ Warper for IncludeFile
CompilerIf #PB_Compiler_IsMainFile=#False
  DeclareModule Class
    EnableExplicit
    
  CompilerIf #False:EndDeclareModule:CompilerEndIf;Correction of the Indention  
CompilerEndIf
;}

CompilerIf #PB_Compiler_Processor=#PB_Processor_x64
  #ClassMagicID=$7373616C436A624F ;ObjClass
CompilerElse
  #ClassMagicID=$436A624F ;ObjC
CompilerEndIf


#CLASS_Version=$0104
Structure __Class_nStruc  ;negative Struc - Information before the Structure of a Class
  Reference.i             ;Reference-Counter
  Mutex.i                 ;Mutex for Threadsafe
  Magic.i                 ;Magic for Object identification
EndStructure

Structure __Class_nVT     ;negative VT - Information before the VT of a Class
  Count.i                 ;Count of Objects
  *Constructor            ;Constructor
  *Free                   ;FreeObject
  *Destructor             ;Destructor 
  *Copy                   ;CopyObject
  *CopyConstructor        ;Copyconstructor
  *Check                  ;CheckClassObject
  *GetReference           ;ReferenceObject
  *Parent.__Class_nVT     ;Parent NVT
  *NameTable              ;NameTable
  *GetObjectMethod        ;GetMethod
  *GetObjectIndex         ;GetIndex
  TableSize.i             ;Entries in NameTable and VT
  *ClassName              ;Classname
  *new                    ;CreateNewClass
  Mutex.i                 ;Mutex Class
  *ExportClass            ;Reserved for ExportClass
  *Self                   ;Needed for Constructor
  ;VT
EndStructure

Interface BaseClass
EndInterface

Structure _BaseClass
  __VT.i
EndStructure

Structure _BaseClass__   
  nStruc.__Class_nStruc               
  ClassStart._BaseClass
EndStructure

Macro __Class_quote
  "
EndMacro

Macro ThreadSafe_DeclareClass(Class,ext=BaseClass,para=())
  #__#Class#_ThreadSafe=#True
  DeclareClass(Class,ext,para)
EndMacro

Macro DeclareClass(Class,ext=BaseClass,para=())
  ;Some little Checks
  CompilerIf SizeOf(Class)<SizeOf(ext)
    CompilerError "Interface-Corrupt "+__Class_quote#Class#__Class_quote
  CompilerEndIf
  CompilerIf OffsetOf(_#Class\__VT)<> OffsetOf(_BaseClass\__VT) 
    CompilerError "Structure-Corrupt _"+__Class_quote#Class#__Class_quote
  CompilerEndIf
  ;Create the negative-Structure
  Structure _#Class#__
    nStruc.__Class_nStruc
    ClassStart._#Class
  EndStructure
  ;Store information about the extends  
  #__#Class#_Extends=__Class_quote#ext#__Class_quote
  #__#Class#_SizeOf_Extends=SizeOf(ext)
  
  Declare.i Class para
  Declare.i Class#_GetVTable__()
  Declare.i Class#_Copy__(*Obj._BaseClass)
  Declare.i Class#_Check__(*Obj._BaseClass)
  Declare.i Class#_Constructor__ para
  Declare.i Class#_GetMethod__(Method.s)
  
  ;has the Class custom parameters?
  CompilerIf __Class_quote#para#__class_quote<>"()"
    Structure class#_Parameterdummy__
    EndStructure    
  CompilerEndIf
  
  ;Don't initalize on DLL
  CompilerIf #PB_Compiler_ExecutableFormat=#PB_Compiler_DLL
    Global Class#_VT__.i
  CompilerElse
    Global Class#_VT__.i=Class#_GetVTable__()
  CompilerEndIf
  
  ;Create Threadsafe?
  CompilerIf Not Defined(__#Class#_ThreadSafe,#PB_Constant)
    #__#Class#_ThreadSafe=#False
  CompilerEndIf
EndMacro

Macro Class(ClassX,Method,para):Class__(i,ClassX,Method,Para):EndMacro
Macro ClassA(ClassX,Method,para):Class__(A,ClassX,Method,Para):EndMacro
Macro ClassB(ClassX,Method,para):Class__(B,ClassX,Method,Para):EndMacro
Macro ClassC(ClassX,Method,para):Class__(C,ClassX,Method,Para):EndMacro
Macro ClassD(ClassX,Method,para):Class__(D,ClassX,Method,Para):EndMacro
Macro ClassW(ClassX,Method,para):Class__(W,ClassX,Method,Para):EndMacro
Macro ClassU(ClassX,Method,para):Class__(U,ClassX,Method,Para):EndMacro
Macro ClassL(ClassX,Method,para):Class__(L,ClassX,Method,Para):EndMacro
Macro ClassI(ClassX,Method,para):Class__(I,ClassX,Method,Para):EndMacro
Macro ClassF(ClassX,Method,para):Class__(F,ClassX,Method,Para):EndMacro
Macro ClassQ(ClassX,Method,para):Class__(Q,ClassX,Method,Para):EndMacro
Macro ClassS(ClassX,Method,para):Class__(S,ClassX,Method,Para):EndMacro

Macro Class__(type,ClassX,Method,para)
  ;Generate Dummy-Procedure - PB doesn't compile unused procedures
__Classdummy_#MacroExpandedCount#__():EndProcedure

Declare.type Classx#_#Method para
AsMethod(ClassX,Method)

;Method-Definition
Procedure.type ClassX#_#Method para
EndMacro

Macro AsMethod(ClassX,Method)
  ;Store information about the first number of a Class (needed for VT)
  CompilerIf Not Defined(ClassX#_StartCount__,#PB_Constant)
    #Classx#_StartCount__=MacroExpandedCount
  CompilerEndIf  
  ;Runtime-Procedure to write the entry in the VT
  Runtime Procedure ClassX#_#MacroExpandedCount#__(*VT,*NT)
    PokeI(*VT+OffsetOf(ClassX\method()),@ClassX#_#Method ())
    ;Write only, sub-class-names
    CompilerIf OffsetOf(classx\method())>=#__#ClassX#_SizeOf_Extends
      DataSection
        label:
        Data.s __Class_quote#Method#__Class_quote
      EndDataSection
      PokeI(*NT+OffsetOf(ClassX\method()),?label)
    CompilerEndIf
  EndProcedure    
EndMacro

Macro ClassConstructor(Class,para)
  Class#___Constructor para
EndMacro
Macro ClassDestructor(Class,para)
  Class#___Destructor para
EndMacro  
Macro ClassCopyConstructor(Class,para)
  Class#___CopyConstructor para
EndMacro

Macro DefineClass(Class,ext=0none,para=())
  CompilerIf Not Defined(__#Class#_Extends,#PB_Constant)
    CompilerError "Missing DeclareClass "+__Class_quote#Class#__Class_quote
  CompilerEndIf 
  CompilerIf __Class_quote#ext#__Class_quote<>"0none" And __Class_quote#ext#__Class_quote<>#__#Class#_Extends
    CompilerError __Class_quote#Class#__Class_quote +" extends "+__Class_quote#ext#__Class_quote+" should be "+#__#Class#_Extends
  CompilerEndIf
  
  ;Add :: before the module name
  CompilerIf #PB_Compiler_Module<>""
    #Class#_ModuleName__=#PB_Compiler_Module+"::"
  CompilerElse
    #Class#_ModuleName__=""
  CompilerEndIf        
  
  CompilerIf Not Defined(Class_Free__,#PB_Procedure)
    DefineClassHelper__()
  CompilerEndIf
    
  Procedure Class#_GetMethod__(Method.s) ;-*_GetMethod__
    If Class#_VT__=0
      Class#_VT__=Class#_GetVTable__()
    EndIf
    ProcedureReturn Class_GetMethod__(Class#_VT__,Method)
  EndProcedure 
  
  Procedure Class#_GetObjectMethod__(*obj._BaseClass,Method.s) ;-*_GetObjectMethod__
    ProcedureReturn Class_GetMethod__(*obj\__VT,Method)
  EndProcedure
  
  Procedure Class#_GetIndex__(Method.s) ;-*_GetIndex__
    If Class#_VT__=0
      Class#_VT__=Class#_GetVTable__()
    EndIf
    ProcedureReturn Class_GetIndex__(Class#_VT__,Method)
  EndProcedure  
  
  Procedure Class#_GetObjectIndex__(*obj._BaseClass,Method.s) ;-*_GetObjectIndex__
    ProcedureReturn Class_GetIndex__(*obj\__VT,Method)
  EndProcedure
  
  Interface class#__ extends class
    __CallConstructor para
  EndInterface
  Global *class#_FakeNVT__
  Structure class#__Allocatefake__
    b.b[SizeOf(Class)+SizeOf(__Class_nVT)+SizeOf(class) +SizeOf(__Class_nVT)+SizeOf(class#__)]
  EndStructure
  Global class#__Allocatefake__.class#__Allocatefake__
  
  Runtime Procedure Class#_GetVTable__();-*_GetVTable__
    Protected *GetVT,*parentVT
    Protected *nVT.__Class_nVT
    Protected *vt
    Protected i
    Protected *method
    
    If Class#_VT__=0
      ;Allocate Memory for nVT, VT, NameTable and FakeNVT
      ;*nVT=AllocateMemory(SizeOf(Class)+SizeOf(__Class_nVT)+SizeOf(class) +SizeOf(__Class_nVT)+SizeOf(class#__))
      *NVT=class#__Allocatefake__
      *VT=*nVT+SizeOf(__Class_nVT)
      *class#_FakeNVT__=*nvt+SizeOf(Class)+SizeOf(__Class_nVT)+SizeOf(class)
      
      ;Store Information about the Class-Control-Procedures
      *nVT\Constructor=@Class#_Constructor__()
      *nVT\free=@Class_Free__()
      CompilerIf Defined(Class#___Destructor,#PB_Procedure)
        *nVT\Destructor=@Class#___Destructor()
      CompilerEndIf 
      *nVT\Copy=@Class#_Copy__()
      CompilerIf Defined(Class#___CopyConstructor,#PB_Procedure)
        *nVT\CopyConstructor=@Class#___CopyConstructor()
      CompilerEndIf
      *nVT\Check=@Class#_Check__()
      *nVT\GetReference=@Class_GetReference__()
      *nVT\ClassName=?Label
      *nVT\TableSize=SizeOf(class)
      *nVT\NameTable=*vt+SizeOf(class)
      *nVT\GetObjectMethod=@Class#_GetObjectMethod__()
      *nvt\GetObjectIndex=@Class#_GetObjectIndex__()
      *nVT\New=@Class()
      *nVT\Mutex=CreateMutex()
      
      CompilerIf __Class_quote#ext#__Class_quote="0none"
        ;Version for the "no Parameter" or no baseclass
        CompilerIf #__#Class#_Extends<>"BaseClass"
          ;Get the Adress of the GetVTable of the Parent
          CompilerIf #Class#_ModuleName__<> ""
            If FindString(#__#Class#_Extends,"::")=0
              *GetVT=GetRuntimeInteger(#Class#_ModuleName__+#__#Class#_Extends+"_GetVTable__()")
            Else
              *GetVT=GetRuntimeInteger(#__#Class#_Extends+"_GetVTable__()")
            EndIf 
          CompilerElse 
            *GetVT=GetRuntimeInteger(#__#Class#_Extends+"_GetVTable__()")
          CompilerEndIf
          ;Get the parentVT
          If *getVT 
            *parentVT=CallFunctionFast(*GetVT)
            *nVT\parent=*parentVT-SizeOf(__Class_nVT)
            ;Copy ParentVT to VT
            CopyMemory(*parentVT,*VT,#__#Class#_SizeOf_Extends)
            CopyMemory(*parentVT+#__#Class#_SizeOf_Extends,*vt+SizeOf(class),#__#Class#_SizeOf_Extends);NameTable
          Else
            Debug "Missing parent class!"
            CallDebugger
            End
          EndIf
        CompilerEndIf
      CompilerElseIf Defined(ext#_GetVTable__,#PB_Procedure)
        ;"Parameter Version" or "Named" BaseClass
        *parentVT=ext#_GetVTable__()
        *nVT\parent=*parentVT-SizeOf(__Class_nVT)
        CopyMemory(*parentVT,*VT,#__#Class#_SizeOf_Extends)
        CopyMemory(*parentVT+#__#Class#_SizeOf_Extends,*vt+SizeOf(class),#__#Class#_SizeOf_Extends);NameTable
      CompilerEndIf
      
      ;Search Methods and fill VT
      CompilerIf Defined(Class#_StartCount__,#PB_Constant)
        i=#Class#_StartCount__        
        Repeat
          *method=GetRuntimeInteger(#Class#_ModuleName__+__Class_quote#Class#__Class_quote+"_"+i+"__()")
          If *method=0
            Break
          EndIf
          CallFunctionFast(*method,*VT,*vt+SizeOf(class))
          i+1
        ForEver
      CompilerEndIf  
      
      ;Check if a VT-field is empty
      CompilerIf #PB_Compiler_Debugger
        i=0
        While i<SizeOf(Class)
          If PeekI(*VT+i)=0
            Debug "Procedure Class is missing! "+Str(i/SizeOf(integer)+1)+" of "+ __Class_quote#Class#__Class_quote
            CallDebugger
            End
          EndIf         
          i+SizeOf(integer)
        Wend
      CompilerEndIf      
      
      CopyMemory(*nVT,*class#_FakeNVT__,SizeOf(__Class_nVT)+SizeOf(class))
      Class#_VT__=*VT
    EndIf
    ProcedureReturn Class#_VT__
    
    DataSection
      label:
      Data.s __Class_quote#Class#__Class_quote
    EndDataSection
  EndProcedure
  
  Procedure Class#_Check__(*ObjVT);-*_Check__
    Protected *nVT.__Class_nVT=*ObjVT-SizeOf(__Class_nVT)
    If Class#_VT__=0
      Class#_VT__=Class#_GetVTable__()
    EndIf
    Protected ok=#False
    
    Repeat  
      If Class#_VT__=*ObjVT
        ok=#True
        Break
      EndIf
      
      *nVT=*ObjVT-SizeOf(__Class_nVT) 
      If *nVT\Parent
        *ObjVT=*nVT\Parent+SizeOf(__Class_nVT) 
      Else
        Break
      EndIf
    ForEver    
    
    ProcedureReturn ok
  EndProcedure  
  
  
  Procedure Class#_Constructor__ para ;-*_Constructor__
                                         
    ;Already mutexed by *
    Protected __ret=#True
    Protected *__nVT.__Class_nVT=Class#_VT__-SizeOf(__Class_nVT);VT is initalized here!
    Protected *__self._#class
    Protected *__saveVT
    Protected __this.class#__
    
    ;Get *self
    *__self=*__nvt\self
    *__nvt\self=0
    UnlockMutex(*__nvt\Mutex)
        
    ;Search for superclass constructor
    CompilerIf #__#Class#_Extends<>"BaseClass"
      LockMutex(*__nvt\Parent\Mutex)
      *__nvt\Parent\self=*__Self
      CompilerIf __Class_quote#ext#__Class_quote="0none"
        __ret=CallFunctionFast(*__nVT\parent\Constructor)
      CompilerElseIf Defined(ext#_Constructor__,#PB_Procedure)
        CompilerIf Defined(ext#_Parameterdummy__,#PB_Structure)
          __ret=ext#_Constructor__ para
        CompilerElse
          __ret=ext#_Constructor__ ()
        CompilerEndIf
      CompilerEndIf
    CompilerEndIf
    
    CompilerIf Defined(Class#___Constructor,#PB_Procedure)
      If __ret 
        ;sub-Constructor
        
        *__saveVT=*__self\__vt
        __this=*__self
        PokeI(*class#_FakeNVT__+SizeOf(__Class_nVT)+OffsetOf(class#__\__CallConstructor()),@class#___Constructor())
        *__self\__vt=*class#_FakeNVT__+SizeOf(__Class_nVT)
        __this\__CallConstructor para
        *__self\__vt=*__saveVT
        
        ;Something happend! - Free the Parents!
        CompilerIf #__#Class#_Extends<>"BaseClass"
          If __ret=0 ;And *__nvt\Parent
            *__nvt=*__nvt\Parent
            
            While *__nVT
              If *__nVT\Destructor
                CallFunctionFast(*__nVT\Destructor,*__self)
              EndIf
              *__nVT=*__nVT\Parent
            Wend  
          EndIf
        CompilerEndIf
        
      EndIf
    CompilerEndIf
    
    ProcedureReturn __ret
  EndProcedure
  
  Procedure Class para;-*
    If Class#_VT__=0
      Class#_VT__=Class#_GetVTable__()
    EndIf
    Protected *__nVT.__Class_nVT=Class#_VT__-SizeOf(__Class_nVT) 
    Protected *__nStruc._BaseClass__
    Protected *__self._BaseClass
    Protected __ret=#True
    
    ;Allocate the Class-Structure
    *__nStruc=AllocateStructure(_#Class#__)      
    If *__nStruc      
      *__nStruc\nStruc\Reference=1
      *__nStruc\nStruc\Magic=#ClassMagicID
      
      CompilerIf  #__#Class#_ThreadSafe
        *__nStruc\nStruc\Mutex=CreateMutex()
        If *__nStruc\nStruc\Mutex=0
          FreeStructure(*__nStruc)
          ProcedureReturn 0
        EndIf
      CompilerEndIf
      
      ;jump over the negativ part
      *__self=*__nStruc+OffsetOf(_BaseClass__\ClassStart)
      *__self\__VT=Class#_VT__
      
      LockMutex(*__nvt\Mutex)
      *__nvt\self=*__self
      __ret=Class#_Constructor__ para
      
      If __ret=0        
        FreeStructure(*__nstruc)
        ProcedureReturn 0
      EndIf
      
      LockMutex(*__nvt\mutex)
      *__nVT\Count+1
      UnlockMutex(*__nvt\mutex)
    EndIf
    
    ProcedureReturn *__self
  EndProcedure
  
  Procedure Class#_Copy__(*Obj._BaseClass);-*_Copy__
                                          ;Static *VT
    If Class#_VT__=0
      Class#_VT__=Class#_GetVTable__()
    EndIf
    Protected *nVT.__Class_nVT=Class#_VT__-SizeOf(__Class_nVT)
    Protected *nnStruc._BaseClass__, *nObj._BaseClass
    Protected *nStruc._BaseClass__=*Obj-OffsetOf(_BaseClass__\ClassStart)
    Protected ret
    
    ;Allocate the Class-Structure
    ;Class + negativ-Structure
    *nnStruc=AllocateStructure(_#Class#__)
    If *nnStruc
      *nObj=*nnStruc+OffsetOf(_BaseClass__\ClassStart)
      
      If *nStruc\nStruc\Mutex
        LockMutex(*nStruc\nStruc\Mutex)
      EndIf
      
      ;Copy Class from Original
      CopyStructure(*nStruc,*nnStruc,_#Class#__)
      
      *nnStruc\nStruc\Reference=1
      ;*nnStruc\nStruc\Magic=#ClassMagicID ;done by copy
      CompilerIf Defined(__#Class#_ThreadSafe,#PB_Constant)
        *nnStruc\nStruc\Mutex=CreateMutex()
        If *nnStruc\nStruc\Mutex=0
          If *nStruc\nStruc\Mutex
            UnlockMutex(*nStruc\nStruc\Mutex)
          EndIf
          FreeStructure(*nnStruc)
          ProcedureReturn 0
        EndIf
      CompilerElse 
        *nnStruc\nStruc\Mutex=0
      CompilerEndIf
      
      ret= Class_CopyConstructor__(*nVT,*nObj,*Obj)
      
      If *nStruc\nStruc\Mutex
        UnlockMutex(*nStruc\nStruc\Mutex)
      EndIf
      
      If ret=0
        FreeStructure(*nnStruc)
        ProcedureReturn 0
      EndIf      
      
      LockMutex(*nVT\mutex)
      *nVT\Count+1
      UnlockMutex(*nVT\mutex)
    EndIf
    
    ProcedureReturn *nObj
  EndProcedure
  
EndMacro

Macro DeclareClassHelper__()
  CompilerIf Not Defined(Class_CopyConstructor__,#PB_Procedure)
    Declare Class_CopyConstructor__(*nVT.__Class_nVT,*nObj,*Obj)
    Declare Class_Free__(*Obj._BaseClass)
    Declare Class_GetMethod__(*VT,Method.s)
    Declare Class_GetReference__(*Obj._BaseClass)
    Declare Class_GetIndex__(*vt,Method.s)
  CompilerEndIf
EndMacro
Macro DefineClassHelper__()
    Procedure Class_CopyConstructor__(*nVT.__Class_nVT,*nObj,*Obj) ;-Class_CopyConstructor__
      
      ;Allready mutexed
      Protected ret=#True
      If *nVT\parent
        ret=Class_CopyConstructor__(*nVT\Parent,*nObj,*Obj)
      EndIf
      
      If ret=#True
        If *nVT\CopyConstructor
          ret=CallFunctionFast(*nVT\CopyConstructor,*nObj,*Obj)
          
          ;Something happend! - Free the Parents!
          If ret=0 And *nvt\Parent
            *nvt=*nvt\Parent
            
            While *nVT
              If *nVT\Destructor
                CallFunctionFast(*nVT\Destructor,*Obj)
              EndIf
              *nVT=*nVT\Parent
            Wend  
          EndIf
          
        EndIf
      EndIf
      ProcedureReturn ret
    EndProcedure
    
    Procedure Class_GetReference__(*Obj._BaseClass);-Class_GetReference__
      Protected *nStruc._BaseClass__=*Obj-OffsetOf(_BaseClass__\ClassStart)
      
      If *nStruc\nStruc\Mutex
        LockMutex(*nStruc\nStruc\Mutex)
      EndIf
      *nStruc\nStruc\Reference+1
      If *nStruc\nStruc\Mutex
        UnlockMutex(*nStruc\nStruc\Mutex)
      EndIf
      ProcedureReturn *nStruc\nStruc\Reference
    EndProcedure
    
    Procedure Class_Free__(*Obj._BaseClass);-Class_Free__
      Protected *VT=*Obj\__VT
      Protected *nVT.__Class_nVT=*VT-SizeOf(__Class_nVT)
      Protected *nStruc._BaseClass__=*Obj-OffsetOf(_BaseClass__\ClassStart)
      Protected ret
      
      ;Reduce Reference-Level
      If *nStruc\nStruc\Mutex
        LockMutex(*nStruc\nStruc\Mutex)
      EndIf
      *nStruc\nStruc\Reference-1
      ret=*nStruc\nStruc\Reference
      If *nStruc\nStruc\Mutex
        UnlockMutex(*nStruc\nStruc\Mutex)
      EndIf
      
      ;Only Free, when no reference exist
      If ret<=0
        
        LockMutex(*nvt\mutex)
        *nVT\count-1
        UnlockMutex(*nvt\mutex)
        
        ;mutex is not needed, because we are the only object
        While *nVT
          If *nVT\Destructor
            CallFunctionFast(*nVT\Destructor,*Obj)
          EndIf
          *nVT=*nVT\Parent
        Wend
        ;*nVT is now invalid!!!
        
        If *nStruc\nStruc\Mutex
          FreeMutex(*nStruc\nStruc\Mutex)
          *nStruc\nStruc\Mutex=0
        EndIf
        
        *Obj\__VT=0;little chance for a clean crash, when somebody try to use the Object again!
        *nStruc\nStruc\Magic=0
        FreeStructure(*nStruc)
      EndIf
      
      ProcedureReturn ret     
    EndProcedure  
    
    Procedure Class_GetIndex__(*vt,Method.s);-Class_GetIndex__
      Protected *nVT.__Class_nVT=*VT-SizeOf(__Class_nVT)
      Protected *NT=*nVT\NameTable
      Protected *i
      Protected Result=-1
      Protected *str
      
      Method=UCase(Method)
      
      While *i<*nVT\TableSize
        *str=PeekI(*NT+*I)
        If *str And UCase(PeekS(*str))=Method
          result=*i / SizeOf(integer)
          Break
        EndIf
        *i+SizeOf(integer)
      Wend
      ProcedureReturn Result
    EndProcedure
    
    Procedure Class_GetMethod__(*VT,Method.s);-Class_GetMethod__
      Protected index
      index=Class_GetIndex__(*vt,Method)
      If index>-1
        ProcedureReturn PeekI(*vt+index*SizeOf(integer))
      EndIf
      ProcedureReturn 0
    EndProcedure  
EndMacro


Macro DeclareDebugObject()
  CompilerIf #PB_Compiler_Debugger
    Declare.i DebugObject__(*obj._BaseClass,Name.s)
  CompilerEndIf
EndMacro

Macro DefineDebugObject()
  CompilerIf #PB_Compiler_Debugger
    Procedure.i DebugObject__(*obj._BaseClass,Name.s) ;-DebugObject__
      Protected *nVT.__Class_nVT=*obj\__VT-SizeOf(__Class_nVT)
      Protected *NT=*nVT\NameTable
      Protected *i
      Debug "OUTPUT OBJECT "+name+" @"+Hex(*obj)+" of "+PeekS(*nVT\ClassName)
      While *i<*nVT\TableSize
        Debug "  "+PeekS(PeekI(*NT+*I))+" @"+Hex(PeekI(*obj\__VT+*i))
        *i+SizeOf(integer)
      Wend
      Debug "OUTPUT END"
    EndProcedure
  CompilerEndIf
EndMacro

Macro DebugObject(obj)
  CompilerIf #PB_Compiler_Debugger
    DebugObject__(obj,__Class_quote#obj#__Class_quote)
  CompilerEndIf
EndMacro

Macro DeclareGetClassNameMethod()
  Declare.i GetClassNameMethod(Class.s,Method.s)
EndMacro

Macro DefineGetClassNameMethod()
  Procedure.i GetClassNameMethod(Class.s,Method.s)
    Protected *GetVT
    Protected *VT
    
    *GetVT=GetRuntimeInteger(class+"_GetVTable__()")
    If *GetVT
      *VT=CallFunctionFast(*GetVT)
      Method=UCase(method)
      
      Protected *nVT.__Class_nVT=*VT-SizeOf(__Class_nVT)
      Protected *NT=*nVT\NameTable
      Protected *i
      Protected *Result
      While *i<*nVT\TableSize
        If UCase(PeekS(PeekI(*NT+*I)))=Method
          *result=PeekI(*VT+*i)
          Break
        EndIf
        *i+SizeOf(integer)
      Wend
      ProcedureReturn *Result
    EndIf
    ProcedureReturn 0
  EndProcedure     
EndMacro

Macro AllocateObject(Class,para=())
  Class para
EndMacro

Macro FreeObject(Obj)
  CallFunctionFast(PeekI(PeekI(Obj)-SizeOf(__Class_nVT)+OffsetOf(__Class_nVT\free)),Obj)
EndMacro

Macro ReferenceObject(Obj)
  CallFunctionFast(PeekI(PeekI(Obj)-SizeOf(__Class_nVT)+OffsetOf(__Class_nVT\GetReference)),Obj)
EndMacro

Macro CountReferenceObject(Obj)
  PeekI(Obj-SizeOf(__Class_nStruc)+OffsetOf(__Class_nStruc\Reference))
EndMacro  

Macro CopyObject(Obj)
  CallFunctionFast(PeekI(PeekI(Obj)-SizeOf(__Class_nVT)+OffsetOf(__Class_nVT\Copy)),Obj)
EndMacro

Macro IsClassObject(Class,Obj)
  Class#_Check__(PeekI(Obj))
EndMacro

Macro IsObject(Obj)
  Bool(Obj<>0 And  PeekI(Obj-SizeOf(__Class_nStruc)+OffsetOf(__Class_nStruc\Magic)) = #ClassMagicID)
EndMacro

Macro ClassId(Class)
  Class#_GetVTable__()
EndMacro

Macro ObjectId(Obj)
  PeekI(Obj)
EndMacro

Macro LockObject(Obj)
  If PeekI(Obj-SizeOf(__Class_nStruc)+OffsetOf(__Class_nStruc\Mutex))=0
    PokeI(Obj-SizeOf(__Class_nStruc)+OffsetOf(__Class_nStruc\Mutex),CreateMutex())
  EndIf
  LockMutex(PeekI(Obj-SizeOf(__Class_nStruc)+OffsetOf(__Class_nStruc\Mutex)))
EndMacro

Macro UnlockObject(Obj)
  LockMutex(PeekI(Obj-SizeOf(__Class_nStruc)+OffsetOf(__Class_nStruc\Mutex)))
EndMacro

Macro CountObject(Class)
  PeekI(Class#_GetVTable__()-SizeOf(__Class_nVT)+OffsetOf(__Class_nVT\Count))
EndMacro

Macro GetClassMethod(class,method)
  class#_GetMethod__(method)
EndMacro

Macro GetObjectMethod(Obj,method)
  CallFunctionFast(PeekI(PeekI(Obj)-SizeOf(__Class_nVT)+OffsetOf(__Class_nVT\GetObjectMethod)),Obj,@method)
EndMacro

Macro GetClassIndex(class,method)
  class#_GetIndex__(method)
EndMacro

Macro GetObjectIndex(Obj,method)
  CallFunctionFast(PeekI(PeekI(Obj)-SizeOf(__Class_nVT)+OffsetOf(__Class_nVT\GetObjectIndex)),Obj,@method)
EndMacro

Macro GetObjectClassName(obj)
  PeekS(PeekI(PeekI(obj)-SizeOf(__Class_nVT)+OffsetOf(__Class_nVT\ClassName)))
EndMacro
Macro GetClassIdName(vt)
  PeekS(PeekI(vt-SizeOf(__Class_nVT)+OffsetOf(__Class_nVT\ClassName)))
EndMacro
  

;-
;{Warper for IncludeFile
CompilerIf #PB_Compiler_IsMainFile=#False
  CompilerIf #False:DeclareModule Class:CompilerEndIf;Correction of the indention
    
    DeclareDebugObject()
    DeclareGetClassNameMethod()
    DeclareClassHelper__()
    
    UndefineMacro FreeObject
    Macro FreeObject(Obj)
      Class_Free__(Obj)
    EndMacro
    UndefineMacro ReferenceObject
    Macro ReferenceObject(Obj)
      Class_GetReference__(Obj)
    EndMacro  
  EndDeclareModule
  
  Module Class
    DefineDebugObject()
    DefineGetClassNameMethod()
    DefineClassHelper__()
  EndModule  
  UseModule class
CompilerEndIf
;}
Wer sich die Macros ansieht, wird feststellen, das man hier für jede Methode ein "Dummy"-Procedure erstellt werden. PB ist aber so intelligent und diese rausschmeißt, wenn sie nirgends benutzt werden. Von daher kein Problem.
Zuletzt geändert von GPI am 14.05.2017 17:32, insgesamt 4-mal geändert.
CodeArchiv Rebirth: Deutsches Forum Github Hilfe ist immer gern gesehen!
GPI
Beiträge: 1511
Registriert: 29.08.2004 13:18
Kontaktdaten:

Re: Klassen/Objecte mittels RES-Datei und Runtime

Beitrag von GPI »

Hier noch ein wildes Beispiel:

Code: Alles auswählen

EnableExplicit

;Check if we use the RES-File or not
CompilerIf Not Defined(BaseClass,#PB_Interface)
  XIncludeFile "class.pbi"
  UseModule Class
CompilerElse
  DefineDebugObject()
  DefineGetClassNameMethod()
CompilerEndIf

;Beispiel



DeclareModule test
  
  ;When we use class as IncludeFile, we must use module Class
  CompilerIf Defined(Class,#PB_Module)
    UseModule Class
  CompilerEndIf
  
  
  EnableExplicit
  
  Interface Counter Extends BaseClass
    Get()
    Set(Value)
    Add(Value=1)
  EndInterface
  Structure _Counter Extends _BaseClass
    _Value.i
  EndStructure
  DeclareClass(Counter)
  
  Interface CounterPlus Extends Counter
    GetTimestamp()
  EndInterface
  Structure _CounterPlus Extends _Counter
    _timestamp.i
  EndStructure
  DeclareClass(CounterPlus,Counter)
  
EndDeclareModule

Debug "--Test"
Define  *test.test::counter
*test=AllocateObject(test::Counter)
Debug "obj:"+Hex(*test)
Debug PeekI(*test)

Debug *test\Get()
*test\set(20)
Debug *test\get()
*test\add(20)
Debug *test\Get()

*test=FreeObject(*test)


Debug "--Test2"

Procedure reftest(*ref.test::CounterPlus)
  Debug "++in reftest"
  ReferenceObject(*ref)
  *ref\set(44)
  Debug *ref\Get()
  Debug *ref\GetTimestamp()
  *ref=FreeObject(*ref)
  Debug "++end reftest"
EndProcedure

Define *test2.test::CounterPlus=AllocateObject(test::CounterPlus)
Debug *test2\Get()
Debug *test2\GetTimestamp()
*test2\set(30)
Debug *test2\Get()
Debug *test2\GetTimestamp()
reftest(*test2)
*test2\add(30)
Debug *test2\Get()
Debug *test2\GetTimestamp()
*test2=FreeObject(*test2)


Interface CounterSub Extends test::CounterPlus
  Sub(value)
  text.s()
EndInterface
Structure _CounterSub Extends test::_CounterPlus
EndStructure
DeclareClass(Countersub,test::CounterPlus)

Procedure Class(CounterSub,Sub,(*self._CounterSub,value.i))
  *self\_value-value
EndProcedure
Procedure ClassS(Countersub,Text,(*self._CounterSub))
  Protected a$
  LockObject(*self)
  a$= "Stringreturn "+*self\_Value+" @"+*self\_timestamp
  UnlockObject(*self)
  ProcedureReturn a$
EndProcedure

Procedure ClassConstructor(Countersub,(*self._Countersub))
  Debug "New Countersub:"+Hex(*self)
  ProcedureReturn #True
EndProcedure
Procedure ClassDestructor(Countersub,(*self._Countersub))
  Debug "Free Countersub:"+Hex(*self)
EndProcedure
Procedure ClassCopyConstructor(CounterSub,(*self._CounterSub,*org._CounterSub))
  Debug "Copy CounterSub:"+Hex(*self)+" from "+Hex(*org)
  ProcedureReturn #True
EndProcedure
  
DefineClass(CounterSub)

Debug "-- Test3"
Define *test3.CounterSub=AllocateObject(CounterSub)
*test3\set(40)
Debug *test3\Get()
*test3\sub(20)
Debug *test3\Get()
Debug "*******************"
Debug *test3\text()
Debug "********************"

ReferenceObject(*test3)
Define *test4.Countersub=CopyObject(*test3)

FreeObject(*test3) ;because of reference
*test3=FreeObject(*test3)

Debug "--test4"
Debug *test4\Get()
*test4\set(10)
Debug *test4\get()

FreeObject(*test4)


Debug "--Defcheck"
Define *xx

Debug "counter"
*xx=AllocateObject(test::Counter)
Debug IsObject(*xx)
Debug "test::Counter:     "+IsClassObject(test::Counter,*xx)+" "+Bool(ClassId(test::Counter)=ObjectId(*xx))
Debug "test::CounterPlus: "+IsClassObject(test::CounterPlus,*xx)+" "+Bool(ClassId(test::CounterPlus)=ObjectId(*xx))
Debug "Countersub:        "+IsClassObject(Countersub,*xx)+" "+Bool(ClassId(Countersub)=ObjectId(*xx))

FreeObject(*xx)

Debug "counterplus"
*xx=AllocateObject(test::CounterPlus)
Debug IsObject(*xx)
Debug "test::Counter: "+IsClassObject(test::Counter,*xx)+" "+Bool(ClassId(test::Counter)=ObjectId(*xx))
Debug "test::CounterPlus: "+IsClassObject(test::CounterPlus,*xx)+" "+Bool(ClassId(test::CounterPlus)=ObjectId(*xx))
Debug "Countersub: "+IsClassObject(Countersub,*xx)+" "+Bool(ClassId(Countersub)=ObjectId(*xx))
FreeObject(*xx)

Debug "countersub"
*xx=AllocateObject(Countersub)
Debug IsObject(*xx)
Debug "test::Counter: "+IsClassObject(test::Counter,*xx)+" "+Bool(ClassId(test::Counter)=ObjectId(*xx))
Debug "test::CounterPlus: "+IsClassObject(test::CounterPlus,*xx)+" "+Bool(ClassId(test::CounterPlus)=ObjectId(*xx))
Debug "Countersub: "+IsClassObject(Countersub,*xx)+" "+Bool(ClassId(Countersub)=ObjectId(*xx))
FreeObject(*xx)

Define l.long
Debug "Faketest"
Debug IsObject(*xx)
Debug IsObject(l)
Debug IsObject(@l)

Module test
  Procedure Class(CounterPlus,Set, (*self._CounterPlus,value));-counterplus set
    *self\_Value=value
    *self\_timestamp=12
  EndProcedure
  Procedure Class(CounterPlus,Add, (*self._CounterPlus,value))
    *self\_Value+value
    *self\_timestamp=1
  EndProcedure
  Procedure Class(CounterPlus,GetTimestamp, (*self._CounterPlus))
    ProcedureReturn *self\_timestamp
  EndProcedure
  
  Procedure ClassConstructor(CounterPlus, (*self._CounterPlus))
    Debug "New Counterplus:"+Hex(*self)    
    ProcedureReturn #True
  EndProcedure
  Procedure ClassDestructor(CounterPlus, (*self._CounterPlus))
    Debug "Free Counterplus:"+Hex(*self)
  EndProcedure
  Procedure ClassCopyConstructor(CounterPlus, (*self._CounterPlus,*org._CounterPlus))
    Debug "Copy Counterplus:"+Hex(*self)+" from "+Hex(*org)
    ProcedureReturn #True
  EndProcedure
  DefineClass(CounterPlus)
  
  Procedure Class(Counter,Get, (*self._counter))
    ProcedureReturn *self\_Value
  EndProcedure
  Procedure Class(Counter,Set, (*self._counter,Value))
    *self\_Value=Value
  EndProcedure
  Procedure Class(Counter,Add, (*self._counter,Value=1))
    *self\_Value+Value
  EndProcedure
  Procedure ClassConstructor(counter, (*self._counter))
    Debug "New Counter:"+Hex(*self)
    ProcedureReturn #True
  EndProcedure
  Procedure ClassDestructor(counter, (*self._counter))
    Debug "Free Counter:"+Hex(*self)
  EndProcedure
  Procedure ClassCopyConstructor(Counter, (*self._Counter,*org._Counter))
    Debug "Copy Counter:"+Hex(*self)+" from "+Hex(*org) 
    ProcedureReturn #True
  EndProcedure
  
  DefineClass(counter)
EndModule
Debug "-------"
Debug "-------"

Interface Steuer Extends BaseClass
  set()
  get()
EndInterface
Structure _Steuer Extends _BaseClass
  value.i
EndStructure
DeclareClass(Steuer,BaseClass,(StartValue))

Procedure Steuer_Set(*self._steuer,value)
  *self\value=value
EndProcedure:AsMethod(Steuer,Set)

Procedure Class(Steuer,get,(*self._steuer))
  ProcedureReturn *self\value
EndProcedure
Procedure Steuer___Constructor(*self._steuer,StartValue)
  Debug "Steuer-Constructor "+Hex(*self)+" with Value:"+StartValue
  *self\value=StartValue
  ProcedureReturn #True
EndProcedure
DefineClass(Steuer,BaseClass,(StartValue))

Define x1.steuer=Steuer(10)
Debug x1\get()

Define x2.steuer=AllocateObject(Steuer,(20))
Debug x2\get()

Define x3.steuer=AllocateObject(Steuer,(30))
Debug x3\get()

Debug "----"

Interface SteuerP Extends Steuer
  text.s()
EndInterface
Structure _SteuerP Extends _Steuer
EndStructure
DeclareClass(SteuerP,Steuer,(StartValue))

Procedure classS(steuerP,Text,(*self._SteuerP))
  ProcedureReturn Str(*self\value)+"%"
EndProcedure
Procedure ClassConstructor(SteuerP,(*self._steuerP,StartValue))
  Debug "SteuerP-Constructor "+Hex(*self)+" with Value:"+StartValue
  ProcedureReturn #True
EndProcedure

DefineClass(SteuerP,Steuer,(StartValue))

Define x4.steuerp=SteuerP(123)
Debug x4\text()


DebugObject(x1)
DebugObject(x2)

Debug "Steuer:"+CountObject(steuer)
Debug "SteuerP:"+CountObject(steuerp)
FreeObject(x1)
Debug "Steuer:"+CountObject(steuer)
Debug "SteuerP:"+CountObject(steuerp)
FreeObject(x2)
Debug "Steuer:"+CountObject(steuer)
Debug "SteuerP:"+CountObject(steuerp)
FreeObject(x3)
Debug "Steuer:"+CountObject(steuer)
Debug "SteuerP:"+CountObject(steuerp)

DebugObject(x4)

Debug "Method CounterPlus\Timestamp "+Hex(GetClassMethod(test::CounterPlus,"GetTimeStamp"))
Debug "Method x4\text "+Hex(GetObjectMethod(x4,"text"))


Debug "Class test::counter get:"+Hex(GetClassNameMethod("teSt::CounTeR","Get"))
Debug "----"
Interface TestClass Extends test::Counter
  text.s()
EndInterface
Structure _TestClass Extends test::_Counter
EndStructure
DeclareClass(TestClass,Test::Counter)

Procedure.s TestClass_Text(*self.test::_Counter)
  ProcedureReturn Str(*self\_Value)
EndProcedure:AsMethod(TestClass,Text)
DefineClass(TestClass)
Zuletzt geändert von GPI am 14.05.2017 17:33, insgesamt 3-mal geändert.
CodeArchiv Rebirth: Deutsches Forum Github Hilfe ist immer gern gesehen!
Benutzeravatar
RSBasic
Admin
Beiträge: 8022
Registriert: 05.10.2006 18:55
Wohnort: Gernsbach
Kontaktdaten:

Re: Klassen/Objecte mittels RES-Datei und Runtime

Beitrag von RSBasic »

Vielen Dank für die vielen Informationen, klingt sehr interessant. :allright:
Aus privaten Gründen habe ich leider nicht mehr so viel Zeit wie früher. Bitte habt Verständnis dafür.
Bild
Bild
GPI
Beiträge: 1511
Registriert: 29.08.2004 13:18
Kontaktdaten:

Re: Klassen/Objecte mittels RES-Datei und Runtime

Beitrag von GPI »

RSBasic hat geschrieben:Vielen Dank für die vielen Informationen, klingt sehr interessant. :allright:
Gibts zu, das interessanteste ist, das Macros in RES gespeichert werden. :)
Übrigens: Prototypen werden nicht gespeichert und Structuren mit Prototypen erzeugen eine RES-File, die den Compiler beim einlesen der RES-File abschmieren lassen.

Ich hab das ganze mal auf 1.1 Geupdated, das hier ist neu:
  • Der Referenz-Zähler startet jetzt mit 0 und nicht mit 1.
  • Class.pbi ist jetzt so geschrieben, das sie gleichzeitig als REF-Source-Datei verwendet werden kann, oder wer das nicht mag, als normale Include-Datei. Man muss aber dann überall, wo Klassen oder Objecte verwendet werden ein UseModule Class einfügen
AsMethod(<Class>,<Method>)
Damit kann man eine Procedure als Klassen-Methode definieren. Wichtig ist, das die Procedure declariert sein muss und sie muss den Namen <Class>_<Method> besitzen. Das ganze kann als Alternative für Class(<ClassName>,<Method>,<Parameterblock>). Man kann problemlos beide Arten mischen.

Code: Alles auswählen

Procedure Steuer_Set(*self._steuer,value)
  *self\value=value
EndProcedure:AsMethod(Steuer,Set)
Procedure Class(Steuer,get,(*self._steuer))
  ProcedureReturn *self\value
EndProcedure
Damit bleibt der Procedure-Browser intakt. Schreibt sich aber imo nicht mehr so schön. Geschmackssache :)
Für die drei Konstruktoren lauten die Namen <Class>___Constructor, <Class>___Destructor und <Class>___CopyConstructor (Man beachte die drei Unterstriche). Hier darf auch kein AsMethod benutzt werden, weil es ja keine Methoden sind.

GetClassMethod(<class>,method.s)
Ermittelt zu einer Klasse eine bestimmte Methode und gibt die Adresse der Procedure zurück, oder 0 wenn es die Methode nicht gibt.

Code: Alles auswählen

Debug "Method CounterPlus\Timestamp "+Hex(GetClassMethod(test::CounterPlus,"GetTimeStamp"))
GetObjectMethod(<Object>,method.s)
Wie oben, nur wird hier nach einer Methode eines Objekts gesucht.

Code: Alles auswählen

Debug "Method x4\text "+Hex(GetObjectMethod(x4,"text"))
DeclareDebugObject()
DefineDebugObject()
DebugObject(<Object>)

Leider muss man den Befehl erst Definieren, sonst ist er nicht einsetzbar (REF-Version/bei der Includeversion ist das schon passiert). Er gibt in Debug-Fenster aus, zu welchen Klasse das Objekt gehört und welche Methoden es kennt.

Code: Alles auswählen

DebugObject(x4)
Output hat geschrieben:OUTPUT OBJECT x4 @49B0C70 of SteuerP
Set @14000AF7C
get @140008B18
Text @1400077CD
OUTPUT END
DeclareGetClassNameMethod()
DefineGetClassNameMethod()
GetClassNameMethod(ClassName.s,Method.s)

Auch hier muss man zuerst die Procedure definieren (REF-Version/bei der Includeversion ist das schon passiert). Funktioniert ähnlich wie GetClassMethod(), nur das hier zwei Strings übergeben werden. Wichtig beim Klassenname ist, das der Modulname *IMMER* (falls vorhanden) angegeben werden muss, auch wenn das Modul eigentlich mit UseModule verfügbar ist.

Code: Alles auswählen

Debug "Class test::counter get:"+Hex(GetClassNameMethod("teSt::CounTeR","Get"))
CodeArchiv Rebirth: Deutsches Forum Github Hilfe ist immer gern gesehen!
GPI
Beiträge: 1511
Registriert: 29.08.2004 13:18
Kontaktdaten:

Re: Klassen/Objecte mittels RES-Datei und Runtime

Beitrag von GPI »

Für meine COM-Object-Lösung hab ich das ganze nochmals überarbeitet

;* Changelog 1.2
; - CHANGE: GetReference and FreeObject now return the reference-counter
; - CHANGE: Constructors must return #true, otherwise the object is released
; - NEW: It is now possible, that a subclass has start-parameter and the superclass not
; - CHANGE: First Parameter *obj of define/declareclass changed to *self
; - NEW: ThreadSafe_DeclareClass declares a class threadsafe
; - NEW GetObjectIndex and GetClassIndex
; - Change: Referece starts now with 1 instead of 0 again :)

so und jetzt editiere ich mal den ersten Post um auf aktuellen stand zu kommen :)
CodeArchiv Rebirth: Deutsches Forum Github Hilfe ist immer gern gesehen!
GPI
Beiträge: 1511
Registriert: 29.08.2004 13:18
Kontaktdaten:

Re: Klassen/Objecte mittels RES-Datei und Runtime

Beitrag von GPI »

Neu in 1.3 - Bugfixes und eine kleine Erweiterung für ExportCom
CodeArchiv Rebirth: Deutsches Forum Github Hilfe ist immer gern gesehen!
GPI
Beiträge: 1511
Registriert: 29.08.2004 13:18
Kontaktdaten:

Re: Klassen/Objecte mittels RES-Datei und Runtime

Beitrag von GPI »

So aktualisiert auf 1.4
Bei Classen mit StartParameter muss man jetzt nicht mehr den zweiten Parameterblock (*self,...) hinzufügen.
Ich hab dazu ein paar eigentlich hässliche Verrenkungen machen müssen, aber es klappt gut :)

Viel Spaß damit
CodeArchiv Rebirth: Deutsches Forum Github Hilfe ist immer gern gesehen!
Antworten