.
"
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
inclusion of the above copyright notice. This software may not
be provided or otherwise made available to, or used by, any
other person. No title to or ownership of the software is
hereby transferred.
"
'From Smalltalk/X, Version:2.10.4 on 24-feb-1995 at 7:10:38 am'!
StandardSystemView subclass:#BrowserView
instanceVariableNames:'classCategoryListView classListView methodCategoryListView
methodListView classMethodListView codeView classToggle
instanceToggle currentClassCategory currentClassHierarchy
currentClass currentMethodCategory currentMethod currentSelector
showInstance actualClass fullClass lastMethodCategory aspect
variableListView fullProtocol lockUpdates autoSearch myLabel
acceptClass'
classVariableNames:'CheckForInstancesWhenRemovingClasses DefaultIcon'
poolDictionaries:''
category:'Interface-Browsers'
!
BrowserView comment:'
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
$Header: /cvs/stx/stx/libtool/BrowserView.st,v 1.27 1995-09-07 12:52:56 claus Exp $
'!
!BrowserView class methodsFor:'documentation'!
copyright
"
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
inclusion of the above copyright notice. This software may not
be provided or otherwise made available to, or used by, any
other person. No title to or ownership of the software is
hereby transferred.
"
!
version
"
$Header: /cvs/stx/stx/libtool/BrowserView.st,v 1.27 1995-09-07 12:52:56 claus Exp $
"
!
documentation
"
this class implements all kinds of class browsers.
Typically, it is started with 'SystemBrowser open', but there are many other
startup messages, to launch special browsers.
See the categories 'startup' and 'special search startup' in the classes
protocol.
Alse, see the extra document 'doc/misc/sbrowser.doc' or the HTML online doc
for how to use the browser.
written winter 89 by claus
Notice: SystemBrowser is currently being rewritten to be an instance
of ApplicationModel - this transition is not yet complete and you see
here intermediate versions of BrowserView/SystemBrowser.
All action is (currently) still done here in BrowserView, although the
SystemBrowsers class methods are used to startup a browser.
This will certainly change ...
"
! !
!BrowserView class methodsFor:'defaults'!
defaultIcon
DefaultIcon isNil ifTrue:[
DefaultIcon := Form fromFile:'SBrowser.xbm' resolution:100
].
^ DefaultIcon
! !
!BrowserView class methodsFor:'initialization'!
initialize
"Browser configuration;
(values can be changed from your private startup file)"
"
setting this to false, the removeClass function will remove
classes WITHOUT checking for instances. Otherwise,
it will check and let you confirm in case there are instances.
Checking for instances may be a bit time consuming, though.
The default is true - therefore, it will check
"
CheckForInstancesWhenRemovingClasses := true
"
CheckForInstancesWhenRemovingClasses := true
CheckForInstancesWhenRemovingClasses := false
"
! !
!BrowserView methodsFor:'help'!
helpTextFor:aComponent
|s|
aComponent == classCategoryListView ifTrue:[
s := 'HELP_CCAT_LIST'
].
aComponent == classListView ifTrue:[
fullProtocol ifTrue:[
s := 'HELP_PCLASS_LIST'
] ifFalse:[
currentClassHierarchy notNil ifTrue:[
s := 'HELP_HCLASS_LIST'
] ifFalse:[
s := 'HELP_CLASS_LIST'
]
]
].
aComponent == methodCategoryListView ifTrue:[
s := 'HELP_MCAT_LIST'
].
aComponent == methodListView ifTrue:[
s := 'HELP_METHOD_LIST'
].
aComponent == variableListView ifTrue:[
s := 'HELP_VAR_LIST'
].
aComponent == codeView ifTrue:[
fullClass ifTrue:[
s := 'HELP_FULLCODE_VIEW'
] ifFalse:[
s := 'HELP_CODE_VIEW'
]
].
(aComponent == instanceToggle
or:[aComponent == classToggle]) ifTrue:[
s := 'HELP_INST_CLASS_TOGGLE'
].
aComponent == classMethodListView ifTrue:[
s := 'HELP_CLSMTHOD_LIST'
].
s notNil ifTrue:[
^ resources string:s
].
^ nil
"Modified: 31.8.1995 / 19:11:39 / claus"
! !
!BrowserView methodsFor:'misc'!
processName
"the name of my process - for the processMonitor only"
^ 'System Browser'.
!
updateCodeView
|code|
fullClass ifTrue:[
currentClass notNil ifTrue:[
code := currentClass source.
]
] ifFalse:[
currentMethod notNil ifTrue:[
(codeView acceptAction isNil
and:[actualClass notNil
and:[currentMethodCategory notNil]]) ifTrue:[
self setAcceptAndExplainActionsForMethod.
].
code := currentMethod source.
]
].
codeView contents:code.
codeView modified:false.
self normalLabel.
!
instanceProtocol:aBoolean
"switch between instance and class protocol"
|onToggle offToggle|
showInstance ~~ aBoolean ifTrue:[
self checkSelectionChangeAllowed ifTrue:[
instanceToggle notNil ifTrue:[
aBoolean ifTrue:[
offToggle := classToggle.
onToggle := instanceToggle.
] ifFalse:[
onToggle := classToggle.
offToggle := instanceToggle.
].
onToggle turnOn.
offToggle turnOff.
].
showInstance := aBoolean.
(variableListView notNil
and:[variableListView hasSelection]) ifTrue:[
self unhilightMethodCategories.
self unhilightMethods.
variableListView deselect
].
fullProtocol ifTrue:[
showInstance ifTrue:[
actualClass := currentClassHierarchy.
] ifFalse:[
actualClass := currentClassHierarchy class.
].
acceptClass := actualClass.
self updateClassList.
self updateMethodCategoryListWithScroll:false.
self updateMethodListWithScroll:false.
self updateVariableList.
^ self
].
currentClass notNil ifTrue:[
self classSelectionChanged
].
codeView modified:false.
] ifFalse:[
aBoolean ifTrue:[
onToggle := classToggle.
offToggle := instanceToggle
] ifFalse:[
offToggle := classToggle.
onToggle := instanceToggle.
].
onToggle turnOn.
offToggle turnOff.
]
]
! !
!BrowserView methodsFor:'method stuff'!
methodSelectionChanged
"method selection has changed - update dependent views"
self withWaitCursorDo:[
|index cls|
self updateCodeView.
self setAcceptAndExplainActionsForMethod.
"
if there is any autoSearch string, do the search
"
autoSearch notNil ifTrue:[
codeView searchFwd:autoSearch startingAtLine:1 col:0 ifAbsent:[]
].
fullProtocol ifTrue:[
"
remove any bold attribute from classList
"
1 to:classListView list size do:[:i |
classListView attributeAt:i remove:#bold.
].
"
boldify the class where this method is implemented
"
currentMethod notNil ifTrue:[
cls := currentMethod who at:1.
index := classListView list indexOf:(cls name).
(index == 0
and:[cls isMeta
and:[cls name endsWith:'class']]) ifTrue:[
index := classListView list indexOf:(cls name copyWithoutLast:5).
].
index ~~ 0 ifTrue:[
classListView attributeAt:index add:#bold.
].
currentClass := acceptClass := cls.
]
].
]
!
updateMethodListWithScroll:scroll
self updateMethodListWithScroll:scroll keepSelection:false
!
updateMethodListWithScroll:scroll keepSelection:keep
|selectors scr first last selection|
methodListView notNil ifTrue:[
selection := methodListView selection.
currentMethodCategory notNil ifTrue:[
fullProtocol ifTrue:[
selectors := self listOfAllSelectorsInCategory:currentMethodCategory
inFullProtocolHierarchyOfClass:actualClass
] ifFalse:[
selectors := self listOfAllSelectorsInCategory:currentMethodCategory
ofClass:actualClass
]
].
scr := scroll.
first := methodListView firstLineShown.
first ~~ 1 ifTrue:[
last := methodListView lastLineShown.
selectors size <= (last - first + 1) ifTrue:[
scr := true
]
].
methodListView list = selectors ifFalse:[
scr ifTrue:[
methodListView contents:selectors
] ifFalse:[
methodListView setContents:selectors
]
].
keep ifTrue:[
methodListView selection:selection.
]
]
!
listOfAllSelectorsInCategory:aCategory ofClass:aClass
"answer a list of all selectors in a given method category
of the argument, aClass"
|newList searchCategory all p|
all := (aCategory = '* all *').
(aCategory = '* no category *') ifTrue:[
searchCategory := nil
] ifFalse:[
searchCategory := aCategory
].
newList := OrderedCollection new.
aClass methodArray with:aClass selectorArray do:[:aMethod :selector |
|sel how|
(all or:[aMethod category = searchCategory]) ifTrue:[
sel := selector.
(p := aMethod privacy) ~~ #public ifTrue:[
how := ' (* ' , p , ' *)'.
].
aMethod isWrapped ifTrue:[
how := ' !!'
].
aMethod isInvalid ifTrue:[
how := ' (** not executable **)'
].
aMethod isLazyMethod ifTrue:[
"/ how := ' (lazy)'
] ifFalse:[
(aMethod code isNil
and:[aMethod byteCode isNil]) ifTrue:[
how := ' (** unloaded **)'
]
].
how notNil ifTrue:[sel := sel , how].
newList add:sel
]
].
(newList size == 0) ifTrue:[^ nil].
^ newList sort
"Modified: 28.8.1995 / 21:53:34 / claus"
!
methodSelection:lineNr
"user clicked on a method line - show code"
|selectorString selectorSymbol|
(fullProtocol not and:[currentClass isNil]) ifTrue:[^ self].
selectorString := methodListView selectionValue.
"
kludge: extract real selector
"
selectorString := selectorString withoutSpaces upTo:(Character space).
selectorSymbol := selectorString asSymbol.
fullProtocol ifTrue:[
currentMethod := currentSelector := nil.
"
search which class implements the selector
"
self classesInFullProtocolHierarchy:actualClass do:[:c |
(currentMethod isNil
and:[c implements:selectorSymbol]) ifTrue:[
currentSelector := selectorSymbol.
currentMethod := c compiledMethodAt:selectorSymbol.
acceptClass := c
]
]
] ifFalse:[
currentSelector := selectorSymbol.
currentMethod := actualClass compiledMethodAt:selectorSymbol.
].
methodCategoryListView notNil ifTrue:[
currentMethod notNil ifTrue:[
(currentMethodCategory = currentMethod category) ifFalse:[
currentMethodCategory := currentMethod category.
methodCategoryListView selectElement:currentMethodCategory
]
]
].
self methodSelectionChanged
!
updateMethodList
self updateMethodListWithScroll:true keepSelection:false
!
checkMethodSelected
currentMethod isNil ifTrue:[
self warn:'select a method first'.
^ false
].
^ true
!
template
"return a method definition template"
^
'message selector and argument names
"comment stating purpose of message"
|temporaries|
statements
"
change above template into real code.
Then ''accept'' either via the menu
or via the keyboard (usually CMD-A).
You do not need this template; you can also
select any existing methods code, change it,
and finally ''accept''.
"
'
!
switchToMethodNamed:matchString
"switch (in the current class) to a method named matchString.
If there are more than one matches, switch to the first."
|aSelector method cat index classToSearch selectors|
currentClass notNil ifTrue:[
showInstance ifTrue:[
classToSearch := currentClass
] ifFalse:[
classToSearch := currentClass class
].
selectors := classToSearch selectorArray.
((matchString ~= '*') and:[matchString includesMatchCharacters]) ifTrue:[
index := selectors findFirst:[:element | matchString match:element]
] ifFalse:[
index := selectors indexOf:matchString
].
(index ~~ 0) ifTrue:[
aSelector := selectors at:index.
method := classToSearch methodArray at:index.
cat := method category.
cat isNil ifTrue:[cat := '* all *'].
methodCategoryListView selectElement:cat.
currentMethodCategory := cat.
self methodCategorySelectionChanged.
currentMethod := classToSearch compiledMethodAt:aSelector.
currentMethod notNil ifTrue:[
currentSelector := aSelector.
methodListView selectElement:aSelector.
].
self methodSelectionChanged
]
]
!
listOfAllSelectorsInCategory:aCategory inFullProtocolHierarchyOfClass:aClass
"answer a list of all selectors in a given method category
of the argument, aClass and its superclasses.
Used with fullProtocol browsing."
|newList|
newList := Set new.
self classesInFullProtocolHierarchy:aClass do:[:c |
|searchCategory|
(aCategory = '* all *') ifTrue:[
newList addAll:(c selectorArray)
] ifFalse:[
(aCategory = '* no category *') ifTrue:[
searchCategory := nil
] ifFalse:[
searchCategory := aCategory
].
c methodArray with:c selectorArray do:[:aMethod :selector |
(aMethod category = searchCategory) ifTrue:[
newList add:selector
]
]
].
].
(newList size == 0) ifTrue:[^ nil].
^ newList asOrderedCollection sort
!
switchToAnyMethodNamed:aString
|aSelector classToStartSearch aClass nm|
aSelector := aString asSymbol.
currentClass isNil ifTrue:[
currentClassHierarchy notNil ifTrue:[
classToStartSearch := currentClassHierarchy
]
] ifFalse:[
classToStartSearch := currentClass
].
classToStartSearch notNil ifTrue:[
showInstance ifFalse:[
classToStartSearch := classToStartSearch class
].
aClass := classToStartSearch whichClassIncludesSelector:aSelector.
aClass notNil ifTrue:[
nm := aClass name.
showInstance ifFalse:[
((nm ~= 'Metaclass') and:[nm endsWith:'class']) ifTrue:[
nm := nm copyWithoutLast:5 "copyTo:(nm size - 5)"
]
].
self switchToClassNamed:nm.
self switchToMethodNamed:aString
]
]
! !
!BrowserView methodsFor:'private'!
checkSelectionChangeAllowed
"return true, if selection change is ok;
its not ok, if code has been changed.
in this case, return the result of a user query"
|action|
codeView modified ifFalse:[
^ true
].
action := OptionBox
request:(resources at:'text has not been accepted.\\Your modifications will be lost when continuing.') withCRs
label:(resources string:'Attention')
form:(WarningBox iconBitmap)
buttonLabels:(resources array:#('abort' 'accept' 'continue'))
values:#(false #accept true)
default:true.
action ~~ #accept ifTrue:[
^ action
].
codeView accept. ^ true
!
normalLabel
"set the normal (inactive) window- and icon labels"
|l il|
myLabel notNil ifTrue:[
"if I have been given an explicit label,
and its not the default, take that one"
myLabel ~= 'System Browser' ifTrue:[
l := il := myLabel
]
].
l isNil ifTrue:[
l := resources string:'System Browser'.
currentClass notNil ifTrue:[
l := l, ': ', currentClass name.
classListView isNil ifTrue:[
currentSelector notNil ifTrue:[
l := l , ' ' , currentSelector
]
].
il := currentClass name
] ifFalse:[
il := l.
]
].
self label:l.
self iconLabel:il.
!
setDoitActionForClass
"tell the codeView what to do on doIt"
"set self for doits. This allows accessing the current class
as self, and access to the class variables by name.
"
codeView doItAction:[:theCode |
|compiler|
currentClass isNil ifTrue:[
compiler := Compiler
] ifFalse:[
compiler := currentClass evaluatorClass
].
compiler
evaluate:theCode
in:nil
receiver:currentClass
notifying:codeView
logged:false
ifFail:nil
].
!
setAcceptAndExplainActionsForMethod
"tell the codeView what to do on accept and explain"
codeView acceptAction:[:theCode |
|cat cls|
codeView cursor:Cursor execute.
(cat := currentMethodCategory) = '* all *' ifTrue:[
"must check from which category this code came from ...
... thanks to Arno for pointing this out"
cat := self askForMethodCategory.
].
(cat notNil and:[cat notEmpty]) ifTrue:[
fullProtocol ifTrue:[
cls := acceptClass "/actualClass whichClassIncludesSelector:currentSelector.
].
cls isNil ifTrue:[
cls := actualClass
].
Object abortSignal catch:[
lockUpdates := true.
actualClass compilerClass
compile:theCode asString
forClass:cls
inCategory:cat
notifying:codeView.
codeView modified:false.
self updateMethodListWithScroll:false.
].
lockUpdates := false.
].
codeView cursor:Cursor normal.
].
codeView explainAction:[:theCode :theSelection |
self showExplanation:(Explainer
explain:theSelection
in:theCode
forClass:actualClass)
].
!
enterBoxTitle:title okText:okText
"convenient method: setup enterBox"
|box|
box := EnterBox new.
box title:(resources string:title) okText:(resources string:okText).
^ box
!
selectorToSearchFor
"look in codeView and methodListView for a search-string when searching for selectors"
|sel t|
sel := codeView selection.
sel notNil ifTrue:[
sel := sel asString.
t := Parser selectorInExpression:sel.
t notNil ifTrue:[
sel := t
].
sel := sel withoutSpaces.
sel == #>> ifTrue:[
"oops - thats probably not what we want here ..."
self extractClassAndSelectorFromSelectionInto:[:c :s :m |
sel := s
]
]
] ifFalse:[
methodListView notNil ifTrue:[
sel := methodListView selectionValue
] ifFalse:[
classMethodListView notNil ifTrue:[
sel := classMethodListView selectionValue.
sel notNil ifTrue:[
sel := self selectorFromClassMethodString:sel
]
]
].
sel notNil ifTrue:[
sel := sel withoutSpaces upTo:(Character space)
] ifFalse:[
sel := ''
]
].
^ sel
!
setSearchPattern:aString
codeView setSearchPattern:aString
!
listBoxTitle:title okText:okText list:aList
"convenient method: setup a listBox & return it"
|box|
box := ListSelectionBox
title:(resources string:title)
okText:(resources string:okText)
action:nil.
box list:aList.
^ box
!
listBoxForCodeSelectionTitle:title okText:okText
"convenient method: setup listBox with text from codeview"
|sel box|
box := self listBoxTitle:title okText:okText list:nil.
sel := codeView selection.
sel notNil ifTrue:[
box initialText:(sel asString withoutSeparators)
].
^ box
!
showExplanation:someText
"show explanation from Parser"
self information:someText
!
stringToSearchFor
"look in codeView and methodListView for a search-string when searching for classes/names"
|sel|
sel := codeView selection.
sel notNil ifTrue:[
sel := sel asString withoutSpaces
] ifFalse:[
sel isNil ifTrue:[
currentClass notNil ifTrue:[
sel := currentClass name
]
].
sel notNil ifTrue:[
sel := sel withoutSpaces
] ifFalse:[
sel := ''
]
].
^ sel
!
findClassOfVariable:aVariableName accessWith:aSelector
"this method returns the class, in which a variable
is defined;
needs either #instVarNames or #classVarNames as aSelector."
|cls homeClass|
"
first, find the class, where the variable is declared
"
cls := currentClass.
[cls notNil] whileTrue:[
((cls perform:aSelector) includes:aVariableName) ifTrue:[
homeClass := cls.
cls := nil.
] ifFalse:[
cls := cls superclass
]
].
homeClass isNil ifTrue:[
"nope, must be one below ... (could optimize a bit, by searching down
for the declaring class ...
"
homeClass := currentClass
] ifFalse:[
"/ Transcript showCr:'starting search in ' , homeClass name.
].
^ homeClass
!
enterBoxForSearchSelectorTitle:title
"convenient method: setup enterBox with text from codeView or selected
method for browsing based on a selector"
|box|
box := self enterBoxTitle:title okText:'search'.
box initialText:(self selectorToSearchFor).
^ box
!
enterBoxForCodeSelectionTitle:title okText:okText
"convenient method: setup enterBox with text from codeview"
|sel box|
box := self enterBoxTitle:(resources string:title) okText:(resources string:okText).
sel := codeView selection.
sel notNil ifTrue:[
box initialText:(sel asString withoutSeparators)
].
^ box
!
classesInFullProtocolHierarchy:aClass do:aBlock
"evaluate aBlock for all non-striked out classes in
the hierarchy"
|index|
index := (classListView list size).
aClass withAllSuperclasses do:[:c |
(classListView isInSelection:index) ifFalse:[
aBlock value:c
].
index := index - 1
]
!
enterBoxForBrowseTitle:title action:aBlock
"convenient method: setup enterBox with text from codeView or selected
method for method browsing based on className/variable"
|box|
box := self enterBoxTitle:title okText:'browse'.
box initialText:(self stringToSearchFor).
box action:[:aString |
aString notEmpty ifTrue:[
self withWaitCursorDo:[aBlock value:aString]
].
].
box showAtPointer
!
askAndBrowseMethodCategory:title action:aBlock
"convenient method: setup enterBox with initial being current method category"
|sel box|
box := self enterBoxTitle:title okText:'browse'.
sel := codeView selection.
sel isNil ifTrue:[
currentMethodCategory notNil ifTrue:[
sel := currentMethodCategory
]
].
sel notNil ifTrue:[
box initialText:(sel asString withoutSpaces)
].
box action:[:aString | self withWaitCursorDo:[aBlock value:aString]].
box showAtPointer
!
classHierarchyDo:aBlock
"eavluate the 2-arg block for every class,
starting at Object; passing class and nesting level to the block."
|classes s classDict l|
classes := Smalltalk allClasses.
classDict := IdentityDictionary new:classes size.
classes do:[:aClass |
s := aClass superclass.
s notNil ifTrue:[
l := classDict at:s ifAbsent:[nil].
l isNil ifTrue:[
l := OrderedCollection new:5.
classDict at:s put:l
].
l add:aClass
]
].
self classHierarchyOf:Object level:0 do:aBlock using:classDict
!
warnLabel:what
"set the title for some warning"
self label:('System Browser WARNING: ' , what)
!
classHierarchyOf:aClass level:level do:aBlock using:aDictionary
"evaluate the 2-arg block for every subclass of aClass,
passing class and nesting level to the block."
|names subclasses|
aBlock value:aClass value:level.
subclasses := aDictionary at:aClass ifAbsent:[nil].
(subclasses size == 0) ifFalse:[
names := subclasses collect:[:class | class name].
names sortWith:subclasses.
subclasses do:[:aSubClass |
self classHierarchyOf:aSubClass level:(level + 1) do:aBlock using:aDictionary
]
]
!
compileCode:someCode
(ReadStream on:someCode) fileIn
!
extractClassAndSelectorFromSelectionInto:aBlock
"given a string which can be either 'class>>sel' or
'class sel', extract className and selector, and call aBlock with
the result."
|sel clsName isMeta sep s|
sel := codeView selection.
sel notNil ifTrue:[
sel := sel asString withoutSeparators.
('*>>*' match:sel) ifTrue:[
sep := $>
] ifFalse:[
('* *' match:sel) ifTrue:[
sep := Character space
]
].
sep notNil ifTrue:[
"
extract class/sel from selection
"
s := ReadStream on:sel.
clsName := s upTo:sep.
[s peek == sep] whileTrue:[s next].
sel := s upToEnd.
(clsName endsWith:'class') ifTrue:[
isMeta := true.
clsName := clsName copyWithoutLast:5 "copyTo:(clsName size - 5)"
] ifFalse:[
isMeta := false
].
]
].
aBlock value:clsName value:sel value:isMeta
!
busyLabel:what with:someArgument
"set the title for some warning"
self label:('System Browser - ' , (resources string:what with:someArgument))
!
classesInHierarchy:aClass do:aBlock
|index|
index := (classListView list size).
aClass withAllSuperclasses do:[:c |
(classListView isInSelection:index) ifFalse:[
aBlock value:c
].
index := index - 1
]
!
askForMethodCategory
|someCategories box txt|
someCategories := actualClass categories sort.
box := self listBoxTitle:'accept in which method category ?' okText:'accept' list:someCategories.
lastMethodCategory isNil ifTrue:[
txt := 'new methods'
] ifFalse:[
txt := lastMethodCategory
].
box initialText:txt.
box action:[:aString | ^ aString ].
box showAtPointer.
^ nil
!
askForSelectorTitle:title
"convenient method: setup enterBox with text from codeView or selected
method for browsing based on a selector. Set action and launch box"
|box|
box := self enterBoxTitle:title okText:'browse'.
box initialText:(self selectorToSearchFor).
box action:[:aString | aString isEmpty ifTrue:[^ nil]. ^ aString].
box showAtPointer.
^ nil
!
askForSelectorTitle:title openWith:selector
"convenient method: setup enterBox with text from codeView or selected
method for browsing based on a selector. Set action and launch box"
|string|
string := self askForSelectorTitle:title.
string notNil ifTrue:[
self withCursor:(Cursor questionMark) do:[
SystemBrowser perform:selector with:string
]
].
!
askForSelectorTitle:title openWith:selector and:arg
"convenient method: setup enterBox with text from codeView or selected
method for browsing based on a selector. Set action and launch box"
|string|
string := self askForSelectorTitle:title.
string notNil ifTrue:[
self withCursor:(Cursor questionMark) do:[
SystemBrowser perform:selector with:string with:arg
]
].
! !
!BrowserView methodsFor:'method category stuff'!
updateMethodCategoryListWithScroll:scroll
|categories|
methodCategoryListView notNil ifTrue:[
fullProtocol ifTrue:[
currentClassHierarchy notNil ifTrue:[
categories := self listOfAllMethodCategoriesInFullProtocolHierarchy:actualClass
]
] ifFalse:[
currentClass notNil ifTrue:[
categories := self listOfAllMethodCategoriesInClass:actualClass
]
].
methodCategoryListView list = categories ifFalse:[
scroll ifTrue:[
methodCategoryListView contents:categories
] ifFalse:[
methodCategoryListView setContents:categories
].
currentMethodCategory notNil ifTrue:[
methodCategoryListView selectElement:currentMethodCategory
]
]
]
!
listOfAllMethodCategoriesInClass:aClass
"answer a list of all method categories of the argument, aClass"
|newList|
newList := Set new.
aClass methodArray do:[:aMethod |
|cat|
cat := aMethod category.
cat isNil ifTrue:[
cat := '* no category *'
].
newList add:cat
].
(newList size == 0) ifTrue:[^ nil].
newList add:'* all *'.
^ newList asOrderedCollection sort
!
methodCategorySelection:lineNr
"user clicked on a method category line - show selectors"
|oldSelector|
"/ oldSelector := currentSelector.
(fullProtocol not and:[currentClass isNil]) ifTrue:[^ self].
currentMethodCategory := methodCategoryListView selectionValue.
self methodCategorySelectionChanged.
"if there is only one method, show it right away"
methodListView list size == 1 ifTrue:[
methodListView selection:1.
self methodSelection:1
] ifFalse:[
oldSelector notNil ifTrue:[
methodListView selectElement:oldSelector.
methodListView hasSelection ifTrue:[
self methodSelection:methodListView selection.
]
]
]
!
methodCategorySelectionChanged
"method category selection has changed - update dependant views"
self withWaitCursorDo:[
currentMethod := currentSelector := nil.
self updateMethodList.
self updateCodeView.
currentMethodCategory notNil ifTrue:[
methodCategoryListView selectElement:currentMethodCategory
].
self setAcceptAndExplainActionsForMethod.
self hilightMethodsInMethodCategoryList:false inMethodList:true.
]
!
updateMethodCategoryList
self updateMethodCategoryListWithScroll:true
!
listOfAllMethodCategoriesInFullProtocolHierarchy:aClass
"answer a list of all method categories of the argument, aClass,
and all of its superclasses.
Used with fullProtocol browsing."
|newList|
newList := Set new.
self classesInFullProtocolHierarchy:aClass do:[:c |
|cat|
c methodArray do:[:aMethod |
cat := aMethod category.
cat isNil ifTrue:[
cat := '* no category *'
].
newList add:cat
]
].
(newList size == 0) ifTrue:[^ nil].
newList add:'* all *'.
^ newList asOrderedCollection sort
!
checkMethodCategorySelected
currentMethodCategory isNil ifTrue:[
self warn:'select a method category first'.
^ false
].
^ true
!
whenMethodCategorySelected:aBlock
self checkMethodCategorySelected ifTrue:[
self withWaitCursorDo:aBlock
]
!
copyMethodsFromClass:aClassName
|class box|
currentClass notNil ifTrue:[
class := Smalltalk classNamed:aClassName.
class isBehavior ifFalse:[
self warn:'no class named %1' with:aClassName.
^ self
].
showInstance ifFalse:[
class := class class
].
"show enterbox for category to copy from"
box := self enterBoxTitle:'name of category to copy from (matchpattern allowed, * for all):'
okText:'copy'.
box action:[:aString | self copyMethodsFromClass:class category:aString].
box showAtPointer.
]
!
copyMethodsFromClass:class category:category
currentClass notNil ifTrue:[
Object abortSignal catch:[
class methodArray do:[:aMethod |
|source|
(category match:aMethod category) ifTrue:[
source := aMethod source.
codeView contents:source.
codeView modified:false.
actualClass compilerClass
compile:source
forClass:actualClass
inCategory:aMethod category
notifying:codeView.
self updateMethodCategoryListWithScroll:false.
self updateMethodListWithScroll:false.
]
]
]
]
!
newMethodCategory:aString
|categories|
currentClass isNil ifTrue:[
^ self warn:'select/create a class first'.
].
categories := methodCategoryListView list.
categories isNil ifTrue:[categories := OrderedCollection new].
(categories includes:aString) ifFalse:[
categories add:aString.
categories sort.
methodCategoryListView contents:categories
].
currentMethodCategory := aString.
self methodCategorySelectionChanged
! !
!BrowserView methodsFor:'change & update'!
update:something with:someArgument from:changedObject
|list|
"
avoid update/warn after my own changes
"
lockUpdates == true ifTrue:[
"/ 'ignored my change' printNL.
^ self
].
"/ changedObject print. ' ' print. someArgument print. ' ' print.
"/ something printNL.
(changedObject == Smalltalk) ifTrue:[
something == #newClass ifTrue:[
(currentClass notNil
and:[someArgument name = currentClass name]) ifTrue:[
"
the current class was autoloaded
"
self warnLabel:'the selected class has changed'.
self updateClassListWithScroll:false.
].
((someArgument category = currentClassCategory)
or:[currentClassCategory notNil
and:[currentClassCategory startsWith:'*']]) ifTrue:[
self updateClassListWithScroll:false.
].
someArgument category ~= currentClassCategory ifTrue:[
"
category new ?
"
(classCategoryListView notNil
and:[(list := classCategoryListView list) notNil
and:[(list includes:someArgument category) not]])
ifTrue:[
self updateClassCategoryListWithScroll:false.
]
].
^ self
].
something == #classRemove ifTrue:[
someArgument = currentClass ifTrue:[
self warnLabel:'the selected class was removed'.
^ self
].
" fall into general update "
].
"
any other (unknown) change
with the Smalltalk dictionary ...
"
self updateClassCategoryListWithScroll:false.
self updateClassListWithScroll:false.
^ self
].
changedObject isBehavior ifTrue:[
"
its a class, that has changed
"
(currentClass notNil
and:[changedObject name = currentClass name]) ifTrue:[
"
its the current class that has changed
"
something == #methodDictionary ifTrue:[
(someArgument isSymbol) ifTrue:[
|changedMethod|
"
the method with selector someArgument was changed or removed
"
self updateMethodCategoryListWithScroll:false.
self updateMethodListWithScroll:false.
someArgument == currentSelector ifTrue:[
"
special care here: the currently shown method has been
changed somehow in another browser (or via fileIn)
"
changedMethod := currentClass compiledMethodAt:currentSelector.
changedMethod isNil ifTrue:[
self warnLabel:'the method shown was removed'.
^ self
].
"compare the source codes"
currentMethod notNil ifTrue:[
changedMethod source = codeView contents ifFalse:[
self warnLabel:'the code shown may not up to date'.
]
].
^ self
].
^ self
]
].
something == #comment ifTrue:[
"
the class has changed its comment; we dont care, except if
currently showing the comment
"
aspect == #comment ifTrue:[
self warnLabel:'the comment shown may not up to date'.
].
^ self
].
something == #definition ifTrue:[
"
the class has changed its definition.
Warn, except if showing a method.
"
aspect notNil ifTrue:[
self warnLabel:'the classes definition has changed'.
].
"/ ^ self
].
"
get the class again - in case of a changed class definition,
we are otherwise refering to the obsolete old class
"
currentClass := Smalltalk at:(currentClass name asSymbol).
showInstance ifTrue:[
actualClass := currentClass
] ifFalse:[
actualClass := currentClass class
].
self updateMethodCategoryListWithScroll:false.
"dont update codeView ...."
"self update"
^ self
].
"
any other class has changed (but not its organization, since
that is cought in the above case).
We are not interrested in it - except, if showing fullProtocol
or hierarchy ...
"
currentClassHierarchy notNil ifTrue:[
fullProtocol ifTrue:[
(currentClass isSubclassOf:changedObject) ifTrue:[
]
] ifFalse:[
((currentClass isSubclassOf:changedObject)
or:[changedObject isSubclassOf:currentClass]) ifTrue:[
]
]
].
^ self
].
(changedObject isMethod) ifTrue:[
]
! !
!BrowserView methodsFor:'initialize / release'!
initialize
super initialize.
showInstance := true.
fullClass := false.
fullProtocol := false.
aspect := nil.
"inform me, when Smalltalk changes"
Smalltalk addDependent:self
!
title:someString
myLabel := someString.
self label:someString.
!
realize
|v checkBlock|
super realize.
checkBlock := [:lineNr | self checkSelectionChangeAllowed].
v := classCategoryListView.
v notNil ifTrue:[
v action:[:lineNr | self classCategorySelection:lineNr].
v selectConditionBlock:checkBlock.
v ignoreReselect:false.
v contents:(self listOfAllClassCategories).
"
tell classCategoryListView to ask for the menu
"
v menuHolder:self; menuPerformer:self; menuMessage:#classCategoryMenu.
].
v := classListView.
v notNil ifTrue:[
v action:[:lineNr | self classSelection:lineNr].
v selectConditionBlock:checkBlock.
v ignoreReselect:false.
"
tell classListView to ask for the menu
"
v menuHolder:self; menuPerformer:self; menuMessage:#classMenu.
].
v := methodCategoryListView.
v notNil ifTrue:[
v action:[:lineNr | self methodCategorySelection:lineNr].
v selectConditionBlock:checkBlock.
v ignoreReselect:false.
"
tell methodCategoryListView to ask for the menu
"
v menuHolder:self; menuPerformer:self; menuMessage:#methodCategoryMenu.
].
v := methodListView.
v notNil ifTrue:[
v action:[:lineNr | self methodSelection:lineNr].
v selectConditionBlock:checkBlock.
v ignoreReselect:false.
"
tell methodListView to ask for the menu
"
v menuHolder:self; menuPerformer:self; menuMessage:#methodMenu.
].
v := classMethodListView.
v notNil ifTrue:[
v action:[:lineNr | self classMethodSelection:lineNr].
v selectConditionBlock:checkBlock.
v ignoreReselect:false.
"
tell classMethodListView to ask for the menu
"
v menuHolder:self; menuPerformer:self; menuMessage:#classMethodMenu.
].
v := variableListView.
v notNil ifTrue:[
v action:[:lineNr | self variableSelection:lineNr].
v ignoreReselect:false.
v toggleSelect:true.
v menuHolder:self; menuPerformer:self; menuMessage:#variableListMenu.
].
"
normal browsers show the top at first;
hierarchy and fullProtocol browsers better show the end
initially
"
currentClassHierarchy notNil ifTrue:[
classListView scrollToBottom.
]
!
destroy
"relese dependant - destroy popups"
Smalltalk removeDependent:self.
currentClass notNil ifTrue:[
currentClass removeDependent:self.
currentClass := nil
].
super destroy
!
terminate
(self checkSelectionChangeAllowed) ifTrue:[
super terminate
]
!
autoSearch:aString
"used with class-method list browsing. If true,
selecting an entry from the list will automatically
search for the searchstring in the codeView"
self setSearchPattern:aString.
autoSearch := aString
! !
!BrowserView methodsFor:'initialize subviews'!
createCodeViewIn:aView at:relY
"setup the code view"
|v|
v := HVScrollableView for:CodeView miniScrollerH:true miniScrollerV:false in:aView.
v origin:(0.0 @ relY) corner:(1.0 @ 1.0).
codeView := v scrolledView
!
createCodeViewIn:aView
"setup the code view"
^ self createCodeViewIn:aView at:0.25
!
createTogglesIn:aFrame
"create and setup the class/instance toggles"
|h halfSpace classAction instanceAction|
classAction := [self instanceProtocol:false].
instanceAction := [self instanceProtocol:true].
halfSpace := ViewSpacing // 2.
instanceToggle := Toggle label:(resources at:'instance') in:aFrame.
h := instanceToggle height.
instanceToggle origin:(0.0 @ 1.0) corner:(0.5 @ 1.0).
instanceToggle topInset:h negated.
instanceToggle turnOn.
instanceToggle pressAction:instanceAction.
instanceToggle releaseAction:classAction.
classToggle := Toggle label:(resources at:'class') in:aFrame.
h := classToggle height.
classToggle origin:(0.5 @ 1.0) corner:(1.0 @ 1.0).
classToggle topInset:h negated.
classToggle turnOff.
classToggle pressAction:classAction.
classToggle releaseAction:instanceAction.
styleSheet is3D ifTrue:[
instanceToggle bottomInset:halfSpace.
classToggle bottomInset:halfSpace.
instanceToggle leftInset:halfSpace.
classToggle leftInset:halfSpace.
instanceToggle rightInset:ViewSpacing - halfSpace.
classToggle rightInset:ViewSpacing - halfSpace.
].
!
setupForList:aList
"setup subviews to browse methods from a list"
|vpanel v|
vpanel := VariableVerticalPanel
origin:(0.0 @ 0.0)
corner:(1.0 @ 1.0)
in:self.
v := ScrollableView for:SelectionInListView in:vpanel.
v origin:(0.0 @ 0.0) corner:(1.0 @ 0.25).
classMethodListView := v scrolledView.
classMethodListView contents:aList.
self createCodeViewIn:vpanel.
self updateCodeView
!
createClassListViewIn:frame
"setup the classlist subview, with its toggles"
|v panel|
self createTogglesIn:frame.
"
oldstyle had no variableList ...
"
"/ v := ScrollableView for:SelectionInListView in:frame.
"/ v origin:(0.0 @ 0.0)
"/ extent:[frame width
"/ @
"/ (frame height
"/ - ViewSpacing
"/ - instanceToggle height
"/ - instanceToggle borderWidth
"/ + v borderWidth)].
"/
"/ classListView := v scrolledView
panel := VariableVerticalPanel
origin:(0.0 @ 0.0)
corner:[frame width
@
(frame height
- ViewSpacing
- instanceToggle height
"-" + instanceToggle borderWidth
+ v borderWidth)]
in:frame.
v := ScrollableView for:SelectionInListView in:panel.
v origin:(0.0 @ 0.0) corner:(1.0 @ 0.7).
classListView := v scrolledView.
v := ScrollableView for:SelectionInListView in:panel.
v origin:(0.0 @ 0.7) corner:(1.0 @ 1.0).
variableListView := v scrolledView.
!
setupForAll
"create subviews for a full browser"
|vpanel hpanel frame v|
vpanel := VariableVerticalPanel origin:(0.0 @ 0.0) corner:(1.0 @ 1.0)
in:self.
hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
v := HVScrollableView for:SelectionInListView
miniScrollerH:true miniScrollerV:false
in:hpanel.
v origin:(0.0 @ 0.0) corner:(0.25 @ 1.0).
classCategoryListView := v scrolledView.
frame := View origin:(0.25 @ 0.0) corner:(0.5 @ 1.0) in:hpanel.
self createClassListViewIn:frame.
v := HVScrollableView for:SelectionInListView miniScrollerH:true miniScrollerV:false in:hpanel.
v origin:(0.5 @ 0.0) corner:(0.75 @ 1.0).
methodCategoryListView := v scrolledView.
v := HVScrollableView for:SelectionInListView miniScrollerH:true miniScrollerV:false in:hpanel.
v origin:(0.75 @ 0.0) corner:(1.0 @ 1.0).
methodListView := v scrolledView.
self createCodeViewIn:vpanel
!
focusSequence
|s|
s := OrderedCollection new.
classCategoryListView notNil ifTrue:[
s add:classCategoryListView
].
classListView notNil ifTrue:[
s add:classListView
].
"/ variableListView notNil ifTrue:[
"/ s add:variableListView
"/ ].
instanceToggle notNil ifTrue:[
s add:instanceToggle.
].
methodCategoryListView notNil ifTrue:[
s add:methodCategoryListView
].
methodListView notNil ifTrue:[
s add:methodListView
].
classMethodListView notNil ifTrue:[
s add:classMethodListView
].
s add:codeView.
^ s
!
setupForClass:aClass
"create subviews for browsing a single class"
|vpanel hpanel frame v|
vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
corner:(1.0 @ 1.0)
in:self.
hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
frame := View origin:(0.0 @ 0.0) corner:(0.5 @ 1.0)in:hpanel.
self createTogglesIn:frame.
v := ScrollableView for:SelectionInListView in:frame.
v origin:(0.0 @ 0.0)
extent:[frame width
@
(frame height
- ViewSpacing
- instanceToggle height
- instanceToggle borderWidth
+ v borderWidth)].
methodCategoryListView := v scrolledView.
v := ScrollableView for:SelectionInListView in:hpanel.
v origin:(0.5 @ 0.0) corner:(1.0 @ 1.0).
methodListView := v scrolledView.
self createCodeViewIn:vpanel.
self switchToClass:aClass.
actualClass := acceptClass := aClass.
self updateMethodCategoryList.
self updateMethodList.
self updateCodeView
!
setupForClassHierarchy:aClass
"setup subviews to browse a class hierarchy"
|vpanel hpanel frame v cls|
vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
corner:(1.0 @ 1.0)
in:self.
"
notice: we use a different ratio here
"
hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.4) in:vpanel.
frame := View origin:(0.0 @ 0.0) corner:(0.33 @ 1.0) in:hpanel.
self createClassListViewIn:frame.
v := ScrollableView for:SelectionInListView in:hpanel.
v origin:(0.33 @ 0.0) corner:(0.66 @ 1.0).
methodCategoryListView := v scrolledView.
v := ScrollableView for:SelectionInListView in:hpanel.
v origin:(0.66 @ 0.0) corner:(1.0 @ 1.0).
methodListView := v scrolledView.
self createCodeViewIn:vpanel at:0.4.
cls := aClass.
cls isMeta ifTrue:[
cls := cls soleInstance
].
currentClassHierarchy := currentClass := actualClass := cls.
self updateClassList.
classListView selectElement:aClass name; makeSelectionVisible.
self updateMethodCategoryList.
self updateMethodList.
self updateCodeView.
aClass isMeta ifTrue:[
self instanceProtocol:false
].
!
setupForFullClass
"setup subviews to browse a class as full text"
|vpanel hpanel v|
vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
corner:(1.0 @ 1.0)
in:self.
hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
v := ScrollableView for:SelectionInListView in:hpanel.
v origin:(0.0 @ 0.0) corner:(0.5 @ 1.0).
classCategoryListView := v scrolledView.
classCategoryListView contents:(self listOfAllClassCategories).
v := ScrollableView for:SelectionInListView in:hpanel.
v origin:(0.5 @ 0.0) corner:(1.0 @ 1.0).
classListView := v scrolledView.
self createCodeViewIn:vpanel.
fullClass := true.
self updateCodeView
!
setupForClassCategory:aClassCategory
"setup subviews to browse a class category"
|vpanel hpanel frame v|
vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
corner:(1.0 @ 1.0)
in:self.
hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
frame := View origin:(0.0 @ 0.0) corner:(0.33 @ 1.0) in:hpanel.
self createClassListViewIn:frame.
v := ScrollableView for:SelectionInListView in:hpanel.
v origin:(0.33 @ 0.0) corner:(0.66 @ 1.0).
methodCategoryListView := v scrolledView.
v := ScrollableView for:SelectionInListView in:hpanel.
v origin:(0.66 @ 0.0) corner:(1.0 @ 1.0).
methodListView := v scrolledView.
self createCodeViewIn:vpanel.
currentClassCategory := aClassCategory.
self updateClassList.
self updateMethodCategoryList.
self updateMethodList.
self updateCodeView
!
setupForClass:aClass selector:selector
"setup subviews to browse a single method"
|v|
v := ScrollableView for:CodeView in:self.
v origin:(0.0 @ 0.0) corner:(1.0 @ 1.0).
codeView := v scrolledView.
currentClassCategory := aClass category.
self switchToClass:aClass.
actualClass := acceptClass := aClass.
currentSelector := selector.
currentMethod := currentClass compiledMethodAt:selector.
currentMethodCategory := currentMethod category.
self updateCodeView
!
setupForClassList:aList
"setup subviews to browse classes from a list"
|vpanel hpanel frame l v|
vpanel := VariableVerticalPanel
origin:(0.0 @ 0.0) corner:(1.0 @ 1.0) in:self.
hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
frame := View origin:(0.0 @ 0.0) corner:(0.33 @ 1.0) in:hpanel.
self createClassListViewIn:frame.
v := ScrollableView for:SelectionInListView in:hpanel.
v origin:(0.33 @ 0.0) corner:(0.66 @ 1.0).
methodCategoryListView := v scrolledView.
v := ScrollableView for:SelectionInListView in:hpanel.
v origin:(0.66 @ 0.0) corner:(1.0 @ 1.0).
methodListView := v scrolledView.
self createCodeViewIn:vpanel.
l := aList collect:[:entry | entry name].
classListView list:(l sort).
self updateMethodCategoryList.
self updateMethodList.
self updateCodeView
!
setupForClass:aClass methodCategory:aMethodCategory
"setup subviews to browse a method category"
|vpanel v|
vpanel := VariableVerticalPanel
origin:(0.0 @ 0.0) corner:(1.0 @ 1.0)
in:self.
v := ScrollableView for:SelectionInListView in:vpanel.
v origin:(0.0 @ 0.0) corner:(1.0 @ 0.25).
methodListView := v scrolledView.
self createCodeViewIn:vpanel.
currentClassCategory := aClass category.
self switchToClass:aClass.
actualClass := acceptClass := aClass.
currentMethodCategory := aMethodCategory.
self updateMethodList.
self updateCodeView
!
setupForFullClassProtocol:aClass
"setup subviews to browse a classes full protocol"
|vpanel hpanel frame v cls|
vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
corner:(1.0 @ 1.0)
in:self.
"
notice: we use a different ratio here
"
hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.4) in:vpanel.
frame := View origin:(0.0 @ 0.0) corner:(0.33 @ 1.0) in:hpanel.
self createClassListViewIn:frame.
classListView multipleSelectOk:true.
classListView toggleSelect:true.
classListView strikeOut:true.
v := ScrollableView for:SelectionInListView in:hpanel.
v origin:(0.33 @ 0.0) corner:(0.66 @ 1.0).
methodCategoryListView := v scrolledView.
v := ScrollableView for:SelectionInListView in:hpanel.
v origin:(0.66 @ 0.0) corner:(1.0 @ 1.0).
methodListView := v scrolledView.
self createCodeViewIn:vpanel at:0.4.
cls := aClass.
cls isMeta ifTrue:[
cls := cls soleInstance
].
currentClassHierarchy := actualClass := acceptClass := currentClass := cls.
fullProtocol := true.
self updateClassList.
self updateMethodCategoryList.
self updateMethodList.
self updateCodeView.
self updateVariableList.
aClass isMeta ifTrue:[
self instanceProtocol:false
].
! !
!BrowserView methodsFor:'class stuff'!
switchToClass:newClass
"switch to some other class;
keep instance protocol as it was ..."
|cls meta|
fullProtocol ifTrue:[^ self].
cls := newClass.
(meta := cls isMeta) ifTrue:[
cls := cls soleInstance
].
currentClass notNil ifTrue:[
currentClass removeDependent:self
].
currentClass := cls.
showInstance ifTrue:[
actualClass := acceptClass := cls.
] ifFalse:[
actualClass := acceptClass := cls class.
].
currentClass notNil ifTrue:[
currentClass addDependent:self.
].
self normalLabel.
"Modified: 1.9.1995 / 01:04:05 / claus"
!
classSelectionChanged
|oldMethodCategory oldMethod oldSelector|
self withWaitCursorDo:[
oldMethodCategory := currentMethodCategory.
oldMethod := currentMethod.
oldSelector := currentSelector.
showInstance ifTrue:[
actualClass := acceptClass := currentClass
] ifFalse:[
actualClass := acceptClass := currentClass class
].
currentMethodCategory := nil.
currentMethod := nil.
currentSelector := nil.
self updateVariableList.
self updateMethodCategoryList.
oldMethodCategory notNil ifTrue:[
methodCategoryListView selectElement:oldMethodCategory.
methodCategoryListView hasSelection ifTrue:[
currentMethodCategory := oldMethodCategory.
self methodCategorySelectionChanged
]
].
self updateMethodList.
self updateCodeView.
fullClass ifTrue:[
codeView acceptAction:[:theCode |
codeView cursor:Cursor execute.
Object abortSignal catch:[
self compileCode:theCode asString.
codeView modified:false.
].
codeView cursor:Cursor normal.
].
] ifFalse:[
self classDefinition.
codeView acceptAction:[:theCode |
codeView cursor:Cursor execute.
Object abortSignal catch:[
(Compiler evaluate:theCode asString notifying:codeView compile:false)
isBehavior ifTrue:[
self classCategoryUpdate.
self updateClassListWithScroll:false.
codeView modified:false.
].
].
codeView cursor:Cursor normal.
].
].
codeView explainAction:nil.
classCategoryListView notNil ifTrue:[
(currentClassCategory = currentClass category) ifFalse:[
currentClassCategory := currentClass category.
classCategoryListView selectElement:currentClassCategory
]
].
self setDoitActionForClass
]
!
updateClassListWithScroll:scroll
|classes oldClassName|
classListView notNil ifTrue:[
"
refetch in case we are not up to date
"
(currentClass notNil and:[fullProtocol not]) ifTrue:[
oldClassName := currentClass name.
currentClass := Smalltalk at:(oldClassName asSymbol).
].
currentClassCategory notNil ifTrue:[
classes := self listOfAllClassesInCategory:currentClassCategory
] ifFalse:[
currentClassHierarchy notNil ifTrue:[
classes := self listOfClassHierarchyOf:currentClassHierarchy
]
].
classListView list = classes ifFalse:[
scroll ifTrue:[
classListView contents:classes
] ifFalse:[
classListView setContents:classes
].
oldClassName notNil ifTrue:[
classListView setContents:classes.
classListView selectElement:oldClassName
] ifFalse:[
variableListView notNil ifTrue:[variableListView contents:nil]
]
].
scroll ifTrue:[
fullProtocol ifTrue:[
classListView scrollToBottom
]
]
]
!
doClassMenu:aBlock
"a helper - check if class is selected and evaluate aBlock
while showing waitCursor"
self checkClassSelected ifTrue:[
self withWaitCursorDo:[aBlock value:currentClass]
]
!
checkClassSelected
"warn and return false, if no class is selected"
currentClass isNil ifTrue:[
self warn:'select a class first'.
^ false
].
^ true
!
listOfAllClassesInCategory:aCategory
"return a list of all classes in a given category"
|newList classes searchCategory nm|
(aCategory = '* hierarchy *') ifTrue:[
newList := OrderedCollection new.
classes := Set new.
self classHierarchyDo:[:aClass :lvl|
nm := aClass name.
(classes includes:nm) ifFalse:[
classes add:nm.
newList add:(String new:lvl) , nm
]
].
^ newList
].
newList := Set new.
(aCategory = '* all *') ifTrue:[
Smalltalk allBehaviorsDo:[:aClass |
newList add:aClass name
]
] ifFalse:[
(aCategory = '* no category *') ifTrue:[
searchCategory := nil
] ifFalse:[
searchCategory := aCategory
].
Smalltalk allBehaviorsDo:[:aClass |
|thisCategory|
aClass isMeta ifFalse:[
thisCategory := aClass category.
((thisCategory = searchCategory)
or:[thisCategory = aCategory]) ifTrue:[
newList add:aClass name
]
]
]
].
(newList size == 0) ifTrue:[^ nil].
^ newList asOrderedCollection sort
!
classSelection:lineNr
"user clicked on a class line - show method categories"
|classSymbol cls oldSelector|
(currentClassHierarchy notNil
and:[fullProtocol]) ifTrue:[
oldSelector := currentSelector.
self updateMethodCategoryListWithScroll:false.
self updateMethodListWithScroll:false.
self updateVariableList.
^ self
].
cls := Smalltalk classNamed:classListView selectionValue withoutSpaces.
"
classSymbol := classListView selectionValue withoutSpaces asSymbol.
(Smalltalk includesKey:classSymbol) ifTrue:[
cls := Smalltalk at:classSymbol
].
"
cls notNil ifTrue:[
self switchToClass:cls.
self classSelectionChanged
]
!
updateClassList
self updateClassListWithScroll:true
!
templateFor:className in:cat
"return a class definition template - be smart in what is offered initially"
|aString name i|
name := 'NewClass'.
i := 1.
[name knownAsSymbol and:[Smalltalk includesKey:name asSymbol]] whileTrue:[
i := i + 1.
name := 'NewClass' , i printString
].
aString := className , ' subclass:#' , name , '
instanceVariableNames: ''''
classVariableNames: ''''
poolDictionaries: ''''
category: '''.
cat notNil ifTrue:[
aString := aString , cat
].
aString := aString , '''
"
Replace ''' , className , ''', ''', name , ''' and
the empty string arguments by true values.
Install (or change) the class by ''accepting'',
either via the menu or the keyboard (usually CMD-A).
To be nice to others (and yourself later), do not forget to
add some documentation; either under the classes documentation
protocol, or as a class comment.
"
'.
^ aString
!
listOfClassHierarchyOf:aClass
"return a hierarchy class-list"
|startClass classes thisOne|
showInstance ifTrue:[
startClass := aClass
] ifFalse:[
startClass := aClass class.
].
classes := startClass allSuperclasses.
thisOne := Array with:startClass.
classes notNil ifTrue:[
classes := classes reverse , thisOne.
] ifFalse:[
classes := thisOne
].
fullProtocol ifFalse:[
classes := classes , startClass allSubclassesInOrder
].
^ classes collect:[:c | c name]
!
switchToClassNamed:aString
|meta str classSymbol theClass newCat element|
meta := false.
str := aString.
classSymbol := aString asSymbolIfInterned.
classSymbol isNil ifTrue:[
(aString endsWith:'class') ifTrue:[
str := aString copyWithoutLast:5.
classSymbol := str asSymbolIfInterned.
classSymbol isNil ifTrue:[
^ self
].
meta := true
].
].
theClass := Smalltalk at:classSymbol.
(theClass isNil and:[str endsWith:'class']) ifTrue:[
str := str copyWithoutLast:5.
classSymbol := str asSymbolIfInterned.
classSymbol isNil ifTrue:[
^ self
].
meta := true.
theClass := Smalltalk at:classSymbol.
].
theClass == currentClass ifTrue:[^ self].
theClass isBehavior ifTrue:[
classCategoryListView notNil ifTrue:[
currentClassHierarchy isNil ifTrue:[
((newCat := theClass category) ~= currentClassCategory) ifTrue:[
currentClassCategory := newCat.
newCat isNil ifTrue:[
element := '* no category *'
] ifFalse:[
element := newCat.
].
classCategoryListView selectElement:element.
"/ classCategoryListView makeSelectionVisible.
]
]
].
self updateClassList.
self switchToClass:theClass.
classListView selectElement:str.
self instanceProtocol:meta not.
self classSelectionChanged
]
"Modified: 1.9.1995 / 01:41:35 / claus"
!
classClassDefinitionTemplateFor:name in:cat
"common helper for newClass and newSubclass
- show a template to define class name in category cat.
Also, set acceptaction to install the class."
currentMethodCategory := nil.
currentMethod := currentSelector := nil.
classListView deselect.
fullClass ifFalse:[
methodCategoryListView contents:nil.
methodListView contents:nil
].
codeView contents:(self templateFor:name in:cat).
codeView modified:false.
codeView acceptAction:[:theCode |
codeView cursor:Cursor execute.
Object abortSignal catch:[
|cls|
cls := (Compiler evaluate:theCode asString notifying:codeView compile:false).
cls isBehavior ifTrue:[
codeView modified:false.
self classCategoryUpdate.
self updateClassListWithScroll:false.
self switchToClassNamed:(cls name).
]
].
codeView cursor:(Cursor normal).
].
codeView explainAction:nil.
self switchToClass:nil
!
renameCurrentClassTo:aString
"helper - do the rename"
self doClassMenu:[:currentClass |
|oldName oldSym newSym|
oldName := currentClass name.
oldSym := oldName asSymbol.
"
currentClass setName:aString.
newSym := aString asSymbol.
Smalltalk at:oldSym put:nil.
Smalltalk removeKey:oldSym.
Smalltalk at:newSym put:currentClass.
"
"
currentClass renameTo:aString.
"
Smalltalk renameClass:currentClass to:aString.
self updateClassList.
self updateMethodCategoryListWithScroll:false.
self updateMethodListWithScroll:false.
self withWaitCursorDo:[
Transcript showCr:('searching for users of ' , oldSym); endEntry.
SystemBrowser browseReferendsOf:oldSym warnIfNone:false
]
]
!
switchToClassNameMatching:aMatchString
|classNames thisName box|
classNames := OrderedCollection new.
Smalltalk allBehaviorsDo:[:aClass |
thisName := aClass name.
(aMatchString match:thisName) ifTrue:[
classNames add:thisName
]
].
(classNames size == 0) ifTrue:[^ nil].
(classNames size == 1) ifTrue:[
^ self switchToClassNamed:(classNames at:1)
].
box := self listBoxTitle:'select class to switch to:'
okText:'ok'
list:classNames sort.
box action:[:aString | self switchToClassNamed:aString].
box showAtPointer
! !
!BrowserView methodsFor:'variable stuff'!
unhilightMethods
"unhighlight items in method list"
variableListView isNil ifTrue:[^ self].
methodListView notNil ifTrue:[
1 to:methodListView list size do:[:entry |
methodListView attributeAt:entry put:nil.
].
].
!
hilightMethodsInMethodCategoryList:inCat inMethodList:inMethods
"search for methods which access the selected
variable, and highlight them"
|name redefinedSelectors|
variableListView isNil ifTrue:[^ self].
inCat ifTrue:[self unhilightMethodCategories].
inMethods ifTrue:[self unhilightMethods].
actualClass isNil ifTrue:[^ self].
(methodCategoryListView isNil
and:[methodListView isNil]) ifTrue:[^ self].
name := variableListView selectionValue.
name isNil ifTrue:[^ self].
self withCursor:(Cursor questionMark) do:[
|classes filter any|
classes := Array with:actualClass.
currentClassHierarchy notNil ifTrue:[
classes := classes , actualClass allSuperclasses.
redefinedSelectors := IdentitySet new.
].
filter := SystemBrowser filterToSearchRefsTo:name classVars:showInstance not modificationsOnly:false.
any := false.
"
highlight the method that ref this variable
"
classes do:[:someClass |
(fullProtocol
and:[classListView valueIsInSelection:(someClass name)]) ifFalse:[
someClass methodArray with:someClass selectorArray
do:[:method :selector |
(inCat
or:[methodListView list notNil
and:[methodListView list includes:selector]])
ifTrue:[
(redefinedSelectors isNil
or:[(redefinedSelectors includes:selector) not])
ifTrue:[
(filter value:someClass value:method value:selector) ifTrue:[
|idx cat|
(inCat
and:[methodCategoryListView notNil
and:[methodCategoryListView list notNil]]) ifTrue:[
cat := method category.
"
highlight the methodCategory
"
idx := methodCategoryListView list indexOf:cat.
idx ~~ 0 ifTrue:[
methodCategoryListView attributeAt:idx put:#bold.
].
].
(inMethods
and:[methodListView notNil
and:[methodListView list notNil]]) ifTrue:[
"
highlight the method
"
idx := methodListView list indexOf:selector.
idx ~~ 0 ifTrue:[
methodListView attributeAt:idx put:#bold.
].
any := true
].
].
redefinedSelectors notNil ifTrue:[
redefinedSelectors add:selector
]
]
]
]
]
].
any ifTrue:[
self setSearchPattern:name
]
]
!
updateVariableList
|l subList last nameAccessSelector class oldSelection|
variableListView isNil ifTrue:[^ self].
oldSelection := variableListView selectionValue.
l := OrderedCollection new.
"
show classVars, if classProtocol is shown (instead of classInstance vars)
"
showInstance ifTrue:[
nameAccessSelector := #instVarNames
] ifFalse:[
nameAccessSelector := #classVarNames
].
"/ class := currentClass notNil ifTrue:[currentClass] ifFalse:[actualClass].
"/ class isNil ifTrue:[class := currentClassHierarchy].
class := currentClassHierarchy notNil ifTrue:[currentClassHierarchy] ifFalse:[currentClass].
class withAllSuperclasses do:[:aClass |
|ignore|
ignore := fullProtocol
and:[classListView valueIsInSelection:(aClass name asString)].
ignore ifFalse:[
subList := aClass perform:nameAccessSelector.
subList size ~~ 0 ifTrue:[
l := l , (subList asOrderedCollection reverse).
l := l , (OrderedCollection with:'---- ' , aClass name , ' ---------').
]
]
].
l reverse.
variableListView setAttributes:nil.
variableListView list:l.
l keysAndValuesDo:[:index :entry |
(entry startsWith:'---') ifTrue:[
variableListView attributeAt:index put:#disabled.
last := index
]
].
last notNil ifTrue:[variableListView scrollToLine:last].
oldSelection notNil ifTrue:[
variableListView selectElement:oldSelection.
self hilightMethodsInMethodCategoryList:true inMethodList:true.
]
!
unhilightMethodCategories
"unhighlight items in method list"
variableListView isNil ifTrue:[^ self].
methodCategoryListView notNil ifTrue:[
1 to:methodCategoryListView list size do:[:entry |
methodCategoryListView attributeAt:entry put:nil.
]
].
!
hilightMethodsInMethodCategoryList
"search for methods which access the selected
variable, and highlight them"
self hilightMethodsInMethodCategoryList:true inMethodList:false
!
hilightMethodsInMethodList
"search for methods which access the selected
variable, and highlight them"
self hilightMethodsInMethodCategoryList:false inMethodList:true
! !
!BrowserView methodsFor:'class list menu'!
classDefinition
"show class definition in codeView and setup accept-action for
a class-definition change.
Extract documentation either from a documentation method or
from the comment - not a biggy, but beginners will like
it when exploring the system."
self doClassMenu:[:currentClass |
|m s aStream isComment|
aStream := WriteStream on:(String new:200).
currentClass fileOutDefinitionOn:aStream.
currentClass isLoaded ifTrue:[
"
add documentation as a comment, if there is any
"
m := currentClass class compiledMethodAt:#documentation.
m notNil ifTrue:[
s := m comment.
isComment := false.
] ifFalse:[
"try comment"
s := currentClass comment.
s notNil ifTrue:[
s isEmpty ifTrue:[
s := nil
] ifFalse:[
isComment := true
]
]
].
].
aStream cr.
aStream cr.
aStream cr.
aStream cr.
aStream cr.
s isNil ifTrue:[
aStream nextPut:$" ; cr; nextPutAll:' no comment or documentation found'; cr.
] ifFalse:[
aStream nextPut:$" ; cr; nextPutAll:' Documentation:'; cr.
aStream cr.
aStream nextPutAll:s.
aStream cr; cr.
aStream nextPutAll:' Notice: '; cr.
aStream nextPutAll:' the above string has been extracted from the classes '.
aStream nextPutAll:(isComment ifTrue:['comment.'] ifFalse:['documentation method.']).
aStream cr.
aStream nextPutAll:' It will not be preserved when accepting a new class definition.'; cr.
].
aStream nextPut:$".
codeView contents:(aStream contents).
codeView modified:false.
codeView acceptAction:[:theCode |
codeView cursor:Cursor execute.
Object abortSignal catch:[
(Compiler evaluate:theCode asString notifying:codeView compile:false)
isBehavior ifTrue:[
codeView modified:false.
self classCategoryUpdate.
self updateClassListWithScroll:false.
]
].
codeView cursor:Cursor normal.
].
codeView explainAction:nil.
methodListView notNil ifTrue:[
methodListView deselect
].
aspect := #definition.
self normalLabel
]
!
classMenu
"sent by classListView to ask for the menu"
|labels selectors|
(device ctrlDown
and:[currentClass notNil]) ifTrue:[
labels := #(
'inspect class'
'-'
'primitive definitions'
'primitive variables'
'primitive functions'
).
selectors := #(
classInspect
nil
classPrimitiveDefinitions
classPrimitiveVariables
classPrimitiveFunctions
).
] ifFalse:[
currentClass isNil ifTrue:[
labels := #(
'new class'
).
selectors := #(
classNewClass
).
] ifFalse:[
currentClass isLoaded ifFalse:[
labels := #(
'new class'
'-'
'load '
).
selectors := #(
classNewClass
nil
classLoad
).
] ifTrue:[
fullProtocol ifTrue:[
labels := #(
'hierarchy'
'definition'
'comment'
'class instvars'
).
selectors := #(
classHierarchy
classDefinition
classComment
classClassInstVars
).
] ifFalse:[
labels := #(
'fileOut'
'printOut'
'printOut protocol'
" 'printOut full protocol' "
'-'
'SPAWN_CLASS'
'spawn full protocol'
'spawn hierarchy'
'spawn subclasses'
'-'
).
selectors := #(
classFileOut
classPrintOut
classPrintOutProtocol
" classPrintOutFullProtocol "
nil
classSpawn
classSpawnFullProtocol
classSpawnHierarchy
classSpawnSubclasses
nil
).
fullClass ifFalse:[
labels := labels , #(
'hierarchy'
'definition'
'comment'
'class instvars'
"/ 'protocols'
'-'
).
selectors := selectors , #(
classHierarchy
classDefinition
classComment
classClassInstVars
"/ classProtocols
nil
).
].
"
dont offer this menu for now - you cannot recompile
the stuff anyway. So there is only confusion in showing
those ...
"
false "currentClass primitiveSpec notNil" ifTrue:[
labels := labels , #(
'primitive definitions'
'primitive variables'
'primitive functions'
'-'
).
selectors := selectors , #(
classPrimitiveDefinitions
classPrimitiveVariables
classPrimitiveFunctions
nil
).
].
labels := labels , #(
"/ 'variable search'
'class refs'
'-'
'new class'
'new subclass'
'rename ...'
'remove'
).
selectors := selectors , #(
"/ variables
classRefs
nil
classNewClass
classNewSubclass
classRename
classRemove
).
currentClass wasAutoloaded ifTrue:[
labels := labels , #(
'unload'
).
selectors := selectors , #(
classUnload
).
]
]
].
].
].
^ PopUpMenu labels:(resources array:labels)
selectors:selectors
!
classFileOut
"fileOut the current class.
Catch errors (sure, you like to know if it failed) and
warn if any)"
self doClassMenu:[:currentClass |
|msg|
self busyLabel:'saving %1' with:currentClass name.
Class fileOutErrorSignal handle:[:ex |
self warn:'cannot create: %1\(%2)' with:ex parameter with:ex errorString.
ex return.
] do:[
currentClass fileOut.
].
self normalLabel.
]
!
doClassMenuWithSelection:aBlock
"a helper - if there is a selection, which represents a classes name,
evaluate aBlock, passing that class and optional selector as arguments.
Otherwise, check if a class is selected and evaluate aBlock with the
current class."
|string words clsName cls sel isMeta|
string := codeView selection.
string notNil ifTrue:[
self extractClassAndSelectorFromSelectionInto:[:c :s :m |
clsName := c.
sel := s.
isMeta := m.
].
clsName isNil ifTrue:[
string := string asString withoutSeparators.
words := string asCollectionOfWords.
words notNil ifTrue:[
clsName := words first.
(clsName endsWith:'class') ifTrue:[
isMeta := true.
clsName := clsName copyWithoutLast:5 "copyTo:(clsName size - 5)"
] ifFalse:[
isMeta := false
].
sel := Parser selectorInExpression:string.
]
].
clsName notNil ifTrue:[
(cls := Smalltalk classNamed:clsName) notNil ifTrue:[
isMeta ifTrue:[
cls := cls class
].
self withWaitCursorDo:[
aBlock value:cls value:sel.
].
^ self
] ifFalse:[
self warn:'no class named: %1 - spawning current' with:clsName
]
].
].
classMethodListView notNil ifTrue:[
sel := classMethodListView selectionValue.
sel notNil ifTrue:[
sel := self selectorFromClassMethodString:sel
]
].
self doClassMenu:[:currentClass | aBlock value:currentClass value:sel]
!
classSpawn
"create a new SystemBrowser browsing current class,
or if there is a selection, spawn a browser on the selected class
even a class/selector pair can be specified."
self doClassMenuWithSelection:[:cls :sel |
|browser|
cls isMeta ifTrue:[
Smalltalk allBehaviorsDo:[:aClass |
aClass class == cls ifTrue:[
browser := SystemBrowser browseClass:aClass.
browser instanceProtocol:false.
sel notNil ifTrue:[
browser switchToMethodNamed:sel
].
^ self
].
].
self warn:'oops, no class for this metaclass'.
^ self
].
browser := SystemBrowser browseClass:cls.
cls hasMethods ifFalse:[
browser instanceProtocol:false.
].
sel notNil ifTrue:[
browser switchToMethodNamed:sel
].
]
"
select 'Smalltalk allClassesDo:' and use spawn from the class menu
select 'Smalltalk' and use spawn from the class menu
"
!
classSpawnHierarchy
"create a new HierarchyBrowser browsing current class"
self doClassMenuWithSelection:[:cls :sel |
SystemBrowser browseClassHierarchy:cls
]
!
classSpawnSubclasses
"create a new browser browsing current class's subclasses"
self doClassMenuWithSelection:[:cls :sel |
|subs|
subs := cls allSubclasses.
(subs notNil and:[subs size ~~ 0]) ifTrue:[
SystemBrowser browseClasses:subs title:('subclasses of ' , cls name)
]
]
!
classPrintOutWith:aSelector
self doClassMenu:[:currentClass |
|printStream|
printStream := Printer new.
currentClass perform:aSelector with:printStream.
printStream close
]
!
classPrintOutFullProtocol
self classPrintOutWith:#printOutFullProtocolOn:
!
classPrintOutProtocol
self classPrintOutWith:#printOutProtocolOn:
!
classPrintOut
self classPrintOutWith:#printOutOn:
!
classHierarchy
"show current classes hierarchy in codeView"
self doClassMenu:[:currentClass |
|aStream|
aStream := WriteStream on:(String new:200).
actualClass printHierarchyOn:aStream.
codeView contents:(aStream contents).
codeView modified:false.
codeView acceptAction:nil.
codeView explainAction:nil.
methodListView notNil ifTrue:[
methodListView deselect
].
aspect := #hierarchy.
self normalLabel
]
!
classNewClass
"create a class-definition prototype in codeview"
|nm cls cat|
nm := 'Object'.
currentClass notNil ifTrue:[
(cls := currentClass superclass) notNil ifTrue:[
nm := cls name
]
].
cat := currentClassCategory.
cat isNil ifTrue:[
cat := '* no category *'
].
self classClassDefinitionTemplateFor:nm in:cat.
aspect := nil.
!
classClassInstVars
"show class instance variables in codeView and setup accept-action
for a class-instvar-definition change"
self doClassMenu:[:currentClass |
|s|
s := WriteStream on:(String new).
currentClass fileOutClassInstVarDefinitionOn:s.
codeView contents:(s contents).
codeView modified:false.
codeView acceptAction:[:theCode |
codeView cursor:Cursor execute.
Object abortSignal catch:[
Compiler evaluate:theCode asString notifying:codeView compile:false.
codeView modified:false.
self updateClassList.
].
codeView cursor:Cursor normal.
].
codeView explainAction:nil.
methodListView notNil ifTrue:[
methodListView deselect
].
aspect := #classInstVars.
self normalLabel
]
!
classSpawnFullProtocol
"create a new browser, browsing current classes full protocol"
self doClassMenuWithSelection:[:cls :sel |
SystemBrowser browseFullClassProtocol:cls
]
!
classLoad
"load an autoloaded class"
|nm|
self checkClassSelected ifFalse:[^ self].
nm := currentClass name.
currentClass autoload.
self switchToClassNamed:nm
!
classUnload
"unload an autoloaded class"
|nm|
self checkClassSelected ifFalse:[^ self].
nm := currentClass name.
currentClass unload.
self switchToClassNamed:nm
!
classInspect
"inspect the current class"
self checkClassSelected ifFalse:[^ self].
currentClass inspect.
!
classProtocols
^ self
!
classRemove
"user requested remove of current class and all subclasses -
count subclasses and let user confirm removal."
|count t box|
currentClass notNil ifTrue:[
count := currentClass allSubclasses size.
t := 'remove %1'.
count ~~ 0 ifTrue:[
t := t , '\(with %2 subclass'.
count ~~ 1 ifTrue:[
t := t , 'es'
].
t := (t , ')')
].
t := t , ' ?'.
t := (resources string:t with:currentClass name with:count) withCRs.
box := YesNoBox
title:t
yesText:(resources at:'remove')
noText:(resources at:'abort').
box confirm ifTrue:[
"after querying user - do really remove current class
and all subclasses
"
self doClassMenu:[:currentClass |
|didRemove|
didRemove := false.
"
query ?
"
currentClass allSubclassesDo:[:aSubClass |
(CheckForInstancesWhenRemovingClasses not
or:[aSubClass hasInstances not
or:[self confirm:(aSubClass name , ' has instances - remove anyway ?')]])
ifTrue:[
Smalltalk removeClass:aSubClass
]
].
(CheckForInstancesWhenRemovingClasses not
or:[currentClass hasInstances not
or:[self confirm:(currentClass name , ' has instances - remove anyway ?')]])
ifTrue:[
didRemove := true.
Smalltalk removeClass:currentClass.
].
self switchToClass:nil.
Smalltalk changed.
self updateClassList.
"if it was the last in its category, update class category list"
"
classListView numberOfLines == 0 ifTrue:[
self updateClassCategoryListWithScroll:false
].
"
didRemove ifTrue:[
methodCategoryListView notNil ifTrue:[methodCategoryListView contents:nil].
methodListView notNil ifTrue:[methodListView contents:nil].
codeView contents:nil.
codeView modified:false
]
]
]
]
!
classShowFrom:getSelector set:setSelector aspect:aspectSymbol default:default
"common helper for comment, primitive-stuff etc.
show the string returned from the classes getSelector-method,
Set acceptaction to change it via setSelector."
self doClassMenu:[:currentClass |
|text|
text := currentClass perform:getSelector.
text isNil ifTrue:[
text := default
].
codeView contents:text.
codeView modified:false.
codeView acceptAction:[:theCode |
Object abortSignal catch:[
lockUpdates := true.
currentClass perform:setSelector with:theCode asString.
codeView modified:false.
].
lockUpdates := false.
].
codeView explainAction:nil.
methodListView notNil ifTrue:[
methodListView deselect
].
aspect := aspectSymbol.
self normalLabel
]
!
classComment
"show the classes comment in the codeView.
Also, set accept action to change the comment."
self classShowFrom:#comment
set:#comment:
aspect:#comment
default:nil
!
classPrimitiveDefinitions
"show the classes primitiveDefinition in the codeView.
Also, set accept action to change it."
self classShowFrom:#primitiveDefinitionsString
set:#primitiveDefinitions:
aspect:#primitiveDefinitions
default:'%{
/*
* includes, defines, structure definitions
* and typedefs come here.
*/
%}'
!
classPrimitiveVariables
"show the classes primitiveVariables in the codeView.
Also, set accept action to change it."
self classShowFrom:#primitiveVariablesString
set:#primitiveVariables:
aspect:#primitiveVariables
default:'%{
/*
* any local C variables
* come here (please, define as static)
*/
%}'
!
classPrimitiveFunctions
"show the classes primitiveFunctions in the codeView.
Also, set accept action to change it."
self classShowFrom:#primitiveFunctionsString
set:#primitiveFunctions:
aspect:#primitiveFunctions
default:'%{
/*
* any local C (helper) functions
* come here (please, define as static)
*/
%}'
!
classNewSubclass
"create a subclass-definition prototype in codeview"
self doClassMenu:[:currentClass |
self classClassDefinitionTemplateFor:(currentClass name)
in:(currentClass category).
aspect := nil
]
!
classRefs
self doClassMenu:[:currentClass |
self withCursor:(Cursor questionMark) do:[
SystemBrowser browseReferendsOf:currentClass name asSymbol
]
]
!
classUses
"a powerful tool, when trying to learn more about where
a class is used. This one searches all uses of a class,
and shows a list of uses - try it and like it"
self doClassMenu:[:currentClass |
self withCursor:(Cursor questionMark) do:[
SystemBrowser browseUsesOf:currentClass
]
]
!
classRename
"launch an enterBox for new name and query user"
|box|
self checkClassSelected ifFalse:[^ self].
box := self enterBoxTitle:(resources string:'rename %1 to:' with:currentClass name) okText:'rename'.
box initialText:(currentClass name).
box action:[:aString | self renameCurrentClassTo:aString].
box showAtPointer
! !
!BrowserView methodsFor:'unused'!
listOfAllSelectorsInCategory:aCategory inHierarchyOfClass:aClass
"answer a list of all selectors in a given method category
of the argument, aClass and its superclasses"
|newList|
newList := Set new.
self classesInHierarchy:aClass do:[:c |
|searchCategory|
(aCategory = '* all *') ifTrue:[
newList addAll:(c selectorArray)
] ifFalse:[
(aCategory = '* no category *') ifTrue:[
searchCategory := nil
] ifFalse:[
searchCategory := aCategory
].
c methodArray with:c selectorArray do:[:aMethod :selector |
(aMethod category = searchCategory) ifTrue:[
newList add:selector
]
]
].
].
(newList size == 0) ifTrue:[^ nil].
^ newList asOrderedCollection sort
!
listOfAllMethodCategoriesInHierarchy:aClass
"answer a list of all method categories of the argument, aClass,
and all of its superclasses"
|newList cat|
newList := Set new.
self classesInHierarchy:aClass do:[:c |
c methodArray do:[:aMethod |
cat := aMethod category.
cat isNil ifTrue:[
cat := '* no category *'
].
newList add:cat
]
].
(newList size == 0) ifTrue:[^ nil].
newList add:'* all *'.
^ newList asOrderedCollection sort
! !
!BrowserView methodsFor:'class category stuff'!
switchToAnyMethod:aSelectorString
"find all implementors of aSelectorString, and present a list
to choose from. When an entry is selected, switch to that class/selector.
This allows for quickly moving around in the system."
|classes sel box theClassName|
classes := OrderedCollection new.
aSelectorString knownAsSymbol ifTrue:[
sel := aSelectorString asSymbol.
Smalltalk allClassesDo:[:aClass |
(aClass implements:sel) ifTrue:[
classes add:aClass.
].
(aClass class implements:sel) ifTrue:[
classes add:aClass class.
].
]
].
classes size == 0 ifTrue:[
SystemBrowser showNoneFound.
^ self
].
classes size > 1 ifTrue:[
box := ListSelectionBox title:(resources string:'#%1\in which class ?' with:aSelectorString) withCRs.
box okText:(resources string:'show').
box list:(classes collect:[:aClass | aClass name]) asSortedCollection.
box action:[:aString | theClassName := aString].
box entryCompletionBlock:[
|s l what m|
s := box contents asString withoutSpaces.
l := classes select:[:cls | cls name startsWith:s].
l size > 0 ifTrue:[
box list:(l collect:[:aClass | aClass name]) asSortedCollection.
box contents:l first name.
l size ~~ 1 ifTrue:[
device beep
]
]
].
box showAtPointer.
] ifFalse:[
theClassName := classes first name
].
theClassName notNil ifTrue:[
self switchToClassNamed:theClassName.
self updateMethodCategoryList.
self switchToMethodNamed:aSelectorString.
].
"Modified: 1.9.1995 / 01:39:58 / claus"
!
listOfAllClassCategories
"return a list of all class categories"
|newList cat|
newList := Set with:'* all *' with:'* hierarchy *'.
Smalltalk allBehaviorsDo:[:aClass |
aClass isMeta ifFalse:[
cat := aClass category.
cat isNil ifTrue:[
cat := '* no category *'
].
cat ~= 'obsolete' ifTrue:[
newList add:cat
]
]
].
^ newList asOrderedCollection sort.
!
classCategorySelectionChanged
"class category has changed - update dependent views"
self withWaitCursorDo:[
self switchToClass:nil.
actualClass := acceptClass := nil.
currentMethodCategory := nil.
currentMethod := currentSelector := nil.
self updateClassList.
self updateMethodCategoryList.
self updateMethodList.
self updateCodeView.
codeView explainAction:nil.
codeView acceptAction:nil
]
!
classCategorySelection:lineNr
"user clicked on a class category line - show classes.
If switching to hierarchy or all, keep current selections"
|newCategory oldClass oldName classIndex|
newCategory := classCategoryListView selectionValue.
(newCategory startsWith:'*') ifTrue:[
"etiher all or hierarchy;
remember current selections and switch after showing class list"
oldClass := currentClass
].
currentClassCategory := newCategory.
oldClass isNil ifTrue:[
self classCategorySelectionChanged
] ifFalse:[
oldName := oldClass name.
self withWaitCursorDo:[
self updateClassList
].
"stupid - search for class name in (indented) list"
classIndex := classListView list findFirst:[:elem | elem endsWith:oldName].
classIndex ~~ 0 ifTrue:[
classListView selection:classIndex.
self switchToClass:(Smalltalk at:(oldName asSymbol))
] ifFalse:[
self normalLabel.
]
]
!
updateClassCategoryListWithScroll:scroll
|oldClassCategory oldClass oldMethodCategory oldMethod
oldSelector newCategoryList|
classMethodListView notNil ifTrue:[ ^ self ].
oldClassCategory := currentClassCategory.
oldClass := currentClass.
oldMethodCategory := currentMethodCategory.
oldMethod := currentMethod.
oldMethod notNil ifTrue:[
oldSelector := currentSelector
].
classCategoryListView notNil ifTrue:[
newCategoryList := self listOfAllClassCategories.
newCategoryList = classCategoryListView list ifFalse:[
scroll ifTrue:[
classCategoryListView contents:newCategoryList
] ifFalse:[
classCategoryListView setContents:newCategoryList
]
]
].
oldClassCategory notNil ifTrue:[
classCategoryListView notNil ifTrue:[
classCategoryListView selectElement:oldClassCategory
]
].
classListView notNil ifTrue:[
oldClass notNil ifTrue:[
classListView selectElement:(oldClass name)
]
].
oldMethodCategory notNil ifTrue:[
methodCategoryListView notNil ifTrue:[
methodCategoryListView selectElement:oldMethodCategory
].
].
oldSelector notNil ifTrue:[
methodListView notNil ifTrue:[
methodListView selectElement:oldSelector
].
]
!
checkClassCategorySelected
currentClassCategory isNil ifTrue:[
self warn:'select a class category first'.
^ false
].
^ true
!
updateClassCategoryList
self updateClassCategoryListWithScroll:true
!
renameCurrentClassCategoryTo:aString
"helper - do the rename"
|any categories|
currentClassCategory notNil ifTrue:[
any := false.
Smalltalk allBehaviorsDo:[:aClass |
aClass category = currentClassCategory ifTrue:[
aClass category:aString.
any := true
]
].
any ifFalse:[
categories := classCategoryListView list.
categories remove:currentClassCategory.
categories add:aString.
categories sort.
classCategoryListView setContents:categories.
currentClassCategory := aString.
classCategoryListView selectElement:aString.
] ifTrue:[
currentClassCategory := aString.
self updateClassCategoryList.
self updateClassListWithScroll:false
]
]
! !
!BrowserView methodsFor:'class-method stuff'!
classFromClassMethodString:aString
"helper for classMethod-list - extract class name from the string"
"/ |pos|
"/
"/ pos := aString indexOf:(Character space).
"/ ^ aString copyTo:(pos - 1)
^ aString upTo:Character space
!
selectorFromClassMethodString:aString
"helper for classMethod-list - extract selector from the string"
|pos|
pos := aString indexOf:(Character space).
^ aString copyFrom:(pos + 1)
!
classMethodSelection:lineNr
"user clicked on a class/method line - show code"
|cls string classString selectorString meta|
string := classMethodListView selectionValue.
classString := self classFromClassMethodString:string.
selectorString := self selectorFromClassMethodString:string.
((classString ~= 'Metaclass') and:[classString endsWith:'class']) ifTrue:[
classString := classString copyWithoutLast:5 "copyTo:(classString size - 5)".
meta := true.
] ifFalse:[
meta := false.
].
self switchToClass:(Smalltalk at:classString asSymbol).
meta ifTrue:[cls := currentClass class] ifFalse:[cls := currentClass].
actualClass := acceptClass := cls.
currentClass isNil ifTrue:[
self warn:'oops class is gone'
] ifFalse:[
currentClassCategory := currentClass category.
currentSelector := selectorString asSymbol.
currentMethod := actualClass compiledMethodAt:currentSelector.
currentMethod isNil ifTrue:[
self warn:'oops method is gone'
] ifFalse:[
currentMethodCategory := currentMethod category.
].
self methodSelectionChanged
].
self setDoitActionForClass
"Modified: 31.8.1995 / 11:56:02 / claus"
! !
!BrowserView methodsFor:'class category list menu'!
classCategoryMenu
|labels selectors|
currentClassCategory isNil ifTrue:[
labels := #(
'spawn full class'
'-'
'update'
'find class ...'
'find method ...'
'-'
'new class category ...'
).
selectors := #(
classCategorySpawnFullClass
nil
classCategoryUpdate
classCategoryFindClass
classCategoryFindMethod
nil
classCategoryNewCategory
).
] ifFalse:[
labels := #(
'fileOut'
'fileOut each'
"
'fileOut binary'
"
'printOut'
'printOut protocol'
'-'
'SPAWN_CATEGORY'
'spawn full class'
'-'
'update'
'find class ...'
'find method ...'
'-'
'new class category ...'
'rename ...'
'remove'
).
selectors := #(
classCategoryFileOut
classCategoryFileOutEach
classCategoryPrintOut
classCategoryPrintOutProtocol
nil
classCategorySpawn
classCategorySpawnFullClass
nil
classCategoryUpdate
classCategoryFindClass
classCategoryFindMethod
nil
classCategoryNewCategory
classCategoryRename
classCategoryRemove
).
].
^ PopUpMenu labels:(resources array:labels)
selectors:selectors
!
classCategoryUpdate
"update class category list and dependants"
|oldClassName oldMethodCategory|
classCategoryListView notNil ifTrue:[
currentClass notNil ifTrue:[
oldClassName := currentClass name.
(oldClassName endsWith:'-old') ifTrue:[
oldClassName := oldClassName copyWithoutLast:4 "copyTo:(oldClassName size - 4)"
]
].
oldMethodCategory := currentMethodCategory.
classCategoryListView setContents:(self listOfAllClassCategories).
currentClassCategory notNil ifTrue:[
classCategoryListView selectElement:currentClassCategory.
self classCategorySelectionChanged.
oldClassName notNil ifTrue:[
classListView selectElement:oldClassName.
self switchToClass:(Smalltalk at:oldClassName asSymbol).
self classSelectionChanged.
oldMethodCategory notNil ifTrue:[
methodCategoryListView selectElement:oldMethodCategory.
currentMethodCategory := oldMethodCategory.
self methodCategorySelectionChanged
]
]
]
]
!
classCategoryPrintOutProtocol
|printStream|
Smalltalk allClassesInCategory:currentClassCategory inOrderDo:[:aClass |
printStream := Printer new.
aClass printOutProtocolOn:printStream.
printStream close
]
!
classCategoryPrintOut
|printStream|
Smalltalk allClassesInCategory:currentClassCategory do:[:aClass |
printStream := Printer new.
aClass printOutOn:printStream.
printStream close
]
!
classCategorySpawn
"create a new SystemBrowser browsing current classCategory"
currentClassCategory notNil ifTrue:[
self withWaitCursorDo:[
SystemBrowser browseClassCategory:currentClassCategory
]
]
!
classCategoryFileOut
"create a file 'categoryName' consisting of all classes in current category"
|aStream fileName|
self checkClassCategorySelected ifFalse:[^ self].
fileName := currentClassCategory asString.
fileName replaceAll:Character space by:$_.
"
this test allows a smalltalk to be built without Projects/ChangeSets
"
Project notNil ifTrue:[
fileName := Project currentProjectDirectory , fileName.
].
self withWaitCursorDo:[
"
if file exists, save original in a .sav file
"
fileName asFilename exists ifTrue:[
self busyLabel:'saving existing %1' with:fileName.
fileName asFilename copyTo:(fileName , '.sav')
].
aStream := FileStream newFileNamed:fileName.
aStream isNil ifTrue:[
self warn:'cannot create: %1' with:fileName
] ifFalse:[
self busyLabel:'writing: %1' with:fileName.
Smalltalk allClassesInCategory:currentClassCategory inOrderDo:[:aClass |
aClass fileOutOn:aStream.
].
aStream close.
]
].
self normalLabel.
!
classCategorySpawnFullClass
"create a new SystemBrowser browsing full class"
|newBrowser|
self withWaitCursorDo:[
newBrowser := SystemBrowser browseFullClasses
" "
.
currentClass notNil ifTrue:[
newBrowser switchToClassNamed:(currentClass name)
]
" "
]
!
classCategoryFileOutEach
self withWaitCursorDo:[
Smalltalk allClassesInCategory:currentClassCategory do:[:aClass |
self busyLabel:'saving: %1' with:aClass name.
Class fileOutErrorSignal handle:[:ex |
self warn:'cannot create: %1' with:ex parameter.
ex return.
] do:[
aClass fileOut
]
].
self normalLabel.
]
!
classCategoryNewCategory
|box|
box := self enterBoxTitle:'name of new class category:' okText:'create'.
box action:[:aString |
|categories|
currentClass notNil ifTrue:[
categories := Set new.
currentClass withAllSuperclasses do:[:aClass |
aClass methodArray do:[:aMethod |
categories add:aMethod category
]
].
categories := categories asOrderedCollection
].
categories isNil ifTrue:[
categories := classCategoryListView list.
].
(categories includes:aString) ifFalse:[
categories add:aString.
categories sort.
classCategoryListView setContents:categories.
currentClassCategory := aString.
classCategoryListView selectElement:aString.
self switchToClass:nil.
actualClass := acceptClass := nil.
self classCategorySelectionChanged
]
].
box showAtPointer
!
classCategoryFindClass
|box|
box := self enterBoxForCodeSelectionTitle:'class to find:' okText:'find'.
box entryCompletionBlock:[
|s what m|
s := box contents asString withoutSpaces.
what := Smalltalk classnameCompletion:s.
box contents:what first.
(what at:2) size ~~ 1 ifTrue:[
device beep
]
].
box action:[:aString | self switchToClassNameMatching:aString].
box showAtPointer
!
classCategoryFindMethod
|box|
box := self listBoxForCodeSelectionTitle:'selector to find:' okText:'find'.
box entryCompletionBlock:[
|s what m|
s := box contents.
s isNil ifTrue:[s := ''].
s := s asString withoutSpaces.
box topView withWaitCursorDo:[
what := Smalltalk selectorCompletion:s.
box list:(what at:2).
box contents:what first.
(what at:2) size ~~ 1 ifTrue:[
device beep
]
]
].
box action:[:aString | self switchToAnyMethod:aString].
box showAtPointer
"Modified: 30.8.1995 / 22:49:49 / claus"
!
classCategoryRename
"launch an enterBox to rename current class category"
|box|
self checkClassCategorySelected ifFalse:[^ self].
box := self enterBoxTitle:'rename class category to:' okText:'rename'.
box initialText:currentClassCategory.
box action:[:aString | self renameCurrentClassCategoryTo:aString].
box showAtPointer
!
classCategoryRemove
"remove all classes in current category"
|count t classesToRemove subclassesRemoved box|
self checkClassCategorySelected ifFalse:[^ self].
classesToRemove := OrderedCollection new.
Smalltalk allBehaviorsDo:[:aClass |
aClass category = currentClassCategory ifTrue:[
classesToRemove add:aClass
]
].
subclassesRemoved := OrderedCollection new.
classesToRemove do:[:aClass |
aClass allSubclassesDo:[:aSubclass |
(classesToRemove includes:aSubclass) ifFalse:[
(subclassesRemoved includes:aSubclass) ifFalse:[
subclassesRemoved add:aSubclass
]
]
]
].
count := classesToRemove size.
t := resources string:'remove %1 ?' with:currentClassCategory.
count ~~ 0 ifTrue:[
t := t , (resources at:'\(with ') , count printString.
count == 1 ifTrue:[
t := t , (resources at:' class')
] ifFalse:[
t := t , (resources at:' classes')
].
t := (t , ')') withCRs
].
count := subclassesRemoved size.
count ~~ 0 ifTrue:[
t := t , (resources at:'\(and ') , count printString.
count == 1 ifTrue:[
t := t , (resources at:' subclass ')
] ifFalse:[
t := t , (resources at:' subclasses ')
].
t := (t , ')') withCRs
].
t := t withCRs.
box := YesNoBox
title:t
yesText:(resources at:'remove')
noText:(resources at:'abort').
box confirm ifTrue:[
"after querying user - do really remove classes in list1 and list2"
subclassesRemoved do:[:aClass |
(CheckForInstancesWhenRemovingClasses not
or:[aClass hasInstances not
or:[self confirm:(aClass name , ' has instances - remove anyway ?')]])
ifTrue:[
Smalltalk removeClass:aClass
]
].
classesToRemove do:[:aClass |
(CheckForInstancesWhenRemovingClasses not
or:[aClass hasInstances not
or:[self confirm:(aClass name , ' has instances - remove anyway ?')]])
ifTrue:[
Smalltalk removeClass:aClass
].
].
currentClassCategory := nil.
self switchToClass:nil.
Smalltalk changed
]
! !
!BrowserView methodsFor:'method list menu'!
methodMenu
"return a popupmenu as appropriate for the methodList"
|m labels selectors
newLabels newSelectors
mthdLabels mthdSelectors
brkLabels brkSelectors
fileLabels fileSelectors
searchLabels searchSelectors
sepLocalLabels sepLocalSelectors
localSearchLabels localSearchSelectors|
device ctrlDown ifTrue:[
"/ 'secret' developpers menu
currentMethod isNil ifTrue:[
methodListView flash.
^ nil
].
labels := #(
'inspect method'
'compile to machine code'
'decompile'
'-'
'make private'
'make protected'
'make public'
).
selectors := #(
methodInspect
methodSTCCompile
methodDecompile
nil
methodMakePrivate
methodMakeProtected
methodMakePublic
)
] ifFalse:[
sepLocalLabels := sepLocalSelectors := #().
searchLabels := #(
'senders ...'
'implementors ...'
'globals ...'
'string search ...'
'apropos ...'
).
searchSelectors := #(
methodSenders
methodImplementors
methodGlobalReferends
methodStringSearch
methodAproposSearch
).
currentClass notNil ifTrue:[
localSearchLabels := #(
'-'
'local senders ...'
'local implementors ...'
'local string search ...'
'local apropos ...'
).
localSearchSelectors := #(
nil
methodLocalSenders
methodLocalImplementors
methodLocalStringSearch
methodLocalAproposSearch
).
] ifFalse:[
localSearchLabels := localSearchSelectors := #()
].
currentMethodCategory notNil ifTrue:[
sepLocalLabels := #('-'). sepLocalSelectors := #(nil).
newLabels := #(
'new method'
).
newSelectors := #(
methodNewMethod
).
] ifFalse:[
newLabels := newSelectors := #()
].
currentMethod notNil ifTrue:[
fileLabels := #(
'fileOut'
'printOut'
'-'
'SPAWN_METHOD'
'-'
).
fileSelectors := #(
methodFileOut
methodPrintOut
nil
methodSpawn
nil
).
sepLocalLabels := #('-'). sepLocalSelectors := #(nil).
mthdLabels := #(
'change category ...'
'remove'
).
mthdSelectors := #(
methodChangeCategory
methodRemove
).
currentMethod isWrapped ifTrue:[
brkLabels := #(
'remove break/trace'
'-'
).
brkSelectors := #(
methodRemoveBreakOrTrace
nil
)
] ifFalse:[
brkLabels := #(
'breakpoint'
'trace'
'trace sender'
'-'
).
brkSelectors := #(
methodBreakPoint
methodTrace
methodTraceSender
nil
)
]
] ifFalse:[
fileLabels := fileSelectors := #().
brkLabels := brkSelectors := #().
mthdLabels := mthdSelectors := #().
].
labels :=
fileLabels ,
searchLabels ,
localSearchLabels ,
sepLocalLabels ,
brkLabels ,
newLabels ,
mthdLabels.
selectors :=
fileSelectors ,
searchSelectors ,
localSearchSelectors ,
sepLocalSelectors ,
brkSelectors ,
newSelectors ,
mthdSelectors.
"
labels := #(
'fileOut'
'printOut'
'-'
'SPAWN_METHOD'
'-'
'senders ...'
'implementors ...'
'globals ...'
'string search ...'
'apropos ...'
'-'
'local senders ...'
'local implementors ...'
'local string search ...'
'local apropos ...'
'-'
'breakpoint'
'trace'
'trace sender'
'-'
'new method'
'change category ...'
'remove'
).
selectors := #(
methodFileOut
methodPrintOut
nil
methodSpawn
nil
methodSenders
methodImplementors
methodGlobalReferends
methodStringSearch
methodAproposSearch
nil
methodLocalSenders
methodLocalImplementors
methodLocalStringSearch
methodLocalAproposSearch
nil
methodBreakPoint
methodTrace
methodTraceSender
nil
methodNewMethod
methodChangeCategory
methodRemove
)
"
].
m := PopUpMenu
labels:(resources array:labels)
selectors:selectors.
currentMethod notNil ifTrue:[
currentMethod isPrivate ifTrue:[
m disable:#methodMakePrivate
].
currentMethod isProtected ifTrue:[
m disable:#methodMakeProtected
].
currentMethod isPublic ifTrue:[
m disable:#methodMakePublic
].
].
currentMethod notNil ifTrue:[
(currentMethod code notNil
or:[Compiler canCreateMachineCode not]) ifTrue:[
m disable:#methodSTCCompile
].
currentMethod byteCode isNil ifTrue:[
m disable:#methodDecompile
].
].
^ m
!
methodRemove
"remove the current method"
self checkMethodSelected ifFalse:[^ self].
actualClass removeSelector:(actualClass selectorAtMethod:currentMethod).
currentMethod := currentSelector := nil.
self updateMethodListWithScroll:false
!
methodPrivacy:how
"change the current methods privacy.
EXPERIMENTAL"
self checkMethodSelected ifFalse:[^ self].
currentMethod isPublic ifFalse:[
currentMethod privacy:how.
actualClass addChangeRecordForMethodPrivacy:currentMethod.
self updateMethodListWithScroll:false keepSelection:true.
]
!
methodMakePublic
"make the current method public.
EXPERIMENTAL"
self methodPrivacy:#public
!
methodMakeProtected
"make the current method protected.
EXPERIMENTAL"
self methodPrivacy:#protected
!
methodMakePrivate
"make the current method private.
EXPERIMENTAL"
self methodPrivacy:#private
!
methodSenders
"launch an enterBox for selector to search for"
self askForSelectorTitle:'selector to browse senders of:'
openWith:#browseAllCallsOn:
!
methodImplementors
"launch an enterBox for selector to search for"
self askForSelectorTitle:'selector to browse implementors of:'
openWith:#browseImplementorsOf:
!
methodLocalSenders
"launch an enterBox for selector to search for in current class & subclasses"
self checkClassSelected ifFalse:[^ self].
self askForSelectorTitle:'selector to browse local senders of:'
openWith:#browseCallsOn:under:
and:currentClass
!
methodPrintOut
"print out the current method"
|printStream|
self checkMethodSelected ifFalse:[^ self].
printStream := Printer new.
actualClass printOutSource:(currentMethod source) on:printStream.
printStream close
!
methodLocalImplementors
"launch an enterBox for selector to search for"
self checkClassSelected ifFalse:[^ self].
self askForSelectorTitle:'selector to browse local implementors of:'
openWith:#browseImplementorsOf:under:
and:currentClass
!
methodGlobalReferends
"launch an enterBox for global symbol to search for"
self enterBoxForBrowseTitle:'global variable to browse users of:'
action:[:aString |
SystemBrowser browseReferendsOf:aString asSymbol
]
!
methodSpawn
"create a new SystemBrowser browsing current method,
or if the current selection is of the form 'class>>selector', spawan
a browser on that method."
|s sel selSymbol clsName clsSymbol cls isMeta w|
classMethodListView notNil ifTrue:[
s := classMethodListView selectionValue.
clsName := self classFromClassMethodString:s.
sel := self selectorFromClassMethodString:s.
isMeta := false
].
self extractClassAndSelectorFromSelectionInto:[:c :s :m |
clsName := c.
sel := s.
isMeta := m
].
(sel notNil and:[clsName notNil]) ifTrue:[
(clsName knownAsSymbol and:[sel knownAsSymbol]) ifTrue:[
clsSymbol := clsName asSymbol.
(Smalltalk includesKey:clsSymbol) ifTrue:[
cls := Smalltalk at:clsSymbol.
isMeta ifTrue:[
cls := cls class
].
cls isBehavior ifFalse:[
cls := cls class
].
cls isBehavior ifTrue:[
selSymbol := sel asSymbol.
self withWaitCursorDo:[
(cls implements:selSymbol) ifFalse:[
cls := cls class.
].
(cls implements:selSymbol) ifTrue:[
SystemBrowser browseClass:cls selector:selSymbol.
^ self
].
w := ' does not implement #' , sel
]
] ifFalse:[
w := ' is not a class'
]
] ifFalse:[
w := ' is unknown'
]
] ifFalse:[
w := ' and/or ' , sel , ' are unknown'
].
self warn:(clsName , w).
^ self
].
self checkMethodSelected ifFalse:[
self warn:'select a method first'.
^ self
].
self withWaitCursorDo:[
w := currentMethod who.
SystemBrowser browseClass:(w at:1) selector:(w at:2)
]
!
methodChangeCategory
"move the current method into another category -
nothing done here, but a query for the new category.
Remember the last category, to allow faster category change of a group of methods."
|box txt|
self checkMethodSelected ifFalse:[^ self].
actualClass isNil ifTrue:[
box := self enterBoxTitle:'' okText:'change'.
] ifFalse:[
|someCategories|
someCategories := actualClass categories sort.
box := self listBoxTitle:'' okText:'change' list:someCategories.
].
box title:('change category from ''' , currentMethod category , ''' to:').
lastMethodCategory isNil ifTrue:[
txt := currentMethod category.
] ifFalse:[
txt := lastMethodCategory
].
box initialText:txt.
box action:[:aString |
lastMethodCategory := aString.
currentMethod category:aString asSymbol.
actualClass changed.
currentMethod changed:#category.
actualClass addChangeRecordForMethodCategory:currentMethod category:aString.
self updateMethodCategoryListWithScroll:false.
self updateMethodListWithScroll:false
].
box showAtPointer
!
methodFileOut
"file out the current method"
self checkMethodSelected ifFalse:[^ self].
self busyLabel:'saving:' with:currentSelector.
Class fileOutErrorSignal handle:[:ex |
self warn:'cannot create: %1' with:ex parameter.
ex return
] do:[
actualClass fileOutMethod:currentMethod.
].
self normalLabel.
!
methodStringSearch
"launch an enterBox for string to search for"
self askForSelectorTitle:'string to search for in sources:'
openWith:#browseForString:
!
methodLocalStringSearch
"launch an enterBox for string to search for"
self checkClassSelected ifFalse:[^ self].
self askForSelectorTitle:'string to search for in local methods:'
openWith:#browseForString:in:
and:(currentClass withAllSubclasses)
!
methodAproposSearch
"launch an enterBox for a keyword search"
self askForSelectorTitle:'keyword to search for:'
openWith:#aproposSearch:
!
methodLocalAproposSearch
"launch an enterBox for a local keyword search"
self askForSelectorTitle:'keyword to search for:'
openWith:#aproposSearch:in:
and:(currentClass withAllSubclasses)
!
methodNewMethod
"prepare for definition of a new method - put a template into
code view and define accept-action to compile it"
currentClass isNil ifTrue:[
^ self warn:'select/create a class first'.
].
currentMethodCategory isNil ifTrue:[
^ self warn:'select/create a method category first'.
].
currentMethod := currentSelector := nil.
methodListView deselect.
codeView contents:(self template).
codeView modified:false.
self setAcceptAndExplainActionsForMethod.
!
methodBreakPoint
"set a breakpoint on the current method"
currentSelector notNil ifTrue:[
currentMethod := actualClass compiledMethodAt:currentSelector.
currentMethod isWrapped ifFalse:[
(currentMethod notNil and:[currentMethod isWrapped not]) ifTrue:[
self commonTraceHelperWith:#trapMethod:
]
].
]
!
methodTrace
"turn on tracing of the current method"
currentClass notNil ifTrue:[
currentSelector notNil ifTrue:[
currentMethod := actualClass compiledMethodAt:currentSelector
]
].
(currentMethod notNil and:[currentMethod isWrapped not]) ifTrue:[
self commonTraceHelperWith:#traceMethod:
]
!
commonTraceHelperWith:aSelector
currentMethod := MessageTracer perform:aSelector with:currentMethod.
self updateMethodListWithScroll:false keepSelection:true.
currentClass changed:#methodDictionary with:currentSelector.
!
methodRemoveBreakOrTrace
"turn off tracing of the current method"
(currentMethod notNil and:[currentMethod isWrapped]) ifTrue:[
self commonTraceHelperWith:#unwrapMethod:
]
!
methodTraceSender
"turn on tracing of the current method"
(currentMethod notNil and:[currentMethod isWrapped not]) ifTrue:[
self commonTraceHelperWith:#traceMethodSender:
]
!
methodInspect
"inspect the current method"
self checkMethodSelected ifFalse:[^ self].
currentMethod inspect.
!
methodSTCCompile
"compile the current method to machine code.
This is not supported on all machines, and never supported in
the demo version."
|prev|
self checkMethodSelected ifFalse:[^ self].
prev := Compiler stcCompilation:#always.
[
codeView accept.
] valueNowOrOnUnwindDo:[
Compiler stcCompilation:prev
].
!
methodDecompile
"decompile the current methods bytecodes.
The Decompiler is delivered as an extra, and not normally
avaliable with the system."
self checkMethodSelected ifFalse:[^ self].
Decompiler notNil ifTrue:[
Autoload autoloadFailedSignal handle:[:ex |
ex return
] do:[
Decompiler autoload.
].
].
Decompiler isLoaded ifFalse:[
Smalltalk
fileIn:'/phys/clam/claus/work/libcomp/not_delivered/Decomp.st'
logged:false.
].
Decompiler isLoaded ifFalse:[
^ self warn:'No decompiler available'.
].
Decompiler decompile:currentMethod.
! !
!BrowserView methodsFor:'method category list menu'!
methodCategoryMenu
|labels selectors i|
currentClass isNil ifTrue:[
methodCategoryListView flash.
^ nil
].
currentMethodCategory isNil ifTrue:[
labels := #(
'find method here ...'
'find method ...'
'-'
'new category ...'
'copy category ...'
'create access methods'
).
selectors := #(
methodCategoryFindMethod
methodCategoryFindAnyMethod
nil
methodCategoryNewCategory
methodCategoryCopyCategory
methodCategoryCreateAccessMethods
).
] ifFalse:[
labels := #(
'fileOut'
'fileOut all'
'printOut'
'-'
'SPAWN_METHODCATEGORY'
'spawn category'
'-'
'find method here ...'
'find method ...'
'-'
'new category ...'
'copy category ...'
'create access methods'
'rename ...'
'remove'
).
selectors := #(
methodCategoryFileOut
methodCategoryFileOutAll
methodCategoryPrintOut
nil
methodCategorySpawn
methodCategorySpawnCategory
nil
methodCategoryFindMethod
methodCategoryFindAnyMethod
nil
methodCategoryNewCategory
methodCategoryCopyCategory
methodCategoryCreateAccessMethods
methodCategoryRename
methodCategoryRemove
).
].
showInstance ifFalse:[
labels := labels copy.
selectors := selectors copy.
i := labels indexOf:'create access methods'.
labels at:i put:'create documentation stubs'.
selectors at:i put:#methodCategoryCreateDocumentationMethods
].
^ PopUpMenu labels:(resources array:labels)
selectors:selectors
!
methodCategoryFindAnyMethod
|box|
box := self enterBoxForSearchSelectorTitle:'method selector to search for:'.
box action:[:aString | self switchToAnyMethodNamed:aString].
box showAtPointer
!
methodCategoryFindMethod
|box|
box := self enterBoxForSearchSelectorTitle:'method selector to search for:'.
box action:[:aString | self switchToMethodNamed:aString].
box showAtPointer
!
methodCategoryPrintOut
|printStream|
self checkClassSelected ifFalse:[^ self].
self whenMethodCategorySelected:[
printStream := Printer new.
actualClass printOutCategory:currentMethodCategory on:printStream.
printStream close
]
!
methodCategoryFileOut
"fileOut all methods in the selected methodcategory of
the current class"
self checkClassSelected ifFalse:[^ self].
self whenMethodCategorySelected:[
self busyLabel:'saving: %1' with:currentClass name , '-' , currentMethodCategory.
Class fileOutErrorSignal handle:[:ex |
self warn:'cannot create: %1' with:ex parameter.
ex return.
] do:[
actualClass fileOutCategory:currentMethodCategory.
].
self normalLabel.
]
!
methodCategorySpawn
"create a new SystemBrowser browsing current method category"
currentMethodCategory notNil ifTrue:[
self withWaitCursorDo:[
SystemBrowser browseClass:actualClass
methodCategory:currentMethodCategory
]
]
!
methodCategoryNewCategory
"show the enter box to add a new method category.
Offer existing superclass categories in box to help avoiding
useless typing."
|someCategories existingCategories box|
actualClass notNil ifTrue:[
someCategories := actualClass allCategories
] ifFalse:[
"
mhmh - offer some typical categories ...
"
showInstance ifTrue:[
someCategories := #('accessing'
'initialization'
'private'
'printing & storing'
'queries'
'testing'
)
] ifFalse:[
someCategories := #(
'documentation'
'initialization'
'instance creation'
).
].
].
someCategories sort.
"
remove existing categories
"
existingCategories := methodCategoryListView list.
existingCategories notNil ifTrue:[
someCategories := someCategories select:[:cat | (existingCategories includes:cat) not].
].
box := self listBoxTitle:'name of new method category:'
okText:'create'
list:someCategories.
box action:[:aString | self newMethodCategory:aString].
box showAtPointer
!
methodCategoryFileOutAll
"fileOut all methods in the selected methodcategory of
the current class"
self whenMethodCategorySelected:[
|fileName outStream|
fileName := currentMethodCategory , '.st'.
fileName replaceAll:Character space by:$_.
"
this test allows a smalltalk to be built without Projects/ChangeSets
"
Project notNil ifTrue:[
fileName := Project currentProjectDirectory , fileName.
].
"
if file exists, save original in a .sav file
"
fileName asFilename exists ifTrue:[
fileName asFilename copyTo:(fileName , '.sav')
].
outStream := FileStream newFileNamed:fileName.
outStream isNil ifTrue:[
^ self warn:'cannot create: %1' with:fileName
].
self busyLabel:'saving: ' with:currentMethodCategory.
Class fileOutErrorSignal handle:[:ex |
self warn:'cannot create: %1' with:ex parameter.
ex return
] do:[
Smalltalk allBehaviorsDo:[:class |
|hasMethodsInThisCategory|
hasMethodsInThisCategory := false.
class methodArray do:[:method |
method category = currentMethodCategory ifTrue:[
hasMethodsInThisCategory := true
]
].
hasMethodsInThisCategory ifTrue:[
class fileOutCategory:currentMethodCategory on:outStream.
outStream cr
].
hasMethodsInThisCategory := false.
class class methodArray do:[:method |
method category = currentMethodCategory ifTrue:[
hasMethodsInThisCategory := true
]
].
hasMethodsInThisCategory ifTrue:[
class class fileOutCategory:currentMethodCategory on:outStream.
outStream cr
]
].
].
outStream close.
self normalLabel.
].
!
methodCategorySpawnCategory
"create a new SystemBrowser browsing all methods from all
classes with same category as current method category"
self askAndBrowseMethodCategory:'category to browse methods:'
action:[:aString |
SystemBrowser browseMethodCategory:aString
]
!
methodCategoryCreateAccessMethods
"create access methods for all instvars"
self checkClassSelected ifFalse:[^ self].
showInstance ifFalse:[
self warn:'select instance - and try again'.
^ self.
].
self withWaitCursorDo:[
|nm names source|
(variableListView notNil
and:[(nm := variableListView selectionValue) notNil]) ifTrue:[
names := Array with:nm
] ifFalse:[
names := currentClass instVarNames
].
names do:[:name |
"check, if method is not already present"
(currentClass implements:(name asSymbol)) ifFalse:[
source := (name , '\ "return ' , name , '"\\ ^ ' , name) withCRs.
Compiler compile:source forClass:currentClass inCategory:'accessing'.
] ifTrue:[
Transcript showCr:'method ''', name , ''' already present'
].
(currentClass implements:((name , ':') asSymbol)) ifFalse:[
source := (name , ':something\ "set ' , name , '"\\ ' , name , ' := something.') withCRs.
Compiler compile:source forClass:currentClass inCategory:'accessing'.
] ifTrue:[
Transcript showCr:'method ''', name , ':'' already present'
].
].
self updateMethodCategoryListWithScroll:false.
self updateMethodListWithScroll:false
]
!
methodCategoryCreateDocumentationMethods
"create empty documentation methods"
|cls histStream|
self checkClassSelected ifFalse:[^ self].
cls := currentClass class.
self withWaitCursorDo:[
|nm names source|
"/ add version method containing RCS template
"/ but only if not already present.
(cls implements:#version) ifFalse:[
Compiler compile:
'version
"
$' , 'Header$
"
' forClass:cls
inCategory:'documentation'.
].
"/ add documentation method containing doc template
"/ but only if not already present.
(cls implements:#documentation) ifFalse:[
Compiler compile:
'documentation
"
documentation to be added.
"
' forClass:cls
inCategory:'documentation'.
].
"/ add examples method containing examples template
"/ but only if not already present.
(cls implements:#examples) ifFalse:[
Compiler compile:
'examples
"
examples to be added.
"
' forClass:cls
inCategory:'documentation'.
].
"/ add history method containing created-entry
"/ but only if not already present.
(cls implements:#history) ifFalse:[
histStream := ReadWriteStream on: String new.
histStream nextPutAll: 'history'; cr.
HistoryLine isBehavior ifTrue:[
histStream nextPutAll: (HistoryLine created printString); cr.
] ifFalse:[
histStream cr.
].
Compiler compile:(histStream contents)
forClass:cls
inCategory:'documentation'.
].
self instanceProtocol:false.
self switchToMethodNamed:#documentation
"/ self updateMethodCategoryListWithScroll:false.
"/ self updateMethodListWithScroll:false
]
!
methodCategoryCopyCategory
"show the enter box to copy from an existing method category"
|title box|
showInstance ifTrue:[
title := 'class to copy instance method category from:'
] ifFalse:[
title := 'class to copy class method category from:'
].
box := self listBoxTitle:title
okText:'ok'
list:(Smalltalk allClasses collect:[:cls | cls name]) asArray sort.
box action:[:aString | self copyMethodsFromClass:aString].
box showAtPointer
!
methodCategoryRename
"launch an enterBox to rename current method category"
|box|
self checkMethodCategorySelected ifFalse:[^ self].
box := self enterBoxTitle:(resources string:'rename method category %1 to:' with:currentMethodCategory)
okText:(resources at:'rename').
box initialText:currentMethodCategory.
box action:[:aString |
actualClass renameCategory:currentMethodCategory to:aString.
currentMethodCategory := aString.
currentMethod := currentSelector := nil.
self updateMethodCategoryList.
self updateMethodListWithScroll:false
].
box showAtPointer
!
methodCategoryRemove
"show number of methods to remove and query user"
|count t box|
currentMethodCategory notNil ifTrue:[
count := 0.
actualClass methodArray do:[:aMethod |
(aMethod category = currentMethodCategory) ifTrue:[
count := count + 1
]
].
(count == 0) ifTrue:[
currentMethodCategory := nil.
currentMethod := currentSelector := nil.
self updateMethodCategoryListWithScroll:false.
self updateMethodList
] ifFalse:[
(count == 1) ifTrue:[
t := 'remove %1\(with 1 method) ?'
] ifFalse:[
t := 'remove %1\(with %2 methods) ?'
].
t := resources string:t with:currentMethodCategory with:count printString.
t := t withCRs.
box := YesNoBox
title:t
yesText:(resources at:'remove')
noText:(resources at:'abort').
box confirm ifTrue:[
actualClass methodArray do:[:aMethod |
(aMethod category = currentMethodCategory) ifTrue:[
actualClass
removeSelector:(actualClass selectorAtMethod:aMethod)
]
].
currentMethodCategory := nil.
currentMethod := currentSelector := nil.
self updateMethodCategoryList.
self updateMethodList
]
]
]
! !
!BrowserView methodsFor:'variable list menu'!
variableListMenu
|labels selectors|
currentClass isNil ifTrue:[
variableListView flash.
^ nil
].
labels := #(
'instvar refs ...'
'classvar refs ...'
'all instvar refs ...'
'all classvar refs ...'
'-'
'instvar mods ...'
'classvar mods ...'
'all instvar mods ...'
'all classvar mods ...'
).
selectors := #(
instVarRefs
classVarRefs
allInstVarRefs
allClassVarRefs
nil
instVarMods
classVarMods
allInstVarMods
allClassVarMods
).
(showInstance and:[variableListView hasSelection]) ifTrue:[
labels := labels , #(
'-'
'type information'
).
selectors := selectors , #(
nil
varTypeInfo
).
].
^ PopUpMenu labels:(resources array:labels)
selectors:selectors
!
variableSelection:lineNr
"variable selection changed"
|name idx|
name := variableListView selectionValue.
name isNil ifTrue:[
self unhilightMethodCategories.
self unhilightMethods.
self autoSearch:nil.
^ self
].
"
first, check if the selected variable is really the one
we get - reselect if its hidden (for example, a class variable
with the same name could be defined in a subclass)
"
idx := variableListView list findLast:[:entry | entry = name].
idx ~~ lineNr ifTrue:[
"select it - user will see whats going on"
variableListView selection:idx
].
"search for methods in the current category, which access the selected
variable, and highlight them"
self hilightMethodsInMethodCategoryList:true inMethodList:true.
self autoSearch:name.
!
enterBoxForVariableSearch:title
|box sel|
box := self enterBoxForCodeSelectionTitle:title okText:'browse'.
variableListView notNil ifTrue:[
codeView hasSelection ifFalse:[
(sel := variableListView selectionValue) notNil ifTrue:[
(sel startsWith:'---') ifFalse:[
box initialText:sel
]
]
]
].
^ box
!
allClassOrInstVarRefsTitle:title access:access mods:modifications
"show an enterbox for instVar to search for"
self doClassMenu:[:currentClass |
|box|
box := self enterBoxForVariableSearch:title.
box action:[:aVariableName |
|homeClass|
aVariableName isEmpty ifFalse:[
windowGroup showCursor:Cursor questionMark.
homeClass := self findClassOfVariable:aVariableName accessWith:access.
access == #classVarNames ifTrue:[
SystemBrowser
browseClassRefsTo:aVariableName
under:homeClass
modificationsOnly:modifications
] ifFalse:[
SystemBrowser
browseInstRefsTo:aVariableName
under:homeClass
modificationsOnly:modifications
]
]
].
box showAtPointer
]
!
instVarRefsOrModsTitle:title mods:mods
"show an enterbox for instvar to search for"
self doClassMenu:[:currentClass |
|box|
box := self enterBoxForVariableSearch:title.
box action:[:aString |
aString notEmpty ifTrue:[
windowGroup showCursor:(Cursor questionMark).
SystemBrowser
browseInstRefsTo:aString
in:(Array with:currentClass)
modificationsOnly:mods
]
].
box showAtPointer
]
!
allClassVarMods
"show an enterbox for classVar to search for"
self allClassOrInstVarRefsTitle:'class variable to browse modifications of:'
access:#classVarNames
mods:true
!
instVarMods
"show an enterbox for instVar to search for"
self instVarRefsOrModsTitle:'instance variable to browse modifications of:'
mods:true
!
instVarRefs
"show an enterbox for instVar to search for"
self instVarRefsOrModsTitle:'instance variable to browse references to:'
mods:false
!
classVarRefsOrModsTitle:title mods:mods
"show an enterbox for classVar to search for"
self doClassMenu:[:currentClass |
|box|
box := self enterBoxForVariableSearch:title.
box action:[:aString |
aString notEmpty ifTrue:[
windowGroup showCursor:(Cursor questionMark).
SystemBrowser
browseClassRefsTo:aString
in:(Array with:currentClass)
modificationsOnly:mods
]
].
box showAtPointer
]
!
allInstVarRefs
"show an enterbox for instVar to search for"
self allClassOrInstVarRefsTitle:'instance variable to browse references to:'
access:#instVarNames
mods:false
!
classVarRefs
"show an enterbox for classVar to search for"
self classVarRefsOrModsTitle:'class variable to browse references to:'
mods:false
!
classVarMods
"show an enterbox for classVar to search for"
self classVarRefsOrModsTitle:'class variable to browse modifications of:'
mods:true
!
allInstVarMods
"show an enterbox for instVar to search for"
self allClassOrInstVarRefsTitle:'instance variable to browse modifications of:'
access:#instVarNames
mods:true
!
allClassVarRefs
"show an enterbox for classVar to search for"
self allClassOrInstVarRefsTitle:'class variable to browse references to:'
access:#classVarNames
mods:false
!
varTypeInfo
"show typical usage of a variable"
|name idx classes values value msg cut names instCount subInstCount box
searchClass|
name := variableListView selectionValue.
name isNil ifTrue:[^ self].
searchClass := actualClass whichClassDefinesInstVar:name.
idx := searchClass instVarOffsetOf:name.
idx isNil ifTrue:[^ self].
classes := IdentitySet new.
values := IdentitySet new.
instCount := 0.
subInstCount := 0.
searchClass allSubInstancesDo:[:i |
|val|
val := i instVarAt:idx.
val notNil ifTrue:[values add:val].
classes add:val class.
(i isMemberOf:searchClass) ifTrue:[
instCount := instCount + 1.
] ifFalse:[
subInstCount := subInstCount + 1
]
].
(instCount == 0 and:[subInstCount == 0]) ifTrue:[
self warn:'there are currently no instances of ' , currentClass name.
^ self
].
instCount ~~ 0 ifTrue:[
msg := 'in (currently: ' , instCount printString,') instances '.
subInstCount ~~ 0 ifTrue:[
msg := msg , 'and '
]
] ifFalse:[
msg := 'in '.
].
subInstCount ~~ 0 ifTrue:[
msg := msg , '(currently: ' , subInstCount printString, ') derived instances '
].
msg := msg, 'of ' , searchClass name , ',\'.
msg := msg , name , ' '.
((values size == 1)
or:[classes size == 1 and:[classes first == UndefinedObject]]) ifTrue:[
values size == 1 ifTrue:[value := values first].
(value isNumber or:[value isString]) ifTrue:[
msg := msg , 'is always the same:\\ ' ,
value class name , ' (' , value storeString , ')'.
] ifFalse:[
(value isNil or:[value == true or:[value == false]]) ifTrue:[
msg := msg , 'is always:\\ ' ,
value printString.
] ifFalse:[
msg := msg , 'is always the same:\\'.
msg := msg , ' ' , value class name.
value isLiteral ifTrue:[
msg := msg , ' (' , value storeString , ')'
]
]
]
] ifFalse:[
classes size == 1 ifTrue:[
msg := msg , 'is always:\\'.
msg := msg , ' ' , classes first name , '\'.
] ifFalse:[
msg := msg , 'is one of:\\'.
classes := classes asOrderedCollection.
classes size > 20 ifTrue:[
classes := classes copyFrom:1 to:20.
cut := true
] ifFalse:[
cut := false.
].
names := classes collect:[:cls |
|nm|
cls == UndefinedObject ifTrue:[
'nil'
] ifFalse:[
cls == True ifTrue:[
'true'
] ifFalse:[
cls == False ifTrue:[
'false'
] ifFalse:[
cls name
]
]
].
].
names sort.
names do:[:nm |
msg := msg , ' ' , nm , '\'.
].
]
].
box := InfoBox title:msg withCRs.
box label:'variable type information'.
box showAtPointer
! !
!BrowserView methodsFor:'class-method list menu'!
classMethodMenu
|labels selectors|
labels := #(
'fileOut'
'fileOut all'
'printOut'
'-'
'spawn'
'spawn class'
'spawn full protocol'
'spawn hierarchy'
'-'
'senders ...'
'implementors ...'
'globals ...'
"/ '-'
"/ 'breakpoint'
"/ 'trace'
"/ 'trace sender'
'-'
'remove'
).
selectors := #(
methodFileOut
classMethodFileOutAll
methodPrintOut
nil
methodSpawn
classSpawn
classSpawnFullProtocol
classSpawnHierarchy
nil
methodSenders
methodImplementors
methodGlobalReferends
"/ nil
"/ methodBreakPoint
"/ methodTrace
"/ methodTraceSender
nil
methodRemove
).
^ PopUpMenu labels:(resources array:labels)
selectors:selectors
!
classMethodFileOutAll
"fileout all methods into one source file"
|list classString selectorString cls mth outStream fileName append
fileBox|
append := false.
fileBox := FileSaveBox
title:(resources string:'save methodss in:')
okText:(resources string:'save')
abortText:(resources string:'cancel')
action:[:fName | fileName := fName].
fileBox appendAction:[:fName | fileName := fName. append := true].
fileBox initialText:'some_methods.st'.
Project notNil ifTrue:[
fileBox directory:Project currentProjectDirectory
].
fileBox showAtPointer.
fileName notNil ifTrue:[
"
if file exists, save original in a .sav file
"
fileName asFilename exists ifTrue:[
fileName asFilename copyTo:(fileName , '.sav')
].
append ifTrue:[
outStream := FileStream appendingOldFileNamed:fileName
] ifFalse:[
outStream := FileStream newFileNamed:fileName.
].
outStream isNil ifTrue:[
^ self warn:'cannot create: %1' with:fileName
].
self withWaitCursorDo:[
list := classMethodListView list.
list do:[:line |
self busyLabel:'writing: ' with:line.
classString := self classFromClassMethodString:line.
selectorString := self selectorFromClassMethodString:line.
((classString ~= 'Metaclass') and:[classString endsWith:'class']) ifTrue:[
classString := classString copyWithoutLast:5 "copyTo:(classString size - 5)".
cls := (Smalltalk at:classString asSymbol).
cls := cls class
] ifFalse:[
cls := (Smalltalk at:classString asSymbol).
].
cls isNil ifTrue:[
self warn:'oops class %1 is gone' with:classString
] ifFalse:[
mth := cls compiledMethodAt:(selectorString asSymbol).
Class fileOutErrorSignal handle:[:ex |
|box|
box := YesNoBox
title:('fileOut error: '
, ex errorString
, '\\continue anyway ?') withCRs
yesText:'continue'
noText:'abort'.
box confirm ifTrue:[
ex proceed
].
self normalLabel.
^ self
] do:[
cls fileOutMethod:mth on:outStream.
]
]
].
outStream close.
self normalLabel.
]
]
! !
BrowserView initialize!