"====================================================================== | | 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. ]. ! "