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

#include "FiveWin.ch"static aClasses := {}function Main()   local oWnd   DEFINE WINDOW oWnd TITLE "Classes hierarchy"   ACTIVATE WINDOW oWnd ;      ON INIT BuildClassesTree( oWnd )return nilfunction 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 nilCLASS TClass   DATA   cName   DATA   cSuper   DATA   aChilds INIT {}   METHOD New( cName )   METHOD GetSuper()   METHOD GetChilds()ENDCLASSMETHOD New( cName ) CLASS TClass   ::cName  = cName   ::cSuper = ""return SelfMETHOD 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   nextreturn nilMETHOD GetChilds() CLASS TClass   local oClass   for each oClass in aClasses      if oClass:cSuper == ::cName         AAdd( ::aChilds, oClass )      endif   nextreturn nil function Error()return ErrorNew()

[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 nilfunction 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 nilfunction AddChilds( oItem, aChilds )   local oChild, oSubItem   for each oChild in aChilds      oSubItem = oItem:Add( oChild:cName )      AddChilds( oSubItem, oChild:aChilds )    nextreturn nilfunction 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()   nextreturn nilCLASS TClass   DATA   cName   DATA   cSuper   DATA   aChilds INIT {}   METHOD New( cName )   METHOD GetSuper()   METHOD GetChilds()ENDCLASSMETHOD New( cName ) CLASS TClass   ::cName  = cName   ::cSuper = ""return SelfMETHOD 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   nextreturn nilMETHOD GetChilds() CLASS TClass   local oClass   for each oClass in aClasses      if oClass:cSuper == ::cName         AAdd( ::aChilds, oClass )      endif   nextreturn 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

#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"   ENDMENUreturn 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( {} )   endifreturn 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 )    nextreturn 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()   nextreturn 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   nextreturn nil//----------------------------------------------------------------------------//METHOD GetChilds() CLASS TClass   local oClass   for each oClass in aClasses      if oClass:cSuper == ::cName         AAdd( ::aChilds, oClass )      endif   nextreturn 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

#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"   ENDMENUreturn 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( {} )   endifreturn 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 )    nextreturn 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()   nextreturn 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   nextreturn nil//----------------------------------------------------------------------------//METHOD GetChilds() CLASS TClass   local oClass   for each oClass in aClasses      if oClass:cSuper == ::cName         AAdd( ::aChilds, oClass )      endif   nextreturn nil //----------------------------------------------------------------------------//function Error()return ErrorNew()//----------------------------------------------------------------------------//CLASS TObject FROM HBObject  // To expose its datas and methodsENDCLASS//----------------------------------------------------------------------------//

[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    ... 

[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