FiveTech Software tech support forums

www.FiveTechSoft.com
https://forums.fivetechsupport.com/

Dinamically building the Classes hierarchy tree

https://forums.fivetechsupport.com/viewtopic.php?t=23851

Page 1 of 1

Dinamically building the Classes hierarchy tree

Posted: Tue Apr 10, 2012 11:11 am
by 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

#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()


Image

Re: Dinamically building the Classes hierarchy tree

Posted: Tue Apr 10, 2012 11:37 am
by Antonio Linares
Enhanced version:

ClassTree.prg

Code: Select all | Expand

#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()


Image

Re: Dinamically building the Classes hierarchy tree

Posted: Tue Apr 10, 2012 12:25 pm
by 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 :-)

Image

Image

Re: Dinamically building the Classes hierarchy tree

Posted: Tue Apr 10, 2012 12:35 pm
by 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 ? :-)

Re: Dinamically building the Classes hierarchy tree

Posted: Tue Apr 10, 2012 9:49 pm
by Antonio Linares
Enhanced version:

ClassTree.prg

Code: Select all | Expand

#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()


Image

Re: Dinamically building the Classes hierarchy tree

Posted: Tue Apr 10, 2012 10:42 pm
by carlos vargas
antonio error y hbclass no muestran info, es correcto?

salu2

Re: Dinamically building the Classes hierarchy tree

Posted: Thu Feb 07, 2013 9:02 pm
by 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

#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

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

Re: Dinamically building the Classes hierarchy tree

Posted: Thu Feb 07, 2013 9:38 pm
by Antonio Linares
Faltaba corregir esto :-)

Code: Select all | Expand

function GetClasses()

   local n := 1, oClass

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

Re: Dinamically building the Classes hierarchy tree

Posted: Thu Feb 07, 2013 9:56 pm
by 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
All times are UTC
Page 1 of 1

Powered by phpBB® Forum Software © phpBB Limited