Dinamically building the Classes hierarchy tree

[Antonio Linares]

A first try to dinamically build a Classes hierarchy tree from the used Classes in your app

classtree.prg

Code: Select all  Expand view

#include "FiveWin.ch"

static aClasses := {}

function Main()

   local oWnd

   DEFINE WINDOW oWnd TITLE "Classes hierarchy"

   ACTIVATE WINDOW oWnd ;
      ON INIT BuildClassesTree( oWnd )

return nil

function BuildClassesTree( oWnd )

   local n := 1, oClass, oTree, oItem, oChild

   while ! Empty( __ClassName( n ) )
      AAdd( aClasses, TClass():New( __ClassName( n++ ) ) )
   end

   for each oClass in aClasses
      oClass:GetSuper()
   next

   for each oClass in aClasses
      oClass:GetChilds()
   next

   oTree = TTreeView():New( 1, 1, oWnd )
   oTree:nWidth = 152
   // oTree:SetImageList( oImageList )
   // oTree:Add( "Files" )
   for each oClass in aClasses
     if Empty( oClass:cSuper )
        oItem = oTree:Add( oClass:cName )
        for each oChild in oClass:aChilds
           oItem:Add( oChild:cName )
        next
     endif
   next

   oTree:Expand()

return nil

CLASS TClass

   DATA   cName
   DATA   cSuper
   DATA   aChilds INIT {}

   METHOD New( cName )

   METHOD GetSuper()

   METHOD GetChilds()

ENDCLASS

METHOD New( cName ) CLASS TClass

   ::cName  = cName
   ::cSuper = ""

return Self

METHOD GetSuper() CLASS TClass

   local oClass, oInstance := &( ::cName + "()" )

   for each oClass in aClasses
      try
         if oInstance:IsDerivedFrom( oClass:cName ) .and. ::cName != oClass:cName
            ::cSuper = oClass:cName
         endif
      end
   next

return nil

METHOD GetChilds() CLASS TClass

   local oClass

   for each oClass in aClasses
      if oClass:cSuper == ::cName
         AAdd( ::aChilds, oClass )
      endif
   next

return nil

function Error()

return ErrorNew()

[Antonio Linares]

Enhanced version:

ClassTree.prg

Code: Select all  Expand view

#include "FiveWin.ch"

static aClasses := {}

function Main()

   local oWnd, o := TDialog()

   DEFINE WINDOW oWnd TITLE "Classes hierarchy"

   ACTIVATE WINDOW oWnd ;
      ON INIT BuildClassesTree( oWnd )

return nil

function BuildClassesTree( oWnd )

   local oTree := TTreeView():New( 1, 1, oWnd )
   local oClass

   oTree:nWidth = 200
   oWnd:oLeft = oTree

   // oTree:SetImageList( oImageList )

   GetClasses()
 
   for each oClass in aClasses
     if Empty( oClass:cSuper )
        AddChilds( oTree:Add( oClass:cName ), oClass:aChilds )
     endif
   next

   oTree:Expand()

return nil

function AddChilds( oItem, aChilds )

   local oChild, oSubItem

   for each oChild in aChilds
      oSubItem = oItem:Add( oChild:cName )
      AddChilds( oSubItem, oChild:aChilds )
   next

return nil

function GetClasses()

   local n := 1, oClass

   while ! Empty( __ClassName( n ) )
      AAdd( aClasses, TClass():New( __ClassName( n++ ) ) )
   end

   for each oClass in aClasses
      oClass:GetSuper()
   next

   for each oClass in aClasses
      oClass:GetChilds()
   next

return nil

CLASS TClass

   DATA   cName
   DATA   cSuper
   DATA   aChilds INIT {}

   METHOD New( cName )

   METHOD GetSuper()

   METHOD GetChilds()

ENDCLASS

METHOD New( cName ) CLASS TClass

   ::cName  = cName
   ::cSuper = ""

return Self

METHOD GetSuper() CLASS TClass

   local oClass, oInstance := &( ::cName + "()" )

   for each oClass in aClasses
      try
         if oInstance:IsDerivedFrom( oClass:cName ) .and. ::cName != oClass:cName
            ::cSuper = oClass:cName
         endif
      end
   next

return nil

METHOD GetChilds() CLASS TClass

   local oClass

   for each oClass in aClasses
      if oClass:cSuper == ::cName
         AAdd( ::aChilds, oClass )
      endif
   next

return nil

function Error()

return ErrorNew()

[Antonio Linares]

This screenshot is back from 1991 and belongs to Actor (c) Whitewater Group, lately acquired and abandoned by Symantec:

http://en.wikipedia.org/wiki/Actor_(programming_language)

Lets see how close we can take our example to this browser

[Antonio Linares]

BTW, I own an original copy of Actor, but classes source code is not included.

Someone of you have a copy of it with Classes sources ?

[Antonio Linares]

Enhanced version:

ClassTree.prg

Code: Select all  Expand view

#include "FiveWin.ch"
#include "Splitter.ch"

static aClasses := {}, oSplit1, oSplit2, oLbxDatas, oLbxMethods

//----------------------------------------------------------------------------//

function Main()

   local oWnd, o := TDialog()

   DEFINE WINDOW oWnd TITLE "Classes hierarchy" ;
      MENU BuildMenu()

   ACTIVATE WINDOW oWnd ;
      ON INIT BuildClassesTree( oWnd ) ;
      ON RESIZE ( If( oSplit1 != nil, oSplit1:AdjLeft(),),;
                  If( oSplit2 != nil, oSplit2:AdjRight(),) )

return nil

//----------------------------------------------------------------------------//

function BuildMenu()

   local oMenu

   MENU oMenu
      MENUITEM "About"
   ENDMENU

return oMenu

//----------------------------------------------------------------------------//

function BuildClassesTree( oWnd )

   local oTree := TTreeView():New( 0, 0, oWnd )
   local oClass, cData, cMethod

   oTree:nWidth = 180
   // oTree:SetImageList( oImageList )

   oTree:Expand()

   @ 0, 186 LISTBOX oLbxDatas VAR cData ITEMS { "one", "two", "three" } ;
      SIZE 200, 200 PIXEL OF oWnd

   @ 0, 391 LISTBOX oLbxMethods VAR cMethod ITEMS { "one", "two", "three" } ;
      SIZE 200, 200 PIXEL OF oWnd

   @ 0, 181 SPLITTER oSplit1 ;
      VERTICAL ;
      PREVIOUS CONTROLS oTree ;
      HINDS CONTROLS oLbxDatas ;
      LEFT MARGIN 150 ;  
      RIGHT MARGIN oSplit2:nLast + 100 ;
      SIZE 4, 300  PIXEL ;
      OF oWnd STYLE

   @ 0, 386 SPLITTER oSplit2 ;
      VERTICAL ;
      PREVIOUS CONTROLS oLbxDatas ;
      HINDS CONTROLS oLbxMethods ;
      LEFT MARGIN oSplit1:nFirst + 120 ;
      RIGHT MARGIN 80 ;
      SIZE 4, 300 PIXEL ;
      OF oWnd STYLE

   GetClasses()
 
   for each oClass in aClasses
     if Empty( oClass:cSuper )
        AddChilds( oTree:Add( oClass:cName ), oClass:aChilds )
     endif
   next

   oTree:bChanged = { || ShowClassInfo( oTree ) }

return nil

//----------------------------------------------------------------------------//

function ShowClassInfo( oTree )

   local oItem := oTree:GetSelected()

   if oItem != nil .and. oItem:Cargo != nil
      oLbxDatas:SetItems( oItem:Cargo:aDatas )
      oLbxMethods:SetItems( oItem:Cargo:aMethods )
   else
      oLbxDatas:SetItems( {} )
      oLbxMethods:SetItems( {} )
   endif

return nil

//----------------------------------------------------------------------------//

function AddChilds( oItem, aChilds )

   local oChild, oSubItem

   for each oChild in aChilds
      oSubItem = oItem:Add( oChild:cName )
      oSubItem:Cargo = oChild      
      AddChilds( oSubItem, oChild:aChilds )
   next

return nil

//----------------------------------------------------------------------------//

function GetClasses()

   local n := 1, oClass

   while ! Empty( __ClassName( n ) )
      AAdd( aClasses, TClass():New( __ClassName( n++ ) ) )
   end

   for each oClass in aClasses
      oClass:GetSuper()
   next

   for each oClass in aClasses
      oClass:GetChilds()
   next

return nil

//----------------------------------------------------------------------------//

CLASS TClass

   DATA   cName
   DATA   cSuper
   DATA   aChilds INIT {}
   DATA   aDatas
   DATA   aMethods

   METHOD New( cName )

   METHOD GetSuper()

   METHOD GetChilds()

ENDCLASS

//----------------------------------------------------------------------------//

METHOD New( cName ) CLASS TClass

   ::cName  = cName
   ::cSuper = ""

return Self

//----------------------------------------------------------------------------//

METHOD GetSuper() CLASS TClass

   local oClass, oInstance := &( ::cName + "()" )

   if ::aDatas == nil
      ::aDatas   = __objGetMsgList( oInstance, .T. )
      ::aMethods = __objGetMsgList( oInstance, .F. )
   endif

   for each oClass in aClasses
      try
         if oInstance:IsDerivedFrom( oClass:cName ) .and. ::cName != oClass:cName
            ::cSuper = oClass:cName
         endif
      end
   next

return nil

//----------------------------------------------------------------------------//

METHOD GetChilds() CLASS TClass

   local oClass

   for each oClass in aClasses
      if oClass:cSuper == ::cName
         AAdd( ::aChilds, oClass )
      endif
   next

return nil

//----------------------------------------------------------------------------//

function Error()

return ErrorNew()

[carlos vargas]

antonio error y hbclass no muestran info, es correcto?

salu2

[Antonio Linares]

Carlos,

Si, es correcto puesto que esa información no la expone Harbour.

Puedes probar a construirlo con la versión más reciente de Harbour. No funciona bien.

De momento lo he corregido asi, pero sigue estando mal:

Code: Select all  Expand view

#include "FiveWin.ch"
#include "Splitter.ch"

static aClasses := {}, oSplit1, oSplit2, oLbxDatas, oLbxMethods

//----------------------------------------------------------------------------//

function Main()

   local oWnd, o := TDialog(), x := TObject()

   DEFINE WINDOW oWnd TITLE "Classes hierarchy" ;
      MENU BuildMenu()

   ACTIVATE WINDOW oWnd ;
      ON INIT BuildClassesTree( oWnd ) ;
      ON RESIZE ( If( oSplit1 != nil, oSplit1:AdjLeft(),),;
                  If( oSplit2 != nil, oSplit2:AdjRight(),) )

return nil

//----------------------------------------------------------------------------//

function BuildMenu()

   local oMenu

   MENU oMenu
      MENUITEM "About"
   ENDMENU

return oMenu

//----------------------------------------------------------------------------//

function BuildClassesTree( oWnd )

   local oTree := TTreeView():New( 0, 0, oWnd )
   local oClass, cData, cMethod

   oTree:nWidth = 180
   // oTree:SetImageList( oImageList )

   oTree:Expand()

   @ 0, 186 LISTBOX oLbxDatas VAR cData ITEMS { "one", "two", "three" } ;
      SIZE 200, 200 PIXEL OF oWnd

   @ 0, 391 LISTBOX oLbxMethods VAR cMethod ITEMS { "one", "two", "three" } ;
      SIZE 200, 200 PIXEL OF oWnd

   @ 0, 181 SPLITTER oSplit1 ;
      VERTICAL ;
      PREVIOUS CONTROLS oTree ;
      HINDS CONTROLS oLbxDatas ;
      LEFT MARGIN 150 ;  
      RIGHT MARGIN oSplit2:nLast + 100 ;
      SIZE 4, 300  PIXEL ;
      OF oWnd STYLE

   @ 0, 386 SPLITTER oSplit2 ;
      VERTICAL ;
      PREVIOUS CONTROLS oLbxDatas ;
      HINDS CONTROLS oLbxMethods ;
      LEFT MARGIN oSplit1:nFirst + 120 ;
      RIGHT MARGIN 80 ;
      SIZE 4, 300 PIXEL ;
      OF oWnd STYLE

   GetClasses()
 
   for each oClass in aClasses
     if Empty( oClass:cSuper )
        // oClass:cSuper = oClass:Super:ClassName()
        AddChilds( oTree:Add( oClass:cName ), oClass:aChilds )
        if oClass:Cargo == nil
           // oClass:Cargo = oClass // TObject()
        endif    
     endif
   next

   oTree:bChanged = { || ShowClassInfo( oTree ) }

return nil

//----------------------------------------------------------------------------//

function ShowClassInfo( oTree )

   local oItem := oTree:GetSelected()

   if oItem != nil .and. oItem:Cargo != nil
      oLbxDatas:SetItems( oItem:Cargo:aDatas )
      oLbxMethods:SetItems( oItem:Cargo:aMethods )
   else
      oLbxDatas:SetItems( {} )
      oLbxMethods:SetItems( {} )
   endif

return nil

//----------------------------------------------------------------------------//

function AddChilds( oItem, aChilds )

   local oChild, oSubItem

   for each oChild in aChilds
      oSubItem = oItem:Add( oChild:cName )
      oSubItem:Cargo = oChild      
      AddChilds( oSubItem, oChild:aChilds )
   next

return nil

//----------------------------------------------------------------------------//

function GetClasses()

   local n := 1, oClass

   while ! Empty( __ClassName( n++ ) )
      AAdd( aClasses, TClass():New( __ClassName( n++ ) ) )
   end

   for each oClass in aClasses
      oClass:GetSuper()
   next

   for each oClass in aClasses
      oClass:GetChilds()
   next

return nil

//----------------------------------------------------------------------------//

CLASS TClass

   DATA   cName
   DATA   cSuper
   DATA   aChilds INIT {}
   DATA   aDatas
   DATA   aMethods

   METHOD New( cName )

   METHOD GetSuper()

   METHOD GetChilds()

ENDCLASS

//----------------------------------------------------------------------------//

METHOD New( cName ) CLASS TClass

   ::cName  = cName
   ::cSuper = ""

return Self

//----------------------------------------------------------------------------//

METHOD GetSuper() CLASS TClass

   local oClass, oInstance
     
   try
      oInstance := &( ::cName + "()" )
   end  
     
   if ! hb_IsObject( oInstance )
      return nil
   endif      
     
   if ::aDatas == nil
      ::aDatas   = __objGetMsgList( oInstance, .T. )
      ::aMethods = __objGetMsgList( oInstance, .F. )
   endif

   for each oClass in aClasses
      try
         if oInstance:IsDerivedFrom( oClass:cName ) .and. ::cName != oClass:cName
           ::cSuper = oClass:cName
         endif
      end
   next

return nil

//----------------------------------------------------------------------------//

METHOD GetChilds() CLASS TClass

   local oClass

   for each oClass in aClasses
      if oClass:cSuper == ::cName
         AAdd( ::aChilds, oClass )
      endif
   next

return nil

//----------------------------------------------------------------------------//

function Error()

return ErrorNew()

//----------------------------------------------------------------------------//

CLASS TObject FROM HBObject  // To expose its datas and methods

ENDCLASS

//----------------------------------------------------------------------------//

[Antonio Linares]

Faltaba corregir esto

Code: Select all  Expand view

function GetClasses()

   local n := 1, oClass

   while ! Empty( __ClassName( n ) )
      AAdd( aClasses, TClass():New( __ClassName( n++ ) ) )
   end
 
   ...
 

[Antonio Linares]

Creo que hay un bug en Harbour ya que:

hb_IsObject( Date() )

devuelve falso

sin embargo:

MsgInfo( Date():Super:ClassName() )

devuelve el valor correcto, luego lo trata como un objeto