"
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 7-nov-1994 at 14:56:27'!
StandardSystemView subclass:#SystemBrowser
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'
classVariableNames:'CheckForInstancesWhenRemovingClasses'
poolDictionaries:''
category:'Interface-Browsers'
!
SystemBrowser comment:'
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
$Header: /cvs/stx/stx/libtool/Attic/SBrowser.st,v 1.15 1994-11-17 14:47:02 claus Exp $
'!
!SystemBrowser 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/Attic/SBrowser.st,v 1.15 1994-11-17 14:47:02 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
"
! !
!SystemBrowser class methodsFor:'initialization'!
initialize
"SystemBrowser 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
"
! !
!SystemBrowser class methodsFor:'startup'!
browseMethods:aList title:aString
"launch a browser for an explicit list of class/selectors.
Each entry in the list must consist of the classes name and the selector,
separated by spaces. For class methods, the string 'class' must be
appended to the classname."
(aList size == 0) ifTrue:[
self showNoneFound:aString.
^ nil
].
aList sort.
^ self newWithLabel:aString
setupBlock:[:browser | browser setupForList:aList]
"
SystemBrowser browseMethods:#('Object printOn:'
'Collection add:')
title:'some methods'
"
"
SystemBrowser browseMethods:#('Behavior new:'
'Setclass new:')
title:'some new: methods'
"
!
browseMethodsIn:aCollectionOfClasses inst:wantInst class:wantClass where:aBlock title:title
"launch a browser for all instance- (if wantInst is true) and/or
classmethods (if wantClass is true) from classes in aCollectionOfClasses,
where aBlock evaluates to true.
The block is called with 3 arguments, class, method and seelctor."
|list|
"
since this may take a long time, lower my priority ...
"
Processor activeProcess withLowerPriorityDo:[
|checkedClasses checkBlock|
checkedClasses := IdentitySet new.
list := OrderedCollection new.
checkBlock := [:cls |
|methodArray selectorArray|
(checkedClasses includes:cls) ifFalse:[
methodArray := cls methodArray.
selectorArray := cls selectorArray.
1 to:methodArray size do:[:index |
|method sel|
method := methodArray at:index.
sel := selectorArray at:index.
(aBlock value:cls value:method value:sel) ifTrue:[
list add:(cls name , ' ' , sel)
]
].
checkedClasses add:cls.
]
].
aCollectionOfClasses do:[:aClass |
"
output disabled - it slows down things too much (when searching for
implementors or senders)
"
"/ Transcript show:'searching '; show:aClass name; showCr:' ...'; endEntry.
wantInst ifTrue:[checkBlock value:aClass].
wantClass ifTrue:[checkBlock value:(aClass class)].
Processor yield
]
].
^ self browseMethods:list title:title
!
browseMethodsIn:aCollectionOfClasses where:aBlock title:title
"launch a browser for all instance- and classmethods from
all classes in aCollectionOfClasses where aBlock evaluates to true.
The block is called with 3 arguments, class, method and seelctor."
^ self browseMethodsIn:aCollectionOfClasses inst:true class:true where:aBlock title:title
!
browseClassCategory:aClassCategory
"launch a browser for all classes under aCategory"
^ self newWithLabel:aClassCategory
setupBlock:[:browser | browser setupForClassCategory:aClassCategory]
"SystemBrowser browseClassCategory:'Kernel-Objects'"
!
browseFullClasses
"launch a browser showing all methods at once"
^ self newWithLabel:'Full Class Browser'
setupBlock:[:browser | browser setupForFullClass]
"SystemBrowser browseFullClasses"
!
browseClass:aClass
"launch a browser for aClass"
^ self newWithLabel:aClass name
setupBlock:[:browser | browser setupForClass:aClass]
"SystemBrowser browseClass:Object"
!
browseClass:aClass selector:selector
"launch a browser for the method at selector in aClass"
^ self
newWithLabel:(aClass name , ' ' , selector , ' ' , selector)
setupBlock:[:browser | browser setupForClass:aClass selector:selector]
"
SystemBrowser browseClass:Object selector:#printString
"
!
browseClassHierarchy:aClass
"launch a browser for aClass and all its superclasses.
this is different from the fullProtocol browser."
^ self newWithLabel:(aClass name , '-' , 'hierarchy')
setupBlock:[:browser | browser setupForClassHierarchy:aClass]
"
SystemBrowser browseClassHierarchy:Number
"
!
browseFullClassProtocol:aClass
"launch a browser for aClasses full protocol.
This is different from hierarchy browsing."
^ self newWithLabel:(aClass name , '-' , 'full protocol')
setupBlock:[:browser | browser setupForFullClassProtocol:aClass]
"
SystemBrowser browseFullClassProtocol:Number
"
!
browseClasses:aList title:title
"launch a browser for all classes in aList"
^ self newWithLabel:title
setupBlock:[:browser | browser setupForClassList:aList]
"
SystemBrowser browseClasses:(Array with:Object
with:Float)
title:'two classes'
"
!
browseClass:aClass methodCategory:aCategory
"launch a browser for all methods under aCategory in aClass"
^ self newWithLabel:(aClass name , ' ' , aCategory)
setupBlock:[:browser | browser setupForClass:aClass methodCategory:aCategory]
"SystemBrowser browseClass:String methodCategory:'copying'"
!
browseMethodCategory:aCategory
"launch a browser for all methods where category = aCategory"
|searchBlock|
aCategory includesMatchCharacters ifTrue:[
searchBlock := [:c :m :s | aCategory match:m category].
] ifFalse:[
searchBlock := [:c :m :s | m category = aCategory]
].
self browseMethodsWhere:searchBlock title:('all methods with category of ' , aCategory)
"
SystemBrowser browseMethodCategory:'printing & storing'
SystemBrowser browseMethodCategory:'print*'
"
!
browseAllSelect:aBlock
"launch a browser for all methods where aBlock returns true.
The block is called with 3 arguments, class, method and seelctor."
^ self browseMethodsWhere:aBlock title:'selected messages'
"
SystemBrowser browseAllSelect:[:aClass :aMethod :selector | selector numArgs == 3]
"
!
browseMethodsWhere:aBlock title:title
"launch a browser for all methods where aBlock returns true.
The block is called with 3 arguments, class, method and seelctor."
^ self browseMethodsIn:(Smalltalk allClasses) where:aBlock title:title
!
browseMethodsOf:aClass where:aBlock title:title
"launch a browser for all instance- and classmethods in aClass
where aBlock evaluates to true.
The block is called with 3 arguments, class, method and seelctor."
^ self browseMethodsIn:(Array with:aClass) where:aBlock title:title
!
browseMethodsFrom:aClass where:aBlock title:title
"launch a browser for all instance- and classmethods in aClass
and all its subclasses where aBlock evaluates to true.
The block is called with 3 arguments, class, method and seelctor."
^ self browseMethodsIn:(aClass withAllSubclasses) where:aBlock title:title
!
browseInstMethodsOf:aClass where:aBlock title:title
"launch a browser for all instance methods in aClass
where aBlock evaluates to true"
^ self browseMethodsIn:(Array with:aClass) inst:true class:false where:aBlock title:title
!
browseInstMethodsIn:aCollectionOfClasses where:aBlock title:title
"launch a browser for all instance methods of all classes in
aCollectionOfClasses where aBlock evaluates to true"
^ self browseMethodsIn:aCollectionOfClasses inst:true class:false
where:aBlock title:title
!
browseInstMethodsFrom:aClass where:aBlock title:title
"launch a browser for all instance methods in aClass and all subclasses
where aBlock evaluates to true"
^ self browseMethodsIn:(aClass withAllSubclasses) inst:true class:false where:aBlock title:title
!
browseFullClassHierarchy:aClass
"launch a browser for aClass and all its superclasses"
^ self newWithLabel:(aClass name , '-' , 'full protocol')
setupBlock:[:browser | browser setupForFullClassHierarchy:aClass]
"
SystemBrowser browseFullClassHierarchy:Number
"
! !
!SystemBrowser class methodsFor:'special search startup'!
browseAllCallsOn:aSelectorString in:aCollectionOfClasses title:title
"launch a browser for all senders of aSelector in aCollectionOfClasses"
|sel browser searchBlock|
((aSelectorString ~= '*') and:[aSelectorString includesMatchCharacters]) ifTrue:[
"a matchString"
searchBlock := [:lits |
|found|
found := false.
lits notNil ifTrue:[
lits do:[:aLiteral |
found ifFalse:[
(aLiteral isMemberOf:Symbol) ifTrue:[
found := (aSelectorString match:aLiteral)
]
]
]
].
found
].
browser := self browseMethodsIn:aCollectionOfClasses
where:[:class :method :s | searchBlock value:(method literals)]
title:title
] ifFalse:[
aSelectorString knownAsSymbol ifFalse:[
"
Transcript showCr:'none found.'.
"
self showNoneFound:title.
^ nil
].
sel := aSelectorString asSymbol.
browser := self browseMethodsIn:aCollectionOfClasses
where:[:class :method :s | method sends:sel]
title:title
].
browser notNil ifTrue:[
|s|
"
kludge for now, if its a multipart selector,
no easy search is (as yet) possible
"
s := aSelectorString.
(s includes:$:) ifTrue:[
s := s copyTo:(s indexOf:$:)
].
browser autoSearch:s
].
^ browser
!
browseImplementorsOf:aSelectorString
"launch a browser for all implementors of aSelector"
^ self browseImplementorsOf:aSelectorString
in:(Smalltalk allClasses)
title:('implementors of: ' , aSelectorString)
"
SystemBrowser browseImplementorsOf:#+
"
!
browseImplementorsOf:aSelectorString in:aCollectionOfClasses title:title
"launch a browser for all implementors of aSelector in
the classes contained in aCollectionOfClasses and its metaclasses"
|list sel|
list := OrderedCollection new.
((aSelectorString ~= '*') and:[aSelectorString includesMatchCharacters]) ifTrue:[
"a matchString"
aCollectionOfClasses do:[:aClass |
aClass selectorArray do:[:aSelector |
(aSelectorString match:aSelector) ifTrue:[
list add:(aClass name , ' ' , aSelector)
]
].
aClass class selectorArray do:[:aSelector |
(aSelectorString match:aSelector) ifTrue:[
list add:(aClass name , 'class ' , aSelector)
]
]
]
] ifFalse:[
"can do a faster search"
aSelectorString knownAsSymbol ifFalse:[
self showNoneFound:title.
^ nil
].
sel := aSelectorString asSymbol.
aCollectionOfClasses do:[:aClass |
(aClass implements:sel) ifTrue:[
list add:(aClass name , ' ' , aSelectorString)
].
(aClass class implements:sel) ifTrue:[
list add:(aClass name , 'class ' , aSelectorString)
]
]
].
^ self browseMethods:list title:title
"
SystemBrowser browseImplementorsOf:#+
in:(Array with:Number
with:Float
with:SmallInteger)
title:'some implementors of +'
"
!
browseAllCallsOn:aSelectorString
"launch a browser for all senders of aSelector"
^ self browseAllCallsOn:aSelectorString
in:(Smalltalk allClasses)
title:('senders of ' , aSelectorString)
"
SystemBrowser browseAllCallsOn:#+
"
!
browseCallsOn:aSelectorString under:aClass
"launch a browser for all senders of aSelector in aClass and subclasses"
^ self browseAllCallsOn:aSelectorString
in:(aClass withAllSubclasses)
title:('senders of: ' ,
aSelectorString ,
' (in or below ' , aClass name , ')')
"
SystemBrowser browseAllCallsOn:#+ under:Number
"
!
browseImplementorsOf:aSelectorString under:aClass
"launch a browser for all implementors of aSelector in aClass
and its subclasses"
^ self browseImplementorsOf:aSelectorString
in:(aClass withAllSubclasses)
title:('implementors of: ' ,
aSelectorString ,
' (in or below ' , aClass name , ')')
"
SystemBrowser browseImplementorsOf:#+ under:Integer
"
!
browseForSymbol:aSymbol title:title warnIfNone:doWarn
"launch a browser for all methods referencing aSymbol"
|browser searchBlock sym|
(aSymbol includesMatchCharacters) ifTrue:[
"a matchString"
searchBlock := [:lits |
|found|
found := false.
lits notNil ifTrue:[
lits do:[:aLiteral |
found ifFalse:[
(aLiteral isMemberOf:Symbol) ifTrue:[
found := (aSymbol match:aLiteral)
]
]
]
].
found
].
] ifFalse:[
"
can do a faster search
"
aSymbol knownAsSymbol ifFalse:[
self showNoneFound:title.
^ nil
].
sym := aSymbol asSymbol.
searchBlock := [:lits |
|found|
found := false.
lits notNil ifTrue:[
lits do:[:aLiteral |
found ifFalse:[
(aLiteral isMemberOf:Symbol) ifTrue:[
found := (sym == aLiteral)
]
]
]
].
found
].
].
browser := self browseMethodsWhere:[:c :m :s | searchBlock value:(m literals)] title:title.
browser notNil ifTrue:[
browser autoSearch:aSymbol
].
^ browser
!
filterToSearchInstRefsTo:varName modificationsOnly:modsOnly
"return a block to search for instvar accesses"
|searchBlock|
searchBlock := [:c :m :s |
|src result parser instvars needMatch|
needMatch := varName includesMatchCharacters.
src := m source.
src isNil ifTrue:[
result := false
] ifFalse:[
needMatch ifFalse:[
"
before doing a slow parse, quickly scan the
methods source for the variables name ...
"
result := (src findString:varName) ~~ 0.
] ifTrue:[
result := true.
].
result ifTrue:[
result := false.
parser := Parser parseMethod:src in:c.
parser notNil ifTrue:[
modsOnly ifTrue:[
instvars := parser modifiedInstVars
] ifFalse:[
instvars := parser usedInstVars
].
instvars notNil ifTrue:[
needMatch ifTrue:[
instvars do:[:iv |
(varName match:iv) ifTrue:[result := true]
]
] ifFalse:[
result := instvars includes:varName
]
]
]
].
].
Processor yield.
result
].
^ searchBlock
!
browseForSymbol:aSymbol
"launch a browser for all methods referencing aSymbol"
^ self browseForSymbol:aSymbol title:('users of ' , aSymbol) warnIfNone:true
!
browseReferendsOf:aGlobalName warnIfNone:doWarn
"launch a browser for all methods referencing a global
named aGlobalName.
"
^ self browseForSymbol:aGlobalName title:('users of: ' , aGlobalName) warnIfNone:doWarn
!
browseReferendsOf:aGlobalName
"launch a browser for all methods referencing a global
named aGlobalName.
"
^ self browseReferendsOf:aGlobalName warnIfNone:true
"
Browser browseReferendsOf:#Transcript
"
!
browseUsesOf:aClass
|dict owners offsets
sz "{ Class: SmallInteger }"
n "{ Class: SmallInteger }"
removeSet newDict|
owners := ObjectMemory whoReferencesInstancesOf:aClass.
"
collect set of offsets in dict; key is class
"
dict := IdentityDictionary new.
owners do:[:someObject |
|cls create|
someObject isContext ifFalse:[
"
someObject refers to an instance of aClass;
find out, which instVar(s)
"
cls := someObject class.
cls ~~ Array ifTrue:[
n := cls instSize.
create := [|s| s := Set new. dict at:cls put:s. s].
1 to:n do:[:i |
|ref|
ref := someObject instVarAt:i.
(ref isMemberOf:aClass) ifTrue:[
offsets := dict at:cls ifAbsent:create.
offsets add:i.
]
].
cls isVariable ifTrue:[
cls isPointers ifTrue:[
| idx "{ Class: SmallInteger }" |
sz := someObject basicSize.
idx := 1.
[idx <= sz] whileTrue:[
|ref|
ref := someObject basicAt:idx.
(ref isMemberOf:aClass) ifTrue:[
offsets := dict at:cls ifAbsent:create.
offsets add:0.
idx := sz
].
idx := idx + 1
]
]
]
]
]
].
"
merge with superclass refs
"
dict keysAndValuesDo:[:cls :set |
cls allSuperclasses do:[:aSuperclass |
|superSet|
superSet := dict at:aSuperclass ifAbsent:[].
superSet notNil ifTrue:[
|removeSet|
superSet := dict at:aSuperclass.
removeSet := Set new.
set do:[:offset |
(superSet includes:offset) ifTrue:[
removeSet add:offset
]
].
set removeAll:removeSet
]
]
].
"
remove empty ones
"
removeSet := Set new.
dict keysAndValuesDo:[:cls :set |
set isEmpty ifTrue:[
removeSet add:cls
]
].
removeSet do:[:cls |
dict removeKey:cls
].
"
replace the indices by real names
"
newDict := IdentityDictionary new.
dict keysAndValuesDo:[:cls :set |
|newSet names|
names := cls allInstVarNames.
newSet := set collect:[:index |
index == 0 ifTrue:['*indexed*'] ifFalse:[names at:index].
].
newDict at:cls put:newSet
].
newDict inspect
!
browseForString:aString in:aCollectionOfClasses
"launch a browser for all methods in aCollectionOfClasses
containing a string-constant"
|browser searchBlock title|
title := 'methods containing: ' , aString displayString.
(aString includesMatchCharacters) ifTrue:[
"a matchString"
searchBlock := [:lits |
|found|
found := false.
lits notNil ifTrue:[
lits do:[:aLiteral |
found ifFalse:[
(aLiteral isMemberOf:String) ifTrue:[
found := (aString match:aLiteral)
]
]
]
].
found
].
] ifFalse:[
searchBlock := [:lits |
|found|
found := false.
lits notNil ifTrue:[
lits do:[:aLiteral |
found ifFalse:[
(aLiteral isMemberOf:String) ifTrue:[
found := (aLiteral = aString)
]
]
]
].
found
].
].
browser := self browseMethodsIn:aCollectionOfClasses
where:[:c :m :s | searchBlock value:(m literals)]
title:title.
browser notNil ifTrue:[
browser autoSearch:aString
].
^ browser
"SystemBrowser browseForString:'*all*'"
"SystemBrowser browseForString:'*should*'"
"SystemBrowser browseForString:'*[eE]rror*'"
!
browseForString:aString
"launch a browser for all methods containing a string"
^ self browseForString:aString in:(Smalltalk allClasses)
!
browseInstRefsTo:varName in:aCollectionOfClasses modificationsOnly:modsOnly title:title
"launch a browser for all methods in aClass where the instVar named
varName is referenced; if modsOnly is true, browse only methods where the
instvar is modified"
|filter browser|
filter := self filterToSearchInstRefsTo:varName modificationsOnly:modsOnly.
browser := self browseInstMethodsIn:aCollectionOfClasses where:filter title:title.
browser notNil ifTrue:[
browser autoSearch:varName
].
^ browser
!
aproposSearch:aString in:aCollectionOfClasses
"browse all methods, which have aString in their selector or
in the methods comment.
This is relatively slow, since all source must be processed."
|matchString list|
matchString := '*' , aString , '*'.
list := OrderedCollection new.
^ self browseMethodsIn:aCollectionOfClasses
where:[:class :method :sel |
(matchString match:sel) ifTrue:[
list add:(class name , '>>' , sel)
] ifFalse:[
(matchString match:(method comment)) ifTrue:[
list add:(class name , '>>' , sel)
]
].
Processor yield.
]
title:('apropos: ' , aString)
"SystemBrowser aproposSearch:'append'"
"SystemBrowser aproposSearch:'add'"
"SystemBrowser aproposSearch:'sort'"
!
browseInstRefsTo:aString in:aCollectionOfClasses modificationsOnly:modsOnly
"launch a browser for all methods in aClass where the instVar named
aString is referenced; if modsOnly is true, browse only methods where the
instvar is modified"
|title|
modsOnly ifTrue:[
title := 'modifications of '
] ifFalse:[
title := 'references to '
].
^ self browseInstRefsTo:aString
in:aCollectionOfClasses
modificationsOnly:modsOnly
title:(title , aString)
!
aproposSearch:aString
"browse all methods, which have aString in their selector or
in the methods comment.
This is relatively slow, since all source must be processed."
^ self aproposSearch:aString in:(Smalltalk allClasses)
!
browseInstRefsTo:aString under:aClass modificationsOnly:modsOnly
"launch a browser for all methods in aClass and subclasses
where the instVar named aString is referenced;
if modsOnly is true, browse only methods where the instvar is modified"
^ self browseInstRefsTo:aString in:(aClass withAllSubclasses) modificationsOnly:modsOnly
!
browseClassRefsTo:varName in:aCollectionOfClasses modificationsOnly:modsOnly title:title
"launch a browser for all methods in aCollectionOfClasses,
where the classVar named aString is referenced;
if modsOnly is true, browse only methods where the classvar is modified"
|searchBlock browser|
searchBlock := self filterToSearchClassRefsTo:varName modificationsOnly:modsOnly.
browser := self browseMethodsIn:aCollectionOfClasses where:searchBlock title:title.
browser notNil ifTrue:[
browser autoSearch:varName
].
^ browser
!
browseClassRefsTo:aString in:aCollectionOfClasses modificationsOnly:modsOnly
"launch a browser for all methods in aClass where the classVar named
aString is referenced; if modsOnly is true, browse only methods where the
classvar is modified"
|title|
modsOnly ifTrue:[
title := 'modifications of '
] ifFalse:[
title := 'references to '
].
^ self browseClassRefsTo:aString in:aCollectionOfClasses modificationsOnly:modsOnly title:(title , aString)
!
browseClassRefsTo:aString under:aClass modificationsOnly:modsOnly
"launch a browser for all methods in aClass and subclasses
where the classVar named aString is referenced;
if modsOnly is true, browse only methods where the classvar is modified"
^ self browseClassRefsTo:aString in:(aClass withAllSubclasses) modificationsOnly:modsOnly
!
filterToSearchClassRefsTo:varName modificationsOnly:modsOnly
"return a searchblock for class variable references"
|searchBlock|
searchBlock := [:c :m :s |
|src result parser classvars needMatch|
needMatch := varName includesMatchCharacters.
src := m source.
src isNil ifTrue:[
result := false
] ifFalse:[
needMatch ifFalse:[
"
before doing a slow parse, quickly scan the
methods source for the variables name ...
"
result := (src findString:varName) ~~ 0.
] ifTrue:[
result := true.
].
result ifTrue:[
result := false.
parser := Parser parseMethod:src in:c.
parser notNil ifTrue:[
modsOnly ifTrue:[
classvars := parser modifiedClassVars
] ifFalse:[
classvars := parser usedClassVars
].
classvars notNil ifTrue:[
needMatch ifTrue:[
classvars do:[:cv |
(varName match:cv) ifTrue:[result := true]
]
] ifFalse:[
result := classvars includes:varName
]
]
].
].
].
Processor yield.
result
].
^ searchBlock
! !
!SystemBrowser class methodsFor:'private'!
newWithLabel:aString setupBlock:aBlock on:aWorkstation
"common helper method for all creation methods"
|newBrowser|
newBrowser := self on:aWorkstation.
newBrowser title:aString.
aBlock value:newBrowser.
newBrowser open.
^ newBrowser
!
newWithLabel:aString setupBlock:aBlock
"common helper method for all creation methods"
^ self newWithLabel:aString setupBlock:aBlock on:Display
!
showNoneFound:what
"/ DialogView warn:(self classResources string:('no ' , what , ' found')).
self showNoneFound
!
showNoneFound
DialogView warn:(self classResources string:'None found').
! !
!SystemBrowser class methodsFor:'general startup'!
openOnDisplay:aDisplay
"launch a standard browser on another display.
Does not work currently - still being developped."
^ self newWithLabel:(self classResources string:'System Browser')
setupBlock:[:browser | browser setupForAll]
on:aDisplay
"
SystemBrowser openOnDisplay:(XWorkstation new initializeFor:'porty:0')
"
!
open
"launch a standard browser"
^ self openOnDisplay:Display
"SystemBrowser open"
! !
!SystemBrowser methodsFor:'dependencies'!
update:something with:someArgument from:changedObject
"
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:[
((someArgument category = currentClassCategory)
or:[currentClassCategory notNil
and:[currentClassCategory startsWith:'*']]) ifTrue:[
self updateClassListWithScroll:false.
].
someArgument category ~= currentClassCategory ifTrue:[
"
category new ?
"
(classCategoryListView notNil
and:[classCategoryListView list notNil
and:[(classCategoryListView 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"
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 isKindOf:Method) ifTrue:[
]
! !
!SystemBrowser methodsFor:'private'!
normalLabel
"set the normal (inactive) window- and icon labels"
|l il sel|
myLabel notNil ifTrue:[
l := il := myLabel
] ifFalse:[
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.
!
setAcceptAndExplainActionsForMethod
"tell the codeView what to do on accept and explain"
codeView acceptAction:[:theCode |
|cat|
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:[
Object abortSignal catch:[
lockUpdates := true.
actualClass compiler
compile:theCode asString
forClass:actualClass
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)
].
!
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"
|box|
codeView modified ifFalse:[
^ true
].
"/ fullProtocol ifTrue:[^ true].
box := YesNoBox
title:(resources at:'contents in codeview has not been accepted.\\Modifications will be lost when continuing.') withCRs
yesText:(resources at:'continue')
noText:(resources at:'abort').
^ box confirm
!
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
] ifFalse:[
sel := ''
]
].
^ sel
!
enterBoxTitle:title okText:okText
"convenient method: setup enterBox"
|box|
box := EnterBox new.
box title:(resources string:title) okText:(resources string:okText).
^ box
!
askAndBrowseSelectorTitle:title action:aBlock
"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 | self withCursor:(Cursor questionMark) do:[aBlock value:aString]].
box showAtPointer
!
setSearchPattern:aString
codeView setSearchPattern:aString
!
listBoxTitle:title okText:okText list:aList
"convenient method: setup a listBox & return it"
|box|
box := ListSelectionBox new.
box okText:(resources string:okText).
box title:(resources string:title).
box list:aList.
^ box
!
showExplanation:someText
"show explanation from Parser"
self notify: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 | self withWaitCursorDo:[aBlock value:aString]].
box showAtPointer
!
askBoxTitle:title okText:okText initialText:initialText action:aBlock
"convenient method: setup enterBox, and open it"
|box|
box := EnterBox new.
box title:(resources string:title) okText:(resources string:okText).
box initialText:initialText.
box action:[:aString | 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
!
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 copyTo:(clsName size - 5)
] ifFalse:[
isMeta := false
].
]
].
aBlock value:clsName value:sel value:isMeta
!
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
!
warnLabel:what
"set the title for some warning"
self label:('System Browser WARNING: ' , what)
!
busyLabel:what with:someArgument
"set the title for some warning"
self label:('System Browser:' , (resources string:what with:someArgument))
! !
!SystemBrowser methodsFor:'method stuff'!
updateMethodListWithScroll:scroll
|selectors scr first last|
methodListView notNil ifTrue:[
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
]
].
]
!
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 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 ifTrue:[
classListView attributeAt:index add:#bold.
].
currentClass := cls.
]
].
]
!
updateMethodList
self updateMethodListWithScroll:true
!
methodSelection:lineNr
"user clicked on a method line - show code"
|selectorString selectorSymbol index|
(fullProtocol not and:[currentClass isNil]) ifTrue:[^ self].
selectorString := methodListView selectionValue.
"
kludge: check if its a wrapped one
"
(selectorString endsWith:' !!') ifTrue:[
selectorString := selectorString copyTo:(selectorString size - 2)
].
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.
]
]
] 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
!
listOfAllSelectorsInCategory:aCategory ofClass:aClass
"answer a list of all selectors in a given method category
of the argument, aClass"
|newList searchCategory selector|
(aCategory = '* all *') ifTrue:[
newList := aClass selectorArray asOrderedCollection
] ifFalse:[
(aCategory = '* no category *') ifTrue:[
searchCategory := nil
] ifFalse:[
searchCategory := aCategory
].
newList := OrderedCollection new.
aClass methodArray with:aClass selectorArray do:[:aMethod :selector |
|sel|
(aMethod category = searchCategory) ifTrue:[
aMethod isWrapped ifTrue:[
sel := selector , ' !!'
] ifFalse:[
sel := selector
].
"mhmh - can this happen ?"
"/ (newList includes:sel) ifFalse:[
newList add:sel
"/ ]
]
]
].
(newList size == 0) ifTrue:[^ nil].
^ newList sort
!
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''.
"
'
!
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 thisList searchCategory selector|
newList := Set new.
self classesInFullProtocolHierarchy:aClass do:[:c |
(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
!
checkMethodSelected
currentMethod isNil ifTrue:[
self warn:'select a method first'.
^ false
].
^ true
!
switchToMethodNamed:matchString
|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
]
]
!
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 whichClassImplements:aSelector.
aClass notNil ifTrue:[
nm := aClass name.
showInstance ifFalse:[
((nm ~= 'Metaclass') and:[nm endsWith:'class']) ifTrue:[
nm := nm copyTo:(nm size - 5)
]
].
self switchToClassNamed:nm.
self switchToMethodNamed:aString
]
]
! !
!SystemBrowser methodsFor:'misc'!
updateCodeView
|code aStream|
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
"switch to instance protocol"
showInstance ifFalse:[
self checkSelectionChangeAllowed ifTrue:[
classToggle turnOff.
instanceToggle turnOn.
showInstance := true.
(variableListView notNil
and:[variableListView hasSelection]) ifTrue:[
self unhilightMethodCategories.
self unhilightMethods.
variableListView deselect
].
fullProtocol ifTrue:[
actualClass := currentClass.
self updateClassList.
self updateMethodCategoryListWithScroll:false.
self updateMethodListWithScroll:false.
self updateVariableList.
^ self
].
currentClass notNil ifTrue:[
self classSelectionChanged
].
codeView modified:false.
] ifFalse:[
instanceToggle turnOff.
classToggle turnOn
]
]
!
classProtocol
"switch to class protocol"
showInstance ifTrue:[
self checkSelectionChangeAllowed ifTrue:[
instanceToggle turnOff.
classToggle turnOn.
showInstance := false.
(variableListView notNil
and:[variableListView hasSelection]) ifTrue:[
self unhilightMethodCategories.
self unhilightMethods.
variableListView deselect
].
fullProtocol ifTrue:[
actualClass := currentClass class.
self updateClassList.
self updateMethodCategoryListWithScroll:false.
self updateMethodListWithScroll:false.
self updateVariableList.
^ self
].
currentClass notNil ifTrue:[
self classSelectionChanged
].
codeView modified:false.
] ifFalse:[
instanceToggle turnOn.
classToggle turnOff
]
]
! !
!SystemBrowser methodsFor:'method category stuff'!
updateMethodCategoryListWithScroll:scroll
|categories|
methodCategoryListView notNil ifTrue:[
fullProtocol ifTrue:[
currentClassHierarchy notNil ifTrue:[
categories := self listOfAllMethodCategoriesInFullProtocolHierarchy:currentClassHierarchy
]
] 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 cat|
newList := Text new.
aClass methodArray do:[:aMethod |
cat := aMethod category.
cat isNil ifTrue:[
cat := '* no category *'
].
(newList includes:cat) ifFalse:[newList add:cat]
].
(newList size == 0) ifTrue:[^ nil].
newList add:'* all *'.
^ newList 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 selection notNil ifTrue:[
self methodSelection:methodListView selection.
]
]
]
!
updateMethodCategoryList
self updateMethodCategoryListWithScroll:true
!
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.
]
!
listOfAllMethodCategoriesInFullProtocolHierarchy:aClass
"answer a list of all method categories of the argument, aClass,
and all of its superclasses.
Used with fullProtocol browsing."
|newList cat|
newList := Text new.
self classesInFullProtocolHierarchy:aClass do:[:c |
c methodArray do:[:aMethod |
cat := aMethod category.
cat isNil ifTrue:[
cat := '* no category *'
].
(newList includes:cat) ifFalse:[newList add:cat]
]
].
(newList size == 0) ifTrue:[^ nil].
newList add:'* all *'.
^ newList 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:[
Symbol hasInterned:aClassName ifTrue:[:sym |
(Smalltalk includesKey:sym) ifTrue:[
class := Smalltalk at:sym
].
].
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
|source|
currentClass notNil ifTrue:[
"/ codeView abortAction:[^ self].
Object abortSignal catch:[
class methodArray do:[:aMethod |
(category match:aMethod category) ifTrue:[
source := aMethod source.
codeView contents:source.
codeView modified:false.
actualClass compiler 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 := Text new].
(categories includes:aString) ifFalse:[
categories add:aString.
categories sort.
methodCategoryListView contents:categories
].
currentMethodCategory := aString.
self methodCategorySelectionChanged
! !
!SystemBrowser methodsFor:'initialize / release'!
initialize
super initialize.
self icon:(Form fromFile:(resources at:'ICON_FILE' default:'SBrowser.xbm')
resolution:100).
showInstance := true.
fullClass := false.
fullProtocol := false.
aspect := nil.
"inform me, when Smalltalk changes"
Smalltalk addDependent:self
!
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).
self initializeClassCategoryMenu
].
v := classListView.
v notNil ifTrue:[
v action:[:lineNr | self classSelection:lineNr].
v selectConditionBlock:checkBlock.
v ignoreReselect:false.
self initializeClassMenu
].
v := methodCategoryListView.
v notNil ifTrue:[
v action:[:lineNr | self methodCategorySelection:lineNr].
v selectConditionBlock:checkBlock.
v ignoreReselect:false.
self initializeMethodCategoryMenu
].
v := methodListView.
v notNil ifTrue:[
v action:[:lineNr | self methodSelection:lineNr].
v selectConditionBlock:checkBlock.
v ignoreReselect:false.
self initializeMethodMenu
].
v := classMethodListView.
v notNil ifTrue:[
v action:[:lineNr | self classMethodSelection:lineNr].
v selectConditionBlock:checkBlock.
v ignoreReselect:false.
self initializeClassMethodMenu
].
v := variableListView.
v notNil ifTrue:[
v action:[:lineNr | self variableSelection:lineNr].
v ignoreReselect:false.
v toggleSelect:true
]
!
terminate
(self checkSelectionChangeAllowed) ifTrue:[
super terminate
]
!
destroy
"relese dependant - destroy popups"
Smalltalk removeDependent:self.
currentClass notNil ifTrue:[
currentClass removeDependent:self.
currentClass := nil
].
super destroy
!
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
!
title:someString
myLabel := someString.
self label:someString.
! !
!SystemBrowser methodsFor:'initialize subviews'!
createClassListViewIn:frame
"setup the classlist subview, with its toggles"
|v panel oldStyle|
self createTogglesIn:frame.
"/ oldStyle := true.
oldStyle := false.
oldStyle ifTrue:[
v := ScrollableView for:SelectionInListView in:frame.
v origin:(0.0 @ 0.0)
extent:[frame width
@
(frame height
- (ViewSpacing // 2)
- instanceToggle height
- instanceToggle borderWidth
+ v borderWidth)].
classListView := v scrolledView
] ifFalse:[
panel := VariableVerticalPanel
origin:(0.0 @ 0.0)
corner:[frame width
@
(frame height
- (ViewSpacing // 2)
- 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
]
!
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
!
createTogglesIn:aFrame
"create and setup the class/instance toggles"
|halfSpacing h classAction instanceAction|
classAction := [self classProtocol].
instanceAction := [self instanceProtocol].
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 leftInset:(ViewSpacing // 2).
classToggle leftInset:(ViewSpacing // 2).
instanceToggle rightInset:ViewSpacing - (ViewSpacing // 2).
classToggle rightInset:ViewSpacing - (ViewSpacing // 2).
].
!
createCodeViewIn:aView
"setup the code view"
^ self createCodeViewIn:aView at:0.25
!
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
!
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
!
setupForClassHierarchy:aClass
"setup subviews to browse a class hierarchy"
|vpanel hpanel frame v|
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.
currentClassHierarchy := aClass.
self updateClassList.
self updateMethodCategoryList.
self updateMethodList.
self updateCodeView
!
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
!
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 // 2)
- 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 := aClass.
self updateMethodCategoryList.
self updateMethodList.
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 := 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 := aClass.
currentMethodCategory := aMethodCategory.
self updateMethodList.
self updateCodeView
!
setupForFullClassProtocol:aClass
"setup subviews to browse a classes full protocol"
|vpanel hpanel frame v|
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.
currentClassHierarchy := actualClass := currentClass := aClass.
fullProtocol := true.
self updateClassList.
self updateMethodCategoryList.
self updateMethodList.
self updateCodeView.
self updateVariableList.
!
setupForFullClassHierarchy:aClass
"setup subviews to browse a class hierarchy"
|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.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 setupActions.
self createCodeViewIn:vpanel at:0.4.
currentClassHierarchy := actualClass := aClass.
fullProtocol := true.
self updateClassList.
self updateMethodCategoryList.
self updateMethodList.
self updateCodeView.
self updateVariableList.
! !
!SystemBrowser 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 thisList searchCategory selector|
newList := Set new.
self classesInHierarchy:aClass do:[:c |
(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 := Text new.
self classesInHierarchy:aClass do:[:c |
c methodArray do:[:aMethod |
cat := aMethod category.
cat isNil ifTrue:[
cat := '* no category *'
].
(newList includes:cat) ifFalse:[newList add:cat]
]
].
(newList size == 0) ifTrue:[^ nil].
newList add:'* all *'.
^ newList sort
! !
!SystemBrowser methodsFor:'class stuff'!
switchToClass:newClass
fullProtocol ifTrue:[^ self].
currentClass notNil ifTrue:[
currentClass removeDependent:self
].
currentClass := newClass.
currentClass notNil ifTrue:[
currentClass addDependent:self.
].
self normalLabel
!
classSelectionChanged
|oldMethodCategory oldMethod oldSelector|
self withWaitCursorDo:[
oldMethodCategory := currentMethodCategory.
oldMethod := currentMethod.
oldSelector := currentSelector.
showInstance ifTrue:[
actualClass := currentClass
] ifFalse:[
actualClass := currentClass class
].
currentMethodCategory := nil.
currentMethod := nil.
currentSelector := nil.
self updateVariableList.
self updateMethodCategoryList.
oldMethodCategory notNil ifTrue:[
methodCategoryListView selectElement:oldMethodCategory.
methodCategoryListView selection notNil 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)
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
]
].
"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 compiler
].
compiler
evaluate:theCode
in:nil
receiver:currentClass
notifying:codeView
logged:false
ifFail:nil
].
]
!
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
]
]
]
!
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
]
!
listOfAllClassesInCategory:aCategory
"return a list of all classes in a given category"
|newList classList searchCategory string|
newList := Text new.
(aCategory = '* all *') ifTrue:[
Smalltalk allBehaviorsDo:[:aClass |
string := aClass name.
newList indexOf:string ifAbsent:[newList add:string]
]
] ifFalse:[
(aCategory = '* hierarchy *') ifTrue:[
classList := Text new.
self classHierarchyDo:[:aClass :lvl|
string := aClass name.
classList indexOf:string ifAbsent:[
classList add:string.
newList add:(String new:lvl) , string
]
].
^ newList
] ifFalse:[
(aCategory = '* no category *') ifTrue:[
searchCategory := nil
] ifFalse:[
searchCategory := aCategory
].
Smalltalk allBehaviorsDo:[:aClass |
aClass isMeta ifFalse:[
(aClass category = searchCategory) ifTrue:[
string := aClass name.
newList indexOf:string ifAbsent:[newList add:string]
]
]
]
]
].
(newList size == 0) ifTrue:[^ nil].
^ newList sort
!
doClassMenu:aBlock
"a helper - check if class is selected and evaluate aBlock
while showing waitCursor"
self checkClassSelected ifTrue:[
self withWaitCursorDo:aBlock
]
!
checkClassSelected
"warn and return false, if no class is selected"
currentClass isNil ifTrue:[
self warn:'select a class first'.
^ false
].
^ true
!
updateClassList
self updateClassListWithScroll:true
!
listOfClassHierarchyOf:aClass
"return a hierarchy class-list"
|classes|
classes := aClass allSuperclasses reverse , (Array with:aClass).
fullProtocol ifFalse:[
classes := classes , aClass allSubclassesInOrder
].
^ classes collect:[:c | c name]
!
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
!
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).
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:[
|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.
self class browseReferendsOf:oldSym warnIfNone:false
]
]
!
switchToClassNamed:aString
|classSymbol theClass newCat|
aString knownAsSymbol ifFalse:[^ self].
classSymbol := aString asSymbol.
theClass := Smalltalk at:classSymbol.
theClass isBehavior ifTrue:[
classCategoryListView notNil ifTrue:[
currentClassHierarchy isNil ifTrue:[
((newCat := theClass category) ~= currentClassCategory) ifTrue:[
currentClassCategory := newCat.
newCat isNil ifTrue:[
classCategoryListView selectElement:'* no category *'
] ifFalse:[
classCategoryListView selectElement:newCat.
].
"/ classCategoryListView makeSelectionVisible.
]
]
].
self updateClassList.
self switchToClass:theClass.
classListView selectElement:aString.
self classSelectionChanged
]
!
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
! !
!SystemBrowser methodsFor:'variable stuff'!
updateVariableList
|l subList flags 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 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
]
!
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 idx 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:currentClass.
currentClassHierarchy notNil ifTrue:[
fullProtocol ifTrue:[
].
classes := classes , currentClass allSuperclasses.
redefinedSelectors := IdentitySet new.
].
showInstance ifTrue:[
filter := self class filterToSearchInstRefsTo:name modificationsOnly:false
] ifFalse:[
filter := self class filterToSearchClassRefsTo:name modificationsOnly:false
].
any := false.
"
highlight the method that ref this variable
"
classes do:[:someClass |
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
]
]
!
hilightMethodsInMethodCategoryList
"search for methods which access the selected
variable, and highlight them"
self hilightMethodsInMethodCategoryList:true inMethodList:false
!
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.
]
].
!
hilightMethodsInMethodList
"search for methods which access the selected
variable, and highlight them"
self hilightMethodsInMethodCategoryList:false inMethodList:true
! !
!SystemBrowser 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:[
|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:[
isComment := true
]
].
].
s notNil ifTrue:[
aStream cr.
aStream cr.
aStream cr.
aStream cr.
aStream cr.
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 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)
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
]
!
initializeClassMenu
|labels menu|
labels := resources array:#(
'fileOut'
'printOut'
'printOut protocol'
" 'printOut full protocol' "
'-'
'SPAWN_CLASS'
'spawn full protocol'
'spawn hierarchy'
'spawn subclasses'
'-'
'hierarchy'
'definition'
'comment'
'class instvars'
" 'protocols' "
'-'
"/ 'variable search'
'class refs'
'-'
'new class'
'new subclass'
'rename ...'
'remove').
menu := PopUpMenu labels:labels
selectors:#(classFileOut
classPrintOut
classPrintOutProtocol
" classPrintOutFullProtocol "
nil
classSpawn
classSpawnFullProtocol
classSpawnHierarchy
classSpawnSubclasses
nil
classHierarchy
classDefinition
classComment
classClassInstVars
" classProtocols "
nil
"/ variables
classRefs
nil
classNewClass
classNewSubclass
classRename
classRemove)
receiver:self
for:classListView.
fullProtocol ifFalse:[
classListView middleButtonMenu:menu.
].
self initializeVariableListMenu.
!
classFileOut
"fileOut the current class.
Catch errors (sure, you like to know if it failed) and
warn if any)"
self doClassMenu:[
self busyLabel:'saving %1' with:currentClass name.
Class fileOutErrorSignal handle:[:ex |
self warn:'cannot create: %1' with:ex parameter.
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 w|
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 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:[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."
|browser|
self doClassMenuWithSelection:[:cls :sel |
cls isMeta ifTrue:[
Smalltalk allBehaviorsDo:[:aClass |
aClass class == cls ifTrue:[
browser := self class browseClass:aClass.
browser classProtocol.
sel notNil ifTrue:[
browser switchToMethodNamed:sel
].
^ self
].
].
self warn:'oops, no class for this metaclass'.
^ self
].
browser := self class browseClass:cls.
cls hasMethods ifFalse:[
browser classProtocol.
].
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 |
self class browseClassHierarchy:cls
]
!
classSpawnSubclasses
"create a new browser browsing current class's subclasses"
|subs|
self doClassMenuWithSelection:[:cls :sel |
subs := cls allSubclasses.
(subs notNil and:[subs size ~~ 0]) ifTrue:[
self class browseClasses:subs title:('subclasses of ' , cls name)
]
]
!
classPrintOutFullProtocol
|printStream|
self doClassMenu:[
printStream := Printer new.
currentClass printOutFullProtocolOn:printStream.
printStream close
]
!
classPrintOutProtocol
|printStream|
self doClassMenu:[
printStream := Printer new.
currentClass printOutProtocolOn:printStream.
printStream close
]
!
classPrintOut
|printStream|
self doClassMenu:[
printStream := Printer new.
currentClass printOutOn:printStream.
printStream close
]
!
classHierarchy
"show current classes hierarchy in codeView"
|aStream|
self doClassMenu:[
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|
currentClass notNil ifTrue:[
nm := currentClass superclass name
] ifFalse:[
nm := 'Object'
].
self classClassDefinitionTemplateFor:nm in:currentClassCategory.
aspect := nil.
!
classClassInstVars
"show class instance variables in codeView and setup accept-action
for a class-instvar-definition change"
|s|
self doClassMenu:[
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.
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 |
self class browseFullClassProtocol:cls
]
!
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 ' , currentClass name.
count ~~ 0 ifTrue:[
t := t , '\(with ' , count printString , ' subclass'.
count ~~ 1 ifTrue:[
t := t , 'es'
].
t := (t , ')') 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:[
"
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:[
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
].
"
methodCategoryListView notNil ifTrue:[methodCategoryListView contents:nil].
methodListView notNil ifTrue:[methodListView contents:nil].
codeView contents:nil.
codeView modified:false
]
]
]
!
classComment
"show the classes comment in the codeView.
Also, set acceptaction to change the comment."
self doClassMenu:[
codeView contents:(currentClass comment).
codeView modified:false.
codeView acceptAction:[:theCode |
Object abortSignal catch:[
lockUpdates := true.
currentClass comment:theCode asString.
codeView modified:false.
].
lockUpdates := false.
].
codeView explainAction:nil.
methodListView notNil ifTrue:[
methodListView deselect
].
aspect := #comment.
self normalLabel
]
!
classRefs
self doClassMenu:[
self withCursor:(Cursor questionMark) do:[
self class browseReferendsOf:currentClass name asSymbol
]
]
!
classNewSubclass
"create a subclass-definition prototype in codeview"
self doClassMenu:[
self classClassDefinitionTemplateFor:(currentClass name)
in:(currentClass category).
aspect := nil
]
!
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:[
self withCursor:(Cursor questionMark) do:[
self class 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
!
classSpawnFullHierarchy
"create a new HierarchyBrowser browsing current class"
self doClassMenuWithSelection:[:cls :sel |
self class browseFullClassHierarchy:cls
]
! !
!SystemBrowser methodsFor:'class category stuff'!
checkClassCategorySelected
currentClassCategory isNil ifTrue:[
self warn:'select a class category first'.
^ false
].
^ true
!
listOfAllClassCategories
"return a list of all class categories"
|newList cat|
newList := Text with:'* all *' with:'* hierarchy *'.
Smalltalk allBehaviorsDo:[:aClass |
cat := aClass category.
cat isNil ifTrue:[
cat := '* no category *'
].
newList indexOf:cat ifAbsent:[newList add:cat]
].
newList sort.
^ newList
!
classCategorySelectionChanged
"class category has changed - update dependent views"
self withWaitCursorDo:[
self switchToClass:nil.
actualClass := 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 classIndex index|
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:[
self withWaitCursorDo:[
self updateClassList
].
"stupid - search for class name in (indented) list"
index := 1.
classListView list do:[:elem |
(elem endsWith:(oldClass name)) ifTrue:[
classIndex := index
].
index := index + 1
].
classIndex notNil ifTrue:[
classListView selection:classIndex.
self switchToClass:(Smalltalk at:(oldClass name 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
].
]
!
updateClassCategoryList
self updateClassCategoryListWithScroll:true
!
allClassesInCurrentCategoryInOrderDo:aBlock
"evaluate aBlock for all classes in the current class category;
superclasses come first - then subclasses"
|classes|
currentClassCategory notNil ifTrue:[
classes := OrderedCollection new.
Smalltalk allBehaviorsDo:[:aClass |
aClass isMeta ifFalse:[
(aClass category = currentClassCategory) ifTrue:[
classes add:aClass
]
]
].
classes topologicalSort:[:a :b | b isSubclassOf:a].
classes do:aBlock
]
!
allClassesInCurrentCategoryDo:aBlock
"evaluate aBlock for all classes in the current class category;
superclasses come first - then subclasses"
currentClassCategory notNil ifTrue:[
Smalltalk allBehaviorsDo:[:aClass |
aClass isMeta ifFalse:[
(aClass category = currentClassCategory) ifTrue:[
aBlock value:aClass
]
]
].
]
!
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
]
]
! !
!SystemBrowser 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)
!
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"
|string classString selectorString|
string := classMethodListView selectionValue.
classString := self classFromClassMethodString:string.
selectorString := self selectorFromClassMethodString:string.
((classString ~= 'Metaclass') and:[classString endsWith:'class']) ifTrue:[
classString := classString copyTo:(classString size - 5).
self switchToClass:(Smalltalk at:classString asSymbol).
actualClass := currentClass class
] ifFalse:[
self switchToClass:(Smalltalk at:classString asSymbol).
actualClass := currentClass
].
currentClass isNil ifTrue:[
self warn:'oops class is gone'
] ifFalse:[
currentClassCategory := currentClass category.
currentSelector := selectorString asSymbol.
currentMethod := actualClass compiledMethodAt:currentSelector.
currentMethodCategory := currentMethod category.
self methodSelectionChanged
]
! !
!SystemBrowser methodsFor:'class category list menu'!
initializeClassCategoryMenu
|labels|
labels := resources array:#(
'fileOut'
'fileOut each'
"
'fileOut binary'
"
'printOut'
'printOut protocol'
'-'
'SPAWN_CATEGORY'
'spawn full class'
'-'
'update'
'find class ...'
'-'
'new class category ...'
'rename ...'
'remove').
classCategoryListView
middleButtonMenu:(PopUpMenu
labels:labels
selectors:#(classCategoryFileOut
classCategoryFileOutEach
classCategoryPrintOut
classCategoryPrintOutProtocol
nil
classCategorySpawn
classCategorySpawnFullClass
nil
classCategoryUpdate
classCategoryFindClass
nil
classCategoryNewCategory
classCategoryRename
classCategoryRemove)
receiver:self
for:classCategoryListView)
!
classCategoryUpdate
"update class category list and dependants"
|oldClassName oldMethodCategory|
classCategoryListView notNil ifTrue:[
currentClass notNil ifTrue:[
oldClassName := currentClass name.
(oldClassName endsWith:'-old') ifTrue:[
oldClassName := oldClassName 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|
self allClassesInCurrentCategoryInOrderDo:[:aClass |
printStream := Printer new.
aClass printOutProtocolOn:printStream.
printStream close
]
!
classCategoryPrintOut
|printStream|
self allClassesInCurrentCategoryDo:[:aClass |
printStream := Printer new.
aClass printOutOn:printStream.
printStream close
]
!
classCategorySpawn
"create a new SystemBrowser browsing current classCategory"
currentClassCategory notNil ifTrue:[
self withWaitCursorDo:[
self class 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.
].
"
if file exists, save original in a .sav file
"
fileName asFilename exists ifTrue:[
fileName asFilename copyTo:(fileName , '.sav')
].
aStream := FileStream newFileNamed:fileName.
aStream isNil ifTrue:[
^ self warn:'cannot create: %1' with:fileName
].
self withWaitCursorDo:[
self busyLabel:'writing: %1' with:fileName.
self allClassesInCurrentCategoryInOrderDo:[:aClass |
aClass fileOutOn:aStream.
].
aStream close.
self normalLabel.
]
!
classCategorySpawnFullClass
"create a new SystemBrowser browsing full class"
|newBrowser|
self withWaitCursorDo:[
newBrowser := self class browseFullClasses
" "
.
currentClass notNil ifTrue:[
newBrowser switchToClassNamed:(currentClass name)
]
" "
]
!
classCategoryFileOutEach
self withWaitCursorDo:[
self allClassesInCurrentCategoryDo:[:aClass |
self busyLabel:'saving: ' 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 := OrderedCollection new.
currentClass withAllSuperclasses do:[:aClass |
aClass methodArray do:[:aMethod |
(categories includes:aMethod category) ifFalse:[
categories add:aMethod category
]
]
].
].
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 := nil.
self classCategorySelectionChanged
]
].
box showAtPointer
!
classCategoryFindClass
|box|
box := self enterBoxForCodeSelectionTitle:'class to find:' okText:'find'.
box action:[:aString | self switchToClassNameMatching:aString].
box showAtPointer
!
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
]
! !
!SystemBrowser methodsFor:'method category list menu'!
initializeMethodCategoryMenu
|labels|
labels := resources array:#(
'fileOut'
'fileOut all'
'printOut'
'-'
'SPAWN_METHODCATEGORY'
'spawn category'
'-'
'find method here ...'
'find method ...'
'-'
'new category ...'
'copy category ...'
'create access methods'
'rename ...'
'remove').
methodCategoryListView
middleButtonMenu:(PopUpMenu
labels:labels
selectors:#(
methodCategoryFileOut
methodCategoryFileOutAll
methodCategoryPrintOut
nil
methodCategorySpawn
methodCategorySpawnCategory
nil
methodCategoryFindMethod
methodCategoryFindAnyMethod
nil
methodCategoryNewCategory
methodCategoryCopyCategory
methodCategoryCreateAccessMethods
methodCategoryRename
methodCategoryRemove)
receiver:self
for:methodCategoryListView)
!
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:[
self class browseClass:actualClass
methodCategory:currentMethodCategory
]
]
!
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.
].
!
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
!
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 |
self class 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
]
!
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 := resources string:'remove %1 ?\(with 1 method)' with:currentMethodCategory
] ifFalse:[
t := resources string:'remove %1 ?\(with %2 methods)' 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 selectorForMethod:aMethod)
]
].
currentMethodCategory := nil.
currentMethod := currentSelector := nil.
self updateMethodCategoryList.
self updateMethodList
]
]
]
! !
!SystemBrowser methodsFor:'method list menu'!
methodMenu
"return a popupmenu as appropriate for the methodList"
|labels selectors|
(currentMethod notNil and:[currentMethod isWrapped]) ifTrue:[
labels := #(
'fileOut'
'printOut'
'-'
'SPAWN_METHOD'
'-'
'senders ...'
'implementors ...'
'globals ...'
"
'strings ...'
'apropos ...'
"
'-'
'local senders ...'
'local implementors ...'
"
'local strings ...'
"
'-'
'remove break/trace'
'-'
'new method'
'change category ...'
'remove'
).
selectors := #(
methodFileOut
methodPrintOut
nil
methodSpawn
nil
methodSenders
methodImplementors
methodGlobalReferends
"
methodStringSearch
methodAproposSearch
"
nil
methodLocalSenders
methodLocalImplementors
"
methodLocalStringSearch
"
nil
methodRemoveBreakOrTrace
nil
methodNewMethod
methodChangeCategory
methodRemove
)
] ifFalse:[
labels := #(
'fileOut'
'printOut'
'-'
'SPAWN_METHOD'
'-'
'senders ...'
'implementors ...'
'globals ...'
"
'strings ...'
'apropos ...'
"
'-'
'local senders ...'
'local implementors ...'
"
'local strings ...'
"
'-'
'breakpoint'
'trace'
'trace sender'
'-'
'new method'
'change category ...'
'remove'
).
selectors := #(
methodFileOut
methodPrintOut
nil
methodSpawn
nil
methodSenders
methodImplementors
methodGlobalReferends
"
methodStringSearch
methodAproposSearch
"
nil
methodLocalSenders
methodLocalImplementors
"
methodLocalStringSearch
"
nil
methodBreakPoint
methodTrace
methodTraceSender
nil
methodNewMethod
methodChangeCategory
methodRemove
)
].
^ PopUpMenu
labels:(resources array:labels)
selectors:selectors
receiver:self
for:methodListView
!
initializeMethodMenu
|labels|
methodListView model:self.
methodListView menu:#methodMenu.
^ self.
labels := resources array:#(
'fileOut'
'printOut'
'-'
'SPAWN_METHOD'
'-'
'senders ...'
'implementors ...'
'globals ...'
"
'strings ...'
'apropos ...'
"
'-'
'local senders ...'
'local implementors ...'
"
'local strings ...'
"
'-'
'breakpoint'
'trace'
'trace sender'
'-'
'new method'
'change category ...'
'remove').
methodListView
middleButtonMenu:(PopUpMenu
labels:labels
selectors:#(methodFileOut
methodPrintOut
nil
methodSpawn
nil
methodSenders
methodImplementors
methodGlobalReferends
"
methodStringSearch
methodAproposSearch
"
nil
methodLocalSenders
methodLocalImplementors
"
methodLocalStringSearch
"
nil
methodBreakPoint
methodTrace
methodTraceSender
nil
methodNewMethod
methodChangeCategory
methodRemove)
receiver:self
for:methodListView)
!
methodImplementors
"launch an enterBox for selector to search for"
self askAndBrowseSelectorTitle:'selector to browse implementors of:'
action:[:aString |
self class browseImplementorsOf:aString
]
!
methodSenders
"launch an enterBox for selector to search for"
self askAndBrowseSelectorTitle:'selector to browse senders of:'
action:[:aString |
self class browseAllCallsOn:aString
]
!
methodRemove
"remove the current method"
self checkMethodSelected ifFalse:[^ self].
actualClass removeSelector:(actualClass selectorForMethod:currentMethod).
currentMethod := currentSelector := nil.
self updateMethodListWithScroll:false
!
initializeMethodMenu2
|labels|
methodListView isNil ifTrue:[^ self].
^self.
labels := resources array:#(
'fileOut'
'printOut'
'-'
'SPAWN_METHOD'
'-'
'senders ...'
'implementors ...'
'globals ...'
"
'strings ...'
'apropos ...'
"
'-'
'local senders ...'
'local implementors ...'
"
'local strings ...'
"
'-'
'remove break/trace'
'-'
'new method'
'change category ...'
'remove').
methodListView
middleButtonMenu:(PopUpMenu
labels:labels
selectors:#(methodFileOut
methodPrintOut
nil
methodSpawn
nil
methodSenders
methodImplementors
methodGlobalReferends
"
methodStringSearch
methodAproposSearch
"
nil
methodLocalSenders
methodLocalImplementors
"
methodLocalStringSearch
"
nil
methodRemoveBreakOrTrace
nil
methodNewMethod
methodChangeCategory
methodRemove)
receiver:self
for:methodListView)
!
methodLocalSenders
"launch an enterBox for selector to search for in current class & subclasses"
self checkClassSelected ifFalse:[^ self].
self askAndBrowseSelectorTitle:'selector to browse local senderss of:'
action:[:aString |
self class browseCallsOn:aString under: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 askAndBrowseSelectorTitle:'selector to browse local implementors of:'
action:[:aString |
self class browseImplementorsOf:aString under:currentClass
]
!
methodGlobalReferends
"launch an enterBox for global symbol to search for"
self enterBoxForBrowseTitle:'global variable to browse users of:'
action:[:aString |
self class 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 meta isMeta w sep|
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:[
self class 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.
self class browseClass:(w at:1) selector:(w at:2)
]
!
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.
!
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.
currentClass changed.
currentMethod changed:#category.
currentClass addChangeRecordForMethodCategory:currentMethod category:aString.
self updateMethodCategoryListWithScroll:false.
self updateMethodListWithScroll:false
].
box showAtPointer
!
methodStringSearch
"launch an enterBox for (sub)-string to search for"
self askAndBrowseSelectorTitle:'string / matchString to search for:'
action:[:aString |
self class browseForString:aString
]
!
methodLocalStringSearch
"launch an enterBox for (sub)-string to search for"
self checkClassSelected ifFalse:[^ self].
self askAndBrowseSelectorTitle:'string / matchString to search for locally:'
action:[:aString |
self class browseForString:aString in:(currentClass withAllSubclasses)
]
!
methodAproposSearch
"launch an enterBox for a keyword search"
self askAndBrowseSelectorTitle:'keyword to search for:'
action:[:aString |
self class aproposSearch:aString
]
!
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.
!
methodTrace
"turn on tracing of the current method"
|sel|
currentClass notNil ifTrue:[
currentSelector notNil ifTrue:[
currentMethod := actualClass compiledMethodAt:currentSelector
]
].
(currentMethod notNil and:[currentMethod isWrapped not])
ifTrue:[
currentMethod := MessageTracer traceMethod:currentMethod.
sel := methodListView selection.
self updateMethodListWithScroll:false.
methodListView selection:sel.
currentClass changed:#methodDictionary with:currentSelector.
]
!
methodRemoveBreakOrTrace
"turn off tracing of the current method"
|sel|
(currentMethod notNil and:[currentMethod isWrapped])
ifTrue:[
currentMethod := MessageTracer unwrapMethod:currentMethod.
sel := methodListView selection.
self updateMethodListWithScroll:false.
methodListView selection:sel.
currentClass changed:#methodDictionary with:currentSelector.
]
!
methodBreakPoint
"set a breakpoint on the current method"
|sel|
currentMethod notNil ifTrue:[
currentMethod isWrapped ifFalse:[
currentMethod := MessageTracer trapMethod:currentMethod.
self initializeMethodMenu2.
sel := methodListView selection.
self updateMethodListWithScroll:false.
methodListView selection:sel
].
]
!
methodTraceSender
"turn on tracing of the current method"
|sel|
(currentMethod notNil and:[currentMethod isWrapped not])
ifTrue:[
currentMethod := MessageTracer traceMethodSender:currentMethod.
sel := methodListView selection.
self updateMethodListWithScroll:false.
methodListView selection:sel.
currentClass changed:#methodDictionary with:currentSelector.
]
!
methodMenuForWrappedMethod
|labels|
labels := resources array:#(
'fileOut'
'printOut'
'-'
'SPAWN_METHOD'
'-'
'senders ...'
'implementors ...'
'globals ...'
"
'strings ...'
'apropos ...'
"
'-'
'local senders ...'
'local implementors ...'
"
'local strings ...'
"
'-'
'remove break/trace'
'-'
'new method'
'change category ...'
'remove').
^ PopUpMenu
labels:labels
selectors:#(methodFileOut
methodPrintOut
nil
methodSpawn
nil
methodSenders
methodImplementors
methodGlobalReferends
"
methodStringSearch
methodAproposSearch
"
nil
methodLocalSenders
methodLocalImplementors
"
methodLocalStringSearch
"
nil
methodRemoveBreakOrTrace
nil
methodNewMethod
methodChangeCategory
methodRemove)
receiver:self
for:methodListView
! !
!SystemBrowser methodsFor:'variable list menu'!
initializeVariableListMenu
|varMenu|
varMenu := (PopUpMenu labels:(resources array:#(
'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
)
receiver:self
for:self).
variableListView isNil ifTrue:[
classListView notNil ifTrue:[
|menu|
menu := classListView middleButtonMenu.
menu addLabel:(resources string:'variable search')
selector:#variables
before:#classRefs.
menu subMenuAt:#variables put:varMenu.
]
] ifFalse:[
variableListView middleButtonMenu:varMenu
]
!
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:[
|box|
box := self enterBoxForVariableSearch:title.
box action:[:aVariableName |
self withCursor:(Cursor questionMark) do:[
|homeClass|
homeClass := self findClassOfVariable:aVariableName
accessWith:access.
(self class) browseInstRefsTo:aVariableName
under:homeClass
modificationsOnly:modifications
]
].
box showAtPointer
]
!
instVarRefsOrModsTitle:title mods:mods
"show an enterbox for instvar to search for"
self doClassMenu:[
|box|
box := self enterBoxForVariableSearch:title.
box action:[:aString |
self withCursor:(Cursor questionMark) do:[
self class 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:[
|box|
box := self enterBoxForVariableSearch:title.
box action:[:aString |
self withCursor:(Cursor questionMark) do:[
self class 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
! !
!SystemBrowser methodsFor:'class-method list menu'!
initializeClassMethodMenu
|labels|
labels := resources array:#(
'fileOut'
'fileOut all'
'printOut'
'-'
'spawn'
'spawn class'
'-'
'sender ...'
'implementors ...'
'globals ...'
"/ '-'
"/ 'breakpoint'
"/ 'trace'
"/ 'trace sender'
).
classMethodListView
middleButtonMenu:(PopUpMenu
labels:labels
selectors:#(methodFileOut
classMethodFileOutAll
methodPrintOut
nil
methodSpawn
classSpawn
nil
methodSenders
methodImplementors
methodGlobalReferends
"/ nil
"/ methodBreakPoint
"/ methodTrace
"/ methodTraceSender
)
receiver:self
for:classMethodListView)
!
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 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 new.
box yesText:'continue' noText:'abort'.
(box confirm:('fileOut error: ' , ex errorString ,
'\\continue anyway ?') withCRs) ifTrue:[
ex proceed
].
self normalLabel.
^ self
] do:[
cls fileOutMethod:mth on:outStream.
]
]
].
outStream close.
self normalLabel.
]
]
! !
SystemBrowser initialize!