Class-Definition with RES-Files

Share your advanced PureBasic knowledge/code with the community.
GPI
PureBasic Expert
PureBasic Expert
Posts: 1394
Joined: Fri Apr 25, 2003 6:41 pm

Class-Definition with RES-Files

Post by GPI »

It is possible to store Macros to RES-Files and i searched for a solution to handle Class with this RES-Files. The big advantage of this method is, that the are automatic loaded by the compiler and they are activ everywhere without copying files or "XIncludeFile". My solution can both, work as RES-File and as Includefile.

[Threadsafe_]DeclareClass(<class>[,<SuperClass>[,(<Startparameter>)]])
It is easy to declare a class. Simpel create an Interface and a Structure. The Structure should have the same name as the Interface, but with a underline (_) at the start. The should EXTENDS the BaseClass (or _BaseClass) (alternativ you can add a __VT.i as first element of the structure. BaseClass contain only this entry).
With DeclareClass you finalize the declaration. (We talk about Threadsafe and Start-Parameter later)

Code: Select all

Interface Counter Extends BaseClass
  Get()
  Set(Value)
  Add(Value=1)
EndInterface
Structure _Counter Extends _BaseClass
  _Value.i
EndStructure
DeclareClass(Counter)
You can use this declaration in DeclareModule-Part of a module.

AllcoateObject(<Class> [,(<StartParameter>)])
FreeObject(<object>)
After the declaration you can use the class already. With AllocateObject(<Class>) or <Class>() you create a new object. FreeObject(<Object>) destroy the object.

Code: Select all

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>))
The definition of a method is not so easy, there a two possibilities. First ist to use Class(<ClassName>,<Method>,<Parameter>) as Procedure Name. The first parameter of the parameter block must be *self When you want to return a string, you must use ClassS(), for double ClassD() and so on.

Code: Select all

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>)
The second possibility is to write a normal procedure with <class>_<method> as name and add the AsMethod() after the procedure.

Code: Select all

Procedure Counter_Add(*self._counter.Value=1)
  *self\_Value+Value
EndProcedure:AsMethod(Counter,Add)
You can mix both methods.

When you inherit a class, you can overwrite the method of the SuperClass (Parent).


ClassConstructor(<Class>,(<Parameter>))
ClassDestructor(<Class>,(<Parameter>))
ClassCopyConstructor(<Class>,(<Parameter>))
My routines support a constructors and destructors. You can use this three macros to use it like the Class-Macro above. Or you can use the direct procedure-names:<Class>___Constuctor(), <Class>__Destructor() and <Class>___CopyConstructor(). Important: There are three underlines! And you should not use AsMethod().
Constructors and destructors will not be overwritten, instead they are all executed. First the SuperClass (parent) Constructor then the SubClass (child) Constructor. Destructors in reverse order. Constructors must return #true otherwise the creation of the object will fail.

Code: Select all

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>)]])
After all methods are defined, you must finalize the class with this command.
One important rule: Don't define a Method of a diffrent class between the first method-definition and the final DefineClass()!

Code: Select all

DefineClass(counter)
Here a example for a heredity:

Code: Select all

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)
Other helpful macros:

ReferenceObject(<Object>)
Increase the reference counter of an Object. For every Reference it is necessary to call a FreeObject() to destroy the object.
Return the number of the activ references.

CountReferenceObject(<Object>)
Return the count of references of an object.

CopyObject(<Object>)
Create a copy of a object and return it. If it fails #Null.

IsClassObject(<ClassName>,<Object>)
Check if an object is part of the class. Important: A Object of a subclass (child) is always part of the SuperClass (parent).

IsObject(<Object>)
Check if an object is really a object created with this routines. IMPORTANT: To check this, the routines use a PEEKI() to the adress one Integer below the object. There is a check, if the Object ist #null.

ClassId(<Class>)
Return the ClassID of the class. (btw. this is the VTable)

ObjectId(<Object>)
Return the ClassId of an Object. When you need to know, it the class of an Object is really identical to a spezific class, compare the ClassId() with the ObjectId()

CountObject(<Class>)
Return how many object of a class exist. Useful to find memory leaks.

GetClassMethod(<class>,method.s)
Return the adress of the method or #Null.

Code: Select all

Debug "Method CounterPlus\Timestamp "+Hex(GetClassMethod(test::CounterPlus,"GetTimeStamp"))
GetObjectMethod(<Object>,method.s)
Same as above, but from an Object.

Code: Select all

Debug "Method x4\text "+Hex(GetObjectMethod(x4,"text"))
GetClassIndex(<class>,method.s) and [GetObjectIndex(<class>,method.s)[/b]
like above, but return the index in the VTable (start with 0) or -1, if the method doesn't exist.

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

You must define DebugObject with the command above, before you can use it. It output the object with it methods. Like the Debug command, without activ debugger this commands are removed complete automatically.

Code: Select all

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

Work like GetClassMethod(), but this time ClassName is a String. Important: the module-name is not optional!

Code: Select all

Debug "Class test::counter get:"+Hex(GetClassNameMethod("teSt::CounTeR","Get"))
GetObjectClassName(<obj>)
Return the name of the class of an object.

GetClassIdName(classid)
Return the name of an ClassId.

Threadsafe
When you need an object to be threadsafe, you should declare it with Threadsafe_DeclareClass() IMPORTANT: You must secure the methods by your own!

LockObject(Object) and UnlockObject(Object)
Lock the object with a mutex. You can use this two commands, even the class is not threadsafe.
You should not lock the object in the constructors and destructors.

Optional startparmater

Simple add a parameter-block in the DeclareClass() and DefineClass() command. And don't forget to add a constructor. When a SuperClass has parameter, a SubClass must have the same. When the Superclass has no parameter, a SubClass can have some!

Code: Select all

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))
And how to use it:

Code: Select all

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()
Last edited by GPI on Sun May 14, 2017 5:43 pm, edited 2 times in total.
GPI
PureBasic Expert
PureBasic Expert
Posts: 1394
Joined: Fri Apr 25, 2003 6:41 pm

Re: Class-Definition with RES-Files

Post by GPI »

Unfortunately the IDE doesn't support the creation of RES-files. I use this little programm to create on (windows).
Important: When you have installed Pure Basic in the program files directory, you need admin rights to create a res file:
Important 2: When you have create the res-file, you must restart the compiler!
Class.pb

Code: Select all

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
Class.pbi

Code: Select all

;    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: http://www.purebasic.fr/english/viewtopic.php?f=12&t=68475
;   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
;}
GPI
PureBasic Expert
PureBasic Expert
Posts: 1394
Joined: Fri Apr 25, 2003 6:41 pm

Re: Class-Definition with RES-Files

Post by GPI »

And finally an example

Code: Select all

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)
Post Reply