"======================================================================
|
|   Smalltalk Blox based class browser example
|
|   $Revision: 1.7.5$
|   $Date: 2000/05/28 16:56:52$
|   $Author: pb$
|
 ======================================================================"

 

"======================================================================
|
| Copyright 1988-92, 1994-95, 1999, 2000 Free Software Foundation, Inc.
| Written by Steve Byrne.
|
| This file is part of GNU Smalltalk.
|
| GNU Smalltalk is free software; you can redistribute it and/or modify it
| under the terms of the GNU General Public License as published by the Free
| Software Foundation; either version 2, or (at your option) any later version.
| 
| GNU Smalltalk is distributed in the hope that it will be useful, but WITHOUT
| ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
| FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more
| details.
| 
| You should have received a copy of the GNU General Public License along with
| GNU Smalltalk; see the file COPYING.  If not, write to the Free Software
| Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.  
|
 ======================================================================"

PackageLoader fileInPackage: 'Blox'!


"----------------------------------------------------------------------
from here down are hacks to get the browser back on the air.  
These are not part of the normal code.
"

Smalltalk at: #HandleErrorsWithGui put: false!
Smalltalk at: #KeepBrowserRunning put: true!


"
----------------------------------------------------------------------
"


Gui subclass: #MessageSetBrowser
       instanceVariableNames: 'collection methodSourceView'
       classVariableNames: ''
       poolDictionaries: ''
       category: 'Graphics-Browser'
! 

!MessageSetBrowser class methodsFor: 'instance creation'!

on: aCollection label: aString
    ^super new
	init: aCollection
	label: aString, ' (', aCollection size printString, ')'
! !

!MessageSetBrowser methodsFor: 'callbacks'!

methodSelectedFrom: receiver at: anIndex
    | assoc |
    assoc := receiver at: anIndex.
    methodSourceView contents: (assoc key "class" 
				    sourceCodeAt: assoc value "selector" ).
! !


!MessageSetBrowser methodsFor: 'private'!

init: aCollection label: aString
    | toplevel container list text labels label |
    collection := aCollection.

    toplevel := BWindow new: aString.
    toplevel width: self browserWidth height: self browserWidth.
    container := BContainer new: toplevel.

    labels := OrderedCollection new: collection size.
    collection do: 
	[ :assoc | label := (self classNameString: assoc key) ,
		       '>>#', assoc value.
		   labels add: label ].

    list := BList new: container.
    list height: 100; width: self browserWidth.
    list contents: labels elements: collection.
    list callback: self message: #methodSelectedFrom:at:.

    methodSourceView := BText new: container.
    methodSourceView width: self browserWidth; height: 200.

    toplevel map.
!

browserWidth
    ^300
!

classNameString: anObject
    | name |
    name := anObject name.
    name isNil
    	ifTrue: [ name := anObject instanceClass name, ' class' ].
    ^name
! !



Gui subclass: #FirstBrowser
       instanceVariableNames: 'text methodList selectedClass showInherited 
			       container toplevel selectors sortedSelectors
			       showClassMethods browsedSelector'
       classVariableNames: 'ClassList'
       poolDictionaries: ''
       category: 'Graphics-Browser'
! 


!FirstBrowser class methodsFor: 'instance creation'!

new
    ^super new init
! !


!FirstBrowser methodsFor: 'callbacks'!

classSelectedFrom: receiver at: anIndex
    | className index |
    className := (receiver at: anIndex).
    (index := className findFirst: [ :ch | ch ~~ Character space ]) > 0
	ifTrue: [ className := className copyFrom: index to: className size ].

    selectedClass := Smalltalk at: className asSymbol.

    self updateDisplay.
!

updateDisplay
    | class | 
    selectedClass notNil
	ifTrue: [ class := selectedClass.
		  showClassMethods
		      ifTrue: [ class := class class ].
		  showInherited
		      ifTrue: [ selectors := class allSelectors ]
		      ifFalse: [ selectors := class selectors ].
		  sortedSelectors 
		      ifTrue: [ selectors := selectors asSortedCollection ].
		  methodList contents: selectors.
		  ].
!

updateDisplaySorted
    selectors notNil
	ifTrue: [ sortedSelectors 
		      ifTrue: [ methodList contents: selectors asSortedCollection ] ].
!


methodSelectedFrom: receiver at: anIndex
    | methodString class |

    browsedSelector := receiver at: anIndex.
    showClassMethods
	ifTrue: [ class := selectedClass class ]
	ifFalse: [ class := selectedClass ].
    (class includesSelector: browsedSelector)
	ifTrue: [ methodString := class sourceCodeAt: browsedSelector. ]
	ifFalse: [ methodString := (class whichClassIncludesSelector: browsedSelector) 
		       sourceCodeAt: browsedSelector ].
    text contents: methodString.
!

showInherited: aBoolean
    showInherited := aBoolean.
    self updateDisplay.
!

sortedSelectors: aBoolean
    sortedSelectors := aBoolean.
    self updateDisplay.
!

showInstanceMethods: aBoolean
    showClassMethods := false.
    self updateDisplay.
!

showClassMethods: aBoolean
    showClassMethods := true.
    self updateDisplay.
!

printSelection
   | selection | 
    "needs to compile a method in the context of the current class that
     does the evaluation, execute it, remove teh method, and print the result"
    text insertTextSelection: ' ', self doIt printString.
!

doIt
    | selection | 
    "needs to compile a method in the context of the current class that
     does the evaluation, execute it, remove teh method, and print the result"

    selection := 'DoItMethod ^[ ', text getSelection, ' ] value'.
    Object compileString: selection printNl
	   ifError: [ :file :line :error | Transcript nextPutAll: 'error'; nl.
					     file printNl.
					      line printNl.
					      error  printNl.
					      ^nil ].
    ^nil DoItMethod.
!

compileIt
    | contents | 
    contents := text contents.
    selectedClass notNil
	ifTrue: [ selectedClass compileString: contents ]
!

saveImage
    Smalltalk snapshot
!

inspectSelection
     self doIt vinspect.
   " ObjectInspector new:"
!

browseImplementors
    | implementors |
    browsedSelector isNil ifTrue: [ ^nil ].
    implementors := OrderedCollection new.
    Namespace current allClassObjectsDo: 
	[ :class | (class includesSelector:  browsedSelector)
		       ifTrue: [ implementors add: class -> browsedSelector].
		   ].
    MessageSetBrowser on: implementors label: browsedSelector, ' implementors'.
!

browseSenders
    | senders set |
    browsedSelector isNil ifTrue: [ ^nil ].
    senders := OrderedCollection new.
    Namespace current allClassObjectsDo: 
	[ :class | set := class whichSelectorsReferTo: browsedSelector.
		   set do: 
		       [ :elem | senders add: class printNl -> elem printNl ].
	  ].
    MessageSetBrowser on: senders label: browsedSelector, ' senders'.
!

inspectClass
    | stream class name supername|
    
    selectedClass isNil ifTrue: [ ^nil ].


    class := selectedClass.

    supername := class superclass name.		"Handle the nil case"
    name := class name.		"handle the nil case"

    stream := WriteStream on: (String new: 50).
    stream nextPutAll: supername;
	space;
	nextPutAll: class kindOfSubclass;
	nextPut: $#;
	nextPutAll: name; nl.

    stream nextPutAll: '    instanceVariableNames: '''.
    class instVarNames do:
	[ :name | stream nextPutAll: name; space. ].
    stream nextPut: $'; nl.
    stream nextPutAll: '    classVariableNames: '''.
    class classVarNames do:
	[ :name | stream nextPutAll: name; space. ].
    stream nextPut: $'; nl.
    stream nextPutAll: '    poolDictionaries: '''.

    stream nextPut: $'; nl.
    stream nextPutAll: '    category: '''.
    stream print: class category; nextPut: $'; nl.

    text contents: stream contents.
!


createClass
    ^self notYetImplemented 
! !


!FirstBrowser methodsFor: 'private'!

init
    showInherited := false.
    sortedSelectors := false.
    showClassMethods := false.

    toplevel := BWindow new: 'Class Browser'.
    toplevel width: 350 height: 400.
    container := BContainer new: toplevel.
    container backgroundColor: 'LightBlue'.

    self createClassBrowser.

    self createSourceTextPane.
    self createInheritedToggle.
    self createSortedToggle.

    self createClassOrInstanceRadioGroup.

    HandleErrorsWithGui := true.	"turn this on!"

    toplevel map.
    toplevel callback: [ 
       KeepBrowserRunning := false.
       Blox terminateMainLoop.
       true
    ]  message: #value
!

createInheritedToggle
    | button |
    button := BToggle new: container label: 'Show Inherited'.
    button callback: self message: 'showInherited:'.
    button height: 20.
!

createSortedToggle
    | button |
    button := BToggle new: container label: 'Sort selectors'.
    button callback: self message: #sortedSelectors:.
    button height: 20.
!

createClassBrowser
    | subcontainer list collection |
    subcontainer := BContainer new: container.
    subcontainer setVerticalLayout: false; height: 150.
    list := BList new: subcontainer.

    list numberOfColumns: 1; width: 150.

    "list useVerticalLayout: true."

    "list contents: #(foo bar baz)."

    ClassList isNil
	ifTrue: [ ClassList  := self hierarchyNames: Object ] .

    list contents: ClassList.

    list callback: self message: #classSelectedFrom:at:.
    (BPopupMenu new: list label: 'classPopup')
	callback: self using:
	    #((Inspect inspectClass)
		  ('Create' createClass)).

    methodList := BList new: subcontainer.
    methodList numberOfColumns: 1; width: 200.
    methodList callback: self message: #methodSelectedFrom:at:.

    self createMethodListMenu.
!


createMethodListMenu
    | menu |
    menu := BPopupMenu new: methodList label: 'methodListPopup'.
    menu callback: self using:
	#(
	  ('Senders' browseSenders)
	      ('Implementors' browseImplementors)
	      "()
	      (Test2)"
	      ).
!


createSourceTextPane
    (text := BText new: container) height: 150.
    text contents: '"Your method goes here"'. 

    self createSourceTextMenu.
!
    
createMenus
    | button |
    BLabel new: container label: 'Menu:'.

    button := BButton new: container label: 'quit'.
    button callback: self message: #quitPressed.
    button backgroundColor: 'Thistle'.

    button := BButton new: container label: 'restart'.
    button callback: self message: 'restartPressed'.
    button backgroundColor: 'red'.

    button := BButton new: container label: 'Test error'.
    button callback: self message: #testError.
    button backgroundColor: 'green'.

!

createClassOrInstanceRadioGroup
    | label group ibutton cbutton |
    label := BLabel new: container label: 'Show:'.
    label height: 15.

    group := BRadioGroup new: container.
    group height: container height - group y.

    ibutton := BRadioButton new: group label: 'Instance'.
    ibutton callback: self message: #showInstanceMethods:.
    ibutton y: 0; height: group height // 2.
    cbutton := BRadioButton new: group label: 'Class'.
    cbutton callback: self message: #showClassMethods:.
    cbutton y: ibutton height; height: ibutton height.
!

createSourceTextMenu
    | menu menuItem |
    menu := BPopupMenu new: text label: 'sourceTextPopup'.
    menuItem := BMenuItem new: menu label: 'DoIt'.
    menuItem callback: self message: #doIt.

    menuItem := BMenuItem new: menu label: 'Compile it'.
    menuItem callback: self message: #compileIt.

    menuItem := BMenuItem new: menu label: 'Inspect'.
    BMenuItem new: menu.
    menuItem callback: self message: #inspectSelection.

    menuItem := BMenuItem new: menu label: 'Print'.
    menuItem callback: self message: 'printSelection'.
    
    "BMenuItem new: menu.
    menuItem := BMenuItem new: menu label: 'Debug'."

    BMenuItem new: menu.
    menuItem := BMenuItem new: menu label: 'Save image'.
    menuItem callback: self message: #saveImage.
!

hierarchyNames: startingClass
    | collection |
    
    collection := OrderedCollection new.
    self computeSubhierarchyFrom: startingClass level: 0 into: collection.
    ^collection
!

computeSubhierarchyFrom: startingClass level: level into: collection
    | name prefix subclasses |
    name := startingClass name.
    name notNil ifTrue:  [
	prefix := String new: level * 2.
	prefix atAllPut: Character space.
	collection add: prefix, name.
    ].
	
    subclasses := startingClass subclasses reject: 
	[ :class | class isMetaclass ].

    (subclasses asSortedCollection: [:a :b | a name < b name]) do:
	[ :subclass | self computeSubhierarchyFrom: subclass 
			   level: level + 1
			   into: collection ].

!

restartPressed
    'restart button pressed!' printNl.
    Blox terminateMainLoop.
!

quitPressed
    'quit button pressed!' printNl.
    KeepBrowserRunning := false.
    Blox terminateMainLoop.
!

testError
    'testing error!' printNl.
    ^self error: 'error test'
! !


Gui subclass: #ObjectInspector
       instanceVariableNames: 'inspectedObject instVarList inspectionPane
			       instVarSelection'
       classVariableNames: ''
       poolDictionaries: ''
       category: 'Graphics-Browser'
! 

!ObjectInspector class methodsFor: 'instance creation'!

new: anObject
    ^self new init: anObject
!

new: anObject in: aContainer
    ^self new init: anObject in: aContainer
!

new: container names: nameList elements: elements
    ^self new init: container names: nameList elements: elements
! !

!ObjectInspector methodsFor: 'callbacks'!

showInstVarFrom: receiver at: anIndex
    instVarSelection := anIndex.
    inspectionPane contents: (instVarList at: anIndex) printString.
!

inspectSelection
    instVarSelection notNil
	ifTrue: [ ObjectInspector new: (instVarList at: instVarSelection) ].
! !


!ObjectInspector methodsFor: 'private'!

init: container names: nameList elements: elements
    | menu menuItem |

    instVarList := BList new: container.
    instVarList width: 100; height: 100.

    instVarList contents: nameList elements: elements.
    instVarList callback: self message: #showInstVarFrom:at: .

    
    menu := BPopupMenu new: instVarList label: 'ObjectInspectorPopup'.
    menuItem := BMenuItem new: menu label: 'Inspect'.
    menuItem callback: self message: #inspectSelection.

    inspectionPane := BText new: container.
    inspectionPane width: 200; height: 100.
    (BPopupMenu new: inspectionPane label: 'ObjectInspector')
	callback: self using:
	    #(('Do it' doIt)
		  ('Print it' printIt)
		  (Accept acceptIt)).

! 

init: anObject in: aContainer
    | class instanceValues instVarNames numInstVars numIndexVars totalVars |
    inspectedObject := anObject.

    class := anObject class.
    
    numIndexVars := anObject basicSize. "scale this "
    numInstVars := class instSize.

    totalVars := numIndexVars + numInstVars.

    instVarNames := OrderedCollection new: totalVars + 1.
    instVarNames add: #self.
    numInstVars > 0
	ifTrue: [ instVarNames addAllLast: class allInstVarNames. ].
    
    1 to: numIndexVars do:
	[ :i | instVarNames add: i printString ].

    instanceValues := OrderedCollection new: totalVars + 1.
    instanceValues add: anObject.
    2 to: totalVars + 1 do:
	[ :i | instanceValues add: (anObject instVarAt: i - 1) ].

    self init: aContainer names: instVarNames elements: instanceValues.
!

init: anObject
    | topLevel container name |
    
    name := anObject class name.
    name isNil ifTrue: [ name := anObject name, ' class' ].

    topLevel := BWindow new: name.
    container := BContainer new: topLevel.
    container setVerticalLayout: false.

    self init: anObject in: container.

    topLevel map.
! 

doIt
    | selection | 
    "needs to compile a method in the context of the current class that
     does the evaluation, execute it, remove the method, and print the result"
    selection := inspectionPane getSelection.

    selection := 'ObjectdoItMethod ^[ ', selection, ' ] value'.
    Object compileString: selection 
	   ifError: [ :file :line :error | Transcript nextPutAll: 'error'; nl.
					     file printNl.
					      line printNl.
					      error  printNl.
					      ^nil ].
    ^nil ObjectdoItMethod.
!

printIt
   | selection | 
    "needs to compile a method in the context of the current class that
     does the evaluation, execute it, remove teh method, and print the result"
    inspectionPane insertTextSelection: ' ', self doIt printString.
!

acceptIt
    | value |
    instVarSelection notNil ifTrue: 
	[ value := self doIt.
	  inspectedObject instVarAt: instVarSelection put: value ].
! !



Gui subclass: #ContextInspector
       instanceVariableNames: 'contextHolder methodSource receiverVars'
       classVariableNames: ''
       poolDictionaries: ''
       category: 'Graphics-Browser'
! 

!ContextInspector class methodsFor: 'instance creation'!

new: contextBrowser
    ^self new init: contextBrowser
! !

!ContextInspector methodsFor: 'private'!

init: contextBrowser
    | toplevel container text subcontainer list class selector context |
    contextHolder := contextBrowser.

    context := contextHolder currentContext.

    selector := context selector.
"brd 7/16 - exit if selector is nil"
    selector isNil ifTrue: ['Unable to inspect method context' printNl. ^self].

    toplevel := BWindow new: 'Context Inspector'.
    toplevel width: 450; height: 300.
    container := BContainer new: toplevel.
    
    text := BText new: container.
    text width: 450; height: 200.
    
    context := contextHolder currentContext.

    selector := context selector.
    class := (context receiver class includesSelector: selector)
	ifTrue: [ context receiver class]
	ifFalse: [  context receiver class 
			whichClassIncludesSelector: selector ].
			
    text contents: (class sourceCodeAt: selector).

    subcontainer := BContainer new: container.
    subcontainer setVerticalLayout: false.
    
    ObjectInspector new: contextHolder currentContext receiver 
		    in: subcontainer.

    self addStackInspector: subcontainer.


    toplevel map.
!



addStackInspector: aContainer
    | context stackVars stackVarValues method totalVars |
    
    context := contextHolder currentContext.
    
    method := self getMethodFromContext: context.

    totalVars := method numArgs + method numTemps.

    stackVars := OrderedCollection new: totalVars + 1.
    stackVars add: #thisContext.

    1 to: totalVars do:
	[ :i | stackVars add: i printString ].
    
    stackVarValues := OrderedCollection new: totalVars + 1.
    stackVarValues add: context.

    2 to: totalVars + 1 do:
	[ :i | stackVarValues add: (context at: i - 1) ].

    ObjectInspector new: aContainer
		    names: stackVars elements: stackVarValues.
!

getMethodFromContext: context
    "limit for right now to just method contexts"
    ^context method.
! !



Gui subclass: #ErrorInspector
       instanceVariableNames: 'callstackList currentSelection numContexts'
       classVariableNames: ''
       poolDictionaries: ''
       category: 'Graphics-Browser'
! 



!ErrorInspector class methodsFor: 'instance creation'!

new: message names: contextStrings contexts: contexts
    ^self new init: message names: contextStrings contexts: contexts
! !

!ErrorInspector methodsFor: 'accessing'!

currentContext
    currentSelection isNil ifTrue: [ ^nil ].
    ^callstackList at: currentSelection
!

next
    currentSelection isNil ifTrue: [ ^nil ].
    currentSelection := currentSelection + 1 min: numContexts.
    "Should change the currently selected list item"
!

previous
    currentSelection isNil ifTrue: [ ^nil ].
    currentSelection := currentSelection - 1 max: 1.
    "Should change the currently selected list item"
! !


!ErrorInspector methodsFor: 'callback'!

inspectContext
    ContextInspector new: self 
!

contextSelectedFrom: receiver at: anIndex
    currentSelection := anIndex
! !


!ErrorInspector methodsFor: 'private'!

init: message names: nameList contexts: contexts
    | topLevel |
    numContexts := contexts size.
    topLevel := BWindow new: message.
    topLevel width: 300; height: 100.
    callstackList := BList new: topLevel.
    
    callstackList contents: nameList elements: contexts.
    callstackList callback: self message: #contextSelectedFrom:at:.
    (BPopupMenu new: callstackList label: 'ErrorBacktrace')
	callback: self using:
	    #((Proceed)
		  (Exit)
		  ()
		  (Inspect inspectContext)).

    topLevel map.
! !


(Object includesSelector: #originalPrimError: )
    ifFalse: [ Object addSelector: #originalPrimError: 
		      withMethod: (Object compiledMethodAt: #primError:) ]!

Smalltalk at: #BBrowserInitialized put: false!

!Object methodsFor: 'overriding'!

primError: message
    | context names contexts nameStr |
    "Check for blox init being called already!"
    (BBrowserInitialized & HandleErrorsWithGui )
	ifFalse: [ ^self originalPrimError: message ].

    names := OrderedCollection new.
    contexts := OrderedCollection new.
    
    context := thisContext.
	
    HandleErrorsWithGui := false. "prevent infinite recursion"
    [ context notNil ] whileTrue: 
	[ names add: context printString.
	  contexts add: context.
	  context := context parentContext.
	  ].
    
    ErrorInspector new: message names: names contexts: contexts.
    HandleErrorsWithGui := true.
!

vinspect
    ObjectInspector new: self.
! !

Smalltalk snapshot!

"

| x |
    KeepBrowserRunning := true.
    BBrowserInitialized := false.
    [ KeepBrowserRunning ] whileTrue: 
	[ 
	  FirstBrowser new.
	  BBrowserInitialized := true.
	  Blox dispatchEvents.
	  'dispatch events returning' printNl. ].
! 
"


