"{ Package: 'Programming Tools' }"
"
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.
"
StandardSystemView subclass:#SystemBrowser
instanceVariableNames:'classCategoryListView classListView
methodCategoryListView methodListView
classMethodListView
codeView classToggle instanceToggle
currentClassCategory currentClassHierarchy
currentClass
currentMethodCategory currentMethod
showInstance actualClass fullClass
enterBox questBox
selectBox lastMethodCategory'
classVariableNames:''
poolDictionaries:''
category:'Interface-Browsers'
!
SystemBrowser comment:'
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
$Header: /cvs/stx/stx/libtool/SystemBrowser.st,v 1.10 1994-08-13 18:39:07 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/SystemBrowser.st,v 1.10 1994-08-13 18:39:07 claus Exp $
"
!
documentation
"
this class implements all kinds of class browsers.
Stypically, it is started with SystemBrowser open, but there are many other startup
messages, to launch special browsers.
See the extra document 'doc/misc/sbrowser.doc' for how to use this browser.
written winter 89 by claus
"
! !
!SystemBrowser class methodsFor:'general startup'!
open
"launch a standard browser"
^ self openOnDisplay:Display
"SystemBrowser open"
!
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')
"
! !
!SystemBrowser class methodsFor:'startup'!
browseFullClasses
"launch a browser showing all methods at once"
^ self newWithLabel:'Full Class Browser'
setupBlock:[:browser | browser setupForFullClass]
"SystemBrowser browseFullClasses"
!
browseClassCategory:aClassCategory
"launch a browser for all classes under aCategory"
^ self newWithLabel:aClassCategory
setupBlock:[:browser | browser setupForClassCategory:aClassCategory]
"SystemBrowser browseClassCategory:'Kernel-Objects'"
!
browseClass:aClass
"launch a browser for aClass"
^ self newWithLabel:aClass name
setupBlock:[:browser | browser setupForClass:aClass]
"SystemBrowser browseClass:Object"
!
browseClassHierarchy:aClass
"launch a browser for aClass and all its superclasses"
^ self newWithLabel:(aClass name , '-' , 'hierarchy')
setupBlock:[:browser | browser setupForClassHierarchy:aClass]
"SystemBrowser browseClassHierarchy: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'"
!
browseClass:aClass selector:selector
"launch a browser for the method at selector in aClass"
^ self newWithLabel:(aClass name , ' ' , selector)
setupBlock:[:browser | browser setupForClass:aClass selector:selector]
"SystemBrowser browseClass:Object selector:#printString"
!
browseMethods:aList title:aString
"launch a browser for an explicit list of class/selectors"
(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'
"
!
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'
!
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
!
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
!
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 prio checkedClasses checkBlock|
"
since this may take a long time, lower my priority ...
"
prio := Processor activeProcess priority.
Processor activeProcess priority:(prio - 1).
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.
]
].
[
checkedClasses := IdentitySet new.
list := OrderedCollection new.
aCollectionOfClasses do:[:aClass |
wantInst ifTrue:[checkBlock value:aClass].
wantClass ifTrue:[checkBlock value:(aClass class)]
]
] valueNowOrOnUnwindDo:[
Processor activeProcess priority:prio.
].
^ self browseMethods:list 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
!
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
!
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
! !
!SystemBrowser class methodsFor:'special search startup'!
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 +'
"
!
browseImplementorsOf:aSelectorString
"launch a browser for all implementors of aSelector"
^ self browseImplementorsOf:aSelectorString
in:(Smalltalk allClasses)
title:('implementors of: ' , aSelectorString)
"
SystemBrowser browseImplementorsOf:#+
"
!
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
"
!
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:[
browser setSearchPattern:aSelectorString
].
^ browser
!
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
"
!
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 setSearchPattern:aSymbol
].
^ browser
!
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
"
!
browseForString:aString in:aCollectionOfClasses
"launch a browser for all methods in aCollectionOfClasses containing a string"
|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 setSearchPattern: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)
!
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)
]
]
]
title:('apropos: ' , aString)
"SystemBrowser aproposSearch:'append'"
"SystemBrowser aproposSearch:'add'"
"SystemBrowser aproposSearch:'sort'"
!
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 in:aCollectionOfClasses modificationsOnly:modsOnly title:title
"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"
|parser result instvars searchBlock browser|
searchBlock := [:c :m :s |
result := false.
parser := Parser parseMethod:(m source) in:c.
parser notNil ifTrue:[
modsOnly ifTrue:[
instvars := parser modifiedInstVars
] ifFalse:[
instvars := parser usedInstVars
].
instvars notNil ifTrue:[
aString includesMatchCharacters ifTrue:[
instvars do:[:iv |
(aString match:iv) ifTrue:[result := true]
]
] ifFalse:[
result := instvars includes:aString
]
]
].
result
].
browser := self browseInstMethodsIn:aCollectionOfClasses where:searchBlock title:title.
browser notNil ifTrue:[
browser setSearchPattern:aString
].
^ browser
!
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)
!
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:aString 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"
|parser result classvars searchBlock browser|
searchBlock := [:c :m :s |
result := false.
parser := Parser parseMethod:(m source) in:c.
parser notNil ifTrue:[
modsOnly ifTrue:[
classvars := parser modifiedClassVars
] ifFalse:[
classvars := parser usedClassVars
].
classvars notNil ifTrue:[
aString includesMatchCharacters ifTrue:[
classvars do:[:cv |
(aString match:cv) ifTrue:[result := true]
]
] ifFalse:[
result := classvars includes:aString
]
]
].
result
].
browser := self browseMethodsIn:aCollectionOfClasses where:searchBlock title:title.
browser notNil ifTrue:[
browser setSearchPattern:aString
].
^ 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
! !
!SystemBrowser class methodsFor:'private'!
showNoneFound:what
"/ DialogView warn:(self classResources string:('no ' , what , ' found')).
self showNoneFound
!
showNoneFound
DialogView warn:(self classResources string:'None found').
!
newWithLabel:aString setupBlock:aBlock on:aWorkstation
"common helper method for all creation methods"
|newBrowser|
newBrowser := self on:aWorkstation.
newBrowser label: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
! !
!SystemBrowser methodsFor:'initialize / release'!
initialize
super initialize.
self icon:(Form fromFile:(resources at:'ICON_FILE' default:'SBrowser.xbm')
resolution:100).
showInstance := true.
fullClass := false.
"inform me, when Smalltalk changes"
Smalltalk addDependent:self
!
destroy
"relese dependant - destroy popups"
Smalltalk removeDependent:self.
currentClass notNil ifTrue:[
currentClass removeDependent:self.
currentClass := nil
].
enterBox notNil ifTrue:[enterBox destroy. enterBox := nil].
questBox notNil ifTrue:[questBox destroy. questBox := nil].
selectBox notNil ifTrue:[selectBox destroy. selectBox := nil].
super destroy
!
terminate
(self checkSelectionChangeAllowed) ifTrue:[
super terminate
]
!
createTogglesIn:aFrame
"create and setup the class/instance toggles"
|bw halfSpacing|
instanceToggle := Toggle label:(resources at:'instance') in:aFrame.
bw := instanceToggle borderWidth.
halfSpacing := [
(self is3D and:[style ~~ #st80]) ifTrue:[
ViewSpacing // 2
] ifFalse:[
0
]
].
instanceToggle extent:[(aFrame width // 2 - halfSpacing value) @ instanceToggle height].
instanceToggle origin:[bw negated + halfSpacing value
@
(aFrame height - instanceToggle heightIncludingBorder + bw)].
instanceToggle turnOn.
instanceToggle pressAction:[self instanceProtocol].
instanceToggle releaseAction:[self classProtocol].
classToggle := Toggle label:(resources at:'class') in:aFrame.
classToggle extent:[(aFrame width - (aFrame width // 2) - halfSpacing value) @ classToggle height].
classToggle origin:[(aFrame width // 2 + halfSpacing value)
@
(aFrame height - classToggle heightIncludingBorder + bw)].
classToggle turnOff.
classToggle pressAction:[self classProtocol].
classToggle releaseAction:[self instanceProtocol]
!
createClassListViewIn:frame
"setup the classlist subview, with its toggles"
|v|
self createTogglesIn:frame.
v := ScrollableView for:SelectionInListView in:frame.
v origin:(0.0 @ 0.0)
extent:[frame width
@
(frame height
- instanceToggle height
- instanceToggle borderWidth)].
classListView := v scrolledView
!
createCodeViewIn:aView
"setup the code view"
|v|
v := HVScrollableView for:CodeView miniScrollerH:true miniScrollerV:false in:aView.
v origin:(0.0 @ 0.25) corner:(1.0 @ 1.0).
codeView := v scrolledView
!
setupActions
"/ |v|
"/ v := classCategoryListView.
"/ v notNil ifTrue:[
"/ v action:[:lineNr | self classCategorySelection:lineNr].
"/ v selectConditionBlock:[self checkSelectionChangeAllowed].
"/ v ignoreReselect:false.
"/ ].
"/ v := classListView.
"/ v notNil ifTrue:[
"/ v action:[:lineNr | self classSelection:lineNr].
"/ v selectConditionBlock:[self checkSelectionChangeAllowed].
"/ v ignoreReselect:false.
"/ ].
"/ v := methodCategoryListView.
"/ v notNil ifTrue:[
"/ v action:[:lineNr | self methodCategorySelection:lineNr].
"/ v selectConditionBlock:[self checkSelectionChangeAllowed].
"/ v ignoreReselect:false.
"/ ].
"/ v := methodListView.
"/ v notNil ifTrue:[
"/ v action:[:lineNr | self methodSelection:lineNr].
"/ v selectConditionBlock:[self checkSelectionChangeAllowed].
"/ v ignoreReselect:false.
"/ ].
"/ v := classMethodListView.
"/ v notNil ifTrue:[
"/ v action:[:lineNr | self listSelection:lineNr].
"/ v selectConditionBlock:[self checkSelectionChangeAllowed].
"/ v ignoreReselect:false.
"/ ]
!
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.
"/ classCategoryListView contents:(self listOfAllClassCategories).
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 setupActions.
self createCodeViewIn:vpanel
!
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 setupActions.
self createCodeViewIn:vpanel.
fullClass := true.
self updateCodeView
!
setupForClassCategory:aClassCategory
"setup subviews to browse a class category"
|vpanel hpanel frame v|
vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
corner:(1.0 @ 1.0)
in:self.
hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
frame := View origin:(0.0 @ 0.0) corner:(0.33 @ 1.0) in:hpanel.
self createClassListViewIn:frame.
v := ScrollableView for:SelectionInListView in:hpanel.
v origin:(0.33 @ 0.0) corner:(0.66 @ 1.0).
methodCategoryListView := v scrolledView.
v := ScrollableView for:SelectionInListView in:hpanel.
v origin:(0.66 @ 0.0) corner:(1.0 @ 1.0).
methodListView := v scrolledView.
"/ self setupActions.
self createCodeViewIn:vpanel.
currentClassCategory := aClassCategory.
self updateClassList.
self updateMethodCategoryList.
self updateMethodList.
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 setupActions.
self createCodeViewIn:vpanel.
l := aList collect:[:entry | entry name].
classListView list:(l sort).
self updateMethodCategoryList.
self updateMethodList.
self updateCodeView
!
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.
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 setupActions.
self createCodeViewIn:vpanel.
currentClassHierarchy := aClass.
self updateClassList.
self updateMethodCategoryList.
self updateMethodList.
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 - instanceToggle heightIncludingBorder)].
methodCategoryListView := v scrolledView.
v := ScrollableView for:SelectionInListView in:hpanel.
v origin:(0.5 @ 0.0) corner:(1.0 @ 1.0).
methodListView := v scrolledView.
"/ self setupActions.
self createCodeViewIn:vpanel.
self switchToClass:aClass.
actualClass := aClass.
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 setupActions.
self createCodeViewIn:vpanel.
currentClassCategory := aClass category.
self switchToClass:aClass.
actualClass := aClass.
currentMethodCategory := aMethodCategory.
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.
currentMethod := currentClass compiledMethodAt:selector.
currentMethodCategory := currentMethod category.
self updateCodeView
!
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 setupActions.
self createCodeViewIn:vpanel.
self updateCodeView
! !
!SystemBrowser methodsFor:'realization'!
realize
|v|
super realize.
v := classCategoryListView.
v notNil ifTrue:[
v action:[:lineNr | self classCategorySelection:lineNr].
v selectConditionBlock:[self checkSelectionChangeAllowed].
v ignoreReselect:false.
v contents:(self listOfAllClassCategories).
self initializeClassCategoryMenu
].
v := classListView.
v notNil ifTrue:[
v action:[:lineNr | self classSelection:lineNr].
v selectConditionBlock:[self checkSelectionChangeAllowed].
v ignoreReselect:false.
self initializeClassMenu
].
v := methodCategoryListView.
v notNil ifTrue:[
v action:[:lineNr | self methodCategorySelection:lineNr].
v selectConditionBlock:[self checkSelectionChangeAllowed].
v ignoreReselect:false.
self initializeMethodCategoryMenu
].
v := methodListView.
v notNil ifTrue:[
v action:[:lineNr | self methodSelection:lineNr].
v selectConditionBlock:[self checkSelectionChangeAllowed].
v ignoreReselect:false.
self initializeMethodMenu
].
v := classMethodListView.
v notNil ifTrue:[
v action:[:lineNr | self listSelection:lineNr].
v selectConditionBlock:[self checkSelectionChangeAllowed].
v ignoreReselect:false.
self initializeClassMethodMenu
]
! !
!SystemBrowser methodsFor:'private'!
checkSelectionChangeAllowed
"return true, if selection change is ok;
its not ok, if code has been changed.
in this case, return the result of a user query"
|box|
codeView modified ifFalse:[
^ true
].
box := questBox.
box isNil ifTrue:[
box := questBox := YesNoBox title:''
].
box title:(resources at:'contents in codeview has not been accepted.\\Modifications will be lost when continuing.') withCRs.
box okText:(resources at:'continue').
box noText:(resources at:'abort').
box yesAction:[^ true] noAction:[^ false].
box showAtPointer
!
switchToClass:newClass
currentClass notNil ifTrue:[
currentClass removeDependent:self
].
currentClass := newClass.
currentClass notNil ifTrue:[
currentClass addDependent:self
]
!
showExplanation:someText
"show explanation from Parser"
self notify:someText
!
setSearchPattern:aString
codeView setSearchPattern:aString
!
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
] 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
!
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
!
listBoxTitle:title okText:okText list:aList
"convenient method: setup a listBox"
|box|
box := selectBox.
box isNil ifTrue:[
box := selectBox := ListSelectionBox
title:''
okText:(resources string:'ok')
abortText:(resources string:'abort')
action:[:aString | ]
].
box title:(resources string:title).
box list:aList.
!
enterBoxTitle:title okText:okText
"convenient method: setup enterBox"
|box|
box := enterBox.
box isNil ifTrue:[
box := enterBox := EnterBox new
].
box title:(resources string:title) okText:(resources string:okText).
box initialText:''
!
enterBoxForSearchSelectorTitle:title
"convenient method: setup enterBox with text from codeView or selected
method for browsing based on a selector"
self enterBoxTitle:title okText:'search'.
enterBox initialText:(self selectorToSearchFor)
!
enterBoxForBrowseSelectorTitle:title
"convenient method: setup enterBox with text from codeView or selected
method for browsing based on a selector"
self enterBoxTitle:title okText:'browse'.
enterBox initialText:(self selectorToSearchFor)
!
enterBoxForBrowseTitle:title
"convenient method: setup enterBox with text from codeView or selected
method for method browsing based on className/variable"
self enterBoxTitle:title okText:'browse'.
enterBox initialText:(self stringToSearchFor)
!
enterBoxForCodeSelectionTitle:title okText:okText
"convenient method: setup enterBox with text from codeview"
|sel|
self enterBoxTitle:(resources string:title) okText:(resources string:okText).
sel := codeView selection.
sel notNil ifTrue:[
enterBox initialText:(sel asString withoutSeparators)
] ifFalse:[
enterBox initialText:nil
]
!
enterBoxForMethodCategory:title
"convenient method: setup enterBox with initial being current method category"
|sel|
self enterBoxTitle:title okText:'browse'.
sel := codeView selection.
sel isNil ifTrue:[
currentMethodCategory notNil ifTrue:[
sel := currentMethodCategory
]
].
sel notNil ifTrue:[
enterBox initialText:(sel asString withoutSpaces)
]
!
newClassCategory:aString
|categories|
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
]
!
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
!
listOfClassHierarchyOf:aClass
"return a hierarchy class-list"
^ (aClass allSuperclasses reverse ,
(Array with:aClass),
aClass allSubclassesInOrder) collect:[:c | c name]
"
|newList theClass|
theClass := aClass.
newList := Text with:theClass name.
[theClass ~~ Object] whileTrue:[
theClass := theClass superclass.
newList add:theClass name
].
newList reverse.
^ newList
"
!
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
!
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
]
]
!
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
!
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 asText
] ifFalse:[
(aCategory = '* no category *') ifTrue:[
searchCategory := nil
] ifFalse:[
searchCategory := aCategory
].
newList := Text new.
aClass methodArray do:[:aMethod |
(aMethod category = searchCategory) ifTrue:[
selector := aClass selectorForMethod:aMethod.
selector notNil ifTrue:[
aMethod isWrapped ifTrue:[
selector := selector , ' !!'
].
(newList includes:selector) ifFalse:[
newList add:selector
]
]
]
]
].
(newList size == 0) ifTrue:[^ nil].
^ newList sort
!
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 , ''''.
^ aString
!
template
"return a method definition template"
^
'message selector and argument names
"comment stating purpose of message"
|temporaries|
statements
'
!
compileCode:someCode
(ReadStream on:someCode) fileIn
! !
!SystemBrowser methodsFor:'user interaction'!
instanceProtocol
showInstance ifFalse:[
self checkSelectionChangeAllowed ifTrue:[
classToggle turnOff.
instanceToggle turnOn.
showInstance := true.
currentClass notNil ifTrue:[
self classSelectionChanged
].
codeView modified:false.
] ifFalse:[
instanceToggle turnOff.
classToggle turnOn
]
]
!
classProtocol
showInstance ifTrue:[
self checkSelectionChangeAllowed ifTrue:[
instanceToggle turnOff.
classToggle turnOn.
showInstance := false.
currentClass notNil ifTrue:[
self classSelectionChanged
].
codeView modified:false.
] ifFalse:[
instanceToggle turnOn.
classToggle turnOff
]
]
!
updateClassCategoryListWithScroll:scroll
|oldClassCategory oldClass oldMethodCategory oldMethod
oldSelector newCategoryList|
classMethodListView notNil ifTrue:[ ^ self ].
oldClassCategory := currentClassCategory.
oldClass := currentClass.
oldMethodCategory := currentMethodCategory.
oldMethod := currentMethod.
oldMethod notNil ifTrue:[
oldSelector := methodListView selectionValue
].
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
!
updateClassListWithScroll:scroll
|classes oldClassName|
classListView notNil ifTrue:[
currentClass notNil 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
].
]
]
!
updateClassList
self updateClassListWithScroll:true
!
updateMethodCategoryListWithScroll:scroll
|categories|
methodCategoryListView notNil ifTrue:[
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
]
]
]
!
updateMethodCategoryList
self updateMethodCategoryListWithScroll:true
!
updateMethodListWithScroll:scroll
|selectors scr first last|
methodListView notNil ifTrue:[
currentMethodCategory notNil ifTrue:[
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
]
].
]
!
updateMethodList
self updateMethodListWithScroll:true
!
updateCodeView
|code aStream|
fullClass ifTrue:[
currentClass notNil ifTrue:[
" this is too slow for big classes ...
code := String new:1000.
aStream := WriteStream on:code.
currentClass fileOutOn:aStream
"
aStream := FileStream newFileNamed:'__temp'.
aStream isNil ifTrue:[
self notify:'cannot create temporary file.'.
codeView contents:nil.
codeView modified:false.
^ self
].
currentClass fileOutOn:aStream.
aStream close.
aStream := FileStream oldFileNamed:'__temp'.
aStream isNil ifTrue:[
self notify:'oops - cannot reopen temp file'.
codeView contents:nil.
codeView modified:false.
^ self
].
code := aStream contents.
aStream close.
OperatingSystem removeFile:'__temp'
]
] ifFalse:[
currentMethod notNil ifTrue:[
code := currentMethod source
]
].
codeView contents:code.
codeView modified:false
!
classSelectionChanged
|oldMethodCategory oldMethod|
self withWaitCursorDo:[
oldMethodCategory := currentMethodCategory.
oldMethod := currentMethod.
showInstance ifTrue:[
actualClass := currentClass
] ifFalse:[
actualClass := currentClass class
].
currentMethodCategory := nil.
currentMethod := nil.
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.
].
codeView explainAction:nil
] 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
]
]
!
classCategorySelectionChanged
"class category has changed - update dependant views"
self withWaitCursorDo:[
self switchToClass:nil.
actualClass := nil.
currentMethodCategory := nil.
currentMethod := 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))
]
]
!
classSelection:lineNr
"user clicked on a class line - show method categories"
|classSymbol cls|
classSymbol := classListView selectionValue withoutSpaces asSymbol.
(Smalltalk includesKey:classSymbol) ifTrue:[
cls := Smalltalk at:classSymbol
].
cls notNil ifTrue:[
self switchToClass:cls.
self classSelectionChanged
]
!
methodCategorySelectionChanged
"method category selection has changed - update dependant views"
self withWaitCursorDo:[
currentMethod := nil.
self updateMethodList.
self updateCodeView.
currentMethodCategory notNil ifTrue:[
methodCategoryListView selectElement:currentMethodCategory
].
codeView acceptAction:[:theCode |
codeView cursor:Cursor execute.
Object abortSignal catch:[
actualClass compiler compile:theCode asString
forClass:actualClass
inCategory:currentMethodCategory
notifying:codeView.
codeView modified:false.
self updateMethodListWithScroll:false.
].
codeView cursor:Cursor normal.
].
codeView explainAction:[:theCode :theSelection |
self showExplanation:(Explainer explain:theSelection
in:theCode
forClass:actualClass)
]
]
!
methodCategorySelection:lineNr
"user clicked on a method category line - show selectors"
currentClass isNil ifTrue:[^ self].
currentMethodCategory := methodCategoryListView selectionValue.
self methodCategorySelectionChanged
!
methodSelectionChanged
"method selection has changed - update dependant views"
self withWaitCursorDo:[
self updateCodeView.
codeView acceptAction:[:theCode |
codeView cursor:Cursor execute.
Object abortSignal catch:[
actualClass compiler compile:theCode asString
forClass:actualClass
inCategory:currentMethodCategory
notifying:codeView.
codeView modified:false.
self updateMethodListWithScroll:false.
].
codeView cursor:Cursor normal.
].
codeView explainAction:[:theCode :theSelection |
self showExplanation:(Explainer explain:theSelection
in:theCode
forClass:actualClass)
].
methodListView notNil ifTrue:[
(currentMethod notNil and:[currentMethod isWrapped]) ifTrue:[
self initializeMethodMenu2
] ifFalse:[
self initializeMethodMenu
]
]
]
!
methodSelection:lineNr
"user clicked on a method line - show code"
|selectorString selectorSymbol|
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.
currentMethod := actualClass compiledMethodAt:selectorSymbol.
methodCategoryListView notNil ifTrue:[
currentMethod notNil ifTrue:[
(currentMethodCategory = currentMethod category) ifFalse:[
currentMethodCategory := currentMethod category.
methodCategoryListView selectElement:currentMethodCategory
]
]
].
self methodSelectionChanged
!
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)
!
listSelection: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.
currentMethod := actualClass compiledMethodAt:(selectorString asSymbol).
currentMethodCategory := currentMethod category.
self methodSelectionChanged
]
! !
!SystemBrowser methodsFor:'class category menu'!
initializeClassCategoryMenu
|labels|
labels := resources array:#(
'fileOut'
'fileOut each'
"
'fileOut binary'
"
'printOut'
'printOut protocol'
'-'
'spawn'
'spawn class'
'-'
'update'
'find class ...'
'-'
'new class category ...'
'rename ...'
'remove').
classCategoryListView
middleButtonMenu:(PopUpMenu
labels:labels
selectors:#(classCategoryFileOut
classCategoryFileOutEach
"
classCategoryBinaryFileOut
"
classCategoryPrintOut
classCategoryPrintOutProtocol
nil
classCategorySpawn
classCategorySpawnFullClass
nil
classCategoryUpdate
classCategoryFindClass
nil
classCategoryNewCategory
classCategoryRename
classCategoryRemove)
receiver:self
for:classCategoryListView)
!
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 allClassesDo:[: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 allClassesDo:[:aClass |
aClass isMeta ifFalse:[
(aClass category = currentClassCategory) ifTrue:[
aBlock value:aClass
]
]
].
]
!
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
]
!
classCategoryFileOut
"create a file 'categoryName' consisting of all classes in current category"
|aStream fileName project|
currentClassCategory isNil ifTrue:[
^ self warn:'select a class category first'.
].
fileName := currentClassCategory asString.
fileName replaceAll:Character space by:$_.
Project notNil ifTrue:[
project := Project current.
project notNil ifTrue:[
fileName := project directory , Filename separator asString , fileName.
].
].
aStream := FileStream newFileNamed:fileName.
aStream isNil ifTrue:[
^ self warn:(resources string:'cannot create: %1' with:fileName)
].
self withWaitCursorDo:[
self label:('System Browser writing: ' , fileName).
self allClassesInCurrentCategoryInOrderDo:[:aClass |
aClass fileOutOn:aStream.
].
aStream close.
self label:'System Browser'.
]
!
classCategoryFileOutEach
self withWaitCursorDo:[
self allClassesInCurrentCategoryDo:[:aClass |
self label:('System Browser saving: ' , aClass name).
aClass fileOut
].
self label:'System Browser'.
]
!
classCategoryBinaryFileOut
self withWaitCursorDo:[
self allClassesInCurrentCategoryInOrderDo:[:aClass |
aClass binaryFileOut
]
]
!
classCategorySpawn
"create a new SystemBrowser browsing current classCategory"
currentClassCategory notNil ifTrue:[
self withWaitCursorDo:[
self class browseClassCategory:currentClassCategory
]
]
!
classCategorySpawnFullClass
"create a new SystemBrowser browsing full class"
|newBrowser|
self withWaitCursorDo:[
newBrowser := self class browseFullClasses
"
.
currentClass notNil ifTrue:[
newBrowser switchToClassNamed:(currentClass name)
]
"
]
!
classCategoryNewCategory
self enterBoxTitle:'name of new class category:' okText:'create'.
enterBox action:[:aString | self newClassCategory:aString].
enterBox showAtPointer
!
switchToClassNamed:aString
|classSymbol theClass|
classSymbol := aString asSymbol.
theClass := Smalltalk at:classSymbol.
theClass isBehavior ifTrue:[
classCategoryListView notNil ifTrue:[
currentClassHierarchy isNil ifTrue:[
(theClass category ~~ currentClassCategory) ifTrue:[
currentClassCategory := theClass category.
currentClassCategory isNil ifTrue:[
classCategoryListView selectElement:'* no category *'
] ifFalse:[
classCategoryListView selectElement:currentClassCategory
].
self classCategorySelectionChanged
]
]
].
self switchToClass:theClass.
classListView selectElement:aString.
self classSelectionChanged
]
!
switchToClassNameMatching:aMatchString
|classNames thisName|
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)
].
self listBoxTitle:'select class to switch to:'
okText:'ok'
list:classNames sort.
selectBox action:[:aString | self switchToClassNamed:aString].
selectBox showAtPointer
!
classCategoryFindClass
self enterBoxForCodeSelectionTitle:'class to find:' okText:'find'.
enterBox action:[:aString | self switchToClassNameMatching:aString].
enterBox showAtPointer
!
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
]
]
!
classCategoryRename
"launch an enterBox to rename current class category"
currentClassCategory isNil ifTrue:[
^ self warn:'select a class category first'.
].
self enterBoxTitle:'rename class category to:' okText:'rename'.
enterBox initialText:currentClassCategory.
enterBox action:[:aString | self renameCurrentClassCategoryTo:aString].
enterBox showAtPointer
!
classCategoryRemove
"remove all classes in current category"
|count t classesToRemove subclassesRemoved|
currentClassCategory isNil ifTrue:[
^ self warn:'select a class category first'.
].
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.
questBox isNil ifTrue:[questBox := YesNoBox title:''].
questBox title:t.
questBox yesAction:[self doRemoveClasses:classesToRemove and:subclassesRemoved].
questBox okText:(resources at:'remove').
questBox noText:(resources at:'abort').
questBox showAtPointer
!
doRemoveClasses:classList and:subclassList
"after querying user - do really remove classes in list1 and list2"
subclassList do:[:aClass |
Smalltalk removeClass:aClass
].
classList do:[:aClass |
Smalltalk removeClass:aClass
].
currentClassCategory := nil.
self switchToClass:nil.
Smalltalk changed
! !
!SystemBrowser methodsFor:'class menu'!
initializeClassMenu
|labels menu|
labels := resources array:#(
'fileOut'
"
'fileOut binary'
"
'printOut'
'printOut protocol'
" 'printOut full protocol' "
'-'
'spawn'
'spawn hierarchy'
'spawn subclasses'
'-'
'hierarchy'
'definition'
'comment'
'class instvars'
" 'protocols' "
'-'
'variable search'
'-'
'new class'
'new subclass'
'rename ...'
'remove').
menu := PopUpMenu labels:labels
selectors:#(classFileOut
"
classBinaryFileOut
"
classPrintOut
classPrintOutProtocol
" classPrintOutFullProtocol "
nil
classSpawn
classSpawnHierarchy
classSpawnSubclasses
nil
classHierarchy
classDefinition
classComment
classClassInstVars
" classProtocols "
nil
"
classInstVarRefs
classClassVarRefs
classAllInstVarRefs
classAllClassVarRefs
nil
classInstVarMods
classClassVarMods
classAllInstVarMods
classAllClassVarMods
"
variables
nil
classNewClass
classNewSubclass
classRename
classRemove)
receiver:self
for:classListView.
classListView middleButtonMenu:menu.
menu subMenuAt:#variables
put:(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:#(
classInstVarRefs
classClassVarRefs
classAllInstVarRefs
classAllClassVarRefs
nil
classInstVarMods
classClassVarMods
classAllInstVarMods
classAllClassVarMods
)
receiver:self
for:self
).
!
doClassMenu:aBlock
"a helper - check if class is selected and evaluate aBlock
while showing waitCursor"
currentClass isNil ifTrue:[
^ self warn:'select a class first'.
].
self withWaitCursorDo:aBlock
!
doClassMenuWithSelection:aBlock
"a helper - if there is a selection, which represents a classes name,
evaluate aBlock, passing that class as argument.
Otherwise, check if a class is selected and evaluate aBlock with the
current class. Otherwise report an error."
|clsName cls isMeta w|
clsName := codeView selection.
clsName notNil ifTrue:[
clsName := clsName asString withoutSeparators.
(clsName endsWith:'class') ifTrue:[
isMeta := true.
clsName := clsName copyTo:(clsName size - 5)
] ifFalse:[
isMeta := false
].
clsName knownAsSymbol ifTrue:[
(Smalltalk includesKey:clsName asSymbol) ifTrue:[
cls := Smalltalk at:clsName asSymbol.
cls isBehavior ifTrue:[
isMeta ifTrue:[
cls := cls class
].
self withWaitCursorDo:[
aBlock value:cls.
].
^ self
] ifFalse:[
w := clsName , ' is not a class'
]
] ifFalse:[
w := clsName , ' is unknown'
].
self warn:w.
^ self
].
].
currentClass isNil ifTrue:[
^ self warn:'select a class first'.
].
self withWaitCursorDo:[aBlock value:currentClass]
!
classSpawn
"create a new SystemBrowser browsing current class,
or if there is a selection, spawn a browser on the selected name."
|browser|
self doClassMenuWithSelection:[:cls |
cls isMeta ifTrue:[
Smalltalk allClassesDo:[:aClass |
aClass class == cls ifTrue:[
browser := self class browseClass:aClass.
browser classProtocol.
^ self
].
].
self warn:'oops, no class for this metaclass'.
^ self
].
self class browseClass:cls
]
!
classSpawnHierarchy
"create a new HierarchyBrowser browsing current class"
self doClassMenuWithSelection:[:cls |
self class browseClassHierarchy:cls
]
!
classSpawnSubclasses
"create a new browser browsing current class's subclasses"
|subs|
self doClassMenuWithSelection:[:cls |
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
]
!
classBinaryFileOut
self doClassMenu:[
currentClass binaryFileOut
]
!
classFileOut
self doClassMenu:[
self label:('System Browser saving: ' , currentClass name).
currentClass fileOut.
self label:'System Browser'
]
!
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
]
]
!
classDefinition
"show class definition in codeView and setup accept-action for
class-definition change"
|aStream|
self doClassMenu:[
aStream := WriteStream on:(String new:200).
currentClass fileOutDefinitionOn:aStream.
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
]
]
!
classClassInstVars
"show class instance variables in codeView and setup accept-action
for 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
]
]
!
classProtocols
^ self
!
classComment
"show the classes comment in the codeView"
self doClassMenu:[
codeView contents:(currentClass comment).
codeView modified:false.
codeView acceptAction:[:theCode |
Object abortSignal catch:[
currentClass comment:theCode asString.
codeView modified:false.
]
].
codeView explainAction:nil.
methodListView notNil ifTrue:[
methodListView deselect
]
]
!
classInstVarRefsOrModsTitle:title mods:mods
"show an enterbox for instvar to search for"
self doClassMenu:[
self enterBoxForCodeSelectionTitle:title okText:'browse'.
enterBox action:[:aString |
self withWaitCursorDo:[
self class browseInstRefsTo:aString
in:(Array with:currentClass)
modificationsOnly:mods
]
].
enterBox showAtPointer
]
!
classInstVarRefs
"show an enterbox for instVar to search for"
self classInstVarRefsOrModsTitle:'instance variable to browse references to:'
mods:false
!
classInstVarMods
"show an enterbox for instVar to search for"
self classInstVarRefsOrModsTitle:'instance variable to browse modifications of:'
mods:true
!
classClassVarRefsOrModsTitle:title mods:mods
"show an enterbox for classVar to search for"
self doClassMenu:[
self enterBoxForCodeSelectionTitle:title okText:'browse'.
enterBox action:[:aString |
self withWaitCursorDo:[
self class browseClassRefsTo:aString
in:(Array with:currentClass)
modificationsOnly:mods
]
].
enterBox showAtPointer
]
!
classClassVarMods
"show an enterbox for classVar to search for"
self classClassVarRefsOrModsTitle:'class variable to browse modifications of:'
mods:true
!
classClassVarRefs
"show an enterbox for classVar to search for"
self classClassVarRefsOrModsTitle:'class variable to browse references to:'
mods:false
!
classAllClassOrInstVarRefsTitle:title access:access
"show an enterbox for instVar to search for"
self doClassMenu:[
self enterBoxForCodeSelectionTitle:title okText:'browse'.
enterBox action:[:aVariableName |
self withWaitCursorDo:[
|homeClass|
homeClass := self findClassOfVariable:aVariableName
accessWith:access.
(self class) browseInstRefsTo:aVariableName
under:homeClass
modificationsOnly:false
]
].
enterBox showAtPointer
]
!
classAllInstVarRefs
"show an enterbox for instVar to search for"
self classAllClassOrInstVarRefsTitle:'instance variable to browse references to:'
access:#instVarNames
!
classAllClassVarRefs
"show an enterbox for classVar to search for"
self classAllClassOrInstVarRefsTitle:'class variable to browse references to:'
access:#classVarNames
!
classAllInstOrClassVarModsTitle:title access:access
"show an enterbox for instVar to search for"
self doClassMenu:[
self enterBoxForCodeSelectionTitle:title okText:'browse'.
enterBox action:[:aVariableName |
self withWaitCursorDo:[
|homeClass|
homeClass := self findClassOfVariable:aVariableName
accessWith:access.
(self class) browseInstRefsTo:aVariableName
under:homeClass
modificationsOnly:true
]
].
enterBox showAtPointer
]
!
classAllInstVarMods
"show an enterbox for instVar to search for"
self classAllInstOrClassVarModsTitle:'instance variable to browse modifications of:'
access:#instVarNames.
!
classAllClassVarMods
"show an enterbox for classVar to search for"
self classAllInstOrClassVarModsTitle:'class variable to browse modifications of:'
access:#classVarNames.
!
classClassDefinitionTemplateFor:name in:cat
"common helper for newClass and newSubclass
- show a template to define class name in category cat"
currentMethodCategory := nil.
currentMethod := 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:[
|cl|
cl := (Compiler evaluate:theCode asString notifying:codeView).
cl isBehavior ifTrue:[
codeView modified:false.
self classCategoryUpdate.
self updateClassListWithScroll:false.
self switchToClassNamed:(cl name)
]
].
codeView cursor:(Cursor normal).
].
codeView explainAction:nil.
self switchToClass:nil
!
classNewClass
"create a class-definition prototype in codeview"
|nm|
currentClass notNil ifTrue:[
nm := currentClass superclass name
] ifFalse:[
nm := 'Object'
].
self classClassDefinitionTemplateFor:nm in:currentClassCategory
!
classNewSubclass
"create a subclass-definition prototype in codeview"
currentClass isNil ifTrue:[
^ self warn:'select a class first'.
].
self classClassDefinitionTemplateFor:(currentClass name)
in:(currentClass category)
!
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
]
]
!
classRename
"launch an enterBox for new name and query user"
currentClass isNil ifTrue:[
^ self warn:'select a class first'.
].
self enterBoxTitle:(resources string:'rename %1 to:' with:currentClass name) okText:'rename'.
enterBox initialText:(currentClass name).
enterBox action:[:aString | self renameCurrentClassTo:aString].
enterBox showAtPointer
!
doRemoveCurrentClass
"after querying user - do really remove current class
and all subclasses"
self doClassMenu:[
currentClass allSubclassesDo:[:aSubClass |
Smalltalk removeClass:aSubClass
].
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
]
!
classRemove
"user requested remove of current class and all subclasses -
count subclasses and let user confirm removal."
|count t|
currentClass notNil ifTrue:[
count := 0.
currentClass allSubclassesDo:[:aSubClass |
count := count + 1
].
t := 'remove ' , currentClass name.
count ~~ 0 ifTrue:[
t := t , '\(with ' , count printString.
count == 1 ifTrue:[
t := t , ' subclass'
] ifFalse:[
t := t , ' subclasses'
].
t := (t , ')') withCRs
].
questBox isNil ifTrue:[questBox := YesNoBox title:''].
questBox title:t.
questBox yesAction:[self doRemoveCurrentClass].
questBox okText:(resources at:'remove').
questBox noText:(resources at:'abort').
questBox showAtPointer
]
! !
!SystemBrowser methodsFor:'method category menu'!
initializeMethodCategoryMenu
|labels|
labels := resources array:#(
'fileOut'
'fileOut all'
'printOut'
'-'
'spawn'
'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)
!
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.
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
]
]
!
copyMethodsFromClass:aClassName
|class|
currentClass notNil ifTrue:[
Symbol hasInterned:aClassName ifTrue:[:sym |
(Smalltalk includesKey:sym) ifTrue:[
class := Smalltalk at:sym
].
].
class isBehavior ifFalse:[
self warn:(resources string:'no class named %1' with:aClassName).
^ self
].
showInstance ifFalse:[
class := class class
].
"show enterbox for category to copy from"
self enterBoxTitle:'name of category to copy from (matchpattern allowed, * for all):'
okText:'copy'.
enterBox action:[:aString | self copyMethodsFromClass:class category:aString].
enterBox showAtPointer
]
!
copyMethodsFromClass:class category:category
|source|
currentClass notNil ifTrue:[
codeView abortAction:[^ self].
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.
]
]
]
!
methodCategoryFindMethod
self enterBoxForSearchSelectorTitle:'method selector to search for:'.
enterBox action:[:aString | self switchToMethodNamed:aString].
enterBox showAtPointer
!
methodCategoryFindAnyMethod
self enterBoxForSearchSelectorTitle:'method selector to search for:'.
enterBox action:[:aString | self switchToAnyMethodNamed:aString].
enterBox showAtPointer
!
methodCategoryPrintOut
|printStream|
currentClass isNil ifTrue:[
^ self warn:'select a class first'.
].
currentMethodCategory isNil ifTrue:[
^ self warn:'select a method category first'.
].
currentMethodCategory notNil ifTrue:[
self withWaitCursorDo:[
printStream := Printer new.
actualClass printOutCategory:currentMethodCategory on:printStream.
printStream close
]
]
!
methodCategoryFileOut
"fileOut all methods in the selected methodcategory of
the current class"
currentClass isNil ifTrue:[
^ self warn:'select a class first'.
].
currentMethodCategory isNil ifTrue:[
^ self warn:'select a method category first'.
].
currentMethodCategory notNil ifTrue:[
self withWaitCursorDo:[
self label:('System Browser saving: ' , currentClass name , '-' , currentMethodCategory).
actualClass fileOutCategory:currentMethodCategory.
self label:'System Browser'.
]
]
!
methodCategoryFileOutAll
"fileOut all methods in the selected methodcategory of
the current class"
|fileName project outStream hasMethodsInThisCategory|
currentMethodCategory isNil ifTrue:[
^ self warn:'select a method category first'.
].
fileName := currentMethodCategory , '.st'.
fileName replaceAll:Character space by:$_.
Project notNil ifTrue:[
project := Project current.
project notNil ifTrue:[
fileName := project directory , Filename separator asString , fileName.
].
].
outStream := FileStream newFileNamed:fileName.
outStream isNil ifTrue:[
^ self warn:(resources string:'cannot create: %1' with:fileName)
].
self withWaitCursorDo:[
self label:('System Browser saving: ' , currentMethodCategory).
Smalltalk allClassesDo:[:class |
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 label:'System Browser'.
].
!
methodCategorySpawn
"create a new SystemBrowser browsing current method category"
currentMethodCategory notNil ifTrue:[
self withWaitCursorDo:[
self class browseClass:actualClass
methodCategory:currentMethodCategory
]
]
!
methodCategorySpawnCategory
"create a new SystemBrowser browsing all methods from all
classes with same category as current method category"
self enterBoxForMethodCategory:'category to browse methods:'.
enterBox action:[:aString | self withWaitCursorDo:[
self class browseMethodCategory:aString
]
].
enterBox showAtPointer
!
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
!
methodCategoryNewCategory
"show the enter box to add a new method category"
|someCategories existingCategories|
"a tiny little goody here ..."
showInstance ifTrue:[
someCategories := #('accessing'
'initialization'
'private'
'printing & storing'
'queries'
'testing'
)
] ifFalse:[
someCategories := #(
'documentation'
'initialization'
'instance creation'
).
].
existingCategories := methodCategoryListView list.
existingCategories notNil ifTrue:[
someCategories := someCategories select:[:cat | (existingCategories includes:cat) not].
].
self listBoxTitle:(resources at:'name of new method category:')
okText:(resources at:'create')
list:someCategories.
selectBox action:[:aString | self newMethodCategory:aString].
selectBox showAtPointer
!
methodCategoryCreateAccessMethods
"create access methods for all instvars"
|source|
currentClass isNil ifTrue:[^ self].
showInstance ifFalse:[
self warn:(resources string:'select instance - and try again').
^ self.
].
self withWaitCursorDo:[
currentClass instVarNames 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|
showInstance ifTrue:[
title := 'class to copy instance method category from:'
] ifFalse:[
title := 'class to copy class method category from:'
].
self listBoxTitle:title
okText:'ok'
list:(Smalltalk allClasses collect:[:cls | cls name]) asArray sort.
selectBox action:[:aString | self copyMethodsFromClass:aString].
selectBox showAtPointer
!
renameCurrentMethodCategoryTo:aString
"helper - do the rename"
currentMethodCategory notNil ifTrue:[
actualClass renameCategory:currentMethodCategory to:aString.
"/ actualClass methodArray do:[:aMethod |
"/ aMethod category = currentMethodCategory ifTrue:[
"/ aMethod category:aString
"/ ]
"/ ].
currentMethodCategory := aString.
currentMethod := nil.
self updateMethodCategoryList.
self updateMethodListWithScroll:false
]
!
methodCategoryRename
"launch an enterBox to rename current method category"
currentMethodCategory isNil ifTrue:[
^ self warn:'select a method category first'.
].
self enterBoxTitle:(resources string:'rename method category %1 to:' with:currentMethodCategory)
okText:(resources at:'rename').
enterBox initialText:currentMethodCategory.
enterBox action:[:aString | self renameCurrentMethodCategoryTo:aString].
enterBox showAtPointer
!
doMethodCategoryRemove
"actually remove all methods from current method category"
currentMethodCategory notNil ifTrue:[
actualClass methodArray do:[:aMethod |
(aMethod category = currentMethodCategory) ifTrue:[
actualClass
removeSelector:(actualClass selectorForMethod:aMethod)
]
].
currentMethodCategory := nil.
currentMethod := nil.
self updateMethodCategoryList.
self updateMethodList
]
!
methodCategoryRemove
"show number of methods to remove and query user"
|count t|
currentMethodCategory notNil ifTrue:[
count := 0.
actualClass methodArray do:[:aMethod |
(aMethod category = currentMethodCategory) ifTrue:[
count := count + 1
]
].
(count == 0) ifTrue:[
currentMethodCategory := nil.
currentMethod := 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.
questBox isNil ifTrue:[questBox := YesNoBox title:''].
questBox title:t.
questBox yesAction:[self doMethodCategoryRemove].
questBox okText:(resources at:'remove').
questBox noText:(resources at:'abort').
questBox showAtPointer
]
]
! !
!SystemBrowser methodsFor:'method menu'!
initializeMethodMenu
|labels|
labels := resources array:#(
'fileOut'
'printOut'
'-'
'spawn'
'-'
'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)
!
initializeMethodMenu2
|labels|
methodListView isNil ifTrue:[^ self].
labels := resources array:#(
'fileOut'
'printOut'
'-'
'spawn'
'-'
'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)
!
methodPrintOut
"print out the current method"
|printStream|
currentMethod isNil ifTrue:[
^ self warn:'select a method first'.
].
printStream := Printer new.
actualClass printOutSource:currentMethod source on:printStream.
printStream close
!
methodFileOut
"file out the current method"
currentMethod isNil ifTrue:[
^ self warn:'select a method first'.
].
self label:'System Browser saving'.
actualClass fileOutMethod:currentMethod.
self label:'System Browser'.
!
methodImplementors
"launch an enterBox for selector to search for"
self enterBoxForBrowseSelectorTitle:'selector to browse implementors of:'.
enterBox action:[:aString | self withWaitCursorDo:[
self class browseImplementorsOf:aString
]
].
enterBox showAtPointer
!
methodLocalImplementors
"launch an enterBox for selector to search for"
currentClass isNil ifTrue:[
^ self warn:'select a class first'.
].
self enterBoxForBrowseSelectorTitle:'selector to browse local implementors of:'.
enterBox action:[:aString | self withWaitCursorDo:[
self class browseImplementorsOf:aString under:currentClass
]
].
enterBox showAtPointer
!
methodSenders
"launch an enterBox for selector to search for"
self enterBoxForBrowseSelectorTitle:'selector to browse senders of:'.
enterBox action:[:aString | self withWaitCursorDo:[
self class browseAllCallsOn:aString
]
].
enterBox showAtPointer
!
methodLocalSenders
"launch an enterBox for selector to search for in current class & subclasses"
currentClass isNil ifTrue:[
^ self warn:'select a class first'.
].
self enterBoxForBrowseSelectorTitle:'selector to browse local senderss of:'.
enterBox action:[:aString | self withWaitCursorDo:[
self class browseCallsOn:aString under:currentClass
]
].
enterBox showAtPointer
!
methodGlobalReferends
"launch an enterBox for global symbol to search for"
self enterBoxForBrowseTitle:'global variable to browse users of:'.
enterBox action:[:aString | self withWaitCursorDo:[
self class browseReferendsOf:aString asSymbol
]
].
enterBox showAtPointer
!
methodStringSearch
"launch an enterBox for (sub)-string to search for"
self enterBoxForBrowseSelectorTitle:'string / matchString to search for:'.
enterBox action:[:aString | self withWaitCursorDo:[
self class browseForString:aString
]
].
enterBox showAtPointer
!
methodLocalStringSearch
"launch an enterBox for (sub)-string to search for"
currentClass isNil ifTrue:[
^ self warn:'select a class first'.
].
self enterBoxForBrowseSelectorTitle:'string / matchString to search for locally:'.
enterBox action:[:aString | self withWaitCursorDo:[
self class browseForString:aString in:(currentClass withAllSubclasses)
]
].
enterBox showAtPointer
!
methodAproposSearch
"launch an enterBox for a keyword search"
self enterBoxForBrowseSelectorTitle:'keyword to search for:'.
enterBox action:[:aString | self withWaitCursorDo:[
self class aproposSearch:aString
]
].
enterBox showAtPointer
!
methodSpawn
"create a new SystemBrowser browsing current method,
or if the current selection is of the form 'class>>selector', spwan
a browser on that method."
|s sel clsName cls browseMeta w sep|
sel := codeView selection.
sel notNil ifTrue:[
sel := sel asString withoutSeparators.
('*>>*' match:sel) ifTrue:[
sep := $>
] ifFalse:[
('* *' match:sel) ifTrue:[
sep := Character space
]
].
sep notNil ifTrue:[
s := ReadStream on:sel.
clsName := s upTo:sep.
[s peek == sep] whileTrue:[s next].
sel := s upToEnd.
(clsName endsWith:'class') ifTrue:[
browseMeta := true.
clsName := clsName copyTo:(clsName size - 5)
] ifFalse:[
browseMeta := false
].
(clsName knownAsSymbol and:[sel knownAsSymbol]) ifTrue:[
(Smalltalk includesKey:clsName asSymbol) ifTrue:[
cls := Smalltalk at:clsName asSymbol.
browseMeta ifTrue:[
cls := cls class
].
cls isBehavior ifFalse:[
cls := cls class
].
cls isBehavior ifTrue:[
(cls implements:sel asSymbol) ifTrue:[
self withWaitCursorDo:[
self class browseClass:cls selector:sel asSymbol
].
^ self
] ifFalse:[
(cls class implements:sel asSymbol) ifTrue:[
self withWaitCursorDo:[
self class browseClass:cls class selector:sel asSymbol
].
^ self
] ifFalse:[
w := clsName , ' does not implement #' , sel
]
]
] ifFalse:[
w := clsName , ' is not a class'
]
] ifFalse:[
w := clsName , ' is unknown'
]
] ifFalse:[
w := clsName , ' and/or ' , sel , ' is unknown'
].
self warn:w.
^ self
].
].
currentMethod isNil ifTrue:[
^ self warn:'select a method first'.
].
self withWaitCursorDo:[
self class browseClass:actualClass
selector:(actualClass selectorForMethod:currentMethod)
]
!
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 := nil.
methodListView deselect.
codeView contents:(self template).
codeView modified:false.
codeView acceptAction:[:theCode |
codeView cursor:Cursor execute.
Object abortSignal catch:[
actualClass compiler compile:theCode asString
forClass:actualClass
inCategory:currentMethodCategory
notifying:codeView.
codeView modified:false.
self updateMethodListWithScroll:false.
].
codeView cursor:Cursor normal.
].
codeView explainAction:[:theCode :theSelection |
self showExplanation:(Explainer explain:theSelection
in:theCode
forClass:actualClass)
]
!
methodRemove
"remove the current method"
currentMethod isNil ifTrue:[
^ self warn:'select a method first'.
].
actualClass
removeSelector:(actualClass selectorForMethod:currentMethod).
self updateMethodListWithScroll:false
!
doChangeCategoryOfCurrentMethodTo:aString
"after querying user - do really change current methods category"
currentMethod isNil ifTrue:[
^ self warn:'select a method first'.
].
currentMethod category:aString asSymbol.
currentClass changed.
self updateMethodCategoryListWithScroll:false.
self updateMethodListWithScroll:false
!
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."
currentMethod isNil ifTrue:[
^ self warn:'select a method first'.
].
self enterBoxTitle:('change category from ' , currentMethod category , ' to:')
okText:'change'.
lastMethodCategory isNil ifTrue:[
enterBox initialText:(currentMethod category).
] ifFalse:[
enterBox initialText:lastMethodCategory
].
enterBox action:[:aString | lastMethodCategory := aString.
self doChangeCategoryOfCurrentMethodTo:aString
].
enterBox showAtPointer
!
methodRemoveBreakOrTrace
"turn off tracing of the current method"
|sel|
currentMethod notNil ifTrue:[
currentMethod isWrapped ifTrue:[
currentMethod := MessageTracer unwrapMethod:currentMethod.
sel := methodListView selection.
self updateMethodListWithScroll:false.
methodListView selection:sel.
self initializeMethodMenu
].
]
!
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
].
]
!
methodTrace
"turn on tracing of the current method"
|sel|
currentMethod notNil ifTrue:[
currentMethod isWrapped ifFalse:[
currentMethod := MessageTracer traceMethod:currentMethod.
self initializeMethodMenu2.
sel := methodListView selection.
self updateMethodListWithScroll:false.
methodListView selection:sel
].
]
!
methodTraceSender
"turn on tracing of the current method"
|sel|
currentMethod notNil ifTrue:[
currentMethod isWrapped ifFalse:[
currentMethod := MessageTracer traceMethodSender:currentMethod.
self initializeMethodMenu2.
sel := methodListView selection.
self updateMethodListWithScroll:false.
methodListView selection:sel
].
]
! !
!SystemBrowser methodsFor:'class-method menu'!
initializeClassMethodMenu
|labels|
labels := resources array:#(
'fileOut'
'printOut'
'-'
'spawn'
'-'
'sender ...'
'implementors ...'
'globals ...'
"/ '-'
"/ 'breakpoint'
"/ 'trace'
"/ 'trace sender'
).
classMethodListView
middleButtonMenu:(PopUpMenu
labels:labels
selectors:#(methodFileOut
methodPrintOut
nil
methodSpawn
nil
methodSenders
methodImplementors
methodGlobalReferends
"/ nil
"/ methodBreakPoint
"/ methodTrace
"/ methodTraceSender
)
receiver:self
for:classMethodListView)
! !
!SystemBrowser methodsFor:'dependencies'!
update
"handle changes from other browsers"
|oldClassCategory oldClassName oldMethodCategory oldMethod oldSelector|
self updateClassCategoryListWithScroll:false.
"
self updateClassListWithScroll:false.
"
^ self.
oldClassCategory := currentClassCategory.
currentClass notNil ifTrue:[
oldClassName := currentClass name
].
oldMethodCategory := currentMethodCategory.
oldMethod := currentMethod.
methodListView notNil ifTrue:[
oldMethod notNil ifTrue:[
oldSelector := methodListView selectionValue
]
].
classCategoryListView notNil ifTrue:[
classCategoryListView setContents:(self listOfAllClassCategories).
oldClassCategory notNil ifTrue:[
classCategoryListView selectElement:oldClassCategory
].
classCategoryListView selection isNil ifTrue:[
currentClassCategory := nil.
self switchToClass:nil.
oldClassName := nil
]
].
classListView notNil ifTrue:[
self updateClassListWithScroll:false.
oldClassName notNil ifTrue:[
classListView selectElement:oldClassName
].
classListView selection isNil ifTrue:[
self switchToClass:nil.
currentMethodCategory := nil.
oldMethodCategory := nil
]
].
methodCategoryListView notNil ifTrue:[
self updateMethodCategoryListWithScroll:false.
oldMethodCategory notNil ifTrue:[
methodCategoryListView selectElement:oldMethodCategory
].
methodCategoryListView selection isNil ifTrue:[
currentMethodCategory := nil.
currentMethod := nil.
oldSelector := nil
]
].
methodListView notNil ifTrue:[
self updateMethodListWithScroll:false.
oldSelector notNil ifTrue:[
methodListView selectElement:oldSelector
].
methodListView selection isNil ifTrue:[
currentMethod := nil
]
].
self updateCodeView
!
update:someObject
(someObject == Smalltalk) ifTrue:[self update. ^ self].
someObject isBehavior ifTrue:[
currentClass notNil ifTrue:[
someObject name = currentClass name ifTrue:[
currentClass := someObject.
showInstance ifTrue:[
actualClass := currentClass
] ifFalse:[
actualClass := currentClass class
].
self updateMethodCategoryListWithScroll:false.
"dont update codeView ...."
"self update"
^ self
]
]
]
! !